diff options
237 files changed, 9370 insertions, 6083 deletions
diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index bf3c420..a57a6cf 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -2,7 +2,7 @@ name: macOS on: [push] jobs: xcode: - runs-on: macos-11.0 + runs-on: macos-11 defaults: run: shell: bash @@ -24,7 +24,7 @@ jobs: ERROR_ON_FAILURES: 1 MAC_CI: 1 clang: - runs-on: macos-11.0 + runs-on: macos-11 strategy: matrix: cfgopt: diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index eaf9128..f2f6c1e 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -27,18 +27,18 @@ jobs: working-directory: unix - name: Package run: | - cp ../unix/tclsh tclsh${TCL_PATCHLEVEL}_unofficial - chmod +x tclsh${TCL_PATCHLEVEL}_unofficial - tar -cf tclsh${TCL_PATCHLEVEL}_unofficial.tar tclsh${TCL_PATCHLEVEL}_unofficial + cp ../unix/tclsh tclsh${TCL_PATCHLEVEL}_snapshot + chmod +x tclsh${TCL_PATCHLEVEL}_snapshot + tar -cf tclsh${TCL_PATCHLEVEL}_snapshot.tar tclsh${TCL_PATCHLEVEL}_snapshot working-directory: 1dist - name: Upload uses: actions/upload-artifact@v2 with: - name: Tclsh ${{ env.TCL_PATCHLEVEL }} Linux single-file build (unofficial) + name: Tclsh ${{ env.TCL_PATCHLEVEL }} Linux single-file build (snapshot) path: 1dist/*.tar macos: name: macOS - runs-on: macos-latest + runs-on: macos-11 defaults: run: shell: bash @@ -55,8 +55,12 @@ jobs: run: | mkdir 1dist touch generic/tclStubInit.c generic/tclOOStubInit.c || true + wget https://github.com/culler/macher/releases/download/v1.3/macher + sudo cp macher /usr/local/bin + sudo chmod a+x /usr/local/bin/macher echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV echo "CREATE_DMG=$(cd create-dmg;pwd)/create-dmg" >> $GITHUB_ENV + echo "CFLAGS=-arch x86_64 -arch arm64e" >> $GITHUB_ENV - name: Configure run: ./configure --disable-symbols --disable-shared --enable-zipfs working-directory: unix @@ -70,8 +74,8 @@ jobs: - name: Package run: | mkdir contents - cp $TCL_BIN contents/tclsh${TCL_PATCHLEVEL}_unofficial - chmod +x contents/tclsh${TCL_PATCHLEVEL}_unofficial + cp $TCL_BIN contents/tclsh${TCL_PATCHLEVEL}_snapshot + chmod +x contents/tclsh${TCL_PATCHLEVEL}_snapshot cat > contents/README.txt <<EOF This is a single-file executable developer preview of Tcl $TCL_PATCHLEVEL @@ -79,20 +83,20 @@ jobs: Use strictly at your own risk. To run it, you need to copy the executable out and run: - xattr -d com.apple.quarantine tclsh${TCL_PATCHLEVEL}_unofficial + xattr -d com.apple.quarantine tclsh${TCL_PATCHLEVEL}_snapshot to mark the executable as runnable on your machine. EOF $CREATE_DMG \ - --volname "Tcl $TCL_PATCHLEVEL (unofficial)" \ + --volname "Tcl $TCL_PATCHLEVEL (snapshot)" \ --window-pos 200 120 \ --window-size 800 400 \ - "Tcl-$TCL_PATCHLEVEL-(unofficial).dmg" \ + "Tcl-$TCL_PATCHLEVEL-(snapshot).dmg" \ "contents/" working-directory: 1dist - name: Upload uses: actions/upload-artifact@v2 with: - name: Tclsh ${{ env.TCL_PATCHLEVEL }} macOS single-file build (unofficial) + name: Tclsh ${{ env.TCL_PATCHLEVEL }} macOS single-file build (snapshot) path: 1dist/*.dmg win: name: Windows @@ -125,10 +129,10 @@ jobs: working-directory: win - name: Set Executable Name run: | - cp ../win/tclsh*.exe tclsh${TCL_PATCHLEVEL}_unofficial.exe + cp ../win/tclsh*.exe tclsh${TCL_PATCHLEVEL}_snapshot.exe working-directory: 1dist - name: Upload uses: actions/upload-artifact@v2 with: - name: Tclsh ${{ env.TCL_PATCHLEVEL }} Windows single-file build (unofficial) - path: '1dist/*_unofficial.exe' + name: Tclsh ${{ env.TCL_PATCHLEVEL }} Windows single-file build (snapshot) + path: '1dist/*_snapshot.exe' @@ -9018,8 +9018,8 @@ in this changeset (new minor version) rather than bug fixes: 2020-02-25 (bug) release refs when setting class's superclasses fails (dkf) 2020-02-26 (bug) C++ compiler compatibility for registry and dde (nijtmans) -=> registry 1.4.3 -=> dde 1.3.5 +=> registry 1.3.5 +=> dde 1.4.3 2020-03-05 (new) Update to Unicode-13 (nijtmans) diff --git a/doc/Access.3 b/doc/Access.3 index 699d7ed..5a29ec2 100644 --- a/doc/Access.3 +++ b/doc/Access.3 @@ -20,7 +20,7 @@ int \fBTcl_Stat\fR(\fIpath\fR, \fIstatPtr\fR) .SH ARGUMENTS .AS "struct stat" *statPtr out -.AP char *path in +.AP "const char" *path in Native name of the file to check the attributes of. .AP int mode in Mask consisting of one or more of \fBR_OK\fR, \fBW_OK\fR, \fBX_OK\fR and diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3 index 5b0fe5a..53f134a 100644 --- a/doc/AddErrInfo.3 +++ b/doc/AddErrInfo.3 @@ -49,7 +49,7 @@ Interpreter in which to record information. The code returned from script evaluation. .AP Tcl_Obj *options A dictionary of return options. -.AP char *message in +.AP "const char" *message in For \fBTcl_AddErrorInfo\fR, this is a conventional C string to append to the \fB\-errorinfo\fR return option. For \fBTcl_AddObjErrorInfo\fR, @@ -66,7 +66,7 @@ appending to the \fB\-errorinfo\fR return option. If negative, all bytes up to the first null byte are used. .AP Tcl_Obj *errorObjPtr in The \fB\-errorcode\fR return option will be set to this value. -.AP char *element in +.AP "const char" *element in String to record as one element of the \fB\-errorcode\fR return option. Last \fIelement\fR argument must be NULL. .AP va_list argList in @@ -308,6 +308,22 @@ The global variables \fBerrorInfo\fR and \fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR so they continue to hold a record of information about the most recent error seen in an interpreter. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The result of \fBTcl_GetReturnOptions\fR will have at least one +reference to it from the Tcl interpreter. If not using it immediately, +you should use \fBTcl_IncrRefCount\fR to add your own reference. +.PP +The \fIoptions\fR argument to \fBTcl_SetReturnOptions\fR will have a +reference added by the Tcl interpreter; it may safely be called with a +zero-reference value. +.PP +\fBTcl_AppendObjToErrorInfo\fR only reads its \fIobjPtr\fR argument; +it does not modify its reference count at all. +.PP +The \fIerrorObjPtr\fR argument to \fBTcl_SetObjErrorCode\fR will have a +reference added by the Tcl interpreter; it may safely be called with a +zero-reference value. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), Tcl_SetErrno(3), errorCode(n), errorInfo(n) diff --git a/doc/Alloc.3 b/doc/Alloc.3 index 8f25c52..70b0f7d 100644 --- a/doc/Alloc.3 +++ b/doc/Alloc.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory +Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -28,6 +28,9 @@ char * char * \fBTcl_AttemptRealloc\fR(\fIptr, size\fR) .sp +void +\fBTcl_GetMemoryInfo\fR(\fIdsPtr\fR) +.sp char * \fBckalloc\fR(\fIsize\fR) .sp @@ -48,6 +51,8 @@ char * Size in bytes of the memory block to allocate. .AP char *ptr in Pointer to memory block to free or realloc. +.AP Tcl_DString *dsPtr in +Initialized DString pointer. .BE .SH DESCRIPTION @@ -88,5 +93,9 @@ these macros are redefined to be special debugging versions of these procedures. To support Tcl's memory debugging within a module, use the macros rather than direct calls to \fBTcl_Alloc\fR, etc. +\fBTcl_GetMemoryInfo\fR appends a list-of-lists of memory stats to the +provided DString. This function cannot be used in stub-enabled extensions, +and it is only available if Tcl is compiled with the threaded memory allocator. + .SH KEYWORDS alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG diff --git a/doc/Backslash.3 b/doc/Backslash.3 index 0805f8e..1a807f6 100644 --- a/doc/Backslash.3 +++ b/doc/Backslash.3 @@ -18,7 +18,7 @@ char \fBTcl_Backslash\fR(\fIsrc, countPtr\fR) .SH ARGUMENTS .AS char *countPtr out -.AP char *src in +.AP "const char" *src in Pointer to a string starting with a backslash. .AP int *countPtr out If \fIcountPtr\fR is not NULL, \fI*countPtr\fR gets filled diff --git a/doc/BoolObj.3 b/doc/BoolObj.3 index 7268e1f..9bbdc7e 100644 --- a/doc/BoolObj.3 +++ b/doc/BoolObj.3 @@ -88,6 +88,18 @@ will lead to a \fBTCL_OK\fR return (and the boolean value 1), while the same value passed to \fBTcl_GetBoolean\fR will lead to a \fBTCL_ERROR\fR return. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_NewBooleanObj\fR always returns a zero-reference object, much +like \fBTcl_NewObj\fR. +.PP +\fBTcl_SetBooleanObj\fR does not modify the reference count of its +\fIobjPtr\fR argument, but does require that the object be unshared. +.PP +\fBTcl_GetBooleanFromObj\fR does not modify the reference count of its +\fIobjPtr\fR argument; it only reads. Note however that this function +may set the interpreter result; if that is the only place that +is holding a reference to the object, it will be deleted. .SH "SEE ALSO" Tcl_NewObj, Tcl_IsShared, Tcl_GetBoolean diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 09400c8..2a7d7a3 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -85,6 +85,18 @@ newly allocated bytes at the end of the array have arbitrary values. If the length of array is reduced to the new length. The return value is a pointer to the value's new array of bytes. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_NewByteArrayObj\fR always returns a zero-reference object, much +like \fBTcl_NewObj\fR. +.PP +\fBTcl_SetByteArrayObj\fR and \fBTcl_SetByteArrayLength\fR do not modify the +reference count of their \fIobjPtr\fR arguments, but do require that the +object be unshared. +.PP +\fBTcl_GetByteArrayFromObj\fR does not modify the reference count of its +\fIobjPtr\fR argument; it only reads. + .SH "SEE ALSO" Tcl_GetStringFromObj, Tcl_NewObj, Tcl_IncrRefCount, Tcl_DecrRefCount diff --git a/doc/Cancel.3 b/doc/Cancel.3 index 847707e..73edaf6 100644 --- a/doc/Cancel.3 +++ b/doc/Cancel.3 @@ -67,6 +67,14 @@ other procedures. If an error is returned and this bit is set in result, where it can be retrieved with \fBTcl_GetObjResult\fR or \fBTcl_GetStringResult\fR. If this flag bit is not set then no error message is left and the interpreter's result will not be modified. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_CancelEval\fR always decrements the reference count of its +\fIresultObjPtr\fR argument (if that is non-NULL). It is expected to +be usually called with an object with zero reference count. If the +object is shared with some other location (including the Tcl +evaluation stack) it should have its reference count incremented +before calling this function. .SH "SEE ALSO" interp(n), Tcl_Eval(3), TIP 285 diff --git a/doc/Class.3 b/doc/Class.3 index 57203d5..5f8e061 100644 --- a/doc/Class.3 +++ b/doc/Class.3 @@ -241,6 +241,29 @@ NULL if the whole chain is to be processed (the argument itself is never NULL); this variable may be updated by the callback. The \fImethodNameObj\fR parameter gives an unshared object containing the name of the method being invoked, as provided by the user; this object may be updated by the callback. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The \fIobjPtr\fR argument to \fBTcl_GetObjectFromObj\fR will not have its +reference count manipulated, but this function may modify the interpreter +result (to report any error) so interpreter results should not be fed into +this without an additional reference being used. +.PP +The result of \fBTcl_GetObjectName\fR is a value that is owned by the object +that is regenerated when this function is first called after the object is +renamed. If the value is to be retained at all, the caller should increment +the reference count. +.PP +The first \fIobjc\fR values in the \fIobjv\fR argument to +\fBTcl_NewObjectInstance\fR are the arguments to pass to the constructor. They +must have a reference count of at least 1, and may have their reference counts +changed during the running of the constructor. Constructors may modify the +interpreter result, which consequently means that interpreter results should +not be used as arguments without an additional reference being taken. +.PP +The \fImethodNameObj\fR argument to a Tcl_ObjectMapMethodNameProc +implementation will be a value with a reference count of at least 1 where at +least one reference is not held by the interpreter result. It is expected that +method name mappers will only read their \fImethodNameObj\fR arguments. .SH "SEE ALSO" Method(3), oo::class(n), oo::copy(n), oo::define(n), oo::object(n) .SH KEYWORDS diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 index 92f9b0c..2623dcd 100644 --- a/doc/CrtAlias.3 +++ b/doc/CrtAlias.3 @@ -243,8 +243,16 @@ any script evaluation mechanism will fail. .PP For a description of the Tcl interface to multiple interpreters, see \fIinterp(n)\fR. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_CreateAliasObj\fR increments the reference counts of the values +in its \fIobjv\fR argument. (That reference lasts the same length of +time as the owning alias.) +.PP +\fBTcl_GetAliasObj\fR returns (via its \fIobjvPtr\fR argument) a +pointer to values that it holds a reference to. .SH "SEE ALSO" -interp +interp(n) .SH KEYWORDS alias, command, exposed commands, hidden commands, interpreter, invoke, diff --git a/doc/CrtMathFnc.3 b/doc/CrtMathFnc.3 index acceb5b..bb96fc9 100644 --- a/doc/CrtMathFnc.3 +++ b/doc/CrtMathFnc.3 @@ -156,6 +156,10 @@ pointed to by \fIargTypesPointer\fR. \fBTcl_ListMathFuncs\fR returns a Tcl value containing a list of all the math functions defined in the interpreter whose name matches \fIpattern\fR. The returned value has a reference count of zero. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_ListMathFuncs\fR always returns a zero-reference object, much +like \fBTcl_NewObj\fR. .SH "SEE ALSO" expr(n), info(n), Tcl_CreateObjCommand(3), Tcl_Free(3), Tcl_NewListObj(3) .SH KEYWORDS diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index 2cd9222..f15e277 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -54,7 +54,7 @@ const char * .AS Tcl_CmdDeleteProc *deleteProc in/out .AP Tcl_Interp *interp in Interpreter in which to create a new command or that contains a command. -.AP char *cmdName in +.AP "const char" *cmdName in Name of command. .AP Tcl_ObjCmdProc *proc in Implementation of the new command: \fIproc\fR will be called whenever @@ -323,6 +323,21 @@ instead. The result from \fBTcl_GetCommandTypeName\fR will be exactly that string which was registered, and not a copy; use of a compile-time constant string is \fIstrongly recommended\fR. .VE "info cmdtype feature" +.SH "REFERENCE COUNT MANAGEMENT" +.PP +When the \fIproc\fR passed to \fBTcl_CreateObjCommand\fR is called, +the values in its \fIobjv\fR argument will have a reference count of +at least 1, with that guaranteed reference being from the Tcl +evaluation stack. You should not call \fBTcl_DecrRefCount\fR on any of +those values unless you call \fBTcl_IncrRefCount\fR on them first. +Also, when the \fIproc\fR is called, the interpreter result is +guaranteed to be an empty string value with a reference count of 1. +.PP +\fBTcl_GetCommandFullName\fR does not modify the reference count of its +\fIobjPtr\fR argument, but does require that the object be unshared. +.PP +\fBTcl_GetCommandFromObj\fR does not modify the reference count of its +\fIobjPtr\fR argument; it only reads. .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_ResetResult(3), Tcl_SetObjResult(3) .SH KEYWORDS diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index b1e6483..bf8587d 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -187,5 +187,14 @@ There is no way to be notified when the trace created by \fBTcl_CreateTrace\fR is deleted. There is no way for the \fIproc\fR associated with a call to \fBTcl_CreateTrace\fR to abort execution of \fIcommand\fR. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +When the \fIproc\fR passed to \fBTcl_CreateObjTrace\fR is called, +the values in its \fIobjv\fR argument will have a reference count of +at least 1, with that guaranteed reference being from the Tcl +evaluation stack. You should not call \fBTcl_DecrRefCount\fR on any of +those values unless you call \fBTcl_IncrRefCount\fR on them first. +.SH "SEE ALSO" +trace(n) .SH KEYWORDS command, create, delete, interpreter, trace diff --git a/doc/DictObj.3 b/doc/DictObj.3 index 2c111c4..0b4c1ca 100644 --- a/doc/DictObj.3 +++ b/doc/DictObj.3 @@ -190,6 +190,73 @@ path as this is easy to construct from repeated use of dictionaries are created for non-terminal keys where they do not already exist. With \fBTcl_DictObjRemoveKeyList\fR, all non-terminal keys must exist and have dictionaries as their values. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_NewDictObj\fR always returns a zero-reference object, much like +\fBTcl_NewObj\fR. +.PP +\fBTcl_DictObjPut\fR does not modify the reference count of its \fIdictPtr\fR +argument, but does require that the object be unshared. If +\fBTcl_DictObjPut\fR returns \fBTCL_ERROR\fR it does not manipulate any +reference counts; but if it returns \fBTCL_OK\fR then it definitely increments +the reference count of \fIvaluePtr\fR and may increment the reference count of +\fIkeyPtr\fR; the latter case happens exactly when the key did not previously +exist in the dictionary. Note however that this function may set the +interpreter result; if that is the only place that is holding a reference to +an object, it will be deleted. +.PP +\fBTcl_DictObjGet\fR only reads from its \fIdictPtr\fR and \fIkeyPtr\fR +arguments, and does not manipulate their reference counts at all. If the +\fIvaluePtrPtr\fR argument is not set to NULL (and the function doesn't return +\fBTCL_ERROR\fR), it will be set to a value with a reference count of at least +1, with a reference owned by the dictionary. Note however that this function +may set the interpreter result; if that is the only place that is holding a +reference to an object, it will be deleted. +.PP +\fBTcl_DictObjRemove\fR does not modify the reference count of its +\fIdictPtr\fR argument, but does require that the object be unshared. It does +not manipulate the reference count of its \fIkeyPtr\fR argument at all. Note +however that this function may set the interpreter result; if that is the only +place that is holding a reference to an object, it will be deleted. +.PP +\fBTcl_DictObjSize\fR does not modify the reference count of its \fIdictPtr\fR +argument; it only reads. Note however that this function may set the +interpreter result; if that is the only place that is holding a reference to +the dictionary object, it will be deleted. +.PP +\fBTcl_DictObjFirst\fR does not modify the reference count of its +\fIdictPtr\fR argument; it only reads. The variables given by the +\fIkeyPtrPtr\fR and \fIvaluePtrPtr\fR arguments (if not NULL) will be updated +to contain references to the relevant values in the dictionary; their +reference counts will be at least 1 (due to the dictionary holding a reference +to them). It may also manipulate internal references; these are not exposed to +user code, but require a matching \fBTcl_DictObjDone\fR call. Note however +that this function may set the interpreter result; if that is the only place +that is holding a reference to the dictionary object, it will be deleted. +.PP +Similarly for \fBTcl_DictObjNext\fR; the variables given by the +\fIkeyPtrPtr\fR and \fIvaluePtrPtr\fR arguments (if not NULL) will be updated +to contain references to the relevant values in the dictionary; their +reference counts will be at least 1 (due to the dictionary holding a reference +to them). +.PP +\fBTcl_DictObjDone\fR does not manipulate (user-visible) reference counts. +.PP +\fBTcl_DictObjPutKeyList\fR is similar to \fBTcl_DictObjPut\fR; it does not +modify the reference count of its \fIdictPtr\fR argument, but does require +that the object be unshared. It may increment the reference count of any value +passed in the \fIkeyv\fR argument, and will increment the reference count of +the \fIvaluePtr\fR argument on success. It is recommended that values passed +via \fIkeyv\fR and \fIvaluePtr\fR do not have zero reference counts. Note +however that this function may set the interpreter result; if that is the only +place that is holding a reference to an object, it will be deleted. +.PP +\fBTcl_DictObjRemoveKeyList\fR is similar to \fBTcl_DictObjRemove\fR; it does +not modify the reference count of its \fIdictPtr\fR argument, but does require +that the object be unshared, and does not modify the reference counts of any +of the values passed in the \fIkeyv\fR argument. Note however that this +function may set the interpreter result; if that is the only place that is +holding a reference to an object, it will be deleted. .SH EXAMPLE Using the dictionary iteration interface to search determine if there is a key that maps to itself: diff --git a/doc/DoubleObj.3 b/doc/DoubleObj.3 index 85e4de5..c70f5d1 100644 --- a/doc/DoubleObj.3 +++ b/doc/DoubleObj.3 @@ -58,6 +58,18 @@ and if \fIinterp\fR is non-NULL, an error message is left in \fIinterp\fR. The \fBTcl_ObjType\fR of \fIobjPtr\fR may be changed to make subsequent calls to \fBTcl_GetDoubleFromObj\fR more efficient. '\" TODO: add discussion of treatment of NaN value +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_NewDoubleObj\fR always returns a zero-reference object, much +like \fBTcl_NewObj\fR. +.PP +\fBTcl_SetDoubleObj\fR does not modify the reference count of its +\fIobjPtr\fR argument, but does require that the object be unshared. +.PP +\fBTcl_GetDoubleFromObj\fR does not modify the reference count of its +\fIobjPtr\fR argument; it only reads. Note however that this function +may set the interpreter result; if that is the only place that +is holding a reference to the object, it will be deleted. .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 2d2461e..c68070c 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -556,5 +556,16 @@ been loaded, it attempts to load an encoding file called \fIname\fB.enc\fR from the \fBencoding\fR subdirectory of each directory that Tcl searches for its script library. If the encoding file exists, but is malformed, an error message will be left in \fIinterp\fR. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_GetEncodingFromObj\fR does not modify the reference count of its +\fIobjPtr\fR argument; it only reads. Note however that this function may set +the interpreter result; if that is the only place that is holding a reference +to the object, it will be deleted. +.PP +\fBTcl_GetEncodingSearchPath\fR returns an object with a reference count of at +least 1. +.SH "SEE ALSO" +encoding(n) .SH KEYWORDS utf, encoding, convert diff --git a/doc/Ensemble.3 b/doc/Ensemble.3 index febc48f..b768fd6 100644 --- a/doc/Ensemble.3 +++ b/doc/Ensemble.3 @@ -209,6 +209,27 @@ namespace whose list of exported commands is used if both the mapping dictionary and the subcommand list properties are NULL. May be read using \fBTcl_GetEnsembleNamespace\fR which returns a Tcl result code (\fBTCL_OK\fR, or \fBTCL_ERROR\fR if the token does not refer to an ensemble). +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_FindEnsemble\fR does not modify the reference count of its +\fIcmdNameObj\fR argument; it only reads. Note however that this function may +set the interpreter result; if that is the only place that is holding a +reference to the object, it will be deleted. +.PP +The ensemble property getters (\fBTcl_GetEnsembleMappingDict\fR, +\fBTcl_GetEnsembleParameterList\fR, \fBTcl_GetEnsembleSubcommandList\fR, and +\fBTcl_GetEnsembleUnknownHandler\fR) do not manipulate the reference count of +the values they provide out; if those are non-NULL, they will have a reference +count of at least 1. Note that these functions may set the interpreter +result. +.PP +The ensemble property setters (\fBTcl_SetEnsembleMappingDict\fR, +\fBTcl_SetEnsembleParameterList\fR, \fBTcl_SetEnsembleSubcommandList\fR, and +\fBTcl_SetEnsembleUnknownHandler\fR) will increment the reference count of the +new value of the property they are given if they succeed (and decrement the +reference count of the old value of the property, if relevant). If the +property setters return \fBTCL_ERROR\fR, the reference count of the Tcl_Obj +argument is left unchanged. .SH "SEE ALSO" namespace(n), Tcl_DeleteCommandFromToken(3) .SH KEYWORDS @@ -65,7 +65,7 @@ null terminating character. If \-1, then all characters up to the first null byte are used. .AP "const char" *script in Points to first byte of script to execute (null-terminated and UTF-8). -.AP char *part in +.AP "const char" *part in String forming part of a Tcl script. .AP va_list argList in An argument list which must have been initialized using @@ -207,6 +207,20 @@ the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code from \fBTcl_EvalObjEx\fR other than \fBTCL_OK\fR or \fBTCL_ERROR\fR. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_EvalObjEx\fR and \fBTcl_GlobalEvalObj\fR both increment and +decrement the reference count of their \fIobjPtr\fR argument; you must +not pass them any value with a reference count of zero. They also +manipulate the interpreter result; you must not count on the +interpreter result to hold the reference count of any value over +these calls. +.PP +\fBTcl_EvalObjv\fR may increment and decrement the reference count of +any value passed via its \fIobjv\fR argument; you must not pass any +value with a reference count of zero. This function also manipulates +the interpreter result; you must not count on the interpreter result +to hold the reference count of any value over this call. .SH KEYWORDS execute, file, global, result, script, value diff --git a/doc/ExprLongObj.3 b/doc/ExprLongObj.3 index 837e0a8..59413e1 100644 --- a/doc/ExprLongObj.3 +++ b/doc/ExprLongObj.3 @@ -98,6 +98,15 @@ containing the expression's value at \fI*resultPtrPtr\fR. In this case, the caller is responsible for calling \fBTcl_DecrRefCount\fR to decrement the value's reference count when it is finished with the value. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR, +\fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprObj\fR all increment and +decrement the reference count of their \fIobjPtr\fR arguments; you +must not pass them any value with a reference count of zero. They also +manipulate the interpreter result; you must not count on the +interpreter result to hold the reference count of any value over these +calls. .SH "SEE ALSO" Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString, Tcl_GetObjResult diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 4583b22..4951ec5 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -45,7 +45,7 @@ int \fBTcl_FSDeleteFile\fR(\fIpathPtr\fR) .sp int -\fBTcl_FSRemoveDirectory\fR(\fIpathPtr, int recursive, errorPtr\fR) +\fBTcl_FSRemoveDirectory\fR(\fIpathPtr, recursive, errorPtr\fR) .sp int \fBTcl_FSRenameFile\fR(\fIsrcPathPtr, destPathPtr\fR) @@ -79,10 +79,10 @@ int \fBTcl_FSUtime\fR(\fIpathPtr, tval\fR) .sp int -\fBTcl_FSFileAttrsGet\fR(\fIinterp, int index, pathPtr, objPtrRef\fR) +\fBTcl_FSFileAttrsGet\fR(\fIinterp, index, pathPtr, objPtrRef\fR) .sp int -\fBTcl_FSFileAttrsSet\fR(\fIinterp, int index, pathPtr, Tcl_Obj *objPtr\fR) +\fBTcl_FSFileAttrsSet\fR(\fIinterp, index, pathPtr, objPtr\fR) .sp const char *const * \fBTcl_FSFileAttrStrings\fR(\fIpathPtr, objPtrRef\fR) @@ -197,6 +197,8 @@ rename operation. .AP Tcl_Obj *destPathPtr in As for \fIpathPtr\fR, but used for the destination filename for a copy or rename operation. +.AP int recursive in +Whether to remove subdirectories and their contents as well. .AP "const char" *encodingName in The encoding of the data stored in the file identified by \fIpathPtr\fR and to be evaluated. @@ -224,6 +226,10 @@ be joined together. If negative, then all elements are joined. .AP Tcl_Obj **errorPtr out In the case of an error, filled with a value containing the name of the file which caused an error in the various copy/rename operations. +.AP int index in +The index of the attribute in question. +.AP Tcl_Obj *objPtr in +The value to set in the operation. .AP Tcl_Obj **objPtrRef out Filled with a value containing the result of the operation. .AP Tcl_Obj *resultPtr out @@ -241,9 +247,9 @@ The structure that contains the result of a stat or lstat operation. Name of a procedure to look up in the file's symbol table .AP "const char" *sym2 in Name of a procedure to look up in the file's symbol table -.AP Tcl_PackageInitProc **proc1Ptr out +.AP Tcl_LibraryInitProc **proc1Ptr out Filled with the init function for this code. -.AP Tcl_PackageInitProc **proc2Ptr out +.AP Tcl_LibraryInitProc **proc2Ptr out Filled with the safe-init function for this code. .AP ClientData *clientDataPtr out Filled with the clientData value to pass to this code's unload @@ -1628,6 +1634,158 @@ typedef int \fBTcl_FSChdirProc\fR( The \fBTcl_FSChdirProc\fR changes the applications current working directory to the value specified in \fIpathPtr\fR. The function returns -1 on error or 0 on success. +.SH "REFERENCE COUNT MANAGEMENT" +.SS "PUBLIC API CALLS" +.PP +For all of these functions, \fIpathPtr\fR (including the \fIsrcPathPtr\fR and +\fIdestPathPtr\fR arguments to \fBTcl_FSCopyFile\fR, +\fBTcl_FSCopyDirectory\fR, and \fBTcl_FSRenameFile\fR, the \fIfirstPtr\fR and +\fIsecondPtr\fR arguments to \fBTcl_FSEqualPaths\fR, and the \fIlinkNamePtr\fR +and \fItoPtr\fR arguments to \fBTcl_FSLink\fR) must not be a zero reference +count value; references may be retained in internal caches even for +theoretically read-only operations. These functions may also manipulate the +interpreter result (if they take and are given a non-NULL \fIinterp\fR +argument); you must not count on the interpreter result to hold the reference +count of any argument value over these calls and should manage your own +references there. However, references held by the arguments to a Tcl command +\fIare\fR suitable for reference count management purposes for the duration of +the implementation of that command. +.PP +The \fIerrorPtr\fR argument to \fBTcl_FSCopyDirectory\fR and +\fBTcl_FSRemoveDirectory\fR is, when an object is set into it at all, set to +an object with a non-zero reference count that should be passed to +\fBTcl_DecrRefCount\fR when no longer needed. +.PP +\fBTcl_FSListVolumes\fR always returns a zero-reference object, much +like \fBTcl_NewObj\fR. +.PP +\fBTcl_FSLink\fR always returns a non-zero-reference object when it is +asked to read; you must call \fBTcl_DecrRefCount\fR on the object +once you no longer need it. +.PP +\fBTcl_FSGetCwd\fR always returns a non-zero-reference object; you +must call \fBTcl_DecrRefCount\fR on the object once you no longer need +it. +.PP +\fBTcl_FSPathSeparator\fR always returns a zero-reference object, much +like \fBTcl_NewObj\fR. +.PP +\fBTcl_FSJoinPath\fR always returns a zero-reference object, much +like \fBTcl_NewObj\fR. Its \fIlistObj\fR argument can have any reference +count; it is only read by this function. +.PP +\fBTcl_FSSplitPath\fR always returns a zero-reference object, much +like \fBTcl_NewObj\fR. +.PP +\fBTcl_FSGetNormalizedPath\fR returns an object with a non-zero +reference count where Tcl is the owner. You should increment its +reference count if you want to retain it, but do not need to if you +are just using the value immediately. +.PP +\fBTcl_FSJoinToPath\fR always returns a zero-reference object, much like +\fBTcl_NewObj\fR. Its \fIbasePtr\fR argument follows the rules above for +\fIpathPtr\fR, as do the values in the \fIobjv\fR argument. +.PP +\fBTcl_FSGetTranslatedPath\fR returns a non-zero-reference object (or +NULL in the error case); you must call \fBTcl_DecrRefCount\fR on the +object once you no longer need it. +.PP +\fBTcl_FSNewNativePath\fR always returns a zero-reference object (or +NULL), much like \fBTcl_NewObj\fR. +.PP +\fBTcl_FSFileSystemInfo\fR always returns a zero-reference object (or +NULL), much like \fBTcl_NewObj\fR. +.PP +The \fIobjPtr\fR and \fIobjPtrRef\fR arguments to \fBTcl_FSFileAttrsGet\fR, +\fBTcl_FSFileAttrsSet\fR and \fBTcl_FSFileAttrStrings\fR are conventional Tcl +values; the \fIobjPtr\fR argument will be read but not retained, and the +\fIobjPtrRef\fR argument will have (on success) a zero-reference value written +into it (as with \fBTcl_NewObj\fR). \fBTcl_FSFileAttrsGet\fR and +\fBTcl_FSFileAttrsSet\fR may also manipulate the interpreter result. +.PP +The \fIresultPtr\fR argument to \fBTcl_FSMatchInDirectory\fR will not have its +reference count manipulated, but it should have a reference count of no more +than 1, and should not be the current interpreter result (as the function may +overwrite that on error). +.SS "VIRTUAL FILESYSTEM INTERFACE" +.PP +For all virtual filesystem implementation functions, any \fIpathPtr\fR +arguments should not have their reference counts manipulated. If they take an +\fIinterp\fR argument, they may set an error message in that, but must not +manipulate the \fIpathPtr\fR afterwards. Aside from that: +.TP +\fIinternalToNormalizedProc\fR +. +This should return a zero-reference count value, as if allocated with +\fBTcl_NewObj\fR. +.TP +\fInormalizePathProc\fR +. +Unlike with other API implementation functions, the \fIpathPtr\fR argument +here is guaranteed to be an unshared object that should be updated. Its +reference count should not be modified. +.TP +\fIfilesystemPathTypeProc\fR +. +The return value (if non-NULL) either has a reference count of zero or needs +to be maintained (on a per-thread basis) by the filesystem. Tcl will increment +the reference count of the value if it wishes to retain it. +.TP +\fIfilesystemSeparatorProc\fR +. +The return value should be a value with reference count of zero. +.TP +\fImatchInDirectoryProc\fR +. +The \fIresultPtr\fR argument should be assumed to hold a list that can be +appended to (i.e., that has a reference count no greater than 1). No reference +to it should be retained. +.TP +\fIlinkProc\fR +. +If \fItoPtr\fR is NULL, this should return a value with reference count 1 that +has just been allocated and passed to \fBTcl_IncrRefCount\fR. If \fItoPtr\fR +is not NULL, it should be returned on success. +.TP +\fIlistVolumesProc\fR +. +The result value should be a list (if non-NULL); it will have its reference +count decremented once (with \fBTcl_DecrRefCount\fR) by Tcl once done. +.TP +\fIfileAttrStringsProc\fR +. +If the result is NULL, the \fIobjPtrRef\fR should have a list value written to +it; that list will have its reference count both incremented (with +\fBTcl_IncrRefCount\fR) and decremented (with \fBTcl_DecrRefCount\fR). +.TP +\fIfileAttrsGetProc\fR +. +The \fIobjPtrRef\fR argument should have (on non-error return) a zero +reference count value written to it (allocated as if with \fBTcl_NewObj\fR). +.TP +\fIfileAttrsSetProc\fR +. +The \fIobjPtr\fR argument should either just be read or its reference count +incremented to retain it. +.TP +\fIremoveDirectoryProc\fR +. +If an error is being reported, the problem filename reported via +\fIerrorPtr\fR should be newly allocated (as if with \fBTcl_NewObj\fR) and +have a reference count of 1 (i.e., have been passed to +\fBTcl_IncrRefCount\fR). +.TP +\fIcopyDirectoryProc\fR +. +If an error is being reported, the problem filename reported via +\fIerrorPtr\fR should be newly allocated (as if with \fBTcl_NewObj\fR) and +have a reference count of 1 (i.e., have been passed to +\fBTcl_IncrRefCount\fR). +.TP +\fIgetCwdProc\fR +. +The result will be passed to \fBTcl_DecrRefCount\fR by the implementation of +\fBTcl_FSGetCwd\fR after it has been normalized. .SH "SEE ALSO" cd(n), file(n), filename(n), load(n), open(n), pwd(n), source(n), unload(n) .SH KEYWORDS diff --git a/doc/GetCwd.3 b/doc/GetCwd.3 index f4f37a1..b19f587 100644 --- a/doc/GetCwd.3 +++ b/doc/GetCwd.3 @@ -17,7 +17,7 @@ char * \fBTcl_GetCwd\fR(\fIinterp\fR, \fIbufferPtr\fR) .sp int -\fBTcl_Chdir\fR(\fIpath\fR) +\fBTcl_Chdir\fR(\fIdirName\fR) .SH ARGUMENTS .AS Tcl_DString *bufferPtr in/out .AP Tcl_Interp *interp in @@ -27,7 +27,7 @@ This dynamic string is used to store the current working directory. At the time of the call it should be uninitialized or free. The caller must eventually call \fBTcl_DStringFree\fR to free up anything stored here. -.AP char *path in +.AP "const char" *dirName in File path in UTF\-8 format. .BE @@ -45,7 +45,7 @@ must call \fBTcl_DStringFree()\fR when the result is no longer needed. The format of the path is UTF\-8. .PP \fBTcl_Chdir\fR changes the applications current working directory to -the value specified in \fIpath\fR. The format of the passed in string +the value specified in \fIdirName\fR. The format of the passed in string must be UTF\-8. The function returns -1 on error or 0 on success. .SH KEYWORDS diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index 8591c56..a788848 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -105,6 +105,12 @@ array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.) This is particularly useful when processing things like \fBTk_ConfigurationSpec\fR, whose string keys are in the same place in each of several array elements. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_GetIndexFromObj\fR and \fBTcl_GetIndexFromObjStruct\fR do not modify +the reference count of their \fIobjPtr\fR arguments; they only read. Note +however that these functions may set the interpreter result; if that is the +only place that is holding a reference to the object, it will be deleted. .SH "SEE ALSO" prefix(n), Tcl_WrongNumArgs(3) .SH KEYWORDS @@ -330,5 +330,19 @@ typedef void \fBTcl_FreeHashEntryProc\fR( If this is NULL then \fBTcl_Free\fR is used to free the space for the entry. Tcl_Obj* keys use this function to decrement the reference count on the value. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +When a hash table is created with \fBTcl_InitCustomHashTable\fR, the +\fBTcl_CreateHashEntry\fR function will increment the reference count of its +\fIkey\fR argument when it creates a key (but not if there is an existing +matching key). The reference count of the key will be decremented when the +corresponding hash entry is deleted, whether with \fBTcl_DeleteHashEntry\fR or +with \fBTcl_DeleteHashTable\fR. The \fBTcl_GetHashKey\fR function will return +the key without further modifying its reference count. +.PP +Custom hash tables that use a Tcl_Obj* as key will generally need to do +something similar in their \fIallocEntryProc\fR. +.SH "SEE ALSO" +Dict(3) .SH KEYWORDS hash table, key, lookup, search, value @@ -2,7 +2,7 @@ '\" Copyright (c) 1998-2000 Scriptics Corporation. '\" All rights reserved. '\" -.TH Tcl_Init 3 8.0 Tcl "Tcl Library Procedures" +.TH Tcl_Init 3 8.7 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME @@ -13,10 +13,15 @@ Tcl_Init \- find and source initialization script .sp int \fBTcl_Init\fR(\fIinterp\fR) +.sp +const char * +\fBTcl_SetPreInitScript\fR(\fIscriptPtr\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Interpreter to initialize. +.AP "const char" *scriptPtr in +Address of the initialization script. .BE .SH DESCRIPTION @@ -26,6 +31,13 @@ Interpreter to initialize. path. .PP \fBTcl_Init\fR is typically called from \fBTcl_AppInit\fR procedures. +.PP +\fBTcl_SetPreInitScript\fR registers the pre-initialization script and +returns the former (now replaced) script pointer. +A value of \fINULL\fR may be passed to not register any script. +The pre-initialization script is executed by \fBTcl_Init\fR before accessing +the file system. The purpose is to typically prepare a custom file system +(like an embedded zip-file) to be activated before the search. .SH "SEE ALSO" Tcl_AppInit, Tcl_Main diff --git a/doc/IntObj.3 b/doc/IntObj.3 index 36bfa7d..d640dbb 100644 --- a/doc/IntObj.3 +++ b/doc/IntObj.3 @@ -160,6 +160,27 @@ If anything later in the caller requires The \fBTcl_InitBignumFromDouble\fR routine is a utility procedure that extracts the integer part of \fIdoubleValue\fR and stores that integer value in the \fBmp_int\fR value \fIbigValue\fR. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR, \fBTcl_NewWideIntObj\fR, and +\fBTcl_NewBignumObj\fR always return a zero-reference object, much like +\fBTcl_NewObj\fR. +.PP +\fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, and +\fBTcl_SetBignumObj\fR do not modify the reference count of their \fIobjPtr\fR +arguments, but do require that the object be unshared. +.PP +\fBTcl_GetIntFromObj\fR, \fBTcl_GetIntForIndex\fR, \fBTcl_GetLongFromObj\fR, +\fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and +\fBTcl_TakeBignumFromObj\fR do not modify the reference count of their +\fIobjPtr\fR arguments; they only read. Note however that this function may +set the interpreter result; if that is the only place that is holding a +reference to the object, it will be deleted. Also note that if +\fBTcl_TakeBignumFromObj\fR is given an unshared value, the value of that +object may be modified; it is intended to be used when the value is +.QW consumed +by the operation at this point. + .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS diff --git a/doc/ListObj.3 b/doc/ListObj.3 index ab836d8..67721c9 100644 --- a/doc/ListObj.3 +++ b/doc/ListObj.3 @@ -246,6 +246,31 @@ with a NULL \fIobjvPtr\fR: result = \fBTcl_ListObjReplace\fR(interp, listPtr, first, count, 0, NULL); .CE +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_NewListObj\fR always returns a zero-reference object, much like +\fBTcl_NewObj\fR. If a non-NULL \fIobjv\fR argument is given, the reference +counts of the first \fIobjc\fR values in that array are incremented. +.PP +\fBTcl_SetListObj\fR does not modify the reference count of its \fIobjPtr\fR +argument, but does require that the object be unshared. The reference counts +of the first \fIobjc\fR values in the \fIobjv\fR array are incremented. +.PP +\fBTcl_ListObjGetElements\fR, \fBTcl_ListObjIndex\fR, and +\fBTcl_ListObjLength\fR do not modify the reference count of their +\fIlistPtr\fR arguments; they only read. Note however that these three +functions may set the interpreter result; if that is the only place that is +holding a reference to the object, it will be deleted. +.PP +\fBTcl_ListObjAppendList\fR, \fBTcl_ListObjAppendElement\fR, and +\fBTcl_ListObjReplace\fR require an unshared \fIlistPtr\fR argument. +\fBTcl_ListObjAppendList\fR only reads its \fIelemListPtr\fR argument. +\fBTcl_ListObjAppendElement\fR increments the reference count of its +\fIobjPtr\fR on success. \fBTcl_ListObjReplace\fR increments the reference +count of the first \fIobjc\fR values in the \fIobjv\fR array on success. Note +however that all these three functions may set the interpreter result on +failure; if that is the only place that is holding a reference to the object, +it will be deleted. .SH "SEE ALSO" Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_GetObjResult(3) .SH KEYWORDS @@ -60,6 +60,10 @@ be unloaded with \fBTcl_FSUnloadFile\fR. the symbol cannot be found, it returns NULL and sets an error message in the given \fIinterp\fR (if that is non-NULL). Note that it is unsafe to use this operation on a handle that has been passed to \fBTcl_FSUnloadFile\fR. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The reference count of the \fIpathPtr\fR argument to \fBTcl_LoadFile\fR may be +incremented. As such, it should not be given a zero reference count value. .SH "SEE ALSO" Tcl_FSLoadFile(3), Tcl_FSUnloadFile(3), load(n), unload(n) .SH KEYWORDS diff --git a/doc/Method.3 b/doc/Method.3 index 9e636a1..577cd54 100644 --- a/doc/Method.3 +++ b/doc/Method.3 @@ -258,8 +258,32 @@ also return TCL_ERROR; it should return TCL_OK otherwise. The \fIoldClientData\fR field to a Tcl_CloneProc gives the value from the method being copied from, and the \fInewClientDataPtr\fR field will point to a variable in which to write the value for the method being copied to. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The \fInameObj\fR argument to \fBTcl_NewMethod\fR and +\fBTcl_NewInstanceMethod\fR (when non-NULL) will have its reference count +incremented if there is no existing method with that name in that +class/object. +.PP +The result of \fBTcl_MethodName\fR is a value with a reference count of at +least one. It should not be modified without first duplicating it (with +\fBTcl_DuplicateObj\fR). +.PP +The values in the first \fIobjc\fR values of the \fIobjv\fR argument to +\fBTcl_ObjectContextInvokeNext\fR are assumed to have a reference count of at +least 1; the containing array is assumed to endure until the next method +implementation (see \fBnext\fR) returns. Be aware that methods may +\fByield\fR; if any post-call actions are desired (e.g., decrementing the +reference count of values passed in here), they must be scheduled with +\fBTcl_NRAddCallback\fR. +.PP +The \fIcallProc\fR of the \fBTcl_MethodType\fR structure takes values of at +least reference count 1 in its \fIobjv\fR argument. It may add its own +references, but must not decrement the reference count below that level; the +caller of the method will decrement the reference count once the method +returns properly (and the reference will be held if the method \fByield\fRs). .SH "SEE ALSO" -Class(3), oo::class(n), oo::define(n), oo::object(n) +Class(3), NRE(3), oo::class(n), oo::define(n), oo::object(n) .SH KEYWORDS constructor, method, object @@ -40,7 +40,7 @@ void .AS Tcl_CmdDeleteProc *interp in .AP Tcl_Interp *interp in The relevant Interpreter. -.AP char *cmdName in +.AP "const char" *cmdName in Name of the command to create. .AP Tcl_ObjCmdProc *proc in Called in order to evaluate a command. Is often just a small wrapper that uses @@ -227,6 +227,25 @@ int Any function comprising a routine can push other functions, making it possible implement looping and sequencing constructs using the function stack. .PP +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The first \fIobjc\fR values in the \fIobjv\fR array passed to the functions +\fBTcl_NRCallObjProc\fR, \fBTcl_NREvalObjv\fR, and \fBTcl_NRCmdSwap\fR should +have a reference count of at least 1; they may have additional references +taken during the execution. +.PP +The \fIobjPtr\fR argument to \fBTcl_NREvalObj\fR and \fBTcl_NRExprObj\fR +should have a reference count of at least 1, and may have additional +references taken to it during execution. +.PP +The \fIresultObj\fR argument to \fBTcl_NRExprObj\fR should be an unshared +object. +.PP +Use \fBTcl_NRAddCallback\fR to schedule any required final decrementing of the +reference counts of arguments to any of the other functions on this page, as +with any other post-processing step in the non-recursive execution engine. +.PP +The .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3) .SH KEYWORDS diff --git a/doc/Namespace.3 b/doc/Namespace.3 index a037442..49b772c 100644 --- a/doc/Namespace.3 +++ b/doc/Namespace.3 @@ -46,10 +46,10 @@ Tcl_Command \fBTcl_FindCommand\fR(\fIinterp, name, contextNsPtr, flags\fR) .sp Tcl_Obj * -\fBTcl_GetNamespaceUnknownHandler(\fIinterp, nsPtr\fR) +\fBTcl_GetNamespaceUnknownHandler\fR(\fIinterp, nsPtr\fR) .sp int -\fBTcl_SetNamespaceUnknownHandler(\fIinterp, nsPtr, handlerPtr\fR) +\fBTcl_SetNamespaceUnknownHandler\fR(\fIinterp, nsPtr, handlerPtr\fR) .SH ARGUMENTS .AS Tcl_NamespaceDeleteProc allowOverwrite in/out .AP Tcl_Interp *interp in/out @@ -159,6 +159,18 @@ for the namespace, or NULL if none is set. \fBTcl_SetNamespaceUnknownHandler\fR sets the unknown command handler for the namespace. If \fIhandlerPtr\fR is NULL, then the handler is reset to its default. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The \fIobjPtr\fR argument to \fBTcl_AppendExportList\fR should be an +unshared object, as it will be modified by this function. The +reference count of \fIobjPtr\fR will not be altered. +.PP +\fBTcl_GetNamespaceUnknownHandler\fR returns a possibly shared value. +Its reference count should be incremented if the value is to be +retained. +.PP +The \fIhandlerPtr\fR argument to \fBTcl_SetNamespaceUnknownHandler\fR +will have its reference count incremented if it is a non-empty list. .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_ListObjAppendList(3), Tcl_SetVar(3) .SH KEYWORDS diff --git a/doc/Object.3 b/doc/Object.3 index eadd041..2099552 100644 --- a/doc/Object.3 +++ b/doc/Object.3 @@ -283,7 +283,12 @@ to reduce storage requirements. Reference counting is used to determine when a value is no longer needed and can safely be freed. A value just created by \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR -has \fIrefCount\fR 0. +has \fIrefCount\fR 0, meaning that the object can often be given to a function +like \fBTcl_SetObjResult\fR, \fBTcl_ListObjAppendElement\fR, or +\fBTcl_DictObjPut\fR (as a value) without explicit reference management, all +of which are common use cases. (The latter two require that the the target +list or dictionary be well-formed, but that is often easy to arrange when the +value is being initially constructed.) The macro \fBTcl_IncrRefCount\fR increments the reference count when a new reference to the value is created. The macro \fBTcl_DecrRefCount\fR decrements the count diff --git a/doc/ObjectType.3 b/doc/ObjectType.3 index 67f5174..7e3cc12 100644 --- a/doc/ObjectType.3 +++ b/doc/ObjectType.3 @@ -248,6 +248,28 @@ The \fIfreeIntRepProc\fR implementation must not access the uses of that field during value deletion. The defined tasks for the \fIfreeIntRepProc\fR have no need to consult the \fIbytes\fR member. +.PP +Note that if a subsidiary value has its reference count reduced to zero +during the running of a \fIfreeIntRepProc\fR, that value may be not freed +immediately, in order to limit stack usage. However, the value will be freed +before the outermost current \fBTcl_DecrRefCount\fR returns. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The \fIobjPtr\fR argument to \fBTcl_AppendAllObjTypes\fR should be an unshared +value; this function will not modify the reference count of that value, but +will modify its contents. If \fIobjPtr\fR is not (interpretable as) a list, +this function will set the interpreter result and produce an error; using an +unshared empty value is strongly recommended. +.PP +The \fIobjPtr\fR argument to \fBTcl_ConvertToType\fR can have any non-zero +reference count; this function will not modify the reference count, but may +write to the interpreter result on error so values that originate from there +should have an additional reference made before calling this. +.PP +None of the callback functions in the \fBTcl_ObjType\fR structure should +modify the reference count of their arguments, but if the values contain +subsidiary values (e.g., the elements of a list or the keys of a dictionary) +then those subsidiary values may have their reference counts modified. .SH "SEE ALSO" Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3) .SH KEYWORDS diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 index c1d1922..4e42b93 100644 --- a/doc/OpenFileChnl.3 +++ b/doc/OpenFileChnl.3 @@ -641,6 +641,24 @@ the channel was created with \fBTcl_OpenFileChannel\fR, \fBTcl_OpenCommandChannel\fR, or \fBTcl_MakeFileChannel\fR. Other channel types may return a different type of handle on Windows platforms. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The \fIreadObjPtr\fR argument to \fBTcl_ReadChars\fR must be an unshared +value; it will be modified by this function. Using the interpreter result for +this purpose is \fIstrongly\fR not recommended; the preferred pattern is to +use a new value from \fBTcl_NewObj\fR to receive the data and only to pass it +to \fBTcl_SetObjResult\fR if this function succeeds. +.PP +The \fIlineObjPtr\fR argument to \fBTcl_GetsObj\fR must be an unshared value; +it will be modified by this function. Using the interpreter result for this +purpose is \fIstrongly\fR not recommended; the preferred pattern is to use a +new value from \fBTcl_NewObj\fR to receive the data and only to pass it to +\fBTcl_SetObjResult\fR if this function succeeds. +.PP +The \fIwriteObjPtr\fR argument to \fBTcl_WriteObj\fR should be a value with +any reference count. This function will not modify the reference count. Using +the interpreter result without adding an additional reference to it is not +recommended. .SH "SEE ALSO" DString(3), fconfigure(n), filename(n), fopen(3), Tcl_CreateChannel(3) .SH KEYWORDS diff --git a/doc/ParseArgs.3 b/doc/ParseArgs.3 index def55de..f29f161 100644 --- a/doc/ParseArgs.3 +++ b/doc/ParseArgs.3 @@ -189,6 +189,12 @@ will be stored at \fIdstPtr\fR; the string inside will have a lifetime linked to the lifetime of the string representation of the argument value that it came from, and so should be copied if it needs to be retained. The \fIsrcPtr\fR and \fIclientData\fR fields are ignored. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The values in the \fIobjv\fR argument to \fBTcl_ParseArgsObjv\fR will not have +their reference counts modified by this function. The interpreter result may +be modified on error; the values passed should not be the interpreter result +with no further reference added. .SH "SEE ALSO" Tcl_GetIndexFromObj(3), Tcl_Main(3), Tcl_CreateObjCommand(3) .SH KEYWORDS diff --git a/doc/ParseCmd.3 b/doc/ParseCmd.3 index 40a0818..03b97f7 100644 --- a/doc/ParseCmd.3 +++ b/doc/ParseCmd.3 @@ -191,6 +191,7 @@ code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. +.SS "DEPRECATED FUNCTIONS" .PP \fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in the return convention used: it returns the result in a new Tcl_Obj. @@ -463,5 +464,12 @@ There are additional fields in the Tcl_Parse structure after the \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR; they should not be referenced by code outside of these procedures. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The result of \fBTcl_EvalTokens\fR is an unshared value with a reference count +of 1; the caller of that function should call \fBTcl_DecrRefCount\fR on the +result value to dispose of it. (The equivalent with +\fBTcl_EvalTokenStandard\fR is just the interpreter result, which can be +retrieved with \fBTcl_GetObjResult\fR.) .SH KEYWORDS backslash substitution, braces, command, expression, parse, token, variable substitution diff --git a/doc/PkgRequire.3 b/doc/PkgRequire.3 index 71f3acf..77e73f1 100644 --- a/doc/PkgRequire.3 +++ b/doc/PkgRequire.3 @@ -91,7 +91,11 @@ functions. \fBTcl_PkgRequireProc\fR is the form of \fBpackage require\fR handling multiple requirements. The other forms are present for backward compatibility and translate their invocations to this form. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The requirements values given (in the \fIobjv\fR argument) to +\fBTcl_PkgRequireProc\fR must have non-zero reference counts. .SH KEYWORDS package, present, provide, require, version .SH "SEE ALSO" -package(n), Tcl_StaticPackage(3) +package(n), Tcl_StaticLibrary(3) diff --git a/doc/RecEvalObj.3 b/doc/RecEvalObj.3 index f9550a2..e68f4b5 100644 --- a/doc/RecEvalObj.3 +++ b/doc/RecEvalObj.3 @@ -44,6 +44,12 @@ allow the user to re-issue recently invoked commands. If the \fIflags\fR argument contains the \fBTCL_NO_EVAL\fR bit then the command is recorded without being evaluated. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The reference count of the \fIcmdPtr\fR argument to \fBTcl_RecordAndEvalObj\fR +must be at least 1. This function will modify the interpreter result; do not +use an existing result as \fIcmdPtr\fR directly without incrementing its +reference count. .SH "SEE ALSO" Tcl_EvalObjEx, Tcl_GetObjResult diff --git a/doc/RegConfig.3 b/doc/RegConfig.3 index d73e3d7..ef46ba5 100644 --- a/doc/RegConfig.3 +++ b/doc/RegConfig.3 @@ -28,7 +28,7 @@ configuration as ASCII string. This means that this information is in UTF-8 too. Must not be NULL. .AP "const Tcl_Config" *configuration in Refers to an array of Tcl_Config entries containing the information -embedded in the binary library. Must not be NULL. The end of the array +embedded in the library. Must not be NULL. The end of the array is signaled by either a key identical to NULL, or a key referring to the empty string. .AP "const char" *valEncoding in @@ -40,10 +40,10 @@ too. Must not be NULL. .PP The function described here has its base in TIP 59 and provides extensions with support for the embedding of configuration -information into their binary library and the generation of a +information into their library and the generation of a Tcl-level interface for querying this information. .PP -To embed configuration information into their binary library an +To embed configuration information into their library an extension has to define a non-volatile array of Tcl_Config entries in one if its source files and then call \fBTcl_RegisterConfig\fR to register that information. @@ -108,4 +108,4 @@ typedef struct Tcl_Config { .\" No cross references yet. .\" .SH "SEE ALSO" .SH KEYWORDS -embedding, configuration, binary library +embedding, configuration, library diff --git a/doc/RegExp.3 b/doc/RegExp.3 index aa757bc..40429c9 100644 --- a/doc/RegExp.3 +++ b/doc/RegExp.3 @@ -51,14 +51,14 @@ can be efficiently searched. .AP Tcl_Obj *patObj in/out Refers to the value from which to get a regular expression. The compiled regular expression is cached in the value. -.AP char *text in +.AP "const char" *text in Text to search for a match with a regular expression. .AP "const char" *pattern in String in the form of a regular expression pattern. .AP Tcl_RegExp regexp in Compiled regular expression. Must have been returned previously by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR. -.AP char *start in +.AP "const char" *start in If \fItext\fR is just a portion of some other string, this argument identifies the beginning of the larger string. If it is not the same as \fItext\fR, then no @@ -377,6 +377,22 @@ If no match was found, then it indicates the earliest point at which a match might occur if additional text is appended to the string. If it is no match is possible even with further text, this field will be set to \-1. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The \fItextObj\fR and \fIpatObj\fR arguments to \fBTcl_RegExpMatchObj\fR must +have reference counts of at least 1. Note however that this function may set +the interpreter result; neither argument should be the direct interpreter +result without an additional reference being taken. +.PP +The \fIpatObj\fR argument to \fBTcl_GetRegExpFromObj\fR must have a reference +count of at least 1. Note however that this function may set the interpreter +result; the argument should not be the direct interpreter result without an +additional reference being taken. +.PP +The \fItextObj\fR argument to \fBTcl_RegExpExecObj\fR must have a reference +count of at least 1. Note however that this function may set the interpreter +result; the argument should not be the direct interpreter result without an +additional reference being taken. .SH "SEE ALSO" re_syntax(n) .SH KEYWORDS diff --git a/doc/SetChanErr.3 b/doc/SetChanErr.3 index 5bb86be..473b61c 100644 --- a/doc/SetChanErr.3 +++ b/doc/SetChanErr.3 @@ -35,20 +35,20 @@ Refers to the Tcl interpreter whose bypass area is accessed. .AP Tcl_Obj* msg in Error message put into a bypass area. A list of return options and values, followed by a string message. Both message and the option/value information -are optional. +are optional. This \fImust\fR be a well-formed list. .AP Tcl_Obj** msgPtr out Reference to a place where the message stored in the accessed bypass area can be stored in. .BE .SH DESCRIPTION .PP -The current definition of a Tcl channel driver does not permit the direct +The standard definition of a Tcl channel driver does not permit the direct return of arbitrary error messages, except for the setting and retrieval of channel options. All other functions are restricted to POSIX error codes. .PP The functions described here overcome this limitation. Channel drivers are allowed to use \fBTcl_SetChannelError\fR and \fBTcl_SetChannelErrorInterp\fR -to place arbitrary error messages in \fBbypass areas\fR defined for channels +to place arbitrary error messages in \fIbypass areas\fR defined for channels and interpreters. And the generic I/O layer uses \fBTcl_GetChannelError\fR and \fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass areas and arrange for their return as errors. The POSIX error codes set by a driver are @@ -134,6 +134,15 @@ leave all their error information in the interpreter result. .ta 1.9i 4i \fBTcl_Close\fR \fBTcl_UnstackChannel\fR \fBTcl_UnregisterChannel\fR .DE +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The \fImsg\fR argument to \fBTcl_SetChannelError\fR and +\fBTcl_SetChannelErrorInterp\fR, if not NULL, may have any reference count; +these functions will copy. +.PP +\fBTcl_GetChannelError\fR and \fBTcl_GetChannelErrorInterp\fR write a value +reference into their \fImsgPtr\fR, but do not manipulate its reference count. +The reference count will be at least 1 (unless the reference is NULL). .SH "SEE ALSO" Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3) .SH KEYWORDS diff --git a/doc/SetResult.3 b/doc/SetResult.3 index 1622290..04a4b7f 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -239,6 +239,33 @@ typedef void \fBTcl_FreeProc\fR( .PP When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to the value of \fIresult\fR passed to \fBTcl_SetResult\fR. + +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The interpreter result is one of the main places that owns references to +values, along with the bytecode execution stack, argument lists, variables, +and the list and dictionary collection values. +.PP +\fBTcl_SetObjResult\fR takes a value with an arbitrary reference count +\fI(specifically including zero)\fR and guarantees to increment the reference +count. If code wishes to continue using the value after setting it as the +result, it should add its own reference to it with \fBTcl_IncrRefCount\fR. +.PP +\fBTcl_GetObjResult\fR returns the current interpreter result value. This will +have a reference count of at least 1. If the caller wishes to keep the +interpreter result value, it should increment its reference count. +.PP +\fBTcl_GetStringResult\fR does not manipulate reference counts, but the string +it returns is owned by (and has a lifetime controlled by) the current +interpreter result value; it should be copied instead of being relied upon to +persist after the next Tcl API call, as most Tcl operations can modify the +interpreter result. +.PP +\fBTcl_SetResult\fR, \fBTcl_AppendResult\fR, \fBTcl_AppendResultVA\fR, +\fBTcl_AppendElement\fR, and \fBTcl_ResetResult\fR all modify the interpreter +result. They may cause the old interpreter result to have its reference count +decremented and a new interpreter result to be allocated. After they have been +called, the reference count of the interpreter result is guaranteed to be 1. .SH "SEE ALSO" Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp, Tcl_GetReturnOptions diff --git a/doc/SetVar.3 b/doc/SetVar.3 index 4aa671a..eb8333b 100644 --- a/doc/SetVar.3 +++ b/doc/SetVar.3 @@ -242,6 +242,27 @@ but the array remains. If an array name is specified without an index, then the entire array is removed. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The result of \fBTcl_SetVar2Ex\fR, \fBTcl_ObjSetVar2\fR, \fBTcl_GetVar2Ex\fR, +and \fBTcl_ObjGetVar2\fR is (if non-NULL) a value with a reference of at least +1, where that reference is held by the variable that the function has just +operated upon. +.PP +The \fInewValuePtr\fR argument to \fBTcl_SetVar2Ex\fR and \fBTcl_ObjSetVar2\fR +may be an arbitrary reference count value; its reference count will be +incremented on success. However, it is recommended to not use a zero reference +count value, as that makes correct handling of the error case tricky. +.PP +The \fIpart1\fR argument to \fBTcl_ObjSetVar2\fR and \fBTcl_ObjGetVar2\fR can +have any reference count; these functions never modify it. It is recommended +to not use a zero reference count for this argument. +.PP +The \fIpart2\fR argument to \fBTcl_ObjSetVar2\fR and \fBTcl_ObjGetVar2\fR, if +non-NULL, should not have a zero reference count as these functions may +retain a reference to it (particularly when it is used to create an array +element that did not previously exist). + .SH "SEE ALSO" Tcl_GetObjResult, Tcl_GetStringResult, Tcl_TraceVar diff --git a/doc/SplitList.3 b/doc/SplitList.3 index d19ca14..863e322 100644 --- a/doc/SplitList.3 +++ b/doc/SplitList.3 @@ -36,7 +36,7 @@ int .AP Tcl_Interp *interp out Interpreter to use for error reporting. If NULL, then no error message is left. -.AP char *list in +.AP "const char" *list in Pointer to a string with proper list structure. .AP int *argcPtr out Filled in with number of elements in \fIlist\fR. diff --git a/doc/StaticLibrary.3 b/doc/StaticLibrary.3 new file mode 100644 index 0000000..9a77ab7 --- /dev/null +++ b/doc/StaticLibrary.3 @@ -0,0 +1,78 @@ +'\" +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH Tcl_StaticLibrary 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_StaticLibrary, Tcl_StaticPackage \- make a statically linked library available via the 'load' command +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_StaticLibrary\fR(\fIinterp, prefix, initProc, safeInitProc\fR) +.sp +\fBTcl_StaticPackage\fR(\fIinterp, prefix, initProc, safeInitProc\fR) +.SH ARGUMENTS +.AS Tcl_LibraryInitProc *safeInitProc +.AP Tcl_Interp *interp in +If not NULL, points to an interpreter into which the library has +already been incorporated (i.e., the caller has already invoked the +appropriate initialization procedure). NULL means the library +has not yet been incorporated into any interpreter. +.AP "const char" *prefix in +Prefix for library initialization function; should be properly +capitalized (first letter upper-case, all others lower-case). +.AP Tcl_LibraryInitProc *initProc in +Procedure to invoke to incorporate this library into a trusted +interpreter. +.AP Tcl_LibraryInitProc *safeInitProc in +Procedure to call to incorporate this library into a safe interpreter +(one that will execute untrusted scripts). NULL means the library +cannot be used in safe interpreters. +.BE +.SH DESCRIPTION +.PP +This procedure may be invoked to announce that a library has been +linked statically with a Tcl application and, optionally, that it +has already been incorporated into an interpreter. +Once \fBTcl_StaticLibrary\fR has been invoked for a library, it +may be incorporated into interpreters using the \fBload\fR command. +\fBTcl_StaticLibrary\fR is normally invoked only by the \fBTcl_AppInit\fR +procedure for the application, not by libraries for themselves +(\fBTcl_StaticLibrary\fR should only be invoked for statically +linked libraries, and code in the library itself should not need +to know whether the library is dynamically loaded or statically linked). +.PP +When the \fBload\fR command is used later to incorporate the library into +an interpreter, one of \fIinitProc\fR and \fIsafeInitProc\fR will +be invoked, depending on whether the target interpreter is safe +or not. +\fIinitProc\fR and \fIsafeInitProc\fR must both match the +following prototype: +.PP +.CS +typedef int \fBTcl_LibraryInitProc\fR( + Tcl_Interp *\fIinterp\fR); +.CE +.PP +The \fIinterp\fR argument identifies the interpreter in which the library +is to be incorporated. The initialization procedure must return \fBTCL_OK\fR or +\fBTCL_ERROR\fR to indicate whether or not it completed successfully; in +the event of an error it should set the interpreter's result to point to an +error message. The result or error from the initialization procedure will +be returned as the result of the \fBload\fR command that caused the +initialization procedure to be invoked. +.PP +\fBTcl_StaticLibrary\fR was named \fBTcl_StaticPackage\fR in Tcl 8.6 and +earlier, but the old name is deprecated now. +.PP +\fBTcl_StaticLibrary\fR can not be used in stub-enabled extensions. Its symbol +entry in the stub table is deprecated and it will be removed in Tcl 9.0. +.SH KEYWORDS +initialization procedure, package, static linking +.SH "SEE ALSO" +load(n), package(n), Tcl_PkgRequire(3) diff --git a/doc/StaticPkg.3 b/doc/StaticPkg.3 deleted file mode 100644 index b22edcc..0000000 --- a/doc/StaticPkg.3 +++ /dev/null @@ -1,73 +0,0 @@ -'\" -'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_StaticPackage 3 7.5 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_StaticPackage \- make a statically linked package available via the 'load' command -.SH SYNOPSIS -.nf -\fB#include <tcl.h>\fR -.sp -\fBTcl_StaticPackage\fR(\fIinterp, pkgName, initProc, safeInitProc\fR) -.SH ARGUMENTS -.AS Tcl_PackageInitProc *safeInitProc -.AP Tcl_Interp *interp in -If not NULL, points to an interpreter into which the package has -already been loaded (i.e., the caller has already invoked the -appropriate initialization procedure). NULL means the package -has not yet been incorporated into any interpreter. -.AP "const char" *pkgName in -Name of the package; should be properly capitalized (first letter -upper-case, all others lower-case). -.AP Tcl_PackageInitProc *initProc in -Procedure to invoke to incorporate this package into a trusted -interpreter. -.AP Tcl_PackageInitProc *safeInitProc in -Procedure to call to incorporate this package into a safe interpreter -(one that will execute untrusted scripts). NULL means the package -cannot be used in safe interpreters. -.BE -.SH DESCRIPTION -.PP -This procedure may be invoked to announce that a package has been -linked statically with a Tcl application and, optionally, that it -has already been loaded into an interpreter. -Once \fBTcl_StaticPackage\fR has been invoked for a package, it -may be loaded into interpreters using the \fBload\fR command. -\fBTcl_StaticPackage\fR is normally invoked only by the \fBTcl_AppInit\fR -procedure for the application, not by packages for themselves -(\fBTcl_StaticPackage\fR should only be invoked for statically -loaded packages, and code in the package itself should not need -to know whether the package is dynamically or statically loaded). -.PP -When the \fBload\fR command is used later to load the package into -an interpreter, one of \fIinitProc\fR and \fIsafeInitProc\fR will -be invoked, depending on whether the target interpreter is safe -or not. -\fIinitProc\fR and \fIsafeInitProc\fR must both match the -following prototype: -.PP -.CS -typedef int \fBTcl_PackageInitProc\fR( - Tcl_Interp *\fIinterp\fR); -.CE -.PP -The \fIinterp\fR argument identifies the interpreter in which the package -is to be loaded. The initialization procedure must return \fBTCL_OK\fR or -\fBTCL_ERROR\fR to indicate whether or not it completed successfully; in -the event of an error it should set the interpreter's result to point to an -error message. The result or error from the initialization procedure will -be returned as the result of the \fBload\fR command that caused the -initialization procedure to be invoked. -.PP -\fBTcl_StaticPackage\fR can not be used in stub-enabled extensions. Its symbol -entry in the stub table is deprecated and it will be removed in Tcl 9.0. -.SH KEYWORDS -initialization procedure, package, static linking -.SH "SEE ALSO" -load(n), package(n), Tcl_PkgRequire(3) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index c55f57d..772073e 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -383,6 +383,33 @@ white space, then that value is ignored entirely. This white-space removal was added to make the output of the \fBconcat\fR command cleaner-looking. \fBTcl_ConcatObj\fR returns a pointer to a newly-created value whose ref count is zero. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_NewStringObj\fR, \fBTcl_NewUnicodeObj\fR, \fBTcl_Format\fR, +\fBTcl_ObjPrintf\fR, and \fBTcl_ConcatObj\fR always return a zero-reference +object, much like \fBTcl_NewObj\fR. +.PP +\fBTcl_GetStringFromObj\fR, \fBTcl_GetString\fR, \fBTcl_GetUnicodeFromObj\fR, +\fBTcl_GetUnicode\fR, \fBTcl_GetUniChar\fR, \fBTcl_GetCharLength\fR, and +\fBTcl_GetRange\fR all only work with an existing value; they do not +manipulate its reference count in any way. +.PP +\fBTcl_SetStringObj\fR, \fBTcl_SetUnicodeObj\fR, \fBTcl_AppendToObj\fR, +\fBTcl_AppendUnicodeToObj\fR, \fBTcl_AppendObjToObj\fR, +\fBTcl_AppendStringsToObj\fR, \fBTcl_AppendStringsToObjVA\fR, +\fBTcl_AppendLimitedToObj\fR, \fBTcl_AppendFormatToObj\fR, +\fBTcl_AppendPrintfToObj\fR, \fBTcl_SetObjLength\fR, and +\fBTcl_AttemptSetObjLength\fR and require their \fIobjPtr\fR to be an unshared +value (i.e, a reference count no more than 1) as they will modify it. +.PP +Additional arguments to the above functions (the \fIappendObjPtr\fR argument +to \fBTcl_AppendObjToObj\fR, values in the \fIobjv\fR argument to +\fBTcl_Format\fR, \fBTcl_AppendFormatToObj\fR, and \fBTcl_ConcatObj\fR) can +have any reference count, but reference counts of zero are not recommended. +.PP +\fBTcl_Format\fR and \fBTcl_AppendFormatToObj\fR may modify the interpreter +result, which involves changing the reference count of a value. + .SH "SEE ALSO" Tcl_NewObj(3), Tcl_IncrRefCount(3), Tcl_DecrRefCount(3), format(n), sprintf(3) .SH KEYWORDS diff --git a/doc/SubstObj.3 b/doc/SubstObj.3 index a2b6214..fa30fb1 100644 --- a/doc/SubstObj.3 +++ b/doc/SubstObj.3 @@ -62,6 +62,13 @@ result of the whole substitution on \fIobjPtr\fR will be truncated at the point immediately before the start of the command substitution, and no characters will be added to the result or substitutions performed after that point. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The \fIobjPtr\fR argument to \fBTcl_SubstObj\fR must not have a reference +count of zero. This function modifies the interpreter result, both on success +and on failure; the result of this function on success is exactly the current +interpreter result. Successful results should have their reference count +incremented if they are to be retained. .SH "SEE ALSO" subst(n) .SH KEYWORDS diff --git a/doc/TclZlib.3 b/doc/TclZlib.3 index 4a5df89..4d06923 100644 --- a/doc/TclZlib.3 +++ b/doc/TclZlib.3 @@ -262,6 +262,31 @@ file named by the \fBfilename\fR field was modified. Suitable for use with . The type of the uncompressed data (either \fBbinary\fR or \fBtext\fR) if known. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_ZlibDeflate\fR and \fBTcl_ZlibInflate\fR take a value with arbitrary +reference count for their \fIdataObj\fR and \fIdictObj\fR arguments (the +latter often being NULL instead), and set the interpreter result with their +output value (or an error). The existing interpreter result should not be +passed as any argument value unless an additional reference is held. +.PP +\fBTcl_ZlibStreamInit\fR takes a value with arbitrary reference count for its +\fIdictObj\fR argument; it only reads from it. The existing interpreter result +should not be passed unless an additional reference is held. +.PP +\fBTcl_ZlibStreamGetCommandName\fR returns a zero reference count value, much +like \fBTcl_NewObj\fR. +.PP +The \fIdataObj\fR argument to \fBTcl_ZlibStreamPut\fR is a value with +arbitrary reference count; it is only ever read from. +.PP +The \fIdataObj\fR argument to \fBTcl_ZlibStreamGet\fR is an unshared value +(see \fBTcl_IsShared\fR) that will be updated by the function. +.PP +The \fIcompDict\fR argument to \fBTcl_ZlibStreamSetCompressionDictionary\fR, +if non-NULL, may be duplicated or may have its reference count incremented. +Using a zero reference count value is not recommended. + .SH "PORTABILITY NOTES" These functions will fail gracefully if Tcl is not linked with the zlib library. diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index 62ceeab..904ecbe 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -10,13 +10,17 @@ .so man.macros .BS .SH NAME -Tcl_Main, Tcl_SetStartupScript, Tcl_GetStartupScript, Tcl_SetMainLoop \- main program, startup script, and event loop definition for Tcl-based applications +Tcl_Main, Tcl_MainEx, Tcl_MainExW, Tcl_SetStartupScript, Tcl_GetStartupScript, Tcl_SetMainLoop \- main program, startup script, and event loop definition for Tcl-based applications .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_Main\fR(\fIargc, argv, appInitProc\fR) .sp +\fBTcl_MainEx\fR(\fIargc, charargv, appInitProc, interp\fR) +.sp +\fBTcl_MainExW\fR(\fIargc, wideargv, appInitProc, interp\fR) +.sp \fBTcl_SetStartupScript\fR(\fIpath, encoding\fR) .sp Tcl_Obj * @@ -30,6 +34,10 @@ Number of elements in \fIargv\fR. .AP char *argv[] in Array of strings containing command-line arguments. On Windows, when using -DUNICODE, the parameter type changes to wchar_t *. +.AP char *charargv[] in +As argv, but does not change type to wchar_t. +.AP char *wideargv[] in +As argv, but type is always wchar_t. .AP Tcl_AppInitProc *appInitProc in Address of an application-specific initialization procedure. The value for this argument is usually \fBTcl_AppInit\fR. @@ -42,6 +50,8 @@ If non-NULL, location to write a copy of the (const char *) pointing to the encoding name. .AP Tcl_MainLoopProc *mainLoopProc in Address of an application-specific event loop procedure. +.AP Tcl_Interp *interp in +Already created Tcl Interpreter. .BE .SH DESCRIPTION .PP @@ -191,6 +201,15 @@ procedure (if any) returns, \fBTcl_Main\fR will also evaluate the \fBexit\fR command. .PP \fBTcl_Main\fR can not be used in stub-enabled extensions. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +\fBTcl_SetStartupScript\fR takes a value (or NULL) for its \fIpath\fR +argument, and will increment the reference count of it. +.PP +\fBTcl_GetStartupScript\fR returns a value with reference count at least 1, or +NULL. It's \fIencodingPtr\fR is also used (if non-NULL) to return a value with +a reference count at least 1, or NULL. In both cases, the owner of the values +is the current thread. .SH "SEE ALSO" tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3), exit(n), encoding(n) diff --git a/doc/TraceVar.3 b/doc/TraceVar.3 index 82aa7b8..7751cf7 100644 --- a/doc/TraceVar.3 +++ b/doc/TraceVar.3 @@ -359,6 +359,14 @@ Traces on a variable are always removed whenever the variable is deleted; the only time \fBTCL_TRACE_DESTROYED\fR is not set is for a whole-array trace invoked when only a single element of an array is unset. +.SH "REFERENCE COUNT MANAGEMENT" +.PP +When a \fIproc\fR callback is invoked, and that callback was installed with +the \fBTCL_TRACE_RESULT_OBJECT\fR flag, the result of the callback is a +Tcl_Obj reference when there is an error. The result will have its reference +count decremented once when no longer needed, or may have additional +references made to it (e.g., by setting it as the interpreter result with +\fBTcl_SetObjResult\fR). .SH BUGS .PP Array traces are not yet integrated with the Tcl \fBinfo exists\fR command, diff --git a/doc/UniCharIsAlpha.3 b/doc/UniCharIsAlpha.3 index 61490ed..a07af9a 100644 --- a/doc/UniCharIsAlpha.3 +++ b/doc/UniCharIsAlpha.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_UniCharIsAlnum, Tcl_UniCharIsAlpha, Tcl_UniCharIsControl, Tcl_UniCharIsDigit, Tcl_UniCharIsGraph, Tcl_UniCharIsLower, Tcl_UniCharIsPrint, Tcl_UniCharIsPunct, Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsWordChar \- routines for classification of Tcl_UniChar characters +Tcl_UniCharIsAlnum, Tcl_UniCharIsAlpha, Tcl_UniCharIsControl, Tcl_UniCharIsDigit, Tcl_UniCharIsGraph, Tcl_UniCharIsLower, Tcl_UniCharIsPrint, Tcl_UniCharIsPunct, Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsUnicode, Tcl_UniCharIsWordChar \- routines for classification of Tcl_UniChar characters .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -44,6 +44,9 @@ int \fBTcl_UniCharIsUpper\fR(\fIch\fR) .sp int +\fBTcl_UniCharIsUnicode\fR(\fIch\fR) +.sp +int \fBTcl_UniCharIsWordChar\fR(\fIch\fR) .SH ARGUMENTS .AS int ch @@ -81,6 +84,9 @@ with the various routines. .PP \fBTcl_UniCharIsUpper\fR tests if the character is an uppercase Unicode character. .PP +\fBTcl_UniCharIsUnicode\fR tests if the character is a Unicode character, not being +a surrogate or noncharacter. +.PP \fBTcl_UniCharIsWordChar\fR tests if the character is alphanumeric or a connector punctuation mark. @@ -233,10 +233,10 @@ characters. .PP \fBTcl_UtfCharComplete\fR returns 1 if the source UTF-8 string \fIsrc\fR of \fIlength\fR bytes is long enough to be decoded by -\fBTcl_UtfToUniChar\fR, or 0 otherwise. This function does not guarantee -that the UTF-8 string is properly formed. This routine is used by -procedures that are operating on a byte at a time and need to know if a -full Unicode character has been seen. +\fBTcl_UtfToUniChar\fR/\fBTcl_UtfNext\fR, or 0 otherwise. This function +does not guarantee that the UTF-8 string is properly formed. This routine +is used by procedures that are operating on a byte at a time and need to +know if a full Unicode character has been seen. .PP \fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings. It returns the number of Tcl_UniChars that are represented by the UTF-8 string @@ -257,7 +257,8 @@ Given \fIsrc\fR, a pointer to some location in a UTF-8 string, \fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the string. The caller must not ask for the next character after the last character in the string if the string is not terminated by a null -character. +character. \fBTcl_UtfCharComplete\fR can be used in that case to +make sure enough bytes are available before calling \fBTcl_UtfNext\fR. .PP \fBTcl_UtfPrev\fR is used to step backward through but not beyond the UTF-8 string that begins at \fIstart\fR. If the UTF-8 string is made @@ -274,12 +275,12 @@ always a pointer to a location in the string. It always returns a pointer to a byte that begins a character when scanning for characters beginning from \fIstart\fR. When \fIsrc\fR is greater than \fIstart\fR, it always returns a pointer less than \fIsrc\fR and greater than or -equal to (\fIsrc\fR - \fBTCL_UTF_MAX\fR). The character that begins +equal to (\fIsrc\fR - 4). The character that begins at the returned pointer is the first one that either includes the byte \fIsrc[-1]\fR, or might include it if the right trail bytes are present at \fIsrc\fR and greater. \fBTcl_UtfPrev\fR never reads the byte \fIsrc[0]\fR nor the byte \fIstart[-1]\fR nor the byte -\fIsrc[-\fBTCL_UTF_MAX\fI-1]\fR. +\fIsrc[-5]\fR. .PP \fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the Pascal Ord() function. It returns the Unicode character represented at the diff --git a/doc/WrongNumArgs.3 b/doc/WrongNumArgs.3 index 93e2ebb..533cb4f 100644 --- a/doc/WrongNumArgs.3 +++ b/doc/WrongNumArgs.3 @@ -73,6 +73,12 @@ is now an \fIindexObject\fR because it was passed to .CS wrong # args: should be "foo barfly fileName count" .CE +.SH "REFERENCE COUNT MANAGEMENT" +.PP +The \fIobjv\fR argument to \fBTcl_WrongNumArgs\fR should be the exact +arguments passed to the command or method implementation function that is +calling \fBTcl_WrongNumArgs\fR. As such, all values referenced in it should +have reference counts greater than zero; this is usually a non-issue. .SH "SEE ALSO" Tcl_GetIndexFromObj(3) .SH KEYWORDS diff --git a/doc/encoding.n b/doc/encoding.n index 5aac181..e78a8e7 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -81,29 +81,13 @@ omitted then the command returns the current system encoding. The system encoding is used whenever Tcl passes strings to system calls. .SH EXAMPLE .PP -It is common practice to write script files using a text editor that -produces output in the euc-jp encoding, which represents the ASCII -characters as singe bytes and Japanese characters as two bytes. This -makes it easy to embed literal strings that correspond to non-ASCII -characters by simply typing the strings in place in the script. -However, because the \fBsource\fR command always reads files using the -current system encoding, Tcl will only source such files correctly -when the encoding used to write the file is the same. This tends not -to be true in an internationalized setting. For example, if such a -file was sourced in North America (where the ISO8859\-1 is normally -used), each byte in the file would be treated as a separate character -that maps to the 00 page in Unicode. The resulting Tcl strings will -not contain the expected Japanese characters. Instead, they will -contain a sequence of Latin-1 characters that correspond to the bytes -of the original string. The \fBencoding\fR command can be used to -convert this string to the expected Japanese Unicode characters. For -example, +The following example converts a byte sequence in Japanese euc-jp encoding to a TCL string: .PP .CS set s [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"] .CE .PP -would return the Unicode string +The result is the unicode codepoint: .QW "\eu306F" , which is the Hiragana letter HA. .SH "SEE ALSO" @@ -22,6 +22,10 @@ of one or more subprocesses to execute. The arguments take the form of a standard shell pipeline where each \fIarg\fR becomes one word of a command, and each distinct command becomes a subprocess. +The result of the command is the standard output of the final subprocess in +the pipeline, interpreted using the system \fBencoding\fR; to use any other +encoding (especially including binary data), the pipeline must be +\fBopen\fRed, configured and read explicitly. .PP If the initial arguments to \fBexec\fR start with \fB\-\fR then they are treated as command-line switches and are not part @@ -411,7 +415,9 @@ With the file \fIcmp.bat\fR looking something like: .CS @gcc %* .CE +.PP or like another variant using single parameters: +.PP .CS @gcc %1 %2 %3 %4 %5 %6 %7 %8 %9 .CE @@ -6,14 +6,14 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH "http" n 2.9 http "Tcl Bundled Packages" +.TH "http" n 2.10 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME http \- Client-side implementation of the HTTP/1.1 protocol .SH SYNOPSIS -\fBpackage require http\fI ?\fB2.9\fR? +\fBpackage require http\fI ?\fB2.10\fR? .\" See Also -useragent option documentation in body! .sp \fB::http::config\fR ?\fI\-option value\fR ...? @@ -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,32 +36,32 @@ 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: .PP .CS -typedef int \fBTcl_PackageInitProc\fR( +typedef int \fBTcl_LibraryInitProc\fR( Tcl_Interp *\fIinterp\fR); .CE .PP The \fIinterp\fR argument identifies the interpreter in which the -package is to be loaded. The initialization procedure must return +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,37 +73,37 @@ interpreters, then the first \fBload\fR will load the code and call the initialization procedure; subsequent \fBload\fRs will call the initialization procedure without loading the code again. For Tcl versions lower than 8.5, it is not possible to unload or reload a -package. From version 8.5 however, the \fBunload\fR command allows the unloading +library. From version 8.5 however, the \fBunload\fR command allows the unloading of libraries loaded with \fBload\fR, for libraries that are aware of the Tcl's unloading mechanism. .PP -The \fBload\fR command also supports packages that are statically -linked with the application, if those packages have been registered -by calling the \fBTcl_StaticPackage\fR procedure. -If \fIfileName\fR is an empty string, then \fIpackageName\fR must +The \fBload\fR command also supports libraries that are statically +linked with the application, if those libraries have been registered +by calling the \fBTcl_StaticLibrary\fR procedure. +If \fIfileName\fR is an empty string, then \fIprefix\fR must be specified. .PP -If \fIpackageName\fR is omitted or specified as an empty string, -Tcl tries to guess the name of the package. -This may be done differently on different platforms. -The default guess, which is used on most UNIX platforms, is to -take the last element of \fIfileName\fR, strip off the first -three characters if they are \fBlib\fR, then strip off the next -three characters if they are \fBtcl\fR, and use any following -alphabetic and underline characters as the module name. -For example, the command \fBload libtclxyz4.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, then strip off the next three characters if they +are \fBtcl\fR, and use any following alphabetic and +underline characters, converted to titlecase as the prefix. +For example, the command \fBload libxyz4.2.so\fR uses the prefix +\fBXyz\fR and the command \fBload bin/last.so {}\fR uses the +prefix \fBLast\fR. +.PP +If \fIfileName\fR is an empty string, then \fIprefix\fR must be specified. -The \fBload\fR command first searches for a statically loaded package -(one that has been registered by calling the \fBTcl_StaticPackage\fR +The \fBload\fR command first searches for a statically loaded library +(one that has been registered by calling the \fBTcl_StaticLibrary\fR procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded -package by that name, and uses it if it is found. If several +library by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of -the package, Tcl picks the file that was loaded first. +the library, Tcl picks the file that was loaded first. .PP If \fB\-global\fR is specified preceding the filename, all symbols found in the shared library are exported for global use by other @@ -112,7 +111,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 @@ -155,7 +154,7 @@ The following is a minimal extension: .CS #include <tcl.h> #include <stdio.h> -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; @@ -189,7 +188,7 @@ switch $tcl_platform(platform) { foo .CE .SH "SEE ALSO" -info sharedlibextension, package(n), Tcl_StaticPackage(3), safe(n) +info sharedlibextension, package(n), Tcl_StaticLibrary(3), safe(n) .SH KEYWORDS binary code, dynamic library, load, safe interpreter, shared library '\"Local Variables: diff --git a/doc/msgcat.n b/doc/msgcat.n index 74a7020..1384fa8 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -219,7 +219,7 @@ As an example, the user may prefer French or English text. This may be configure .PP .VS "TIP 499" .TP -\fB::msgcat:mcloadedlocales subcommand\fR ?\fIlocale\fR? +\fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR? . This group of commands manage the list of loaded locales for packages not setting a package locale. .PP @@ -72,7 +72,7 @@ indicate that the opened channel should be configured as if with the reading or writing of binary data. .PP In the second form, \fIaccess\fR consists of a list of any of the -following flags, all of which have the standard POSIX meanings. +following flags, most of which have the standard POSIX meanings. One of the flags must be either \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR. .TP 15 \fBRDONLY\fR @@ -453,6 +453,12 @@ application are competing for the console at the same time. If the command pipeline is started from a script, so that Tcl is not accessing the console, or if the command pipeline does not use standard input or output, but is redirected from or to a file, then the above problems do not occur. +.PP +Files opened in the +.QW \fBa\fR +mode or with the \fBAPPEND\fR flag set are implemented by seeking immediately +before each write, which is not an atomic operation and does not carry the +guarantee of strict appending that is present on POSIX platforms. .RE .TP \fBUnix\fR\0\0\0\0\0\0\0 @@ -527,6 +533,19 @@ Note that the equivalent options exist on Unix, but are on the serial channel type. .VE "8.7, TIP 160" .SH "EXAMPLES" +Open a file for writing, forcing it to be created and raising an error if it +already exists. +.PP +.CS +set myNewFile [\fBopen\fR filename.txt {WRONLY CREAT EXCL}] +.CE +.PP +Open a file for writing as a log file. +.PP +.CS +set myLogFile [\fBopen\fR filename.log "a"] +fconfigure $myLogFile -buffering line +.CE .PP Open a command pipeline and catch any errors: .PP @@ -538,6 +557,18 @@ if {[catch {close $fl} err]} { } .CE .PP +Open a command pipeline and read binary data from it. Note the unusual form +with +.QW |[list +that handles non-trivial edge cases with arguments that potentially have +spaces in. +.PP +.CS +set fl [\fBopen\fR |[list create_image_data $input] "rb"] +set binData [read $fl] +close $fl +.CE +.PP .VS "8.7, TIP 160" Read a password securely from the user (assuming that the script is being run interactively): diff --git a/doc/packagens.n b/doc/packagens.n index 65535ef..d55151f 100644 --- a/doc/packagens.n +++ b/doc/packagens.n @@ -29,7 +29,7 @@ This parameter specifies the name of the package. It is required. This parameter specifies the version of the package. It is required. .TP \fB\-load \fIfilespec\fR -This parameter specifies a binary library that must be loaded with the +This parameter specifies a library that must be loaded with the \fBload\fR command. \fIfilespec\fR is a list with two elements. The first element is the name of the file to load. The second, optional element is a list of commands supplied by loading that file. If the 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, diff --git a/doc/refchan.n b/doc/refchan.n index 8737556..c17117d 100644 --- a/doc/refchan.n +++ b/doc/refchan.n @@ -322,6 +322,19 @@ invocation (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE +.TP +\fIcmdPrefix \fBtruncate\fR \fIchannelId length\fR +. +This \fIoptional\fR subcommand handles changing the length of the +underlying data stream for the channel \fIchannelId\fR. Its length +gets set to \fIlength\fR. +.RS +.PP +If the subcommand throws an error the command which caused its +invocation (usually \fBchan truncate\fR) will appear to have thrown +this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, +etc.) is treated as and converted to an error. +.RE .SH NOTES Some of the functions supported in channels defined in Tcl's C interface are not available to channels reflected to the Tcl level. diff --git a/doc/string.n b/doc/string.n index 7cd53ca..f3d7616 100644 --- a/doc/string.n +++ b/doc/string.n @@ -404,7 +404,7 @@ Formally, the \fBstring bytelength\fR operation returns the content of the \fIlength\fR field of the \fBTcl_Obj\fR structure, after calling \fBTcl_GetString\fR to ensure that the \fIbytes\fR field is populated. This is highly unlikely to be useful to Tcl scripts, as Tcl's internal -encoding is not strict UTF\-8, but rather a modified CESU\-8 with a +encoding is not strict UTF\-8, but rather a modified WTF\-8 with a denormalized NUL (identical to that used in a number of places by Java's serialization mechanism) to enable basic processing with non-Unicode-aware C functions. As this representation should only @@ -413,10 +413,10 @@ store the representation is of very low value (except to C extension code, which has direct access for the purpose of memory management, etc.) .PP -\fICompatibility note:\fR it is likely that this subcommand will be -withdrawn in a future version of Tcl. It is better to use the -\fBencoding convertto\fR command to convert a string to a known -encoding and then apply \fBstring length\fR to that. +\fICompatibility note:\fR This subcommand is deprecated and will +be removed in Tcl 9.0. It is better to use the \fBencoding convertto\fR +command to convert a string to a known encoding (e.g. "utf-8" or "cesu-8") +and then apply \fBstring length\fR to that. .PP .CS \fBstring length\fR [encoding convertto utf-8 $theString] diff --git a/doc/unload.n b/doc/unload.n index 0a8e99b..00b709b 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 @@ -90,7 +90,7 @@ detached from the process. The unload procedure must match the following prototype: .PP .CS -typedef int \fBTcl_PackageUnloadProc\fR( +typedef int \fBTcl_LibraryUnloadProc\fR( Tcl_Interp *\fIinterp\fR, int \fIflags\fR); .CE @@ -114,19 +114,20 @@ 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, then strip off the next three characters if they +are \fBtcl\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/doc/zipfs.n b/doc/zipfs.n index da2e026..a75a70b 100644 --- a/doc/zipfs.n +++ b/doc/zipfs.n @@ -84,7 +84,7 @@ Return a list of all files in the mounted zipfs, or just those matching \fIpattern\fR (optionally controlled by the option parameters). The order of the names in the list is arbitrary. .TP -\fBzipfs mount ?\fImountpoint\fR? ?\fIzipfile\fR? ?\fIpassword\fR? +\fBzipfs mount\fR ?\fImountpoint\fR? ?\fIzipfile\fR? ?\fIpassword\fR? . The \fBzipfs mount\fR command mounts a ZIP archive file as a Tcl virtual filesystem at \fImountpoint\fR. After this command executes, files contained @@ -146,6 +146,8 @@ the ZIP archive, otherwise the file returned by \fBinfo nameofexecutable\fR (see \fBzipfs mkkey\fR) is placed between the image and ZIP chunks of the output file and the contents of the ZIP chunk are protected with that password. +If the starting image has a ZIP archive already attached to it, it is removed +from the copy in \fIoutfile\fR before the new ZIP archive is added. .PP If there is a file, \fBmain.tcl\fR, in the root directory of the resulting archive and the image file that the archive is attached to is a \fBtclsh\fR diff --git a/generic/regc_lex.c b/generic/regc_lex.c index 2c0ddeb..bad91ce 100644 --- a/generic/regc_lex.c +++ b/generic/regc_lex.c @@ -427,7 +427,7 @@ next( if (INCON(L_BBND) && NEXT1('}')) { v->now++; INTOCON(L_BRE); - RET('}'); + RETV('}', 1); } else { FAILW(REG_BADBR); } diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 5cee41e..cf751ba 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -227,7 +227,7 @@ static const crange alphaRangeTable[] = { {0x119A0, 0x119A7}, {0x119AA, 0x119D0}, {0x11A0B, 0x11A32}, {0x11A5C, 0x11A89}, {0x11AB0, 0x11AF8}, {0x11C00, 0x11C08}, {0x11C0A, 0x11C2E}, {0x11C72, 0x11C8F}, {0x11D00, 0x11D06}, {0x11D0B, 0x11D30}, {0x11D60, 0x11D65}, {0x11D6A, 0x11D89}, - {0x11EE0, 0x11EF2}, {0x12000, 0x12399}, {0x12480, 0x12543}, {0x12F90, 0x12FF2}, + {0x11EE0, 0x11EF2}, {0x12000, 0x12399}, {0x12480, 0x12543}, {0x12F90, 0x12FF0}, {0x13000, 0x1342E}, {0x14400, 0x14646}, {0x16800, 0x16A38}, {0x16A40, 0x16A5E}, {0x16A70, 0x16ABE}, {0x16AD0, 0x16AED}, {0x16B00, 0x16B2F}, {0x16B40, 0x16B43}, {0x16B63, 0x16B77}, {0x16B7D, 0x16B8F}, {0x16E40, 0x16E7F}, {0x16F00, 0x16F4A}, @@ -247,7 +247,7 @@ static const crange alphaRangeTable[] = { {0x1EE34, 0x1EE37}, {0x1EE4D, 0x1EE4F}, {0x1EE67, 0x1EE6A}, {0x1EE6C, 0x1EE72}, {0x1EE74, 0x1EE77}, {0x1EE79, 0x1EE7C}, {0x1EE80, 0x1EE89}, {0x1EE8B, 0x1EE9B}, {0x1EEA1, 0x1EEA3}, {0x1EEA5, 0x1EEA9}, {0x1EEAB, 0x1EEBB}, {0x20000, 0x2A6DF}, - {0x2A700, 0x2B737}, {0x2B740, 0x2B81D}, {0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0}, + {0x2A700, 0x2B738}, {0x2B740, 0x2B81D}, {0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0}, {0x2F800, 0x2FA1D}, {0x30000, 0x3134A} #endif }; @@ -256,11 +256,11 @@ static const crange alphaRangeTable[] = { static const chr alphaCharTable[] = { 0xAA, 0xB5, 0xBA, 0x2EC, 0x2EE, 0x376, 0x377, 0x37F, 0x386, - 0x38C, 0x559, 0x66E, 0x66F, 0x6D5, 0x6E5, 0x6E6, 0x6EE, 0x6EF, + 0x38C, 0x559, 0x66E, 0x66F, 0x6D5, 0x6E5, 0x6E6, 0x6EE, 0x6EF, 0x6FF, 0x710, 0x7B1, 0x7F4, 0x7F5, 0x7FA, 0x81A, 0x824, 0x828, - 0x93D, 0x950, 0x98F, 0x990, 0x9B2, 0x9BD, 0x9CE, 0x9DC, 0x9DD, - 0x9F0, 0x9F1, 0x9FC, 0xA0F, 0xA10, 0xA32, 0xA33, 0xA35, 0xA36, - 0xA38, 0xA39, 0xA5E, 0xAB2, 0xAB3, 0xABD, 0xAD0, 0xAE0, 0xAE1, + 0x93D, 0x950, 0x98F, 0x990, 0x9B2, 0x9BD, 0x9CE, 0x9DC, 0x9DD, + 0x9F0, 0x9F1, 0x9FC, 0xA0F, 0xA10, 0xA32, 0xA33, 0xA35, 0xA36, + 0xA38, 0xA39, 0xA5E, 0xAB2, 0xAB3, 0xABD, 0xAD0, 0xAE0, 0xAE1, 0xAF9, 0xB0F, 0xB10, 0xB32, 0xB33, 0xB3D, 0xB5C, 0xB5D, 0xB71, 0xB83, 0xB99, 0xB9A, 0xB9C, 0xB9E, 0xB9F, 0xBA3, 0xBA4, 0xBD0, 0xC3D, 0xC5D, 0xC60, 0xC61, 0xC80, 0xCBD, 0xCDD, 0xCDE, 0xCE0, @@ -274,13 +274,13 @@ static const chr alphaCharTable[] = { 0xA7D1, 0xA7D3, 0xA8FB, 0xA8FD, 0xA8FE, 0xA9CF, 0xAA7A, 0xAAB1, 0xAAB5, 0xAAB6, 0xAAC0, 0xAAC2, 0xFB1D, 0xFB3E, 0xFB40, 0xFB41, 0xFB43, 0xFB44 #if CHRBITS > 16 - ,0x1003C, 0x1003D, 0x10594, 0x10595, 0x105BB, 0x105BC, 0x10808, 0x10837, 0x10838, + ,0x1003C, 0x1003D, 0x10594, 0x10595, 0x105BB, 0x105BC, 0x10808, 0x10837, 0x10838, 0x1083C, 0x108F4, 0x108F5, 0x109BE, 0x109BF, 0x10A00, 0x10EB0, 0x10EB1, 0x10F27, 0x11071, 0x11072, 0x11075, 0x11144, 0x11147, 0x11176, 0x111DA, 0x111DC, 0x11288, 0x1130F, 0x11310, 0x11332, 0x11333, 0x1133D, 0x11350, 0x114C4, 0x114C5, 0x114C7, 0x11644, 0x116B8, 0x11909, 0x11915, 0x11916, 0x1193F, 0x11941, 0x119E1, 0x119E3, 0x11A00, 0x11A3A, 0x11A50, 0x11A9D, 0x11C40, 0x11D08, 0x11D09, 0x11D46, 0x11D67, - 0x11D68, 0x11D98, 0x11FB0, 0x16F50, 0x16FE0, 0x16FE1, 0x16FE3, 0x1AFFD, 0x1AFFE, + 0x11D68, 0x11D98, 0x11FB0, 0x16F50, 0x16FE0, 0x16FE1, 0x16FE3, 0x1AFFD, 0x1AFFE, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D4BB, 0x1D546, 0x1E14E, 0x1E7ED, 0x1E7EE, 0x1E94B, 0x1EE21, 0x1EE22, 0x1EE24, 0x1EE27, 0x1EE39, 0x1EE3B, 0x1EE42, 0x1EE47, 0x1EE49, 0x1EE4B, 0x1EE51, 0x1EE52, 0x1EE54, 0x1EE57, 0x1EE59, 0x1EE5B, @@ -299,8 +299,8 @@ static const crange controlRangeTable[] = { {0x202A, 0x202E}, {0x2060, 0x2064}, {0x2066, 0x206F}, {0xE000, 0xF8FF}, {0xFFF9, 0xFFFB} #if CHRBITS > 16 - ,{0x13430, 0x13438}, {0x1BCA0, 0x1BCA3}, {0x1CF42, 0x1CF46}, {0x1D173, 0x1D17A}, - {0xE0020, 0xE007F}, {0xF0000, 0xFFFFD}, {0x100000, 0x10FFFD} + ,{0x13430, 0x13438}, {0x1BCA0, 0x1BCA3}, {0x1D173, 0x1D17A}, {0xE0020, 0xE007F}, + {0xF0000, 0xFFFFD}, {0x100000, 0x10FFFD} #endif }; @@ -381,23 +381,24 @@ static const crange punctRangeTable[] = { static const chr punctCharTable[] = { 0x3A, 0x3B, 0x3F, 0x40, 0x5F, 0x7B, 0x7D, 0xA1, 0xA7, - 0xAB, 0xB6, 0xB7, 0xBB, 0xBF, 0x37E, 0x387, 0x589, 0x58A, + 0xAB, 0xB6, 0xB7, 0xBB, 0xBF, 0x37E, 0x387, 0x589, 0x58A, 0x5BE, 0x5C0, 0x5C3, 0x5C6, 0x5F3, 0x5F4, 0x609, 0x60A, 0x60C, 0x60D, 0x61B, 0x6D4, 0x85E, 0x964, 0x965, 0x970, 0x9FD, 0xA76, 0xAF0, 0xC77, 0xC84, 0xDF4, 0xE4F, 0xE5A, 0xE5B, 0xF14, 0xF85, - 0xFD9, 0xFDA, 0x10FB, 0x1400, 0x166E, 0x169B, 0x169C, 0x1735, 0x1736, + 0xFD9, 0xFDA, 0x10FB, 0x1400, 0x166E, 0x169B, 0x169C, 0x1735, 0x1736, 0x1944, 0x1945, 0x1A1E, 0x1A1F, 0x1B7D, 0x1B7E, 0x1C7E, 0x1C7F, 0x1CD3, 0x207D, 0x207E, 0x208D, 0x208E, 0x2329, 0x232A, 0x27C5, 0x27C6, 0x29FC, 0x29FD, 0x2CFE, 0x2CFF, 0x2D70, 0x3030, 0x303D, 0x30A0, 0x30FB, 0xA4FE, 0xA4FF, 0xA673, 0xA67E, 0xA8CE, 0xA8CF, 0xA8FC, 0xA92E, 0xA92F, 0xA95F, - 0xA9DE, 0xA9DF, 0xAADE, 0xAADF, 0xAAF0, 0xAAF1, 0xABEB, 0xFD3E, 0xFD3F, + 0xA9DE, 0xA9DF, 0xAADE, 0xAADF, 0xAAF0, 0xAAF1, 0xABEB, 0xFD3E, 0xFD3F, 0xFE63, 0xFE68, 0xFE6A, 0xFE6B, 0xFF1A, 0xFF1B, 0xFF1F, 0xFF20, 0xFF3F, 0xFF5B, 0xFF5D #if CHRBITS > 16 ,0x1039F, 0x103D0, 0x1056F, 0x10857, 0x1091F, 0x1093F, 0x10A7F, 0x10EAD, 0x110BB, 0x110BC, 0x11174, 0x11175, 0x111CD, 0x111DB, 0x112A9, 0x1145A, 0x1145B, 0x1145D, 0x114C6, 0x116B9, 0x1183B, 0x119E2, 0x11C70, 0x11C71, 0x11EF7, 0x11EF8, 0x11FFF, - 0x16A6E, 0x16A6F, 0x16AF5, 0x16B44, 0x16FE2, 0x1BC9F, 0x1E95E, 0x1E95F + 0x12FF1, 0x12FF2, 0x16A6E, 0x16A6F, 0x16AF5, 0x16B44, 0x16FE2, 0x1BC9F, 0x1E95E, + 0x1E95F #endif }; @@ -447,7 +448,8 @@ static const crange lowerRangeTable[] = { {0x1D5EE, 0x1D607}, {0x1D622, 0x1D63B}, {0x1D656, 0x1D66F}, {0x1D68A, 0x1D6A5}, {0x1D6C2, 0x1D6DA}, {0x1D6DC, 0x1D6E1}, {0x1D6FC, 0x1D714}, {0x1D716, 0x1D71B}, {0x1D736, 0x1D74E}, {0x1D750, 0x1D755}, {0x1D770, 0x1D788}, {0x1D78A, 0x1D78F}, - {0x1D7AA, 0x1D7C2}, {0x1D7C4, 0x1D7C9}, {0x1DF00, 0x1DF1E}, {0x1E922, 0x1E943} + {0x1D7AA, 0x1D7C2}, {0x1D7C4, 0x1D7C9}, {0x1DF00, 0x1DF09}, {0x1DF0B, 0x1DF1E}, + {0x1E922, 0x1E943} #endif }; @@ -505,7 +507,7 @@ static const chr lowerCharTable[] = { 0x2C9F, 0x2CA1, 0x2CA3, 0x2CA5, 0x2CA7, 0x2CA9, 0x2CAB, 0x2CAD, 0x2CAF, 0x2CB1, 0x2CB3, 0x2CB5, 0x2CB7, 0x2CB9, 0x2CBB, 0x2CBD, 0x2CBF, 0x2CC1, 0x2CC3, 0x2CC5, 0x2CC7, 0x2CC9, 0x2CCB, 0x2CCD, 0x2CCF, 0x2CD1, 0x2CD3, - 0x2CD5, 0x2CD7, 0x2CD9, 0x2CDB, 0x2CDD, 0x2CDF, 0x2CE1, 0x2CE3, 0x2CE4, + 0x2CD5, 0x2CD7, 0x2CD9, 0x2CDB, 0x2CDD, 0x2CDF, 0x2CE1, 0x2CE3, 0x2CE4, 0x2CEC, 0x2CEE, 0x2CF3, 0x2D27, 0x2D2D, 0xA641, 0xA643, 0xA645, 0xA647, 0xA649, 0xA64B, 0xA64D, 0xA64F, 0xA651, 0xA653, 0xA655, 0xA657, 0xA659, 0xA65B, 0xA65D, 0xA65F, 0xA661, 0xA663, 0xA665, 0xA667, 0xA669, 0xA66B, @@ -564,7 +566,7 @@ static const chr upperCharTable[] = { 0x14A, 0x14C, 0x14E, 0x150, 0x152, 0x154, 0x156, 0x158, 0x15A, 0x15C, 0x15E, 0x160, 0x162, 0x164, 0x166, 0x168, 0x16A, 0x16C, 0x16E, 0x170, 0x172, 0x174, 0x176, 0x178, 0x179, 0x17B, 0x17D, - 0x181, 0x182, 0x184, 0x186, 0x187, 0x193, 0x194, 0x19C, 0x19D, + 0x181, 0x182, 0x184, 0x186, 0x187, 0x193, 0x194, 0x19C, 0x19D, 0x19F, 0x1A0, 0x1A2, 0x1A4, 0x1A6, 0x1A7, 0x1A9, 0x1AC, 0x1AE, 0x1AF, 0x1B5, 0x1B7, 0x1B8, 0x1BC, 0x1C4, 0x1C7, 0x1CA, 0x1CD, 0x1CF, 0x1D1, 0x1D3, 0x1D5, 0x1D7, 0x1D9, 0x1DB, 0x1DE, 0x1E0, @@ -575,7 +577,7 @@ static const chr upperCharTable[] = { 0x230, 0x232, 0x23A, 0x23B, 0x23D, 0x23E, 0x241, 0x248, 0x24A, 0x24C, 0x24E, 0x370, 0x372, 0x376, 0x37F, 0x386, 0x38C, 0x38E, 0x38F, 0x3CF, 0x3D8, 0x3DA, 0x3DC, 0x3DE, 0x3E0, 0x3E2, 0x3E4, - 0x3E6, 0x3E8, 0x3EA, 0x3EC, 0x3EE, 0x3F4, 0x3F7, 0x3F9, 0x3FA, + 0x3E6, 0x3E8, 0x3EA, 0x3EC, 0x3EE, 0x3F4, 0x3F7, 0x3F9, 0x3FA, 0x460, 0x462, 0x464, 0x466, 0x468, 0x46A, 0x46C, 0x46E, 0x470, 0x472, 0x474, 0x476, 0x478, 0x47A, 0x47C, 0x47E, 0x480, 0x48A, 0x48C, 0x48E, 0x490, 0x492, 0x494, 0x496, 0x498, 0x49A, 0x49C, @@ -755,7 +757,7 @@ static const crange graphRangeTable[] = { {0x18D00, 0x18D08}, {0x1AFF0, 0x1AFF3}, {0x1AFF5, 0x1AFFB}, {0x1B000, 0x1B122}, {0x1B150, 0x1B152}, {0x1B164, 0x1B167}, {0x1B170, 0x1B2FB}, {0x1BC00, 0x1BC6A}, {0x1BC70, 0x1BC7C}, {0x1BC80, 0x1BC88}, {0x1BC90, 0x1BC99}, {0x1BC9C, 0x1BC9F}, - {0x1CF00, 0x1CF2D}, {0x1CF30, 0x1CF41}, {0x1CF50, 0x1CFC4}, {0x1D000, 0x1D0F5}, + {0x1CF00, 0x1CF2D}, {0x1CF30, 0x1CF46}, {0x1CF50, 0x1CFC3}, {0x1D000, 0x1D0F5}, {0x1D100, 0x1D126}, {0x1D129, 0x1D172}, {0x1D17B, 0x1D1EA}, {0x1D200, 0x1D245}, {0x1D2E0, 0x1D2F3}, {0x1D300, 0x1D356}, {0x1D360, 0x1D378}, {0x1D400, 0x1D454}, {0x1D456, 0x1D49C}, {0x1D4A9, 0x1D4AC}, {0x1D4AE, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, @@ -779,7 +781,7 @@ static const crange graphRangeTable[] = { {0x1F900, 0x1FA53}, {0x1FA60, 0x1FA6D}, {0x1FA70, 0x1FA74}, {0x1FA78, 0x1FA7C}, {0x1FA80, 0x1FA86}, {0x1FA90, 0x1FAAC}, {0x1FAB0, 0x1FABA}, {0x1FAC0, 0x1FAC5}, {0x1FAD0, 0x1FAD9}, {0x1FAE0, 0x1FAE7}, {0x1FAF0, 0x1FAF6}, {0x1FB00, 0x1FB92}, - {0x1FB94, 0x1FBCA}, {0x1FBF0, 0x1FBF9}, {0x20000, 0x2A6DF}, {0x2A700, 0x2B737}, + {0x1FB94, 0x1FBCA}, {0x1FBF0, 0x1FBF9}, {0x20000, 0x2A6DF}, {0x2A700, 0x2B738}, {0x2B740, 0x2B81D}, {0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0}, {0x2F800, 0x2FA1D}, {0x30000, 0x3134A}, {0xE0100, 0xE01EF} #endif @@ -789,18 +791,18 @@ static const crange graphRangeTable[] = { static const chr graphCharTable[] = { 0x38C, 0x85E, 0x98F, 0x990, 0x9B2, 0x9C7, 0x9C8, 0x9D7, 0x9DC, - 0x9DD, 0xA0F, 0xA10, 0xA32, 0xA33, 0xA35, 0xA36, 0xA38, 0xA39, + 0x9DD, 0xA0F, 0xA10, 0xA32, 0xA33, 0xA35, 0xA36, 0xA38, 0xA39, 0xA3C, 0xA47, 0xA48, 0xA51, 0xA5E, 0xAB2, 0xAB3, 0xAD0, 0xB0F, - 0xB10, 0xB32, 0xB33, 0xB47, 0xB48, 0xB5C, 0xB5D, 0xB82, 0xB83, + 0xB10, 0xB32, 0xB33, 0xB47, 0xB48, 0xB5C, 0xB5D, 0xB82, 0xB83, 0xB99, 0xB9A, 0xB9C, 0xB9E, 0xB9F, 0xBA3, 0xBA4, 0xBD0, 0xBD7, - 0xC55, 0xC56, 0xC5D, 0xCD5, 0xCD6, 0xCDD, 0xCDE, 0xCF1, 0xCF2, + 0xC55, 0xC56, 0xC5D, 0xCD5, 0xCD6, 0xCDD, 0xCDE, 0xCF1, 0xCF2, 0xDBD, 0xDCA, 0xDD6, 0xE81, 0xE82, 0xE84, 0xEA5, 0xEC6, 0x10C7, 0x10CD, 0x1258, 0x12C0, 0x1772, 0x1773, 0x1940, 0x1F59, 0x1F5B, 0x1F5D, 0x2070, 0x2071, 0x2D27, 0x2D2D, 0x2D6F, 0x2D70, 0xA7D0, 0xA7D1, 0xA7D3, 0xFB3E, 0xFB40, 0xFB41, 0xFB43, 0xFB44, 0xFDCF, 0xFFFC, 0xFFFD #if CHRBITS > 16 ,0x1003C, 0x1003D, 0x101A0, 0x10594, 0x10595, 0x105BB, 0x105BC, 0x10808, 0x10837, - 0x10838, 0x1083C, 0x108F4, 0x108F5, 0x1093F, 0x10A05, 0x10A06, 0x10EB0, 0x10EB1, + 0x10838, 0x1083C, 0x108F4, 0x108F5, 0x1093F, 0x10A05, 0x10A06, 0x10EB0, 0x10EB1, 0x11288, 0x1130F, 0x11310, 0x11332, 0x11333, 0x11347, 0x11348, 0x11350, 0x11357, 0x11909, 0x11915, 0x11916, 0x11937, 0x11938, 0x11D08, 0x11D09, 0x11D3A, 0x11D3C, 0x11D3D, 0x11D67, 0x11D68, 0x11D90, 0x11D91, 0x11FB0, 0x16FF0, 0x16FF1, 0x1AFFD, diff --git a/generic/tcl.decls b/generic/tcl.decls index 5895946..3dec972 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -860,8 +860,8 @@ declare 243 { void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr) } declare 244 {nostub {Don't use this function in a stub-enabled extension}} { - void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, - Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) + void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, + Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) } declare 245 {deprecated {No longer in use, changed to macro}} { int Tcl_StringMatch(const char *str, const char *pattern) @@ -1163,7 +1163,7 @@ declare 325 { const char *Tcl_UtfAtIndex(const char *src, int index) } declare 326 { - int Tcl_UtfCharComplete(const char *src, int length) + int TclUtfCharComplete(const char *src, int length) } declare 327 { int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) @@ -1175,10 +1175,10 @@ declare 329 { const char *Tcl_UtfFindLast(const char *src, int ch) } declare 330 { - const char *Tcl_UtfNext(const char *src) + const char *TclUtfNext(const char *src) } declare 331 { - const char *Tcl_UtfPrev(const char *src, const char *start) + const char *TclUtfPrev(const char *src, const char *start) } declare 332 { int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, @@ -1581,8 +1581,8 @@ declare 443 { } declare 444 { int Tcl_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, - const char *sym2, Tcl_PackageInitProc **proc1Ptr, - Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, + const char *sym2, Tcl_LibraryInitProc **proc1Ptr, + Tcl_LibraryInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr) } declare 445 { @@ -2413,6 +2413,20 @@ declare 653 { unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) } +# TIP #575 +declare 654 { + int Tcl_UtfCharComplete(const char *src, int length) +} +declare 655 { + const char *Tcl_UtfNext(const char *src) +} +declare 656 { + const char *Tcl_UtfPrev(const char *src, const char *start) +} +declare 657 { + int Tcl_UniCharIsUnicode(int ch) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## @@ -2437,6 +2451,9 @@ declare 0 win { declare 1 win { char *Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr) } +declare 3 win { + void Tcl_WinConvertError(unsigned errCode) +} ################################ # Mac OS X specific functions @@ -2467,8 +2484,8 @@ export { Tcl_Interp *interp) } export { - void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, - Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) + void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, + Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) } export { void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) @@ -2497,6 +2514,9 @@ export { export { void Tcl_InitSubsystems(void) } +export { + int TclZipfs_AppHook(int *argc, char ***argv) +} # Local Variables: # mode: tcl diff --git a/generic/tcl.h b/generic/tcl.h index 38dda28..4bf1464 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -697,8 +697,8 @@ typedef int (Tcl_MathProc) (ClientData clientData, Tcl_Interp *interp, typedef void (Tcl_NamespaceDeleteProc) (ClientData clientData); typedef int (Tcl_ObjCmdProc) (ClientData clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); -typedef int (Tcl_PackageInitProc) (Tcl_Interp *interp); -typedef int (Tcl_PackageUnloadProc) (Tcl_Interp *interp, int flags); +typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); +typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); typedef void (Tcl_TcpAcceptProc) (ClientData callbackData, Tcl_Channel chan, char *address, int port); @@ -717,7 +717,12 @@ typedef void (Tcl_ServiceModeHookProc) (int mode); typedef ClientData (Tcl_InitNotifierProc) (void); typedef void (Tcl_FinalizeNotifierProc) (ClientData clientData); typedef void (Tcl_MainLoopProc) (void); - + +#ifndef TCL_NO_DEPRECATED +# define Tcl_PackageInitProc Tcl_LibraryInitProc +# define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc +#endif + /* *---------------------------------------------------------------------------- * The following structure represents a type of object, which is a particular @@ -2131,7 +2136,7 @@ typedef struct Tcl_EncodingType { #if TCL_UTF_MAX > 3 /* * int isn't 100% accurate as it should be a strict 4-byte value - * (perhaps wchar_t). ILP64/SILP64 systems may have troubles. The + * (perhaps int32_t). ILP64/SILP64 systems may have troubles. The * size of this value must be reflected correctly in regcustom.h. */ typedef int Tcl_UniChar; @@ -2380,6 +2385,10 @@ EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN void Tcl_InitSubsystems(void); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); +EXTERN const char * Tcl_SetPreInitScript(const char *string); +#ifndef TCL_NO_DEPRECATED +# define Tcl_StaticPackage Tcl_StaticLibrary +#endif #ifdef _WIN32 EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv); #else diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 70cb1b6..03655b9 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -94,7 +94,7 @@ union overhead { #define MINBLOCK ((sizeof(union overhead) + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1)) #define NBUCKETS (13 - (MINBLOCK >> 4)) -#define MAXMALLOC (1<<(NBUCKETS+2)) +#define MAXMALLOC ((size_t)1 << (NBUCKETS+2)) static union overhead *nextf[NBUCKETS]; /* @@ -583,7 +583,7 @@ TclpRealloc( Tcl_MutexUnlock(allocMutexPtr); return (void *)(overPtr+1); } - maxSize = 1 << (i+3); + maxSize = (size_t)1 << (i+3); expensive = 0; if (numBytes+OVERHEAD > maxSize) { expensive = 1; @@ -656,18 +656,18 @@ mstats( for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) { fprintf(stderr, " %u", j); } - totalFree += ((size_t)j) * (1 << (i + 3)); + totalFree += ((size_t)j) * ((size_t)1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { fprintf(stderr, " %" TCL_Z_MODIFIER "u", numMallocs[i]); - totalUsed += numMallocs[i] * (1 << (i + 3)); + totalUsed += numMallocs[i] * ((size_t)1 << (i + 3)); } fprintf(stderr, "\n\tTotal small in use: %" TCL_Z_MODIFIER "u, total free: %" TCL_Z_MODIFIER "u\n", totalUsed, totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_Z_MODIFIER "u\n", + fprintf(stderr, "\n\tNumber of big (>%" TCL_Z_MODIFIER "u) blocks in use: %" TCL_Z_MODIFIER "u\n", MAXMALLOC, numMallocs[NBUCKETS]); Tcl_MutexUnlock(allocMutexPtr); @@ -748,6 +748,8 @@ TclpRealloc( } #endif /* !USE_TCLALLOC */ +#else +TCL_MAC_EMPTY_FILE(generic_tclAlloc_c) #endif /* !TCL_THREADS */ /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2ed4270..86d7960 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -774,6 +774,10 @@ Tcl_CreateInterp(void) Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; +#ifdef _WIN32 +# define getenv(x) _wgetenv(L##x) /* On Windows, use _wgetenv below */ +#endif + /* TIP #268 */ #if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE) if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { @@ -1822,28 +1826,28 @@ DeleteInterpProc( ckfree(hTablePtr); } - /* - * Invoke deletion callbacks; note that a callback can create new - * callbacks, so we iterate. - */ - while (iPtr->assocData != NULL) { + if (iPtr->assocData != NULL) { AssocData *dPtr; hTablePtr = iPtr->assocData; - iPtr->assocData = NULL; + /* + * Invoke deletion callbacks; note that a callback can create new + * callbacks, so we iterate. + */ for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); hPtr != NULL; hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { dPtr = (AssocData *)Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(hPtr); if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } + Tcl_DeleteHashEntry(hPtr); ckfree(dPtr); } Tcl_DeleteHashTable(hTablePtr); ckfree(hTablePtr); + iPtr->assocData = NULL; } /* @@ -3501,14 +3505,15 @@ Tcl_DeleteCommandFromToken( cmdPtr->flags |= CMD_DYING; /* - * Call trace functions for the command being deleted. Then delete its - * traces. + * Call each functions and then delete the trace. */ cmdPtr->nsPtr->refCount++; if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; + /* CallCommandTraces() does not cmdPtr, that's + * done just before Tcl_DeleteCommandFromToken() returns */ CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); /* @@ -3678,7 +3683,6 @@ CallCommandTraces( } } cmdPtr->flags |= CMD_TRACE_ACTIVE; - cmdPtr->refCount++; result = NULL; active.nextPtr = iPtr->activeCmdTracePtr; @@ -3736,7 +3740,6 @@ CallCommandTraces( */ cmdPtr->flags &= ~CMD_TRACE_ACTIVE; - cmdPtr->refCount--; iPtr->activeCmdTracePtr = active.nextPtr; Tcl_Release(iPtr); return result; @@ -7906,7 +7909,16 @@ ExprAbsFunc( } goto unChanged; } else if (l == WIDE_MIN) { - if (mp_init_i64(&big, l) != MP_OKAY) { + if (sizeof(Tcl_WideInt) > sizeof(int64_t)) { + Tcl_WideUInt ul = -(Tcl_WideUInt)WIDE_MIN; + if (mp_init(&big) != MP_OKAY || mp_unpack(&big, 1, 1, + sizeof(Tcl_WideInt), 0, 0, &ul) != MP_OKAY) { + return TCL_ERROR; + } + if (mp_neg(&big, &big) != MP_OKAY) { + return TCL_ERROR; + } + } else if (mp_init_i64(&big, l) != MP_OKAY) { return TCL_ERROR; } goto tooLarge; diff --git a/generic/tclClock.c b/generic/tclClock.c index eb52244..90a998d 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1650,19 +1650,37 @@ ClockGetenvObjCmd( int objc, Tcl_Obj *const objv[]) { +#ifdef _WIN32 + const WCHAR *varName; + const WCHAR *varValue; + Tcl_DString ds; +#else const char *varName; const char *varValue; +#endif if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } +#ifdef _WIN32 + Tcl_DStringInit(&ds); + varName = Tcl_UtfToWCharDString(TclGetString(objv[1]), -1, &ds); + varValue = _wgetenv(varName); + if (varValue == NULL) { + Tcl_DStringFree(&ds); + } else { + Tcl_DStringSetLength(&ds, 0); + Tcl_WCharToUtfDString(varValue, -1, &ds); + Tcl_DStringResult(interp, &ds); + } +#else varName = TclGetString(objv[1]); varValue = getenv(varName); - if (varValue == NULL) { - varValue = ""; + if (varValue != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1)); } - Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1)); +#endif return TCL_OK; } @@ -2021,26 +2039,52 @@ ClockSecondsObjCmd( *---------------------------------------------------------------------- */ +#ifdef _WIN32 +#define getenv(x) _wgetenv(L##x) +#else +#define WCHAR char +#define wcslen strlen +#define wcscmp strcmp +#define wcscpy strcpy +#endif + static void TzsetIfNecessary(void) { - static char* tzWas = (char *)INT2PTR(-1); /* Previous value of TZ, protected by - * clockMutex. */ - const char *tzIsNow; /* Current value of TZ */ + static WCHAR* tzWas = (WCHAR *)INT2PTR(-1); /* Previous value of TZ, protected by + * clockMutex. */ + static long tzLastRefresh = 0; /* Used for latency before next refresh */ + static size_t tzEnvEpoch = 0; /* Last env epoch, for faster signaling, + that TZ changed via TCL */ + const WCHAR *tzIsNow; /* Current value of TZ */ + + /* + * Prevent performance regression on some platforms by resolving of system time zone: + * small latency for check whether environment was changed (once per second) + * no latency if environment was changed with tcl-env (compare both epoch values) + */ + Tcl_Time now; + Tcl_GetTime(&now); + if (now.sec == tzLastRefresh && tzEnvEpoch == TclEnvEpoch) { + return; + } + + tzEnvEpoch = TclEnvEpoch; + tzLastRefresh = now.sec; Tcl_MutexLock(&clockMutex); tzIsNow = getenv("TZ"); - if (tzIsNow != NULL && (tzWas == NULL || tzWas == INT2PTR(-1) - || strcmp(tzIsNow, tzWas) != 0)) { + if (tzIsNow != NULL && (tzWas == NULL || tzWas == (WCHAR *)INT2PTR(-1) + || wcscmp(tzIsNow, tzWas) != 0)) { tzset(); - if (tzWas != NULL && tzWas != INT2PTR(-1)) { + if (tzWas != NULL && tzWas != (WCHAR *)INT2PTR(-1)) { ckfree(tzWas); } - tzWas = (char *)ckalloc(strlen(tzIsNow) + 1); - strcpy(tzWas, tzIsNow); + tzWas = (WCHAR *)ckalloc(sizeof(WCHAR) * (wcslen(tzIsNow) + 1)); + wcscpy(tzWas, tzIsNow); } else if (tzIsNow == NULL && tzWas != NULL) { tzset(); - if (tzWas != INT2PTR(-1)) ckfree(tzWas); + if (tzWas != (WCHAR *)INT2PTR(-1)) ckfree(tzWas); tzWas = NULL; } Tcl_MutexUnlock(&clockMutex); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index c09ad95..8e6200d 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -613,8 +613,6 @@ EncodingConverttoObjCmd( int length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ - /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */ - if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index beb55c0..b9fc84a 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1241,7 +1241,7 @@ TclInfoFrame( { Interp *iPtr = (Interp *) interp; Tcl_Obj *tmpObj; - Tcl_Obj *lv[20]; /* Keep uptodate when more keys are added to + Tcl_Obj *lv[20] = {NULL}; /* Keep uptodate when more keys are added to * the dict. */ int lc = 0; /* @@ -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/tclCmdMZ.c b/generic/tclCmdMZ.c index d020a93..6f71198 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1533,16 +1533,16 @@ StringIsCmd( "boolean", "dict", "digit", "double", "entier", "false", "graph", "integer", "list", "lower", "print", "punct", - "space", "true", "upper", "wideinteger", - "wordchar", "xdigit", NULL + "space", "true", "upper", "unicode", + "wideinteger", "wordchar", "xdigit", NULL }; enum isClassesEnum { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, - STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, - STR_IS_WORD, STR_IS_XDIGIT + STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_UNICODE, + STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT }; static const char *const isOptions[] = { "-strict", "-failindex", NULL @@ -1872,6 +1872,9 @@ StringIsCmd( case STR_IS_UPPER: chcomp = Tcl_UniCharIsUpper; break; + case STR_IS_UNICODE: + chcomp = Tcl_UniCharIsUnicode; + break; case STR_IS_WORD: chcomp = Tcl_UniCharIsWordChar; break; @@ -2832,6 +2835,7 @@ StringCatCmd( * *---------------------------------------------------------------------- */ +#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) static int StringBytesCmd( TCL_UNUSED(ClientData), @@ -2850,6 +2854,7 @@ StringBytesCmd( Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length)); return TCL_OK; } +#endif /* *---------------------------------------------------------------------- @@ -3306,7 +3311,9 @@ TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { +#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, +#endif {"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0}, {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0bac52b..a160625 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -505,19 +505,19 @@ TclCompileStringIsCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", - "boolean", "dict", "digit", "double", "entier", - "false", "graph", "integer", "list", - "lower", "print", "punct", "space", - "true", "upper", "wideinteger", "wordchar", - "xdigit", NULL + "boolean", "dict", "digit", "double", + "entier", "false", "graph", "integer", + "list", "lower", "print", "punct", + "space", "true", "upper", "unicode", + "wideinteger", "wordchar", "xdigit", NULL }; enum isClassesEnum { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, - STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, - STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, - STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, - STR_IS_XDIGIT + STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, + STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, + STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, + STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_UNICODE, + STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT }; int t, range, allowEmpty = 0, end; InstStringClassType strClassType; @@ -609,6 +609,9 @@ TclCompileStringIsCmd( case STR_IS_UPPER: strClassType = STR_CLASS_UPPER; goto compileStrClass; + case STR_IS_UNICODE: + strClassType = STR_CLASS_UNICODE; + goto compileStrClass; case STR_IS_WORD: strClassType = STR_CLASS_WORD; goto compileStrClass; @@ -1415,6 +1418,7 @@ StringClassDesc const tclStringClassTable[] = { {"upper", Tcl_UniCharIsUpper}, {"word", Tcl_UniCharIsWordChar}, {"xdigit", UniCharIsHexDigit}, + {"unicode", Tcl_UniCharIsUnicode}, {"", NULL} }; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index fa15fba..03aebe3 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2145,7 +2145,7 @@ ParseLexeme( */ if (!TclIsBareword(*start) || *start == '_') { - if (TclUCS4Complete(start, numBytes)) { + if (Tcl_UtfCharComplete(start, numBytes)) { scanned = TclUtfToUCS4(start, &ch); } else { char utfBytes[8]; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 21a27f7..6a5faaf 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -922,8 +922,9 @@ typedef enum InstStringClassType { STR_CLASS_UPPER, /* Unicode upper-case alphabet characters. */ STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector * punctuation) characters. */ - STR_CLASS_XDIGIT /* Characters that can be used as digits in + STR_CLASS_XDIGIT, /* Characters that can be used as digits in * hexadecimal numbers ([0-9A-Fa-f]). */ + STR_CLASS_UNICODE /* Unicode characters. */ } InstStringClassType; typedef struct StringClassDesc { diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 540187f..a145bac 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -178,7 +178,7 @@ Tcl_RegisterConfig( * QueryConfigObjCmd -- * * Implementation of "::<package>::pkgconfig", the command to query - * configuration information embedded into a binary library. + * configuration information embedded into a library. * * Results: * A standard tcl result. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index dc39657..713f3e9 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -749,10 +749,10 @@ EXTERN int Tcl_SplitList(Tcl_Interp *interp, EXTERN void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr); /* 244 */ -EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, - const char *pkgName, - Tcl_PackageInitProc *initProc, - Tcl_PackageInitProc *safeInitProc); +EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp, + const char *prefix, + Tcl_LibraryInitProc *initProc, + Tcl_LibraryInitProc *safeInitProc); /* 245 */ TCL_DEPRECATED("No longer in use, changed to macro") int Tcl_StringMatch(const char *str, const char *pattern); @@ -999,7 +999,7 @@ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ EXTERN const char * Tcl_UtfAtIndex(const char *src, int index); /* 326 */ -EXTERN int Tcl_UtfCharComplete(const char *src, int length); +EXTERN int TclUtfCharComplete(const char *src, int length); /* 327 */ EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst); @@ -1008,9 +1008,9 @@ EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch); /* 329 */ EXTERN const char * Tcl_UtfFindLast(const char *src, int ch); /* 330 */ -EXTERN const char * Tcl_UtfNext(const char *src); +EXTERN const char * TclUtfNext(const char *src); /* 331 */ -EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); +EXTERN const char * TclUtfPrev(const char *src, const char *start); /* 332 */ EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, @@ -1338,8 +1338,8 @@ EXTERN int Tcl_FSDeleteFile(Tcl_Obj *pathPtr); /* 444 */ EXTERN int Tcl_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, const char *sym2, - Tcl_PackageInitProc **proc1Ptr, - Tcl_PackageInitProc **proc2Ptr, + Tcl_LibraryInitProc **proc1Ptr, + Tcl_LibraryInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); /* 445 */ @@ -1931,6 +1931,14 @@ EXTERN Tcl_UniChar * TclGetUnicodeFromObj(Tcl_Obj *objPtr, /* 653 */ EXTERN unsigned char * TclGetByteArrayFromObj(Tcl_Obj *objPtr, size_t *lengthPtr); +/* 654 */ +EXTERN int Tcl_UtfCharComplete(const char *src, int length); +/* 655 */ +EXTERN const char * Tcl_UtfNext(const char *src); +/* 656 */ +EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); +/* 657 */ +EXTERN int Tcl_UniCharIsUnicode(int ch); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2210,7 +2218,7 @@ typedef struct TclStubs { void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */ int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */ void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */ - TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_StaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 244 */ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ @@ -2292,12 +2300,12 @@ typedef struct TclStubs { int (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ const char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ - int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */ + int (*tclUtfCharComplete) (const char *src, int length); /* 326 */ int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ - const char * (*tcl_UtfNext) (const char *src); /* 330 */ - const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */ + const char * (*tclUtfNext) (const char *src); /* 330 */ + const char * (*tclUtfPrev) (const char *src, const char *start); /* 331 */ int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */ int (*tcl_UtfToLower) (char *src); /* 334 */ @@ -2410,7 +2418,7 @@ typedef struct TclStubs { int (*tcl_FSCopyDirectory) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); /* 441 */ int (*tcl_FSCreateDirectory) (Tcl_Obj *pathPtr); /* 442 */ int (*tcl_FSDeleteFile) (Tcl_Obj *pathPtr); /* 443 */ - int (*tcl_FSLoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, const char *sym2, Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); /* 444 */ + int (*tcl_FSLoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, const char *sym2, Tcl_LibraryInitProc **proc1Ptr, Tcl_LibraryInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); /* 444 */ int (*tcl_FSMatchInDirectory) (Tcl_Interp *interp, Tcl_Obj *result, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); /* 445 */ Tcl_Obj * (*tcl_FSLink) (Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction); /* 446 */ int (*tcl_FSRemoveDirectory) (Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr); /* 447 */ @@ -2620,6 +2628,10 @@ typedef struct TclStubs { char * (*tclGetStringFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 651 */ Tcl_UniChar * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */ unsigned char * (*tclGetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 653 */ + int (*tcl_UtfCharComplete) (const char *src, int length); /* 654 */ + const char * (*tcl_UtfNext) (const char *src); /* 655 */ + const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ + int (*tcl_UniCharIsUnicode) (int ch); /* 657 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3139,8 +3151,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SplitList) /* 242 */ #define Tcl_SplitPath \ (tclStubsPtr->tcl_SplitPath) /* 243 */ -#define Tcl_StaticPackage \ - (tclStubsPtr->tcl_StaticPackage) /* 244 */ +#define Tcl_StaticLibrary \ + (tclStubsPtr->tcl_StaticLibrary) /* 244 */ #define Tcl_StringMatch \ (tclStubsPtr->tcl_StringMatch) /* 245 */ #define Tcl_TellOld \ @@ -3302,18 +3314,18 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUtf) /* 324 */ #define Tcl_UtfAtIndex \ (tclStubsPtr->tcl_UtfAtIndex) /* 325 */ -#define Tcl_UtfCharComplete \ - (tclStubsPtr->tcl_UtfCharComplete) /* 326 */ +#define TclUtfCharComplete \ + (tclStubsPtr->tclUtfCharComplete) /* 326 */ #define Tcl_UtfBackslash \ (tclStubsPtr->tcl_UtfBackslash) /* 327 */ #define Tcl_UtfFindFirst \ (tclStubsPtr->tcl_UtfFindFirst) /* 328 */ #define Tcl_UtfFindLast \ (tclStubsPtr->tcl_UtfFindLast) /* 329 */ -#define Tcl_UtfNext \ - (tclStubsPtr->tcl_UtfNext) /* 330 */ -#define Tcl_UtfPrev \ - (tclStubsPtr->tcl_UtfPrev) /* 331 */ +#define TclUtfNext \ + (tclStubsPtr->tclUtfNext) /* 330 */ +#define TclUtfPrev \ + (tclStubsPtr->tclUtfPrev) /* 331 */ #define Tcl_UtfToExternal \ (tclStubsPtr->tcl_UtfToExternal) /* 332 */ #define Tcl_UtfToExternalDString \ @@ -3956,11 +3968,20 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclGetUnicodeFromObj) /* 652 */ #define TclGetByteArrayFromObj \ (tclStubsPtr->tclGetByteArrayFromObj) /* 653 */ +#define Tcl_UtfCharComplete \ + (tclStubsPtr->tcl_UtfCharComplete) /* 654 */ +#define Tcl_UtfNext \ + (tclStubsPtr->tcl_UtfNext) /* 655 */ +#define Tcl_UtfPrev \ + (tclStubsPtr->tcl_UtfPrev) /* 656 */ +#define Tcl_UniCharIsUnicode \ + (tclStubsPtr->tcl_UniCharIsUnicode) /* 657 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ +#undef TclUnusedStubEntry #if defined(USE_TCL_STUBS) # undef Tcl_CreateInterp # undef Tcl_FindExecutable @@ -3969,7 +3990,7 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_SetPanicProc # undef Tcl_SetExitProc # undef Tcl_ObjSetVar2 -# undef Tcl_StaticPackage +# undef Tcl_StaticLibrary # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) # define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) # define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) @@ -4230,10 +4251,16 @@ extern const TclStubs *tclStubsPtr; #define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) #endif -#if defined(USE_TCL_STUBS) && (TCL_UTF_MAX > 3) +#undef TclUtfCharComplete +#undef TclUtfNext +#undef TclUtfPrev +#if defined(USE_TCL_STUBS) && (TCL_UTF_MAX < 4) && !defined(TCL_NO_DEPRECATED) # undef Tcl_UtfCharComplete -# define Tcl_UtfCharComplete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \ - ? ((length) >= 4) : tclStubsPtr->tcl_UtfCharComplete((src), (length))) +# undef Tcl_UtfNext +# undef Tcl_UtfPrev +# define Tcl_UtfCharComplete (tclStubsPtr->tclUtfCharComplete) +# define Tcl_UtfNext (tclStubsPtr->tclUtfNext) +# define Tcl_UtfPrev (tclStubsPtr->tclUtfPrev) #endif #define Tcl_CreateSlave Tcl_CreateChild #define Tcl_GetSlave Tcl_GetChild diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index c4ef159..21c254e 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,13 @@ FillEncodingFileMap(void) *--------------------------------------------------------------------------- */ +/* Those flags must not conflict with other TCL_ENCODING_* flags in tcl.h */ +/* Since TCL_ENCODING_MODIFIED is only used for utf-8/cesu-8 and + * TCL_ENCODING_LE is only used for utf-16/ucs-2. re-use the same value */ +#define TCL_ENCODING_MODIFIED 0x20 /* Converting NULL bytes to 0xC0 0x80 */ +#define TCL_ENCODING_LE TCL_ENCODING_MODIFIED /* Little-endian encoding */ +#define TCL_ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */ + void TclInitEncodingSubsystem(void) { @@ -533,7 +533,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,11 +553,14 @@ 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; + type.clientData = INT2PTR(TCL_ENCODING_UTF); + Tcl_CreateEncoding(&type); + type.clientData = INT2PTR(0); + type.encodingName = "cesu-8"; Tcl_CreateEncoding(&type); type.toUtfProc = Utf16ToUtfProc; @@ -565,7 +568,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 +582,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); @@ -1141,19 +1144,21 @@ Tcl_ExternalToUtfDString( } flags = TCL_ENCODING_START | TCL_ENCODING_END; + if (encodingPtr->toUtfProc == UtfToUtfProc) { + flags |= TCL_ENCODING_MODIFIED | TCL_ENCODING_UTF; + } while (1) { result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + src += srcRead; if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); return Tcl_DStringValue(dstPtr); } - flags &= ~TCL_ENCODING_START; - src += srcRead; srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); @@ -1249,15 +1254,17 @@ Tcl_ExternalToUtf( if (!noTerminate) { /* * If there are any null characters in the middle of the buffer, - * they will converted to the UTF-8 null character (\xC080). To get + * they will converted to the UTF-8 null character (\xC0\x80). To get * the actual \0 at the end of the destination buffer, we need to * append it manually. First make room for it... */ dstLen--; } + if (encodingPtr->toUtfProc == UtfToUtfProc) { + flags |= TCL_ENCODING_MODIFIED | TCL_ENCODING_UTF; + } do { - int savedFlags = flags; Tcl_EncodingState savedState = *statePtr; result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen, @@ -1267,7 +1274,6 @@ Tcl_ExternalToUtf( break; } dstLen = Tcl_UtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1); - flags = savedFlags; *statePtr = savedState; } while (1); if (!noTerminate) { @@ -1331,10 +1337,11 @@ Tcl_UtfToExternalDString( flags = TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, - srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, - &dstChars); + srcLen, flags, &state, dst, dstLen, + &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + src += srcRead; if (result != TCL_CONVERT_NOSPACE) { if (encodingPtr->nullSize == 2) { Tcl_DStringSetLength(dstPtr, soFar + 1); @@ -1344,7 +1351,6 @@ Tcl_UtfToExternalDString( } flags &= ~TCL_ENCODING_START; - src += srcRead; srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); @@ -1433,8 +1439,8 @@ Tcl_UtfToExternal( dstLen -= encodingPtr->nullSize; result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen, - flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, - dstCharsPtr); + flags, statePtr, dst, dstLen, srcReadPtr, + dstWrotePtr, dstCharsPtr); if (encodingPtr->nullSize == 2) { dst[*dstWrotePtr + 1] = '\0'; } @@ -2156,104 +2162,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 @@ -2271,15 +2179,11 @@ UtfExtToUtfIntProc( static int UtfToUtfProc( - TCL_UNUSED(ClientData), + ClientData clientData, /* additional flags, e.g. TCL_ENCODING_MODIFIED */ 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 @@ -2292,21 +2196,15 @@ 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; int result, numChars, charLimit = INT_MAX; - int *chPtr = (int *) statePtr; + int ch; - if (flags & TCL_ENCODING_START) { - *statePtr = 0; - } result = TCL_OK; srcStart = src; @@ -2320,10 +2218,11 @@ UtfToUtfProc( } dstStart = dst; - dstEnd = dst + dstLen - TCL_UTF_MAX; + flags |= PTR2INT(clientData); + dstEnd = dst + dstLen - ((flags & TCL_ENCODING_UTF) ? TCL_UTF_MAX : 6); for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { - if ((src > srcClose) && (!TclUCS4Complete(src, srcEnd - src))) { + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the * last UTF-8 character in the source buffer hasn't been cut off. @@ -2336,50 +2235,98 @@ UtfToUtfProc( result = TCL_CONVERT_NOSPACE; break; } - if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && pureNullMode == 0)) { + 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. */ *dst++ = *src++; - *chPtr = 0; /* reset surrogate handling */ - } 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_MODIFIED)) { /* * Convert 0xC080 to real nulls when we are in output mode. */ *dst++ = 0; - *chPtr = 0; /* reset surrogate handling */ src += 2; - } else if (!TclUCS4Complete(src, srcEnd - src)) { + } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { /* * 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. */ - *chPtr = UCHAR(*src); - src += 1; - dst += Tcl_UniCharToUtf(*chPtr, dst); + if (flags & TCL_ENCODING_MODIFIED) { + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_MULTIBYTE; + break; + } + ch = UCHAR(*src++); + } else { + char chbuf[2]; + chbuf[0] = UCHAR(*src++); chbuf[1] = 0; + TclUtfToUCS4(chbuf, &ch); + } + dst += Tcl_UniCharToUtf(ch, dst); } else { - src += TclUtfToUCS4(src, chPtr); - if ((*chPtr | 0x7FF) == 0xDFFF) { - /* A surrogate character is detected, handle especially */ - int low = *chPtr; - 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); - continue; + int low; + const char *saveSrc = src; + size_t len = TclUtfToUCS4(src, &ch); + if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR) + && (flags & TCL_ENCODING_MODIFIED)) { + result = TCL_CONVERT_SYNTAX; + break; + } + src += len; + if (!(flags & TCL_ENCODING_UTF)) { + if (ch > 0xFFFF) { + /* CESU-8 6-byte sequence for chars > U+FFFF */ + ch -= 0x10000; + *dst++ = 0xED; + *dst++ = (char) (((ch >> 16) & 0x0F) | 0xA0); + *dst++ = (char) (((ch >> 10) & 0x3F) | 0x80); + ch = (ch & 0x0CFF) | 0xDC00; + } + goto cesu8; + } else if ((ch | 0x7FF) == 0xDFFF) { + /* + * A surrogate character is detected, handle especially. + */ + + low = ch; + len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; + + if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) { + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_UNKNOWN; + src = saveSrc; + break; + } + if (!(flags & TCL_ENCODING_MODIFIED)) { + ch = 0xFFFD; + } + cesu8: + *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; + } else if (!Tcl_UniCharIsUnicode(ch)) { + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_UNKNOWN; + src = saveSrc; + break; + } + if (!(flags & TCL_ENCODING_MODIFIED)) { + ch = 0xFFFD; + } } - dst += Tcl_UniCharToUtf(*chPtr, dst); + dst += Tcl_UniCharToUtf(ch, dst); } } @@ -2407,7 +2354,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. */ @@ -2433,18 +2380,27 @@ Utf16ToUtfProc( int result, numChars, charLimit = INT_MAX; unsigned short ch; + flags |= PTR2INT(clientData); if (flags & TCL_ENCODING_CHAR_LIMIT) { charLimit = *dstCharsPtr; } 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 - (clientData?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; } @@ -2461,15 +2417,17 @@ 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); } + /* * 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 { @@ -2502,15 +2460,11 @@ Utf16ToUtfProc( static int UtfToUtf16Proc( - 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. */ - 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 +2483,8 @@ UtfToUtf16Proc( { const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; int result, numChars; - Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + int ch, len; - if (flags & TCL_ENCODING_START) { - *statePtr = 0; - } srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; @@ -2543,6 +2494,7 @@ UtfToUtf16Proc( dstStart = dst; dstEnd = dst + dstLen - sizeof(Tcl_UniChar); + flags |= PTR2INT(clientData); result = TCL_OK; for (numChars = 0; src < srcEnd; numChars++) { @@ -2559,38 +2511,35 @@ UtfToUtf16Proc( result = TCL_CONVERT_NOSPACE; break; } - src += TclUtfToUniChar(src, chPtr); - - if (clientData) { -#if TCL_UTF_MAX > 3 - if (*chPtr <= 0xFFFF) { - *dst++ = (*chPtr & 0xFF); - *dst++ = (*chPtr >> 8); + len = TclUtfToUCS4(src, &ch); + if (!Tcl_UniCharIsUnicode(ch)) { + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_UNKNOWN; + break; + } + ch = 0xFFFD; + } + src += len; + if (flags & TCL_ENCODING_LE) { + 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; @@ -2617,7 +2566,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. */ @@ -2645,6 +2594,7 @@ UtfToUcs2Proc( #endif Tcl_UniChar ch = 0; + flags |= PTR2INT(clientData); srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; @@ -2688,7 +2638,7 @@ UtfToUcs2Proc( * casting dst to a Tcl_UniChar. [Bug 1122671] */ - if (clientData) { + if (flags & TCL_ENCODING_LE) { *dst++ = (ch & 0xFF); *dst++ = (ch >> 8); } else { @@ -3096,7 +3046,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. @@ -3141,7 +3093,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] @@ -3199,7 +3151,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/tclEnsemble.c b/generic/tclEnsemble.c index 929f3ef..ccd43b9 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -165,7 +165,7 @@ TclNamespaceEnsembleCmd( const char *simpleName; int index, done; - if (nsPtr == NULL || nsPtr->flags & NS_DYING) { + if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "tried to manipulate ensemble of deleted namespace", @@ -1730,7 +1730,7 @@ NsEnsembleImplementationCmdNR( return TCL_ERROR; } - if (ensemblePtr->nsPtr->flags & NS_DYING) { + if (ensemblePtr->nsPtr->flags & NS_DEAD) { /* * Don't know how we got here, but make things give up quickly. */ diff --git a/generic/tclEnv.c b/generic/tclEnv.c index ad55645..64d0309 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -36,6 +36,11 @@ TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */ # define techar char #endif + +/* MODULE_SCOPE */ +size_t TclEnvEpoch = 0; /* Epoch of the tcl environment + * (if changed with tcl-env). */ + static struct { int cacheSize; /* Number of env strings in cache. */ char **cache; /* Array containing all of the environment @@ -417,6 +422,7 @@ Tcl_PutEnv( value[0] = '\0'; TclSetEnv(name, value+1); } + TclEnvEpoch++; Tcl_DStringFree(&nameString); return 0; @@ -624,6 +630,7 @@ EnvTraceProc( if (flags & TCL_TRACE_ARRAY) { TclSetupEnv(interp); + TclEnvEpoch++; return NULL; } @@ -644,6 +651,7 @@ EnvTraceProc( value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY); TclSetEnv(name2, value); + TclEnvEpoch++; } /* @@ -667,6 +675,7 @@ EnvTraceProc( if (flags & TCL_TRACE_UNSETS) { TclUnsetEnv(name2); + TclEnvEpoch++; } return NULL; } 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"); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 55bc314..f9c2954 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8817,7 +8817,7 @@ ExecuteExtendedUnaryMathOp( int opcode, /* What operation to perform. */ Tcl_Obj *valuePtr) /* The operand on the stack. */ { - ClientData ptr; + ClientData ptr = NULL; int type; Tcl_WideInt w; mp_int big; diff --git a/generic/tclIO.c b/generic/tclIO.c index 9cace8c..d704d29 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3387,7 +3387,8 @@ int Tcl_Close( Tcl_Interp *interp, /* Interpreter for errors. */ Tcl_Channel chan) /* The channel being closed. Must not be - * referenced in any interpreter. */ + * referenced in any interpreter. May be NULL, + * in which case this is a no-op. */ { CloseCallback *cbPtr; /* Iterate over close callbacks for this * channel. */ @@ -3659,7 +3660,7 @@ Tcl_CloseEx( * That won't do. */ - if (statePtr->flags & CHANNEL_INCLOSE) { + if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal recursive call to close through close-handler" @@ -4320,6 +4321,7 @@ Write( /* State info for channel */ char *nextNewLine = NULL; int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0; + char safe[BUFFER_PADDING]; if (srcLen) { WillWrite(chanPtr); @@ -4338,7 +4340,7 @@ Write( while (srcLen + saved + endEncoding > 0) { ChannelBuffer *bufPtr; - char *dst, safe[BUFFER_PADDING]; + char *dst; int result, srcRead, dstLen, dstWrote, srcLimit = srcLen; if (nextNewLine) { @@ -4383,7 +4385,7 @@ Write( ReleaseChannelBuffer(bufPtr); if (total == 0) { - Tcl_SetErrno(EINVAL); + Tcl_SetErrno(EILSEQ); return -1; } break; @@ -8604,9 +8606,12 @@ ChannelTimerProc( ClientData clientData) { Channel *chanPtr = (Channel *)clientData; + + /* State info for channel */ ChannelState *statePtr = chanPtr->state; - /* State info for channel */ + /* Preserve chanPtr to guard against deallocation in Tcl_NotifyChannel. */ + TclChannelPreserve((Tcl_Channel)chanPtr); Tcl_Preserve(statePtr); statePtr->timer = NULL; if (statePtr->interestMask & TCL_WRITABLE @@ -8622,22 +8627,27 @@ ChannelTimerProc( Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE); } - if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA) - && (statePtr->interestMask & TCL_READABLE) - && (statePtr->inQueueHead != NULL) - && IsBufferReady(statePtr->inQueueHead)) { - /* - * Restart the timer in case a channel handler reenters the event loop - * before UpdateInterest gets called by Tcl_NotifyChannel. - */ + /* The channel may have just been closed from within Tcl_NotifyChannel */ + if (!GotFlag(statePtr, CHANNEL_INCLOSE)) { + if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA) + && (statePtr->interestMask & TCL_READABLE) + && (statePtr->inQueueHead != NULL) + && IsBufferReady(statePtr->inQueueHead)) { + /* + * Restart the timer in case a channel handler reenters the event loop + * before UpdateInterest gets called by Tcl_NotifyChannel. + */ - statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - ChannelTimerProc,chanPtr); - Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); - } else { - UpdateInterest(chanPtr); + statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + ChannelTimerProc,chanPtr); + Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); + } else { + UpdateInterest(chanPtr); + } } + Tcl_Release(statePtr); + TclChannelRelease((Tcl_Channel)chanPtr); } /* @@ -8702,7 +8712,7 @@ Tcl_CreateChannelHandler( /* * The remainder of the initialization below is done regardless of whether - * or not this is a new record or a modification of an old one. + * this is a new record or a modification of an old one. */ chPtr->mask = mask; @@ -10965,15 +10975,17 @@ Tcl_SetChannelErrorInterp( Tcl_Obj *msg) /* Error message to store. */ { Interp *iPtr = (Interp *) interp; - - if (iPtr->chanMsg != NULL) { - TclDecrRefCount(iPtr->chanMsg); - iPtr->chanMsg = NULL; - } + Tcl_Obj *disposePtr = iPtr->chanMsg; if (msg != NULL) { iPtr->chanMsg = FixLevelCode(msg); Tcl_IncrRefCount(iPtr->chanMsg); + } else { + iPtr->chanMsg = NULL; + } + + if (disposePtr != NULL) { + TclDecrRefCount(disposePtr); } return; } @@ -11001,15 +11013,17 @@ Tcl_SetChannelError( Tcl_Obj *msg) /* Error message to store. */ { ChannelState *statePtr = ((Channel *) chan)->state; - - if (statePtr->chanMsg != NULL) { - TclDecrRefCount(statePtr->chanMsg); - statePtr->chanMsg = NULL; - } + Tcl_Obj *disposePtr = statePtr->chanMsg; if (msg != NULL) { statePtr->chanMsg = FixLevelCode(msg); Tcl_IncrRefCount(statePtr->chanMsg); + } else { + statePtr->chanMsg = NULL; + } + + if (disposePtr != NULL) { + TclDecrRefCount(disposePtr); } return; } diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index e6e8e58..9097bf4 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -56,12 +56,13 @@ static int ReflectGetOption(ClientData clientData, static int ReflectSetOption(ClientData clientData, Tcl_Interp *interp, const char *optionName, const char *newValue); +static int ReflectTruncate(ClientData clientData, + long long length); static void TimerRunRead(ClientData clientData); static void TimerRunWrite(ClientData clientData); /* - * 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 = { @@ -79,7 +80,7 @@ static const Tcl_ChannelType tclRChannelType = { ReflectGetOption, /* Get options. NULL'able */ ReflectWatch, /* Initialize notifier */ NULL, /* Get OS handle from the channel. NULL'able */ - ReflectClose, /* No close2 support. NULL'able */ + ReflectClose, /* No close2 support. NULL'able */ ReflectBlock, /* Set blocking/nonblocking. NULL'able */ NULL, /* Flush channel. Not used by core. NULL'able */ NULL, /* Handle events. NULL'able */ @@ -89,7 +90,7 @@ static const Tcl_ChannelType tclRChannelType = { #else NULL, /* thread action */ #endif - NULL /* truncate */ + ReflectTruncate /* Truncate. NULL'able */ }; /* @@ -187,6 +188,7 @@ static const char *const methodNames[] = { "initialize", /* */ "read", /* OPT */ "seek", /* OPT */ + "truncate", /* OPT */ "watch", /* */ "write", /* OPT */ NULL @@ -200,6 +202,7 @@ typedef enum { METH_INIT, METH_READ, METH_SEEK, + METH_TRUNCATE, METH_WATCH, METH_WRITE } MethodName; @@ -209,7 +212,8 @@ typedef enum { (FLAG(METH_INIT) | FLAG(METH_FINAL) | FLAG(METH_WATCH)) #define NULLABLE_METHODS \ (FLAG(METH_BLOCKING) | FLAG(METH_SEEK) | \ - FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | FLAG(METH_CGETALL)) + FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | \ + FLAG(METH_CGETALL) | FLAG(METH_TRUNCATE)) #define RANDW \ (TCL_READABLE | TCL_WRITABLE) @@ -239,7 +243,8 @@ typedef enum { ForwardedBlock, ForwardedSetOpt, ForwardedGetOpt, - ForwardedGetOptAll + ForwardedGetOptAll, + ForwardedTruncate } ForwardedOperation; /* @@ -302,6 +307,10 @@ struct ForwardParamGetOpt { const char *name; /* Name of option to get, maybe NULL */ Tcl_DString *value; /* Result */ }; +struct ForwardParamTruncate { + ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ + Tcl_WideInt length; /* I: Length of file. */ +}; /* * Now join all these together in a single union for convenience. @@ -316,6 +325,7 @@ typedef union ForwardParam { struct ForwardParamBlock block; struct ForwardParamSetOpt setOpt; struct ForwardParamGetOpt getOpt; + struct ForwardParamTruncate truncate; } ForwardParam; /* @@ -706,6 +716,9 @@ TclChanCreateObjCmd( #endif clonePtr->wideSeekProc = NULL; } + if (!(methods & FLAG(METH_TRUNCATE))) { + clonePtr->truncateProc = NULL; + } chanPtr->typePtr = clonePtr; } @@ -1143,7 +1156,7 @@ TclChanCaughtErrorBypass( * ReflectClose -- * * This function is invoked when the channel is closed, to delete the - * driver specific instance data. + * driver-specific instance data. * * Results: * A posix error. @@ -1176,8 +1189,8 @@ ReflectClose( /* * This call comes from TclFinalizeIOSystem. There are no * interpreters, and therefore we cannot call upon the handler command - * anymore. Threading is irrelevant as well. We simply clean up all - * our C level data structures and leave the Tcl level to the other + * anymore. Threading is irrelevant as well. Simply clean up all + * the C level data structures and leave the Tcl level to the other * finalization functions. */ @@ -2048,6 +2061,73 @@ ReflectGetOption( } /* + *---------------------------------------------------------------------- + * + * ReflectTruncate -- + * + * This function is invoked to truncate a channel's file size. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Arbitrary, as it calls upon a Tcl script. + * + *---------------------------------------------------------------------- + */ + +static int +ReflectTruncate( + ClientData clientData, /* Channel to query */ + long long length) /* Length to truncate to. */ +{ + ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; + Tcl_Obj *lenObj; + int errorNum; /* EINVAL or EOK (success). */ + Tcl_Obj *resObj; /* Result for 'truncate' */ + + /* + * Are we in the correct thread? + */ + +#ifdef TCL_THREADS + if (rcPtr->thread != Tcl_GetCurrentThread()) { + ForwardParam p; + + p.truncate.length = length; + + ForwardOpToHandlerThread(rcPtr, ForwardedTruncate, &p); + + if (p.base.code != TCL_OK) { + PassReceivedError(rcPtr->chan, &p); + return EINVAL; + } + + return EOK; + } +#endif + + /* ASSERT: rcPtr->method & FLAG(METH_TRUNCATE) */ + + Tcl_Preserve(rcPtr); + + lenObj = Tcl_NewIntObj(length); + Tcl_IncrRefCount(lenObj); + + if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) { + Tcl_SetChannelError(rcPtr->chan, resObj); + errorNum = EINVAL; + } else { + errorNum = EOK; + } + + Tcl_DecrRefCount(lenObj); + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + Tcl_Release(rcPtr); + return errorNum; +} + +/* * Helpers. ========================================================= */ @@ -3278,6 +3358,19 @@ ForwardProc( Tcl_Release(rcPtr); break; + case ForwardedTruncate: { + Tcl_Obj *lenObj = Tcl_NewIntObj(paramPtr->truncate.length); + + Tcl_IncrRefCount(lenObj); + Tcl_Preserve(rcPtr); + if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + } + Tcl_Release(rcPtr); + Tcl_DecrRefCount(lenObj); + break; + } + default: /* * Bad operation code. diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 191837e..87e60c3 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -2646,8 +2646,9 @@ Tcl_FSGetCwd( norm = TclFSNormalizeAbsolutePath(interp,retVal); if (norm != NULL) { /* - * Assign to global storage the pathname of the current directory - * and copy it into thread-local storage as well. + * Assign to global storage the pathname of the current + * directory and copy it into thread-local storage as + * well. * * At system startup multiple threads could in principle * call this function simultaneously, which is a little @@ -3009,7 +3010,7 @@ Tcl_FSLoadFile( const char *sym1, const char *sym2, /* Names of two functions to find in the * dynamic shared object. */ - Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, + Tcl_LibraryInitProc **proc1Ptr, Tcl_LibraryInitProc **proc2Ptr, /* Places to store pointers to the functions * named by sym1 and sym2. */ Tcl_LoadHandle *handlePtr, /* A place to store the token for the loaded @@ -3027,8 +3028,8 @@ Tcl_FSLoadFile( res = Tcl_LoadFile(interp, pathPtr, symbols, 0, procPtrs, handlePtr); if (res == TCL_OK) { - *proc1Ptr = (Tcl_PackageInitProc *) procPtrs[0]; - *proc2Ptr = (Tcl_PackageInitProc *) procPtrs[1]; + *proc1Ptr = (Tcl_LibraryInitProc *) procPtrs[0]; + *proc2Ptr = (Tcl_LibraryInitProc *) procPtrs[1]; } else { *proc1Ptr = *proc2Ptr = NULL; } @@ -3077,6 +3078,13 @@ Tcl_FSLoadFile( * */ +#ifdef _WIN32 +#define getenv(x) _wgetenv(L##x) +#define atoi(x) _wtoi(x) +#else +#define WCHAR char +#endif + static int skipUnlink( Tcl_Obj *shlibFile) @@ -3098,7 +3106,7 @@ skipUnlink( (void)shlibFile; return 1; #else - char *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK"); + WCHAR *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK"); if (skipstr && (skipstr[0] != '\0')) { return atoi(skipstr); @@ -3782,10 +3790,12 @@ Tcl_FSListVolumes(void) if (thisFsVolumes != NULL) { Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes); - /* The refCount of each list returned by a `listVolumesProc` is - * already incremented. Do not hang onto the list, though. It - * belongs to the filesystem. Add its contents to * the result - * we are building, and then decrement the refCount. */ + /* + * The refCount of each list returned by a `listVolumesProc` + * is already incremented. Do not hang onto the list, though. + * It belongs to the filesystem. Add its contents to the + * result we are building, and then decrement the refCount. + */ Tcl_DecrRefCount(thisFsVolumes); } } @@ -4358,15 +4368,14 @@ Tcl_FSCreateDirectory( int Tcl_FSCopyDirectory( - Tcl_Obj *srcPathPtr, /* - * The pathname of the directory to be copied. - */ + Tcl_Obj *srcPathPtr, /* The pathname of the directory to be + * copied. */ Tcl_Obj *destPathPtr, /* The pathname of the target directory. */ Tcl_Obj **errorPtr) /* If not NULL, and there is an error, a place - * to store a pointer to a new object, with - * its refCount already incremented, and - * containing the pathname name of file - * causing the error. */ + * to store a pointer to a new object, with + * its refCount already incremented, and + * containing the pathname name of file + * causing the error. */ { int retVal = -1; const Tcl_Filesystem *fsPtr, *fsPtr2; diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index f08278b..48ebb69 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -785,7 +785,7 @@ PrefixLongestObjCmd( * Adjust in case we stopped in the middle of a UTF char. */ - resultLength = TclUtfPrev(&resultString[i+1], + resultLength = Tcl_UtfPrev(&resultString[i+1], resultString) - resultString; break; } @@ -1332,7 +1332,6 @@ PrintUsage( int width, numSpaces; #define NUM_SPACES 20 static const char spaces[] = " "; - char tmp[TCL_DOUBLE_SPACE]; Tcl_Obj *msg; /* @@ -1382,7 +1381,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); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index a4ed641..aad7db3 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -17,6 +17,7 @@ library tcl # Define the unsupported generic interfaces. interface tclInt +scspec EXTERN # Declare each of the functions in the unsupported internal Tcl # interface. These interfaces are allowed to changed between versions. @@ -183,7 +184,7 @@ declare 41 { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 { - CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) + const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } # Removed in 8.5a2: #declare 43 { @@ -239,8 +240,8 @@ declare 55 { # Replaced with TclpLoadFile in 8.1: # declare 56 { # int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, -# char *sym2, Tcl_PackageInitProc **proc1Ptr, -# Tcl_PackageInitProc **proc2Ptr) +# char *sym2, Tcl_LibraryInitProc **proc1Ptr, +# Tcl_LibraryInitProc **proc2Ptr) # } # Signature changed to take a length in 8.1: # declare 57 { @@ -408,7 +409,7 @@ declare 98 { # Tcl_Obj *objPtr, int flags) #} declare 101 { - CONST86 char *TclSetPreInitScript(const char *string) + const char *TclSetPreInitScript(const char *string) } declare 102 { void TclSetupEnv(Tcl_Interp *interp) @@ -552,8 +553,8 @@ declare 138 { } #declare 139 { # int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, -# char *sym2, Tcl_PackageInitProc **proc1Ptr, -# Tcl_PackageInitProc **proc2Ptr, void **clientDataPtr) +# char *sym2, Tcl_LibraryInitProc **proc1Ptr, +# Tcl_LibraryInitProc **proc2Ptr, void **clientDataPtr) #} #declare 140 { # int TclLooksLikeInt(const char *bytes, int length) @@ -1025,8 +1026,8 @@ declare 256 { Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) } declare 257 { - void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, - Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) + void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, + Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) } # TIP 431: temporary directory creation function diff --git a/generic/tclInt.h b/generic/tclInt.h index 66bbc17..ad9a5c1 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -415,29 +415,27 @@ struct NamespacePathEntry { * Flags used to represent the status of a namespace: * * NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the - * namespace but there are still active call frames on the Tcl + * namespace. There may still be active call frames on the Tcl * stack that refer to the namespace. When the last call frame - * referring to it has been popped, it's variables and command - * will be destroyed and it will be marked "dead" (NS_DEAD). The - * namespace can no longer be looked up by name. + * referring to it has been popped, its remaining variables and + * commands are destroyed and it is marked "dead" (NS_DEAD). + * NS_TEARDOWN -1 means that TclTeardownNamespace has already been called on + * this namespace and it should not be called again [Bug 1355942]. * NS_DEAD - 1 means Tcl_DeleteNamespace has been called to delete the - * namespace and no call frames still refer to it. Its variables - * and command have already been destroyed. This bit allows the - * namespace resolution code to recognize that the namespace is - * "deleted". When the last namespaceName object in any byte code - * unit that refers to the namespace has been freed (i.e., when - * the namespace's refCount is 0), the namespace's storage will - * be freed. - * NS_KILLED - 1 means that TclTeardownNamespace has already been called on - * this namespace and it should not be called again [Bug 1355942] + * namespace and no call frames still refer to it. It is no longer + * accessible by name. Its variables and commands have already + * been destroyed. When the last namespaceName object in any byte + * code unit that refers to the namespace has been freed (i.e., + * when the namespace's refCount is 0), the namespace's storage + * will be freed. * NS_SUPPRESS_COMPILATION - * Marks the commands in this namespace for not being compiled, * forcing them to be looked up every time. */ #define NS_DYING 0x01 -#define NS_DEAD 0x02 -#define NS_KILLED 0x04 +#define NS_TEARDOWN 0x02 +#define NS_DEAD 0x04 #define NS_SUPPRESS_COMPILATION 0x08 /* @@ -1804,7 +1802,7 @@ typedef struct AllocCache { struct Cache *nextPtr; /* Linked list of cache entries. */ Tcl_ThreadId owner; /* Which thread's cache is this? */ Tcl_Obj *firstObjPtr; /* List of free objects for thread. */ - int numObjects; /* Number of objects for thread. */ + size_t numObjects; /* Number of objects for thread. */ } AllocCache; /* @@ -2739,7 +2737,6 @@ MODULE_SCOPE char *tclNativeExecutableName; MODULE_SCOPE int tclFindExecutableSearchDone; MODULE_SCOPE char *tclMemDumpFileName; MODULE_SCOPE TclPlatformType tclPlatform; -MODULE_SCOPE Tcl_NotifierProcs tclNotifierHooks; MODULE_SCOPE Tcl_Encoding tclIdentityEncoding; @@ -2959,6 +2956,7 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, const char *name, Tcl_Namespace *nameNamespacePtr, Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); +MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, @@ -3044,7 +3042,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 *, @@ -3133,12 +3131,21 @@ MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); -MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); +MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, + Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, int len); +MODULE_SCOPE void TclpAlertNotifier(ClientData clientData); +MODULE_SCOPE void TclpServiceModeHook(int mode); +MODULE_SCOPE void TclpSetTimer(const Tcl_Time *timePtr); +MODULE_SCOPE int TclpWaitForEvent(const Tcl_Time *timePtr); +MODULE_SCOPE void TclpCreateFileHandler(int fd, int mask, + Tcl_FileProc *proc, ClientData clientData); MODULE_SCOPE int TclpDeleteFile(const void *path); +MODULE_SCOPE void TclpDeleteFileHandler(int fd); MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); +MODULE_SCOPE void TclpFinalizeNotifier(ClientData clientData); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, @@ -3152,6 +3159,7 @@ MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); +MODULE_SCOPE ClientData TclpInitNotifier(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); @@ -3178,8 +3186,9 @@ MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); -MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName); -MODULE_SCOPE void *TclInitPkgFiles(Tcl_Interp *interp); +MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, + const char *fileName); +MODULE_SCOPE void * TclInitPkgFiles(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_PathPart portion); MODULE_SCOPE char * TclpReadlink(const char *fileName, @@ -3253,16 +3262,10 @@ MODULE_SCOPE int TclUtfCount(int ch); # define TclUtfToUCS4 Tcl_UtfToUniChar # define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1) # define TclUCS4Prev(src, ptr) (((src) > (ptr)) ? ((src) - 1) : (src)) -# define TclUCS4Complete Tcl_UtfCharComplete -# define TclChar16Complete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \ - ? ((length) >= 3) : Tcl_UtfCharComplete((src), (length))) #else MODULE_SCOPE int TclUtfToUCS4(const char *, int *); MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *, int *); MODULE_SCOPE const Tcl_UniChar *TclUCS4Prev(const Tcl_UniChar *, const Tcl_UniChar *); -# define TclUCS4Complete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \ - ? ((length) >= 4) : Tcl_UtfCharComplete((src), (length))) -# define TclChar16Complete Tcl_UtfCharComplete #endif MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); @@ -4218,6 +4221,37 @@ MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); #define TCL_INDEX_START (0) /* + *---------------------------------------------------------------------- + * + * TclScaleTime -- + * + * TIP #233 (Virtualized Time): Wrapper around the time virutalisation + * rescale function to hide the binding of the clientData. + * + * This is static inline code; it's like a macro, but a function. It's + * used because this is a piece of code that ends up in places that are a + * bit performance sensitive. + * + * Results: + * None + * + * Side effects: + * Updates the time structure (given as an argument) with what the time + * should be after virtualisation. + * + *---------------------------------------------------------------------- + */ + +static inline void +TclScaleTime( + Tcl_Time *timePtr) +{ + if (timePtr != NULL) { + tclScaleTimeProcPtr(timePtr, tclTimeClientData); + } +} + +/* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. @@ -4696,11 +4730,6 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; (numChars) = _count; \ } while (0); -#define TclUtfPrev(src, start) \ - (((src) < (start) + 2) ? (start) : \ - ((unsigned char) *((src) - 1)) < 0x80 ? (src) - 1 : \ - Tcl_UtfPrev(src, start)) - /* *---------------------------------------------------------------- * Macro that encapsulates the logic that determines when it is safe to @@ -4737,7 +4766,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ -#ifdef WORDS_BIGENDIAN +#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3) # define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) #else /* !WORDS_BIGENDIAN */ # define TclUniCharNcmp Tcl_UniCharNcmp @@ -4768,7 +4797,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); *---------------------------------------------------------------------- */ -MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init; +MODULE_SCOPE Tcl_LibraryInitProc TclTommath_Init; /* *---------------------------------------------------------------------- @@ -4780,11 +4809,11 @@ MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init; *---------------------------------------------------------------------- */ -MODULE_SCOPE Tcl_PackageInitProc TclplatformtestInit; -MODULE_SCOPE Tcl_PackageInitProc TclObjTest_Init; -MODULE_SCOPE Tcl_PackageInitProc TclThread_Init; -MODULE_SCOPE Tcl_PackageInitProc Procbodytest_Init; -MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; +MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit; +MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init; +MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; +MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; +MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; /* *---------------------------------------------------------------- @@ -5155,6 +5184,35 @@ typedef struct NRE_callback { #define Tcl_Free(ptr) TclpFree(ptr) #endif +/* + * Special hack for macOS, where the static linker (technically the 'ar' + * command) hates empty object files, and accepts no flags to make it shut up. + * + * These symbols are otherwise completely useless. + * + * They can't be written to or written through. They can't be seen by any + * other code. They use a separate attribute (supported by all macOS + * compilers, which are derivatives of clang or gcc) to stop the compilation + * from moaning. They will be excluded during the final linking stage. + * + * Other platforms get nothing at all. That's good. + */ + +#ifdef MAC_OSX_TCL +#define TCL_MAC_EMPTY_FILE(name) \ + static __attribute__((used)) const void *const TclUnusedFile_ ## name; \ + static const void *const TclUnusedFile_ ## name = NULL; +#else +#define TCL_MAC_EMPTY_FILE(name) +#endif /* MAC_OSX_TCL */ + +/* + * Other externals. + */ + +MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment + * (if changed with tcl-env). */ + #endif /* _TCLINT */ /* diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 1e7e26d..5ae92e4 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -153,7 +153,7 @@ EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str, /* 41 */ EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command); /* 42 */ -EXTERN CONST86 char * TclpGetUserHome(const char *name, +EXTERN const char * TclpGetUserHome(const char *name, Tcl_DString *bufferPtr); /* Slot 43 is reserved */ /* 44 */ @@ -264,7 +264,7 @@ EXTERN int TclServiceIdle(void); /* Slot 99 is reserved */ /* Slot 100 is reserved */ /* 101 */ -EXTERN CONST86 char * TclSetPreInitScript(const char *string); +EXTERN const char * TclSetPreInitScript(const char *string); /* 102 */ EXTERN void TclSetupEnv(Tcl_Interp *interp); /* 103 */ @@ -651,10 +651,10 @@ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 257 */ -EXTERN void TclStaticPackage(Tcl_Interp *interp, - const char *pkgName, - Tcl_PackageInitProc *initProc, - Tcl_PackageInitProc *safeInitProc); +EXTERN void TclStaticLibrary(Tcl_Interp *interp, + const char *prefix, + Tcl_LibraryInitProc *initProc, + Tcl_LibraryInitProc *safeInitProc); /* 258 */ EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, Tcl_Obj *basenameObj); @@ -710,7 +710,7 @@ typedef struct TclIntStubs { TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */ int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */ Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */ - CONST86 char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ + const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ void (*reserved43)(void); int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */ int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */ @@ -769,7 +769,7 @@ typedef struct TclIntStubs { int (*tclServiceIdle) (void); /* 98 */ void (*reserved99)(void); void (*reserved100)(void); - CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ + const char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ @@ -925,7 +925,7 @@ typedef struct TclIntStubs { Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ - void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ + void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 259 */ void (*tclUnusedStubEntry) (void); /* 260 */ @@ -1370,8 +1370,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ -#define TclStaticPackage \ - (tclIntStubsPtr->tclStaticPackage) /* 257 */ +#define TclStaticLibrary \ + (tclIntStubsPtr->tclStaticLibrary) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #define TclGetBytesFromObj \ @@ -1409,12 +1409,15 @@ extern const TclIntStubs *tclIntStubsPtr; # undef TclGetCommandFullName # undef TclCopyChannelOld # undef TclSockMinimumBuffersOld -# undef Tcl_StaticPackage -# define Tcl_StaticPackage (tclIntStubsPtr->tclStaticPackage) +# undef Tcl_StaticLibrary +# define Tcl_StaticLibrary (tclIntStubsPtr->tclStaticLibrary) #endif #undef TclGuessPackageName +#undef TclUnusedStubEntry +#undef TclSetPreInitScript #ifndef TCL_NO_DEPRECATED +# define TclSetPreInitScript Tcl_SetPreInitScript # define TclGuessPackageName(fileName, pkgName) ((void)fileName,(void)pkgName,0) #endif diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index de308de..bd8d8e5 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -570,6 +570,11 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpGmtime_unix #undef TclWinConvertWSAError #define TclWinConvertWSAError TclWinConvertError +#if !defined(TCL_USE_STUBS) && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +# undef TclWinConvertError +# define TclWinConvertError Tcl_WinConvertError +#endif + #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa diff --git a/generic/tclInterp.c b/generic/tclInterp.c index a263a66..fd90abc 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -281,7 +281,7 @@ static Tcl_ObjCmdProc NRChildCmd; /* *---------------------------------------------------------------------- * - * TclSetPreInitScript -- + * Tcl_SetPreInitScript -- * * This routine is used to change the value of the internal variable, * tclPreInitScript. @@ -296,12 +296,12 @@ static Tcl_ObjCmdProc NRChildCmd; */ const char * -TclSetPreInitScript( +Tcl_SetPreInitScript( const char *string) /* Pointer to a script. */ { const char *prevString = tclPreInitScript; tclPreInitScript = string; - return(prevString); + return prevString; } /* @@ -4785,7 +4785,7 @@ ChildTimeLimitCmd( Tcl_Obj *milliObj = NULL, *secObj = NULL; int gran = 0; Tcl_Time limitMoment; - int tmp; + Tcl_WideInt tmp; Tcl_LimitGetTime(childInterp, &limitMoment); for (i=consumedObjc ; i<objc ; i+=2) { @@ -4817,17 +4817,17 @@ ChildTimeLimitCmd( if (milliLen == 0) { break; } - if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { return TCL_ERROR; } - if (tmp < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "milliseconds must be at least 0", -1)); + if (tmp < 0 || tmp > LONG_MAX) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "milliseconds must be between 0 and %ld", LONG_MAX)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; } - limitMoment.usec = ((long) tmp)*1000; + limitMoment.usec = ((long)tmp)*1000; break; case OPT_SEC: secObj = objv[i+1]; @@ -4835,17 +4835,17 @@ ChildTimeLimitCmd( if (secLen == 0) { break; } - if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { return TCL_ERROR; } - if (tmp < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "seconds must be at least 0", -1)); + if (tmp < 0 || tmp > LONG_MAX) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "seconds must be between 0 and %ld", LONG_MAX)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; } - limitMoment.sec = tmp; + limitMoment.sec = (long)tmp; break; } } diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 8b8aa2b..ed2be03 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -12,89 +12,102 @@ #include "tclInt.h" + /* - * The following structure describes a package that has been loaded either + * The following structure describes a library that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call - * to TclGetLoadedPackages). All such packages are linked together into a - * single list for the process. Packages are never unloaded, until the + * to Tcl_StaticLibrary). All such libraries are linked together into a + * single list for the process. Library are never unloaded, until the * application exits, when TclFinalizeLoad is called, and these structures are * freed. */ -typedef struct LoadedPackage { - char *fileName; /* Name of the file from which the package was - * loaded. An empty string means the package +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 *packageName; /* Name of package prefix for the package, + 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 * is no longer needed. If fileName is NULL, * then this field is irrelevant. */ - Tcl_PackageInitProc *initProc; + Tcl_LibraryInitProc *initProc; /* Initialization function to call to - * incorporate this package into a trusted + * incorporate this library into a trusted * interpreter. */ - Tcl_PackageInitProc *safeInitProc; + Tcl_LibraryInitProc *safeInitProc; /* Initialization function to call to - * incorporate this package into a safe + * incorporate this library into a safe * interpreter (one that will execute - * untrusted scripts). NULL means the package + * untrusted scripts). NULL means the library * can't be used in unsafe interpreters. */ - Tcl_PackageUnloadProc *unloadProc; - /* Finalisation function to unload a package + Tcl_LibraryUnloadProc *unloadProc; + /* Finalization function to unload a library * from a trusted interpreter. NULL means that - * the package cannot be unloaded. */ - Tcl_PackageUnloadProc *safeUnloadProc; - /* Finalisation function to unload a package + * the library cannot be unloaded. */ + Tcl_LibraryUnloadProc *safeUnloadProc; + /* Finalization function to unload a library * from a safe interpreter. NULL means that - * the package cannot be unloaded. */ - int interpRefCount; /* How many times the package has been loaded + * the library cannot be unloaded. */ + int interpRefCount; /* How many times the library has been loaded * in trusted interpreters. */ - int safeInterpRefCount; /* How many times the package has been loaded + int safeInterpRefCount; /* How many times the library has been loaded * in safe interpreters. */ - struct LoadedPackage *nextPtr; - /* Next in list of all packages loaded into + 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 packages 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; - /* First in list of all packages loaded into +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 package that has been + * The following structure represents a particular library that has been * incorporated into a particular interpreter (by calling its initialization * function). There is a list of these structures for each interpreter, with * an AssocData value (key "load") for the interpreter that points to the - * first package (if any). + * first library (if any). */ -typedef struct InterpPackage { - LoadedPackage *pkgPtr; /* Points to detailed information about - * package. */ - struct InterpPackage *nextPtr; - /* Next package in this interpreter, or NULL +typedef struct InterpLibrary { + LoadedLibrary *libraryPtr; /* Points to detailed information about + * library. */ + 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: */ -static void LoadCleanupProc(ClientData clientData, - Tcl_Interp *interp); +static void LoadCleanupProc(ClientData clientData, + Tcl_Interp *interp); +static int IsStatic (LoadedLibrary *libraryPtr); +static int UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target, + LoadedLibrary *library, int keepLibrary, + const char *fullFileName, int interpExiting); + + +static int +IsStatic (LoadedLibrary *libraryPtr) { + int res; + res = (libraryPtr->fileName[0] == '\0'); + return res; +} /* *---------------------------------------------------------------------- @@ -121,14 +134,14 @@ Tcl_LoadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; - LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp, initName, safeInitName; + 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; - const char *p, *fullFileName, *packageName; + Tcl_LibraryInitProc *initProc; + const char *p, *fullFileName, *prefix; Tcl_LoadHandle loadHandle; Tcl_UniChar ch = 0; unsigned len; @@ -159,7 +172,7 @@ Tcl_LoadObjCmd( } } if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"); + Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { @@ -167,23 +180,23 @@ Tcl_LoadObjCmd( } fullFileName = Tcl_GetString(objv[1]); - Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&pfx); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); Tcl_DStringInit(&unloadName); Tcl_DStringInit(&safeUnloadName); Tcl_DStringInit(&tmp); - packageName = NULL; + prefix = NULL; if (objc >= 3) { - packageName = Tcl_GetString(objv[2]); - if (packageName[0] == '\0') { - packageName = NULL; + prefix = Tcl_GetString(objv[2]); + if (prefix[0] == '\0') { + prefix = NULL; } } - if ((fullFileName[0] == 0) && (packageName == NULL)) { + if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must specify either file name or package name", -1)); + "must specify either file name or prefix", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -191,7 +204,7 @@ Tcl_LoadObjCmd( } /* - * Figure out which interpreter we're going to load the package into. + * Figure out which interpreter we're going to load the library into. */ target = interp; @@ -206,89 +219,89 @@ Tcl_LoadObjCmd( } /* - * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if it + * Scan through the libraries that are currently loaded to see if the + * library we want is already loaded. We'll use a loaded library if it * meets any of the following conditions: * - Its name and file match the once we're looking for. * - Its file matches, and we weren't given a name. * - Its name matches, the file name was specified as empty, and there is - * only no statically loaded package with the same name. + * only no statically loaded library with the same prefix. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); defaultPtr = NULL; - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - if (packageName == NULL) { + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { + if (prefix == NULL) { namesMatch = 0; } else { - TclDStringClear(&pkgName); - Tcl_DStringAppend(&pkgName, packageName, -1); + TclDStringClear(&pfx); + Tcl_DStringAppend(&pfx, prefix, -1); TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); + Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); + Tcl_UtfToLower(Tcl_DStringValue(&pfx)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), - Tcl_DStringValue(&pkgName)) == 0) { + Tcl_DStringValue(&pfx)) == 0) { namesMatch = 1; } else { namesMatch = 0; } } - TclDStringClear(&pkgName); + TclDStringClear(&pfx); - filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || (packageName == NULL))) { + filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0); + if (filesMatch && (namesMatch || (prefix == NULL))) { break; } if (namesMatch && (fullFileName[0] == 0)) { - defaultPtr = pkgPtr; + defaultPtr = libraryPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* - * Can't have two different packages loaded from the same file. + * Can't have two different libraries loaded from the same file. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" is already loaded for package \"%s\"", - fullFileName, pkgPtr->packageName)); + "file \"%s\" is already loaded for prefix \"%s\"", + 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; } /* - * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, then + * Scan through the list of libraries already loaded in the target + * interpreter. If the library we want is already loaded there, then * there's nothing for us to do. */ - if (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 package is a static one. + * if the desired library is a static one. */ if (fullFileName[0] == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package \"%s\" isn't loaded statically", packageName)); + "no library with prefix \"%s\" is loaded statically", prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", NULL); code = TCL_ERROR; @@ -296,11 +309,11 @@ Tcl_LoadObjCmd( } /* - * Figure out the module name if it wasn't provided explicitly. + * Figure out the prefix if it wasn't provided explicitly. */ - if (packageName != NULL) { - Tcl_DStringAppend(&pkgName, packageName, -1); + if (prefix != NULL) { + Tcl_DStringAppend(&pfx, prefix, -1); } else { Tcl_Obj *splitPtr, *pkgGuessPtr; int pElements; @@ -311,11 +324,11 @@ Tcl_LoadObjCmd( */ /* - * The platform-specific code couldn't figure out the module - * name. Make a guess by taking the last element of the file - * name, stripping off any leading "lib", and then using all - * of the alphabetic and underline characters that follow - * that. + * The platform-specific code couldn't figure out the prefix. + * Make a guess by taking the last element of the file + * name, stripping off any leading "lib" and/or "tcl", and + * then using all of the alphabetic and underline characters + * that follow that. */ splitPtr = Tcl_FSSplitPath(objv[1], &pElements); @@ -346,85 +359,85 @@ Tcl_LoadObjCmd( if (p == pkgGuess) { Tcl_DecrRefCount(splitPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't figure out package name for %s", + "couldn't figure out prefix for %s", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "WHATPACKAGE", NULL); + "WHATLIBRARY", NULL); code = TCL_ERROR; goto done; } - Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess); + Tcl_DStringAppend(&pfx, pkgGuess, p - pkgGuess); Tcl_DecrRefCount(splitPtr); } /* - * Fix the capitalization in the package name so that the first + * Fix the capitalization in the prefix so that the first * character is in caps (or title case) but the others are all * lower-case. */ - Tcl_DStringSetLength(&pkgName, - Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); + Tcl_DStringSetLength(&pfx, + Tcl_UtfToTitle(Tcl_DStringValue(&pfx))); /* * Compute the names of the two initialization functions, based on the - * package name. + * prefix. */ - TclDStringAppendDString(&initName, &pkgName); + TclDStringAppendDString(&initName, &pfx); TclDStringAppendLiteral(&initName, "_Init"); - TclDStringAppendDString(&safeInitName, &pkgName); + TclDStringAppendDString(&safeInitName, &pfx); TclDStringAppendLiteral(&safeInitName, "_SafeInit"); - TclDStringAppendDString(&unloadName, &pkgName); + TclDStringAppendDString(&unloadName, &pfx); TclDStringAppendLiteral(&unloadName, "_Unload"); - TclDStringAppendDString(&safeUnloadName, &pkgName); + TclDStringAppendDString(&safeUnloadName, &pfx); TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload"); /* - * Call platform-specific code to load the package and find the two + * Call platform-specific code to load the library and find the two * initialization functions. */ 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; } /* - * Create a new record to describe this package. + * 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); - len = Tcl_DStringLength(&pkgName) + 1; - pkgPtr->packageName = (char *)ckalloc(len); - memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); - pkgPtr->loadHandle = loadHandle; - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = (Tcl_PackageInitProc *) + libraryPtr->fileName = (char *)ckalloc(len); + memcpy(libraryPtr->fileName, fullFileName, len); + len = Tcl_DStringLength(&pfx) + 1; + libraryPtr->prefix = (char *)ckalloc(len); + memcpy(libraryPtr->prefix, Tcl_DStringValue(&pfx), len); + libraryPtr->loadHandle = loadHandle; + libraryPtr->initProc = initProc; + libraryPtr->safeInitProc = (Tcl_LibraryInitProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeInitName)); - pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) + libraryPtr->unloadProc = (Tcl_LibraryUnloadProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&unloadName)); - pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) + libraryPtr->safeUnloadProc = (Tcl_LibraryUnloadProc *) 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 @@ -435,32 +448,32 @@ Tcl_LoadObjCmd( } /* - * Invoke the package's initialization function (either the normal one or + * Invoke the library's initialization function (either the normal one or * the safe one, depending on whether or not the interpreter is safe). */ if (Tcl_IsSafe(target)) { - if (pkgPtr->safeInitProc == NULL) { + if (libraryPtr->safeInitProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use package in a safe interpreter: no" - " %s_SafeInit procedure", pkgPtr->packageName)); + "can't use library in a safe interpreter: no" + " %s_SafeInit procedure", libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", NULL); code = TCL_ERROR; goto done; } - code = pkgPtr->safeInitProc(target); + code = libraryPtr->safeInitProc(target); } else { - if (pkgPtr->initProc == NULL) { + if (libraryPtr->initProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't attach package to interpreter: no %s_Init procedure", - pkgPtr->packageName)); + "can't attach library to interpreter: no %s_Init procedure", + libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); code = TCL_ERROR; goto done; } - code = pkgPtr->initProc(target); + code = libraryPtr->initProc(target); } /* @@ -487,33 +500,33 @@ Tcl_LoadObjCmd( } /* - * Record the fact that the package has been loaded in the target + * Record the fact that the library has been loaded in the target * interpreter. * * Update the proper reference count. */ - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&libraryMutex); if (Tcl_IsSafe(target)) { - pkgPtr->safeInterpRefCount++; + libraryPtr->safeInterpRefCount++; } else { - pkgPtr->interpRefCount++; + libraryPtr->interpRefCount++; } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); /* - * Refetch ipFirstPtr: loading the package may have introduced additional - * static packages at the head of the linked list! + * Refetch ipFirstPtr: loading the library may have introduced additional + * static libraries at the head of the linked list! */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = (InterpPackage *)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); done: - Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&pfx); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); Tcl_DStringFree(&unloadName); @@ -547,14 +560,12 @@ Tcl_UnloadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; /* Which interpreter to unload from. */ - LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp; - Tcl_PackageUnloadProc *unloadProc; - InterpPackage *ipFirstPtr, *ipPtr; + LoadedLibrary *libraryPtr; + Tcl_DString pfx, tmp; + InterpLibrary *ipFirstPtr, *ipPtr; int i, index, code, complain = 1, keepLibrary = 0; - int trustedRefCount = -1, safeRefCount = -1; const char *fullFileName = ""; - const char *packageName; + const char *prefix; static const char *const options[] = { "-nocomplain", "-keeplibrary", "--", NULL }; @@ -598,7 +609,7 @@ Tcl_UnloadObjCmd( endOfForLoop: if ((objc-i < 1) || (objc-i > 3)) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? fileName ?packageName? ?interp?"); + "?-switch ...? fileName ?prefix? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { @@ -606,19 +617,19 @@ Tcl_UnloadObjCmd( } fullFileName = Tcl_GetString(objv[i]); - Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&pfx); Tcl_DStringInit(&tmp); - packageName = NULL; + prefix = NULL; if (objc - i >= 2) { - packageName = Tcl_GetString(objv[i+1]); - if (packageName[0] == '\0') { - packageName = NULL; + prefix = Tcl_GetString(objv[i+1]); + if (prefix[0] == '\0') { + prefix = NULL; } } - if ((fullFileName[0] == 0) && (packageName == NULL)) { + if ((fullFileName[0] == 0) && (prefix == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must specify either file name or package name", -1)); + "must specify either file name or prefix", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", NULL); code = TCL_ERROR; @@ -626,7 +637,7 @@ Tcl_UnloadObjCmd( } /* - * Figure out which interpreter we're going to load the package into. + * Figure out which interpreter we're going to load the library into. */ target = interp; @@ -640,65 +651,61 @@ Tcl_UnloadObjCmd( } /* - * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if it + * Scan through the libraries that are currently loaded to see if the + * library we want is already loaded. We'll use a loaded library if it * meets any of the following conditions: - * - Its name and file match the once we're looking for. - * - Its file matches, and we weren't given a name. - * - Its name matches, the file name was specified as empty, and there is - * only no statically loaded package with the same name. + * - Its prefix and file match the once we're looking for. + * - Its file matches, and we weren't given a prefix. + * - Its prefix matches, the file name was specified as empty, and there is + * 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 (packageName == NULL) { + if (prefix == NULL) { namesMatch = 0; } else { - TclDStringClear(&pkgName); - Tcl_DStringAppend(&pkgName, packageName, -1); + TclDStringClear(&pfx); + Tcl_DStringAppend(&pfx, prefix, -1); TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); + Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); + Tcl_UtfToLower(Tcl_DStringValue(&pfx)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), - Tcl_DStringValue(&pkgName)) == 0) { + Tcl_DStringValue(&pfx)) == 0) { namesMatch = 1; } else { namesMatch = 0; } } - TclDStringClear(&pkgName); + TclDStringClear(&pfx); - filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || (packageName == NULL))) { + filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0); + if (filesMatch && (namesMatch || (prefix == NULL))) { break; } - if (namesMatch && (fullFileName[0] == 0)) { - defaultPtr = pkgPtr; - } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { break; } } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); if (fullFileName[0] == 0) { /* - * It's an error to try unload a static package. + * It's an error to try unload a static library. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package \"%s\" is loaded statically and cannot be unloaded", - packageName)); + "library with prefix \"%s\" is loaded statically and cannot be unloaded", + prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", NULL); code = TCL_ERROR; goto done; } - if (pkgPtr == NULL) { + if (libraryPtr == NULL) { /* * The DLL pointed by the provided filename has never been loaded. */ @@ -712,16 +719,16 @@ Tcl_UnloadObjCmd( } /* - * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, then we + * Scan through the list of libraries already loaded in the target + * interpreter. If the library we want is already loaded there, then we * should proceed with unloading. */ code = TCL_ERROR; - if (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; } @@ -729,7 +736,7 @@ Tcl_UnloadObjCmd( } if (code != TCL_OK) { /* - * The package has not been loaded in this interpreter. + * The library has not been loaded in this interpreter. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -741,38 +748,72 @@ Tcl_UnloadObjCmd( goto done; } + code = UnloadLibrary(interp, target, libraryPtr, keepLibrary, fullFileName, 0); + + done: + Tcl_DStringFree(&pfx); + Tcl_DStringFree(&tmp); + if (!complain && (code != TCL_OK)) { + code = TCL_OK; + Tcl_ResetResult(interp); + } + return code; +} + +static int +UnloadLibrary( + Tcl_Interp *interp, + Tcl_Interp *target, + LoadedLibrary *libraryPtr, + int keepLibrary, + const char *fullFileName, + int interpExiting +) +{ + int code; + InterpLibrary *ipFirstPtr, *ipPtr; + LoadedLibrary *iterLibraryPtr; + int trustedRefCount = -1, safeRefCount = -1; + Tcl_LibraryUnloadProc *unloadProc = NULL; + /* * 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) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" cannot be unloaded under a safe interpreter", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - NULL); - code = TCL_ERROR; - goto done; + if (libraryPtr->safeUnloadProc == NULL) { + if (!interpExiting) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded under a safe interpreter", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", + NULL); + code = TCL_ERROR; + goto done; + } } - unloadProc = pkgPtr->safeUnloadProc; + unloadProc = libraryPtr->safeUnloadProc; } else { - if (pkgPtr->unloadProc == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" cannot be unloaded under a trusted interpreter", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - NULL); - code = TCL_ERROR; - goto done; + if (libraryPtr->unloadProc == NULL) { + if (!interpExiting) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded under a trusted interpreter", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", + NULL); + code = TCL_ERROR; + goto done; + } } - unloadProc = pkgPtr->unloadProc; + unloadProc = libraryPtr->unloadProc; } + + /* - * We are ready to unload the package. First, evaluate the unload + * We are ready to unload the library. First, evaluate the unload * function. If this fails, we cannot proceed with unload. Also, we must * specify the proper flag to pass to the unload callback. * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should @@ -781,62 +822,97 @@ Tcl_UnloadObjCmd( * after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed. */ - code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; - if (!keepLibrary) { - Tcl_MutexLock(&packageMutex); - trustedRefCount = pkgPtr->interpRefCount; - safeRefCount = pkgPtr->safeInterpRefCount; - Tcl_MutexUnlock(&packageMutex); - - if (Tcl_IsSafe(target)) { - safeRefCount--; - } else { - trustedRefCount--; - } + if (unloadProc == NULL) { + code = TCL_OK; + } else { + code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; + if (!keepLibrary) { + Tcl_MutexLock(&libraryMutex); + trustedRefCount = libraryPtr->interpRefCount; + safeRefCount = libraryPtr->safeInterpRefCount; + Tcl_MutexUnlock(&libraryMutex); + + if (Tcl_IsSafe(target)) { + safeRefCount--; + } else { + trustedRefCount--; + } - if (safeRefCount <= 0 && trustedRefCount <= 0) { - code = TCL_UNLOAD_DETACH_FROM_PROCESS; + if (safeRefCount <= 0 && trustedRefCount <= 0) { + code = TCL_UNLOAD_DETACH_FROM_PROCESS; + } } + code = unloadProc(target, code); } - code = unloadProc(target, code); + + if (code != TCL_OK) { Tcl_TransferResult(target, code, interp); goto done; } + + /* + * Remove this library from the interpreter's library cache. + */ + + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipPtr = ipFirstPtr; + if (ipPtr->libraryPtr == libraryPtr) { + ipFirstPtr = ipFirstPtr->nextPtr; + } else { + InterpLibrary *ipPrevPtr; + + for (ipPrevPtr = ipPtr; ipPtr != NULL; + ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { + if (ipPtr->libraryPtr == libraryPtr) { + ipPrevPtr->nextPtr = ipPtr->nextPtr; + break; + } + } + } + ckfree(ipPtr); + Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr); + + + if (IsStatic(libraryPtr)) { + goto done; + } + /* * The unload function executed fine. Examine the reference count to see * 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,52 +926,30 @@ Tcl_UnloadObjCmd( * it's been unloaded. */ - if (pkgPtr->fileName[0] != '\0') { - Tcl_MutexLock(&packageMutex); - if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) { + if (!IsStatic(libraryPtr)) { + 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; + iterLibraryPtr = libraryPtr; + if (iterLibraryPtr == 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 == iterLibraryPtr) { + libraryPtr->nextPtr = iterLibraryPtr->nextPtr; break; } } } - /* - * Remove this library from the interpreter's library cache. - */ - - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = ipFirstPtr; - if (ipPtr->pkgPtr == defaultPtr) { - ipFirstPtr = ipFirstPtr->nextPtr; - } else { - InterpPackage *ipPrevPtr; - - for (ipPrevPtr = ipPtr; ipPtr != NULL; - ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == defaultPtr) { - ipPrevPtr->nextPtr = ipPtr->nextPtr; - break; - } - } - } - Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, - ipFirstPtr); - ckfree(defaultPtr->fileName); - ckfree(defaultPtr->packageName); - ckfree(defaultPtr); - ckfree(ipPtr); - Tcl_MutexUnlock(&packageMutex); + ckfree(iterLibraryPtr->fileName); + ckfree(iterLibraryPtr->prefix); + ckfree(iterLibraryPtr); + Tcl_MutexUnlock(&libraryMutex); } else { code = TCL_ERROR; } @@ -911,111 +965,107 @@ Tcl_UnloadObjCmd( } done: - Tcl_DStringFree(&pkgName); - Tcl_DStringFree(&tmp); - if (!complain && (code != TCL_OK)) { - code = TCL_OK; - Tcl_ResetResult(interp); - } return code; } /* *---------------------------------------------------------------------- * - * Tcl_StaticPackage -- + * Tcl_StaticLibrary -- * - * This function is invoked to indicate that a particular package has + * This function is invoked to indicate that a particular library has * been linked statically with an application. * * Results: * None. * * Side effects: - * Once this function completes, the package becomes loadable via the + * Once this function completes, the library becomes loadable via the * "load" command with an empty file name. * *---------------------------------------------------------------------- */ void -Tcl_StaticPackage( - Tcl_Interp *interp, /* If not NULL, it means that the package has +Tcl_StaticLibrary( + Tcl_Interp *interp, /* If not NULL, it means that the library has * already been loaded into the given * interpreter by calling the appropriate init * proc. */ - const char *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, + Tcl_LibraryInitProc *initProc, /* Function to call to incorporate this - * package into a trusted interpreter. */ - Tcl_PackageInitProc *safeInitProc) + * library into a trusted interpreter. */ + Tcl_LibraryInitProc *safeInitProc) /* Function to call to incorporate this - * package into a safe interpreter (one that + * library into a safe interpreter (one that * will execute untrusted scripts). NULL means - * the package can't be used in safe + * the library can't be used in safe * interpreters. */ { - LoadedPackage *pkgPtr; - InterpPackage *ipPtr, *ipFirstPtr; + LoadedLibrary *libraryPtr; + InterpLibrary *ipPtr, *ipFirstPtr; /* - * Check to see if someone else has already reported this package as + * Check to see if someone else has already reported this library as * statically loaded in the process. */ - Tcl_MutexLock(&packageMutex); - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - if ((pkgPtr->initProc == initProc) - && (pkgPtr->safeInitProc == safeInitProc) - && (strcmp(pkgPtr->packageName, pkgName) == 0)) { + Tcl_MutexLock(&libraryMutex); + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { + if ((libraryPtr->initProc == initProc) + && (libraryPtr->safeInitProc == safeInitProc) + && (strcmp(libraryPtr->prefix, prefix) == 0)) { break; } } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); /* - * If the package is not yet recorded as being loaded statically, add it + * 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->packageName = (char *)ckalloc(strlen(pkgName) + 1); - strcpy(pkgPtr->packageName, pkgName); - pkgPtr->loadHandle = NULL; - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = safeInitProc; - Tcl_MutexLock(&packageMutex); - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; - Tcl_MutexUnlock(&packageMutex); + if (libraryPtr == NULL) { + libraryPtr = (LoadedLibrary *)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; + libraryPtr->unloadProc = NULL; + libraryPtr->safeUnloadProc = NULL; + Tcl_MutexLock(&libraryMutex); + libraryPtr->nextPtr = firstLibraryPtr; + firstLibraryPtr = libraryPtr; + Tcl_MutexUnlock(&libraryMutex); } if (interp != NULL) { /* - * If we're loading the package into an interpreter, determine whether + * If we're loading the library into an interpreter, determine whether * it's already loaded. */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(interp, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->libraryPtr == libraryPtr) { return; } } /* - * Package isn't loaded in the current interp yet. Mark it as now being + * Library isn't loaded in the current interp yet. Mark it as now being * 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); } @@ -1024,7 +1074,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). @@ -1034,7 +1084,7 @@ Tcl_StaticPackage( * list of lists is placed in the interp's result. Each sublist * corresponds to one loaded file; its first element is the name of the * file (or an empty string for something that's statically loaded) and - * the second element is the name of the package in that file. + * the second element is the prefix of the library in that file. * * Side effects: * None. @@ -1043,33 +1093,33 @@ Tcl_StaticPackage( */ int -TclGetLoadedPackagesEx( +TclGetLoadedLibraries( Tcl_Interp *interp, /* Interpreter in which to return information * or error message. */ const char *targetName, /* Name of target interpreter or NULL. If * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ - const char *packageName) /* Package name or NULL. If NULL, return info - * for all packages. + const char *prefix) /* Prefix or NULL. If NULL, return info + * for all prefixes. */ { 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->packageName, -1); + Tcl_MutexLock(&libraryMutex); + for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; + libraryPtr = libraryPtr->nextPtr) { + pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1); + pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); } - Tcl_MutexUnlock(&packageMutex); + Tcl_MutexUnlock(&libraryMutex); Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1078,19 +1128,19 @@ 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 packages. + * Return information about all of the available libraries. */ - if (packageName) { + if (prefix) { resultObj = NULL; for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - pkgPtr = ipPtr->pkgPtr; + libraryPtr = ipPtr->libraryPtr; - if (!strcmp(packageName, pkgPtr->packageName)) { - resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); + if (!strcmp(prefix, libraryPtr->prefix)) { + resultObj = Tcl_NewStringObj(libraryPtr->fileName, -1); break; } } @@ -1102,15 +1152,15 @@ TclGetLoadedPackagesEx( } /* - * Return information about only the packages that are loaded in a given + * Return information about only the libraries that are loaded in a given * interpreter. */ TclNewObj(resultObj); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - pkgPtr = ipPtr->pkgPtr; - pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + libraryPtr = ipPtr->libraryPtr; + pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1); + pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); } Tcl_SetObjResult(interp, resultObj); @@ -1122,7 +1172,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,24 +1180,27 @@ 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 + TCL_UNUSED(ClientData), /* Pointer to first InterpLibrary structure * for interp. */ - TCL_UNUSED(Tcl_Interp *)) + Tcl_Interp *interp) { - InterpPackage *ipPtr, *nextPtr; + InterpLibrary *ipPtr; + LoadedLibrary *libraryPtr; - ipPtr = (InterpPackage *)clientData; - while (ipPtr != NULL) { - nextPtr = ipPtr->nextPtr; - ckfree(ipPtr); - ipPtr = nextPtr; + while (1) { + ipPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL); + if (ipPtr == NULL) { + break; + } + libraryPtr = ipPtr->libraryPtr; + UnloadLibrary(interp, interp, libraryPtr, 0 ,"", 1); } } @@ -1157,7 +1210,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 +1224,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 +1245,14 @@ TclFinalizeLoad(void) * it has been unloaded. */ - if (pkgPtr->fileName[0] != '\0') { - Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle); + if (!IsStatic(libraryPtr)) { + Tcl_FSUnloadFile(NULL, libraryPtr->loadHandle); } #endif - ckfree(pkgPtr->fileName); - ckfree(pkgPtr->packageName); - ckfree(pkgPtr); + ckfree(libraryPtr->fileName); + ckfree(libraryPtr->prefix); + ckfree(libraryPtr); } } diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index f57b7e1..5dc9659 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -306,7 +306,7 @@ Tcl_PushCallFrame( /* * TODO: Examine whether it would be better to guard based on NS_DYING - * or NS_KILLED. It appears that these are not tested because they can + * or NS_TEARDOWN. It appears that these are not tested because they can * be set in a global interp that has been [namespace delete]d, but * which never really completely goes away because of lingering global * things like ::errorInfo and [::unknown] and hidden commands. @@ -986,20 +986,21 @@ Tcl_DeleteNamespace( } /* - * If the namespace is on the call frame stack, it is marked as "dying" - * (NS_DYING is OR'd into its flags): the namespace can't be looked up by - * name but its commands and variables are still usable by those active - * call frames. When all active call frames referring to the namespace - * have been popped from the Tcl stack, Tcl_PopCallFrame will call this - * function again to delete everything in the namespace. If no nsName - * objects refer to the namespace (i.e., if its refCount is zero), its - * commands and variables are deleted and the storage for its namespace - * structure is freed. Otherwise, if its refCount is nonzero, the - * namespace's commands and variables are deleted but the structure isn't - * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the - * namespace resolution code to recognize that the namespace is "deleted". - * The structure's storage is freed by FreeNsNameInternalRep when its - * refCount reaches 0. + * If the namespace is on the call frame stack, it is marked as "dying" + * (NS_DYING is OR'd into its flags): Contents of the namespace are + * still available and visible until the namespace is later marked as + * NS_DEAD, and its commands and variables are still usable by any + * active call frames referring to th namespace. When all active call + * frames referring to the namespace have been popped from the Tcl + * stack, Tcl_PopCallFrame calls Tcl_DeleteNamespace again. If no + * nsName objects refer to the namespace (i.e., if its refCount is + * zero), its commands and variables are deleted and the storage for + * its namespace structure is freed. Otherwise, if its refCount is + * nonzero, the namespace's commands and variables are deleted but the + * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's + * flags to allow the namespace resolution code to recognize that the + * namespace is "deleted". The structure's storage is freed by + * FreeNsNameInternalRep when its refCount reaches 0. */ if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) { @@ -1013,16 +1014,16 @@ Tcl_DeleteNamespace( } } nsPtr->parentPtr = NULL; - } else if (!(nsPtr->flags & NS_KILLED)) { + } else if (!(nsPtr->flags & NS_TEARDOWN)) { /* * Delete the namespace and everything in it. If this is the global * namespace, then clear it but don't free its storage unless the - * interpreter is being torn down. Set the NS_KILLED flag to avoid + * interpreter is being torn down. Set the NS_TEARDOWN flag to avoid * recursive calls here - if the namespace is really in the process of * being deleted, ignore any second call. */ - nsPtr->flags |= (NS_DYING|NS_KILLED); + nsPtr->flags |= (NS_DYING|NS_TEARDOWN); TclTeardownNamespace(nsPtr); @@ -1060,7 +1061,7 @@ Tcl_DeleteNamespace( * get killed later, avoiding mem leaks. */ - nsPtr->flags &= ~(NS_DYING|NS_KILLED); + nsPtr->flags &= ~(NS_DYING|NS_TEARDOWN); } } TclNsDecrRefCount(nsPtr); @@ -1073,6 +1074,83 @@ TclNamespaceDeleted( return (nsPtr->flags & NS_DYING) ? 1 : 0; } +void +TclDeleteNamespaceChildren( + Namespace *nsPtr /* Namespace whose children to delete */ +) +{ + Interp *iPtr = (Interp *) nsPtr->interp; + Tcl_HashEntry *entryPtr; + int i, unchecked; + Tcl_HashSearch search; + /* + * Delete all the child namespaces. + * + * BE CAREFUL: When each child is deleted, it divorces itself from its + * parent. The hash table can't be proplery traversed if its elements are + * being deleted. Because of traces (and the desire to avoid the + * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug + * f97d4ee020]) copy to a temporary array and then delete all those + * namespaces. + * + * Important: leave the hash table itself still live. + */ + +#ifndef BREAK_NAMESPACE_COMPAT + unchecked = (nsPtr->childTable.numEntries > 0); + while (nsPtr->childTable.numEntries > 0 && unchecked) { + int length = nsPtr->childTable.numEntries; + Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = (Namespace *)Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + unchecked = 0; + for (i = 0 ; i < length ; i++) { + if (!(children[i]->flags & NS_DYING)) { + unchecked = 1; + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + } + TclStackFree((Tcl_Interp *) iPtr, children); + } +#else + if (nsPtr->childTablePtr != NULL) { + unchecked = (nsPtr->childTable.numEntries > 0); + while (nsPtr->childTable.numEntries > 0 && unchecked) { + int length = nsPtr->childTablePtr->numEntries; + Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = (Namespace *)Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + unchecked = 0; + for (i = 0 ; i < length ; i++) { + if (!(children[i]->flags & NS_DYING)) { + unchecked = 1; + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + } + TclStackFree((Tcl_Interp *) iPtr, children); + } + } +#endif +} + /* *---------------------------------------------------------------------- * @@ -1181,62 +1259,7 @@ TclTeardownNamespace( nsPtr->commandPathSourceList = NULL; } - /* - * Delete all the child namespaces. - * - * BE CAREFUL: When each child is deleted, it will divorce itself from its - * parent. You can't traverse a hash table properly if its elements are - * being deleted. Because of traces (and the desire to avoid the - * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug - * f97d4ee020]) we copy to a temporary array and then delete all those - * namespaces. - * - * Important: leave the hash table itself still live. - */ - -#ifndef BREAK_NAMESPACE_COMPAT - while (nsPtr->childTable.numEntries > 0) { - int length = nsPtr->childTable.numEntries; - Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Namespace *) * length); - - i = 0; - for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - children[i] = (Namespace *)Tcl_GetHashValue(entryPtr); - children[i]->refCount++; - i++; - } - for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); - TclNsDecrRefCount(children[i]); - } - TclStackFree((Tcl_Interp *) iPtr, children); - } -#else - if (nsPtr->childTablePtr != NULL) { - while (nsPtr->childTablePtr->numEntries > 0) { - int length = nsPtr->childTablePtr->numEntries; - Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Namespace *) * length); - - i = 0; - for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - children[i] = Tcl_GetHashValue(entryPtr); - children[i]->refCount++; - i++; - } - for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); - TclNsDecrRefCount(children[i]); - } - TclStackFree((Tcl_Interp *) iPtr, children); - } - } -#endif + TclDeleteNamespaceChildren(nsPtr); /* * Free the namespace's export pattern array. @@ -2618,7 +2641,7 @@ Tcl_FindCommand( &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL)) { if ((cxtNsPtr == realNsPtr) - || !(realNsPtr->flags & NS_DYING)) { + || !(realNsPtr->flags & NS_DEAD)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); @@ -2630,7 +2653,7 @@ Tcl_FindCommand( * Next, check along the path. */ - for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) { + for (i=0 ; (cmdPtr == NULL) && i<cxtNsPtr->commandPathLength ; i++) { pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr; if (pathNsPtr == NULL) { continue; @@ -2639,7 +2662,7 @@ Tcl_FindCommand( TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL) - && !(realNsPtr->flags & NS_DYING)) { + && !(realNsPtr->flags & NS_DEAD)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); @@ -2657,7 +2680,7 @@ Tcl_FindCommand( TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL) - && !(realNsPtr->flags & NS_DYING)) { + && !(realNsPtr->flags & NS_DEAD)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); @@ -3277,7 +3300,7 @@ NamespaceDeleteCmd( name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); if ((namespacePtr == NULL) - || (((Namespace *) namespacePtr)->flags & NS_KILLED)) { + || (((Namespace *) namespacePtr)->flags & NS_TEARDOWN)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown namespace \"%s\" in namespace delete command", TclGetString(objv[i]))); diff --git a/generic/tclNotify.c b/generic/tclNotify.c index b43413d..12b40b1 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -10,6 +10,7 @@ * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 1998 Scriptics Corporation. * Copyright © 2003 Kevin B. Kenny. All rights reserved. + * Copyright © 2021 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -18,11 +19,11 @@ #include "tclInt.h" /* - * Module-scope struct of notifier hooks that are checked in the default + * Notifier hooks that are checked in the public wrappers for the default * notifier functions (for overriding via Tcl_SetNotifier). */ -Tcl_NotifierProcs tclNotifierHooks = { +static Tcl_NotifierProcs tclNotifierHooks = { NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL }; @@ -174,7 +175,8 @@ TclFinalizeNotifier(void) Tcl_Event *evPtr, *hold; if (!tsdPtr->initialized) { - return; /* Notifier not initialized for the current thread */ + return; /* Notifier not initialized for the current + * thread. */ } Tcl_MutexLock(&(tsdPtr->queueMutex)); @@ -227,6 +229,38 @@ Tcl_SetNotifier( Tcl_NotifierProcs *notifierProcPtr) { tclNotifierHooks = *notifierProcPtr; + + /* + * Don't allow hooks to refer to the hook point functions; avoids infinite + * loop. + */ + + if (tclNotifierHooks.setTimerProc == Tcl_SetTimer) { + tclNotifierHooks.setTimerProc = NULL; + } + if (tclNotifierHooks.waitForEventProc == Tcl_WaitForEvent) { + tclNotifierHooks.waitForEventProc = NULL; + } + if (tclNotifierHooks.initNotifierProc == Tcl_InitNotifier) { + tclNotifierHooks.initNotifierProc = NULL; + } + if (tclNotifierHooks.finalizeNotifierProc == Tcl_FinalizeNotifier) { + tclNotifierHooks.finalizeNotifierProc = NULL; + } + if (tclNotifierHooks.alertNotifierProc == Tcl_AlertNotifier) { + tclNotifierHooks.alertNotifierProc = NULL; + } + if (tclNotifierHooks.serviceModeHookProc == Tcl_ServiceModeHook) { + tclNotifierHooks.serviceModeHookProc = NULL; + } +#ifndef _WIN32 + if (tclNotifierHooks.createFileHandlerProc == Tcl_CreateFileHandler) { + tclNotifierHooks.createFileHandlerProc = NULL; + } + if (tclNotifierHooks.deleteFileHandlerProc == Tcl_DeleteFileHandler) { + tclNotifierHooks.deleteFileHandlerProc = NULL; + } +#endif /* !_WIN32 */ } /* @@ -276,7 +310,7 @@ Tcl_CreateEventSource( * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - EventSource *sourcePtr = (EventSource *)ckalloc(sizeof(EventSource)); + EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; sourcePtr->checkProc = checkProc; @@ -794,7 +828,7 @@ Tcl_SetServiceMode( void Tcl_SetMaxBlockTime( - const Tcl_Time *timePtr) /* Specifies a maximum elapsed time for the + const Tcl_Time *timePtr) /* Specifies a maximum elapsed time for the * next blocking operation in the event * tsdPtr-> */ { @@ -1133,6 +1167,260 @@ Tcl_ThreadAlert( } /* + *---------------------------------------------------------------------- + * + * Tcl_InitNotifier -- + * + * Initializes the platform specific notifier state. Forwards to the + * platform implementation when the hook is not enabled. + * + * Results: + * Returns a handle to the notifier state for this thread.. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_InitNotifier(void) +{ + if (tclNotifierHooks.initNotifierProc) { + return tclNotifierHooks.initNotifierProc(); + } else { + return TclpInitNotifier(); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FinalizeNotifier -- + * + * This function is called to cleanup the notifier state before a thread + * is terminated. Forwards to the platform implementation when the hook + * is not enabled. + * + * Results: + * None. + * + * Side effects: + * If no finalizeNotifierProc notifier hook exists, TclpFinalizeNotifier + * is called. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FinalizeNotifier( + ClientData clientData) +{ + if (tclNotifierHooks.finalizeNotifierProc) { + tclNotifierHooks.finalizeNotifierProc(clientData); + } else { + TclpFinalizeNotifier(clientData); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AlertNotifier -- + * + * Wake up the specified notifier from any thread. This routine is called + * by the platform independent notifier code whenever the Tcl_ThreadAlert + * routine is called. This routine is guaranteed not to be called by Tcl + * on a given notifier after Tcl_FinalizeNotifier is called for that + * notifier. This routine is typically called from a thread other than + * the notifier's thread. Forwards to the platform implementation when + * the hook is not enabled. + * + * Results: + * None. + * + * Side effects: + * See the platform-specific implementations. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AlertNotifier( + ClientData clientData) /* Pointer to thread data. */ +{ + if (tclNotifierHooks.alertNotifierProc) { + tclNotifierHooks.alertNotifierProc(clientData); + } else { + TclpAlertNotifier(clientData); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ServiceModeHook -- + * + * This function is invoked whenever the service mode changes. Forwards + * to the platform implementation when the hook is not enabled. + * + * Results: + * None. + * + * Side effects: + * See the platform-specific implementations. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ServiceModeHook( + int mode) /* Either TCL_SERVICE_ALL, or + * TCL_SERVICE_NONE. */ +{ + if (tclNotifierHooks.serviceModeHookProc) { + tclNotifierHooks.serviceModeHookProc(mode); + } else { + TclpServiceModeHook(mode); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetTimer -- + * + * This function sets the current notifier timer value. Forwards to the + * platform implementation when the hook is not enabled. + * + * Results: + * None. + * + * Side effects: + * See the platform-specific implementations. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetTimer( + const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ +{ + if (tclNotifierHooks.setTimerProc) { + tclNotifierHooks.setTimerProc(timePtr); + } else { + TclpSetTimer(timePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitForEvent -- + * + * This function is called by Tcl_DoOneEvent to wait for new events on + * the notifier's message queue. If the block time is 0, then + * Tcl_WaitForEvent just polls without blocking. Forwards to the + * platform implementation when the hook is not enabled. + * + * Results: + * Returns -1 if the wait would block forever, 1 if an out-of-loop source + * was processed (see platform-specific notes) and otherwise returns 0. + * + * Side effects: + * Queues file events that are detected by the notifier. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitForEvent( + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ +{ + if (tclNotifierHooks.waitForEventProc) { + return tclNotifierHooks.waitForEventProc(timePtr); + } else { + return TclpWaitForEvent(timePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateFileHandler -- + * + * This function registers a file descriptor handler with the notifier. + * Forwards to the platform implementation when the hook is not enabled. + * + * This function is not defined on Windows. The OS API there is too + * different. + * + * Results: + * None. + * + * Side effects: + * Creates a new file handler structure. + * + *---------------------------------------------------------------------- + */ + +#ifndef _WIN32 +void +Tcl_CreateFileHandler( + int fd, /* Handle of stream to watch. */ + int mask, /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: indicates + * conditions under which proc should be + * called. */ + Tcl_FileProc *proc, /* Function to call for each selected + * event. */ + ClientData clientData) /* Arbitrary data to pass to proc. */ +{ + if (tclNotifierHooks.createFileHandlerProc) { + tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); + } else { + TclpCreateFileHandler(fd, mask, proc, clientData); + } +} +#endif /* !_WIN32 */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteFileHandler -- + * + * Cancel a previously-arranged callback arrangement for a file + * descriptor. Forwards to the platform implementation when the hook is + * not enabled. + * + * This function is not defined on Windows. The OS API there is too + * different. + * + * Results: + * None. + * + * Side effects: + * If a callback was previously registered on the file descriptor, remove + * it. + * + *---------------------------------------------------------------------- + */ + +#ifndef _WIN32 +void +Tcl_DeleteFileHandler( + int fd) /* Stream id for which to remove callback + * function. */ +{ + if (tclNotifierHooks.deleteFileHandlerProc) { + tclNotifierHooks.deleteFileHandlerProc(fd); + } else { + TclpDeleteFileHandler(fd); + } +} +#endif /* !_WIN32 */ + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclParse.c b/generic/tclParse.c index df6c9bf..4de0356 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -935,7 +935,7 @@ TclParseBackslash( * #217987] test subst-3.2 */ - if (TclUCS4Complete(p, numBytes - 1)) { + if (Tcl_UtfCharComplete(p, numBytes - 1)) { count = TclUtfToUCS4(p, &unichar) + 1; /* +1 for '\' */ } else { char utfBytes[8]; diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index 672d3c9..d84472c 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -2,7 +2,7 @@ * tclPkgConfig.c -- * * This file contains the configuration information to embed into the tcl - * binary library. + * library. * * Copyright © 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> * diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index ee5ca50..f2bc0da 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -65,6 +65,9 @@ EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, /* 1 */ EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr); +/* Slot 2 is reserved */ +/* 3 */ +EXTERN void Tcl_WinConvertError(unsigned errCode); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ @@ -89,6 +92,8 @@ typedef struct TclPlatStubs { #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ + void (*reserved2)(void); + void (*tcl_WinConvertError) (unsigned errCode); /* 3 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */ @@ -114,6 +119,9 @@ extern const TclPlatStubs *tclPlatStubsPtr; (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ #define Tcl_WinTCharToUtf \ (tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */ +/* Slot 2 is reserved */ +#define Tcl_WinConvertError \ + (tclPlatStubsPtr->tcl_WinConvertError) /* 3 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #define Tcl_MacOSXOpenBundleResources \ diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c index d91a9c4..ecdf652 100644 --- a/generic/tclPosixStr.c +++ b/generic/tclPosixStr.c @@ -158,6 +158,9 @@ Tcl_ErrnoId(void) #ifdef EINIT case EINIT: return "EINIT"; #endif +#ifdef EILSEQ + case EILSEQ: return "EILSEQ"; +#endif #ifdef EINPROGRESS case EINPROGRESS: return "EINPROGRESS"; #endif @@ -617,6 +620,9 @@ Tcl_ErrnoMsg( #ifdef EINIT case EINIT: return "initialization error"; #endif +#ifdef EILSEQ + case EILSEQ: return "illegal byte sequence"; +#endif #ifdef EINPROGRESS case EINPROGRESS: return "operation now in progress"; #endif diff --git a/generic/tclResult.c b/generic/tclResult.c index ba42e46..5b7a8e5 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -464,6 +464,7 @@ Tcl_SetResult( ResetObjResult(iPtr); } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -482,10 +483,12 @@ Tcl_SetResult( *---------------------------------------------------------------------- */ +#undef Tcl_GetStringResult const char * Tcl_GetStringResult( Tcl_Interp *interp)/* Interpreter whose result to return. */ { +#ifndef TCL_NO_DEPRECATED Interp *iPtr = (Interp *) interp; /* * If the string result is empty, move the object result to the string @@ -497,8 +500,10 @@ Tcl_GetStringResult( TCL_VOLATILE); } return iPtr->result; +#else + return TclGetString(Tcl_GetObjResult(interp)); +#endif } -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 50b473a..508b280 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -70,6 +70,11 @@ static void SetUnicodeObj(Tcl_Obj *objPtr, static int UnicodeLength(const Tcl_UniChar *unicode); static void UpdateStringOfString(Tcl_Obj *objPtr); +#define ISCONTINUATION(bytes) (\ + ((((bytes)[0] & 0xC0) == 0x80) || (((bytes)[0] == '\xED') \ + && (((bytes)[1] & 0xF0) == 0xB0) && (((bytes)[2] & 0xC0) == 0x80)))) + + /* * The structure below defines the string Tcl object type by means of * functions that can be invoked by generic object code. @@ -1199,10 +1204,10 @@ Tcl_AppendLimitedToObj( } eLen = strlen(ellipsis); while (eLen > limit) { - eLen = TclUtfPrev(ellipsis+eLen, ellipsis) - ellipsis; + eLen = Tcl_UtfPrev(ellipsis+eLen, ellipsis) - ellipsis; } - toCopy = TclUtfPrev(bytes+limit+1-eLen, bytes) - bytes; + toCopy = Tcl_UtfPrev(bytes+limit+1-eLen, bytes) - bytes; } /* @@ -1218,6 +1223,12 @@ Tcl_AppendLimitedToObj( SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); + /* If appended string starts with a continuation byte or a lower surrogate, + * force objPtr to unicode representation. See [7f1162a867] */ + if (bytes && ISCONTINUATION(bytes)) { + Tcl_GetUnicode(objPtr); + stringPtr = GET_STRING(objPtr); + } if (stringPtr->hasUnicode && stringPtr->numChars > 0) { AppendUtfToUnicodeRep(objPtr, bytes, toCopy); } else { @@ -1415,6 +1426,13 @@ Tcl_AppendObjToObj( SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); + /* If appended string starts with a continuation byte or a lower surrogate, + * force objPtr to unicode representation. See [7f1162a867] + * This fixes append-3.4, append-3.7 and utf-1.18 testcases. */ + if (ISCONTINUATION(TclGetString(appendObjPtr))) { + Tcl_GetUnicode(objPtr); + stringPtr = GET_STRING(objPtr); + } /* * If objPtr has a valid Unicode rep, then get a Unicode string from * appendObjPtr and append it. @@ -2644,7 +2662,7 @@ AppendPrintfToObjVA( * multi-byte characters. */ - q = TclUtfPrev(end, bytes); + q = Tcl_UtfPrev(end, bytes); if (!Tcl_UtfCharComplete(q, (int)(end - q))) { end = q; } @@ -3032,7 +3050,7 @@ TclStringCat( { Tcl_Obj *objResultPtr, * const *ov; int oc, length = 0, binary = 1; - int allowUniChar = 1, requestUniChar = 0; + int allowUniChar = 1, requestUniChar = 0, forceUniChar = 0; int first = objc - 1; /* Index of first value possibly not empty */ int last = 0; /* Index of last value possibly not empty */ int inPlace = flags & TCL_STRING_IN_PLACE; @@ -3068,7 +3086,9 @@ TclStringCat( */ binary = 0; - if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { + if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) { + forceUniChar = 1; + } else if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { /* Prevent shimmer of non-string types. */ allowUniChar = 0; } @@ -3117,7 +3137,7 @@ TclStringCat( } } } while (--oc); - } else if (allowUniChar && requestUniChar) { + } else if ((allowUniChar && requestUniChar) || forceUniChar) { /* * Result will be pure Tcl_UniChar array. Pre-size it. */ @@ -3270,7 +3290,7 @@ TclStringCat( dst += more; } } - } else if (allowUniChar && requestUniChar) { + } else if ((allowUniChar && requestUniChar) || forceUniChar) { /* Efficiently produce a pure Tcl_UniChar array result */ Tcl_UniChar *dst; @@ -3456,7 +3476,7 @@ TclStringCmp( s1 = (char *) Tcl_GetUnicode(value1Ptr); s2 = (char *) Tcl_GetUnicode(value2Ptr); if ( -#ifdef WORDS_BIGENDIAN +#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3) 1 #else checkEq @@ -3809,6 +3829,9 @@ TclStringReverse( String *stringPtr; Tcl_UniChar ch = 0; int inPlace = flags & TCL_STRING_IN_PLACE; +#if TCL_UTF_MAX < 4 + int needFlip = 0; +#endif if (TclIsPureByteArray(objPtr)) { int numBytes; @@ -3826,11 +3849,11 @@ TclStringReverse( if (stringPtr->hasUnicode) { Tcl_UniChar *from = Tcl_GetUnicode(objPtr); + stringPtr = GET_STRING(objPtr); Tcl_UniChar *src = from + stringPtr->numChars; + Tcl_UniChar *to; if (!inPlace || Tcl_IsShared(objPtr)) { - Tcl_UniChar *to; - /* * Create a non-empty, pure unicode value, so we can coax * Tcl_SetObjLength into growing the unicode rep buffer. @@ -3839,20 +3862,56 @@ TclStringReverse( objPtr = Tcl_NewUnicodeObj(&ch, 1); Tcl_SetObjLength(objPtr, stringPtr->numChars); to = Tcl_GetUnicode(objPtr); + stringPtr = GET_STRING(objPtr); while (--src >= from) { +#if TCL_UTF_MAX < 4 + ch = *src; + if ((ch & 0xF800) == 0xD800) { + needFlip = 1; + } + *to++ = ch; +#else *to++ = *src; +#endif } } else { /* * Reversing in place. */ +#if TCL_UTF_MAX < 4 + to = src; +#endif while (--src > from) { ch = *src; +#if TCL_UTF_MAX < 4 + if ((ch & 0xF800) == 0xD800) { + needFlip = 1; + } +#endif *src = *from; *from++ = ch; } } +#if TCL_UTF_MAX < 4 + if (needFlip) { + /* + * Flip back surrogate pairs. + */ + + from = to - stringPtr->numChars; + while (--to >= from) { + ch = *to; + if ((ch & 0xFC00) == 0xD800) { + if ((to-1 >= from) && ((to[-1] & 0xFC00) == 0xDC00)) { + to[0] = to[-1]; + to[-1] = ch; + --to; + } + } + } + } +#endif } if (objPtr->bytes) { @@ -3876,8 +3935,8 @@ TclStringReverse( * Pass 1. Reverse the bytes of each multi-byte character. */ - int charCount = 0; int bytesLeft = numBytes; + int chw; while (bytesLeft) { /* @@ -3886,18 +3945,16 @@ TclStringReverse( * skip calling Tcl_UtfCharComplete() here. */ - int bytesInChar = TclUtfToUniChar(from, &ch); + int bytesInChar = TclUtfToUCS4(from, &chw); ReverseBytes((unsigned char *)to, (unsigned char *)from, bytesInChar); to += bytesInChar; from += bytesInChar; bytesLeft -= bytesInChar; - charCount++; } from = to = objPtr->bytes; - stringPtr->numChars = charCount; } /* Pass 2. Reverse all the bytes. */ ReverseBytes((unsigned char *)to, (unsigned char *)from, numBytes); @@ -4110,9 +4167,22 @@ ExtendUnicodeRepWithString( } else { numAppendChars = 0; } - for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { + dst = stringPtr->unicode + numOrigChars; + if (numAppendChars-- > 0) { bytes += TclUtfToUniChar(bytes, &unichar); - *dst = unichar; +#if TCL_UTF_MAX > 3 + /* join upper/lower surrogate */ + if (bytes && (stringPtr->unicode[numOrigChars - 1] | 0x3FF) == 0xDBFF && (unichar | 0x3FF) == 0xDFFF) { + stringPtr->numChars--; + unichar = ((stringPtr->unicode[numOrigChars - 1] & 0x3FF) << 10) + (unichar & 0x3FF) + 0x10000; + dst--; + } +#endif + *dst++ = unichar; + while (numAppendChars-- > 0) { + bytes += TclUtfToUniChar(bytes, &unichar); + *dst++ = unichar; + } } *dst = 0; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index dd7dc26..5028916 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -65,15 +65,22 @@ #undef TclWinGetSockOpt #undef TclWinSetSockOpt #undef TclWinNToHS -#undef TclStaticPackage +#undef TclStaticLibrary #undef Tcl_BackgroundError #undef TclGuessPackageName #undef TclGetLoadedPackages -#define TclStaticPackage Tcl_StaticPackage +#define TclStaticLibrary Tcl_StaticLibrary #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar #undef Tcl_MacOSXOpenBundleResources +#undef TclWinConvertWSAError +#undef TclWinConvertError +#if defined(_WIN32) || defined(__CYGWIN__) +#define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError +#define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError +#endif + #if TCL_UTF_MAX > 3 static void uniCodePanic(void) { @@ -90,6 +97,32 @@ static void uniCodePanic(void) { # define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic #endif +#define TclUtfCharComplete UtfCharComplete +#define TclUtfNext UtfNext +#define TclUtfPrev UtfPrev + +static int TclUtfCharComplete(const char *src, int length) { + if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) { + return length < 3; + } + return Tcl_UtfCharComplete(src, length); +} + +static const char *TclUtfNext(const char *src) { + if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) { + return src + 1; + } + return Tcl_UtfNext(src); +} + +static const char *TclUtfPrev(const char *src, const char *start) { + if ((src >= start + 3) && ((src[-1] & 0xC0) == 0x80) + && ((src[-2] & 0xC0) == 0x80) && ((src[-3] & 0xC0) == 0x80)) { + return src - 3; + } + return Tcl_UtfPrev(src, start); +} + #define TclBN_mp_add mp_add #define TclBN_mp_and mp_and #define TclBN_mp_clamp mp_clamp @@ -142,7 +175,7 @@ static void uniCodePanic(void) { #define TclBN_mp_xor mp_xor #define TclBN_mp_zero mp_zero #define TclBN_s_mp_add s_mp_add -#define TclBN_s_mp_balance_mul mp_balance_mul +#define TclBN_s_mp_balance_mul s_mp_balance_mul #define TclBN_mp_karatsuba_mul s_mp_karatsuba_mul #define TclBN_mp_karatsuba_sqr s_mp_karatsuba_sqr #define TclBN_s_mp_mul_digs s_mp_mul_digs @@ -266,6 +299,8 @@ mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *c) { # define Tcl_MacOSXOpenBundleResources 0 # define TclGuessPackageName 0 # define TclGetLoadedPackages 0 +# undef TclSetPreInitScript +# define TclSetPreInitScript 0 #else #define TclGuessPackageName guessPackageName @@ -283,7 +318,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) { @@ -602,8 +637,6 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ # define Tcl_Eval 0 # undef Tcl_GlobalEval # define Tcl_GlobalEval 0 -# undef Tcl_GetStringResult -# define Tcl_GetStringResult 0 # undef Tcl_SaveResult # define Tcl_SaveResult 0 # undef Tcl_RestoreResult @@ -1006,7 +1039,7 @@ static const TclIntStubs tclIntStubs = { TclPtrIncrObjVar, /* 254 */ TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ - TclStaticPackage, /* 257 */ + TclStaticLibrary, /* 257 */ TclpCreateTemporaryDirectory, /* 258 */ TclGetBytesFromObj, /* 259 */ TclUnusedStubEntry, /* 260 */ @@ -1122,6 +1155,8 @@ static const TclPlatStubs tclPlatStubs = { #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ Tcl_WinUtfToTChar, /* 0 */ Tcl_WinTCharToUtf, /* 1 */ + 0, /* 2 */ + Tcl_WinConvertError, /* 3 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ Tcl_MacOSXOpenBundleResources, /* 0 */ @@ -1493,7 +1528,7 @@ const TclStubs tclStubs = { Tcl_SourceRCFile, /* 241 */ Tcl_SplitList, /* 242 */ Tcl_SplitPath, /* 243 */ - Tcl_StaticPackage, /* 244 */ + Tcl_StaticLibrary, /* 244 */ Tcl_StringMatch, /* 245 */ Tcl_TellOld, /* 246 */ Tcl_TraceVar, /* 247 */ @@ -1575,12 +1610,12 @@ const TclStubs tclStubs = { Tcl_UniCharToUpper, /* 323 */ Tcl_UniCharToUtf, /* 324 */ Tcl_UtfAtIndex, /* 325 */ - Tcl_UtfCharComplete, /* 326 */ + TclUtfCharComplete, /* 326 */ Tcl_UtfBackslash, /* 327 */ Tcl_UtfFindFirst, /* 328 */ Tcl_UtfFindLast, /* 329 */ - Tcl_UtfNext, /* 330 */ - Tcl_UtfPrev, /* 331 */ + TclUtfNext, /* 330 */ + TclUtfPrev, /* 331 */ Tcl_UtfToExternal, /* 332 */ Tcl_UtfToExternalDString, /* 333 */ Tcl_UtfToLower, /* 334 */ @@ -1903,6 +1938,10 @@ const TclStubs tclStubs = { TclGetStringFromObj, /* 651 */ TclGetUnicodeFromObj, /* 652 */ TclGetByteArrayFromObj, /* 653 */ + Tcl_UtfCharComplete, /* 654 */ + Tcl_UtfNext, /* 655 */ + Tcl_UtfPrev, /* 656 */ + Tcl_UniCharIsUnicode, /* 657 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 45b5ca3..99fe92f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -19,6 +19,9 @@ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif +#ifndef TCL_NO_DEPRECATED +# define TCL_NO_DEPRECATED +#endif #include "tclInt.h" #ifdef TCL_WITH_EXTERNAL_TOMMATH # include "tommath.h" @@ -224,6 +227,7 @@ static Tcl_CmdProc TestcreatecommandCmd; static Tcl_CmdProc TestdcallCmd; static Tcl_CmdProc TestdelCmd; static Tcl_CmdProc TestdelassocdataCmd; +static Tcl_ObjCmdProc TestdebugObjCmd; static Tcl_ObjCmdProc TestdoubledigitsObjCmd; static Tcl_CmdProc TestdstringCmd; static Tcl_ObjCmdProc TestencodingObjCmd; @@ -262,6 +266,7 @@ static Tcl_ObjCmdProc TestparsevarObjCmd; static Tcl_ObjCmdProc TestparsevarnameObjCmd; static Tcl_ObjCmdProc TestpreferstableObjCmd; static Tcl_ObjCmdProc TestprintObjCmd; +static Tcl_ObjCmdProc TestpurifyObjCmd; static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, @@ -274,7 +279,7 @@ static Tcl_CmdProc Testset2Cmd; static Tcl_CmdProc TestseterrorcodeCmd; static Tcl_ObjCmdProc TestsetobjerrorcodeCmd; static Tcl_CmdProc TestsetplatformCmd; -static Tcl_CmdProc TeststaticpkgCmd; +static Tcl_CmdProc TeststaticlibraryCmd; static Tcl_CmdProc TesttranslatefilenameCmd; static Tcl_CmdProc TestupvarCmd; static Tcl_ObjCmdProc TestWrongNumArgsObjCmd; @@ -501,6 +506,8 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd, NULL, NULL); Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testdebug", TestdebugObjCmd, + NULL, NULL); Tcl_CreateCommand(interp, "testdel", TestdelCmd, NULL, NULL); Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, NULL, NULL); @@ -565,6 +572,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testpurify", TestpurifyObjCmd, + NULL, NULL); Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, @@ -601,7 +610,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, NULL, NULL); - Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, + Tcl_CreateCommand(interp, "teststaticlibrary", TeststaticlibraryCmd, NULL, NULL); Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); @@ -3361,6 +3370,40 @@ TestlocaleCmd( /* *---------------------------------------------------------------------- * + * TestdebugObjCmd -- + * + * Implements the "testdebug" command, to detect whether Tcl was built with + * --enabble-symbols. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestdebugObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + TCL_UNUSED(int) /*objc*/, + TCL_UNUSED(Tcl_Obj *const *) /*objv*/) +{ + +#if defined(NDEBUG) && NDEBUG == 1 + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); +#else + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); +#endif + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * CleanupTestSetassocdataTests -- * * This function is called when an interpreter is deleted to clean @@ -3762,6 +3805,40 @@ TestprintObjCmd( /* *---------------------------------------------------------------------- * + * TestpurifyObjCmd -- + * + * Implements the "testpurify" command, to detect whether Tcl was built with + * -DPURIFY. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestpurifyObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + TCL_UNUSED(int) /*objc*/, + TCL_UNUSED(Tcl_Obj *const *) /*objv*/) +{ + +#ifdef PURIFY + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); +#else + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); +#endif + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestregexpObjCmd -- * * This procedure implements the "testregexp" command. It is used to give @@ -4214,10 +4291,10 @@ TestsetplatformCmd( /* *---------------------------------------------------------------------- * - * TeststaticpkgCmd -- + * TeststaticlibraryCmd -- * - * This procedure implements the "teststaticpkg" command. - * It is used to test the procedure Tcl_StaticPackage. + * This procedure implements the "teststaticlibrary" command. + * It is used to test the procedure Tcl_StaticLibrary. * * Results: * A standard Tcl result. @@ -4230,7 +4307,7 @@ TestsetplatformCmd( */ static int -TeststaticpkgCmd( +TeststaticlibraryCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ @@ -4240,7 +4317,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) { @@ -4249,7 +4326,7 @@ TeststaticpkgCmd( if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { return TCL_ERROR; } - Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], + Tcl_StaticLibrary((loaded) ? interp : NULL, argv[1], StaticInitProc, (safe) ? StaticInitProc : NULL); return TCL_OK; } @@ -6962,7 +7039,7 @@ TestUtfPrevCmd( } else { offset = numBytes; } - result = TclUtfPrev(bytes + offset, bytes); + result = Tcl_UtfPrev(bytes + offset, bytes); Tcl_SetObjResult(interp, Tcl_NewIntObj(result - bytes)); return TCL_OK; } diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 17546a4..f766030 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -54,14 +54,13 @@ static Tcl_ObjCmdProc TeststringobjCmd; #define VARPTR_KEY "TCLOBJTEST_VARPTR" #define NUMBER_OF_OBJECT_VARS 20 -static void VarPtrDeleteProc(void *clientData, Tcl_Interp *interp) +static void VarPtrDeleteProc(void *clientData, TCL_UNUSED(Tcl_Interp *)) { int i; Tcl_Obj **varPtr = (Tcl_Obj **) clientData; for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]); } - Tcl_DeleteAssocData(interp, VARPTR_KEY); ckfree(varPtr); } diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index ad508b9..727f061 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -82,18 +82,17 @@ typedef union Block { * and statistics information. */ -typedef struct Bucket { +typedef struct { Block *firstPtr; /* First block available */ Block *lastPtr; /* End of block list */ - long numFree; /* Number of blocks available */ + size_t numFree; /* Number of blocks available */ /* All fields below for accounting only */ - long numRemoves; /* Number of removes from bucket */ - long numInserts; /* Number of inserts into bucket */ - long numWaits; /* Number of waits to acquire a lock */ - long numLocks; /* Number of locks acquired */ - long totalAssigned; /* Total space assigned to bucket */ + size_t numRemoves; /* Number of removes from bucket */ + size_t numInserts; /* Number of inserts into bucket */ + size_t numLocks; /* Number of locks acquired */ + size_t totalAssigned; /* Total space assigned to bucket */ } Bucket; /* @@ -107,9 +106,9 @@ typedef struct Cache { struct Cache *nextPtr; /* Linked list of cache entries */ Tcl_ThreadId owner; /* Which thread's cache is this? */ Tcl_Obj *firstObjPtr; /* List of free objects for thread */ - int numObjects; /* Number of objects for thread */ + size_t numObjects; /* Number of objects for thread */ Tcl_Obj *lastPtr; /* Last object in this cache */ - int totalAssigned; /* Total space assigned to thread */ + size_t totalAssigned; /* Total space assigned to thread */ Bucket buckets[NBUCKETS]; /* The buckets for this thread */ } Cache; @@ -120,8 +119,8 @@ typedef struct Cache { static struct { size_t blockSize; /* Bucket blocksize. */ - int maxBlocks; /* Max blocks before move to share. */ - int numMove; /* Num blocks to move to share. */ + size_t maxBlocks; /* Max blocks before move to share. */ + size_t numMove; /* Num blocks to move to share. */ Tcl_Mutex *lockPtr; /* Share bucket lock. */ } bucketInfo[NBUCKETS]; @@ -132,12 +131,12 @@ static struct { static Cache * GetCache(void); static void LockBucket(Cache *cachePtr, int bucket); static void UnlockBucket(Cache *cachePtr, int bucket); -static void PutBlocks(Cache *cachePtr, int bucket, int numMove); +static void PutBlocks(Cache *cachePtr, int bucket, size_t numMove); static int GetBlocks(Cache *cachePtr, int bucket); static Block * Ptr2Block(void *ptr); -static void * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize); -static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove); -static void PutObjs(Cache *fromPtr, int numMove); +static void * Block2Ptr(Block *blockPtr, int bucket, size_t reqSize); +static void MoveObjs(Cache *fromPtr, Cache *toPtr, size_t numMove); +static void PutObjs(Cache *fromPtr, size_t numMove); /* * Local variables defined in this file and initialized at startup. @@ -548,7 +547,7 @@ TclThreadAllocObj(void) */ if (cachePtr->numObjects == 0) { - int numMove; + size_t numMove; Tcl_MutexLock(objLockPtr); numMove = sharedPtr->numObjects; @@ -565,11 +564,11 @@ TclThreadAllocObj(void) cachePtr->numObjects = numMove = NOBJALLOC; newObjsPtr = (Tcl_Obj *)TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0); if (newObjsPtr == NULL) { - Tcl_Panic("alloc: could not allocate %d new objects", numMove); + Tcl_Panic("alloc: could not allocate %" TCL_Z_MODIFIER "u new objects", numMove); } cachePtr->lastPtr = newObjsPtr + numMove - 1; objPtr = cachePtr->firstObjPtr; /* NULL */ - while (--numMove >= 0) { + while (numMove-- > 0) { newObjsPtr[numMove].internalRep.twoPtrValue.ptr1 = objPtr; objPtr = newObjsPtr + numMove; } @@ -671,14 +670,14 @@ Tcl_GetMemoryInfo( Tcl_DStringAppendElement(dsPtr, buf); } for (n = 0; n < NBUCKETS; ++n) { - sprintf(buf, "%lu %ld %ld %ld %ld %ld %ld", - (unsigned long) bucketInfo[n].blockSize, + sprintf(buf, "%" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" + TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u", + bucketInfo[n].blockSize, cachePtr->buckets[n].numFree, cachePtr->buckets[n].numRemoves, cachePtr->buckets[n].numInserts, cachePtr->buckets[n].totalAssigned, - cachePtr->buckets[n].numLocks, - cachePtr->buckets[n].numWaits); + cachePtr->buckets[n].numLocks); Tcl_DStringAppendElement(dsPtr, buf); } Tcl_DStringEndSublist(dsPtr); @@ -707,7 +706,7 @@ static void MoveObjs( Cache *fromPtr, Cache *toPtr, - int numMove) + size_t numMove) { Tcl_Obj *objPtr = fromPtr->firstObjPtr; Tcl_Obj *fromFirstObjPtr = objPtr; @@ -720,7 +719,7 @@ MoveObjs( * to be moved) as the first object in the 'from' cache. */ - while (--numMove) { + while (numMove-- > 1) { objPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1; } fromPtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1; @@ -754,9 +753,9 @@ MoveObjs( static void PutObjs( Cache *fromPtr, - int numMove) + size_t numMove) { - int keep = fromPtr->numObjects - numMove; + size_t keep = fromPtr->numObjects - numMove; Tcl_Obj *firstPtr, *lastPtr = NULL; fromPtr->numObjects = keep; @@ -767,7 +766,7 @@ PutObjs( do { lastPtr = firstPtr; firstPtr = (Tcl_Obj *)firstPtr->internalRep.twoPtrValue.ptr1; - } while (--keep > 0); + } while (keep-- > 1); lastPtr->internalRep.twoPtrValue.ptr1 = NULL; } @@ -808,7 +807,7 @@ static void * Block2Ptr( Block *blockPtr, int bucket, - unsigned int reqSize) + size_t reqSize) { void *ptr; @@ -898,14 +897,14 @@ static void PutBlocks( Cache *cachePtr, int bucket, - int numMove) + size_t numMove) { /* * We have numFree. Want to shed numMove. So compute how many * Blocks to keep. */ - int keep = cachePtr->buckets[bucket].numFree - numMove; + size_t keep = cachePtr->buckets[bucket].numFree - numMove; Block *lastPtr = NULL, *firstPtr; cachePtr->buckets[bucket].numFree = keep; @@ -916,7 +915,7 @@ PutBlocks( do { lastPtr = firstPtr; firstPtr = firstPtr->nextBlock; - } while (--keep > 0); + } while (keep-- > 1); lastPtr->nextBlock = NULL; } @@ -961,7 +960,7 @@ GetBlocks( int bucket) { Block *blockPtr; - int n; + size_t n; /* * First, atttempt to move blocks from the shared cache. Note the @@ -994,7 +993,7 @@ GetBlocks( cachePtr->buckets[bucket].firstPtr = blockPtr; sharedPtr->buckets[bucket].numFree -= n; cachePtr->buckets[bucket].numFree = n; - while (--n > 0) { + while (n-- > 1) { blockPtr = blockPtr->nextBlock; } sharedPtr->buckets[bucket].firstPtr = blockPtr->nextBlock; @@ -1016,7 +1015,7 @@ GetBlocks( blockPtr = NULL; n = NBUCKETS; size = 0; - while (--n > bucket) { + while (n-- > (size_t)bucket + 1) { if (cachePtr->buckets[n].numFree > 0) { size = bucketInfo[n].blockSize; blockPtr = cachePtr->buckets[n].firstPtr; @@ -1045,7 +1044,7 @@ GetBlocks( n = size / bucketInfo[bucket].blockSize; cachePtr->buckets[bucket].numFree = n; cachePtr->buckets[bucket].firstPtr = blockPtr; - while (--n > 0) { + while (n-- > 1) { blockPtr->nextBlock = (Block *) ((char *) blockPtr + bucketInfo[bucket].blockSize); blockPtr = blockPtr->nextBlock; @@ -1082,9 +1081,9 @@ TclInitThreadAlloc(void) objLockPtr = TclpNewAllocMutex(); for (i = 0; i < NBUCKETS; ++i) { bucketInfo[i].blockSize = MINALLOC << i; - bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); + bucketInfo[i].maxBlocks = ((size_t)1) << (NBUCKETS - 1 - i); bucketInfo[i].numMove = i < NBUCKETS - 1 ? - 1 << (NBUCKETS - 2 - i) : 1; + (size_t)1 << (NBUCKETS - 2 - i) : 1; bucketInfo[i].lockPtr = TclpNewAllocMutex(); } TclpInitAllocCache(); diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c index ba789d3..4d2aca5 100644 --- a/generic/tclThreadJoin.c +++ b/generic/tclThreadJoin.c @@ -305,6 +305,8 @@ TclSignalExitThread( Tcl_MutexUnlock(&threadPtr->threadMutex); } +#else +TCL_MAC_EMPTY_FILE(generic_tclThreadJoin_c) #endif /* _WIN32 */ /* diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 847717a..3a3b9a8 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -17,7 +17,6 @@ library tcl # Define the unsupported generic interfaces. interface tclTomMath -# hooks {tclTomMathInt} scspec EXTERN # Declare each of the functions in the Tcl tommath interface diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 62605fc..1b2c05f 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -73,6 +73,11 @@ MODULE_SCOPE mp_err TclBN_s_mp_mul_d(const mp_int *a, mp_digit b, mp_int *c); MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len); MODULE_SCOPE void TclBN_s_mp_set(mp_int *a, mp_digit b); MODULE_SCOPE mp_err TclBN_s_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c); +MODULE_SCOPE mp_err TclBN_s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c); +MODULE_SCOPE const char *const TclBN_mp_s_rmap; +MODULE_SCOPE const uint8_t TclBN_mp_s_rmap_reverse[]; +MODULE_SCOPE const size_t TclBN_mp_s_rmap_reverse_sz; +MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #ifdef __cplusplus } #endif @@ -149,7 +154,7 @@ MODULE_SCOPE mp_err TclBN_s_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c); #define mp_xor TclBN_mp_xor #define mp_zero TclBN_mp_zero #define s_mp_add TclBN_s_mp_add -#define s_mp_balance_mul TclBN_mp_balance_mul +#define s_mp_balance_mul TclBN_s_mp_balance_mul #define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul #define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr #define s_mp_mul_digs TclBN_s_mp_mul_digs diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 2fd602b..dc30794 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -495,7 +495,7 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 15488, 1344, 1344, 1344, 1344, 1344, 1344, 11328, 1344, 1344, + 1344, 4608, 1344, 1344, 1344, 1344, 1344, 1344, 11328, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -815,7 +815,7 @@ static const unsigned char groupMap[] = { 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 93, 93, 93, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 93, 93, 125, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 93, 93, 0, 0, 0, 0, 0, 0, 0, @@ -1415,24 +1415,24 @@ static const unsigned char groupMap[] = { 0, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, - 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 93, 93, - 93, 93, 93, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 93, - 3, 3, 3, 3, 3, 14, 14, 14, 14, 92, 92, 92, 92, 3, 14, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 18, 18, 18, 18, 18, - 18, 18, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 3, 3, 3, 3, - 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, - 0, 93, 15, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, + 15, 15, 15, 15, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 0, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 93, 93, 93, + 93, 93, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 93, 3, + 3, 3, 3, 3, 14, 14, 14, 14, 92, 92, 92, 92, 3, 14, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 18, 18, 18, 18, 18, 18, + 18, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 3, 3, 3, 3, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, + 93, 15, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, @@ -1453,9 +1453,9 @@ static const unsigned char groupMap[] = { 0, 0, 14, 93, 93, 3, 17, 17, 17, 17, 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, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 17, 17, 17, 17, 17, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 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, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 125, @@ -1535,7 +1535,7 @@ static const unsigned char groupMap[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 15, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 0, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 0, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 5db7343..fcdf80a 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -64,20 +64,12 @@ static const unsigned char totalBytes[256] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, -/* Tcl_UtfCharComplete() might point to 2nd byte of valid 4-byte sequence */ - 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, - 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, -/* End of "continuation byte section" */ + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, - 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, -#if TCL_UTF_MAX > 3 - 4,4,4,4,4, -#else - 1,1,1,1,1, -#endif - 1,1,1,1,1,1,1,1,1,1,1 + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1 }; - + static const unsigned char complete[256] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, @@ -88,15 +80,9 @@ static const unsigned char complete[256] = { 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, /* End of "continuation byte section" */ 2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, - 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, -#if TCL_UTF_MAX > 3 - 4,4,4,4,4, -#else - 3,3,3,3,3, -#endif - 1,1,1,1,1,1,1,1,1,1,1 + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1 }; - + /* * Functions used only in this module. */ @@ -694,7 +680,7 @@ Tcl_UtfToUniCharDString( p += TclUtfToUCS4(p, &ch); *w++ = ch; } - while ((p < endPtr) && TclUCS4Complete(p, endPtr-p)) { + while ((p < endPtr) && Tcl_UtfCharComplete(p, endPtr-p)) { p += TclUtfToUCS4(p, &ch); *w++ = ch; } @@ -752,7 +738,7 @@ Tcl_UtfToChar16DString( *w++ = ch; } while (p < endPtr) { - if (TclChar16Complete(p, endPtr-p)) { + if (Tcl_UtfCharComplete(p, endPtr-p)) { p += Tcl_UtfToChar16(p, &ch); *w++ = ch; } else { @@ -833,7 +819,7 @@ Tcl_NumUtfChars( /* Pointer to the end of string. Never read endPtr[0] */ const char *endPtr = src + length; /* Pointer to last byte where optimization still can be used */ - const char *optPtr = endPtr - TCL_UTF_MAX; + const char *optPtr = endPtr - 4; /* * Optimize away the call in this loop. Justified because... @@ -970,6 +956,10 @@ Tcl_UtfNext( const char *next; if (((*src) & 0xC0) == 0x80) { + /* Continuation byte, so we start 'inside' a (possible valid) UTF-8 + * sequence. Since we are not allowed to access src[-1], we cannot + * check if the sequence is actually valid, the best we can do is + * just assume it is valid and locate the end. */ if ((((*++src) & 0xC0) == 0x80) && (((*++src) & 0xC0) == 0x80)) { ++src; } @@ -1064,7 +1054,7 @@ Tcl_UtfPrev( * it (the fallback) is correct. */ - || (trailBytesSeen >= complete[byte])) { + || (trailBytesSeen >= totalBytes[byte])) { /* * That is, (1 + trailBytesSeen > needed). * We've examined more bytes than needed to complete @@ -1105,19 +1095,14 @@ Tcl_UtfPrev( /* Continue the search backwards... */ look--; - } while (trailBytesSeen < TCL_UTF_MAX); + } while (trailBytesSeen < 4); /* - * We've seen TCL_UTF_MAX trail bytes, so we know there will not be a + * We've seen 4 trail bytes, so we know there will not be a * properly formed byte sequence to find, and we can stop looking, - * accepting the fallback (for TCL_UTF_MAX > 3) or just go back as - * far as we can. + * accepting the fallback. */ -#if TCL_UTF_MAX > 3 return fallback; -#else - return src - TCL_UTF_MAX; -#endif } /* @@ -1744,7 +1729,7 @@ Tcl_UniCharToLower( /* Clear away extension bits, if any */ return ch & 0x1FFFFF; } - + /* *---------------------------------------------------------------------- * @@ -1838,7 +1823,7 @@ Tcl_UniCharNcmp( const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ { -#ifdef WORDS_BIGENDIAN +#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3) /* * We are definitely on a big-endian machine; memcmp() is safe */ @@ -1852,6 +1837,14 @@ Tcl_UniCharNcmp( for ( ; numChars != 0; ucs++, uct++, numChars--) { if (*ucs != *uct) { +#if TCL_UTF_MAX < 4 + /* special case for handling upper surrogates */ + if (((*ucs & 0xFC00) == 0xD800) && ((*uct & 0xFC00) != 0xD800)) { + return 1; + } else if (((*uct & 0xFC00) == 0xD800)) { + return -1; + } +#endif return (*ucs - *uct); } } @@ -1889,6 +1882,14 @@ Tcl_UniCharNcasecmp( Tcl_UniChar lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { +#if TCL_UTF_MAX < 4 + /* special case for handling upper surrogates */ + if (((lcs & 0xFC00) == 0xD800) && ((lct & 0xFC00) != 0xD800)) { + return 1; + } else if (((lct & 0xFC00) == 0xD800)) { + return -1; + } +#endif return (lcs - lct); } } @@ -2181,6 +2182,36 @@ Tcl_UniCharIsUpper( /* *---------------------------------------------------------------------- * + * Tcl_UniCharIsUnicode -- + * + * Test if a character is a Unicode character. + * + * Results: + * Returns non-zero if character belongs to the Unicode set. + * + * Excluded are: + * 1) All characters > U+10FFFF + * 2) Surrogates U+D800 - U+DFFF + * 3) Last 2 characters of each plane, so U+??FFFE and U+??FFFF + * 4) The characters in the range U+FDD0 - U+FDEF + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UniCharIsUnicode( + int ch) /* Unicode character to test. */ +{ + return ((unsigned int)ch <= 0x10FFFF) && ((ch & 0xFFF800) != 0xD800) + && ((ch & 0xFFFE) != 0xFFFE) && ((unsigned int)(ch - 0xFDD0) >= 32); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_UniCharIsWordChar -- * * Test if a character is alphanumeric or a connector punctuation mark. diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 1288738..bbacbe2 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1707,7 +1707,7 @@ TclTrimRight( const char *q = trim; int pInc = 0, bytesLeft = numTrim; - pp = TclUtfPrev(p, bytes); + pp = Tcl_UtfPrev(p, bytes); do { pp += pInc; pInc = TclUtfToUCS4(pp, &ch1); @@ -1718,14 +1718,14 @@ TclTrimRight( */ do { - int qInc = TclUtfToUCS4(q, &ch2); + pInc = TclUtfToUCS4(q, &ch2); if (ch1 == ch2) { break; } - q += qInc; - bytesLeft -= qInc; + q += pInc; + bytesLeft -= pInc; } while (bytesLeft); if (bytesLeft == 0) { @@ -1771,7 +1771,7 @@ TclTrimLeft( * rely on (trim[numTrim] == '\0'). */ { const char *p = bytes; - int ch1, ch2; + int ch1, ch2; /* Empty strings -> nothing to do */ if ((numBytes == 0) || (numTrim == 0)) { @@ -2030,7 +2030,14 @@ Tcl_ConcatObj( continue; } if (resPtr) { - if (TCL_OK != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) { + Tcl_Obj *elemPtr = NULL; + + Tcl_ListObjIndex(NULL, objPtr, 0, &elemPtr); + if (elemPtr == NULL) { + continue; + } + if (Tcl_GetString(elemPtr)[0] == '#' || TCL_OK + != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) { /* Abandon ship! */ Tcl_DecrRefCount(resPtr); goto slow; diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 50653ff..35b6712 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -2,7 +2,7 @@ * tclZipfs.c -- * * Implementation of the ZIP filesystem used in TIP 430 - * Adapted from the implentation for AndroWish. + * Adapted from the implementation for AndroWish. * * Copyright © 2016-2017 Sean Woods <yoda@etoyoc.com> * Copyright © 2013-2015 Christian Werner <chw@ch-werner.de> @@ -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 @@ -129,6 +130,14 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \ } \ } while (0) +#define ZIPFS_MEM_ERROR(interp) \ + do { \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_NewStringObj( \ + "out of memory", -1)); \ + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); \ + } \ + } while (0) #define ZIPFS_POSIX_ERROR(interp,errstr) \ do { \ if (interp) { \ @@ -136,27 +145,11 @@ "%s: %s", errstr, Tcl_PosixError(interp))); \ } \ } while (0) - -/* - * Macros to read and write 16 and 32 bit integers from/to ZIP archives. - */ - -#define ZipReadInt(p) \ - ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24)) -#define ZipReadShort(p) \ - ((p)[0] | ((p)[1] << 8)) - -#define ZipWriteInt(p, v) \ - do { \ - (p)[0] = (v) & 0xff; \ - (p)[1] = ((v) >> 8) & 0xff; \ - (p)[2] = ((v) >> 16) & 0xff; \ - (p)[3] = ((v) >> 24) & 0xff; \ - } while (0) -#define ZipWriteShort(p, v) \ - do { \ - (p)[0] = (v) & 0xff; \ - (p)[1] = ((v) >> 8) & 0xff; \ +#define ZIPFS_ERROR_CODE(interp,errcode) \ + do { \ + if (interp) { \ + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", errcode, NULL); \ + } \ } while (0) /* @@ -177,6 +170,12 @@ TCL_DECLARE_MUTEX(localtimeMutex) #endif /* !_WIN32 && !HAVE_LOCALTIME_R && TCL_THREADS */ /* + * Forward declaration. + */ + +struct ZipEntry; + +/* * In-core description of mounted ZIP archive file. */ @@ -205,6 +204,7 @@ typedef struct ZipFile { /* * In-core description of file contained in mounted ZIP archive. + * ZIP_ATTR_ */ typedef struct ZipEntry { @@ -249,7 +249,7 @@ typedef struct ZipChannel { * Most are kept in single ZipFS struct. When build with threading support * this struct is protected by the ZipFSMutex (see below). * - * The "fileHash" component is the process wide global table of all known ZIP + * The "fileHash" component is the process-wide global table of all known ZIP * archive members in all mounted ZIP archives. * * The "zipHash" components is the process wide global table of all mounted @@ -260,12 +260,22 @@ static struct { int initialized; /* True when initialized */ int lock; /* RW lock, see below */ int waiters; /* RW lock, see below */ - int wrmax; /* Maximum write size of a file */ + 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} }; @@ -282,9 +292,30 @@ static const char *zipfs_literal_tcl_library = NULL; /* Function prototypes */ +static int CopyImageFile(Tcl_Interp *interp, const char *imgName, + Tcl_Channel out); static inline int DescribeMounted(Tcl_Interp *interp, const char *mountPoint); +static int InitReadableChannel(Tcl_Interp *interp, + ZipChannel *info, ZipEntry *z); +static int InitWritableChannel(Tcl_Interp *interp, + ZipChannel *info, ZipEntry *z, int trunc); static inline int ListMountPoints(Tcl_Interp *interp); +static void SerializeCentralDirectoryEntry( + const unsigned char *start, + const unsigned char *end, unsigned char *buf, + ZipEntry *z, size_t nameLength, + long long dataStartOffset); +static void SerializeCentralDirectorySuffix( + const unsigned char *start, + const unsigned char *end, unsigned char *buf, + int entryCount, long long dataStartOffset, + long long directoryStartOffset, + long long suffixStartOffset); +static void SerializeLocalEntryHeader( + const unsigned char *start, + const unsigned char *end, unsigned char *buf, + ZipEntry *z, int nameLength, int align); #if !defined(STATIC_BUILD) static int ZipfsAppHookFindTclInit(const char *archive); #endif @@ -299,6 +330,9 @@ static Tcl_Channel ZipFSOpenFileChannelProc(Tcl_Interp *interp, static int ZipFSMatchInDirectoryProc(Tcl_Interp *interp, Tcl_Obj *result, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); +static void ZipFSMatchMountPoints(Tcl_Obj *result, + Tcl_Obj *normPathPtr, const char *pattern, + Tcl_DString *prefix); static Tcl_Obj * ZipFSListVolumesProc(void); static const char *const *ZipFSFileAttrStringsProc(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); @@ -309,19 +343,23 @@ static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index, static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); +static int ZipMapArchive(Tcl_Interp *interp, ZipFile *zf, + void *handle); static void ZipfsExitHandler(ClientData clientData); +static void ZipfsMountExitHandler(ClientData clientData); static void ZipfsSetup(void); +static void ZipfsFinalize(void); static int ZipChannelClose(void *instanceData, Tcl_Interp *interp, int flags); static Tcl_DriverGetHandleProc ZipChannelGetFile; static int ZipChannelRead(void *instanceData, char *buf, int toRead, int *errloc); -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) static int ZipChannelSeek(void *instanceData, long offset, int mode, int *errloc); #endif -static long long ZipChannelWideSeek(void *instanceData, long long offset, - int mode, int *errloc); +static long long ZipChannelWideSeek(void *instanceData, + long long offset, int mode, int *errloc); static void ZipChannelWatchChannel(void *instanceData, int mask); static int ZipChannelWrite(void *instanceData, @@ -360,7 +398,7 @@ static const Tcl_Filesystem zipfsFilesystem = { NULL, /* renameFileProc */ NULL, /* copyDirectoryProc */ NULL, /* lstatProc */ - (Tcl_FSLoadFileProc *)(void *)ZipFSLoadFile, + (Tcl_FSLoadFileProc *) (void *) ZipFSLoadFile, NULL, /* getCwdProc */ NULL, /* chdirProc */ }; @@ -370,27 +408,28 @@ static const Tcl_Filesystem zipfsFilesystem = { */ static Tcl_ChannelType ZipChannelType = { - "zip", /* Type name. */ + "zip", /* Type name. */ TCL_CHANNEL_VERSION_5, - TCL_CLOSE2PROC, /* Close channel, clean instance data */ - ZipChannelRead, /* Handle read request */ - ZipChannelWrite, /* Handle write request */ -#ifndef TCL_NO_DEPRECATED - ZipChannelSeek, /* Move location of access point, NULL'able */ + TCL_CLOSE2PROC, /* Close channel, clean instance data */ + ZipChannelRead, /* Handle read request */ + ZipChannelWrite, /* Handle write request */ +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) + ZipChannelSeek, /* Move location of access point, NULL'able */ #else - NULL, /* Move location of access point, NULL'able */ + NULL, /* Move location of access point, NULL'able */ #endif - NULL, /* Set options, NULL'able */ - NULL, /* Get options, NULL'able */ - ZipChannelWatchChannel, /* Initialize notifier */ - ZipChannelGetFile, /* Get OS handle from the channel */ - ZipChannelClose, /* 2nd version of close channel, NULL'able */ - NULL, /* Set blocking mode for raw channel, NULL'able */ - NULL, /* Function to flush channel, NULL'able */ - NULL, /* Function to handle event, NULL'able */ - ZipChannelWideSeek, /* Wide seek function, NULL'able */ - NULL, /* Thread action function, NULL'able */ - NULL, /* Truncate function, NULL'able */ + NULL, /* Set options, NULL'able */ + NULL, /* Get options, NULL'able */ + ZipChannelWatchChannel, /* Initialize notifier */ + ZipChannelGetFile, /* Get OS handle from the channel */ + ZipChannelClose, /* 2nd version of close channel, NULL'able */ + NULL, /* Set blocking mode for raw channel, + * NULL'able */ + NULL, /* Function to flush channel, NULL'able */ + NULL, /* Function to handle event, NULL'able */ + ZipChannelWideSeek, /* Wide seek function, NULL'able */ + NULL, /* Thread action function, NULL'able */ + NULL, /* Truncate function, NULL'able */ }; /* @@ -402,6 +441,79 @@ static Tcl_ChannelType ZipChannelType = { /* *------------------------------------------------------------------------- * + * ZipReadInt, ZipReadShort, ZipWriteInt, ZipWriteShort -- + * + * Inline functions to read and write little-endian 16 and 32 bit + * integers from/to buffers representing parts of ZIP archives. + * + * These take bufferStart and bufferEnd pointers, which are used to + * maintain a guarantee that out-of-bounds accesses don't happen when + * reading or writing critical directory structures. + * + *------------------------------------------------------------------------- + */ + +static inline unsigned int +ZipReadInt( + const unsigned char *bufferStart, + const unsigned char *bufferEnd, + const unsigned char *ptr) +{ + if (ptr < bufferStart || ptr + 4 > bufferEnd) { + Tcl_Panic("out of bounds read(4): start=%p, end=%p, ptr=%p", + bufferStart, bufferEnd, ptr); + } + return ptr[0] | (ptr[1] << 8) | (ptr[2] << 16) | (ptr[3] << 24); +} + +static inline unsigned short +ZipReadShort( + const unsigned char *bufferStart, + const unsigned char *bufferEnd, + const unsigned char *ptr) +{ + if (ptr < bufferStart || ptr + 2 > bufferEnd) { + Tcl_Panic("out of bounds read(2): start=%p, end=%p, ptr=%p", + bufferStart, bufferEnd, ptr); + } + return ptr[0] | (ptr[1] << 8); +} + +static inline void +ZipWriteInt( + const unsigned char *bufferStart, + const unsigned char *bufferEnd, + unsigned char *ptr, + unsigned int value) +{ + if (ptr < bufferStart || ptr + 4 > bufferEnd) { + Tcl_Panic("out of bounds write(4): start=%p, end=%p, ptr=%p", + bufferStart, bufferEnd, ptr); + } + ptr[0] = value & 0xff; + ptr[1] = (value >> 8) & 0xff; + ptr[2] = (value >> 16) & 0xff; + ptr[3] = (value >> 24) & 0xff; +} + +static inline void +ZipWriteShort( + const unsigned char *bufferStart, + const unsigned char *bufferEnd, + unsigned char *ptr, + unsigned short value) +{ + if (ptr < bufferStart || ptr + 2 > bufferEnd) { + Tcl_Panic("out of bounds write(2): start=%p, end=%p, ptr=%p", + bufferStart, bufferEnd, ptr); + } + ptr[0] = value & 0xff; + ptr[1] = (value >> 8) & 0xff; +} + +/* + *------------------------------------------------------------------------- + * * ReadLock, WriteLock, Unlock -- * * POSIX like rwlock functions to support multiple readers and single @@ -420,7 +532,7 @@ TCL_DECLARE_MUTEX(ZipFSMutex) static Tcl_Condition ZipFSCond; -static void +static inline void ReadLock(void) { Tcl_MutexLock(&ZipFSMutex); @@ -433,7 +545,7 @@ ReadLock(void) Tcl_MutexUnlock(&ZipFSMutex); } -static void +static inline void WriteLock(void) { Tcl_MutexLock(&ZipFSMutex); @@ -446,7 +558,7 @@ WriteLock(void) Tcl_MutexUnlock(&ZipFSMutex); } -static void +static inline void Unlock(void) { Tcl_MutexLock(&ZipFSMutex); @@ -566,7 +678,7 @@ ToDosDate( *------------------------------------------------------------------------- */ -static int +static inline int CountSlashes( const char *string) { @@ -585,6 +697,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 @@ -770,16 +991,16 @@ CanonicalPath( *------------------------------------------------------------------------- */ -static ZipEntry * +static inline ZipEntry * ZipFSLookup( - char *filename) + const char *filename) { Tcl_HashEntry *hPtr; ZipEntry *z = NULL; hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename); if (hPtr) { - z = (ZipEntry *)Tcl_GetHashValue(hPtr); + z = (ZipEntry *) Tcl_GetHashValue(hPtr); } return z; } @@ -787,13 +1008,13 @@ ZipFSLookup( /* *------------------------------------------------------------------------- * - * ZipFSLookupMount -- + * ZipFSLookupZip -- * - * This function returns an indication if the given file name corresponds - * to a mounted ZIP archive file. + * This function gets the structure for a mounted ZIP archive. * * Results: - * Returns true, if the given file name is a mounted ZIP archive file. + * Returns a pointer to the structure, or NULL if the file is ZIP file is + * unknown/not mounted. * * Side effects: * None. @@ -801,25 +1022,76 @@ ZipFSLookup( *------------------------------------------------------------------------- */ -#ifdef NEVER_USED -static int -ZipFSLookupMount( - char *filename) +static inline ZipFile * +ZipFSLookupZip( + const char *mountPoint) { Tcl_HashEntry *hPtr; - Tcl_HashSearch search; + ZipFile *zf = NULL; - for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - ZipFile *zf = Tcl_GetHashValue(hPtr); + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); + if (hPtr) { + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + } + return zf; +} + +/* + *------------------------------------------------------------------------- + * + * AllocateZipFile, AllocateZipEntry, AllocateZipChannel -- + * + * Allocates the memory for a datastructure. Always ensures that it is + * zeroed out for safety. + * + * Returns: + * The allocated structure, or NULL if allocate fails. + * + * Side effects: + * The interpreter result may be written to on error. Which might fail + * (for ZipFile) in a low-memory situation. Always panics if ZipEntry + * allocation fails. + * + *------------------------------------------------------------------------- + */ - if (strcmp(zf->mountPoint, filename) == 0) { - return 1; - } +static inline ZipFile * +AllocateZipFile( + Tcl_Interp *interp, + size_t mountPointNameLength) +{ + size_t size = sizeof(ZipFile) + mountPointNameLength + 1; + ZipFile *zf = (ZipFile *) attemptckalloc(size); + + if (!zf) { + ZIPFS_MEM_ERROR(interp); + } else { + memset(zf, 0, size); } - return 0; + return zf; +} + +static inline ZipEntry * +AllocateZipEntry(void) +{ + ZipEntry *z = (ZipEntry *) ckalloc(sizeof(ZipEntry)); + memset(z, 0, sizeof(ZipEntry)); + return z; +} + +static inline ZipChannel * +AllocateZipChannel( + Tcl_Interp *interp) +{ + ZipChannel *zc = (ZipChannel *) attemptckalloc(sizeof(ZipChannel)); + + if (!zc) { + ZIPFS_MEM_ERROR(interp); + } else { + memset(zc, 0, sizeof(ZipChannel)); + } + return zc; } -#endif /* NEVER_USED */ /* *------------------------------------------------------------------------- @@ -856,6 +1128,10 @@ ZipFSCloseArchive( return; } + /* + * Remove the memory mapping, if we have one. + */ + #ifdef _WIN32 if (zf->data && !zf->ptrToFree) { UnmapViewOfFile(zf->data); @@ -867,7 +1143,7 @@ ZipFSCloseArchive( #else /* !_WIN32 */ if ((zf->data != MAP_FAILED) && !zf->ptrToFree) { munmap(zf->data, zf->length); - zf->data = (unsigned char *)MAP_FAILED; + zf->data = (unsigned char *) MAP_FAILED; } #endif /* _WIN32 */ @@ -888,7 +1164,7 @@ ZipFSCloseArchive( * * This function takes a memory mapped zip file and indexes the contents. * When "needZip" is zero an embedded ZIP archive in an executable file - * is accepted. + * is accepted. Note that we do not support ZIP64. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed @@ -908,12 +1184,20 @@ ZipFSFindTOC( ZipFile *zf) { size_t i; - unsigned char *p, *q; + const unsigned char *p, *q; + const unsigned char *start = zf->data; + const unsigned char *end = zf->data + zf->length; + + /* + * Scan backwards from the end of the file for the signature. This is + * necessary because ZIP archives aren't the only things that get tagged + * on the end of executables; digital signatures can also go there. + */ p = zf->data + zf->length - ZIP_CENTRAL_END_LEN; - while (p >= zf->data) { + while (p >= start) { if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) { - if (ZipReadInt(p) == ZIP_CENTRAL_END_SIG) { + if (ZipReadInt(start, end, p) == ZIP_CENTRAL_END_SIG) { break; } p -= ZIP_SIG_LEN; @@ -922,73 +1206,93 @@ ZipFSFindTOC( } } if (p < zf->data) { + /* + * Didn't find it (or not enough space for a central directory!); not + * a ZIP archive. This might be OK or a problem. + */ + if (!needZip) { zf->baseOffset = zf->passOffset = zf->length; return TCL_OK; } ZIPFS_ERROR(interp, "wrong end signature"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "END_SIG", NULL); - } + ZIPFS_ERROR_CODE(interp, "END_SIG"); goto error; } - zf->numFiles = ZipReadShort(p + ZIP_CENTRAL_ENTS_OFFS); + + /* + * How many files in the archive? If that's bogus, we're done here. + */ + + zf->numFiles = ZipReadShort(start, end, p + ZIP_CENTRAL_ENTS_OFFS); if (zf->numFiles == 0) { if (!needZip) { zf->baseOffset = zf->passOffset = zf->length; return TCL_OK; } ZIPFS_ERROR(interp, "empty archive"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); - } + ZIPFS_ERROR_CODE(interp, "EMPTY"); goto error; } - q = zf->data + ZipReadInt(p + ZIP_CENTRAL_DIRSTART_OFFS); - p -= ZipReadInt(p + ZIP_CENTRAL_DIRSIZE_OFFS); - if ((p < zf->data) || (p > zf->data + zf->length) + + /* + * Where does the central directory start? + */ + + q = zf->data + ZipReadInt(start, end, p + ZIP_CENTRAL_DIRSTART_OFFS); + p -= ZipReadInt(start, end, p + ZIP_CENTRAL_DIRSIZE_OFFS); + if ((p < q) || (p < zf->data) || (p > zf->data + zf->length) || (q < zf->data) || (q > zf->data + zf->length)) { if (!needZip) { zf->baseOffset = zf->passOffset = zf->length; return TCL_OK; } ZIPFS_ERROR(interp, "archive directory not found"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_DIR", NULL); - } + ZIPFS_ERROR_CODE(interp, "NO_DIR"); goto error; } + + /* + * Read the central directory. + */ + zf->baseOffset = zf->passOffset = p - q; zf->directoryOffset = p - zf->data; q = p; for (i = 0; i < zf->numFiles; i++) { int pathlen, comlen, extra; - if (q + ZIP_CENTRAL_HEADER_LEN > zf->data + zf->length) { + if (q + ZIP_CENTRAL_HEADER_LEN > end) { ZIPFS_ERROR(interp, "wrong header length"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_LEN", NULL); - } + ZIPFS_ERROR_CODE(interp, "HDR_LEN"); goto error; } - if (ZipReadInt(q) != ZIP_CENTRAL_HEADER_SIG) { + if (ZipReadInt(start, end, q) != ZIP_CENTRAL_HEADER_SIG) { ZIPFS_ERROR(interp, "wrong header signature"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_SIG", NULL); - } + ZIPFS_ERROR_CODE(interp, "HDR_SIG"); goto error; } - pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); - comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS); + 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); q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; } + + /* + * If there's also an encoded password, extract that too (but don't decode + * yet). + */ + q = zf->data + zf->baseOffset; - if ((zf->baseOffset >= 6) && (ZipReadInt(q - 4) == ZIP_PASSWORD_END_SIG)) { + if ((zf->baseOffset >= 6) && + (ZipReadInt(start, end, q - 4) == ZIP_PASSWORD_END_SIG)) { + const unsigned char *passPtr; + i = q[-5]; - if (q - 5 - i > zf->data) { + passPtr = q - 5 - i; + if (passPtr >= start && passPtr + i < end) { zf->passBuf[0] = i; - memcpy(zf->passBuf + 1, q - 5 - i, i); + memcpy(zf->passBuf + 1, passPtr, i); zf->passOffset -= i ? (5 + i) : 0; } } @@ -1037,18 +1341,42 @@ ZipFSOpenArchive( zf->data = NULL; zf->mountHandle = INVALID_HANDLE_VALUE; #else /* !_WIN32 */ - zf->data = (unsigned char *)MAP_FAILED; + zf->data = (unsigned char *) MAP_FAILED; #endif /* _WIN32 */ zf->length = 0; zf->numFiles = 0; zf->baseOffset = zf->passOffset = 0; zf->ptrToFree = NULL; zf->passBuf[0] = 0; + + /* + * Actually open the file. + */ + zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0); if (!zf->chan) { return TCL_ERROR; } - if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) { + + /* + * See if we can get the OS handle. If we can, we can use that to memory + * map the file, which is nice and efficient. However, it totally depends + * on the filename pointing to a real regular OS file. + * + * Opening real filesystem entities that are not files will lead to an + * error. + */ + + if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) == TCL_OK) { + if (ZipMapArchive(interp, zf, handle) != TCL_OK) { + goto error; + } + } else { + /* + * Not an OS file, but rather something in a Tcl VFS. Must copy into + * memory. + */ + zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); if (zf->length == ERROR_LENGTH) { ZIPFS_POSIX_ERROR(interp, "seek error"); @@ -1057,21 +1385,16 @@ ZipFSOpenArchive( if ((zf->length - ZIP_CENTRAL_END_LEN) > (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) { ZIPFS_ERROR(interp, "illegal file size"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL); - } + ZIPFS_ERROR_CODE(interp, "FILE_SIZE"); goto error; } if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) { ZIPFS_POSIX_ERROR(interp, "seek error"); goto error; } - zf->ptrToFree = zf->data = (unsigned char *)attemptckalloc(zf->length); + zf->ptrToFree = zf->data = (unsigned char *) attemptckalloc(zf->length); if (!zf->ptrToFree) { - ZIPFS_ERROR(interp, "out of memory"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } + ZIPFS_MEM_ERROR(interp); goto error; } i = Tcl_Read(zf->chan, (char *) zf->data, zf->length); @@ -1081,67 +1404,137 @@ ZipFSOpenArchive( } Tcl_Close(interp, zf->chan); zf->chan = NULL; - } else { + } + return ZipFSFindTOC(interp, needZip, zf); + + /* + * Handle errors by closing the archive. This includes closing the channel + * handle for the archive file. + */ + + error: + ZipFSCloseArchive(interp, zf); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * ZipMapArchive -- + * + * Wrapper around the platform-specific parts of mmap() (and Windows's + * equivalent) because it's not part of the standard channel API. + * + *------------------------------------------------------------------------- + */ + +static int +ZipMapArchive( + Tcl_Interp *interp, /* Interpreter for error reporting. */ + ZipFile *zf, /* The archive descriptor structure. */ + void *handle) /* The OS handle to the open archive. */ +{ #ifdef _WIN32 - int readSuccessful; + HANDLE hFile = (HANDLE) handle; + int readSuccessful; + + /* + * Determine the file size. + */ + # ifdef _WIN64 - i = GetFileSizeEx((HANDLE) handle, (PLARGE_INTEGER) &zf->length); - readSuccessful = (i != 0); + readSuccessful = GetFileSizeEx(hFile, (PLARGE_INTEGER) &zf->length) != 0; # else /* !_WIN64 */ - zf->length = GetFileSize((HANDLE) handle, 0); - readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE); + zf->length = GetFileSize(hFile, 0); + readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE); # endif /* _WIN64 */ - if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) { - ZIPFS_POSIX_ERROR(interp, "invalid file size"); - goto error; - } - zf->mountHandle = CreateFileMappingW((HANDLE) handle, 0, PAGE_READONLY, - 0, zf->length, 0); - if (zf->mountHandle == INVALID_HANDLE_VALUE) { - ZIPFS_POSIX_ERROR(interp, "file mapping failed"); - goto error; - } - zf->data = (unsigned char *)MapViewOfFile(zf->mountHandle, FILE_MAP_READ, 0, 0, - zf->length); - if (!zf->data) { - ZIPFS_POSIX_ERROR(interp, "file mapping failed"); - goto error; - } + if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) { + ZIPFS_POSIX_ERROR(interp, "invalid file size"); + return TCL_ERROR; + } + + /* + * Map the file. + */ + + zf->mountHandle = CreateFileMappingW(hFile, 0, PAGE_READONLY, 0, + zf->length, 0); + if (zf->mountHandle == INVALID_HANDLE_VALUE) { + ZIPFS_POSIX_ERROR(interp, "file mapping failed"); + return TCL_ERROR; + } + zf->data = (unsigned char *) + MapViewOfFile(zf->mountHandle, FILE_MAP_READ, 0, 0, zf->length); + if (!zf->data) { + ZIPFS_POSIX_ERROR(interp, "file mapping failed"); + return TCL_ERROR; + } #else /* !_WIN32 */ - zf->length = lseek(PTR2INT(handle), 0, SEEK_END); - if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) { - ZIPFS_POSIX_ERROR(interp, "invalid file size"); - goto error; - } - lseek(PTR2INT(handle), 0, SEEK_SET); - zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ, - MAP_FILE | MAP_PRIVATE, PTR2INT(handle), 0); - if (zf->data == MAP_FAILED) { - ZIPFS_POSIX_ERROR(interp, "file mapping failed"); - goto error; - } -#endif /* _WIN32 */ + int fd = PTR2INT(handle); + + /* + * Determine the file size. + */ + + zf->length = lseek(fd, 0, SEEK_END); + if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) { + ZIPFS_POSIX_ERROR(interp, "invalid file size"); + return TCL_ERROR; } - return ZipFSFindTOC(interp, needZip, zf); + lseek(fd, 0, SEEK_SET); - error: - ZipFSCloseArchive(interp, zf); - return TCL_ERROR; + zf->data = (unsigned char *) + mmap(0, zf->length, PROT_READ, MAP_FILE | MAP_PRIVATE, fd, 0); + if (zf->data == MAP_FAILED) { + ZIPFS_POSIX_ERROR(interp, "file mapping failed"); + return TCL_ERROR; + } +#endif /* _WIN32 */ + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * IsPasswordValid -- + * + * Basic test for whether a passowrd is valid. If the test fails, sets an + * error message in the interpreter. + * + * Returns: + * TCL_OK if the test passes, TCL_ERROR if it fails. + * + *------------------------------------------------------------------------- + */ + +static inline int +IsPasswordValid( + Tcl_Interp *interp, + const char *passwd, + int pwlen) +{ + if ((pwlen > 255) || strchr(passwd, 0xff)) { + ZIPFS_ERROR(interp, "illegal password"); + ZIPFS_ERROR_CODE(interp, "BAD_PASS"); + return TCL_ERROR; + } + return TCL_OK; } /* *------------------------------------------------------------------------- * - * ZipFSRootNode -- + * ZipFSCatalogFilesystem -- * - * This function generates the root node for a ZIPFS filesystem. + * This function generates the root node for a ZIPFS filesystem by + * reading the ZIP's central directory. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed * into the given "interp" if it is not NULL. * * Side effects: - * ... + * Will acquire and release the write lock. * *------------------------------------------------------------------------- */ @@ -1149,7 +1542,7 @@ ZipFSOpenArchive( static int ZipFSCatalogFilesystem( Tcl_Interp *interp, /* Current interpreter. NULLable. */ - ZipFile *zf0, + ZipFile *zf, /* Temporary buffer hold archive descriptors */ const char *mountPoint, /* Mount point path. */ const char *passwd, /* Password for opening the ZIP, or NULL if * the ZIP is unprotected. */ @@ -1157,7 +1550,7 @@ ZipFSCatalogFilesystem( { int pwlen, isNew; size_t i; - ZipFile *zf; + ZipFile *zf0; ZipEntry *z; Tcl_HashEntry *hPtr; Tcl_DString ds, dsm, fpBuf; @@ -1170,16 +1563,24 @@ ZipFSCatalogFilesystem( pwlen = 0; if (passwd) { pwlen = strlen(passwd); - if ((pwlen > 255) || strchr(passwd, 0xff)) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); - } + if (IsPasswordValid(interp, passwd, pwlen) != TCL_OK) { return TCL_ERROR; } } + /* + * Validate the TOC data. If that's bad, things fall apart. + */ + + if (zf->baseOffset >= zf->length || zf->passOffset >= zf->length || + zf->directoryOffset >= zf->length) { + ZIPFS_ERROR(interp, "bad zip data"); + ZIPFS_ERROR_CODE(interp, "BAD_ZIP"); + ZipFSCloseArchive(interp, zf); + ckfree(zf); + return TCL_ERROR; + } + WriteLock(); /* @@ -1197,37 +1598,30 @@ ZipFSCatalogFilesystem( hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew); if (!isNew) { if (interp) { - zf = (ZipFile *)Tcl_GetHashValue(hPtr); + zf0 = (ZipFile *) Tcl_GetHashValue(hPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s is already mounted on %s", zf->name, mountPoint)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "MOUNTED", NULL); - } - Unlock(); - ZipFSCloseArchive(interp, zf0); - return TCL_ERROR; - } - zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); - if (!zf) { - if (interp) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + "%s is already mounted on %s", zf0->name, mountPoint)); + ZIPFS_ERROR_CODE(interp, "MOUNTED"); } Unlock(); - ZipFSCloseArchive(interp, zf0); + ZipFSCloseArchive(interp, zf); + ckfree(zf); return TCL_ERROR; } Unlock(); - *zf = *zf0; - zf->mountPoint = (char *)Tcl_GetHashKey(&ZipFS.zipHash, hPtr); - Tcl_CreateExitHandler(ZipfsExitHandler, zf); + /* + * Convert to a real archive descriptor. + */ + + zf->mountPoint = (char *) Tcl_GetHashKey(&ZipFS.zipHash, hPtr); + Tcl_CreateExitHandler(ZipfsMountExitHandler, zf); zf->mountPointLen = strlen(zf->mountPoint); + zf->nameLength = strlen(zipname); - zf->name = (char *)ckalloc(zf->nameLength + 1); + zf->name = (char *) ckalloc(zf->nameLength + 1); memcpy(zf->name, zipname, zf->nameLength + 1); - zf->entries = NULL; - zf->topEnts = NULL; - zf->numOpen = 0; + Tcl_SetHashValue(hPtr, zf); if ((zf->passBuf[0] == 0) && pwlen) { int k = 0; @@ -1242,21 +1636,15 @@ ZipFSCatalogFilesystem( if (mountPoint[0] != '\0') { hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mountPoint, &isNew); if (isNew) { - z = (ZipEntry *)ckalloc(sizeof(ZipEntry)); + z = AllocateZipEntry(); Tcl_SetHashValue(hPtr, z); - z->tnext = NULL; z->depth = CountSlashes(mountPoint); z->zipFilePtr = zf; z->isDirectory = (zf->baseOffset == 0) ? 1 : -1; /* root marker */ - z->isEncrypted = 0; z->offset = zf->baseOffset; - z->crc32 = 0; - z->timestamp = 0; - z->numBytes = z->numCompressedBytes = 0; z->compressMethod = ZIP_COMPMETH_STORED; - z->data = NULL; - z->name = (char *)Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr); z->next = zf->entries; zf->entries = z; } @@ -1264,17 +1652,17 @@ ZipFSCatalogFilesystem( q = zf->data + zf->directoryOffset; Tcl_DStringInit(&fpBuf); for (i = 0; i < zf->numFiles; i++) { + const unsigned char *start = zf->data; + const unsigned char *end = zf->data + zf->length; int extra, isdir = 0, dosTime, dosDate, nbcompr; size_t offs, pathlen, comlen; unsigned char *lq, *gq = NULL; char *fullpath, *path; - pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); - comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); - path = Tcl_DStringValue(&ds); + 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); + path = DecodeZipEntryText(q + ZIP_CENTRAL_HEADER_LEN, pathlen, &ds); if ((pathlen > 0) && (path[pathlen - 1] == '/')) { Tcl_DStringSetLength(&ds, pathlen - 1); path = Tcl_DStringValue(&ds); @@ -1284,24 +1672,25 @@ ZipFSCatalogFilesystem( goto nextent; } lq = zf->data + zf->baseOffset - + ZipReadInt(q + ZIP_CENTRAL_LOCALHDR_OFFS); - if ((lq < zf->data) || (lq > zf->data + zf->length)) { + + ZipReadInt(start, end, q + ZIP_CENTRAL_LOCALHDR_OFFS); + if ((lq < start) || (lq + ZIP_LOCAL_HEADER_LEN > end)) { goto nextent; } - nbcompr = ZipReadInt(lq + ZIP_LOCAL_COMPLEN_OFFS); + nbcompr = ZipReadInt(start, end, lq + ZIP_LOCAL_COMPLEN_OFFS); if (!isdir && (nbcompr == 0) - && (ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) - && (ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { + && (ZipReadInt(start, end, lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) + && (ZipReadInt(start, end, lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { gq = q; - nbcompr = ZipReadInt(gq + ZIP_CENTRAL_COMPLEN_OFFS); + nbcompr = ZipReadInt(start, end, gq + ZIP_CENTRAL_COMPLEN_OFFS); } offs = (lq - zf->data) + ZIP_LOCAL_HEADER_LEN - + ZipReadShort(lq + ZIP_LOCAL_PATHLEN_OFFS) - + ZipReadShort(lq + ZIP_LOCAL_EXTRALEN_OFFS); + + ZipReadShort(start, end, lq + ZIP_LOCAL_PATHLEN_OFFS) + + ZipReadShort(start, end, lq + ZIP_LOCAL_EXTRALEN_OFFS); if (offs + nbcompr > zf->length) { goto nextent; } + if (!isdir && (mountPoint[0] == '\0') && !CountSlashes(path)) { #ifdef ANDROID /* @@ -1317,8 +1706,7 @@ ZipFSCatalogFilesystem( Tcl_DStringInit(&ds2); Tcl_DStringAppend(&ds2, "assets/.root/", -1); Tcl_DStringAppend(&ds2, path, -1); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2)); - if (hPtr) { + if (ZipFSLookup(Tcl_DStringValue(&ds2))) { /* should not happen but skip it anyway */ Tcl_DStringFree(&ds2); goto nextent; @@ -1335,83 +1723,91 @@ ZipFSCatalogFilesystem( goto nextent; #endif /* ANDROID */ } + Tcl_DStringSetLength(&fpBuf, 0); fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1); - z = (ZipEntry *)ckalloc(sizeof(ZipEntry)); - z->name = NULL; - z->tnext = NULL; + z = AllocateZipEntry(); z->depth = CountSlashes(fullpath); z->zipFilePtr = zf; z->isDirectory = isdir; - z->isEncrypted = (ZipReadShort(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) + z->isEncrypted = + (ZipReadShort(start, end, lq + ZIP_LOCAL_FLAGS_OFFS) & 1) && (nbcompr > 12); z->offset = offs; if (gq) { - z->crc32 = ZipReadInt(gq + ZIP_CENTRAL_CRC32_OFFS); - dosDate = ZipReadShort(gq + ZIP_CENTRAL_MDATE_OFFS); - dosTime = ZipReadShort(gq + ZIP_CENTRAL_MTIME_OFFS); + z->crc32 = ZipReadInt(start, end, gq + ZIP_CENTRAL_CRC32_OFFS); + dosDate = ZipReadShort(start, end, gq + ZIP_CENTRAL_MDATE_OFFS); + dosTime = ZipReadShort(start, end, gq + ZIP_CENTRAL_MTIME_OFFS); z->timestamp = DosTimeDate(dosDate, dosTime); - z->numBytes = ZipReadInt(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); - z->compressMethod = ZipReadShort(gq + ZIP_CENTRAL_COMPMETH_OFFS); + z->numBytes = ZipReadInt(start, end, + gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); + z->compressMethod = ZipReadShort(start, end, + gq + ZIP_CENTRAL_COMPMETH_OFFS); } else { - z->crc32 = ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS); - dosDate = ZipReadShort(lq + ZIP_LOCAL_MDATE_OFFS); - dosTime = ZipReadShort(lq + ZIP_LOCAL_MTIME_OFFS); + z->crc32 = ZipReadInt(start, end, lq + ZIP_LOCAL_CRC32_OFFS); + dosDate = ZipReadShort(start, end, lq + ZIP_LOCAL_MDATE_OFFS); + dosTime = ZipReadShort(start, end, lq + ZIP_LOCAL_MTIME_OFFS); z->timestamp = DosTimeDate(dosDate, dosTime); - z->numBytes = ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS); - z->compressMethod = ZipReadShort(lq + ZIP_LOCAL_COMPMETH_OFFS); + z->numBytes = ZipReadInt(start, end, + lq + ZIP_LOCAL_UNCOMPLEN_OFFS); + z->compressMethod = ZipReadShort(start, end, + lq + ZIP_LOCAL_COMPMETH_OFFS); } z->numCompressedBytes = nbcompr; - z->data = NULL; hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew); if (!isNew) { /* should not happen but skip it anyway */ ckfree(z); - } else { - Tcl_SetHashValue(hPtr, z); - z->name = (char *)Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - z->next = zf->entries; - zf->entries = z; - if (isdir && (mountPoint[0] == '\0') && (z->depth == 1)) { - z->tnext = zf->topEnts; - zf->topEnts = z; - } - if (!z->isDirectory && (z->depth > 1)) { - char *dir, *end; - ZipEntry *zd; - - Tcl_DStringSetLength(&ds, strlen(z->name) + 8); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, z->name, -1); - dir = Tcl_DStringValue(&ds); - for (end = strrchr(dir, '/'); end && (end != dir); - end = strrchr(dir, '/')) { - Tcl_DStringSetLength(&ds, end - dir); - hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew); - if (!isNew) { - break; - } - zd = (ZipEntry *)ckalloc(sizeof(ZipEntry)); - zd->name = NULL; - zd->tnext = NULL; - zd->depth = CountSlashes(dir); - zd->zipFilePtr = zf; - zd->isDirectory = 1; - zd->isEncrypted = 0; - zd->offset = z->offset; - zd->crc32 = 0; - zd->timestamp = z->timestamp; - zd->numBytes = zd->numCompressedBytes = 0; - zd->compressMethod = ZIP_COMPMETH_STORED; - zd->data = NULL; - Tcl_SetHashValue(hPtr, zd); - zd->name = (char *)Tcl_GetHashKey(&ZipFS.fileHash, hPtr); - zd->next = zf->entries; - zf->entries = zd; - if ((mountPoint[0] == '\0') && (zd->depth == 1)) { - zd->tnext = zf->topEnts; - zf->topEnts = zd; - } + goto nextent; + } + + Tcl_SetHashValue(hPtr, z); + z->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->next = zf->entries; + zf->entries = z; + if (isdir && (mountPoint[0] == '\0') && (z->depth == 1)) { + z->tnext = zf->topEnts; + zf->topEnts = z; + } + + /* + * Make any directory nodes we need. ZIPs are not consistent about + * containing directory nodes. + */ + + if (!z->isDirectory && (z->depth > 1)) { + char *dir, *endPtr; + ZipEntry *zd; + + Tcl_DStringSetLength(&ds, strlen(z->name) + 8); + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, z->name, -1); + dir = Tcl_DStringValue(&ds); + for (endPtr = strrchr(dir, '/'); endPtr && (endPtr != dir); + endPtr = strrchr(dir, '/')) { + Tcl_DStringSetLength(&ds, endPtr - dir); + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew); + if (!isNew) { + /* + * Already made. That's fine. + */ + break; + } + + zd = AllocateZipEntry(); + zd->depth = CountSlashes(dir); + zd->zipFilePtr = zf; + zd->isDirectory = 1; + zd->offset = z->offset; + zd->timestamp = z->timestamp; + zd->compressMethod = ZIP_COMPMETH_STORED; + Tcl_SetHashValue(hPtr, zd); + zd->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + zd->next = zf->entries; + zf->entries = zd; + if ((mountPoint[0] == '\0') && (zd->depth == 1)) { + zd->tnext = zf->topEnts; + zf->topEnts = zd; } } } @@ -1456,7 +1852,12 @@ ZipfsSetup(void) Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); ZipFS.idCount = 1; ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE; + ZipFS.fallbackEntryEncoding = (char *) + ckalloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1); + strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING); + ZipFS.utf8 = Tcl_GetEncoding(NULL, "utf-8"); ZipFS.initialized = 1; + Tcl_CreateExitHandler(ZipfsExitHandler, NULL); } /* @@ -1485,17 +1886,28 @@ ListMountPoints( Tcl_HashEntry *hPtr; Tcl_HashSearch search; ZipFile *zf; + Tcl_Obj *resultList; + if (!interp) { + /* + * Are there any entries in the zipHash? Don't need to enumerate them + * all to know. + */ + + return (ZipFS.zipHash.numEntries ? TCL_OK : TCL_BREAK); + } + + resultList = Tcl_NewObj(); for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - if (!interp) { - return TCL_OK; - } - zf = (ZipFile *)Tcl_GetHashValue(hPtr); - Tcl_AppendElement(interp, zf->mountPoint); - Tcl_AppendElement(interp, zf->name); + zf = (ZipFile *) Tcl_GetHashValue(hPtr); + Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj( + zf->mountPoint, -1)); + Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj( + zf->name, -1)); } - return (interp ? TCL_OK : TCL_BREAK); + Tcl_SetObjResult(interp, resultList); + return TCL_OK; } /* @@ -1522,13 +1934,10 @@ DescribeMounted( Tcl_Interp *interp, const char *mountPoint) { - Tcl_HashEntry *hPtr; - ZipFile *zf; - if (interp) { - hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); - if (hPtr) { - zf = (ZipFile *)Tcl_GetHashValue(hPtr); + ZipFile *zf = ZipFSLookupZip(mountPoint); + + if (zf) { Tcl_SetObjResult(interp, Tcl_NewStringObj(zf->name, -1)); return TCL_OK; } @@ -1558,7 +1967,8 @@ int TclZipfs_Mount( Tcl_Interp *interp, /* Current interpreter. NULLable. */ const char *mountPoint, /* Mount point path. */ - const char *zipname, /* Path to ZIP file to mount. */ + const char *zipname, /* Path to ZIP file to mount; should be + * normalized. */ const char *passwd) /* Password for opening the ZIP, or NULL if * the ZIP is unprotected. */ { @@ -1595,22 +2005,11 @@ TclZipfs_Mount( * Have both a mount point and a file (name) to mount there. */ - if (passwd) { - if ((strlen(passwd) > 255) || strchr(passwd, 0xff)) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); - } - return TCL_ERROR; - } + if (passwd && IsPasswordValid(interp, passwd, strlen(passwd)) != TCL_OK) { + return TCL_ERROR; } - zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); + zf = AllocateZipFile(interp, strlen(mountPoint)); if (!zf) { - if (interp) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } return TCL_ERROR; } if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) { @@ -1619,10 +2018,8 @@ TclZipfs_Mount( } if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname) != TCL_OK) { - ckfree(zf); return TCL_ERROR; } - ckfree(zf); return TCL_OK; } @@ -1686,23 +2083,16 @@ TclZipfs_MountBuffer( * Have both a mount point and data to mount there. */ - zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); + zf = AllocateZipFile(interp, strlen(mountPoint)); if (!zf) { - if (interp) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } return TCL_ERROR; } zf->isMemBuffer = 1; zf->length = datalen; if (copy) { - zf->data = (unsigned char *)attemptckalloc(datalen); + zf->data = (unsigned char *) attemptckalloc(datalen); if (!zf->data) { - if (interp) { - Tcl_AppendResult(interp, "out of memory", (char *) NULL); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } + ZIPFS_MEM_ERROR(interp); return TCL_ERROR; } memcpy(zf->data, data, datalen); @@ -1711,13 +2101,11 @@ TclZipfs_MountBuffer( zf->data = data; zf->ptrToFree = NULL; } - zf->passBuf[0] = 0; /* stop valgrind cries */ if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) { return TCL_ERROR; } result = ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL, "Memory Buffer"); - ckfree(zf); return result; } @@ -1767,13 +2155,20 @@ TclZipfs_Unmount( goto done; } - zf = (ZipFile *)Tcl_GetHashValue(hPtr); + zf = (ZipFile *) Tcl_GetHashValue(hPtr); if (zf->numOpen > 0) { ZIPFS_ERROR(interp, "filesystem is busy"); + ZIPFS_ERROR_CODE(interp, "BUSY"); ret = TCL_ERROR; goto done; } Tcl_DeleteHashEntry(hPtr); + + /* + * Now no longer mounted - the rest of the code won't find it - but we're + * still cleaning things up. + */ + for (z = zf->entries; z; z = znext) { znext = z->next; hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); @@ -1786,9 +2181,10 @@ TclZipfs_Unmount( ckfree(z); } ZipFSCloseArchive(interp, zf); - Tcl_DeleteExitHandler(ZipfsExitHandler, zf); + Tcl_DeleteExitHandler(ZipfsMountExitHandler, zf); ckfree(zf); unmounted = 1; + done: Unlock(); if (unmounted) { @@ -1820,16 +2216,38 @@ ZipFSMountObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + const char *mountPoint = NULL, *zipFile = NULL, *password = NULL; + Tcl_Obj *zipFileObj = NULL; + int result; if (objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?zipfile? ?password?"); return TCL_ERROR; } + if (objc > 1) { + mountPoint = Tcl_GetString(objv[1]); + } + if (objc > 2) { + zipFileObj = Tcl_FSGetNormalizedPath(interp, objv[2]); + if (!zipFileObj) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "could not normalize zip filename", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NORMALIZE", NULL); + return TCL_ERROR; + } + Tcl_IncrRefCount(zipFileObj); + zipFile = Tcl_GetString(zipFileObj); + } + if (objc > 3) { + password = Tcl_GetString(objv[3]); + } - return TclZipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL, - (objc > 2) ? Tcl_GetString(objv[2]) : NULL, - (objc > 3) ? Tcl_GetString(objv[3]) : NULL); + result = TclZipfs_Mount(interp, mountPoint, zipFile, password); + if (zipFileObj != NULL) { + Tcl_DecrRefCount(zipFileObj); + } + return result; } /* @@ -1937,7 +2355,6 @@ ZipFSUnmountObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "zipfile"); return TCL_ERROR; @@ -1970,37 +2387,80 @@ ZipFSMkKeyObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int len, i = 0; - char *pw, passBuf[264]; + const char *pw; + Tcl_Obj *passObj; + unsigned char *passBuf; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "password"); return TCL_ERROR; } - pw = Tcl_GetString(objv[1]); - len = strlen(pw); + pw = Tcl_GetStringFromObj(objv[1], &len); if (len == 0) { return TCL_OK; } - if ((len > 255) || strchr(pw, 0xff)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("illegal password", -1)); + if (IsPasswordValid(interp, pw, len) != TCL_OK) { return TCL_ERROR; } + + passObj = Tcl_NewByteArrayObj(NULL, 264); + passBuf = Tcl_GetByteArrayFromObj(passObj, (int *)NULL); while (len > 0) { int ch = pw[len - 1]; - passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - i++; + passBuf[i++] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; len--; } passBuf[i] = i; - ++i; - passBuf[i++] = (char) ZIP_PASSWORD_END_SIG; - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); - passBuf[i] = '\0'; - Tcl_AppendResult(interp, passBuf, (char *) NULL); + i++; + ZipWriteInt(passBuf, passBuf + 264, passBuf + i, ZIP_PASSWORD_END_SIG); + Tcl_SetByteArrayLength(passObj, i + 4); + Tcl_SetObjResult(interp, passObj); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * RandomChar -- + * + * Worker for ZipAddFile(). Picks a random character (range: 0..255) + * using Tcl's standard PRNG. + * + * Returns: + * Tcl result code. Updates chPtr with random character on success. + * + * Side effects: + * Advances the PRNG state. May reenter the Tcl interpreter if the user + * has replaced the PRNG. + * + *------------------------------------------------------------------------- + */ + +static int +RandomChar( + Tcl_Interp *interp, + int step, + int *chPtr) +{ + double r; + Tcl_Obj *ret; + + if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", -1, 0) != TCL_OK) { + goto failed; + } + ret = Tcl_GetObjResult(interp); + if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) { + goto failed; + } + *chPtr = (int) (r * 256); return TCL_OK; + + failed: + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (evaluating PRNG step %d for password encoding)", + step)); + return TCL_ERROR; } /* @@ -2008,11 +2468,14 @@ ZipFSMkKeyObjCmd( * * ZipAddFile -- * - * This procedure is used by ZipFSMkZipOrImgCmd() to add a single file to + * This procedure is used by ZipFSMkZipOrImg() to add a single file to * the output ZIP archive file being written. A ZipEntry struct about the * 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. * @@ -2026,23 +2489,30 @@ ZipFSMkKeyObjCmd( static int ZipAddFile( Tcl_Interp *interp, /* Current interpreter. */ - const char *path, - const char *name, - Tcl_Channel out, + Tcl_Obj *pathObj, /* Actual name of the file to add. */ + 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. */ - char *buf, - int bufsize, - Tcl_HashTable *fileHash) + char *buf, /* Working buffer. */ + int bufsize, /* Size of buf */ + Tcl_HashTable *fileHash) /* Where to record ZIP entry metdata so we can + * built the central directory. */ { + const unsigned char *start = (unsigned char *) buf; + const unsigned char *end = (unsigned char *) buf + bufsize; Tcl_Channel in; 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 pos[3]; + long long headerStartOffset, dataStartOffset, dataEndOffset; int mtime = 0, isNew, compMeth; unsigned long keys[3], keys0[3]; char obuf[4096]; @@ -2052,23 +2522,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\"", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "PATH_LEN", NULL); + "path too long for \"%s\"", Tcl_GetString(pathObj))); + ZIPFS_ERROR_CODE(interp, "PATH_LEN"); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } - in = Tcl_OpenFileChannel(interp, path, "rb", 0); + 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) { @@ -2079,27 +2557,31 @@ ZipAddFile( Tcl_Close(interp, in); return TCL_ERROR; } else { - Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1); Tcl_StatBuf statBuf; - Tcl_IncrRefCount(pathObj); if (Tcl_FSStat(pathObj, &statBuf) != -1) { mtime = statBuf.st_mtime; } - Tcl_DecrRefCount(pathObj); } Tcl_ResetResult(interp); + + /* + * Compute the CRC. + */ + crc = 0; nbyte = nbytecompr = 0; 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; } + readErrorWithChannelOpen: Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s", - path, Tcl_PosixError(interp))); + Tcl_GetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); return TCL_ERROR; } @@ -2111,66 +2593,70 @@ ZipAddFile( } if (Tcl_Seek(in, 0, SEEK_SET) == -1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("seek error on \"%s\": %s", - path, Tcl_PosixError(interp))); + Tcl_GetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } - pos[0] = Tcl_Tell(out); + + /* + * Remember where we've got to so far so we can write the header (after + * writing the file). + */ + + headerStartOffset = Tcl_Tell(out); + + /* + * Reserve space for the per-file header. Includes writing the file name + * as we already know that. + */ + 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) { - wrerr: + writeErrorWithChannelOpen: Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error on %s: %s", path, Tcl_PosixError(interp))); + "write error on \"%s\": %s", + Tcl_GetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } - if ((len + pos[0]) & 3) { - unsigned char abuf[8]; - /* - * Align payload to next 4-byte boundary using a dummy extra entry - * similar to the zipalign tool from Android's SDK. - */ + /* + * Align payload to next 4-byte boundary (if necessary) using a dummy + * extra entry similar to the zipalign tool from Android's SDK. + */ - align = 4 + ((len + pos[0]) & 3); - ZipWriteShort(abuf, 0xffff); - ZipWriteShort(abuf + 2, align - 4); - ZipWriteInt(abuf + 4, 0x03020100); + if ((len + headerStartOffset) & 3) { + unsigned char abuf[8]; + const unsigned char *astart = abuf; + const unsigned char *aend = abuf + 8; + + align = 4 + ((len + headerStartOffset) & 3); + ZipWriteShort(astart, aend, abuf, 0xffff); + ZipWriteShort(astart, aend, abuf + 2, align - 4); + ZipWriteInt(astart, aend, abuf + 4, 0x03020100); if ((size_t) Tcl_Write(out, (const char *) abuf, align) != align) { - goto wrerr; + goto writeErrorWithChannelOpen; } } + + /* + * Set up encryption if we were asked to. + */ + if (passwd) { int i, ch, tmp; unsigned char kvbuf[24]; - Tcl_Obj *ret; init_keys(passwd, keys, crc32tab); for (i = 0; i < 12 - 2; i++) { - double r; - - if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", -1, 0) != TCL_OK) { - Tcl_Obj *eiPtr = Tcl_ObjPrintf( - "\n (evaluating PRNG step %d for password encoding)", - i); - - Tcl_AppendObjToErrorInfo(interp, eiPtr); + if (RandomChar(interp, i, &ch) != TCL_OK) { Tcl_Close(interp, in); return TCL_ERROR; } - ret = Tcl_GetObjResult(interp); - if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) { - Tcl_Obj *eiPtr = Tcl_ObjPrintf( - "\n (evaluating PRNG step %d for password encoding)", - i); - - Tcl_AppendObjToErrorInfo(interp, eiPtr); - Tcl_Close(interp, in); - return TCL_ERROR; - } - ch = (int) (r * 256); kvbuf[i + 12] = UCHAR(zencode(keys, crc32tab, ch, tmp)); } Tcl_ResetResult(interp); @@ -2183,16 +2669,23 @@ ZipAddFile( len = Tcl_Write(out, (char *) kvbuf, 12); memset(kvbuf, 0, 24); if (len != 12) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error on %s: %s", path, Tcl_PosixError(interp))); - Tcl_Close(interp, in); - return TCL_ERROR; + goto writeErrorWithChannelOpen; } memcpy(keys0, keys, sizeof(keys0)); nbytecompr += 12; } + + /* + * Save where we've got to in case we need to just store this file. + */ + Tcl_Flush(out); - pos[2] = Tcl_Tell(out); + dataStartOffset = Tcl_Tell(out); + + /* + * Compress the stream. + */ + compMeth = ZIP_COMPMETH_DEFLATED; memset(&stream, 0, sizeof(z_stream)); stream.zalloc = Z_NULL; @@ -2201,19 +2694,18 @@ ZipAddFile( if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, Z_DEFAULT_STRATEGY) != Z_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "compression init error on \"%s\"", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE_INIT", NULL); + "compression init error on \"%s\"", Tcl_GetString(pathObj))); + ZIPFS_ERROR_CODE(interp, "DEFLATE_INIT"); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } + do { len = Tcl_Read(in, buf, bufsize); if (len == ERROR_LENGTH) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "read error on %s: %s", path, Tcl_PosixError(interp))); deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; + goto readErrorWithChannelOpen; } stream.avail_in = len; stream.next_in = (unsigned char *) buf; @@ -2224,10 +2716,11 @@ ZipAddFile( len = deflate(&stream, flush); if (len == (size_t) Z_STREAM_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "deflate error on %s", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE", NULL); + "deflate error on \"%s\"", Tcl_GetString(pathObj))); + ZIPFS_ERROR_CODE(interp, "DEFLATE"); deflateEnd(&stream); Tcl_Close(interp, in); + Tcl_DStringFree(&zpathDs); return TCL_ERROR; } olen = sizeof(obuf) - stream.avail_out; @@ -2240,41 +2733,42 @@ ZipAddFile( } } if (olen && ((size_t) Tcl_Write(out, obuf, olen) != olen)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); deflateEnd(&stream); - Tcl_Close(interp, in); - return TCL_ERROR; + goto writeErrorWithChannelOpen; } nbytecompr += olen; } while (stream.avail_out == 0); } while (flush != Z_FINISH); deflateEnd(&stream); + + /* + * Work out where we've got to. + */ + Tcl_Flush(out); - pos[1] = Tcl_Tell(out); + dataEndOffset = Tcl_Tell(out); + if (nbyte - nbytecompr <= 0) { /* * Compressed file larger than input, write it again uncompressed. */ + if (Tcl_Seek(in, 0, SEEK_SET) != 0) { goto seekErr; } - if (Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) { + if (Tcl_Seek(out, dataStartOffset, SEEK_SET) != dataStartOffset) { seekErr: - Tcl_Close(interp, in); 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); while (1) { len = Tcl_Read(in, buf, bufsize); if (len == ERROR_LENGTH) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "read error on \"%s\": %s", - path, Tcl_PosixError(interp))); - Tcl_Close(interp, in); - return TCL_ERROR; + goto readErrorWithChannelOpen; } else if (len == 0) { break; } @@ -2287,61 +2781,57 @@ ZipAddFile( } } if ((size_t) Tcl_Write(out, buf, len) != len) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - Tcl_Close(interp, in); - return TCL_ERROR; + goto writeErrorWithChannelOpen; } nbytecompr += len; } compMeth = ZIP_COMPMETH_STORED; + + /* + * Chop off everything after this; it's the over-large compressed data + * and we don't know if it is going to get overwritten otherwise. + */ + Tcl_Flush(out); - pos[1] = Tcl_Tell(out); - Tcl_TruncateChannel(out, pos[1]); + dataEndOffset = Tcl_Tell(out); + 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\"", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DUPLICATE_PATH", NULL); + "non-unique path name \"%s\"", Tcl_GetString(pathObj))); + ZIPFS_ERROR_CODE(interp, "DUPLICATE_PATH"); return TCL_ERROR; } - z = (ZipEntry *)ckalloc(sizeof(ZipEntry)); + /* + * Remember that we've written the file (for central directory generation) + * and generate the local (per-file) header in the space that we reserved + * earlier. + */ + + z = AllocateZipEntry(); Tcl_SetHashValue(hPtr, z); - z->name = NULL; - z->tnext = NULL; - z->depth = 0; - z->zipFilePtr = NULL; - z->isDirectory = 0; z->isEncrypted = (passwd ? 1 : 0); - z->offset = pos[0]; + z->offset = headerStartOffset; z->crc32 = crc; z->timestamp = mtime; z->numBytes = nbyte; z->numCompressedBytes = nbytecompr; z->compressMethod = compMeth; - z->data = NULL; - z->name = (char *)Tcl_GetHashKey(fileHash, hPtr); - z->next = NULL; + z->name = (char *) Tcl_GetHashKey(fileHash, hPtr); /* * Write final local header information. */ - ZipWriteInt(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG); - ZipWriteShort(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION); - ZipWriteShort(buf + ZIP_LOCAL_FLAGS_OFFS, z->isEncrypted); - ZipWriteShort(buf + ZIP_LOCAL_COMPMETH_OFFS, z->compressMethod); - ZipWriteShort(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp)); - ZipWriteShort(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp)); - ZipWriteInt(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32); - ZipWriteInt(buf + ZIP_LOCAL_COMPLEN_OFFS, z->numCompressedBytes); - ZipWriteInt(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes); - ZipWriteShort(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen); - ZipWriteShort(buf + ZIP_LOCAL_EXTRALEN_OFFS, align); - if (Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) { + + SerializeLocalEntryHeader(start, end, (unsigned char *) buf, z, + zpathlen, align); + if (Tcl_Seek(out, headerStartOffset, SEEK_SET) != headerStartOffset) { Tcl_DeleteHashEntry(hPtr); ckfree(z); Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2356,7 +2846,7 @@ ZipAddFile( return TCL_ERROR; } Tcl_Flush(out); - if (Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) { + if (Tcl_Seek(out, dataEndOffset, SEEK_SET) != dataEndOffset) { Tcl_DeleteHashEntry(hPtr); ckfree(z); Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2369,12 +2859,101 @@ ZipAddFile( /* *------------------------------------------------------------------------- * - * ZipFSMkZipOrImgObjCmd -- + * ZipFSFind -- + * + * Worker for ZipFSMkZipOrImg() that discovers the list of files to add. + * Simple wrapper around [zipfs find]. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +ZipFSFind( + Tcl_Interp *interp, + Tcl_Obj *dirRoot) +{ + Tcl_Obj *cmd[2]; + int result; + + cmd[0] = Tcl_NewStringObj("::tcl::zipfs::find", -1); + cmd[1] = dirRoot; + Tcl_IncrRefCount(cmd[0]); + result = Tcl_EvalObjv(interp, 2, cmd, 0); + Tcl_DecrRefCount(cmd[0]); + if (result != TCL_OK) { + return NULL; + } + return Tcl_GetObjResult(interp); +} + +/* + *------------------------------------------------------------------------- + * + * ComputeNameInArchive -- + * + * Helper for ZipFSMkZipOrImg() that computes what the actual name of a + * file in the ZIP archive should be, stripping a prefix (if appropriate) + * and any leading slashes. If the result is an empty string, the entry + * should be skipped. + * + * Returns: + * 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) + * + *------------------------------------------------------------------------- + */ + +static inline const char * +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; 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; + + if (directNameObj) { + name = Tcl_GetString(directNameObj); + } else { + name = Tcl_GetStringFromObj(pathObj, &len); + if (slen > 0) { + if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { + /* + * Guaranteed to be a NUL at the end, which will make this + * entry be skipped. + */ + + return name + len; + } + name += slen; + } + } + while (name[0] == '/') { + ++name; + } + return name; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkZipOrImg -- * * This procedure is creates a new ZIP archive file or image file given * output filename, input directory of files to be archived, optional * password, and optional image to be prepended to the output ZIP archive - * file. + * 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. @@ -2386,95 +2965,103 @@ ZipAddFile( */ static int -ZipFSMkZipOrImgObjCmd( +ZipFSMkZipOrImg( Tcl_Interp *interp, /* Current interpreter. */ - int isImg, - int isList, - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + int isImg, /* Are we making an image? */ + Tcl_Obj *targetFile, /* What file are we making? */ + Tcl_Obj *dirRoot, /* What directory do we take files from? Do + * not specify at the same time as + * mappingList (one must be NULL). */ + Tcl_Obj *mappingList, /* What files are we putting in, and with what + * names? Do not specify at the same time as + * dirRoot (one must be NULL). */ + Tcl_Obj *originFile, /* If we're making an image, what file does + * the non-ZIP part of the image come from? */ + Tcl_Obj *stripPrefix, /* Are we going to strip a prefix from + * filenames found beneath dirRoot? If NULL, + * do not strip anything (except for dirRoot + * itself). */ + Tcl_Obj *passwordObj) /* The password for encoding things. NULL if + * there's no password protection. */ { Tcl_Channel out; - int pwlen = 0, count, ret = TCL_ERROR, lobjc; - size_t len, slen = 0, i = 0; - long long pos[3]; - Tcl_Obj **lobjv, *list = NULL; + int pwlen = 0, slen = 0, count, ret = TCL_ERROR, lobjc; + size_t len, i = 0; + long long dataStartOffset; /* The overall file offset of the start of the + * data section of the file. */ + long long directoryStartOffset; + /* The overall file offset of the start of the + * central directory. */ + long long suffixStartOffset;/* The overall file offset of the start of the + * suffix of the central directory (i.e., + * where this data will be written). */ + Tcl_Obj **lobjv, *list = mappingList; ZipEntry *z; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable fileHash; char *strip = NULL, *pw = NULL, passBuf[264], buf[4096]; + unsigned char *start = (unsigned char *) buf; + unsigned char *end = start + sizeof(buf); /* * Caller has verified that the number of arguments is correct. */ passBuf[0] = 0; - if (objc > (isList ? 3 : 4)) { - pw = Tcl_GetString(objv[isList ? 3 : 4]); - pwlen = strlen(pw); - if ((pwlen > 255) || strchr(pw, 0xff)) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); + if (passwordObj != NULL) { + pw = Tcl_GetStringFromObj(passwordObj, &pwlen); + if (IsPasswordValid(interp, pw, pwlen) != TCL_OK) { return TCL_ERROR; } + if (pwlen <= 0) { + pw = NULL; + pwlen = 0; + } } - if (isList) { - list = objv[2]; - Tcl_IncrRefCount(list); - } else { - Tcl_Obj *cmd[3]; - - cmd[1] = Tcl_NewStringObj("::tcl::zipfs::find", -1); - cmd[2] = objv[2]; - cmd[0] = Tcl_NewListObj(2, cmd + 1); - Tcl_IncrRefCount(cmd[0]); - if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) { - Tcl_DecrRefCount(cmd[0]); + if (dirRoot != NULL) { + list = ZipFSFind(interp, dirRoot); + if (!list) { return TCL_ERROR; } - Tcl_DecrRefCount(cmd[0]); - list = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(list); } + Tcl_IncrRefCount(list); if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { Tcl_DecrRefCount(list); return TCL_ERROR; } - if (isList && (lobjc % 2)) { + if (mappingList && (lobjc % 2)) { Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, - Tcl_NewStringObj("need even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "LIST_LENGTH", NULL); + ZIPFS_ERROR(interp, "need even number of elements"); + ZIPFS_ERROR_CODE(interp, "LIST_LENGTH"); return TCL_ERROR; } if (lobjc == 0) { Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); + ZIPFS_ERROR(interp, "empty archive"); + ZIPFS_ERROR_CODE(interp, "EMPTY"); return TCL_ERROR; } - out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "wb", 0755); + out = Tcl_FSOpenFileChannel(interp, targetFile, "wb", 0755); if (out == NULL) { Tcl_DecrRefCount(list); return TCL_ERROR; } - if (pwlen <= 0) { - pw = NULL; - pwlen = 0; - } + + /* + * Copy the existing contents from the image if it is an executable image. + * Care must be taken because this might include an existing ZIP, which + * needs to be stripped. + */ + if (isImg) { ZipFile *zf, zf0; int isMounted = 0; const char *imgName; - if (isList) { - imgName = (objc > 4) ? Tcl_GetString(objv[4]) : - Tcl_GetNameOfExecutable(); - } else { - imgName = (objc > 5) ? Tcl_GetString(objv[5]) : - Tcl_GetNameOfExecutable(); - } + // TODO: normalize the origin file name + imgName = (originFile != NULL) ? Tcl_GetString(originFile) : + Tcl_GetNameOfExecutable(); if (pwlen) { i = 0; for (len = pwlen; len-- > 0;) { @@ -2499,7 +3086,7 @@ ZipFSMkZipOrImgObjCmd( WriteLock(); for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - zf = (ZipFile *)Tcl_GetHashValue(hPtr); + zf = (ZipFile *) Tcl_GetHashValue(hPtr); if (strcmp(zf->name, imgName) == 0) { isMounted = 1; zf->numOpen++; @@ -2507,10 +3094,16 @@ ZipFSMkZipOrImgObjCmd( } } Unlock(); + if (!isMounted) { zf = &zf0; + memset(&zf0, 0, sizeof(ZipFile)); } if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) { + /* + * Copy everything up to the ZIP-related suffix. + */ + if ((size_t) Tcl_Write(out, (char *) zf->data, zf->passOffset) != zf->passOffset) { memset(passBuf, 0, sizeof(passBuf)); @@ -2535,56 +3128,23 @@ ZipFSMkZipOrImgObjCmd( Unlock(); } } else { - size_t k; - int m, n; - Tcl_Channel in; - const char *errMsg = "seek error"; - /* * Fall back to read it as plain file which hopefully is a static * tclsh or wish binary with proper zipfs infrastructure built in. */ - Tcl_ResetResult(interp); - in = Tcl_OpenFileChannel(interp, imgName, "rb", 0644); - if (!in) { - memset(passBuf, 0, sizeof(passBuf)); - Tcl_DecrRefCount(list); - Tcl_Close(interp, out); - return TCL_ERROR; - } - i = Tcl_Seek(in, 0, SEEK_END); - if (i == ERROR_LENGTH) { - cperr: + if (CopyImageFile(interp, imgName, out) != TCL_OK) { memset(passBuf, 0, sizeof(passBuf)); Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s: %s", errMsg, Tcl_PosixError(interp))); Tcl_Close(interp, out); - Tcl_Close(interp, in); return TCL_ERROR; } - Tcl_Seek(in, 0, SEEK_SET); - for (k = 0; k < i; k += m) { - m = i - k; - if (m > (int) sizeof(buf)) { - m = (int) sizeof(buf); - } - n = Tcl_Read(in, buf, m); - if (n == -1) { - errMsg = "read error"; - goto cperr; - } else if (n == 0) { - break; - } - m = Tcl_Write(out, buf, n); - if (m != n) { - errMsg = "write error"; - goto cperr; - } - } - Tcl_Close(interp, in); } + + /* + * Store the password so that the automounter can find it. + */ + len = strlen(passBuf); if (len > 0) { i = Tcl_Write(out, passBuf, len); @@ -2599,105 +3159,74 @@ ZipFSMkZipOrImgObjCmd( memset(passBuf, 0, sizeof(passBuf)); Tcl_Flush(out); } + + /* + * Prepare the contents of the ZIP archive. + */ + Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); - pos[0] = Tcl_Tell(out); - if (!isList && (objc > 3)) { - strip = Tcl_GetString(objv[3]); - slen = strlen(strip); + 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 += (isList ? 2 : 1)) { - const char *path, *name; + for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) { + Tcl_Obj *pathObj = lobjv[i]; + const char *name = ComputeNameInArchive(pathObj, + (mappingList ? lobjv[i + 1] : NULL), strip, slen); - path = Tcl_GetString(lobjv[i]); - if (isList) { - name = Tcl_GetString(lobjv[i + 1]); - } else { - name = path; - if (slen > 0) { - len = strlen(name); - if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { - continue; - } - name += slen; - } - } - while (name[0] == '/') { - ++name; - } if (name[0] == '\0') { continue; } - if (ZipAddFile(interp, path, name, out, pw, buf, sizeof(buf), + if (ZipAddFile(interp, pathObj, name, out, pw, buf, sizeof(buf), &fileHash) != TCL_OK) { goto done; } } - pos[1] = Tcl_Tell(out); + + /* + * Construct the contents of the ZIP central directory. + */ + + directoryStartOffset = Tcl_Tell(out); count = 0; - for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { - const char *path, *name; + 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; - path = Tcl_GetString(lobjv[i]); - if (isList) { - name = Tcl_GetString(lobjv[i + 1]); - } else { - name = path; - if (slen > 0) { - len = strlen(name); - if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { - continue; - } - name += slen; - } - } - while (name[0] == '/') { - ++name; - } - if (name[0] == '\0') { - continue; - } hPtr = Tcl_FindHashEntry(&fileHash, name); if (!hPtr) { continue; } - z = (ZipEntry *)Tcl_GetHashValue(hPtr); - len = strlen(z->name); - ZipWriteInt(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG); - ZipWriteShort(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION); - ZipWriteShort(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION); - ZipWriteShort(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted); - ZipWriteShort(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->compressMethod); - ZipWriteShort(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp)); - ZipWriteShort(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp)); - ZipWriteInt(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32); - ZipWriteInt(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->numCompressedBytes); - ZipWriteInt(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes); - ZipWriteShort(buf + ZIP_CENTRAL_PATHLEN_OFFS, len); - ZipWriteShort(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_IATTR_OFFS, 0); - ZipWriteInt(buf + ZIP_CENTRAL_EATTR_OFFS, 0); - ZipWriteInt(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]); - if ((Tcl_Write(out, buf, - ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN) - || ((size_t) Tcl_Write(out, z->name, len) != len)) { + z = (ZipEntry *) Tcl_GetHashValue(hPtr); + + 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, name, len) != len)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error: %s", Tcl_PosixError(interp))); + Tcl_DStringFree(&ds); goto done; } + Tcl_DStringFree(&ds); count++; } + + /* + * Finalize the central directory. + */ + Tcl_Flush(out); - pos[2] = Tcl_Tell(out); - ZipWriteInt(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG); - ZipWriteShort(buf + ZIP_CENTRAL_DISKNO_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_ENTS_OFFS, count); - ZipWriteShort(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count); - ZipWriteInt(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]); - ZipWriteInt(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]); - ZipWriteShort(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); + suffixStartOffset = Tcl_Tell(out); + SerializeCentralDirectorySuffix(start, end, (unsigned char *) buf, + count, dataStartOffset, directoryStartOffset, suffixStartOffset); if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error: %s", Tcl_PosixError(interp))); @@ -2715,7 +3244,7 @@ ZipFSMkZipOrImgObjCmd( Tcl_DecrRefCount(list); for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - z = (ZipEntry *)Tcl_GetHashValue(hPtr); + z = (ZipEntry *) Tcl_GetHashValue(hPtr); ckfree(z); Tcl_DeleteHashEntry(hPtr); } @@ -2724,18 +3253,207 @@ ZipFSMkZipOrImgObjCmd( } /* + * --------------------------------------------------------------------- + * + * CopyImageFile -- + * + * A simple file copy function that is used (by ZipFSMkZipOrImg) for + * anything that is not an image with a ZIP appended. + * + * Returns: + * A Tcl result code. + * + * Side effects: + * Writes to an output channel. + * + * --------------------------------------------------------------------- + */ + +static int +CopyImageFile( + Tcl_Interp *interp, /* For error reporting. */ + const char *imgName, /* Where to copy from. */ + Tcl_Channel out) /* Where to copy to; already open for writing + * binary data. */ +{ + size_t i, k; + int m, n; + Tcl_Channel in; + char buf[4096]; + const char *errMsg; + + Tcl_ResetResult(interp); + in = Tcl_OpenFileChannel(interp, imgName, "rb", 0644); + if (!in) { + return TCL_ERROR; + } + + /* + * Get the length of the file (and exclude non-files). + */ + + i = Tcl_Seek(in, 0, SEEK_END); + if (i == ERROR_LENGTH) { + errMsg = "seek error"; + goto copyError; + } + Tcl_Seek(in, 0, SEEK_SET); + + /* + * Copy the whole file, 8 blocks at a time (reasonably efficient). Note + * that this totally ignores things like Windows's Alternate File Streams. + */ + + for (k = 0; k < i; k += m) { + m = i - k; + if (m > (int) sizeof(buf)) { + m = (int) sizeof(buf); + } + n = Tcl_Read(in, buf, m); + if (n == -1) { + errMsg = "read error"; + goto copyError; + } else if (n == 0) { + break; + } + m = Tcl_Write(out, buf, n); + if (m != n) { + errMsg = "write error"; + goto copyError; + } + } + Tcl_Close(interp, in); + return TCL_OK; + + copyError: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s: %s", errMsg, Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; +} + +/* + * --------------------------------------------------------------------- + * + * SerializeLocalEntryHeader, SerializeCentralDirectoryEntry, + * SerializeCentralDirectorySuffix -- + * + * Create serialized forms of the structures that make up the ZIP + * metadata. Note that the both the local entry and the central directory + * entry need to have the name of the entry written directly afterwards. + * + * We could write these as structs except we need to guarantee that we + * are writing these out as little-endian values. + * + * Side effects: + * Both update their buffer arguments, but otherwise change nothing. + * + * --------------------------------------------------------------------- + */ + +static void +SerializeLocalEntryHeader( + const unsigned char *start, /* The start of writable memory. */ + const unsigned char *end, /* The end of writable memory. */ + unsigned char *buf, /* Where to serialize to */ + ZipEntry *z, /* The description of what to serialize. */ + int nameLength, /* The length of the name. */ + int align) /* The number of alignment bytes. */ +{ + ZipWriteInt(start, end, buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG); + ZipWriteShort(start, end, buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION); + ZipWriteShort(start, end, buf + ZIP_LOCAL_FLAGS_OFFS, z->isEncrypted); + ZipWriteShort(start, end, buf + ZIP_LOCAL_COMPMETH_OFFS, + z->compressMethod); + ZipWriteShort(start, end, buf + ZIP_LOCAL_MTIME_OFFS, + ToDosTime(z->timestamp)); + ZipWriteShort(start, end, buf + ZIP_LOCAL_MDATE_OFFS, + ToDosDate(z->timestamp)); + ZipWriteInt(start, end, buf + ZIP_LOCAL_CRC32_OFFS, z->crc32); + ZipWriteInt(start, end, buf + ZIP_LOCAL_COMPLEN_OFFS, + z->numCompressedBytes); + ZipWriteInt(start, end, buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes); + ZipWriteShort(start, end, buf + ZIP_LOCAL_PATHLEN_OFFS, nameLength); + ZipWriteShort(start, end, buf + ZIP_LOCAL_EXTRALEN_OFFS, align); +} + +static void +SerializeCentralDirectoryEntry( + const unsigned char *start, /* The start of writable memory. */ + const unsigned char *end, /* The end of writable memory. */ + unsigned char *buf, /* Where to serialize to */ + ZipEntry *z, /* The description of what to serialize. */ + size_t nameLength, /* The length of the name. */ + long long dataStartOffset) /* The overall file offset of the start of the + * data section of the file. */ +{ + ZipWriteInt(start, end, buf + ZIP_CENTRAL_SIG_OFFS, + ZIP_CENTRAL_HEADER_SIG); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSIONMADE_OFFS, + ZIP_MIN_VERSION); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMPMETH_OFFS, + z->compressMethod); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_MTIME_OFFS, + ToDosTime(z->timestamp)); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_MDATE_OFFS, + ToDosDate(z->timestamp)); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_COMPLEN_OFFS, + z->numCompressedBytes); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_PATHLEN_OFFS, nameLength); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKFILE_OFFS, 0); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_IATTR_OFFS, 0); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_EATTR_OFFS, 0); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_LOCALHDR_OFFS, + z->offset - dataStartOffset); +} + +static void +SerializeCentralDirectorySuffix( + const unsigned char *start, /* The start of writable memory. */ + const unsigned char *end, /* The end of writable memory. */ + unsigned char *buf, /* Where to serialize to */ + int entryCount, /* The number of entries in the directory */ + long long dataStartOffset, /* The overall file offset of the start of the + * data section of the file. */ + long long directoryStartOffset, + /* The overall file offset of the start of the + * central directory. */ + long long suffixStartOffset)/* The overall file offset of the start of the + * suffix of the central directory (i.e., + * where this data will be written). */ +{ + ZipWriteInt(start, end, buf + ZIP_CENTRAL_END_SIG_OFFS, + ZIP_CENTRAL_END_SIG); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKNO_OFFS, 0); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_ENTS_OFFS, entryCount); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_TOTALENTS_OFFS, entryCount); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_DIRSIZE_OFFS, + suffixStartOffset - directoryStartOffset); + ZipWriteInt(start, end, buf + ZIP_CENTRAL_DIRSTART_OFFS, + directoryStartOffset - dataStartOffset); + ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); +} + +/* *------------------------------------------------------------------------- * * ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd -- * * These procedures are invoked to process the [zipfs mkzip] and [zipfs - * lmkzip] commands. See description of ZipFSMkZipOrImgCmd(). + * lmkzip] commands. See description of ZipFSMkZipOrImg(). * * Results: * A standard Tcl result. * * Side effects: - * See description of ZipFSMkZipOrImgCmd(). + * See description of ZipFSMkZipOrImg(). * *------------------------------------------------------------------------- */ @@ -2747,17 +3465,22 @@ ZipFSMkZipObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Obj *stripPrefix, *password; + if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "operation not permitted in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter"); + ZIPFS_ERROR_CODE(interp, "SAFE_INTERP"); return TCL_ERROR; } - return ZipFSMkZipOrImgObjCmd(interp, 0, 0, objc, objv); + + stripPrefix = (objc > 3 ? objv[3] : NULL); + password = (objc > 4 ? objv[4] : NULL); + return ZipFSMkZipOrImg(interp, 0, objv[1], objv[2], NULL, NULL, + stripPrefix, password); } static int @@ -2767,17 +3490,21 @@ ZipFSLMkZipObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Obj *password; + if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "operation not permitted in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter"); + ZIPFS_ERROR_CODE(interp, "SAFE_INTERP"); return TCL_ERROR; } - return ZipFSMkZipOrImgObjCmd(interp, 0, 1, objc, objv); + + password = (objc > 3 ? objv[3] : NULL); + return ZipFSMkZipOrImg(interp, 0, objv[1], NULL, objv[2], NULL, + NULL, password); } /* @@ -2786,13 +3513,13 @@ ZipFSLMkZipObjCmd( * ZipFSMkImgObjCmd, ZipFSLMkImgObjCmd -- * * These procedures are invoked to process the [zipfs mkimg] and [zipfs - * lmkimg] commands. See description of ZipFSMkZipOrImgCmd(). + * lmkimg] commands. See description of ZipFSMkZipOrImg(). * * Results: * A standard Tcl result. * * Side effects: - * See description of ZipFSMkZipOrImgCmd(). + * See description of ZipFSMkZipOrImg(). * *------------------------------------------------------------------------- */ @@ -2804,18 +3531,24 @@ ZipFSMkImgObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Obj *originFile, *stripPrefix, *password; + if (objc < 3 || objc > 6) { Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password? ?infile?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "operation not permitted in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter"); + ZIPFS_ERROR_CODE(interp, "SAFE_INTERP"); return TCL_ERROR; } - return ZipFSMkZipOrImgObjCmd(interp, 1, 0, objc, objv); + + originFile = (objc > 5 ? objv[5] : NULL); + stripPrefix = (objc > 3 ? objv[3] : NULL); + password = (objc > 4 ? objv[4] : NULL); + return ZipFSMkZipOrImg(interp, 1, objv[1], objv[2], NULL, + originFile, stripPrefix, password); } static int @@ -2825,17 +3558,22 @@ ZipFSLMkImgObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Obj *originFile, *password; + if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password infile?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "operation not permitted in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter"); + ZIPFS_ERROR_CODE(interp, "SAFE_INTERP"); return TCL_ERROR; } - return ZipFSMkZipOrImgObjCmd(interp, 1, 1, objc, objv); + + originFile = (objc > 4 ? objv[4] : NULL); + password = (objc > 3 ? objv[3] : NULL); + return ZipFSMkZipOrImg(interp, 1, objv[1], NULL, objv[2], + originFile, NULL, password); } /* @@ -2950,7 +3688,7 @@ ZipFSExistsObjCmd( * * ZipFSInfoObjCmd -- * - * This procedure is invoked to process the [zipfs info] command. On + * This procedure is invoked to process the [zipfs info] command. On * success, it returns a Tcl list made up of name of ZIP archive file, * size uncompressed, size compressed, and archive offset of a file in * the ZIP filesystem. @@ -3026,36 +3764,48 @@ ZipFSListObjCmd( Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *result = Tcl_GetObjResult(interp); + const char *options[] = {"-glob", "-regexp", NULL}; + enum list_options { OPT_GLOB, OPT_REGEXP }; + + /* + * Parse arguments. + */ if (objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?"); return TCL_ERROR; } if (objc == 3) { - int n; - char *what = Tcl_GetStringFromObj(objv[1], &n); + int idx; - if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", + 0, &idx) != TCL_OK) { + return TCL_ERROR; + } + switch (idx) { + case OPT_GLOB: pattern = Tcl_GetString(objv[2]); - } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { + break; + case OPT_REGEXP: regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2])); if (!regexp) { return TCL_ERROR; } - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown option \"%s\"", what)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_OPT", NULL); - return TCL_ERROR; + break; } } else if (objc == 2) { pattern = Tcl_GetString(objv[1]); } + + /* + * Scan for matching entries. + */ + ReadLock(); if (pattern) { for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr); + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); if (Tcl_StringMatch(z->name, pattern)) { Tcl_ListObjAppendElement(interp, result, @@ -3065,7 +3815,7 @@ ZipFSListObjCmd( } else if (regexp) { for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr); + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) { Tcl_ListObjAppendElement(interp, result, @@ -3075,7 +3825,7 @@ ZipFSListObjCmd( } else { for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr); + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(z->name, -1)); @@ -3104,16 +3854,13 @@ ZipFSListObjCmd( *------------------------------------------------------------------------- */ -#ifdef _WIN32 -#define LIBRARY_SIZE 64 -#endif /* _WIN32 */ - Tcl_Obj * TclZipfs_TclLibrary(void) { Tcl_Obj *vfsInitScript; int found; -#ifdef _WIN32 +#if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(STATIC_BUILD) +# define LIBRARY_SIZE 64 HMODULE hModule; WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char dllName[(MAX_PATH + LIBRARY_SIZE) * 3]; @@ -3148,27 +3895,22 @@ TclZipfs_TclLibrary(void) */ #if !defined(STATIC_BUILD) -#if defined(_WIN32) - hModule = TclWinGetTclInstance(); +#if defined(_WIN32) || defined(__CYGWIN__) + hModule = (HMODULE)TclWinGetTclInstance(); GetModuleFileNameW(hModule, wName, MAX_PATH); +#ifdef __CYGWIN__ + cygwin_conv_path(3, wName, dllName, sizeof(dllName)); +#else WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL, NULL); +#endif if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) { return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); } #else -# if defined(CFG_RUNTIME_LIBDIR) - if (ZipfsAppHookFindTclInit( - CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) { + if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) { return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); } -# endif -# if defined(CFG_RUNTIME_BINDIR) - if (ZipfsAppHookFindTclInit( - CFG_RUNTIME_BINDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } -# endif #endif /* _WIN32 */ #endif /* !defined(STATIC_BUILD) */ @@ -3243,7 +3985,7 @@ ZipChannelClose( TCL_UNUSED(Tcl_Interp *), int flags) { - ZipChannel *info = (ZipChannel *)instanceData; + ZipChannel *info = (ZipChannel *) instanceData; if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) { return EINVAL; @@ -3259,7 +4001,8 @@ ZipChannelClose( } if (info->isWriting) { ZipEntry *z = info->zipEntryPtr; - unsigned char *newdata = (unsigned char *)attemptckrealloc(info->ubuf, info->numRead); + unsigned char *newdata = (unsigned char *) + attemptckrealloc(info->ubuf, info->numRead); if (newdata) { if (z->data) { @@ -3475,7 +4218,7 @@ ZipChannelWideSeek( return info->numRead; } -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) static int ZipChannelSeek( void *instanceData, @@ -3544,7 +4287,7 @@ ZipChannelGetFile( * ZipChannelOpen -- * * This function opens a Tcl_Channel on a file from a mounted ZIP archive - * according to given open mode. + * according to given open mode (already parsed by caller). * * Results: * Tcl_Channel on success, or NULL on error. @@ -3558,24 +4301,19 @@ ZipChannelGetFile( static Tcl_Channel ZipChannelOpen( Tcl_Interp *interp, /* Current interpreter. */ - char *filename, - int mode, - TCL_UNUSED(int) /*permissions*/) + char *filename, /* What are we opening. */ + int wr, /* True if we're opening in write mode. */ + int trunc) /* True if we're opening in truncate mode. */ { ZipEntry *z; ZipChannel *info; - int i, ch, trunc, wr, flags = 0; + int flags = 0; char cname[128]; - if ((mode & O_APPEND) - || ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("unsupported open mode", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_MODE", NULL); - } - return NULL; - } + /* + * Is the file there? + */ + WriteLock(); z = ZipFSLookup(filename); if (!z) { @@ -3587,188 +4325,161 @@ ZipChannelOpen( } goto error; } - trunc = (mode & O_TRUNC) != 0; - wr = (mode & (O_WRONLY | O_RDWR)) != 0; - if ((z->compressMethod != ZIP_COMPMETH_STORED) - && (z->compressMethod != ZIP_COMPMETH_DEFLATED)) { - ZIPFS_ERROR(interp, "unsupported compression method"); + + /* + * Do we support opening the file that way? + */ + + if (wr && z->isDirectory) { + Tcl_SetErrno(EISDIR); if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "COMP_METHOD", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unsupported file type: %s", + Tcl_PosixError(interp))); } goto error; } - if (wr && z->isDirectory) { - ZIPFS_ERROR(interp, "unsupported file type"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_TYPE", NULL); - } + if ((z->compressMethod != ZIP_COMPMETH_STORED) + && (z->compressMethod != ZIP_COMPMETH_DEFLATED)) { + ZIPFS_ERROR(interp, "unsupported compression method"); + ZIPFS_ERROR_CODE(interp, "COMP_METHOD"); goto error; } if (!trunc) { flags |= TCL_READABLE; if (z->isEncrypted && (z->zipFilePtr->passBuf[0] == 0)) { ZIPFS_ERROR(interp, "decryption failed"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DECRYPT", NULL); - } + ZIPFS_ERROR_CODE(interp, "DECRYPT"); goto error; } else if (wr && !z->data && (z->numBytes > ZipFS.wrmax)) { ZIPFS_ERROR(interp, "file too large"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL); - } + ZIPFS_ERROR_CODE(interp, "FILE_SIZE"); goto error; } } else { flags = TCL_WRITABLE; } - info = (ZipChannel *)attemptckalloc(sizeof(ZipChannel)); + + info = AllocateZipChannel(interp); if (!info) { - ZIPFS_ERROR(interp, "out of memory"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } goto error; } info->zipFilePtr = z->zipFilePtr; info->zipEntryPtr = z; - info->numRead = 0; if (wr) { + /* + * Set up a writable channel. + */ + flags |= TCL_WRITABLE; - info->isWriting = 1; - info->isDirectory = 0; - info->maxWrite = ZipFS.wrmax; - info->iscompr = 0; - info->isEncrypted = 0; - info->ubuf = (unsigned char *)attemptckalloc(info->maxWrite); - if (!info->ubuf) { - merror0: - if (info->ubuf) { - ckfree(info->ubuf); - } + if (InitWritableChannel(interp, info, z, trunc) == TCL_ERROR) { ckfree(info); - ZIPFS_ERROR(interp, "out of memory"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } goto error; } - memset(info->ubuf, 0, info->maxWrite); - if (trunc) { - info->numBytes = 0; - } else if (z->data) { - unsigned int j = z->numBytes; - - if (j > info->maxWrite) { - j = info->maxWrite; - } - memcpy(info->ubuf, z->data, j); - info->numBytes = j; - } else { - unsigned char *zbuf = z->zipFilePtr->data + z->offset; - - if (z->isEncrypted) { - int len = z->zipFilePtr->passBuf[0] & 0xFF; - char passBuf[260]; - - for (i = 0; i < len; i++) { - ch = z->zipFilePtr->passBuf[len - i]; - passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - } - passBuf[i] = '\0'; - init_keys(passBuf, info->keys, crc32tab); - memset(passBuf, 0, sizeof(passBuf)); - for (i = 0; i < 12; i++) { - ch = info->ubuf[i]; - zdecode(info->keys, crc32tab, ch); - } - zbuf += i; - } - if (z->compressMethod == ZIP_COMPMETH_DEFLATED) { - z_stream stream; - int err; - unsigned char *cbuf = NULL; - - memset(&stream, 0, sizeof(z_stream)); - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - stream.avail_in = z->numCompressedBytes; - if (z->isEncrypted) { - unsigned int j; - - stream.avail_in -= 12; - cbuf = (unsigned char *)attemptckalloc(stream.avail_in); - if (!cbuf) { - goto merror0; - } - for (j = 0; j < stream.avail_in; j++) { - ch = info->ubuf[j]; - cbuf[j] = zdecode(info->keys, crc32tab, ch); - } - stream.next_in = cbuf; - } else { - stream.next_in = zbuf; - } - stream.next_out = info->ubuf; - stream.avail_out = info->maxWrite; - if (inflateInit2(&stream, -15) != Z_OK) { - goto cerror0; - } - err = inflate(&stream, Z_SYNC_FLUSH); - inflateEnd(&stream); - if ((err == Z_STREAM_END) - || ((err == Z_OK) && (stream.avail_in == 0))) { - if (cbuf) { - memset(info->keys, 0, sizeof(info->keys)); - ckfree(cbuf); - } - goto wrapchan; - } - cerror0: - if (cbuf) { - memset(info->keys, 0, sizeof(info->keys)); - ckfree(cbuf); - } - if (info->ubuf) { - ckfree(info->ubuf); - } - ckfree(info); - ZIPFS_ERROR(interp, "decompression error"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL); - } - goto error; - } else if (z->isEncrypted) { - for (i = 0; i < z->numBytes - 12; i++) { - ch = zbuf[i]; - info->ubuf[i] = zdecode(info->keys, crc32tab, ch); - } - } else { - memcpy(info->ubuf, zbuf, z->numBytes); - } - memset(info->keys, 0, sizeof(info->keys)); - goto wrapchan; - } } else if (z->data) { + /* + * Set up a readable channel for direct data. + */ + flags |= TCL_READABLE; - info->isWriting = 0; - info->iscompr = 0; - info->isDirectory = 0; - info->isEncrypted = 0; info->numBytes = z->numBytes; - info->maxWrite = 0; info->ubuf = z->data; } else { + /* + * Set up a readable channel. + */ + flags |= TCL_READABLE; - info->isWriting = 0; - info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED); - info->ubuf = z->zipFilePtr->data + z->offset; - info->isDirectory = z->isDirectory; - info->isEncrypted = z->isEncrypted; - info->numBytes = z->numBytes; - info->maxWrite = 0; - if (info->isEncrypted) { + if (InitReadableChannel(interp, info, z) == TCL_ERROR) { + ckfree(info); + goto error; + } + } + + /* + * Wrap the ZipChannel into a Tcl_Channel. + */ + + sprintf(cname, "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset, + ZipFS.idCount++); + z->zipFilePtr->numOpen++; + Unlock(); + return Tcl_CreateChannel(&ZipChannelType, cname, info, flags); + + error: + Unlock(); + return NULL; +} + +/* + *------------------------------------------------------------------------- + * + * InitWritableChannel -- + * + * Assistant for ZipChannelOpen() that sets up a writable channel. It's + * up to the caller to actually register the channel. + * + * Returns: + * Tcl result code. + * + * Side effects: + * Allocates memory for the implementation of the channel. Writes to the + * interpreter's result on error. + * + *------------------------------------------------------------------------- + */ + +static int +InitWritableChannel( + Tcl_Interp *interp, /* Current interpreter, or NULL (when errors + * will be silent). */ + ZipChannel *info, /* The channel to set up. */ + ZipEntry *z, /* The zipped file that the channel will write + * to. */ + int trunc) /* Whether to truncate the data. */ +{ + int i, ch; + unsigned char *cbuf = NULL; + + /* + * Set up a writable channel. + */ + + info->isWriting = 1; + info->maxWrite = ZipFS.wrmax; + + info->ubuf = (unsigned char *) attemptckalloc(info->maxWrite); + if (!info->ubuf) { + goto memoryError; + } + memset(info->ubuf, 0, info->maxWrite); + + if (trunc) { + /* + * Truncate; nothing there. + */ + + info->numBytes = 0; + } else if (z->data) { + /* + * Already got uncompressed data. + */ + + unsigned int j = z->numBytes; + + if (j > info->maxWrite) { + j = info->maxWrite; + } + memcpy(info->ubuf, z->data, j); + info->numBytes = j; + } else { + /* + * Need to uncompress the existing data. + */ + + unsigned char *zbuf = z->zipFilePtr->data + z->offset; + + if (z->isEncrypted) { int len = z->zipFilePtr->passBuf[0] & 0xFF; char passBuf[260]; @@ -3783,118 +4494,244 @@ ZipChannelOpen( ch = info->ubuf[i]; zdecode(info->keys, crc32tab, ch); } - info->ubuf += i; + zbuf += i; } - if (info->iscompr) { + + if (z->compressMethod == ZIP_COMPMETH_DEFLATED) { z_stream stream; int err; - unsigned char *ubuf = NULL; - unsigned int j; memset(&stream, 0, sizeof(z_stream)); stream.zalloc = Z_NULL; stream.zfree = Z_NULL; stream.opaque = Z_NULL; stream.avail_in = z->numCompressedBytes; - if (info->isEncrypted) { + if (z->isEncrypted) { + unsigned int j; + stream.avail_in -= 12; - ubuf = (unsigned char *)attemptckalloc(stream.avail_in); - if (!ubuf) { - info->ubuf = NULL; - goto merror; + cbuf = (unsigned char *) attemptckalloc(stream.avail_in); + if (!cbuf) { + goto memoryError; } for (j = 0; j < stream.avail_in; j++) { ch = info->ubuf[j]; - ubuf[j] = zdecode(info->keys, crc32tab, ch); + cbuf[j] = zdecode(info->keys, crc32tab, ch); } - stream.next_in = ubuf; + stream.next_in = cbuf; } else { - stream.next_in = info->ubuf; - } - stream.next_out = info->ubuf = (unsigned char *)attemptckalloc(info->numBytes); - if (!info->ubuf) { - merror: - if (ubuf) { - info->isEncrypted = 0; - memset(info->keys, 0, sizeof(info->keys)); - ckfree(ubuf); - } - ckfree(info); - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } - goto error; + stream.next_in = zbuf; } - stream.avail_out = info->numBytes; + stream.next_out = info->ubuf; + stream.avail_out = info->maxWrite; if (inflateInit2(&stream, -15) != Z_OK) { - goto cerror; + goto corruptionError; } err = inflate(&stream, Z_SYNC_FLUSH); inflateEnd(&stream); if ((err == Z_STREAM_END) || ((err == Z_OK) && (stream.avail_in == 0))) { - if (ubuf) { - info->isEncrypted = 0; + if (cbuf) { memset(info->keys, 0, sizeof(info->keys)); - ckfree(ubuf); + ckfree(cbuf); } - goto wrapchan; - } - cerror: - if (ubuf) { - info->isEncrypted = 0; - memset(info->keys, 0, sizeof(info->keys)); - ckfree(ubuf); - } - if (info->ubuf) { - ckfree(info->ubuf); - } - ckfree(info); - ZIPFS_ERROR(interp, "decompression error"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL); + return TCL_OK; } - goto error; - } else if (info->isEncrypted) { - unsigned char *ubuf = NULL; - unsigned int j, len; + goto corruptionError; + } else if (z->isEncrypted) { + /* + * Need to decrypt some otherwise-simple stored data. + */ + for (i = 0; i < z->numBytes - 12; i++) { + ch = zbuf[i]; + info->ubuf[i] = zdecode(info->keys, crc32tab, ch); + } + } else { /* - * Decode encrypted but uncompressed file, since we support - * Tcl_Seek() on it, and it can be randomly accessed later. + * Simple stored data. Copy into our working buffer. */ - len = z->numCompressedBytes - 12; - ubuf = (unsigned char *) attemptckalloc(len); - if (ubuf == NULL) { - ckfree((char *) info); - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - } - goto error; + memcpy(info->ubuf, zbuf, z->numBytes); + } + memset(info->keys, 0, sizeof(info->keys)); + } + return TCL_OK; + + memoryError: + if (info->ubuf) { + ckfree(info->ubuf); + } + ZIPFS_MEM_ERROR(interp); + return TCL_ERROR; + + corruptionError: + if (cbuf) { + memset(info->keys, 0, sizeof(info->keys)); + ckfree(cbuf); + } + if (info->ubuf) { + ckfree(info->ubuf); + } + ZIPFS_ERROR(interp, "decompression error"); + ZIPFS_ERROR_CODE(interp, "CORRUPT"); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * InitReadableChannel -- + * + * Assistant for ZipChannelOpen() that sets up a readable channel. It's + * up to the caller to actually register the channel. + * + * Returns: + * Tcl result code. + * + * Side effects: + * Allocates memory for the implementation of the channel. Writes to the + * interpreter's result on error. + * + *------------------------------------------------------------------------- + */ + +static int +InitReadableChannel( + Tcl_Interp *interp, /* Current interpreter, or NULL (when errors + * will be silent). */ + ZipChannel *info, /* The channel to set up. */ + ZipEntry *z) /* The zipped file that the channel will read + * from. */ +{ + unsigned char *ubuf = NULL; + int i, ch; + + info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED); + info->ubuf = z->zipFilePtr->data + z->offset; + info->isDirectory = z->isDirectory; + info->isEncrypted = z->isEncrypted; + info->numBytes = z->numBytes; + + if (info->isEncrypted) { + int len = z->zipFilePtr->passBuf[0] & 0xFF; + char passBuf[260]; + + for (i = 0; i < len; i++) { + ch = z->zipFilePtr->passBuf[len - i]; + passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + } + passBuf[i] = '\0'; + init_keys(passBuf, info->keys, crc32tab); + memset(passBuf, 0, sizeof(passBuf)); + for (i = 0; i < 12; i++) { + ch = info->ubuf[i]; + zdecode(info->keys, crc32tab, ch); + } + info->ubuf += i; + } + + if (info->iscompr) { + z_stream stream; + int err; + unsigned int j; + + /* + * Data to decode is compressed, and possibly encrpyted too. + */ + + memset(&stream, 0, sizeof(z_stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = z->numCompressedBytes; + if (info->isEncrypted) { + stream.avail_in -= 12; + ubuf = (unsigned char *) attemptckalloc(stream.avail_in); + if (!ubuf) { + info->ubuf = NULL; + goto memoryError; } - for (j = 0; j < len; j++) { + + for (j = 0; j < stream.avail_in; j++) { ch = info->ubuf[j]; ubuf[j] = zdecode(info->keys, crc32tab, ch); } - info->ubuf = ubuf; + stream.next_in = ubuf; + } else { + stream.next_in = info->ubuf; + } + stream.next_out = info->ubuf = (unsigned char *) + attemptckalloc(info->numBytes); + if (!info->ubuf) { + goto memoryError; + } + stream.avail_out = info->numBytes; + if (inflateInit2(&stream, -15) != Z_OK) { + goto corruptionError; + } + err = inflate(&stream, Z_SYNC_FLUSH); + inflateEnd(&stream); + + /* + * Decompression was successful if we're either in the END state, or + * in the OK state with no buffered bytes. + */ + + if ((err != Z_STREAM_END) + && ((err != Z_OK) || (stream.avail_in != 0))) { + goto corruptionError; + } + + if (ubuf) { info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + ckfree(ubuf); + } + return TCL_OK; + } else if (info->isEncrypted) { + unsigned int j, len; + + /* + * Decode encrypted but uncompressed file, since we support Tcl_Seek() + * on it, and it can be randomly accessed later. + */ + + len = z->numCompressedBytes - 12; + ubuf = (unsigned char *) attemptckalloc(len); + if (ubuf == NULL) { + goto memoryError; + } + for (j = 0; j < len; j++) { + ch = info->ubuf[j]; + ubuf[j] = zdecode(info->keys, crc32tab, ch); } + info->ubuf = ubuf; + info->isEncrypted = 0; } + return TCL_OK; - wrapchan: - sprintf(cname, "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset, - ZipFS.idCount++); - z->zipFilePtr->numOpen++; - Unlock(); - return Tcl_CreateChannel(&ZipChannelType, cname, info, flags); + corruptionError: + if (ubuf) { + info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + ckfree(ubuf); + } + if (info->ubuf) { + ckfree(info->ubuf); + } + ZIPFS_ERROR(interp, "decompression error"); + ZIPFS_ERROR_CODE(interp, "CORRUPT"); + return TCL_ERROR; - error: - Unlock(); - return NULL; + memoryError: + if (ubuf) { + info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + ckfree(ubuf); + } + ZIPFS_MEM_ERROR(interp); + return TCL_ERROR; } /* @@ -3979,9 +4816,14 @@ ZipEntryAccess( * * ZipFSOpenFileChannelProc -- * + * Open a channel to a file in a mounted ZIP archive. Delegates to + * ZipChannelOpen(). + * * Results: + * Tcl_Channel on success, or NULL on error. * * Side effects: + * Allocates memory. * *------------------------------------------------------------------------- */ @@ -3991,16 +4833,31 @@ ZipFSOpenFileChannelProc( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *pathPtr, int mode, - int permissions) + TCL_UNUSED(int) /* permissions */) { - int len; + int trunc = (mode & O_TRUNC) != 0; + int wr = (mode & (O_WRONLY | O_RDWR)) != 0; pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return NULL; } - return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), mode, - permissions); + + /* + * Check for unsupported modes. + */ + + if ((mode & O_APPEND) || ((ZipFS.wrmax <= 0) && wr)) { + Tcl_SetErrno(EACCES); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write access not supported: %s", + Tcl_PosixError(interp))); + } + return NULL; + } + + return ZipChannelOpen(interp, Tcl_GetString(pathPtr), wr, trunc); } /* @@ -4025,13 +4882,11 @@ ZipFSStatProc( Tcl_Obj *pathPtr, Tcl_StatBuf *buf) { - int len; - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return -1; } - return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf); + return ZipEntryStat(Tcl_GetString(pathPtr), buf); } /* @@ -4056,13 +4911,11 @@ ZipFSAccessProc( Tcl_Obj *pathPtr, int mode) { - int len; - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return -1; } - return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode); + return ZipEntryAccess(Tcl_GetString(pathPtr), mode); } /* @@ -4094,6 +4947,38 @@ ZipFSFilesystemSeparatorProc( /* *------------------------------------------------------------------------- * + * AppendWithPrefix -- + * + * Worker for ZipFSMatchInDirectoryProc() that is a wrapper around + * Tcl_ListObjAppendElement() which knows about handling prefixes. + * + *------------------------------------------------------------------------- + */ + +static inline void +AppendWithPrefix( + Tcl_Obj *result, /* Where to append a list element to. */ + Tcl_DString *prefix, /* The prefix to add to the element, or NULL + * for don't do that. */ + const char *name, /* The name to append. */ + int nameLen) /* The length of the name. May be -1 for + * append-up-to-NUL-byte. */ +{ + if (prefix) { + int prefixLength = Tcl_DStringLength(prefix); + + Tcl_DStringAppend(prefix, name, nameLen); + Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj( + Tcl_DStringValue(prefix), Tcl_DStringLength(prefix))); + Tcl_DStringSetLength(prefix, prefixLength); + } else { + Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(name, nameLen)); + } +} + +/* + *------------------------------------------------------------------------- + * * ZipFSMatchInDirectoryProc -- * * This routine is used by the globbing code to search a directory for @@ -4113,24 +4998,24 @@ ZipFSFilesystemSeparatorProc( static int ZipFSMatchInDirectoryProc( TCL_UNUSED(Tcl_Interp *), - Tcl_Obj *result, - Tcl_Obj *pathPtr, - const char *pattern, - Tcl_GlobTypeData *types) + Tcl_Obj *result, /* Where to append matched items to. */ + Tcl_Obj *pathPtr, /* Where we are looking. */ + const char *pattern, /* What names we are looking for. */ + Tcl_GlobTypeData *types) /* What types we are looking for. */ { Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - int scnt, l, dirOnly = -1, prefixLen, strip = 0; - size_t len; + int scnt, l, dirOnly = -1, prefixLen, strip = 0, mounts = 0, len; char *pat, *prefix, *path; - Tcl_DString dsPref; + Tcl_DString dsPref, *prefixBuf = NULL; if (!normPathPtr) { return -1; } if (types) { dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR; + mounts = (types->type == TCL_GLOB_TYPE_MOUNT); } /* @@ -4143,107 +5028,58 @@ ZipFSMatchInDirectoryProc( * The (normalized) path we're searching. */ - path = Tcl_GetString(normPathPtr); - len = normPathPtr->length; + path = Tcl_GetStringFromObj(normPathPtr, &len); Tcl_DStringInit(&dsPref); - Tcl_DStringAppend(&dsPref, prefix, prefixLen); - if (strcmp(prefix, path) == 0) { - prefix = NULL; + prefixBuf = NULL; } else { + /* + * We need to strip the normalized prefix of the filenames and replace + * it with the official prefix that we were expecting to get. + */ + strip = len + 1; - } - if (prefix) { + Tcl_DStringAppend(&dsPref, prefix, prefixLen); Tcl_DStringAppend(&dsPref, "/", 1); - prefixLen++; prefix = Tcl_DStringValue(&dsPref); + prefixBuf = &dsPref; } + ReadLock(); - if (types && (types->type == TCL_GLOB_TYPE_MOUNT)) { - l = CountSlashes(path); - if (path[len - 1] == '/') { - len--; - } else { - l++; - } - if (!pattern || (pattern[0] == '\0')) { - pattern = "*"; - } - for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - ZipFile *zf = (ZipFile *)Tcl_GetHashValue(hPtr); - - if (zf->mountPointLen == 0) { - ZipEntry *z; - - for (z = zf->topEnts; z; z = z->tnext) { - size_t lenz = strlen(z->name); - - if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0) - && (z->name[len] == '/') - && (CountSlashes(z->name) == l) - && Tcl_StringCaseMatch(z->name + len + 1, pattern, - 0)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, z->name, lenz); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name, lenz)); - } - } - } - } else if ((zf->mountPointLen > len + 1) - && (strncmp(zf->mountPoint, path, len) == 0) - && (zf->mountPoint[len] == '/') - && (CountSlashes(zf->mountPoint) == l) - && Tcl_StringCaseMatch(zf->mountPoint + len + 1, - pattern, 0)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, zf->mountPoint, - zf->mountPointLen); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(zf->mountPoint, - zf->mountPointLen)); - } - } - } + + /* + * Are we globbing the mount points? + */ + + if (mounts) { + ZipFSMatchMountPoints(result, normPathPtr, pattern, prefixBuf); goto end; } + /* + * Can we skip the complexity of actual globbing? Without a pattern, yes; + * it's a directory existence test. + */ + if (!pattern || (pattern[0] == '\0')) { - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); - if (hPtr) { - ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr); - - if ((dirOnly < 0) || (!dirOnly && !z->isDirectory) - || (dirOnly && z->isDirectory)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, z->name, -1); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name, -1)); - } - } + ZipEntry *z = ZipFSLookup(path); + + if (z && ((dirOnly < 0) || (!dirOnly && !z->isDirectory) + || (dirOnly && z->isDirectory))) { + AppendWithPrefix(result, prefixBuf, z->name, -1); } goto end; } + /* + * We've got to work for our supper and do the actual globbing. And all + * we've got really is an undifferentiated pile of all the filenames we've + * got from all our ZIP mounts. + */ + l = strlen(pattern); - pat = (char *)ckalloc(len + l + 2); + pat = (char *) ckalloc(len + l + 2); memcpy(pat, path, len); while ((len > 1) && (pat[len - 1] == '/')) { --len; @@ -4254,25 +5090,17 @@ ZipFSMatchInDirectoryProc( } memcpy(pat + len, pattern, l + 1); scnt = CountSlashes(pat); + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr); + ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr); if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory) || (!dirOnly && z->isDirectory))) { continue; } if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, z->name + strip, -1); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(z->name + strip, -1)); - } + AppendWithPrefix(result, prefixBuf, z->name + strip, -1); } } ckfree(pat); @@ -4286,6 +5114,94 @@ ZipFSMatchInDirectoryProc( /* *------------------------------------------------------------------------- * + * ZipFSMatchMountPoints -- + * + * This routine is a worker for ZipFSMatchInDirectoryProc, used by the + * globbing code to search for all mount points files which match a given + * pattern. + * + * Results: + * None. + * + * Side effects: + * Adds the matching mounts to the list in result, uses prefix as working + * space if it is non-NULL. + * + *------------------------------------------------------------------------- + */ + +static void +ZipFSMatchMountPoints( + Tcl_Obj *result, /* The list of matches being built. */ + Tcl_Obj *normPathPtr, /* Where we're looking from. */ + const char *pattern, /* What we're looking for. NULL for a full + * list. */ + Tcl_DString *prefix) /* Workspace filled with a prefix for all the + * filenames, or NULL if no prefix is to be + * used. */ +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + int l, normLength; + const char *path = Tcl_GetStringFromObj(normPathPtr, &normLength); + size_t len = (size_t) normLength; + + if (len < 1) { + /* + * Shouldn't happen. But "shouldn't"... + */ + + return; + } + l = CountSlashes(path); + if (path[len - 1] == '/') { + len--; + } else { + l++; + } + if (!pattern || (pattern[0] == '\0')) { + pattern = "*"; + } + + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); + + if (zf->mountPointLen == 0) { + ZipEntry *z; + + /* + * Enumerate the contents of the ZIP; it's mounted on the root. + */ + + for (z = zf->topEnts; z; z = z->tnext) { + size_t lenz = strlen(z->name); + + if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0) + && (z->name[len] == '/') + && (CountSlashes(z->name) == l) + && Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)) { + AppendWithPrefix(result, prefix, z->name, lenz); + } + } + } else if ((zf->mountPointLen > len + 1) + && (strncmp(zf->mountPoint, path, len) == 0) + && (zf->mountPoint[len] == '/') + && (CountSlashes(zf->mountPoint) == l) + && Tcl_StringCaseMatch(zf->mountPoint + len + 1, + pattern, 0)) { + /* + * Standard mount; append if it matches. + */ + + AppendWithPrefix(result, prefix, zf->mountPoint, zf->mountPointLen); + } + } +} + +/* + *------------------------------------------------------------------------- + * * ZipFSPathInFilesystemProc -- * * This function determines if the given path object is in the ZIP @@ -4307,22 +5223,18 @@ ZipFSPathInFilesystemProc( { Tcl_HashEntry *hPtr; Tcl_HashSearch search; - int ret = -1; - size_t len; + int ret = -1, len; char *path; pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return -1; } - - path = Tcl_GetString(pathPtr); + path = Tcl_GetStringFromObj(pathPtr, &len); if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) { return -1; } - len = pathPtr->length; - ReadLock(); hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); if (hPtr) { @@ -4332,7 +5244,7 @@ ZipFSPathInFilesystemProc( for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { - ZipFile *zf = (ZipFile *)Tcl_GetHashValue(hPtr); + ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); if (zf->mountPointLen == 0) { ZipEntry *z; @@ -4340,12 +5252,13 @@ ZipFSPathInFilesystemProc( for (z = zf->topEnts; z != NULL; z = z->tnext) { size_t lenz = strlen(z->name); - if ((len >= lenz) && (strncmp(path, z->name, lenz) == 0)) { + if (((size_t) len >= lenz) && + (strncmp(path, z->name, lenz) == 0)) { ret = TCL_OK; goto endloop; } } - } else if ((len >= zf->mountPointLen) && + } else if (((size_t) len >= zf->mountPointLen) && (strncmp(path, zf->mountPoint, zf->mountPointLen) == 0)) { ret = TCL_OK; break; @@ -4397,11 +5310,25 @@ ZipFSListVolumesProc(void) *------------------------------------------------------------------------- */ +enum ZipFileAttrs { + ZIP_ATTR_UNCOMPSIZE, + ZIP_ATTR_COMPSIZE, + ZIP_ATTR_OFFSET, + ZIP_ATTR_MOUNT, + ZIP_ATTR_ARCHIVE, + ZIP_ATTR_PERMISSIONS, + ZIP_ATTR_CRC +}; + static const char *const * ZipFSFileAttrStringsProc( TCL_UNUSED(Tcl_Obj *) /*pathPtr*/, TCL_UNUSED(Tcl_Obj **) /*objPtrRef*/) { + /* + * Must match up with ZipFileAttrs enum above. + */ + static const char *const attrs[] = { "-uncompsize", "-compsize", @@ -4409,6 +5336,7 @@ ZipFSFileAttrStringsProc( "-mount", "-archive", "-permissions", + "-crc", NULL, }; @@ -4460,27 +5388,31 @@ ZipFSFileAttrsGetProc( goto done; } switch (index) { - case 0: + case ZIP_ATTR_UNCOMPSIZE: TclNewIntObj(*objPtrRef, z->numBytes); break; - case 1: + case ZIP_ATTR_COMPSIZE: TclNewIntObj(*objPtrRef, z->numCompressedBytes); break; - case 2: + case ZIP_ATTR_OFFSET: TclNewIntObj(*objPtrRef, z->offset); break; - case 3: + case ZIP_ATTR_MOUNT: *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint, z->zipFilePtr->mountPointLen); break; - case 4: + case ZIP_ATTR_ARCHIVE: *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1); break; - case 5: + case ZIP_ATTR_PERMISSIONS: *objPtrRef = Tcl_NewStringObj("0o555", -1); break; + case ZIP_ATTR_CRC: + TclNewIntObj(*objPtrRef, z->crc32); + break; default: ZIPFS_ERROR(interp, "unknown attribute"); + ZIPFS_ERROR_CODE(interp, "FILE_ATTR"); ret = TCL_ERROR; } @@ -4513,10 +5445,8 @@ ZipFSFileAttrsSetProc( TCL_UNUSED(Tcl_Obj *) /*pathPtr*/, TCL_UNUSED(Tcl_Obj *) /*objPtr*/) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "UNSUPPORTED_OP", NULL); - } + ZIPFS_ERROR(interp, "unsupported operation"); + ZIPFS_ERROR_CODE(interp, "UNSUPPORTED_OP"); return TCL_ERROR; } @@ -4618,7 +5548,7 @@ ZipFSLoadFile( if (execName) { const char *p = strrchr(execName, '/'); - if (p > execName + 1) { + if (p && p > execName + 1) { --p; objs[0] = Tcl_NewStringObj(execName, p - execName); } @@ -4644,7 +5574,8 @@ ZipFSLoadFile( Tcl_DecrRefCount(objs[1]); } - loadFileProc = (Tcl_FSLoadFileProc2 *)(void *)tclNativeFilesystem.loadFileProc; + loadFileProc = (Tcl_FSLoadFileProc2 *) (void *) + tclNativeFilesystem.loadFileProc; if (loadFileProc) { ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); } else { @@ -4733,8 +5664,12 @@ TclZipfs_Init( Tcl_Obj *mapObj; Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); - Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax, - TCL_LINK_INT); + 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); @@ -4752,7 +5687,7 @@ TclZipfs_Init( return TCL_OK; #else /* !HAVE_ZLIB */ ZIPFS_ERROR(interp, "no zlib available"); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); + ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); return TCL_ERROR; #endif /* HAVE_ZLIB */ } @@ -4798,13 +5733,48 @@ ZipfsAppHookFindTclInit( static void ZipfsExitHandler( + TCL_UNUSED(ClientData) +) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + if (ZipFS.initialized != -1) { + hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + if (hPtr == NULL) { + ZipfsFinalize(); + } else { + /* ZipFS.fallbackEntryEncoding was already freed by + * ZipfsMountExitHandler + */ + } + } +} + +static void +ZipfsFinalize(void) { + Tcl_DeleteHashTable(&ZipFS.fileHash); + ckfree(ZipFS.fallbackEntryEncoding); + ZipFS.initialized = -1; +} + +static void +ZipfsMountExitHandler( ClientData clientData) { - ZipFile *zf = (ZipFile *)clientData; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + ZipFile *zf = (ZipFile *) clientData; if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) { Tcl_Panic("tried to unmount busy filesystem"); } + + hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + if (hPtr == NULL) { + ZipfsFinalize(); + } + } /* @@ -4830,14 +5800,14 @@ TclZipfs_AppHook( char ***argvPtr) /* Pointer to argv */ #endif /* _WIN32 */ { - char *archive; + const char *archive; #ifdef _WIN32 Tcl_FindExecutable(NULL); #else Tcl_FindExecutable((*argvPtr)[0]); #endif - archive = (char *) Tcl_GetNameOfExecutable(); + archive = Tcl_GetNameOfExecutable(); TclZipfs_Init(NULL); /* @@ -4962,9 +5932,7 @@ TclZipfs_Mount( * the ZIP is unprotected. */ { ZIPFS_ERROR(interp, "no zlib available"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - } + ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); return TCL_ERROR; } @@ -4977,9 +5945,7 @@ TclZipfs_MountBuffer( int copy) { ZIPFS_ERROR(interp, "no zlib available"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - } + ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); return TCL_ERROR; } @@ -4989,9 +5955,7 @@ TclZipfs_Unmount( const char *mountPoint) /* Mount point path. */ { ZIPFS_ERROR(interp, "no zlib available"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - } + ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); return TCL_ERROR; } #endif /* !HAVE_ZLIB */ diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 9fc84da..440bb9a 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -3957,7 +3957,7 @@ TclZlibInit( * Formally provide the package as a Tcl built-in. */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); #endif return Tcl_PkgProvide(interp, "tcl::zlib", TCL_ZLIB_VERSION); diff --git a/library/clock.tcl b/library/clock.tcl index 150ae3c..136ded2 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -2988,8 +2988,7 @@ proc ::tcl::clock::GetSystemTimeZone {} { set timezone $result } elseif {[set result [getenv TZ]] ne {}} { set timezone $result - } - if {![info exists timezone]} { + } else { # Cache the time zone only if it was detected by one of the # expensive methods. if { [info exists CachedSystemTimeZone] } { diff --git a/library/cookiejar/cookiejar.tcl b/library/cookiejar/cookiejar.tcl index cfa73ae..85f73b4 100644 --- a/library/cookiejar/cookiejar.tcl +++ b/library/cookiejar/cookiejar.tcl @@ -57,9 +57,9 @@ namespace eval [info object namespace ::http::cookiejar] { variable version 0.2.0 variable domainlist \ - http://publicsuffix.org/list/effective_tld_names.dat + https://publicsuffix.org/list/public_suffix_list.dat variable domainfile \ - [file join [file dirname [info script]] effective_tld_names.txt.gz] + [file join [file dirname [info script]] public_suffix_list.dat.gz] # The list is directed to from http://publicsuffix.org/list/ variable loglevel info variable vacuumtrigger 200 diff --git a/library/cookiejar/effective_tld_names.txt.gz b/library/cookiejar/public_suffix_list.dat.gz Binary files differindex 13e08bb..65bf75a 100644 --- a/library/cookiejar/effective_tld_names.txt.gz +++ b/library/cookiejar/public_suffix_list.dat.gz diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index 5d1727d..18ac517 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,3 +1,12 @@ -if {![package vsatisfies [package provide Tcl] 8.5-]} return if {[info sharedlibextension] != ".dll"} return -package ifneeded dde 1.4.4 [list load [file join $dir tcldde14.dll] Dde] +if {[package vsatisfies [package provide Tcl] 9.0-]} { + package ifneeded dde 1.4.4 \ + [list load [file join $dir tcl9dde14.dll] Dde] +} elseif {![package vsatisfies [package provide Tcl] 8.7] + && [::tcl::pkgconfig get debug]} { + package ifneeded dde 1.4.4 \ + [list load [file join $dir tcldde14g.dll] Dde] +} else { + package ifneeded dde 1.4.4 \ + [list load [file join $dir tcldde14.dll] Dde] +} diff --git a/library/http/http.tcl b/library/http/http.tcl index df8fe2d..74f93df 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.10.0a1 +package provide http 2.10a1 namespace eval http { # Allow resourcing to not clobber existing data diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index f312aac..b8afd79 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.10.0a1 [list tclPkgSetup $dir http 2.10.0a1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.10a1 [list tclPkgSetup $dir http 2.10a1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/library/init.tcl b/library/init.tcl index c9bfff6..e30296e 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -214,9 +214,9 @@ proc unknown args { set errInfo [dict get $opts -errorinfo] set errCode [dict get $opts -errorcode] set cinfo $args - if {[string bytelength $cinfo] > 150} { + if {[string length [encoding convertto utf-8 $cinfo]] > 150} { set cinfo [string range $cinfo 0 150] - while {[string bytelength $cinfo] > 150} { + while {[string length [encoding convertto utf-8 $cinfo]] > 150} { set cinfo [string range $cinfo 0 end-1] } append cinfo ... diff --git a/library/manifest.txt b/library/manifest.txt index 08529da..afd44cf 100644 --- a/library/manifest.txt +++ b/library/manifest.txt @@ -5,7 +5,7 @@ apply {{dir} { set ::test [info script] set isafe [interp issafe] foreach {safe package version file} { - 0 http 2.10.0a1 {http http.tcl} + 0 http 2.10a1 {http http.tcl} 1 msgcat 1.7.1 {msgcat msgcat.tcl} 1 opt 0.4.8 {opt optparse.tcl} 0 cookiejar 0.2.0 {cookiejar cookiejar.tcl} diff --git a/library/registry/pkgIndex.tcl b/library/registry/pkgIndex.tcl index 5c73f30..765f02a 100644 --- a/library/registry/pkgIndex.tcl +++ b/library/registry/pkgIndex.tcl @@ -1,4 +1,9 @@ if {![package vsatisfies [package provide Tcl] 8.5-]} return if {[info sharedlibextension] != ".dll"} return -package ifneeded registry 1.3.6 \ - [list load [file join $dir tclregistry13.dll] Registry] +if {[package vsatisfies [package provide Tcl] 9.0-]} { + package ifneeded registry 1.3.6 \ + [list load [file join $dir tcl9registry13.dll] Registry] +} else { + package ifneeded registry 1.3.6 \ + [list load [file join $dir tclregistry13.dll] Registry] +} diff --git a/library/safe.tcl b/library/safe.tcl index 2ee4531..3c01f75 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -1009,8 +1009,8 @@ proc ::safe::AliasLoad {child file args} { return -code error $msg } - # package name (can be empty if file is not). - set package [lindex $args 0] + # prefix (can be empty if file is not). + set prefix [lindex $args 0] namespace upvar ::safe [VarName $child] state @@ -1022,23 +1022,23 @@ proc ::safe::AliasLoad {child file args} { # authorize that. if {!$state(nestedok)} { Log $child "loading to a sub interp (nestedok)\ - disabled (trying to load $package to $target)" + disabled (trying to load $prefix to $target)" return -code error "permission denied (nested load)" } } # Determine what kind of load is requested if {$file eq ""} { - # static package loading - if {$package eq ""} { - set msg "load error: empty filename and no package name" + # static loading + if {$prefix eq ""} { + set msg "load error: empty filename and no prefix" Log $child $msg return -code error $msg } if {!$state(staticsok)} { - Log $child "static packages loading disabled\ - (trying to load $package to $target)" - return -code error "permission denied (static package)" + Log $child "static loading disabled\ + (trying to load $prefix to $target)" + return -code error "permission denied (static library)" } } else { # file loading @@ -1061,10 +1061,10 @@ proc ::safe::AliasLoad {child file args} { } try { - return [::interp invokehidden $child load $file $package $target] + return [::interp invokehidden $child load $file $prefix $target] } on error msg { - # Some packages return no error message. - set msg0 "load of binary library for package $package failed" + # Some libraries return no error message. + set msg0 "load of library for prefix $prefix failed" if {$msg eq {}} { set msg $msg0 } else { diff --git a/libtommath/bn_mp_sqrt.c b/libtommath/bn_mp_sqrt.c index 4481d3a..dcf28fd 100644 --- a/libtommath/bn_mp_sqrt.c +++ b/libtommath/bn_mp_sqrt.c @@ -4,6 +4,7 @@ /* SPDX-License-Identifier: Unlicense */ #ifndef NO_FLOATING_POINT +#include <float.h> #include <math.h> #if (MP_DIGIT_BIT != 28) || (FLT_RADIX != 2) || (DBL_MANT_DIG != 53) || (DBL_MAX_EXP != 1024) #define NO_FLOATING_POINT diff --git a/macosx/Tcl.xcode/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj index eba62f2..0746261 100644 --- a/macosx/Tcl.xcode/project.pbxproj +++ b/macosx/Tcl.xcode/project.pbxproj @@ -394,7 +394,7 @@ F96D3EA208F272A7004A47F5 /* split.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = split.n; sourceTree = "<group>"; }; F96D3EA308F272A7004A47F5 /* SplitList.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitList.3; sourceTree = "<group>"; }; F96D3EA408F272A7004A47F5 /* SplitPath.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitPath.3; sourceTree = "<group>"; }; - F96D3EA508F272A7004A47F5 /* StaticPkg.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticPkg.3; sourceTree = "<group>"; }; + F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticLibrary.3; sourceTree = "<group>"; }; F96D3EA608F272A7004A47F5 /* StdChannels.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StdChannels.3; sourceTree = "<group>"; }; F96D3EA708F272A7004A47F5 /* string.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = string.n; sourceTree = "<group>"; }; F96D3EA808F272A7004A47F5 /* StringObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StringObj.3; sourceTree = "<group>"; }; @@ -1141,7 +1141,7 @@ F96D3EA208F272A7004A47F5 /* split.n */, F96D3EA308F272A7004A47F5 /* SplitList.3 */, F96D3EA408F272A7004A47F5 /* SplitPath.3 */, - F96D3EA508F272A7004A47F5 /* StaticPkg.3 */, + F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */, F96D3EA608F272A7004A47F5 /* StdChannels.3 */, F96D3EA708F272A7004A47F5 /* string.n */, F96D3EA808F272A7004A47F5 /* StringObj.3 */, diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index c20e83a..6bb3417 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -393,7 +393,7 @@ F96D3EA208F272A7004A47F5 /* split.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = split.n; sourceTree = "<group>"; }; F96D3EA308F272A7004A47F5 /* SplitList.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitList.3; sourceTree = "<group>"; }; F96D3EA408F272A7004A47F5 /* SplitPath.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitPath.3; sourceTree = "<group>"; }; - F96D3EA508F272A7004A47F5 /* StaticPkg.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticPkg.3; sourceTree = "<group>"; }; + F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticLibrary.3; sourceTree = "<group>"; }; F96D3EA608F272A7004A47F5 /* StdChannels.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StdChannels.3; sourceTree = "<group>"; }; F96D3EA708F272A7004A47F5 /* string.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = string.n; sourceTree = "<group>"; }; F96D3EA808F272A7004A47F5 /* StringObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StringObj.3; sourceTree = "<group>"; }; @@ -1141,7 +1141,7 @@ F96D3EA208F272A7004A47F5 /* split.n */, F96D3EA308F272A7004A47F5 /* SplitList.3 */, F96D3EA408F272A7004A47F5 /* SplitPath.3 */, - F96D3EA508F272A7004A47F5 /* StaticPkg.3 */, + F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */, F96D3EA608F272A7004A47F5 /* StdChannels.3 */, F96D3EA708F272A7004A47F5 /* string.n */, F96D3EA808F272A7004A47F5 /* StringObj.3 */, diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 5bdc5a3..c870a36 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -534,7 +534,58 @@ MODULE_SCOPE long tclMacOSXDarwinRelease; /* *---------------------------------------------------------------------- * - * Tcl_InitNotifier -- + * LookUpFileHandler -- + * + * Look up the file handler structure (and optionally the previous one in + * the chain) associated with a file descriptor. + * + * Returns: + * A pointer to the file handler, or NULL if it can't be found. + * + * Side effects: + * If prevPtrPtr is non-NULL, it will be written to if the file handler + * is found. + * + *---------------------------------------------------------------------- + */ + +static inline FileHandler * +LookUpFileHandler( + ThreadSpecificData *tsdPtr, /* Where to look things up. */ + int fd, /* What we are looking for. */ + FileHandler **prevPtrPtr) /* If non-NULL, where to report the previous + * pointer. */ +{ + FileHandler *filePtr, *prevPtr; + + /* + * Find the entry for the given file (and return if there isn't one). + */ + + for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; + prevPtr = filePtr, filePtr = filePtr->nextPtr) { + if (filePtr == NULL) { + return NULL; + } + if (filePtr->fd == fd) { + break; + } + } + + /* + * Report what we've found to our caller. + */ + + if (prevPtrPtr) { + *prevPtrPtr = prevPtr; + } + return filePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclpInitNotifier -- * * Initializes the platform specific notifier state. * @@ -548,22 +599,16 @@ MODULE_SCOPE long tclMacOSXDarwinRelease; */ ClientData -Tcl_InitNotifier(void) +TclpInitNotifier(void) { - ThreadSpecificData *tsdPtr; - - if (tclNotifierHooks.initNotifierProc) { - return tclNotifierHooks.initNotifierProc(); - } - - tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); #ifdef WEAK_IMPORT_SPINLOCKLOCK /* * Initialize support for weakly imported spinlock API. */ if (pthread_once(&spinLockLockInitControl, SpinLockLockInit)) { - Tcl_Panic("Tcl_InitNotifier: pthread_once failed"); + Tcl_Panic("Tcl_InitNotifier: %s", "pthread_once failed"); } #endif @@ -590,7 +635,8 @@ Tcl_InitNotifier(void) runLoopSource = CFRunLoopSourceCreate(NULL, LONG_MIN, &runLoopSourceContext); if (!runLoopSource) { - Tcl_Panic("Tcl_InitNotifier: could not create CFRunLoopSource"); + Tcl_Panic("Tcl_InitNotifier: %s", + "could not create CFRunLoopSource"); } CFRunLoopAddSource(runLoop, runLoopSource, kCFRunLoopCommonModes); CFRunLoopAddSource(runLoop, runLoopSource, tclEventsOnlyRunLoopMode); @@ -602,8 +648,8 @@ Tcl_InitNotifier(void) LONG_MIN, UpdateWaitingListAndServiceEvents, &runLoopObserverContext); if (!runLoopObserver) { - Tcl_Panic("Tcl_InitNotifier: could not create " - "CFRunLoopObserver"); + Tcl_Panic("Tcl_InitNotifier: %s", + "could not create CFRunLoopObserver"); } CFRunLoopAddObserver(runLoop, runLoopObserver, kCFRunLoopCommonModes); @@ -620,8 +666,8 @@ Tcl_InitNotifier(void) LONG_MIN, UpdateWaitingListAndServiceEvents, &runLoopObserverContext); if (!runLoopObserverTcl) { - Tcl_Panic("Tcl_InitNotifier: could not create " - "CFRunLoopObserver"); + Tcl_Panic("Tcl_InitNotifier: %s", + "could not create CFRunLoopObserver"); } CFRunLoopAddObserver(runLoop, runLoopObserverTcl, tclEventsOnlyRunLoopMode); @@ -650,7 +696,7 @@ Tcl_InitNotifier(void) int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild); if (result) { - Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed"); + Tcl_Panic("Tcl_InitNotifier: %s", "pthread_atfork failed"); } atForkInit = 1; } @@ -663,20 +709,20 @@ Tcl_InitNotifier(void) */ if (pipe(fds) != 0) { - Tcl_Panic("Tcl_InitNotifier: could not create trigger pipe"); + Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger pipe"); } status = fcntl(fds[0], F_GETFL); status |= O_NONBLOCK; if (fcntl(fds[0], F_SETFL, status) < 0) { - Tcl_Panic("Tcl_InitNotifier: could not make receive pipe non " - "blocking"); + Tcl_Panic("Tcl_InitNotifier: %s", + "could not make receive pipe non-blocking"); } status = fcntl(fds[1], F_GETFL); status |= O_NONBLOCK; if (fcntl(fds[1], F_SETFL, status) < 0) { - Tcl_Panic("Tcl_InitNotifier: could not make trigger pipe non " - "blocking"); + Tcl_Panic("Tcl_InitNotifier: %s", + "could not make trigger pipe non-blocking"); } receivePipe = fds[0]; @@ -762,7 +808,7 @@ StartNotifierThread(void) pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE); pthread_attr_setstacksize(&attr, 60 * 1024); result = pthread_create(¬ifierThread, &attr, - (void * (*)(void *))NotifierThreadProc, NULL); + (void * (*)(void *)) NotifierThreadProc, NULL); pthread_attr_destroy(&attr); if (result) { Tcl_Panic("StartNotifierThread: unable to start notifier thread"); @@ -776,7 +822,7 @@ StartNotifierThread(void) /* *---------------------------------------------------------------------- * - * Tcl_FinalizeNotifier -- + * TclpFinalizeNotifier -- * * This function is called to cleanup the notifier state before a thread * is terminated. @@ -792,17 +838,10 @@ StartNotifierThread(void) */ void -Tcl_FinalizeNotifier( - ClientData clientData) +TclpFinalizeNotifier( + TCL_UNUSED(ClientData)) { - ThreadSpecificData *tsdPtr; - - if (tclNotifierHooks.finalizeNotifierProc) { - tclNotifierHooks.finalizeNotifierProc(clientData); - return; - } - - tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); LOCK_NOTIFIER_INIT; notifierCount--; @@ -876,7 +915,7 @@ Tcl_FinalizeNotifier( /* *---------------------------------------------------------------------- * - * Tcl_AlertNotifier -- + * TclpAlertNotifier -- * * Wake up the specified notifier from any thread. This routine is called * by the platform independent notifier code whenever the Tcl_ThreadAlert @@ -893,15 +932,10 @@ Tcl_FinalizeNotifier( */ void -Tcl_AlertNotifier( +TclpAlertNotifier( ClientData clientData) { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData; - - if (tclNotifierHooks.alertNotifierProc) { - tclNotifierHooks.alertNotifierProc(clientData); - return; - } + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; LOCK_NOTIFIER_TSD; if (tsdPtr->runLoop) { @@ -914,7 +948,7 @@ Tcl_AlertNotifier( /* *---------------------------------------------------------------------- * - * Tcl_SetTimer -- + * TclpSetTimer -- * * This function sets the current notifier timer value. * @@ -928,18 +962,13 @@ Tcl_AlertNotifier( */ void -Tcl_SetTimer( +TclpSetTimer( const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ { ThreadSpecificData *tsdPtr; CFRunLoopTimerRef runLoopTimer; CFTimeInterval waitTime; - if (tclNotifierHooks.setTimerProc) { - tclNotifierHooks.setTimerProc(timePtr); - return; - } - tsdPtr = TCL_TSD_INIT(&dataKey); runLoopTimer = tsdPtr->runLoopTimer; if (!runLoopTimer) { @@ -949,7 +978,7 @@ Tcl_SetTimer( Tcl_Time vTime = *timePtr; if (vTime.sec != 0 || vTime.usec != 0) { - tclScaleTimeProcPtr(&vTime, tclTimeClientData); + TclScaleTime(&vTime); waitTime = vTime.sec + 1.0e-6 * vTime.usec; } else { waitTime = 0; @@ -988,7 +1017,7 @@ TimerWakeUp( /* *---------------------------------------------------------------------- * - * Tcl_ServiceModeHook -- + * TclpServiceModeHook -- * * This function is invoked whenever the service mode changes. * @@ -1002,18 +1031,11 @@ TimerWakeUp( */ void -Tcl_ServiceModeHook( +TclpServiceModeHook( int mode) /* Either TCL_SERVICE_ALL, or * TCL_SERVICE_NONE. */ { - ThreadSpecificData *tsdPtr; - - if (tclNotifierHooks.serviceModeHookProc) { - tclNotifierHooks.serviceModeHookProc(mode); - return; - } - - tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (mode == TCL_SERVICE_ALL && !tsdPtr->runLoopTimer) { if (!tsdPtr->runLoop) { @@ -1033,9 +1055,9 @@ Tcl_ServiceModeHook( /* *---------------------------------------------------------------------- * - * Tcl_CreateFileHandler -- + * TclpCreateFileHandler -- * - * This function registers a file handler with the select notifier. + * This function registers a file handler with the notifier. * * Results: * None. @@ -1047,7 +1069,7 @@ Tcl_ServiceModeHook( */ void -Tcl_CreateFileHandler( +TclpCreateFileHandler( int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates @@ -1057,24 +1079,11 @@ Tcl_CreateFileHandler( * event. */ ClientData clientData) /* Arbitrary data to pass to proc. */ { - ThreadSpecificData *tsdPtr; - FileHandler *filePtr; - - if (tclNotifierHooks.createFileHandlerProc) { - tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); - return; - } - - tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); - for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd == fd) { - break; - } - } if (filePtr == NULL) { - filePtr = (FileHandler *)ckalloc(sizeof(FileHandler)); + filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->readyMask = 0; filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; @@ -1113,7 +1122,7 @@ Tcl_CreateFileHandler( /* *---------------------------------------------------------------------- * - * Tcl_DeleteFileHandler -- + * TclpDeleteFileHandler -- * * Cancel a previously-arranged callback arrangement for a file. * @@ -1127,47 +1136,34 @@ Tcl_CreateFileHandler( */ void -Tcl_DeleteFileHandler( +TclpDeleteFileHandler( int fd) /* Stream id for which to remove callback * function. */ { FileHandler *filePtr, *prevPtr; - int i, numFdBits; - ThreadSpecificData *tsdPtr; - - if (tclNotifierHooks.deleteFileHandlerProc) { - tclNotifierHooks.deleteFileHandlerProc(fd); - return; - } - - tsdPtr = TCL_TSD_INIT(&dataKey); - numFdBits = -1; + int i, numFdBits = -1; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Find the entry for the given file (and return if there isn't one). */ - for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { - if (filePtr == NULL) { - return; - } - if (filePtr->fd == fd) { - break; - } + filePtr = LookUpFileHandler(tsdPtr, fd, &prevPtr); + if (filePtr == NULL) { + return; } /* * Find current max fd. */ - if (fd+1 == tsdPtr->numFdBits) { + if (fd + 1 == tsdPtr->numFdBits) { numFdBits = 0; - for (i = fd-1; i >= 0; i--) { + for (i = fd - 1; i >= 0; i--) { if (FD_ISSET(i, &tsdPtr->checkMasks.readable) || FD_ISSET(i, &tsdPtr->checkMasks.writable) || FD_ISSET(i, &tsdPtr->checkMasks.exceptional)) { - numFdBits = i+1; + numFdBits = i + 1; break; } } @@ -1250,12 +1246,8 @@ FileHandlerEventProc( */ tsdPtr = TCL_TSD_INIT(&dataKey); - for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd != fileEvPtr->fd) { - continue; - } - + filePtr = LookUpFileHandler(tsdPtr, fileEvPtr->fd, NULL); + if (filePtr != NULL) { /* * The code is tricky for two reasons: * 1. The file handler's desired events could have changed since the @@ -1284,7 +1276,6 @@ FileHandlerEventProc( UNLOCK_NOTIFIER_TSD; filePtr->proc(filePtr->clientData, mask); } - break; } return 1; } @@ -1292,7 +1283,7 @@ FileHandlerEventProc( /* *---------------------------------------------------------------------- * - * Tcl_WaitForEvent -- + * TclpWaitForEvent -- * * This function is called by Tcl_DoOneEvent to wait for new events on * the message queue. If the block time is 0, then Tcl_WaitForEvent just @@ -1309,7 +1300,7 @@ FileHandlerEventProc( */ int -Tcl_WaitForEvent( +TclpWaitForEvent( const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { int result, polling, runLoopRunning; @@ -1317,9 +1308,6 @@ Tcl_WaitForEvent( SInt32 runLoopStatus; ThreadSpecificData *tsdPtr; - if (tclNotifierHooks.waitForEventProc) { - return tclNotifierHooks.waitForEventProc(timePtr); - } result = -1; polling = 0; waitTime = CF_TIMEINTERVAL_FOREVER; @@ -1343,10 +1331,9 @@ Tcl_WaitForEvent( */ if (vTime.sec != 0 || vTime.usec != 0) { - tclScaleTimeProcPtr(&vTime, tclTimeClientData); + TclScaleTime(&vTime); waitTime = vTime.sec + 1.0e-6 * vTime.usec; } else { - /* * The max block time was set to 0. * @@ -1357,8 +1344,8 @@ Tcl_WaitForEvent( * or timers are ready to fire immediately, only one (possibly two * if one is a version 0 source) will be fired, regardless of the * value of returnAfterSourceHandled." This can cause some chanio - * tests to fail. So we use a small positive waitTime unless there - * is another RunLoop running. + * tests to fail. So we use a small positive waitTime unless + * there is another RunLoop running. */ polling = 1; @@ -1431,7 +1418,7 @@ QueueFileEvents( { SelectMasks readyMasks; FileHandler *filePtr; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) info; /* * Queue all detected file events. @@ -1470,7 +1457,8 @@ QueueFileEvents( */ if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent)); + FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) + ckalloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; @@ -1485,8 +1473,8 @@ QueueFileEvents( * * UpdateWaitingListAndServiceEvents -- * - * CFRunLoopObserver callback for updating waitingList and - * servicing Tcl events. + * CFRunLoopObserver callback for updating waitingList and servicing Tcl + * events. * * Results: * None. @@ -1503,7 +1491,8 @@ UpdateWaitingListAndServiceEvents( CFRunLoopActivity activity, void *info) { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) info; + if (tsdPtr->sleeping) { return; } @@ -1626,8 +1615,7 @@ Tcl_Sleep( vdelay.sec = ms / 1000; vdelay.usec = (ms % 1000) * 1000; - tclScaleTimeProcPtr(&vdelay, tclTimeClientData); - + TclScaleTime(&vdelay); if (tsdPtr->runLoop) { CFTimeInterval waitTime; @@ -1853,7 +1841,7 @@ TclUnixWaitForFile( * * Result: * None. Once started, this routine never exits. It dies with the overall - * process. + * process or terminates its own thread (on notifier termination). * * Side effects: * The trigger pipe used to signal the notifier thread is created when @@ -2090,9 +2078,9 @@ AtForkChild(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * If a child process unlocks an os_unfair_lock that was created in its parent - * the child will exit with an illegal instruction error. So we reinitialize - * the lock in the child rather than attempt to unlock it. + * If a child process unlocks an os_unfair_lock that was created in its + * parent the child will exit with an illegal instruction error. So we + * reinitialize the lock in the child rather than attempt to unlock it. */ #if defined(USE_OS_UNFAIR_LOCK) diff --git a/tests/append.test b/tests/append.test index a174615..c0c0cce 100644 --- a/tests/append.test +++ b/tests/append.test @@ -15,8 +15,12 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands unset -nocomplain x +catch [list package require -exact tcl::test [info patchlevel]] +testConstraint testbytestring [llength [info commands testbytestring]] + test append-1.1 {append command} { unset -nocomplain x list [append x 1 2 abc "long string"] $x @@ -53,6 +57,35 @@ test append-3.3 {append errors} -returnCodes error -body { unset -nocomplain x append x } -result {can't read "x": no such variable} +test append-3.4 {append surrogates} -body { + set x \uD83D + append x \uDE02 +} -result \uD83D\uDE02 +test append-3.5 {append surrogates} -body { + set x \uD83D + set x $x\uDE02 +} -result \uD83D\uDE02 +test append-3.6 {append surrogates} -body { + set x \uDE02 + set x \uD83D$x +} -result \uD83D\uDE02 +test append-3.7 {append \xC0 \x80} -constraints testbytestring -body { + set x [testbytestring \xC0] + string length [append x [testbytestring \x80]] +} -result 2 +test append-3.8 {append \xC0 \x80} -constraints testbytestring -body { + set x [testbytestring \xC0] + string length $x[testbytestring \x80] +} -result 2 +test append-3.9 {append \xC0 \x80} -constraints testbytestring -body { + set x [testbytestring \x80] + string length [testbytestring \xC0]$x +} -result 2 +test append-3.10 {append surrogates} -body { + set x \uD83D + string range $x 0 end + append x \uDE02 +} -result [string range \uD83D\uDE02 0 end] test append-4.1 {lappend command} { unset -nocomplain x diff --git a/tests/binary.test b/tests/binary.test index 8b326d4..a43fb49 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -14,6 +14,9 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] + testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}] testConstraint testbytestring [llength [info commands testbytestring]] @@ -25,9 +28,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -37,19 +40,19 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -59,11 +62,11 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 @@ -160,16 +163,16 @@ test binary-4.3 {Tcl_BinaryObjCmd: format} { } \x80 test binary-4.4 {Tcl_BinaryObjCmd: format} { binary format B* 010011 -} \x4c +} \x4C test binary-4.5 {Tcl_BinaryObjCmd: format} { binary format B8 01001101 -} \x4d +} \x4D test binary-4.6 {Tcl_BinaryObjCmd: format} { binary format A2X2B9 oo 01001101 -} \x4d\x00 +} \x4D\x00 test binary-4.7 {Tcl_BinaryObjCmd: format} { binary format B9 010011011010 -} \x4d\x80 +} \x4D\x80 test binary-4.8 {Tcl_BinaryObjCmd: format} { binary format B2B3 10 010 } \x80\x40 @@ -191,16 +194,16 @@ test binary-5.4 {Tcl_BinaryObjCmd: format} { } 2 test binary-5.5 {Tcl_BinaryObjCmd: format} { binary format b8 01001101 -} \xb2 +} \xB2 test binary-5.6 {Tcl_BinaryObjCmd: format} { binary format A2X2b9 oo 01001101 -} \xb2\x00 +} \xB2\x00 test binary-5.7 {Tcl_BinaryObjCmd: format} { binary format b9 010011011010 -} \xb2\x01 +} \xB2\x01 test binary-5.8 {Tcl_BinaryObjCmd: format} { binary format b17 1 -} \x01\00\00 +} \x01\x00\x00 test binary-5.9 {Tcl_BinaryObjCmd: format} { binary format b2b3 10 010 } \x01\x02 @@ -219,19 +222,19 @@ test binary-6.3 {Tcl_BinaryObjCmd: format} { } \x01 test binary-6.4 {Tcl_BinaryObjCmd: format} { binary format h c -} \x0c +} \x0C test binary-6.5 {Tcl_BinaryObjCmd: format} { binary format h* baadf00d -} \xab\xda\x0f\xd0 +} \xAB\xDA\x0F\xD0 test binary-6.6 {Tcl_BinaryObjCmd: format} { binary format h4 c410 -} \x4c\x01 +} \x4C\x01 test binary-6.7 {Tcl_BinaryObjCmd: format} { binary format h6 c4102 -} \x4c\x01\x02 +} \x4C\x01\x02 test binary-6.8 {Tcl_BinaryObjCmd: format} { binary format h5 c41020304 -} \x4c\x01\x02 +} \x4C\x01\x02 test binary-6.9 {Tcl_BinaryObjCmd: format} { binary format a3X3h5 foo 2 } \x02\x00\x00 @@ -253,19 +256,19 @@ test binary-7.3 {Tcl_BinaryObjCmd: format} { } \x10 test binary-7.4 {Tcl_BinaryObjCmd: format} { binary format H c -} \xc0 +} \xC0 test binary-7.5 {Tcl_BinaryObjCmd: format} { binary format H* baadf00d -} \xba\xad\xf0\x0d +} \xBA\xAD\xF0\x0D test binary-7.6 {Tcl_BinaryObjCmd: format} { binary format H4 c410 -} \xc4\x10 +} \xC4\x10 test binary-7.7 {Tcl_BinaryObjCmd: format} { binary format H6 c4102 -} \xc4\x10\x20 +} \xC4\x10\x20 test binary-7.8 {Tcl_BinaryObjCmd: format} { binary format H5 c41023304 -} \xc4\x10\x20 +} \xC4\x10\x20 test binary-7.9 {Tcl_BinaryObjCmd: format} { binary format a3X3H5 foo 2 } \x20\x00\x00 @@ -485,34 +488,34 @@ test binary-13.3 {Tcl_BinaryObjCmd: format} { } {} test binary-13.4 {Tcl_BinaryObjCmd: format} bigEndian { binary format f 1.6 -} \x3f\xcc\xcc\xcd +} \x3F\xCC\xCC\xCD test binary-13.5 {Tcl_BinaryObjCmd: format} littleEndian { binary format f 1.6 -} \xcd\xcc\xcc\x3f +} \xCD\xCC\xCC\x3F test binary-13.6 {Tcl_BinaryObjCmd: format} bigEndian { binary format f* {1.6 3.4} -} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A test binary-13.7 {Tcl_BinaryObjCmd: format} littleEndian { binary format f* {1.6 3.4} -} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 test binary-13.8 {Tcl_BinaryObjCmd: format} bigEndian { binary format f2 {1.6 3.4} -} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A test binary-13.9 {Tcl_BinaryObjCmd: format} littleEndian { binary format f2 {1.6 3.4} -} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 test binary-13.10 {Tcl_BinaryObjCmd: format} bigEndian { binary format f2 {1.6 3.4 5.6} -} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A test binary-13.11 {Tcl_BinaryObjCmd: format} littleEndian { binary format f2 {1.6 3.4 5.6} -} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 test binary-13.12 {Tcl_BinaryObjCmd: float overflow} bigEndian { binary format f -3.402825e+38 -} \xff\x7f\xff\xff +} \xFF\x7F\xFF\xFF test binary-13.13 {Tcl_BinaryObjCmd: float overflow} littleEndian { binary format f -3.402825e+38 -} \xff\xff\x7f\xff +} \xFF\xFF\x7F\xFF test binary-13.14 {Tcl_BinaryObjCmd: float underflow} bigEndian { binary format f -3.402825e-100 } \x80\x00\x00\x00 @@ -529,11 +532,11 @@ test binary-13.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-13.18 {Tcl_BinaryObjCmd: format} bigEndian { set a {1.6 3.4} binary format f1 $a -} \x3f\xcc\xcc\xcd +} \x3F\xCC\xCC\xCD test binary-13.19 {Tcl_BinaryObjCmd: format} littleEndian { set a {1.6 3.4} binary format f1 $a -} \xcd\xcc\xcc\x3f +} \xCD\xCC\xCC\x3F test binary-14.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { binary format d @@ -546,28 +549,28 @@ test binary-14.3 {Tcl_BinaryObjCmd: format} { } {} test binary-14.4 {Tcl_BinaryObjCmd: format} bigEndian { binary format d 1.6 -} \x3f\xf9\x99\x99\x99\x99\x99\x9a +} \x3F\xF9\x99\x99\x99\x99\x99\x9A test binary-14.5 {Tcl_BinaryObjCmd: format} littleEndian { binary format d 1.6 -} \x9a\x99\x99\x99\x99\x99\xf9\x3f +} \x9A\x99\x99\x99\x99\x99\xF9\x3F test binary-14.6 {Tcl_BinaryObjCmd: format} bigEndian { binary format d* {1.6 3.4} -} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 test binary-14.7 {Tcl_BinaryObjCmd: format} littleEndian { binary format d* {1.6 3.4} -} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 test binary-14.8 {Tcl_BinaryObjCmd: format} bigEndian { binary format d2 {1.6 3.4} -} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 test binary-14.9 {Tcl_BinaryObjCmd: format} littleEndian { binary format d2 {1.6 3.4} -} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 test binary-14.10 {Tcl_BinaryObjCmd: format} bigEndian { binary format d2 {1.6 3.4 5.6} -} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 test binary-14.11 {Tcl_BinaryObjCmd: format} littleEndian { binary format d2 {1.6 3.4 5.6} -} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 test binary-14.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body { binary format d2 {1.6} } -result {number of elements in list does not match count} @@ -578,11 +581,11 @@ test binary-14.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-14.16 {Tcl_BinaryObjCmd: format} bigEndian { set a {1.6 3.4} binary format d1 $a -} \x3f\xf9\x99\x99\x99\x99\x99\x9a +} \x3F\xF9\x99\x99\x99\x99\x99\x9A test binary-14.17 {Tcl_BinaryObjCmd: format} littleEndian { set a {1.6 3.4} binary format d1 $a -} \x9a\x99\x99\x99\x99\x99\xf9\x3f +} \x9A\x99\x99\x99\x99\x99\xF9\x3F test binary-14.18 {FormatNumber: Bug 1116542} { binary scan [binary format d 1.25] d w set w @@ -874,11 +877,11 @@ test binary-24.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-24.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 h* arg1] $arg1 + list [binary scan \x52\xA3 h* arg1] $arg1 } {1 253a} test binary-24.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xc2\xa3 h arg1] $arg1 + list [binary scan \xC2\xA3 h arg1] $arg1 } {1 2} test binary-24.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -890,7 +893,7 @@ test binary-24.5 {Tcl_BinaryObjCmd: scan} { } {1 {}} test binary-24.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xf2\x53 h2 arg1] $arg1 + list [binary scan \xF2\x53 h2 arg1] $arg1 } {1 2f} test binary-24.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -920,11 +923,11 @@ test binary-25.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-25.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 H* arg1] $arg1 + list [binary scan \x52\xA3 H* arg1] $arg1 } {1 52a3} test binary-25.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xc2\xa3 H arg1] $arg1 + list [binary scan \xC2\xA3 H arg1] $arg1 } {1 c} test binary-25.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -936,7 +939,7 @@ test binary-25.5 {Tcl_BinaryObjCmd: scan} { } {1 {}} test binary-25.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xf2\x53 H2 arg1] $arg1 + list [binary scan \xF2\x53 H2 arg1] $arg1 } {1 f2} test binary-25.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -965,27 +968,27 @@ test binary-26.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-26.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 c* arg1] $arg1 + list [binary scan \x52\xA3 c* arg1] $arg1 } {1 {82 -93}} test binary-26.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 c arg1] $arg1 + list [binary scan \x52\xA3 c arg1] $arg1 } {1 82} test binary-26.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 c1 arg1] $arg1 + list [binary scan \x52\xA3 c1 arg1] $arg1 } {1 82} test binary-26.5 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 c0 arg1] $arg1 + list [binary scan \x52\xA3 c0 arg1] $arg1 } {1 {}} test binary-26.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 c2 arg1] $arg1 + list [binary scan \x52\xA3 c2 arg1] $arg1 } {1 {82 -93}} test binary-26.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xff c arg1] $arg1 + list [binary scan \xFF c arg1] $arg1 } {1 -1} test binary-26.8 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1006,15 +1009,15 @@ test binary-26.10 {Tcl_BinaryObjCmd: scan} { } {2 {112 -121} 5} test binary-26.11 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 cu* arg1] $arg1 + list [binary scan \x52\xA3 cu* arg1] $arg1 } {1 {82 163}} test binary-26.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 cu arg1] $arg1 + list [binary scan \x52\xA3 cu arg1] $arg1 } {1 82} test binary-26.13 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xff cu arg1] $arg1 + list [binary scan \xFF cu arg1] $arg1 } {1 255} test binary-26.14 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 @@ -1034,23 +1037,23 @@ test binary-27.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-27.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 s* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 s* arg1] $arg1 } {1 {-23726 21587}} test binary-27.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 s arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 s arg1] $arg1 } {1 -23726} test binary-27.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 s1 arg1] $arg1 + list [binary scan \x52\xA3 s1 arg1] $arg1 } {1 -23726} test binary-27.5 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 s0 arg1] $arg1 + list [binary scan \x52\xA3 s0 arg1] $arg1 } {1 {}} test binary-27.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 s2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 s2 arg1] $arg1 } {1 {-23726 21587}} test binary-27.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1067,23 +1070,23 @@ test binary-27.9 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2 } {2 {-23726 21587} 5} test binary-27.10 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 su* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 su* arg1] $arg1 } {1 {41810 21587}} test binary-27.11 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \xff\xff\xff\xff sus arg1 arg2] $arg1 $arg2 + list [binary scan \xFF\xFF\xFF\xFF sus arg1 arg2] $arg1 $arg2 } {2 65535 -1} test binary-27.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \xff\xff\xff\xff ssu arg1 arg2] $arg1 $arg2 + list [binary scan \xFF\xFF\xFF\xFF ssu arg1 arg2] $arg1 $arg2 } {2 -1 65535} test binary-28.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { @@ -1091,23 +1094,23 @@ test binary-28.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-28.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 S* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 S* arg1] $arg1 } {1 {21155 21332}} test binary-28.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 S arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 S arg1] $arg1 } {1 21155} test binary-28.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 S1 arg1] $arg1 + list [binary scan \x52\xA3 S1 arg1] $arg1 } {1 21155} test binary-28.5 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 S0 arg1] $arg1 + list [binary scan \x52\xA3 S0 arg1] $arg1 } {1 {}} test binary-28.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 S2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 S2 arg1] $arg1 } {1 {21155 21332}} test binary-28.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1124,15 +1127,15 @@ test binary-28.9 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2 } {2 {21155 21332} 5} test binary-28.10 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 Su* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 Su* arg1] $arg1 } {1 {21155 21332}} test binary-28.11 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xa3\x52\x54\x53 Su* arg1] $arg1 + list [binary scan \xA3\x52\x54\x53 Su* arg1] $arg1 } {1 {41810 21587}} test binary-29.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { @@ -1140,23 +1143,23 @@ test binary-29.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-29.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1 } {1 {1414767442 67305985}} test binary-29.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 i arg1] $arg1 } {1 1414767442} test binary-29.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 i1 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 i1 arg1] $arg1 } {1 1414767442} test binary-29.5 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53 i0 arg1] $arg1 + list [binary scan \x52\xA3\x53 i0 arg1] $arg1 } {1 {}} test binary-29.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 i2 arg1] $arg1 } {1 {1414767442 67305985}} test binary-29.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1173,15 +1176,15 @@ test binary-29.9 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2 } {2 {1414767442 67305985} 5} test binary-29.10 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 - list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iui arg1 arg2] $arg1 $arg2 + list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF iui arg1 arg2] $arg1 $arg2 } {2 4294967295 -1} test binary-29.11 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 - list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iiu arg1 arg2] $arg1 $arg2 + list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF iiu arg1 arg2] $arg1 $arg2 } {2 -1 4294967295} test binary-29.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 @@ -1193,23 +1196,23 @@ test binary-30.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-30.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1 } {1 {1386435412 16909060}} test binary-30.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 I arg1] $arg1 } {1 1386435412} test binary-30.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 I1 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 I1 arg1] $arg1 } {1 1386435412} test binary-30.5 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53 I0 arg1] $arg1 + list [binary scan \x52\xA3\x53 I0 arg1] $arg1 } {1 {}} test binary-30.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 I2 arg1] $arg1 } {1 {1386435412 16909060}} test binary-30.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1226,15 +1229,15 @@ test binary-30.9 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2 } {2 {1386435412 16909060} 5} test binary-30.10 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 - list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IuI arg1 arg2] $arg1 $arg2 + list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF IuI arg1 arg2] $arg1 $arg2 } {2 4294967295 -1} test binary-30.11 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 - list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IIu arg1 arg2] $arg1 $arg2 + list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF IIu arg1 arg2] $arg1 $arg2 } {2 -1 4294967295} test binary-30.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 @@ -1246,43 +1249,43 @@ test binary-31.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-31.2 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A f* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.3 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 f* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.4 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A f arg1] $arg1 } {1 1.600000023841858} test binary-31.5 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 f arg1] $arg1 } {1 1.600000023841858} test binary-31.6 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD f1 arg1] $arg1 } {1 1.600000023841858} test binary-31.7 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F f1 arg1] $arg1 } {1 1.600000023841858} test binary-31.8 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD f0 arg1] $arg1 } {1 {}} test binary-31.9 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f f0 arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F f0 arg1] $arg1 } {1 {}} test binary-31.10 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A f2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.11 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 f2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1293,19 +1296,19 @@ test binary-31.13 {Tcl_BinaryObjCmd: scan} -setup { unset -nocomplain arg1 } -returnCodes error -body { set arg1 1 - binary scan \x3f\xcc\xcc\xcd f1 arg1(a) + binary scan \x3F\xCC\xCC\xCD f1 arg1(a) } -result {can't set "arg1(a)": variable isn't array} test binary-31.14 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A\x05 f2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-31.15 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-32.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { @@ -1313,43 +1316,43 @@ test binary-32.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-32.2 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d* arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 d* arg1] $arg1 } {1 {1.6 3.4}} test binary-32.3 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d* arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 d* arg1] $arg1 } {1 {1.6 3.4}} test binary-32.4 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 d arg1] $arg1 } {1 1.6} test binary-32.5 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 d arg1] $arg1 } {1 1.6} test binary-32.6 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A d1 arg1] $arg1 } {1 1.6} test binary-32.7 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d1 arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F d1 arg1] $arg1 } {1 1.6} test binary-32.8 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d0 arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A d0 arg1] $arg1 } {1 {}} test binary-32.9 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d0 arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F d0 arg1] $arg1 } {1 {}} test binary-32.10 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d2 arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 d2 arg1] $arg1 } {1 {1.6 3.4}} test binary-32.11 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d2 arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 d2 arg1] $arg1 } {1 {1.6 3.4}} test binary-32.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1360,19 +1363,19 @@ test binary-32.13 {Tcl_BinaryObjCmd: scan} -setup { unset -nocomplain arg1 } -returnCodes error -body { set arg1 1 - binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1(a) + binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A d1 arg1(a) } -result {can't set "arg1(a)": variable isn't array} test binary-32.14 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 d2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33\x05 d2c* arg1 arg2] $arg1 $arg2 } {2 {1.6 3.4} 5} test binary-32.15 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 d2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40\x05 d2c* arg1 arg2] $arg1 $arg2 } {2 {1.6 3.4} 5} test binary-33.1 {Tcl_BinaryObjCmd: scan} { @@ -1543,20 +1546,20 @@ test binary-38.4 {FormatNumber: word alignment} { } \x01\x00\x00\x00\x01 test binary-38.5 {FormatNumber: word alignment} bigEndian { set x [binary format c1d1 1 1.6] -} \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a +} \x01\x3F\xF9\x99\x99\x99\x99\x99\x9A test binary-38.6 {FormatNumber: word alignment} littleEndian { set x [binary format c1d1 1 1.6] -} \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f +} \x01\x9A\x99\x99\x99\x99\x99\xF9\x3F test binary-38.7 {FormatNumber: word alignment} bigEndian { set x [binary format c1f1 1 1.6] -} \x01\x3f\xcc\xcc\xcd +} \x01\x3F\xCC\xCC\xCD test binary-38.8 {FormatNumber: word alignment} littleEndian { set x [binary format c1f1 1 1.6] -} \x01\xcd\xcc\xcc\x3f +} \x01\xCD\xCC\xCC\x3F test binary-39.1 {ScanNumber: sign extension} { unset -nocomplain arg1 - list [binary scan \x52\xa3 c2 arg1] $arg1 + list [binary scan \x52\xA3 c2 arg1] $arg1 } {1 {82 -93}} test binary-39.2 {ScanNumber: sign extension} { unset -nocomplain arg1 @@ -1576,7 +1579,7 @@ test binary-39.5 {ScanNumber: sign extension} { } {1 {16843010 -2130640639 25297153 16876033 16843137}} test binary-39.6 {ScanNumber: no sign extension} { unset -nocomplain arg1 - list [binary scan \x52\xa3 cu2 arg1] $arg1 + list [binary scan \x52\xA3 cu2 arg1] $arg1 } {1 {82 163}} test binary-39.7 {ScanNumber: no sign extension} { unset -nocomplain arg1 @@ -1597,11 +1600,11 @@ test binary-39.10 {ScanNumber: no sign extension} { test binary-40.3 {ScanNumber: NaN} -body { unset -nocomplain arg1 - list [binary scan \xff\xff\xff\xff f1 arg1] $arg1 + list [binary scan \xFF\xFF\xFF\xFF f1 arg1] $arg1 } -match glob -result {1 -NaN*} test binary-40.4 {ScanNumber: NaN} -body { unset -nocomplain arg1 - list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1 + list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF d arg1] $arg1 } -match glob -result {1 -NaN*} test binary-41.1 {ScanNumber: word alignment} -setup { @@ -1627,22 +1630,22 @@ test binary-41.4 {ScanNumber: word alignment} -setup { test binary-41.5 {ScanNumber: word alignment} -setup { unset -nocomplain arg1 arg2 } -constraints bigEndian -body { - list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2 + list [binary scan \x01\x3F\xCC\xCC\xCD c1f1 arg1 arg2] $arg1 $arg2 } -result {2 1 1.600000023841858} test binary-41.6 {ScanNumber: word alignment} -setup { unset -nocomplain arg1 arg2 } -constraints littleEndian -body { - list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2 + list [binary scan \x01\xCD\xCC\xCC\x3F c1f1 arg1 arg2] $arg1 $arg2 } -result {2 1 1.600000023841858} test binary-41.7 {ScanNumber: word alignment} -setup { unset -nocomplain arg1 arg2 } -constraints bigEndian -body { - list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2 + list [binary scan \x01\x3F\xF9\x99\x99\x99\x99\x99\x9A c1d1 arg1 arg2] $arg1 $arg2 } -result {2 1 1.6} test binary-41.8 {ScanNumber: word alignment} -setup { unset -nocomplain arg1 arg2 } -constraints littleEndian -body { - list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2 + list [binary scan \x01\x9A\x99\x99\x99\x99\x99\xF9\x3F c1d1 arg1 arg2] $arg1 $arg2 } -result {2 1 1.6} test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} -constraints {} -body { @@ -1713,26 +1716,26 @@ test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} { } {66 64 0 0 0 0 127 -1 -1 -1 65 76} test binary-46.1 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} { - binary format a* \u20ac -} \u00ac + binary format a* € +} \xAC test binary-46.2 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} { - list [binary scan [binary format a* \u20ac\u20bd] s x] $x + list [binary scan [binary format a* €₽] s x] $x } {1 -16980} test binary-46.3 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} { set x {} set y {} set z {} - list [binary scan [binary format a* \u20ac\u20bd] aaa x y z] $x $y $z -} "2 \u00ac \u00bd {}" + list [binary scan [binary format a* €₽] aaa x y z] $x $y $z +} "2 \xAC \xBD {}" test binary-46.4 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} { - set x [encoding convertto iso8859-15 \u20ac] + set x [encoding convertto iso8859-15 €] set y [binary format a* $x] list $x $y -} "\u00a4 \u00a4" +} "\xA4 \xA4" test binary-46.5 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} { - set x [binary scan \u00a4 a* y] + set x [binary scan \xA4 a* y] list $x $y [encoding convertfrom iso8859-15 $y] -} "1 \u00a4 \u20ac" +} "1 \xA4 €" test binary-47.1 {Tcl_BinaryObjCmd: number cache reference count handling} { # This test is only reliable when memory debugging is turned on, but @@ -1898,28 +1901,28 @@ test binary-51.3 {Tcl_BinaryObjCmd: format} { } {} test binary-51.4 {Tcl_BinaryObjCmd: format} {} { binary format Q 1.6 -} \x3f\xf9\x99\x99\x99\x99\x99\x9a +} \x3F\xF9\x99\x99\x99\x99\x99\x9A test binary-51.5 {Tcl_BinaryObjCmd: format} {} { binary format q 1.6 -} \x9a\x99\x99\x99\x99\x99\xf9\x3f +} \x9A\x99\x99\x99\x99\x99\xF9\x3F test binary-51.6 {Tcl_BinaryObjCmd: format} {} { binary format Q* {1.6 3.4} -} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 test binary-51.7 {Tcl_BinaryObjCmd: format} {} { binary format q* {1.6 3.4} -} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 test binary-51.8 {Tcl_BinaryObjCmd: format} {} { binary format Q2 {1.6 3.4} -} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 test binary-51.9 {Tcl_BinaryObjCmd: format} {} { binary format q2 {1.6 3.4} -} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 test binary-51.10 {Tcl_BinaryObjCmd: format} {} { binary format Q2 {1.6 3.4 5.6} -} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 test binary-51.11 {Tcl_BinaryObjCmd: format} {} { binary format q2 {1.6 3.4 5.6} -} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 test binary-51.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body { binary format q2 {1.6} } -result {number of elements in list does not match count} @@ -1930,11 +1933,11 @@ test binary-51.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-51.16 {Tcl_BinaryObjCmd: format} {} { set a {1.6 3.4} binary format Q1 $a -} \x3f\xf9\x99\x99\x99\x99\x99\x9a +} \x3F\xF9\x99\x99\x99\x99\x99\x9A test binary-51.17 {Tcl_BinaryObjCmd: format} {} { set a {1.6 3.4} binary format q1 $a -} \x9a\x99\x99\x99\x99\x99\xf9\x3f +} \x9A\x99\x99\x99\x99\x99\xF9\x3F # format R/r test binary-53.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { @@ -1948,34 +1951,34 @@ test binary-53.3 {Tcl_BinaryObjCmd: format} { } {} test binary-53.4 {Tcl_BinaryObjCmd: format} {} { binary format R 1.6 -} \x3f\xcc\xcc\xcd +} \x3F\xCC\xCC\xCD test binary-53.5 {Tcl_BinaryObjCmd: format} {} { binary format r 1.6 -} \xcd\xcc\xcc\x3f +} \xCD\xCC\xCC\x3F test binary-53.6 {Tcl_BinaryObjCmd: format} {} { binary format R* {1.6 3.4} -} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A test binary-53.7 {Tcl_BinaryObjCmd: format} {} { binary format r* {1.6 3.4} -} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 test binary-53.8 {Tcl_BinaryObjCmd: format} {} { binary format R2 {1.6 3.4} -} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A test binary-53.9 {Tcl_BinaryObjCmd: format} {} { binary format r2 {1.6 3.4} -} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 test binary-53.10 {Tcl_BinaryObjCmd: format} {} { binary format R2 {1.6 3.4 5.6} -} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A test binary-53.11 {Tcl_BinaryObjCmd: format} {} { binary format r2 {1.6 3.4 5.6} -} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 test binary-53.12 {Tcl_BinaryObjCmd: float overflow} {} { binary format R -3.402825e+38 -} \xff\x7f\xff\xff +} \xFF\x7F\xFF\xFF test binary-53.13 {Tcl_BinaryObjCmd: float overflow} {} { binary format r -3.402825e+38 -} \xff\xff\x7f\xff +} \xFF\xFF\x7F\xFF test binary-53.14 {Tcl_BinaryObjCmd: float underflow} {} { binary format R -3.402825e-100 } \x80\x00\x00\x00 @@ -1992,11 +1995,11 @@ test binary-53.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-53.18 {Tcl_BinaryObjCmd: format} {} { set a {1.6 3.4} binary format R1 $a -} \x3f\xcc\xcc\xcd +} \x3F\xCC\xCC\xCD test binary-53.19 {Tcl_BinaryObjCmd: format} {} { set a {1.6 3.4} binary format r1 $a -} \xcd\xcc\xcc\x3f +} \xCD\xCC\xCC\x3F # scan t (s) test binary-54.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { @@ -2004,23 +2007,23 @@ test binary-54.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-54.2 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 t* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 t* arg1] $arg1 } {1 {-23726 21587}} test binary-54.3 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 t arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 t arg1] $arg1 } {1 -23726} test binary-54.4 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3 t1 arg1] $arg1 + list [binary scan \x52\xA3 t1 arg1] $arg1 } {1 -23726} test binary-54.5 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3 t0 arg1] $arg1 + list [binary scan \x52\xA3 t0 arg1] $arg1 } {1 {}} test binary-54.6 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 t2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 t2 arg1] $arg1 } {1 {-23726 21587}} test binary-54.7 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 @@ -2037,7 +2040,7 @@ test binary-54.9 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2 } {2 {-23726 21587} 5} test binary-54.10 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 @@ -2058,23 +2061,23 @@ test binary-55.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-55.2 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 t* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 t* arg1] $arg1 } {1 {21155 21332}} test binary-55.3 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 t arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 t arg1] $arg1 } {1 21155} test binary-55.4 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3 t1 arg1] $arg1 + list [binary scan \x52\xA3 t1 arg1] $arg1 } {1 21155} test binary-55.5 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3 t0 arg1] $arg1 + list [binary scan \x52\xA3 t0 arg1] $arg1 } {1 {}} test binary-55.6 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 t2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 t2 arg1] $arg1 } {1 {21155 21332}} test binary-55.7 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 @@ -2091,7 +2094,7 @@ test binary-55.9 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2 } {2 {21155 21332} 5} test binary-55.10 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 @@ -2112,23 +2115,23 @@ test binary-56.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-56.2 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1 } {1 {1414767442 67305985}} test binary-56.3 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n arg1] $arg1 } {1 1414767442} test binary-56.4 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 n1 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 n1 arg1] $arg1 } {1 1414767442} test binary-56.5 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53 n0 arg1] $arg1 + list [binary scan \x52\xA3\x53 n0 arg1] $arg1 } {1 {}} test binary-56.6 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1 } {1 {1414767442 67305985}} test binary-56.7 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 @@ -2145,7 +2148,7 @@ test binary-56.9 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 } {2 {1414767442 67305985} 5} test binary-56.10 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 @@ -2166,23 +2169,23 @@ test binary-57.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-57.2 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1 } {1 {1386435412 16909060}} test binary-57.3 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n arg1] $arg1 } {1 1386435412} test binary-57.4 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 n1 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 n1 arg1] $arg1 } {1 1386435412} test binary-57.5 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53 n0 arg1] $arg1 + list [binary scan \x52\xA3\x53 n0 arg1] $arg1 } {1 {}} test binary-57.6 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1 } {1 {1386435412 16909060}} test binary-57.7 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 @@ -2199,7 +2202,7 @@ test binary-57.9 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 } {2 {1386435412 16909060} 5} test binary-57.10 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 @@ -2220,43 +2223,43 @@ test binary-58.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-58.2 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q* arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 Q* arg1] $arg1 } {1 {1.6 3.4}} test binary-58.3 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q* arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 q* arg1] $arg1 } {1 {1.6 3.4}} test binary-58.4 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 Q arg1] $arg1 } {1 1.6} test binary-58.5 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 q arg1] $arg1 } {1 1.6} test binary-58.6 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a Q1 arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A Q1 arg1] $arg1 } {1 1.6} test binary-58.7 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f q1 arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F q1 arg1] $arg1 } {1 1.6} test binary-58.8 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a Q0 arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A Q0 arg1] $arg1 } {1 {}} test binary-58.9 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f q0 arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F q0 arg1] $arg1 } {1 {}} test binary-58.10 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q2 arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 Q2 arg1] $arg1 } {1 {1.6 3.4}} test binary-58.11 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q2 arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 q2 arg1] $arg1 } {1 {1.6 3.4}} test binary-58.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -2267,19 +2270,19 @@ test binary-58.13 {Tcl_BinaryObjCmd: scan} -setup { unset -nocomplain arg1 } -returnCodes error -body { set arg1 1 - binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a q1 arg1(a) + binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A q1 arg1(a) } -result {can't set "arg1(a)": variable isn't array} test binary-58.14 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 Q2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33\x05 Q2c* arg1 arg2] $arg1 $arg2 } {2 {1.6 3.4} 5} test binary-58.15 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 q2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40\x05 q2c* arg1 arg2] $arg1 $arg2 } {2 {1.6 3.4} 5} # scan R/r @@ -2288,43 +2291,43 @@ test binary-59.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-59.2 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R* arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A R* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.3 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r* arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 r* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.4 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A R arg1] $arg1 } {1 1.600000023841858} test binary-59.5 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 r arg1] $arg1 } {1 1.600000023841858} test binary-59.6 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd R1 arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD R1 arg1] $arg1 } {1 1.600000023841858} test binary-59.7 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f r1 arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F r1 arg1] $arg1 } {1 1.600000023841858} test binary-59.8 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd R0 arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD R0 arg1] $arg1 } {1 {}} test binary-59.9 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f r0 arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F r0 arg1] $arg1 } {1 {}} test binary-59.10 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R2 arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A R2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.11 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r2 arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 r2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -2335,19 +2338,19 @@ test binary-59.13 {Tcl_BinaryObjCmd: scan} -setup { unset -nocomplain arg1 } -returnCodes error -body { set arg1 1 - binary scan \x3f\xcc\xcc\xcd r1 arg1(a) + binary scan \x3F\xCC\xCC\xCD r1 arg1(a) } -result {can't set "arg1(a)": variable isn't array} test binary-59.14 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 R2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A\x05 R2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-59.15 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-60.1 {[binary format] with NaN} -body { @@ -2496,7 +2499,7 @@ test binary-70.4 {binary encode hex} -body { binary encode hex [string repeat a 20] } -result [string repeat 61 20] test binary-70.5 {binary encode hex} -body { - binary encode hex \0\1\2\3\4\0\1\2\3\4 + binary encode hex \x00\x01\x02\x03\x04\x00\x01\x02\x03\x04 } -result {00010203040001020304} test binary-71.1 {binary decode hex} -body { @@ -2513,7 +2516,7 @@ test binary-71.4 {binary decode hex} -body { } -result [string repeat a 20] test binary-71.5 {binary decode hex} -body { binary decode hex 00010203040001020304 -} -result "\0\1\2\3\4\0\1\2\3\4" +} -result "\x00\x01\x02\x03\x04\x00\x01\x02\x03\x04" test binary-71.6 {binary decode hex} -body { binary decode hex "61 61" } -result {aa} @@ -2572,19 +2575,19 @@ test binary-72.4 {binary encode base64} -body { binary encode base64 [string repeat abc 20] } -result [string repeat YWJj 20] test binary-72.5 {binary encode base64} -body { - binary encode base64 \0\1\2\3\4\0\1\2\3 + binary encode base64 \x00\x01\x02\x03\x04\x00\x01\x02\x03 } -result {AAECAwQAAQID} test binary-72.6 {binary encode base64} -body { - binary encode base64 \0 + binary encode base64 \x00 } -result {AA==} test binary-72.7 {binary encode base64} -body { - binary encode base64 \0\0 + binary encode base64 \x00\x00 } -result {AAA=} test binary-72.8 {binary encode base64} -body { - binary encode base64 \0\0\0 + binary encode base64 \x00\x00\x00 } -result {AAAA} test binary-72.9 {binary encode base64} -body { - binary encode base64 \0\0\0\0 + binary encode base64 \x00\x00\x00\x00 } -result {AAAAAA==} test binary-72.10 {binary encode base64} -body { binary encode base64 -maxlen 0 -wrapchar : abcabcabc @@ -2644,7 +2647,7 @@ test binary-72.28 {binary encode base64} -body { binary encode base64 -maxlen 6 -wrapchar 0123456789 abcabcabc } -result {YWJjYW0123456789JjYWJj} test binary-72.29 {binary encode base64} { - string length [binary encode base64 -maxlen 3 -wrapchar \xca abc] + string length [binary encode base64 -maxlen 3 -wrapchar \xCA abc] } 5 test binary-73.1 {binary decode base64} -body { @@ -2661,19 +2664,19 @@ test binary-73.4 {binary decode base64} -body { } -result [string repeat abc 20] test binary-73.5 {binary decode base64} -body { binary decode base64 AAECAwQAAQID -} -result "\0\1\2\3\4\0\1\2\3" +} -result "\x00\x01\x02\x03\x04\x00\x01\x02\x03" test binary-73.6 {binary decode base64} -body { binary decode base64 AA== -} -result "\0" +} -result "\x00" test binary-73.7 {binary decode base64} -body { binary decode base64 AAA= -} -result "\0\0" +} -result "\x00\x00" test binary-73.8 {binary decode base64} -body { binary decode base64 AAAA -} -result "\0\0\0" +} -result "\x00\x00\x00" test binary-73.9 {binary decode base64} -body { binary decode base64 AAAAAA== -} -result "\0\0\0\0" +} -result "\x00\x00\x00\x00" test binary-73.10 {binary decode base64} -body { set s "[string repeat YWJj 10]\n[string repeat YWJj 10]" binary decode base64 $s @@ -2791,22 +2794,22 @@ test binary-74.4 {binary encode uuencode} -body { binary encode uuencode [string repeat abc 20] } -result "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" test binary-74.5 {binary encode uuencode} -body { - binary encode uuencode \0\1\2\3\4\0\1\2\3 + binary encode uuencode \x00\x01\x02\x03\x04\x00\x01\x02\x03 } -result ")``\$\"`P0``0(#\n" test binary-74.6 {binary encode uuencode} -body { binary encode uuencode \0 } -result {!`` } test binary-74.7 {binary encode uuencode} -body { - binary encode uuencode \0\0 + binary encode uuencode \x00\x00 } -result "\"``` " test binary-74.8 {binary encode uuencode} -body { - binary encode uuencode \0\0\0 + binary encode uuencode \x00\x00\x00 } -result {#```` } test binary-74.9 {binary encode uuencode} -body { - binary encode uuencode \0\0\0\0 + binary encode uuencode \x00\x00\x00\x00 } -result {$`````` } test binary-74.10 {binary encode uuencode} -returnCodes error -body { @@ -2842,7 +2845,7 @@ test binary-75.4 {binary decode uuencode} -body { } -result [string repeat abc 20] test binary-75.5 {binary decode uuencode} -body { binary decode uuencode ")``\$\"`P0``0(#" -} -result "\0\1\2\3\4\0\1\2\3" +} -result "\x00\x01\x02\x03\x04\x00\x01\x02\x03" test binary-75.6 {binary decode uuencode} -body { string length [binary decode uuencode "`\n"] } -result 0 @@ -2948,18 +2951,18 @@ test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength { testsetbytearraylength [string cat A B C] 1 } A test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength { - testsetbytearraylength [string cat \u0141 B C] 1 + testsetbytearraylength [string cat Ł B C] 1 } A test binary-80.1 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { - testbytestring "\u4E4E" -} -result "expected byte sequence but character 0 was '\u4E4E' (U+004E4E)" + testbytestring "乎" +} -result "expected byte sequence but character 0 was '乎' (U+004E4E)" test binary-80.2 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\x00\xA0\xA0\xA0\xE4\xB9\x8E"] -} -result "expected byte sequence but character 4 was '\u4E4E' (U+004E4E)" +} -result "expected byte sequence but character 4 was '乎' (U+004E4E)" test binary-80.3 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xE4\xB9\x8E"] -} -result "expected byte sequence but character 4 was '\u4E4E' (U+004E4E)" +} -result "expected byte sequence but character 4 was '乎' (U+004E4E)" test binary-80.4 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"] } -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)" diff --git a/tests/chan.test b/tests/chan.test index 3e65433..92846d5 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -48,10 +48,10 @@ test chan-4.1 {chan command: configure subcommand} -body { chan configure } -returnCodes error -result "wrong # args: should be \"chan configure channelId ?-option value ...?\"" test chan-4.2 {chan command: [Bug 800753]} -body { - chan configure stdout -eofchar \u0100 + chan configure stdout -eofchar Ā } -returnCodes error -match glob -result {bad value*} test chan-4.3 {chan command: [Bug 800753]} -body { - chan configure stdout -eofchar \u0000 + chan configure stdout -eofchar \x00 } -returnCodes error -match glob -result {bad value*} test chan-4.4 {chan command: check valid inValue, no outValue} -body { chan configure stdout -eofchar [list \x27 {}] diff --git a/tests/chanio.test b/tests/chanio.test index 04f0e3f..53e8020 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -79,7 +79,7 @@ namespace eval ::tcl::test::io { if {$argv != ""} { set f [open [lindex $argv 0]] } - chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a + chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A chan configure stdout -encoding binary -translation lf -buffering none chan event $f readable "foo $f" proc foo {f} { @@ -115,17 +115,17 @@ set path(test1) [makeFile {} test1] test chan-io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] chan configure $f -encoding binary - chan puts -nonewline $f "a\u4e4d\0" + chan puts -nonewline $f "a乍\x00" chan close $f contents $path(test1) -} "a\x4d\x00" +} "aM\x00" test chan-io-1.7 {Tcl_WriteChars: WriteChars} { set f [open $path(test1) w] chan configure $f -encoding shiftjis - chan puts -nonewline $f "a\u4e4d\0" + chan puts -nonewline $f "a乍\x00" chan close $f contents $path(test1) -} "a\x93\xe1\x00" +} "a\x93\xE1\x00" set path(test2) [makeFile {} test2] test chan-io-1.8 {Tcl_WriteChars: WriteChars} { # This test written for SF bug #506297. @@ -138,7 +138,7 @@ test chan-io-1.8 {Tcl_WriteChars: WriteChars} { chan puts -nonewline $f [format %s%c [string repeat " " 4] 12399] chan close $f contents $path(test2) -} " \x1b\$B\$O\x1b(B" +} " \x1B\$B\$O\x1B(B" test chan-io-1.9 {Tcl_WriteChars: WriteChars} { # When closing a channel with an encoding that appends escape bytes, check # for the case where the escape bytes overflow the current IO buffer. The @@ -273,13 +273,13 @@ test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { # to the beginning of that UTF-8 character and try again. # # Translate the first 16 bytes, produce 14 bytes of output, 2 left over - # (first two bytes of \uff21 in UTF-8). Given those two bytes try + # (first two bytes of Ａ in UTF-8). Given those two bytes try # translating them again, find that no bytes are read produced, and break # to outer loop where those two bytes will have the remaining 4 bytes (the - # last byte of \uff21 plus the all of \uff22) appended. + # last byte of Ａ plus the all of Ｂ) appended. set f [open $path(test1) w] chan configure $f -encoding shiftjis -buffersize 16 - chan puts -nonewline $f "12345678901234\uff21\uff22" + chan puts -nonewline $f "12345678901234ＡＢ" set x [list [contents $path(test1)]] chan close $f lappend x [contents $path(test1)] @@ -421,7 +421,7 @@ test chan-io-6.3 {Tcl_GetsObj: how many have we used?} -body { test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} -body { set f [open $path(test1) w] chan configure $f -translation binary - chan puts $f "\x81\u1234\0" + chan puts $f "\x81\u1234\x00" chan close $f set f [open $path(test1)] chan configure $f -translation binary @@ -432,14 +432,14 @@ test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} -body { test chan-io-6.5 {Tcl_GetsObj: encoding != NULL} -body { set f [open $path(test1) w] chan configure $f -translation binary - chan puts $f "\x88\xea\x92\x9a" + chan puts $f "\x88\xEA\x92\x9A" chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis list [chan gets $f line] $line } -cleanup { chan close $f -} -result [list 2 "\u4e00\u4e01"] +} -result [list 2 "一丁"] set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a @@ -467,20 +467,20 @@ test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints stdio -body { } -result {-1} test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} -body { set f [open $path(test1) w] - chan puts $f "abcdef\x1aghijk\nwombat" + chan puts $f "abcdef\x1Aghijk\nwombat" chan close $f set f [open $path(test1)] - chan configure $f -eofchar \x1a + chan configure $f -eofchar \x1A list [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f } -result {6 abcdef -1 {}} test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} -body { set f [open $path(test1) w] - chan puts $f "abcdefghijk\nwom\u001abat" + chan puts $f "abcdefghijk\nwom\x1Abat" chan close $f set f [open $path(test1)] - chan configure $f -eofchar \x1a + chan configure $f -eofchar \x1A list [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f @@ -865,7 +865,7 @@ test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { chan configure $f -blocking 0 lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan configure $f -blocking 1 - chan puts -nonewline $f "\nabcd\refg\x1a" + chan puts -nonewline $f "\nabcd\refg\x1A" lappend x [chan gets $f line] $line [testchannel queuedcr $f] lappend x [chan gets $f line] $line } -cleanup { @@ -883,7 +883,7 @@ test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { chan configure $f -blocking 0 lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan configure $f -blocking 1 - chan puts -nonewline $f "abcd\refg\x1a" + chan puts -nonewline $f "abcd\refg\x1A" lappend x [chan gets $f line] $line [testchannel queuedcr $f] lappend x [chan gets $f line] $line } -cleanup { @@ -919,7 +919,7 @@ test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eo chan configure $f -blocking 0 lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan configure $f -blocking 1 - chan puts -nonewline $f "\n\x1a" + chan puts -nonewline $f "\n\x1A" lappend x [chan gets $f line] $line [testchannel queuedcr $f] } -cleanup { chan close $f @@ -985,10 +985,10 @@ test chan-io-6.52 {Tcl_GetsObj: saw EOF character} -constraints {testchannel} -b # if (eof != NULL) set f [open $path(test1) w] chan configure $f -translation lf - chan puts -nonewline $f "123456\x1ak9012345\r" + chan puts -nonewline $f "123456\x1Ak9012345\r" chan close $f set f [open $path(test1)] - chan configure $f -eofchar \x1a + chan configure $f -eofchar \x1A list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] } -cleanup { chan close $f @@ -1016,14 +1016,14 @@ test chan-io-6.55 {Tcl_GetsObj: overconverted} -body { # Tcl_ExternalToUtf(), make sure state updated set f [open $path(test1) w] chan configure $f -encoding iso2022-jp - chan puts $f "there\u4e00ok\n\u4e01more bytes\nhere" + chan puts $f "there一ok\n丁more bytes\nhere" chan close $f set f [open $path(test1)] chan configure $f -encoding iso2022-jp list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f -} -result [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] +} -result [list 8 "there一ok" 11 "丁more bytes" 4 "here"] test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup { update variable x {} @@ -1057,19 +1057,19 @@ test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} -body { # (result == TCL_CONVERT_MULTIBYTE) set f [open $path(test1) w] chan configure $f -encoding shiftjis - chan puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend" + chan puts $f "1234567890123０１２３４\nend" chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis -buffersize 16 chan gets $f } -cleanup { chan close $f -} -result "1234567890123\uff10\uff11\uff12\uff13\uff14" +} -result "1234567890123０１２３４" test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} -body { # (bufPtr->nextAdded < bufPtr->bufLength) set f [open $path(test1) w] chan configure $f -encoding binary - chan puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" + chan puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82" chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis @@ -1082,7 +1082,7 @@ test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup { } -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -encoding binary - chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis @@ -1091,13 +1091,13 @@ test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup { lappend x [chan gets $f line] $line } -cleanup { chan close $f -} -result [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] +} -result [list 15 "1234567890123０１" 18 0 1 -1 ""] test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup { variable x "" } -constraints {stdio fileevent} -body { set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none - chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" chan configure $f -encoding shiftjis -blocking 0 chan event $f read [namespace code { lappend x [chan gets $f line] $line [chan blocked $f] @@ -1110,7 +1110,7 @@ test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup { return $x } -cleanup { chan close $f -} -result [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] +} -result [list -1 "" 1 17 "1234567890123０１２３" 0] test chan-io-8.1 {PeekAhead: only go to device if no more cached data} -constraints {testchannel} -body { # (bufPtr->nextPtr == NULL) @@ -1205,7 +1205,7 @@ test chan-io-8.7 {PeekAhead: cleanup} -setup { chan puts -nonewline $f "abcdefghijklmno\r" # here lappend x [chan gets $f line] $line [testchannel queuedcr $f] - chan puts -nonewline $f "\x1a" + chan puts -nonewline $f "\x1A" lappend x [chan gets $f line] $line } -cleanup { chan close $f @@ -1361,22 +1361,22 @@ test chan-io-12.4 {ReadChars: split-up char} -setup { chan configure $f -encoding shiftjis vwait [namespace which -variable x] chan configure $f -encoding binary -blocking 1 - chan puts -nonewline $f "\x7b" + chan puts -nonewline $f "\x7B" after 500 ;# Give the cat process time to catch up chan configure $f -encoding shiftjis -blocking 0 vwait [namespace which -variable x] return $x } -cleanup { chan close $f -} -result [list "123456789012345" 1 "\u672c" 0] +} -result [list "123456789012345" 1 "本" 0] test chan-io-12.5 {ReadChars: chan events on partial characters} -setup { variable x {} } -constraints {stdio fileevent} -body { set path(test1) [makeFile { chan configure stdout -encoding binary -buffering none - chan gets stdin; chan puts -nonewline "\xe7" + chan gets stdin; chan puts -nonewline "\xE7" chan gets stdin; chan puts -nonewline "\x89" - chan gets stdin; chan puts -nonewline "\xa6" + chan gets stdin; chan puts -nonewline "\xA6" } test1] set f [openpipe r+ $path(test1)] chan event $f readable [namespace code { @@ -1401,7 +1401,7 @@ test chan-io-12.5 {ReadChars: chan events on partial characters} -setup { vwait [namespace which -variable x] vwait [namespace which -variable x] lappend x [catch {chan close $f} msg] $msg -} -result "{} timeout {} timeout \u7266 {} eof 0 {}" +} -result "{} timeout {} timeout 牦 {} eof 0 {}" test chan-io-13.1 {TranslateInputEOL: cr mode} -body { set f [open $path(test1) w] @@ -1530,7 +1530,7 @@ test chan-io-13.10 {TranslateInputEOL: auto mode: \n} -body { chan close $f } -result "abcd\ndef" test chan-io-13.11 {TranslateInputEOL: EOF char} -body { - # (*chanPtr->inEofChar != '\0') + # (*chanPtr->inEofChar != '\x00') set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\ndefgh" @@ -1542,7 +1542,7 @@ test chan-io-13.11 {TranslateInputEOL: EOF char} -body { chan close $f } -result "abcd\nd" test chan-io-13.12 {TranslateInputEOL: find EOF char in src} -body { - # (*chanPtr->inEofChar != '\0') + # (*chanPtr->inEofChar != '\x00') set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n" @@ -1878,7 +1878,7 @@ test chan-io-20.2 {Tcl_CreateChannel: initial settings} -constraints {win} -body list [chan configure $f -eofchar] [chan configure $f -translation] } -cleanup { chan close $f -} -result [list [list \x1a ""] {auto crlf}] +} -result [list [list \x1A ""] {auto crlf}] test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -body { set f [open $path(test1) w+] list [chan configure $f -eofchar] [chan configure $f -translation] @@ -3091,10 +3091,10 @@ test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} -setup { } -body { set f [open $path(test1) w] chan configure $f -translation lf - chan puts -nonewline $f hello\nthere\nand\rhere\n\x1a + chan puts -nonewline $f hello\nthere\nand\rhere\n\x1A chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A chan read $f } -cleanup { chan close $f @@ -3107,11 +3107,11 @@ test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} -setup { file delete $path(test1) } -constraints {win} -body { set f [open $path(test1) w] - chan configure $f -eofchar \x1a -translation lf + chan configure $f -translation lf -eofchar \x1A chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A chan read $f } -cleanup { chan close $f @@ -3129,7 +3129,7 @@ test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $s chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A set l "" lappend l [chan gets $f] lappend l [chan gets $f] @@ -3150,7 +3150,7 @@ test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} -setup { chan puts $f $s chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A set l "" lappend l [chan gets $f] lappend l [chan gets $f] @@ -3183,7 +3183,7 @@ test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} -setup { lappend l [chan eof $f] } -cleanup { chan close $f -} -result "abc def 0 \x1aghi 0 qrs 0 {} 1" +} -result "abc def 0 \x1Aghi 0 qrs 0 {} 1" test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} -setup { file delete $path(test1) set l "" @@ -3195,7 +3195,7 @@ test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} -setup { set f [open $path(test1) r] chan configure $f -translation cr -eofchar {} set x [chan gets $f] - lappend l [string equal $x "abc\ndef\n\x1aghi\nqrs\n"] + lappend l [string equal $x "abc\ndef\n\x1Aghi\nqrs\n"] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3213,7 +3213,7 @@ test chan-io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} -setup { set f [open $path(test1) r] chan configure $f -translation crlf -eofchar {} set x [chan gets $f] - lappend l [string equal $x "abc\ndef\n\x1aghi\nqrs\n"] + lappend l [string equal $x "abc\ndef\n\x1Aghi\nqrs\n"] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3228,7 +3228,7 @@ test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} -setup { chan puts $f [format abc\ndef\n%cqrs\ntuv 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3242,7 +3242,7 @@ test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3256,7 +3256,7 @@ test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3270,7 +3270,7 @@ test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3284,7 +3284,7 @@ test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3298,7 +3298,7 @@ test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3649,7 +3649,7 @@ test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} -setup { chan puts $f [format "hello\nthere\nand\rhere\n\%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3665,11 +3665,11 @@ test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} -setup { set l "" } -body { set f [open $path(test1) w] - chan configure $f -eofchar \x1a -translation lf + chan configure $f -translation lf -eofchar \x1A chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3689,8 +3689,7 @@ test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a - chan configure $f -translation auto + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3708,7 +3707,7 @@ test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3738,7 +3737,7 @@ test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} -setup { lappend l [chan eof $f] } -cleanup { chan close $f -} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1" +} -result "abc def 0 \x1Aqrs 0 tuv 0 {} 1" test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} -setup { file delete $path(test1) set l "" @@ -3760,7 +3759,7 @@ test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} -setup { lappend l [chan eof $f] } -cleanup { chan close $f -} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1" +} -result "abc def 0 \x1Aqrs 0 tuv 0 {} 1" test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} -setup { file delete $path(test1) set l "" @@ -3782,7 +3781,7 @@ test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} -setup { lappend l [chan eof $f] } -cleanup { chan close $f -} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1" +} -result "abc def 0 \x1Aqrs 0 tuv 0 {} 1" test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} -setup { file delete $path(test1) set l "" @@ -3792,7 +3791,7 @@ test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3810,7 +3809,7 @@ test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3828,7 +3827,7 @@ test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3846,7 +3845,7 @@ test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3864,7 +3863,7 @@ test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3882,7 +3881,7 @@ test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -4638,12 +4637,12 @@ test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4652,12 +4651,12 @@ test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4666,12 +4665,12 @@ test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4680,12 +4679,12 @@ test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4694,12 +4693,12 @@ test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4708,12 +4707,12 @@ test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4727,7 +4726,7 @@ test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4741,7 +4740,7 @@ test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4755,7 +4754,7 @@ test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4769,7 +4768,7 @@ test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4783,7 +4782,7 @@ test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4797,7 +4796,7 @@ test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -5167,27 +5166,27 @@ test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup { } -body { set f [open $path(test1) w] chan configure $f -encoding {} - chan puts -nonewline $f \xe7\x89\xa6 + chan puts -nonewline $f \xE7\x89\xA6 chan close $f set f [open $path(test1) r] chan configure $f -encoding utf-8 chan read $f } -cleanup { chan close $f -} -result \u7266 +} -result 牦 test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] chan configure $f -encoding binary - chan puts -nonewline $f \xe7\x89\xa6 + chan puts -nonewline $f \xE7\x89\xA6 chan close $f set f [open $path(test1) r] chan configure $f -encoding utf-8 chan read $f } -cleanup { chan close $f -} -result \u7266 +} -result 牦 test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup { file delete $path(test1) set f [open $path(test1) w] @@ -5201,7 +5200,7 @@ test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_ } -constraints {stdio fileevent} -body { set f [openpipe r+ $path(cat)] chan configure $f -encoding binary - chan puts -nonewline $f "\xe7" + chan puts -nonewline $f "\xE7" chan flush $f chan configure $f -encoding utf-8 -blocking 0 chan event $f readable [namespace code { lappend x [chan read $f] }] @@ -5219,7 +5218,7 @@ test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_ return $x } -cleanup { chan close $f -} -result "{} timeout {} timeout \xe7 timeout" +} -result "{} timeout {} timeout \xE7 timeout" test chan-io-39.18 {Tcl_SetChannelOption, setting read mode independently} \ -constraints {socket} -body { proc accept {s a p} {chan close $s} @@ -5533,11 +5532,11 @@ test chan-io-42.2 {Tcl_FileeventCmd: replacing} {fileevent} { } {{first script} {new script} {yet another} {}} test chan-io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {fileevent} { set result {} - chan event $f r "first scr\0ipt" + chan event $f r "first scr\x00ipt" lappend result [string length [chan event $f readable]] - chan event $f r "new scr\0ipt" + chan event $f r "new scr\x00ipt" lappend result [string length [chan event $f readable]] - chan event $f r "yet ano\0ther" + chan event $f r "yet ano\x00ther" lappend result [string length [chan event $f readable]] chan event $f r "" lappend result [chan event $f readable] @@ -5983,7 +5982,7 @@ test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6007,7 +6006,7 @@ test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6031,7 +6030,7 @@ test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6055,7 +6054,7 @@ test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6079,7 +6078,7 @@ test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mo chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6103,7 +6102,7 @@ test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6127,7 +6126,7 @@ test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} - chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation lf + chan configure $f -translation lf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6151,7 +6150,7 @@ test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6175,7 +6174,7 @@ test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} - chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation cr + chan configure $f -translation cr -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6199,7 +6198,7 @@ test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6223,7 +6222,7 @@ test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mod chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation crlf + chan configure $f -translation crlf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6247,7 +6246,7 @@ test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} - chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6784,7 +6783,7 @@ set path(utf8-rp.txt) [makeFile {} utf8-rp.txt] # Create kyrillic file, use lf translation to avoid os eol issues set out [open $path(kyrillic.txt) w] chan configure $out -encoding koi8-r -translation lf -chan puts $out "\u0410\u0410" +chan puts $out "АА" chan close $out test chan-io-52.9 {TclCopyChannel & encodings} {fcopy} { # Copy kyrillic to UTF-8, using chan copy. @@ -6822,7 +6821,7 @@ test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} { test chan-io-52.11 {TclCopyChannel & encodings} -setup { set f [open $path(utf8-fcopy.txt) w] fconfigure $f -encoding utf-8 -translation lf - puts $f "\u0410\u0410" + puts $f "АА" close $f } -constraints {fcopy} -body { # binary to encoding => the input has to be in utf-8 to make sense to the @@ -7496,7 +7495,7 @@ test chan-io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { set out [open $path(script) w] chan puts $out "catch {load $::tcltestlib Tcltest}" chan puts $out { - chan puts [testbytestring \xe2] + chan puts [testbytestring \xE2] exit 1 } proc readit {pipe} { @@ -7519,7 +7518,7 @@ test chan-io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # cut of the remainder of the error stack, especially the filename set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]] list $x $result -} {1 {gets {} catch {error writing "stdout": invalid argument}}} +} {1 {gets {} catch {error writing "stdout": illegal byte sequence}}} test chan-io-61.1 {Reset eof state after changing the eof char} -setup { set datafile [makeFile {} eofchar] diff --git a/tests/clock.test b/tests/clock.test index 37c8066..2a53259 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -234,7 +234,7 @@ namespace eval ::testClock { Bias 300 \ StandardBias 0 \ DaylightBias -60 \ - StandardStart \x00\x00\x0b\x00\x01\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00 \ + StandardStart \x00\x00\x0B\x00\x01\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00 \ DaylightStart \x00\x00\x03\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00]] } @@ -36789,16 +36789,16 @@ test clock-58.1 {clock l10n - Japanese localisation} {*}{ -body { set trouble {} foreach {date jdate} { - 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 - 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 - 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 - 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 - 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 - 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 - 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 - 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 - 2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5 - 2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5 + 1872-12-31 西暦1872年12月31日 + 1873-01-01 明治06年01月01日 + 1912-07-29 明治45年07月29日 + 1912-07-30 大正01年07月30日 + 1926-12-24 大正15年12月24日 + 1926-12-25 昭和01年12月25日 + 1989-01-07 昭和64年01月07日 + 1989-01-08 平成01年01月08日 + 2019-04-30 平成31年04月30日 + 2019-05-01 令和01年05月01日 } { set status [catch { set secs [clock scan $date \ diff --git a/tests/cmdAH.test b/tests/cmdAH.test index baa148e..5fefbeb 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -149,10 +149,10 @@ test cmdAH-2.6.2 {cd} -constraints {unix nonPortable} -setup { test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -setup { set dir [pwd] } -returnCodes error -body { - cd .\0 + cd .\x00 } -cleanup { cd $dir -} -match glob -result "couldn't change working directory to \".\0\": *" +} -match glob -result "couldn't change working directory to \".\x00\": *" test cmdAH-2.7 {Tcl_ConcatObjCmd} { concat } {} @@ -186,7 +186,7 @@ test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { encoding system jis0208 - encoding convertto \u4e4e + encoding convertto 乎 } -cleanup { encoding system $system } -result 8C @@ -194,7 +194,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { encoding system iso8859-1 - encoding convertto jis0208 \u4e4e + encoding convertto jis0208 乎 } -cleanup { encoding system $system } -result 8C @@ -211,7 +211,7 @@ test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup { encoding convertfrom 8C } -cleanup { encoding system $system -} -result \u4e4e +} -result 乎 test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { @@ -219,7 +219,7 @@ test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup { encoding convertfrom jis0208 8C } -cleanup { encoding system $system -} -result \u4e4e +} -result 乎 test cmdAH-4.11 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding names foo } -result {wrong # args: should be "encoding names"} @@ -1221,7 +1221,7 @@ test cmdAH-24.9 {Tcl_FileObjCmd: mtime touch with non-ascii chars} -setup { set oldfile $file } -constraints unix -body { # introduce some non-ascii characters. - append file \u2022 + append file • file delete -force $file file rename $oldfile $file set mtime [file mtime $file] @@ -1246,7 +1246,7 @@ test cmdAH-24.11 {Tcl_FileObjCmd: mtime touch with non-ascii chars} -setup { set oldfile $file } -constraints win -body { # introduce some non-ascii characters. - append file \u2022 + append file • file delete -force $file file rename $oldfile $file set mtime [file mtime $file] diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 83fe80e..063750c 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -151,17 +151,17 @@ test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} { } } {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}} test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { - lsort -ascii [list \0 \x7f \x80 \uffff] -} [list \0 \x7f \x80 \uffff] + lsort -ascii [list \x00 \x7F \x80 \uFFFF] +} [list \x00 \x7F \x80 \uFFFF] test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { - lsort -ascii -nocase [list \0 \x7f \x80 \uffff] -} [list \0 \x7f \x80 \uffff] + lsort -ascii -nocase [list \x00 \x7F \x80 \uFFFF] +} [list \x00 \x7F \x80 \uFFFF] test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { - lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff] -} [list \0 \x7f \x80 \uffff \U01ffff] + lsort -ascii [list \x00 \x7F \x80 \U01ffff \uFFFF] +} [list \x00 \x7F \x80 \uFFFF \U01ffff] test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { - lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff] -} [list \0 \x7f \x80 \uffff \U01ffff] + lsort -ascii -nocase [list \x00 \x7F \x80 \U01ffff \uFFFF] +} [list \x00 \x7F \x80 \uFFFF \U01FFFF] test cmdIL-1.41 {lsort -stride and -index} -body { lsort -stride 2 -index -2 {a 2 b 1} } -returnCodes error -result {index "-2" out of range} @@ -177,7 +177,7 @@ test cmdIL-2.1 {MergeSort and MergeLists procedures} -setup { set r 1435753299 proc rand {} { global r - set r [expr {(16807 * $r) % (0x7fffffff)}] + set r [expr {(16807 * $r) % (0x7FFFFFFF)}] } } -body { for {set i 0} {$i < 150} {incr i} { @@ -396,16 +396,16 @@ test cmdIL-4.23 {DictionaryCompare procedure, case} { } {ABcd AbCd} test cmdIL-4.24 {DictionaryCompare procedure, international characters} {hasIsoLocale} { ::tcltest::set_iso8859_1_locale - set result [lsort -dictionary "a b c A B C \xe3 \xc4"] + set result [lsort -dictionary "a b c A B C ã Ä"] ::tcltest::restore_locale set result -} "A a B b C c \xe3 \xc4" +} "A a B b C c ã Ä" test cmdIL-4.25 {DictionaryCompare procedure, international characters} {hasIsoLocale} { ::tcltest::set_iso8859_1_locale - set result [lsort -dictionary "a23\xe3 a23\xc5 a23\xe4"] + set result [lsort -dictionary "a23ã a23Å a23ä"] ::tcltest::restore_locale set result -} "a23\xe3 a23\xe4 a23\xc5" +} "a23ã a23ä a23Å" test cmdIL-4.26 {DefaultCompare procedure, signed characters} { set l [lsort [list "abc\200" "abc"]] set viewlist {} @@ -472,10 +472,10 @@ test cmdIL-4.36 {SortCompare procedure, UTF-8 with -nocase option} { scan [lsort -ascii -nocase [list \u101 \u100]] %c%c%c } {257 32 256} test cmdIL-4.37 {SortCompare procedure, UTF-8 with -nocase option} { - scan [lsort -ascii -nocase [list a\u0000a a]] %c%c%c%c%c + scan [lsort -ascii -nocase [list a\x00a a]] %c%c%c%c%c } {97 32 97 0 97} test cmdIL-4.38 {SortCompare procedure, UTF-8 with -nocase option} { - scan [lsort -ascii -nocase [list a a\u0000a]] %c%c%c%c%c + scan [lsort -ascii -nocase [list a a\x00a]] %c%c%c%c%c } {97 32 97 0 97} test cmdIL-5.1 {lsort with list style index} { diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index ef9790f..a1cb6c2 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -299,19 +299,19 @@ test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} { } {]\n} test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} { apply {{} { - set x ab\000c + set x ab\x00c set y [split $x {}] binary scan $y c* z return $z }} } {97 32 98 32 0 32 99} test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} { - split "a0ab1b2bbb3\000c4" ab\000c + split "a0ab1b2bbb3\x00c4" ab\x00c } {{} 0 {} 1 2 {} {} 3 {} 4} test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { - # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq" - split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e" -} "a b qw\u5e4eN wq" + # if not UTF-8 aware, result is "a {} {} b qwå {} N wq" + split "a乎b qw幎N wq" " 乎" +} "a b qw幎N wq" # The tests for Tcl_StringObjCmd are in string.test # The tests for Tcl_SubstObjCmd are in subst.test diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index 03c5dc9..b70e65c 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -29,9 +29,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -41,19 +41,19 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -63,11 +63,11 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 diff --git a/tests/compile.test b/tests/compile.test index 23d81dd..31af2e2 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -286,10 +286,10 @@ test compile-7.1 {TclCompileWhileCmd: command substituted test expression} { } {4} test compile-8.1 {CollectArgInfo: binary data} { - list [catch "string length \000foo" msg] $msg + list [catch "string length \x00foo" msg] $msg } {0 4} test compile-8.2 {CollectArgInfo: binary data} { - list [catch "string length foo\000" msg] $msg + list [catch "string length foo\x00" msg] $msg } {0 4} test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} { set x ] diff --git a/tests/encoding.test b/tests/encoding.test index b1150c6..0e80c09 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -183,7 +183,7 @@ test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { test encoding-8.1 {Tcl_ExternalToUtf} { set f [open [file join [temporaryDirectory] dummy] w] fconfigure $f -translation binary -encoding iso8859-1 - puts -nonewline $f "ab\x8c\xc1g" + puts -nonewline $f "ab\x8C\xC1g" close $f set f [open [file join [temporaryDirectory] dummy] r] fconfigure $f -translation binary -encoding shiftjis @@ -219,7 +219,7 @@ test encoding-10.1 {Tcl_UtfToExternal} { close $f file delete [file join [temporaryDirectory] dummy] return $x -} "ab\x8c\xc1g" +} "ab\x8C\xC1g" proc viewable {str} { set res "" @@ -227,7 +227,7 @@ proc viewable {str} { if {[string is print $c] && [string is ascii $c]} { append res $c } else { - append res "\\u[format %4.4x [scan $c %c]]" + append res "\\u[format %4.4X [scan $c %c]]" } } return "$str ($res)" @@ -258,7 +258,7 @@ test encoding-11.5 {LoadEncodingFile: escape file} { } [viewable "\x1B\$B8C\x1B(B"] test encoding-11.5.1 {LoadEncodingFile: escape file} { viewable [encoding convertto iso2022-jp 乎] -} [viewable "\x1b\$B8C\x1b(B"] +} [viewable "\x1B\$B8C\x1B(B"] test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup { set system [encoding system] set path [encoding dirs] @@ -283,24 +283,24 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} } -result {invalid encoding file "splat"} test encoding-11.8 {encoding: extended Unicode UTF-16} { viewable [encoding convertto utf-16le 😹] -} {=Ø9Þ (=\u00d89\u00de)} +} {=Ø9Þ (=\u00D89\u00DE)} test encoding-11.9 {encoding: extended Unicode UTF-16} { viewable [encoding convertto utf-16be 😹] -} {Ø=Þ9 (\u00d8=\u00de9)} +} {Ø=Þ9 (\u00D8=\u00DE9)} # OpenEncodingFile is fully tested by the rest of the tests in this file. test encoding-12.1 {LoadTableEncoding: normal encoding} { - set x [encoding convertto iso8859-3 \u0120] - append x [encoding convertto iso8859-3 \xD5] - append x [encoding convertfrom iso8859-3 \xD5] -} "\xD5?\u120" + set x [encoding convertto iso8859-3 Ġ] + append x [encoding convertto iso8859-3 Õ] + append x [encoding convertfrom iso8859-3 Õ] +} "Õ?Ġ" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { - set x [encoding convertto iso8859-3 ab\u0120g] - append x [encoding convertfrom iso8859-3 ab\xD5g] -} "ab\xD5gab\u120g" + set x [encoding convertto iso8859-3 abĠg] + append x [encoding convertfrom iso8859-3 abÕg] +} "abÕgabĠg" test encoding-12.3 {LoadTableEncoding: multi-byte encoding} { set x [encoding convertto shiftjis ab乎g] - append x [encoding convertfrom shiftjis ab\x8c\xc1g] + append x [encoding convertfrom shiftjis ab\x8C\xC1g] } "ab\x8C\xC1gab乎g" test encoding-12.4 {LoadTableEncoding: double-byte encoding} { set x [encoding convertto jis0208 乎α] @@ -317,7 +317,7 @@ test encoding-13.1 {LoadEscapeTable} { } [viewable "ab\x1B\$B8C\x1B\$\(DD%\x1B(Bg"] test encoding-15.1 {UtfToUtfProc} { - encoding convertto utf-8 \xA3 + encoding convertto utf-8 £ } "\xC2\xA3" test encoding-15.2 {UtfToUtfProc null character output} testbytestring { binary scan [testbytestring [encoding convertto utf-8 \x00]] H* z @@ -343,61 +343,61 @@ test encoding-15.6 {UtfToUtfProc emoji character output} { set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D] binary scan $y H* z list [string length $y] $z -} {10 edb882f09f9882eda0bd} +} {10 efbfbdf09f9882efbfbd} test encoding-15.7 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D set y [encoding convertto utf-8 \uDE02\uD83D\uD83D] binary scan $y H* z list [string length $x] [string length $y] $z -} {3 9 edb882eda0bdeda0bd} +} {3 9 efbfbdefbfbdefbfbd} test encoding-15.8 {UtfToUtfProc emoji character output} { - set x \uDE02\uD83D\xE9 - set y [encoding convertto utf-8 \uDE02\uD83D\xE9] + set x \uDE02\uD83Dé + set y [encoding convertto utf-8 \uDE02\uD83Dé] binary scan $y H* z list [string length $x] [string length $y] $z -} {3 8 edb882eda0bdc3a9} +} {3 8 efbfbdefbfbdc3a9} test encoding-15.9 {UtfToUtfProc emoji character output} { set x \uDE02\uD83DX set y [encoding convertto utf-8 \uDE02\uD83DX] binary scan $y H* z list [string length $x] [string length $y] $z -} {3 7 edb882eda0bd58} +} {3 7 efbfbdefbfbd58} test encoding-15.10 {UtfToUtfProc high surrogate character output} { - set x \uDE02\xE9 - set y [encoding convertto utf-8 \uDE02\xE9] + set x \uDE02é + set y [encoding convertto utf-8 \uDE02é] binary scan $y H* z list [string length $x] [string length $y] $z -} {2 5 edb882c3a9} +} {2 5 efbfbdc3a9} test encoding-15.11 {UtfToUtfProc low surrogate character output} { - set x \uDA02\xE9 - set y [encoding convertto utf-8 \uDA02\xE9] + set x \uDA02é + set y [encoding convertto utf-8 \uDA02é] binary scan $y H* z list [string length $x] [string length $y] $z -} {2 5 eda882c3a9} +} {2 5 efbfbdc3a9} test encoding-15.12 {UtfToUtfProc high surrogate character output} { set x \uDE02Y set y [encoding convertto utf-8 \uDE02Y] binary scan $y H* z list [string length $x] [string length $y] $z -} {2 4 edb88259} +} {2 4 efbfbd59} test encoding-15.13 {UtfToUtfProc low surrogate character output} { set x \uDA02Y set y [encoding convertto utf-8 \uDA02Y] binary scan $y H* z list [string length $x] [string length $y] $z -} {2 4 eda88259} +} {2 4 efbfbd59} test encoding-15.14 {UtfToUtfProc high surrogate character output} { set x \uDE02 set y [encoding convertto utf-8 \uDE02] binary scan $y H* z list [string length $x] [string length $y] $z -} {1 3 edb882} +} {1 3 efbfbd} test encoding-15.15 {UtfToUtfProc low surrogate character output} { set x \uDA02 set y [encoding convertto utf-8 \uDA02] binary scan $y H* z list [string length $x] [string length $y] $z -} {1 3 eda882} +} {1 3 efbfbd} test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { set x \xF0\xA0\xA1\xC2 set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2] @@ -409,6 +409,26 @@ test encoding-15.17 {UtfToUtfProc emoji character output} { binary scan $y H* z list [string length $y] $z } {4 f09f9882} +test encoding-15.18 {UtfToUtfProc CESU-8 6-byte sequence} { + set y [encoding convertto cesu-8 \U10000] + binary scan $y H* z + list [string length $y] $z +} {6 eda080edb080} +test encoding-15.19 {UtfToUtfProc CESU-8 upper surrogate} { + set y [encoding convertto cesu-8 \uD800] + binary scan $y H* z + list [string length $y] $z +} {3 eda080} +test encoding-15.20 {UtfToUtfProc CESU-8 lower surrogate} { + set y [encoding convertto cesu-8 \uDC00] + binary scan $y H* z + list [string length $y] $z +} {3 edb080} +test encoding-15.21 {UtfToUtfProc CESU-8 noncharacter} { + set y [encoding convertto cesu-8 \uFFFF] + binary scan $y H* z + list [string length $y] $z +} {3 efbfbf} test encoding-16.1 {Utf16ToUtfProc} -body { set val [encoding convertfrom utf-16 NN] @@ -425,7 +445,7 @@ test encoding-16.3 {Utf16ToUtfProc} -body { test encoding-16.4 {Ucs2ToUtfProc} -body { set val [encoding convertfrom ucs-2 NN] list $val [format %x [scan $val %c]] -} -result "\u4E4E 4e4e" +} -result "乎 4e4e" test encoding-16.4 {Ucs2ToUtfProc} -body { set val [encoding convertfrom ucs-2 "\xD8\xD8\xDC\xDC"] list $val [format %x [scan $val %c]] @@ -434,15 +454,15 @@ test encoding-16.4 {Ucs2ToUtfProc} -body { test encoding-17.1 {UtfToUtf16Proc} -body { encoding convertto utf-16 "\U460DC" } -result "\xD8\xD8\xDC\xDC" -test encoding-17.2 {UtfToUtf16Proc} -body { - encoding convertto utf-16 "\uDCDC" -} -result "\xDC\xDC" -test encoding-17.3 {UtfToUtf16Proc} -body { - encoding convertto utf-16 "\uD8D8" -} -result "\xD8\xD8" -test encoding-17.4 {UtfToUcs2Proc} -body { +test encoding-17.2 {UtfToUcs2Proc} -body { encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] } -result "\uFFFD" +test encoding-17.3 {UtfToUtf16Proc} -body { + encoding convertto utf-16be "\uDCDC" +} -result "\xFF\xFD" +test encoding-17.4 {UtfToUtf16Proc} -body { + encoding convertto utf-16le "\uD8D8" +} -result "\xFD\xFF" test encoding-18.1 {TableToUtfProc} { } {} @@ -459,18 +479,18 @@ test encoding-21.1 {EscapeToUtfProc} { test encoding-22.1 {EscapeFromUtfProc} { } {} -set iso2022encData "\u001b\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\u001b(B -\u001b\$B>.@Z<jAwIU@h\$H\$7\$F;HMQ\$7\$F\$*\$j\$^\$9!#62\$lF~\$j\$^\$9\$,!\"@5\$7\$\$=;=j\$r\$4EPO?\$7\$J\$*\u001b(B -\u001b\$B\$*4j\$\$\$\$\$?\$7\$^\$9!#\$^\$?!\"BgJQ62=L\$G\$9\$,!\"=;=jJQ99\$N\$\"\$H!\"F|K\\8l%5!<%S%9It!J\u001b(B -casino_japanese@___.com \u001b\$B!K\$^\$G\$4=;=jJQ99:Q\$NO\"Mm\$r\$\$\$?\$@\$1\$J\$\$\$G\u001b(B -\u001b\$B\$7\$g\$&\$+!)\u001b(B" +set iso2022encData "\x1B\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\x1B(B +\x1B\$B>.@Z<jAwIU@h\$H\$7\$F;HMQ\$7\$F\$*\$j\$^\$9!#62\$lF~\$j\$^\$9\$,!\"@5\$7\$\$=;=j\$r\$4EPO?\$7\$J\$*\x1B(B +\x1B\$B\$*4j\$\$\$\$\$?\$7\$^\$9!#\$^\$?!\"BgJQ62=L\$G\$9\$,!\"=;=jJQ99\$N\$\"\$H!\"F|K\\8l%5!<%S%9It!J\x1B(B +casino_japanese@___.com \x1B\$B!K\$^\$G\$4=;=jJQ99:Q\$NO\"Mm\$r\$\$\$?\$@\$1\$J\$\$\$G\x1B(B +\x1B\$B\$7\$g\$&\$+!)\x1B(B" set iso2022uniData [encoding convertfrom iso2022-jp $iso2022encData] -set iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u3054\u8cfc\u5165\u6642\u306b\u3054\u767b\u9332\u3044\u305f\u3060\u3044\u305f\u3054\u4f4f\u6240\u3092\u30ad\u30e3\u30c3\u30b7\u30e5\u30a2\u30a6\u30c8\u306e\u969b\u306e -\u5c0f\u5207\u624b\u9001\u4ed8\u5148\u3068\u3057\u3066\u4f7f\u7528\u3057\u3066\u304a\u308a\u307e\u3059\u3002\u6050\u308c\u5165\u308a\u307e\u3059\u304c\u3001\u6b63\u3057\u3044\u4f4f\u6240\u3092\u3054\u767b\u9332\u3057\u306a\u304a -\u304a\u9858\u3044\u3044\u305f\u3057\u307e\u3059\u3002\u307e\u305f\u3001\u5927\u5909\u6050\u7e2e\u3067\u3059\u304c\u3001\u4f4f\u6240\u5909\u66f4\u306e\u3042\u3068\u3001\u65e5\u672c\u8a9e\u30b5\u30fc\u30d3\u30b9\u90e8\uff08 -\u0063\u0061\u0073\u0069\u006e\u006f\u005f\u006a\u0061\u0070\u0061\u006e\u0065\u0073\u0065\u0040\u005f\u005f\u005f\u002e\u0063\u006f\u006d\u0020\uff09\u307e\u3067\u3054\u4f4f\u6240\u5909\u66f4\u6e08\u306e\u9023\u7d61\u3092\u3044\u305f\u3060\u3051\u306a\u3044\u3067 -\u3057\u3087\u3046\u304b\uff1f" +set iso2022uniData2 "私どもでは、チップご購入時にご登録いただいたご住所をキャッシュアウトの際の +小切手送付先として使用しております。恐れ入りますが、正しい住所をご登録しなお +お願いいたします。また、大変恐縮ですが、住所変更のあと、日本語サービス部（ +casino_japanese@___.com ）までご住所変更済の連絡をいただけないで +しょうか？" cd [temporaryDirectory] set fid [open iso2022.txt w] @@ -539,7 +559,7 @@ test encoding-24.2 {EscapeFreeProc on open channels} {exec} { set env(TCL_FINALIZE_ON_EXIT) 1 exit }] -} "ab\x1B\$B8C\x1B\$(DD%\x1B(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)" +} "ab\x1B\$B8C\x1B\$(DD%\x1B(Bg (ab\\u001B\$B8C\\u001B\$(DD%\\u001B(Bg)" test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { # Bug #219314 - if we don't free escape encodings correctly on channel # closure, we go boom @@ -554,7 +574,7 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { close $f removeFile iso2022.tcl list $count [viewable $line] -} [list 3 "乎乞也 (\\u4e4e\\u4e5e\\u4e5f)"] +} [list 3 "乎乞也 (\\u4E4E\\u4E5E\\u4E5F)"] test encoding-24.4 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC0\x80"] @@ -632,20 +652,20 @@ proc foreach-jisx0208 {varName command} { } proc gen-jisx0208-euc-jp {code} { binary format cc \ - [expr {($code >> 8) | 0x80}] [expr {($code & 0xff) | 0x80}] + [expr {($code >> 8) | 0x80}] [expr {($code & 0xFF) | 0x80}] } proc gen-jisx0208-iso2022-jp {code} { binary format a3cca3 \ - "\x1b\$B" [expr {$code >> 8}] [expr {$code & 0xff}] "\x1b(B" + "\x1B\$B" [expr {$code >> 8}] [expr {$code & 0xFF}] "\x1B(B" } proc gen-jisx0208-cp932 {code} { set c1 [expr {($code >> 8) | 0x80}] set c2 [expr {($code & 0xff)| 0x80}] if {$c1 % 2} { - set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x31 : 0x71)}] - incr c2 [expr {- (0x60 + ($c2 < 0xe0))}] + set c1 [expr {($c1 >> 1) + ($c1 < 0xDF ? 0x31 : 0x71)}] + incr c2 [expr {- (0x60 + ($c2 < 0xE0))}] } else { - set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x30 : 0x70)}] + set c1 [expr {($c1 >> 1) + ($c1 < 0xDF ? 0x30 : 0x70)}] incr c2 -2 } binary format cc $c1 $c2 @@ -742,7 +762,7 @@ test encoding-28.0 {all encodings load} -body { llength $name } return $count -} -result [expr {[info exists ::tcl_precision] ? 86 : 85}] +} -result [expr {[info exists ::tcl_precision] ? 87 : 86}] runtests diff --git a/tests/exec.test b/tests/exec.test index 412cd4c..6e4718a 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -169,19 +169,19 @@ test exec-2.6 {redirecting input from immediate source, with UTF} -setup { encoding system iso8859-1 proc quotenonascii s { regsub -all {\[|\\|\]} $s {\\&} s - regsub -all "\[\u007f-\uffff\]" $s \ - {[apply {c {format {\u%04x} [scan $c %c]}} &]} s + regsub -all "\[\x7F-\xFF\]" $s \ + {[apply {c {format {\x%02X} [scan $c %c]}} &]} s return [subst -novariables $s] } } -constraints {exec} -body { - # If this fails, it may give back: "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1" + # If this fails, it may give back: "\xC3\xA9\xC3\xA0\xC3\xBC\xC3\xB1" # If it does, this means that the UTF -> external conversion did not occur # before writing out the temp file. - quotenonascii [exec [interpreter] $path(cat) << "\uE9\uE0\uFC\uF1"] + quotenonascii [exec [interpreter] $path(cat) << "\xE9\xE0\xFC\xF1"] } -cleanup { encoding system $sysenc rename quotenonascii {} -} -result {\u00e9\u00e0\u00fc\u00f1} +} -result {\xE9\xE0\xFC\xF1} # I/O redirection: output to file. diff --git a/tests/execute.test b/tests/execute.test index f22747c..d86ad0e 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -1066,7 +1066,7 @@ test execute-9.1 {Interp result resetting [Bug 1522803]} { } SUCCESS test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} { - apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130 + apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} İ } {48 {304 304}} test execute-10.2 {Bug 2802881} -setup { interp create child diff --git a/tests/expr-old.test b/tests/expr-old.test index 50fbba7..676443a 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -35,9 +35,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -47,19 +47,19 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -69,11 +69,11 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 diff --git a/tests/expr.test b/tests/expr.test index 9add1f1..32706d9 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -33,9 +33,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -45,21 +45,21 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) - binary scan \x00\x00\x00\x00\x00\x00\xf8\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\xFF d \ ieeeValues(-NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -69,13 +69,13 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) - binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-NaN) set ieeeValues(littleEndian) 0 return 1 @@ -351,7 +351,7 @@ test expr-8.11 {CompileEqualityExpr: error compiling equality arm} -body { expr 2!=x } -returnCodes error -match glob -result * test expr-8.12 {CompileBitAndExpr: equality expr} {expr {"a"eq"a"}} 1 -test expr-8.13 {CompileBitAndExpr: equality expr} {expr {"\374" eq [set s \u00fc]}} 1 +test expr-8.13 {CompileBitAndExpr: equality expr} {expr {"\374" eq [set s \xFC]}} 1 test expr-8.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0 test expr-8.15 {CompileBitAndExpr: equality expr} {expr 2.0eq2} 0 test expr-8.16 {CompileBitAndExpr: equality expr} {expr 3.2ne2.2} 1 @@ -6699,6 +6699,12 @@ test expr-38.12 {abs and -0x0 [Bug 2954959]} { test expr-38.13 {abs and 0.0 [Bug 2954959]} { ::tcl::mathfunc::abs 1e-324 } 1e-324 +test expr-38.14 {abs and INT64_MIN special-case} { + ::tcl::mathfunc::abs -9223372036854775808 +} 9223372036854775808 +test expr-38.15 {abs and INT128_MIN special-case} { + ::tcl::mathfunc::abs -170141183460469231731687303715884105728 +} 170141183460469231731687303715884105728 testConstraint testexprlongobj [llength [info commands testexprlongobj]] testConstraint testexprdoubleobj [llength [info commands testexprdoubleobj]] diff --git a/tests/fCmd.test b/tests/fCmd.test index 6a909f8..d1d1930 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -271,7 +271,7 @@ test fCmd-3.14 {FileCopyRename: FileBasename fails} -setup { file mkdir td1 file rename ~_totally_bogus_user td1 } -result {user "_totally_bogus_user" doesn't exist} -test fCmd-3.15 {FileCopyRename: source[0] == '\0'} -setup { +test fCmd-3.15 {FileCopyRename: source[0] == '\x00'} -setup { cleanup } -constraints {notRoot unixOrWin} -returnCodes error -body { file mkdir td1 @@ -313,7 +313,7 @@ test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} -setup { } -constraints {notRoot} -returnCodes error -body { file mkdir ~_totally_bogus_user } -result {user "_totally_bogus_user" doesn't exist} -test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\0'} -setup { +test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\x00'} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { file mkdir "" diff --git a/tests/fileSystemEncoding.test b/tests/fileSystemEncoding.test index 848b570..c9d36d2 100644 --- a/tests/fileSystemEncoding.test +++ b/tests/fileSystemEncoding.test @@ -13,7 +13,7 @@ namespace eval ::tcl::test::fileSystemEncoding { namespace import -force ::tcltest::* } - variable fname1 \u767b\u9e1b\u9d72\u6a13 + variable fname1 登鸛鵲樓 proc autopath {} { global auto_path diff --git a/tests/format.test b/tests/format.test index 9a62193..41918b2 100644 --- a/tests/format.test +++ b/tests/format.test @@ -105,17 +105,17 @@ test format-2.4 {string formatting} { format "%s %s %% %c %s" abcd {This is a very long test string.} 120 x } {abcd This is a very long test string. % x x} test format-2.5 {string formatting, embedded nulls} { - format "%10s" abc\0def -} " abc\0def" + format "%10s" abc\x00def +} " abc\x00def" test format-2.6 {string formatting, international chars} { - format "%10s" abc\ufeffdef -} " abc\ufeffdef" + format "%10s" abc\uFEFFdef +} " abc\uFEFFdef" test format-2.7 {string formatting, international chars} { - format "%.5s" abc\ufeffdef -} "abc\ufeffd" + format "%.5s" abc\uFEFFdef +} "abc\uFEFFd" test format-2.8 {string formatting, international chars} { - format "foo\ufeffbar%s" baz -} "foo\ufeffbarbaz" + format "foo\uFEFFbar%s" baz +} "foo\uFEFFbarbaz" test format-2.9 {string formatting, width} { format "a%5sa" f } "a fa" @@ -143,13 +143,19 @@ test format-2.16 {string formatting, width and precision} { test format-2.17 {string formatting, width and precision} { format "a%5.7sa" foobarbaz } "afoobarba" +test format-2.18 {string formatting, surrogates} { + format "\uD83D%s" \uDE02 +} \uD83D\uDE02 +test format-2.19 {string formatting, surrogates} { + format "%s\uDE02" \uD83D +} \uD83D\uDE02 test format-3.1 {Tcl_FormatObjCmd: character formatting} { format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 65 65 65 65 65 65 3 65 -4 65 } "|A|A|A|A|A | A| A|A |" test format-3.2 {Tcl_FormatObjCmd: international character formatting} { - format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xa2 0x4e4e 0x25a 0xc3 0xff08 0 3 0x6575 -4 0x4e4f -} "|\ua2|\u4e4e|\u25a|\uc3|\uff08 | \0| \u6575|\u4e4f |" + format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xA2 0x4E4E 0x25A 0xC3 0xFF08 0 3 0x6575 -4 0x4E4F +} "|¢|乎|ɚ|Ã|（ | \x00| 敵|乏 |" test format-4.1 {e and f formats} {eformat} { format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053 diff --git a/tests/http.test b/tests/http.test index ff9fb78..2fd5af4 100644 --- a/tests/http.test +++ b/tests/http.test @@ -42,7 +42,7 @@ proc bgerror {args} { # Name resolution is often a problem on OSX; not focus of HTTP package anyway. # Also a problem on other platforms for http-4.14 (test with bad port number). set HOST localhost -set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" +set bindata "This is binary data\x0D\x0Amore\x0Dmore\x0Amore\x00null" catch {unset data} # Ensure httpd file exists @@ -620,12 +620,12 @@ test http-5.3 {http::formatQuery} { http::formatQuery lines "line1\nline2\nline3" } {lines=line1%0D%0Aline2%0D%0Aline3} test http-5.4 {http::formatQuery} { - http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 + http::formatQuery name1 ~bwelch name2 ¡¢¢ } {name1=~bwelch&name2=%C2%A1%C2%A2%C2%A2} test http-5.5 {http::formatQuery} { set enc [http::config -urlencoding] http::config -urlencoding iso8859-1 - set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2] + set res [http::formatQuery name1 ~bwelch name2 ¡¢¢] http::config -urlencoding $enc set res } {name1=~bwelch&name2=%A1%A2%A2} @@ -650,24 +650,24 @@ test http-7.1 {http::mapReply} { test http-7.2 {http::mapReply} { # RFC 2718 specifies that we pass urlencoding on utf-8 chars by default, # so make sure this gets converted to utf-8 then urlencoded. - http::mapReply "\u2208" + http::mapReply "∈" } {%E2%88%88} test http-7.3 {http::formatQuery} -setup { set enc [http::config -urlencoding] } -returnCodes error -body { # this would be reverting to http <=2.4 behavior http::config -urlencoding "" - http::mapReply "\u2208" + http::mapReply "∈" } -cleanup { http::config -urlencoding $enc -} -result "can't read \"formMap(\u2208)\": no such element in array" +} -result "can't read \"formMap(∈)\": no such element in array" test http-7.4 {http::formatQuery} -setup { set enc [http::config -urlencoding] } -body { # this would be reverting to http <=2.4 behavior w/o errors # (unknown chars become '?') http::config -urlencoding "iso8859-1" - http::mapReply "\u2208" + http::mapReply "∈" } -cleanup { http::config -urlencoding $enc } -result {%3F} @@ -715,37 +715,37 @@ test http-idna-2.1 {puny encode: functional test} { ::tcl::idna puny encode abc } abc- test http-idna-2.2 {puny encode: functional test} { - ::tcl::idna puny encode a\u20acb\u20acc + ::tcl::idna puny encode a€b€c } abc-k50ab test http-idna-2.3 {puny encode: functional test} { ::tcl::idna puny encode ABC } ABC- test http-idna-2.4 {puny encode: functional test} { - ::tcl::idna puny encode A\u20ACB\u20ACC + ::tcl::idna puny encode A€B€C } ABC-k50ab test http-idna-2.5 {puny encode: functional test} { ::tcl::idna puny encode ABC 0 } abc- test http-idna-2.6 {puny encode: functional test} { - ::tcl::idna puny encode A\u20ACB\u20ACC 0 + ::tcl::idna puny encode A€B€C 0 } abc-k50ab test http-idna-2.7 {puny encode: functional test} { ::tcl::idna puny encode ABC 1 } ABC- test http-idna-2.8 {puny encode: functional test} { - ::tcl::idna puny encode A\u20ACB\u20ACC 1 + ::tcl::idna puny encode A€B€C 1 } ABC-k50ab test http-idna-2.9 {puny encode: functional test} { ::tcl::idna puny encode abc 0 } abc- test http-idna-2.10 {puny encode: functional test} { - ::tcl::idna puny encode a\u20ACb\u20ACc 0 + ::tcl::idna puny encode a€b€c 0 } abc-k50ab test http-idna-2.11 {puny encode: functional test} { ::tcl::idna puny encode abc 1 } ABC- test http-idna-2.12 {puny encode: functional test} { - ::tcl::idna puny encode a\u20ACb\u20ACc 1 + ::tcl::idna puny encode a€b€c 1 } ABC-k50ab test http-idna-2.13 {puny encode: edge cases} { ::tcl::idna puny encode "" @@ -875,43 +875,43 @@ test http-idna-3.1 {puny decode: functional test} { } abc test http-idna-3.2 {puny decode: functional test} { ::tcl::idna puny decode abc-k50ab -} a\u20acb\u20acc +} a€b€c test http-idna-3.3 {puny decode: functional test} { ::tcl::idna puny decode ABC- } ABC test http-idna-3.4 {puny decode: functional test} { ::tcl::idna puny decode ABC-k50ab -} A\u20ACB\u20ACC +} A€B€C test http-idna-3.5 {puny decode: functional test} { ::tcl::idna puny decode ABC-K50AB -} A\u20ACB\u20ACC +} A€B€C test http-idna-3.6 {puny decode: functional test} { ::tcl::idna puny decode abc-K50AB -} a\u20ACb\u20ACc +} a€b€c test http-idna-3.7 {puny decode: functional test} { ::tcl::idna puny decode ABC- 0 } abc test http-idna-3.8 {puny decode: functional test} { ::tcl::idna puny decode ABC-K50AB 0 -} a\u20ACb\u20ACc +} a€b€c test http-idna-3.9 {puny decode: functional test} { ::tcl::idna puny decode ABC- 1 } ABC test http-idna-3.10 {puny decode: functional test} { ::tcl::idna puny decode ABC-K50AB 1 -} A\u20ACB\u20ACC +} A€B€C test http-idna-3.11 {puny decode: functional test} { ::tcl::idna puny decode abc- 0 } abc test http-idna-3.12 {puny decode: functional test} { ::tcl::idna puny decode abc-k50ab 0 -} a\u20ACb\u20ACc +} a€b€c test http-idna-3.13 {puny decode: functional test} { ::tcl::idna puny decode abc- 1 } ABC test http-idna-3.14 {puny decode: functional test} { ::tcl::idna puny decode abc-k50ab 1 -} A\u20ACB\u20ACC +} A€B€C test http-idna-3.15 {puny decode: edge cases and errors} { # Is this case actually correct? binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]] @@ -1045,16 +1045,16 @@ test http-idna-4.1 {IDNA encoding} { ::tcl::idna encode abc.def } abc.def test http-idna-4.2 {IDNA encoding} { - ::tcl::idna encode a\u20acb\u20acc.def + ::tcl::idna encode a€b€c.def } xn--abc-k50ab.def test http-idna-4.3 {IDNA encoding} { - ::tcl::idna encode def.a\u20acb\u20acc + ::tcl::idna encode def.a€b€c } def.xn--abc-k50ab test http-idna-4.4 {IDNA encoding} { ::tcl::idna encode ABC.DEF } ABC.DEF test http-idna-4.5 {IDNA encoding} { - ::tcl::idna encode A\u20acB\u20acC.def + ::tcl::idna encode A€B€C.def } xn--ABC-k50ab.def test http-idna-4.6 {IDNA encoding: invalid edge case} { # Should this be an error? @@ -1084,7 +1084,7 @@ test http-idna-4.9.1 {IDNA encoding: max lengths from RFC 5890} { } {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c} unset overlong test http-idna-4.10 {IDNA encoding: edge cases} { - ::tcl::idna encode pass\u00e9.example.com + ::tcl::idna encode passé.example.com } xn--pass-epa.example.com test http-idna-5.1 {IDNA decoding} { diff --git a/tests/info.test b/tests/info.test index d9a4f54..ced4435 100644 --- a/tests/info.test +++ b/tests/info.test @@ -22,7 +22,7 @@ if {{::tcltest} ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] testConstraint zlib [llength [info commands zlib]] - +testConstraint nodep [info exists tcl_precision] # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. @@ -101,7 +101,7 @@ test info-2.5 {info body option, returning bytecompiled bodies} -body { # Fix for problem tested for in info-2.5 caused problems when # procedure body had no string rep (i.e. was not yet bytecode) # causing an empty string to be returned [Bug #545644] -test info-2.6 {info body option, returning list bodies} { +test info-2.6 {info body option, returning list bodies} nodep { proc foo args [list subst bar] list [string bytelength [info body foo]] \ [foo; string bytelength [info body foo]] diff --git a/tests/init.test b/tests/init.test index 0074625..4acad3d 100644 --- a/tests/init.test +++ b/tests/init.test @@ -155,7 +155,7 @@ foreach arg [subst -nocommands -novariables { error stack cannot be uniquely determined. foo bar "} - {argument that contains non-ASCII character, \u20ac, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library} + {argument that contains non-ASCII character, €, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library} }] { ;# emacs needs -> " test init-4.$count.0 {::errorInfo produced by [unknown]} -setup { diff --git a/tests/interp.test b/tests/interp.test index c19755f..385d3e2 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -3524,7 +3524,7 @@ test interp-35.19 {interp limit syntax} -body { interp limit $i time -seconds -1 } -cleanup { interp delete $i -} -returnCodes error -result {seconds must be at least 0} +} -match glob -returnCodes error -result {seconds must be between 0 and *} test interp-35.20 {interp limit syntax} -body { set i [interp create] interp limit $i time -millis foobar @@ -3536,7 +3536,7 @@ test interp-35.21 {interp limit syntax} -body { interp limit $i time -millis -1 } -cleanup { interp delete $i -} -returnCodes error -result {milliseconds must be at least 0} +} -match glob -returnCodes error -result {milliseconds must be between 0 and *} test interp-35.22 {interp time limits normalize milliseconds} -body { set i [interp create] interp limit $i time -seconds 1 -millis 1500 diff --git a/tests/io.test b/tests/io.test index 0d75116..e26c97f 100644 --- a/tests/io.test +++ b/tests/io.test @@ -108,17 +108,17 @@ set path(test1) [makeFile {} test1] test io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] fconfigure $f -encoding binary - puts -nonewline $f "a\u4e4d\0" + puts -nonewline $f "a乍\x00" close $f contents $path(test1) -} "a\x4d\x00" +} "a\x4D\x00" test io-1.7 {Tcl_WriteChars: WriteChars} { set f [open $path(test1) w] fconfigure $f -encoding shiftjis - puts -nonewline $f "a\u4e4d\0" + puts -nonewline $f "a乍\x00" close $f contents $path(test1) -} "a\x93\xe1\x00" +} "a\x93\xE1\x00" set path(test2) [makeFile {} test2] test io-1.8 {Tcl_WriteChars: WriteChars} { # This test written for SF bug #506297. @@ -132,7 +132,7 @@ test io-1.8 {Tcl_WriteChars: WriteChars} { puts -nonewline $f [format %s%c [string repeat " " 4] 12399] close $f contents $path(test2) -} " \x1b\$B\$O\x1b(B" +} " \x1B\$B\$O\x1B(B" test io-1.9 {Tcl_WriteChars: WriteChars} { # When closing a channel with an encoding that appends @@ -295,14 +295,14 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { # in src to the beginning of that UTF-8 character and try again. # # Translate the first 16 bytes, produce 14 bytes of output, 2 left over - # (first two bytes of \uff21 in UTF-8). Given those two bytes try + # (first two bytes of Ａ in UTF-8). Given those two bytes try # translating them again, find that no bytes are read produced, and break # to outer loop where those two bytes will have the remaining 4 bytes - # (the last byte of \uff21 plus the all of \uff22) appended. + # (the last byte of Ａ plus the all of Ｂ) appended. set f [open $path(test1) w] fconfigure $f -encoding shiftjis -buffersize 16 - puts -nonewline $f "12345678901234\uff21\uff22" + puts -nonewline $f "12345678901234ＡＢ" set x [list [contents $path(test1)]] close $f lappend x [contents $path(test1)] @@ -451,7 +451,7 @@ test io-6.3 {Tcl_GetsObj: how many have we used?} { test io-6.4 {Tcl_GetsObj: encoding == NULL} { set f [open $path(test1) w] fconfigure $f -translation binary - puts $f "\x81\u1234\0" + puts $f "\x81\u1234\x00" close $f set f [open $path(test1)] fconfigure $f -translation binary @@ -462,14 +462,14 @@ test io-6.4 {Tcl_GetsObj: encoding == NULL} { test io-6.5 {Tcl_GetsObj: encoding != NULL} { set f [open $path(test1) w] fconfigure $f -translation binary - puts $f "\x88\xea\x92\x9a" + puts $f "\x88\xEA\x92\x9A" close $f set f [open $path(test1)] fconfigure $f -encoding shiftjis set x [list [gets $f line] $line] close $f set x -} [list 2 "\u4e00\u4e01"] +} [list 2 "一丁"] set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a @@ -509,7 +509,7 @@ test io-6.8 {Tcl_GetsObj: remember if EOF is seen} { } {6 abcdef -1 {}} test io-6.9 {Tcl_GetsObj: remember if EOF is seen} { set f [open $path(test1) w] - puts $f "abcdefghijk\nwom\u001abat" + puts $f "abcdefghijk\nwom\x1Abat" close $f set f [open $path(test1)] fconfigure $f -eofchar \x1A @@ -1052,14 +1052,14 @@ test io-6.55 {Tcl_GetsObj: overconverted} { set f [open $path(test1) w] fconfigure $f -encoding iso2022-jp - puts $f "there\u4e00ok\n\u4e01more bytes\nhere" + puts $f "there一ok\n丁more bytes\nhere" close $f set f [open $path(test1)] fconfigure $f -encoding iso2022-jp set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x -} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] +} [list 8 "there一ok" 11 "丁more bytes" 4 "here"] test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio fileevent} { update set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1086,20 +1086,20 @@ test io-7.1 {FilterInputBytes: split up character at end of buffer} { set f [open $path(test1) w] fconfigure $f -encoding shiftjis - puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend" + puts $f "1234567890123０１２３４\nend" close $f set f [open $path(test1)] fconfigure $f -encoding shiftjis -buffersize 16 set x [gets $f] close $f set x -} "1234567890123\uff10\uff11\uff12\uff13\uff14" +} "1234567890123０１２３４" test io-7.2 {FilterInputBytes: split up character in middle of buffer} { # (bufPtr->nextAdded < bufPtr->bufLength) set f [open $path(test1) w] fconfigure $f -encoding binary - puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" + puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82" close $f set f [open $path(test1)] fconfigure $f -encoding shiftjis @@ -1110,7 +1110,7 @@ test io-7.2 {FilterInputBytes: split up character in middle of buffer} { test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { set f [open $path(test1) w] fconfigure $f -encoding binary - puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" close $f set f [open $path(test1)] fconfigure $f -encoding shiftjis @@ -1119,11 +1119,11 @@ test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { lappend x [gets $f line] $line close $f set x -} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] +} [list 15 "1234567890123０１" 18 0 1 -1 ""] test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent} { set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -encoding binary -buffering none - puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" fconfigure $f -encoding shiftjis -blocking 0 fileevent $f read [namespace code "ready $f"] variable x {} @@ -1138,7 +1138,7 @@ test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent vwait [namespace which -variable x] close $f set x -} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] +} [list -1 "" 1 17 "1234567890123０１２３" 0] test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} { # (bufPtr->nextPtr == NULL) @@ -1415,19 +1415,19 @@ test io-12.4 {ReadChars: split-up char} {stdio testchannel fileevent} { fconfigure $f -encoding shiftjis vwait [namespace which -variable x] fconfigure $f -encoding binary -blocking 1 - puts -nonewline $f "\x7b" + puts -nonewline $f "\x7B" after 500 ;# Give the cat process time to catch up fconfigure $f -encoding shiftjis -blocking 0 vwait [namespace which -variable x] close $f set x -} [list "123456789012345" 1 "\u672c" 0] +} [list "123456789012345" 1 "本" 0] test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} { set path(test1) [makeFile { fconfigure stdout -encoding binary -buffering none - gets stdin; puts -nonewline "\xe7" + gets stdin; puts -nonewline "\xE7" gets stdin; puts -nonewline "\x89" - gets stdin; puts -nonewline "\xa6" + gets stdin; puts -nonewline "\xA6" } test1] set f [open "|[list [interpreter] $path(test1)]" r+] fileevent $f readable [namespace code { @@ -1454,7 +1454,7 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} { vwait [namespace which -variable x] lappend x [catch {close $f} msg] $msg set x -} "{} timeout {} timeout \u7266 {} eof 0 {}" +} "{} timeout {} timeout 牦 {} eof 0 {}" test io-12.6 {ReadChars: too many chars read} { proc driver {cmd args} { variable buffer @@ -1464,7 +1464,7 @@ test io-12.6 {ReadChars: too many chars read} { initialize { set index($chan) 0 set buffer($chan) [encoding convertto utf-8 \ - [string repeat \uBEEF 20][string repeat . 20]] + [string repeat 뻯 20][string repeat . 20]] return {initialize finalize watch read} } finalize { @@ -1497,7 +1497,7 @@ test io-12.7 {ReadChars: too many chars read [bc5b790099]} { initialize { set index($chan) 0 set buffer($chan) [encoding convertto utf-8 \ - [string repeat \uBEEF 10]....\uBEEF] + [string repeat 뻯 10]....뻯] return {initialize finalize watch read} } finalize { @@ -1524,7 +1524,7 @@ test io-12.7 {ReadChars: too many chars read [bc5b790099]} { test io-12.8 {ReadChars: multibyte chars split} { set f [open $path(test1) w] fconfigure $f -translation binary - puts -nonewline $f [string repeat a 9]\xc2\xa0 + puts -nonewline $f [string repeat a 9]\xC2\xA0 close $f set f [open $path(test1)] fconfigure $f -encoding utf-8 -buffersize 10 @@ -1535,7 +1535,7 @@ test io-12.8 {ReadChars: multibyte chars split} { test io-12.9 {ReadChars: multibyte chars split} { set f [open $path(test1) w] fconfigure $f -translation binary - puts -nonewline $f [string repeat a 9]\xc2 + puts -nonewline $f [string repeat a 9]\xC2 close $f set f [open $path(test1)] fconfigure $f -encoding utf-8 -buffersize 10 @@ -1546,7 +1546,7 @@ test io-12.9 {ReadChars: multibyte chars split} { test io-12.10 {ReadChars: multibyte chars split} { set f [open $path(test1) w] fconfigure $f -translation binary - puts -nonewline $f [string repeat a 9]\xc2 + puts -nonewline $f [string repeat a 9]\xC2 close $f set f [open $path(test1)] fconfigure $f -encoding utf-8 -buffersize 11 @@ -1732,7 +1732,7 @@ test io-13.10 {TranslateInputEOL: auto mode: \n} { set x } "abcd\ndef" test io-13.11 {TranslateInputEOL: EOF char} { - # (*chanPtr->inEofChar != '\0') + # (*chanPtr->inEofChar != '\x00') set f [open $path(test1) w] fconfigure $f -translation lf @@ -1745,7 +1745,7 @@ test io-13.11 {TranslateInputEOL: EOF char} { set x } "abcd\nd" test io-13.12 {TranslateInputEOL: find EOF char in src} { - # (*chanPtr->inEofChar != '\0') + # (*chanPtr->inEofChar != '\x00') set f [open $path(test1) w] fconfigure $f -translation lf @@ -2346,9 +2346,9 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ set result ok } } ok -test io-28.4 {Tcl_Close} {testchannel} { +test io-28.4 Tcl_Close testchannel { file delete $path(test1) - set l "" + set l {} lappend l [lsort [testchannel open]] set f [open $path(test1) w] lappend l [lsort [testchannel open]] @@ -2373,6 +2373,74 @@ test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} { lsort $l } {file1 file2} + +test io-28.6 { + close channel in write event handler + + Should not produce a segmentation fault in a Tcl built with + --enable-symbols and -DPURIFY +} debugpurify { + variable done + variable res + after 0 [list coroutine c1 apply [list {} { + variable done + set chan [chan create w {apply {args { + list initialize finalize watch write configure blocking + }}}] + chan configure $chan -blocking 0 + while 1 { + chan event $chan writable [list [info coroutine]] + yield + close $chan + set done 1 + return + } + } [namespace current]]] + vwait [namespace current]::done +return success +} success + + +test io-28.7 { + close channel in read event handler + + Should not produce a segmentation fault in a Tcl built with + --enable-symbols and -DPURIFY +} debugpurify { + variable done + variable res + after 0 [list coroutine c1 apply [list {} { + variable done + set chan [chan create r {apply {{cmd chan args} { + switch $cmd { + blocking - finalize { + } + watch { + chan postevent $chan read + } + initialize { + list initialize finalize watch read write configure blocking + } + default { + error [list {unexpected command} $cmd] + } + } + }}}] + chan configure $chan -blocking 0 + while 1 { + chan event $chan readable [list [info coroutine]] + yield + close $chan + set done 1 + return + } + } [namespace current]]] + vwait [namespace current]::done +return success +} success + + + test io-29.1 {Tcl_WriteChars, channel not writable} { list [catch {puts stdin hello} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} @@ -3202,7 +3270,7 @@ test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { puts -nonewline $f hello\nthere\nand\rhere\n\x1A close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation auto + fconfigure $f -translation auto -eofchar \x1A set c [read $f] close $f set c @@ -3214,11 +3282,11 @@ here test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -eofchar \x1A -translation lf + fconfigure $f -translation lf -eofchar \x1A puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation auto + fconfigure $f -translation auto -eofchar \x1A set c [read $f] close $f set c @@ -3235,7 +3303,7 @@ test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation auto + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3255,7 +3323,7 @@ test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation auto + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3736,7 +3804,7 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation auto + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3751,11 +3819,11 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -eofchar \x1A -translation lf + fconfigure $f -translation lf -eofchar \x1A puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation auto + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3775,8 +3843,7 @@ test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1A - fconfigure $f -translation auto + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3794,7 +3861,7 @@ test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation auto + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -5311,9 +5378,6 @@ test io-39.1 {Tcl_GetChannelOption} { close $f1 set x } 1 -# -# Test 17.2 was removed. -# test io-39.2 {Tcl_GetChannelOption} { file delete $path(test1) set f1 [open $path(test1) w] @@ -5479,26 +5543,26 @@ test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -encoding {} - puts -nonewline $f \xe7\x89\xa6 + puts -nonewline $f \xE7\x89\xA6 close $f set f [open $path(test1) r] fconfigure $f -encoding utf-8 set x [read $f] close $f set x -} \u7266 +} 牦 test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -encoding binary - puts -nonewline $f \xe7\x89\xa6 + puts -nonewline $f \xE7\x89\xA6 close $f set f [open $path(test1) r] fconfigure $f -encoding utf-8 set x [read $f] close $f set x -} \u7266 +} 牦 test io-39.16 {Tcl_SetChannelOption: -encoding, errors} { file delete $path(test1) set f [open $path(test1) w] @@ -5509,7 +5573,7 @@ test io-39.16 {Tcl_SetChannelOption: -encoding, errors} { test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio fileevent} { set f [open "|[list [interpreter] $path(cat)]" r+] fconfigure $f -encoding binary - puts -nonewline $f "\xe7" + puts -nonewline $f "\xE7" flush $f fconfigure $f -encoding utf-8 -blocking 0 variable x {} @@ -5527,7 +5591,7 @@ test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} vwait [namespace which -variable x] close $f set x -} "{} timeout {} timeout \xe7 timeout" +} "{} timeout {} timeout \xE7 timeout" test io-39.18 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} @@ -5830,11 +5894,11 @@ test io-42.2 {Tcl_FileeventCmd: replacing} {fileevent} { } {{first script} {new script} {yet another} {}} test io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {fileevent} { set result {} - fileevent $f r "first scr\0ipt" + fileevent $f r "first scr\x00ipt" lappend result [string length [fileevent $f readable]] - fileevent $f r "new scr\0ipt" + fileevent $f r "new scr\x00ipt" lappend result [string length [fileevent $f readable]] - fileevent $f r "yet ano\0ther" + fileevent $f r "yet ano\x00ther" lappend result [string length [fileevent $f readable]] fileevent $f r "" lappend result [fileevent $f readable] @@ -6391,7 +6455,7 @@ test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation auto + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6447,7 +6511,7 @@ test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation auto + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6503,7 +6567,7 @@ test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation auto + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6531,7 +6595,7 @@ test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation lf + fconfigure $f -translation lf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6587,7 +6651,7 @@ test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation cr + fconfigure $f -translation cr -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6643,7 +6707,7 @@ test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {f set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1A -translation crlf + fconfigure $f -translation crlf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -7218,7 +7282,7 @@ set path(utf8-rp.txt) [makeFile {} utf8-rp.txt] # Create kyrillic file, use lf translation to avoid os eol issues set out [open $path(kyrillic.txt) w] fconfigure $out -encoding koi8-r -translation lf -puts $out "\u0410\u0410" +puts $out "АА" close $out test io-52.9 {TclCopyChannel & encodings} {fcopy} { # Copy kyrillic to UTF-8, using fcopy. @@ -7270,7 +7334,7 @@ test io-52.10 {TclCopyChannel & encodings} {fcopy} { test io-52.11 {TclCopyChannel & encodings} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf - puts $out "\u0410\u0410" + puts $out "АА" close $out } -constraints {fcopy} -body { # binary to encoding => the input has to be @@ -8390,7 +8454,7 @@ test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { set out [open $path(script) w] puts $out "catch {load $::tcltestlib Tcltest}" puts $out { - puts [testbytestring \xe2] + puts [testbytestring \xE2] exit 1 } proc readit {pipe} { @@ -8414,7 +8478,7 @@ test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # cut of the remainder of the error stack, especially the filename set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]] list $x $result -} {1 {gets {} catch {error writing "stdout": invalid argument}}} +} {1 {gets {} catch {error writing "stdout": illegal byte sequence}}} test io-61.1 {Reset eof state after changing the eof char} -setup { set datafile [makeFile {} eofchar] @@ -8748,7 +8812,7 @@ test io-73.5 {effect of eof on encoding end flags} -setup { read $rfd } -body { set result [eof $rfd] - puts -nonewline $wfd "more\u00c2\u00a0data" + puts -nonewline $wfd "more\xC2\xA0data" lappend result [eof $rfd] lappend result [read $rfd] lappend result [eof $rfd] @@ -8756,7 +8820,7 @@ test io-73.5 {effect of eof on encoding end flags} -setup { close $wfd close $rfd removeFile io-73.5 -} -result [list 1 1 more\u00a0data 1] +} -result [list 1 1 more\xA0data 1] test io-74.1 {[104f2885bb] improper cache validity check} -setup { set fn [makeFile {} io-74.1] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index bdf162d..dbca866 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -494,14 +494,14 @@ test iocmd-12.10 {POSIX open access modes: BINARY} { } 5 test iocmd-12.11 {POSIX open access modes: BINARY} { set f [open $path(test1) {WRONLY BINARY TRUNC}] - puts $f \u0248 ;# gets truncated to \u0048 + puts $f Ɉ ;# gets truncated to H close $f set f [open $path(test1) r] fconfigure $f -translation binary set result [read -nonewline $f] close $f set result -} \u0048 +} H test iocmd-13.1 {errors in open command} { list [catch {open} msg] $msg diff --git a/tests/list.test b/tests/list.test index 4cd3a75..905a3d3 100644 --- a/tests/list.test +++ b/tests/list.test @@ -45,23 +45,23 @@ test list-1.24 {basic tests} {list} {} test list-1.25 {basic tests} {list # #} {{#} #} test list-1.26 {basic tests} {list #\{ #\{} {\#\{ #\{} test list-1.27 {basic null treatment} { - set l [list "" "\0" "\0\0"] - set e "{} \0 \0\0" + set l [list "" "\x00" "\x00\x00"] + set e "{} \x00 \x00\x00" string equal $l $e } 1 test list-1.28 {basic null treatment} { - set result "\0a\0b" + set result "\x00a\x00b" list $result [string length $result] -} "\0a\0b 4" +} "\x00a\x00b 4" test list-1.29 {basic null treatment} { - set result "\0a\0b" + set result "\x00a\x00b" set srep "$result 4" set lrep [list $result [string length $result]] string equal $srep $lrep } 1 test list-1.30 {basic null treatment} { - set l [list "\0abc" "xyz"] - set e "\0abc xyz" + set l [list "\x00abc" "xyz"] + set e "\x00abc xyz" string equal $l $e } 1 diff --git a/tests/load.test b/tests/load.test index 7978f64..40901e5 100644 --- a/tests/load.test +++ b/tests/load.test @@ -36,9 +36,9 @@ testConstraint $loaded [expr {![string match *pkga* $alreadyLoaded]}] set alreadyTotalLoaded [info loaded] -# Certain tests require the 'teststaticpkg' command from tcltest +# Certain tests require the 'teststaticlibrary' command from tcltest -testConstraint teststaticpkg [llength [info commands teststaticpkg]] +testConstraint teststaticlibrary [llength [info commands teststaticlibrary]] # Test load-10.1 requires the 'testsimplefilesystem' command from tcltest @@ -47,28 +47,28 @@ testConstraint testsimplefilesystem \ test load-1.1 {basic errors} -returnCodes error -body { load -} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"} test load-1.2 {basic errors} -returnCodes error -body { load a b c d -} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"} test load-1.3 {basic errors} -returnCodes error -body { load a b foobar } -result {could not find interpreter "foobar"} test load-1.4 {basic errors} -returnCodes error -body { load -global {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test load-1.5 {basic errors} -returnCodes error -body { load -lazy {} {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test load-1.6 {basic errors} -returnCodes error -body { load {} Unknown -} -result {package "Unknown" isn't loaded statically} +} -result {no library with prefix "Unknown" is loaded statically} test load-1.7 {basic errors} -returnCodes error -body { load -abc foo } -result {bad option "-abc": must be -global, -lazy, or --} test load-1.8 {basic errors} -returnCodes error -body { load -global -} -result {couldn't figure out package name for -global} +} -result {couldn't figure out prefix for -global} test load-2.1 {basic loading, with guess for package name} \ [list $dll $loaded] { @@ -90,7 +90,7 @@ test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] {TCL LOOKUP LOAD_SYMBOL *Foo_Init}] test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg -} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}} +} {1 {can't use library in a safe interpreter: no Pkga_SafeInit procedure}} test load-3.1 {error in _Init procedure, same interpreter} \ [list $dll $loaded] { @@ -128,7 +128,7 @@ test load-4.2 {reloading package into same interpreter} -setup { catch {load [file join $testDir pkga$ext] Pkga} } -constraints [list $dll $loaded] -returnCodes error -body { load [file join $testDir pkga$ext] Pkgb -} -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\"" +} -result "file \"[file join $testDir pkga$ext]\" is already loaded for prefix \"Pkga\"" test load-5.1 {file name not specified and no static package: pick default} -setup { catch {interp delete x} @@ -150,78 +150,78 @@ test load-6.1 {errors loading file} [list $dll $loaded] { catch {load foo foo} } {1} -test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] { +test load-7.1 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" - teststaticpkg Test 1 0 + teststaticlibrary Test 1 0 load {} test load {} test child list [set x] [child eval set x] } {loaded loaded} -test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] { +test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" - teststaticpkg Another 0 0 + teststaticlibrary Another 0 0 load {} Another child eval {set x "not loaded"} list [catch {load {} Another child} msg] $msg \ [child eval set x] [set x] -} {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} -test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] { +} {1 {can't use library in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} +test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" - teststaticpkg More 0 1 + teststaticlibrary More 0 1 load {} more set x } {not loaded} catch {load [file join $testDir pkga$ext] Pkga} catch {load [file join $testDir pkgb$ext] Pkgb} catch {load [file join $testDir pkge$ext] Pkge} -set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] -test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup { - teststaticpkg Test 1 0 - teststaticpkg Another 0 0 - teststaticpkg More 0 1 -} -constraints [list teststaticpkg $dll $loaded] -body { - teststaticpkg Double 0 1 - teststaticpkg Double 0 1 +set currentRealLibraries [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] +test load-7.4 {Tcl_StaticLibrary procedure, redundant calls} -setup { + teststaticlibrary Test 1 0 + teststaticlibrary Another 0 0 + teststaticlibrary More 0 1 +} -constraints [list teststaticlibrary $dll $loaded] -body { + teststaticlibrary Double 0 1 + teststaticlibrary Double 0 1 info loaded -} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded] +} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded] -testConstraint teststaticpkg_8.x 0 -if {[testConstraint teststaticpkg]} { +testConstraint teststaticlibrary_8.x 0 +if {[testConstraint teststaticlibrary]} { catch { - teststaticpkg Test 1 1 - teststaticpkg Another 0 1 - teststaticpkg More 0 1 - teststaticpkg Double 0 1 - testConstraint teststaticpkg_8.x 1 + teststaticlibrary Test 1 1 + teststaticlibrary Another 0 1 + teststaticlibrary More 0 1 + teststaticlibrary Double 0 1 + testConstraint teststaticlibrary_8.x 1 } } -test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.1 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded] -} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]] -test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body { +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded]] +test load-8.2 {TclGetLoadedLibraries procedure} -constraints {teststaticlibrary_8.x} -body { info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} -test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.3a {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded {}] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] -test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.3b {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded child] } [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] -test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.4 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { load [file join $testDir pkgb$ext] Pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] } [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child -test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} -setup { +test load-9.1 {Tcl_StaticLibrary, load already-loaded package into another interp} -setup { interp create child1 interp create child2 load {} Tcltest child1 load {} Tcltest child2 -} -constraints {teststaticpkg} -body { - child1 eval { teststaticpkg Loadninepointone 0 1 } - child2 eval { teststaticpkg Loadninepointone 0 1 } +} -constraints {teststaticlibrary} -body { + child1 eval { teststaticlibrary Loadninepointone 0 1 } + child2 eval { teststaticlibrary Loadninepointone 0 1 } list [child1 eval { info loaded {} }] \ [child2 eval { info loaded {} }] } -match glob -cleanup { @@ -234,7 +234,7 @@ test load-10.1 {load from vfs} -setup { cd $testDir testsimplefilesystem 1 } -constraints [list $dll $loaded testsimplefilesystem] -body { - list [catch {load simplefs:/pkgd$ext PKGD} msg] $msg + list [catch {load simplefs:/pkgd$ext Pkgd} msg] $msg } -result {0 {}} -cleanup { testsimplefilesystem 0 cd $dir diff --git a/tests/lsearch.test b/tests/lsearch.test index 06f3ae4..7c1402d 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -102,13 +102,13 @@ test lsearch-3.7 {lsearch errors} -returnCodes error -body { } -result {-subindices cannot be used without -index option} test lsearch-4.1 {binary data} { - lsearch -exact [list foo one\000two bar] bar + lsearch -exact [list foo one\x00two bar] bar } 2 test lsearch-4.2 {binary data} { set x one append x \x00 append x two - lsearch -exact [list foo one\000two bar] $x + lsearch -exact [list foo one\x00two bar] $x } 1 # Make a sorted list diff --git a/tests/main.test b/tests/main.test index 37f87b4..2d3f63c 100644 --- a/tests/main.test +++ b/tests/main.test @@ -68,56 +68,56 @@ namespace eval ::tcl::test::main { stdio } -setup { makeFile {puts [list $argv0 $argv $tcl_interactive]} script - catch {set f [open "|[list [interpreter] script \u00c0]" r]} + catch {set f [open "|[list [interpreter] script À]" r]} } -body { read $f } -cleanup { close $f removeFile script } -result [list script [list [encoding convertfrom [encoding system] \ - [encoding convertto [encoding system] \u00c0]]] 0]\n + [encoding convertto [encoding system] À]]] 0]\n test Tcl_Main-1.4 { } -constraints { stdio } -setup { makeFile {puts [list $argv0 $argv $tcl_interactive]} script - catch {set f [open "|[list [interpreter] script \u20ac]" r]} + catch {set f [open "|[list [interpreter] script €]" r]} } -body { read $f } -cleanup { close $f removeFile script } -result [list script [list [encoding convertfrom [encoding system] \ - [encoding convertto [encoding system] \u20ac]]] 0]\n + [encoding convertto [encoding system] €]]] 0]\n test Tcl_Main-1.5 { } -constraints { stdio } -setup { - makeFile {puts [list $argv0 $argv $tcl_interactive]} \u00c0 - catch {set f [open "|[list [interpreter] \u00c0]" r]} + makeFile {puts [list $argv0 $argv $tcl_interactive]} À + catch {set f [open "|[list [interpreter] À]" r]} } -body { read $f } -cleanup { close $f - removeFile \u00c0 + removeFile À } -result [list [list [encoding convertfrom [encoding system] \ - [encoding convertto [encoding system] \u00c0]]] {} 0]\n + [encoding convertto [encoding system] À]]] {} 0]\n test Tcl_Main-1.6 { } -constraints { stdio } -setup { - makeFile {puts [list $argv0 $argv $tcl_interactive]} \u20ac - catch {set f [open "|[list [interpreter] \u20ac]" r]} + makeFile {puts [list $argv0 $argv $tcl_interactive]} € + catch {set f [open "|[list [interpreter] €]" r]} } -body { read $f } -cleanup { close $f - removeFile \u20ac + removeFile € } -result [list [list [encoding convertfrom [encoding system] \ - [encoding convertto [encoding system] \u20ac]]] {} 0]\n + [encoding convertto [encoding system] €]]] {} 0]\n test Tcl_Main-1.7 { Tcl_Main: startup script - -encoding option @@ -129,8 +129,8 @@ namespace eval ::tcl::test::main { set f [open $script w] chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} - puts -nonewline $f {puts [string equal \u20ac } - puts $f "\u20ac]" + puts -nonewline $f {puts [string equal € } + puts $f "€]" close $f catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]} } -body { @@ -151,7 +151,7 @@ namespace eval ::tcl::test::main { chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } - puts $f "\u20ac]" + puts $f "€]" close $f catch {set f [open "|[list [interpreter] -encoding ascii script]" r]} } -body { @@ -172,7 +172,7 @@ namespace eval ::tcl::test::main { chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } - puts $f "\u20ac]" + puts $f "€]" close $f catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]} } -body { @@ -606,8 +606,8 @@ namespace eval ::tcl::test::main { catch {set f [open "|[list [interpreter]]" w+]} catch {chan configure $f -blocking 0} } -body { - type $f "chan configure stdin -eofchar \"\\032 {}\" - if 1 \{\n\032" + type $f "chan configure stdin -eofchar \"\\x1A {}\" + if 1 \{\n\x1A" variable wait chan event $f readable \ [list set [namespace which -variable wait] "child exit"] diff --git a/tests/namespace.test b/tests/namespace.test index efd00a8..6eabf61 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -182,8 +182,8 @@ test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} } {} test namespace-7.7 {Bug 1655305} -setup { interp create child - # Can't invoke through the ensemble, since deleting the global namespace - # (indirectly, via deleting ::tcl) deletes the ensemble. + # Can't invoke through the ensemble, since deleting ::tcl + # (indirectly, via deleting the global namespace) deletes the ensemble. child eval {rename ::tcl::info::commands ::infocommands} child hide infocommands child eval { @@ -207,10 +207,72 @@ test namespace-7.8 {Bug ba1419303b4c} -setup { namespace delete ns1 } } -body { - # No segmentation fault given --enable-symbols=mem. + # No segmentation fault given --enable-symbols. namespace delete ns1 } -result {} + +test namespace-7.9 { + Bug e39cb3f462631a99 + + A namespace being deleted should not be removed from other namespace paths + until the contents of the namespace are entirely removed. +} -setup { + + + + +} -body { + + variable res {} + + + namespace eval ns1 { + proc p1 caller { + lappend [namespace parent]::res $caller + } + } + + + namespace eval ns1a { + namespace path [namespace parent]::ns1 + + proc t1 {old new op} { + $old t1 + } + } + + namespace eval ns2 { + proc p1 caller { + lappend [namespace parent]::res $caller + } + } + + namespace eval ns2a { + namespace path [namespace parent]::ns2 + + proc t1 {old new op} { + [namespace tail $old] t2 + } + } + + + trace add command ns1::p1 delete ns1a::t1 + namespace delete ns1 + + trace add command ns2::p1 delete ns2a::t1 + namespace delete ns2 + + return $res + +} -cleanup { + namespace delete ns1a + namespace delete ns2a + unset res +} -result {t1 t2} + + + test namespace-8.1 {TclTeardownNamespace, delete global namespace} { catch {interp delete test_interp} interp create test_interp @@ -2723,7 +2785,11 @@ test namespace-51.12 {name resolution path control} -body { catch {namespace delete ::test_ns_3} catch {namespace delete ::test_ns_4} } -test namespace-51.13 {name resolution path control} -body { +test namespace-51.13 { + name resolution path control + when the trace fires, ns_2 is being deleted but isn't gone yet, and is + still visible for the trace +} -body { set ::result {} namespace eval ::test_ns_1 { proc foo {} {lappend ::result 1} @@ -2746,8 +2812,7 @@ test namespace-51.13 {name resolution path control} -body { } bar } - # Should the result be "2 {} {2 3 2 1}" instead? -} -result {2 {} {2 3 1 1}} -cleanup { +} -result {2 {} {2 3 2 1}} -cleanup { catch {namespace delete ::test_ns_1} catch {namespace delete ::test_ns_2} catch {namespace delete ::test_ns_3} @@ -3340,6 +3405,43 @@ test namespace-56.5 {Bug 8b9854c3d8} -setup { } -result 1 +test namespace-56.6 { + Namespace deletion traces on both the original routine and the imported + routine should run without any memory error under a debug build. +} -body { + variable res {} + + proc ondelete {old new op} { + variable res + set tail [namespace tail $old] + set up [namespace tail [namespace qualifiers $old]] + lappend res [list $up $tail] + } + + + namespace eval ns1 {} { + namespace export * + proc p1 {} { + namespace upvar [namespace parent] res res + incr res + } + trace add command p1 delete ondelete + } + + namespace eval ns2 {} { + namespace import [namespace parent]::ns1::p1 + trace add command p1 delete ondelete + } + + namespace delete ns1 + namespace delete ns2 + after 1 + return $res +} -cleanup { + unset res + rename ondelete {} +} -result {{ns1 p1} {ns2 p1}} + test namespace-57.0 { an imported alias should be usable in the deletion trace for the alias diff --git a/tests/obj.test b/tests/obj.test index a2976de..4fa8d3a 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -251,10 +251,10 @@ test obj-13.7 {SetBooleanFromAny, error converting from "empty string"} testobj } {{} 1 {expected boolean value but got ""}} test obj-13.8 {SetBooleanFromAny, unicode strings} testobj { set result "" - lappend result [teststringobj set 1 1\u7777] + lappend result [teststringobj set 1 1睷] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg -} "1\u7777 1 {expected boolean value but got \"1\u7777\"}" +} "1睷 1 {expected boolean value but got \"1睷\"}" test obj-14.1 {UpdateStringOfBoolean} testobj { set result "" diff --git a/tests/parse.test b/tests/parse.test index 3bf0de9..b0c051b 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -31,7 +31,7 @@ testConstraint testevent [llength [info commands testevent]] testConstraint memory [llength [info commands memory]] test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {testparser testbytestring} { - testparser [testbytestring "foo\0 bar"] -1 + testparser [testbytestring "foo\x00 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser { testparser "foo bar" -1 @@ -300,8 +300,8 @@ test parse-6.15 {ParseTokens procedure, backslash-newline} testparser { testparser "\"b\\\nc\"" 0 } {- \"b\\\nc\" 1 word \"b\\\nc\" 3 text b 0 backslash \\\n 0 text c 0 {}} test parse-6.16 {ParseTokens procedure, backslash substitution} testparser { - testparser {\n\a\x7f} 0 -} {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}} + testparser {\n\a\x7F} 0 +} {- {\n\a\x7F} 1 word {\n\a\x7F} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7F} 0 {}} test parse-6.17 {ParseTokens procedure, null characters} {testparser testbytestring} { expr {[testparser [testbytestring "foo\0zz"] 0] eq "- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \0] 0 text zz 0 {}" @@ -707,7 +707,7 @@ test parse-13.6 {Tcl_ParseVar memory leak} -constraints {testparsevar memory} -s } -result 0 test parse-14.1 {Tcl_ParseBraces procedure, computing string length} {testparser testbytestring} { - testparser [testbytestring "foo\0 bar"] -1 + testparser [testbytestring "foo\x00 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-14.2 {Tcl_ParseBraces procedure, computing string length} testparser { testparser "foo bar" -1 @@ -744,7 +744,7 @@ test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} testparser { } {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"} test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} {testparser testbytestring} { - testparser [testbytestring "foo\0 bar"] -1 + testparser [testbytestring "foo\x00 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} testparser { testparser "foo bar" -1 @@ -910,10 +910,10 @@ test parse-15.54 {CommandComplete procedure} " info complete \"foo bar;# \{\" " 1 test parse-15.55 {CommandComplete procedure} testbytestring { - info complete "set x [testbytestring \0]; puts hi" + info complete "set x [testbytestring \x00]; puts hi" } 1 test parse-15.56 {CommandComplete procedure} testbytestring { - info complete "set x [testbytestring \0]; \{" + info complete "set x [testbytestring \x00]; \{" } 0 test parse-15.57 {CommandComplete procedure} { info complete "# Comment should be complete command" diff --git a/tests/parseExpr.test b/tests/parseExpr.test index 99ada39..c70c5e3 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -32,9 +32,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -44,19 +44,19 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -66,11 +66,11 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 @@ -85,7 +85,7 @@ testConstraint ieeeFloatingPoint [testIEEE] ###################################################################### test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {testexprparser testbytestring} { - testexprparser [testbytestring "1+2\0 +3"] -1 + testexprparser [testbytestring "1+2\x00 +3"] -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser { testexprparser "1 + 2" -1 @@ -882,17 +882,17 @@ test parseExpr-21.36 {error messages} -body { } -returnCodes error -result {invalid character "@" in expression "...fghijklmnopqrstuvwxyz"@"abcdefghijklmnopqrstu..."} test parseExpr-21.37 {error messages} -body { - expr [format {"%s" @ 0} [string repeat \u00a7 25]] + expr [format {"%s" @ 0} [string repeat \xA7 25]] } -returnCodes error -result [format {invalid character "@" -in expression "...%s" @ 0"} [string repeat \u00a7 10]] +in expression "...%s" @ 0"} [string repeat \xA7 10]] test parseExpr-21.38 {error messages} -body { - expr [format {0 @ "%s"} [string repeat \u00a7 25]] + expr [format {0 @ "%s"} [string repeat \xA7 25]] } -returnCodes error -result [format {invalid character "@" -in expression "0 @ "%s..."} [string repeat \u00a7 10]] +in expression "0 @ "%s..."} [string repeat \xA7 10]] test parseExpr-21.39 {error messages} -body { - expr [format {"%s" @ "%s"} [string repeat \u00a7 25] [string repeat \u00a7 25]] + expr [format {"%s" @ "%s"} [string repeat \xA7 25] [string repeat \xA7 25]] } -returnCodes error -result [format {invalid character "@" -in expression "...%s" @ "%s..."} [string repeat \u00a7 10] [string repeat \u00a7 10]] +in expression "...%s" @ "%s..."} [string repeat \xA7 10] [string repeat \xA7 10]] test parseExpr-21.40 {error messages} -body { catch {expr {"abcdefghijklmnopqrstuvwxyz"@0}} m o dict get $o -errorinfo @@ -902,13 +902,13 @@ in expression "...fghijklmnopqrstuvwxyz"@0" invoked from within "expr {"abcdefghijklmnopqrstuvwxyz"@0}"} test parseExpr-21.41 {error messages} -body { - catch {expr [format {"%s" @ 0} [string repeat \u00a7 25]]} m o + catch {expr [format {"%s" @ 0} [string repeat \xA7 25]]} m o dict get $o -errorinfo } -result [format {invalid character "@" in expression "...%s" @ 0" (parsing expression ""%s...") invoked from within -"expr [format {"%%s" @ 0} [string repeat \u00a7 25]]"} [string repeat \u00a7 10] [string repeat \u00a7 10]] +"expr [format {"%%s" @ 0} [string repeat \xA7 25]]"} [string repeat \xA7 10] [string repeat \xA7 10]] test parseExpr-21.42 {error message} -body { expr {123456789012345678901234567890*"abcdefghijklmnopqrstuvwxyz} } -returnCodes error -result {missing " @@ -1066,13 +1066,13 @@ test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body { } -result {TCL PARSE EXPR BADNUMBER BINARY} test parseExpr-22.19 {Bug d2ffcca163} -constraints testexprparser -body { - testexprparser \u0433 -1 + testexprparser г -1 } -returnCodes error -match glob -result {*invalid character*} test parseExpr-22.20 {Bug d2ffcca163} -constraints testexprparser -body { - testexprparser \u043f -1 + testexprparser п -1 } -returnCodes error -match glob -result {*invalid character*} test parseExpr-22.21 {Bug d2ffcca163} -constraints testexprparser -body { - testexprparser in\u0433(0) -1 + testexprparser inг(0) -1 } -returnCodes error -match glob -result {missing operand*} test parseExpr-23.1 {TIP 582: comments} -constraints testexprparser -body { diff --git a/tests/parseOld.test b/tests/parseOld.test index f8caf24..44aa5d1 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -22,7 +22,6 @@ if {"::tcltest" ni [namespace children]} { catch [list package require -exact tcl::test [info patchlevel]] testConstraint testwordend [llength [info commands testwordend]] -testConstraint testbytestring [llength [info commands testbytestring]] # Save the argv value for restoration later set savedArgv $argv @@ -264,14 +263,14 @@ test parseOld-7.10 {backslash substitution} { test parseOld-7.11 {backslash substitution} { eval "list a \"b c\"\\\nd e" } {a {b c} d e} -test parseOld-7.12 {backslash substitution} testbytestring { - expr {[list \ua2] eq [testbytestring "\xc2\xa2"]} +test parseOld-7.12 {backslash substitution} { + expr {[list \uA2] eq "¢"} } 1 -test parseOld-7.13 {backslash substitution} testbytestring { - expr {[list \u4e21] eq [testbytestring "\xe4\xb8\xa1"]} +test parseOld-7.13 {backslash substitution} { + expr {[list \u4E21] eq "両"} } 1 -test parseOld-7.14 {backslash substitution} testbytestring { - expr {[list \u4e2k] eq [testbytestring "\xd3\xa2k"]} +test parseOld-7.14 {backslash substitution} { + expr {[list \u4E2k] eq "Ӣk"} } 1 # Semi-colon. diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index df49c32..62bd3d4 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -577,19 +577,21 @@ test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] { exec [interpreter] << $cmd pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl } "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" + test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] { # Do all [load]ing of shared libraries in another process, so we can # delete the file and not get stuck because we're holding a reference to # it. # # This test depends on context from prior test, so repeat it. + set script \ "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]" append script \n \ "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]" exec [interpreter] << $script pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension] -} {0 {}} +} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}}}}}" if {[testConstraint $dll]} { file delete -force [file join $fullPkgPath [file tail $x]] diff --git a/tests/proc.test b/tests/proc.test index 23aea28..ab32567 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -17,6 +17,7 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands testConstraint tcl::test [expr {![catch {package require tcl::test}]}] testConstraint memory [llength [info commands memory]] diff --git a/tests/reg.test b/tests/reg.test index 3c9020d..b6198d8 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -514,8 +514,8 @@ expectMatch 9.40 eE {a[\\]b} "a\\b" "a\\b" expectMatch 9.41 bE {a[\\]b} "a\\b" "a\\b" expectError 9.42 - {a[\Z]b} EESCAPE expectMatch 9.43 & {a[[b]c} "a\[c" "a\[c" -expectMatch 9.44 EMP* {a[\u00fe-\u0507][\u00ff-\u0300]b} \ - "a\u0102\u02ffb" "a\u0102\u02ffb" +expectMatch 9.44 EMP* {a[\xFE-\u0507][\xFF-\u0300]b} \ + "a\u0102\u02FFb" "a\u0102\u02FFb" doing 10 "anchors and newlines" @@ -643,8 +643,8 @@ expectMatch 13.29 P "a\\U0001234x" "a\u1234x" "a\u1234x" expectMatch 13.30 P {a\U0001234x} "a\u1234x" "a\u1234x" expectMatch 13.31 P "a\\U000012345x" "a\u12345x" "a\u12345x" expectMatch 13.32 P {a\U000012345x} "a\u12345x" "a\u12345x" -expectMatch 13.33 P "a\\U1000000x" "a\ufffd0x" "a\ufffd0x" -expectMatch 13.34 P {a\U1000000x} "a\ufffd0x" "a\ufffd0x" +expectMatch 13.33 P "a\\U1000000x" "a\uFFFD0x" "a\uFFFD0x" +expectMatch 13.34 P {a\U1000000x} "a\uFFFD0x" "a\uFFFD0x" doing 14 "back references" @@ -1221,6 +1221,10 @@ test reg-33.29 {} { test reg-33.30 {Bug 1080042} { regexp {(\Y)+} foo } 1 +test reg-33.31 {Bug 7c64aa5e1a} { + regexp -inline {(?b).\{1,10\}} {abcdef} +} abcdef + # cleanup ::tcltest::cleanupTests diff --git a/tests/regexp.test b/tests/regexp.test index 842789e..6bed21e 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -19,6 +19,7 @@ if {"::tcltest" ni [namespace children]} { unset -nocomplain foo testConstraint exec [llength [info commands exec]] +testConstraint nodep [info exists tcl_precision] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -54,8 +55,8 @@ test regexp-1.6 {basic regexp operation} { } {0 1} test regexp-1.7 {regexp utf compliance} { # if not UTF-8 aware, result is "0 1" - set foo "\u4e4eb q" - regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar + set foo "乎b q" + regexp "乎b q" "a乎b qw幎N wq" bar list [string compare $foo $bar] [regexp 4 $bar] } {0 0} test regexp-1.8 {regexp ***= metasyntax} { @@ -194,14 +195,14 @@ test regexp-3.7 {getting substrings back from regexp} { } {1 {1 2} {1 1} {-1 -1} {2 2}} test regexp-3.8a {-indices by multi-byte utf-8} { regexp -inline -indices {(\w+)-(\w+)} \ - "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442" + "grüß-привет" } {{0 10} {0 3} {5 10}} test regexp-3.8b {-indices by multi-byte utf-8, from -start position} { list\ [regexp -inline -indices -start 3 {(\w+)-(\w+)} \ - "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] \ + "grüß-привет"] \ [regexp -inline -indices -start 4 {(\w+)-(\w+)} \ - "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] + "grüß-привет"] } {{{3 10} {3 3} {5 10}} {}} test regexp-4.1 {-nocase option to regexp} { @@ -352,8 +353,8 @@ test regexp-7.16 {basic regsub operation} { } {0 {}} test regexp-7.17 {regsub utf compliance} { # if not UTF-8 aware, result is "0 1" - set foo "xyz555ijka\u4e4ebpqr" - regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar + set foo "xyz555ijka乎bpqr" + regsub a乎b xyza乎bijka乎bpqr 555 bar list [string compare $foo $bar] [regexp 4 $bar] } {0 0} test regexp-7.18 {basic regsub replacement} { @@ -765,7 +766,7 @@ test regexp-19.2 {regsub null replacement} { string equal $result $expected } 1 -test regexp-20.1 {regsub shared object shimmering} -body { +test regexp-20.1 {regsub shared object shimmering} -constraints nodep -body { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz set b $a diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 4dfc2e6..1587c72 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -16,6 +16,8 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +testConstraint nodep [info exists tcl_precision] + # Procedure to evaluate a script within a proc, to test compilation # functionality @@ -62,8 +64,8 @@ test regexpComp-1.6 {basic regexp operation} { test regexpComp-1.7 {regexp utf compliance} { # if not UTF-8 aware, result is "0 1" evalInProc { - set foo "\u4e4eb q" - regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar + set foo "乎b q" + regexp "乎b q" "a乎b qw幎N wq" bar list [string compare $foo $bar] [regexp 4 $bar] } } {0 0} @@ -447,8 +449,8 @@ test regexpComp-7.16 {basic regsub operation} { test regexpComp-7.17 {regsub utf compliance} { evalInProc { # if not UTF-8 aware, result is "0 1" - set foo "xyz555ijka\u4e4ebpqr" - regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar + set foo "xyz555ijka乎bpqr" + regsub a乎b xyza乎bijka乎bpqr 555 bar list [string compare $foo $bar] [regexp 4 $bar] } } {0 0} @@ -791,7 +793,7 @@ test regexpComp-19.1 {regsub null replacement} { } } "\0a\0hel\0a\0lo\0a\0 14" -test regexpComp-20.1 {regsub shared object shimmering} { +test regexpComp-20.1 {regsub shared object shimmering} nodep { evalInProc { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz diff --git a/tests/safe-zipfs.test b/tests/safe-zipfs.test index f67bc43..a6088c4 100644 --- a/tests/safe-zipfs.test +++ b/tests/safe-zipfs.test @@ -13,714 +13,714 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 - namespace import -force ::tcltest::* -} -foreach i [interp children] { - interp delete $i -} +apply [list {} { + global auto_path + global tcl_library + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } -set SaveAutoPath $::auto_path -set ::auto_path [info library] -set TestsDir [file normalize [file dirname [info script]]] + foreach i [interp children] { + interp delete $i + } -set ZipMountPoint [zipfs root]auto-files -zipfs mount $ZipMountPoint [file join $TestsDir auto-files.zip] + set SaveAutoPath $::auto_path + set ::auto_path [info library] + set TestsDir [file normalize [file dirname [info script]]] -set PathMapp {} -lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR $ZipMountPoint ZIPDIR + set ZipMountPoint [zipfs root]auto-files + zipfs mount $ZipMountPoint [file join $TestsDir auto-files.zip] -proc mapList {map listIn} { - set listOut {} - foreach element $listIn { - lappend listOut [string map $map $element] - } - return $listOut -} -proc mapAndSortList {map listIn} { - set listOut {} - foreach element $listIn { - lappend listOut [string map $map $element] - } - lsort $listOut -} - -# Force actual loading of the safe package because we use un-exported (and -# thus un-autoindexed) APIs in this test result arguments: -catch {safe::interpConfigure} - -# testing that nested and statics do what is advertised (we use a -# package - tcl::test - but it might be absent if we're in standard tclsh) - -testConstraint tcl::test [expr {![catch {package require tcl::test}]}] - -# Tests 5.* test the example files before using them to test safe interpreters. - -test safe-zipfs-5.1 {example tclIndex commands, test in parent interpreter; zipfs} -setup { - set tmpAutoPath $::auto_path - lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2] -} -body { - # Try to load the commands. - set code3 [catch report1 msg3] - set code4 [catch report2 msg4] - list $code3 $msg3 $code4 $msg4 -} -cleanup { - catch {rename report1 {}} - catch {rename report2 {}} - set ::auto_path $tmpAutoPath - auto_reset -} -match glob -result {0 ok1 0 ok2} -test safe-zipfs-5.2 {example tclIndex commands, negative test in parent interpreter; zipfs} -setup { - set tmpAutoPath $::auto_path - lappend ::auto_path [file join $ZipMountPoint auto0] -} -body { - # Try to load the commands. - set code3 [catch report1 msg3] - set code4 [catch report2 msg4] - list $code3 $msg3 $code4 $msg4 -} -cleanup { - catch {rename report1 {}} - catch {rename report2 {}} - set ::auto_path $tmpAutoPath - auto_reset -} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} -test safe-zipfs-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories; zipfs} -setup { - set tmpAutoPath $::auto_path - lappend ::auto_path [file join $ZipMountPoint auto0] -} -body { - # Try to load the packages and run a command from each one. - set code3 [catch {package require SafeTestPackage1} msg3] - set code4 [catch {package require SafeTestPackage2} msg4] - set code5 [catch HeresPackage1 msg5] - set code6 [catch HeresPackage2 msg6] - list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 -} -cleanup { - set ::auto_path $tmpAutoPath - catch {package forget SafeTestPackage1} - catch {package forget SafeTestPackage2} - catch {rename HeresPackage1 {}} - catch {rename HeresPackage2 {}} -} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} -test safe-zipfs-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories; zipfs} -setup { - set tmpAutoPath $::auto_path - lappend ::auto_path [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2] -} -body { - # Try to load the packages and run a command from each one. - set code3 [catch {package require SafeTestPackage1} msg3] - set code4 [catch {package require SafeTestPackage2} msg4] - set code5 [catch HeresPackage1 msg5] - set code6 [catch HeresPackage2 msg6] - list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 -} -cleanup { - set ::auto_path $tmpAutoPath - catch {package forget SafeTestPackage1} - catch {package forget SafeTestPackage2} - catch {rename HeresPackage1 {}} - catch {rename HeresPackage2 {}} -} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} -test safe-zipfs-5.5 {example modules packages, test in parent interpreter, replace path; zipfs} -setup { - set oldTm [tcl::tm::path list] - foreach path $oldTm { - tcl::tm::path remove $path + set PathMapp {} + lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR $ZipMountPoint ZIPDIR + + proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut } - tcl::tm::path add [file join $ZipMountPoint auto0 modules] -} -body { - # Try to load the modules and run a command from each one. - set code0 [catch {package require test0} msg0] - set code1 [catch {package require mod1::test1} msg1] - set code2 [catch {package require mod2::test2} msg2] - set out0 [test0::try0] - set out1 [mod1::test1::try1] - set out2 [mod2::test2::try2] - list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 -} -cleanup { - tcl::tm::path remove [file join $ZipMountPoint auto0 modules] - foreach path [lreverse $oldTm] { - tcl::tm::path add $path + proc mapAndSortList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + lsort $listOut } - catch {package forget test0} - catch {package forget mod1::test1} - catch {package forget mod2::test2} - catch {namespace delete ::test0} - catch {namespace delete ::mod1} -} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} -test safe-zipfs-5.6 {example modules packages, test in parent interpreter, append to path; zipfs} -setup { - tcl::tm::path add [file join $ZipMountPoint auto0 modules] -} -body { - # Try to load the modules and run a command from each one. - set code0 [catch {package require test0} msg0] - set code1 [catch {package require mod1::test1} msg1] - set code2 [catch {package require mod2::test2} msg2] - set out0 [test0::try0] - set out1 [mod1::test1::try1] - set out2 [mod2::test2::try2] - list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 -} -cleanup { - tcl::tm::path remove [file join $ZipMountPoint auto0 modules] - catch {package forget test0} - catch {package forget mod1::test1} - catch {package forget mod2::test2} - catch {namespace delete ::test0} - catch {namespace delete ::mod1} -} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} - -# high level general test -# Use zipped example packages not http1.0 etc -test safe-zipfs-7.1 {tests that everything works at high level; zipfs} -setup { - set tmpAutoPath $::auto_path - lappend ::auto_path [file join $ZipMountPoint auto0] - set i [safe::interpCreate] - set ::auto_path $tmpAutoPath -} -body { - # no error shall occur: - # (because the default access_path shall include 1st level sub dirs so - # package require in a child works like in the parent) - set v [interp eval $i {package require SafeTestPackage1}] - # no error shall occur: - interp eval $i {HeresPackage1} - set v -} -cleanup { - safe::interpDelete $i -} -match glob -result 1.2.3 -test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath; zipfs} -setup { -} -body { - set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] - # should not add anything (p0) - set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p* (not p1 if parent has a module path) - set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # should add as p* (not p2 if parent has a module path) - set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]] - set confA [safe::interpConfigure $i] - set mappA [mapList $PathMapp [dict get $confA -accessPath]] - # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level - # provided deep path) - list $token1 $token2 $token3 -- \ + + # Force actual loading of the safe package because we use un-exported (and + # thus un-autoindexed) APIs in this test result arguments: + catch {safe::interpConfigure} + + # Tests 5.* test the example files before using them to test safe interpreters. + + test safe-zipfs-5.1 {example tclIndex commands, test in parent interpreter; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2] + } -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 + } -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset + } -match glob -result {0 ok1 0 ok2} + test safe-zipfs-5.2 {example tclIndex commands, negative test in parent interpreter; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] + } -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 + } -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset + } -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} + test safe-zipfs-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] + } -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 + } -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} + } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} + test safe-zipfs-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2] + } -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 + } -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} + } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} + test safe-zipfs-5.5 {example modules packages, test in parent interpreter, replace path; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] + } -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 + } -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} + } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + test safe-zipfs-5.6 {example modules packages, test in parent interpreter, append to path; zipfs} -setup { + tcl::tm::path add [file join $ZipMountPoint auto0 modules] + } -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 + } -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} + } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + + # high level general test + # Use zipped example packages not http1.0 etc + test safe-zipfs-7.1 {tests that everything works at high level; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] + set i [safe::interpCreate] + set ::auto_path $tmpAutoPath + } -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a child works like in the parent) + set v [interp eval $i {package require SafeTestPackage1}] + # no error shall occur: + interp eval $i {HeresPackage1} + set v + } -cleanup { + safe::interpDelete $i + } -match glob -result 1.2.3 + test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath; zipfs} -setup { + } -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # should add as p* (not p2 if parent has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 $token3 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] + } -cleanup { + } -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ + 1 {can't find package SafeTestPackage1} --\ + {TCLLIB */dummy/unixlike/test/path ZIPDIR/auto0} -- {}} + test safe-zipfs-7.4 {tests specific path and positive search; zipfs} -setup { + } -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-zipfs-7.2, SafeTestPackage1 should be found + list $token1 $token2 -- \ [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ $mappA -- [safe::interpDelete $i] -} -cleanup { -} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ - 1 {can't find package SafeTestPackage1} --\ - {TCLLIB */dummy/unixlike/test/path ZIPDIR/auto0} -- {}} -test safe-zipfs-7.4 {tests specific path and positive search; zipfs} -setup { -} -body { - set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] - # should not add anything (p0) - set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p* (not p1 if parent has a module path) - set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set confA [safe::interpConfigure $i] - set mappA [mapList $PathMapp [dict get $confA -accessPath]] - # this time, unlike test safe-zipfs-7.2, SafeTestPackage1 should be found - list $token1 $token2 -- \ - [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ - $mappA -- [safe::interpDelete $i] - # Note that the glob match elides directories (those from the module path) - # other than the first and last in the access path. -} -cleanup { -} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ - {TCLLIB * ZIPDIR/auto0/auto1} -- {}} - -test safe-zipfs-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset); zipfs} -setup { -} -body { - set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]]] - # Inspect. - set confA [safe::interpConfigure $i] - set mappA [mapList $PathMapp [dict get $confA -accessPath]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Load auto_load data. - interp eval $i {catch nonExistentCommand} - - # Load and run the commands. - # This guarantees the test will pass even if the tokens are swapped. - set code1 [catch {interp eval $i {report1}} msg1] - set code2 [catch {interp eval $i {report2}} msg2] - - # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto2] \ - [file join $ZipMountPoint auto0 auto1]] - # Inspect. - set confB [safe::interpConfigure $i] - set mappB [mapList $PathMapp [dict get $confB -accessPath]] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Run the commands. - set code3 [catch {interp eval $i {report1}} msg3] - set code4 [catch {interp eval $i {report2}} msg4] - - list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB -} -cleanup { - safe::interpDelete $i -} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ - {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ - {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}} -test safe-zipfs-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset); zipfs} -setup { -} -body { - set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]]] - # Inspect. - set confA [safe::interpConfigure $i] - set mappA [mapList $PathMapp [dict get $confA -accessPath]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Load auto_load data. - interp eval $i {catch nonExistentCommand} - - # Do not load the commands. With the tokens swapped, the test - # will pass only if the Safe Base has called auto_reset. - - # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto2] \ - [file join $ZipMountPoint auto0 auto1]] - # Inspect. - set confB [safe::interpConfigure $i] - set mappB [mapList $PathMapp [dict get $confB -accessPath]] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Load and run the commands. - set code3 [catch {interp eval $i {report1}} msg3] - set code4 [catch {interp eval $i {report2}} msg4] - - list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB -} -cleanup { - safe::interpDelete $i -} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ - 0 ok1 0 ok2 --\ - {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ - {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}} -test safe-zipfs-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement; zipfs} -setup { -} -body { - # For complete correspondence to safe-stock87-9.11, include auto0 in access path. - set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0] \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]]] - # Inspect. - set confA [safe::interpConfigure $i] - set mappA [mapList $PathMapp [dict get $confA -accessPath]] - set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Load pkgIndex.tcl data. - catch {interp eval $i {package require NOEXIST}} - - # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. - # This would have no effect because the records in Pkg of these directories - # were from access as children of {$p(:1:)}. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0] \ - [file join $ZipMountPoint auto0 auto2] \ - [file join $ZipMountPoint auto0 auto1]] - # Inspect. - set confB [safe::interpConfigure $i] - set mappB [mapList $PathMapp [dict get $confB -accessPath]] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Try to load the packages and run a command from each one. - set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] - set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] - set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] - set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] - - list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ - $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 -} -cleanup { - safe::interpDelete $i -} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ - {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ - {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} --\ - 0 OK1 0 OK2} -test safe-zipfs-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0; zipfs} -setup { -} -body { - set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]]] - # Inspect. - set confA [safe::interpConfigure $i] - set mappA [mapList $PathMapp [dict get $confA -accessPath]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Load pkgIndex.tcl data. - catch {interp eval $i {package require NOEXIST}} - - # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto2] \ - [file join $ZipMountPoint auto0 auto1]] - # Inspect. - set confB [safe::interpConfigure $i] - set mappB [mapList $PathMapp [dict get $confB -accessPath]] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Try to load the packages and run a command from each one. - set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] - set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] - set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] - set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] - - list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ - $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 -} -cleanup { - safe::interpDelete $i -} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ - 0 1.2.3 0 2.3.4 --\ - {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ - {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} --\ - 0 OK1 0 OK2} -test safe-zipfs-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed; zipfs} -setup { -} -body { - set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]]] - # Inspect. - set confA [safe::interpConfigure $i] - set mappA [mapList $PathMapp [dict get $confA -accessPath]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Load pkgIndex.tcl data. - catch {interp eval $i {package require NOEXIST}} - - # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. - safe::interpConfigure $i -accessPath [list $tcl_library] - - # Inspect. - set confB [safe::interpConfigure $i] - set mappB [mapList $PathMapp [dict get $confB -accessPath]] - set code4 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]} path4] - set code5 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]} path5] - - # Try to load the packages. - set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] - set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] - - list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ - $mappA -- $mappB -} -cleanup { - safe::interpDelete $i -} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ - 1 {* not found in access path} -- 1 1 --\ - {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB*}} -test safe-zipfs-9.20 {check module loading; zipfs} -setup { - set oldTm [tcl::tm::path list] - foreach path $oldTm { - tcl::tm::path remove $path - } - tcl::tm::path add [file join $ZipMountPoint auto0 modules] -} -body { - set i [safe::interpCreate -accessPath [list $tcl_library]] - - # Inspect. - set confA [safe::interpConfigure $i] - set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] - set modsA [interp eval $i {tcl::tm::path list}] - set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] - - # Try to load the packages and run a command from each one. - set code0 [catch {interp eval $i {package require test0}} msg0] - set code1 [catch {interp eval $i {package require mod1::test1}} msg1] - set code2 [catch {interp eval $i {package require mod2::test2}} msg2] - set out0 [interp eval $i {test0::try0}] - set out1 [interp eval $i {mod1::test1::try1}] - set out2 [interp eval $i {mod2::test2::try2}] - - list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2 -} -cleanup { - tcl::tm::path remove [file join $ZipMountPoint auto0 modules] - foreach path [lreverse $oldTm] { - tcl::tm::path add $path - } - safe::interpDelete $i -} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ - 0 0.5 0 1.0 0 2.0 --\ - {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ - ZIPDIR/auto0/modules/mod2} -- res0 res1 res2} -# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in -# tokenized form to the child's access path, and then adds all the -# descendants, discovered recursively by using glob. -# - The order of the directories in the list returned by glob is system-dependent, -# and therefore this is true also for (a) the order of token assignment to -# descendants of the [tcl::tm::list] roots; and (b) the order of those same -# directories in the access path. Both those things must be sorted before -# comparing with expected results. The test is therefore not totally strict, -# but will notice missing or surplus directories. -test safe-zipfs-9.21 {interpConfigure change the access path; check module loading; stale data case 1; zipfs} -setup { - set oldTm [tcl::tm::path list] - foreach path $oldTm { - tcl::tm::path remove $path - } - tcl::tm::path add [file join $ZipMountPoint auto0 modules] -} -body { - set i [safe::interpCreate -accessPath [list $tcl_library]] - - # Inspect. - set confA [safe::interpConfigure $i] - set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] - set modsA [interp eval $i {tcl::tm::path list}] - set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] - - # Add to access path. - # This injects more tokens, pushing modules to higher token numbers. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]] - # Inspect. - set confB [safe::interpConfigure $i] - set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] - set modsB [interp eval $i {tcl::tm::path list}] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] - - # Load pkg data. - catch {interp eval $i {package require NOEXIST}} - catch {interp eval $i {package require mod1::NOEXIST}} - catch {interp eval $i {package require mod2::NOEXIST}} - - # Try to load the packages and run a command from each one. - set code0 [catch {interp eval $i {package require test0}} msg0] - set code1 [catch {interp eval $i {package require mod1::test1}} msg1] - set code2 [catch {interp eval $i {package require mod2::test2}} msg2] - set out0 [interp eval $i {test0::try0}] - set out1 [interp eval $i {mod1::test1::try1}] - set out2 [interp eval $i {mod2::test2::try2}] - - list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ - [lsort [list $path3 $path4 $path5]] -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ - $out0 $out1 $out2 -} -cleanup { - tcl::tm::path remove [file join $ZipMountPoint auto0 modules] - foreach path [lreverse $oldTm] { - tcl::tm::path add $path - } - safe::interpDelete $i -} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ - {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ - 0 0.5 0 1.0 0 2.0 --\ - {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ - ZIPDIR/auto0/modules/mod2} --\ - {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ - ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ - res0 res1 res2} -# See comments on lsort after test safe-zipfs-9.20. -test safe-zipfs-9.22 {interpConfigure change the access path; check module loading; stale data case 0; zipfs} -setup { - set oldTm [tcl::tm::path list] - foreach path $oldTm { - tcl::tm::path remove $path - } - tcl::tm::path add [file join $ZipMountPoint auto0 modules] -} -body { - set i [safe::interpCreate -accessPath [list $tcl_library]] - - # Inspect. - set confA [safe::interpConfigure $i] - set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] - set modsA [interp eval $i {tcl::tm::path list}] - set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] - - # Add to access path. - # This injects more tokens, pushing modules to higher token numbers. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]] - # Inspect. - set confB [safe::interpConfigure $i] - set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] - set modsB [interp eval $i {tcl::tm::path list}] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] - - # Try to load the packages and run a command from each one. - set code0 [catch {interp eval $i {package require test0}} msg0] - set code1 [catch {interp eval $i {package require mod1::test1}} msg1] - set code2 [catch {interp eval $i {package require mod2::test2}} msg2] - set out0 [interp eval $i {test0::try0}] - set out1 [interp eval $i {mod1::test1::try1}] - set out2 [interp eval $i {mod2::test2::try2}] - - list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ - [lsort [list $path3 $path4 $path5]] -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ - $out0 $out1 $out2 -} -cleanup { - tcl::tm::path remove [file join $ZipMountPoint auto0 modules] - foreach path [lreverse $oldTm] { - tcl::tm::path add $path - } - safe::interpDelete $i -} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ - {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ - 0 0.5 0 1.0 0 2.0 --\ - {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ - ZIPDIR/auto0/modules/mod2} --\ - {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ - ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ - res0 res1 res2} -# See comments on lsort after test safe-zipfs-9.20. -test safe-zipfs-9.23 {interpConfigure change the access path; check module loading; stale data case 3; zipfs} -setup { - set oldTm [tcl::tm::path list] - foreach path $oldTm { - tcl::tm::path remove $path - } - tcl::tm::path add [file join $ZipMountPoint auto0 modules] -} -body { - set i [safe::interpCreate -accessPath [list $tcl_library]] - - # Inspect. - set confA [safe::interpConfigure $i] - set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] - set modsA [interp eval $i {tcl::tm::path list}] - set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] - - # Force the interpreter to acquire pkg data which will soon become stale. - catch {interp eval $i {package require NOEXIST}} - catch {interp eval $i {package require mod1::NOEXIST}} - catch {interp eval $i {package require mod2::NOEXIST}} - - # Add to access path. - # This injects more tokens, pushing modules to higher token numbers. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]] - # Inspect. - set confB [safe::interpConfigure $i] - set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] - set modsB [interp eval $i {tcl::tm::path list}] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] - - # Refresh stale pkg data. - catch {interp eval $i {package require NOEXIST}} - catch {interp eval $i {package require mod1::NOEXIST}} - catch {interp eval $i {package require mod2::NOEXIST}} - - # Try to load the packages and run a command from each one. - set code0 [catch {interp eval $i {package require test0}} msg0] - set code1 [catch {interp eval $i {package require mod1::test1}} msg1] - set code2 [catch {interp eval $i {package require mod2::test2}} msg2] - set out0 [interp eval $i {test0::try0}] - set out1 [interp eval $i {mod1::test1::try1}] - set out2 [interp eval $i {mod2::test2::try2}] - - list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ - [lsort [list $path3 $path4 $path5]] -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ - $out0 $out1 $out2 -} -cleanup { - tcl::tm::path remove [file join $ZipMountPoint auto0 modules] - foreach path [lreverse $oldTm] { - tcl::tm::path add $path - } - safe::interpDelete $i -} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ - {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ - 0 0.5 0 1.0 0 2.0 --\ - {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ - ZIPDIR/auto0/modules/mod2} --\ - {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ - ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ - res0 res1 res2} -# See comments on lsort after test safe-zipfs-9.20. -test safe-zipfs-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case); zipfs} -setup { - set oldTm [tcl::tm::path list] - foreach path $oldTm { - tcl::tm::path remove $path - } - tcl::tm::path add [file join $ZipMountPoint auto0 modules] -} -body { - set i [safe::interpCreate -accessPath [list $tcl_library]] - - # Inspect. - set confA [safe::interpConfigure $i] - set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] - set modsA [interp eval $i {tcl::tm::path list}] - set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] - - # Force the interpreter to acquire pkg data which will soon become stale. - catch {interp eval $i {package require NOEXIST}} - catch {interp eval $i {package require mod1::NOEXIST}} - catch {interp eval $i {package require mod2::NOEXIST}} - - # Add to access path. - # This injects more tokens, pushing modules to higher token numbers. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]] - # Inspect. - set confB [safe::interpConfigure $i] - set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] - set modsB [interp eval $i {tcl::tm::path list}] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] - - # Try to load the packages and run a command from each one. - set code0 [catch {interp eval $i {package require test0}} msg0] - set code1 [catch {interp eval $i {package require mod1::test1}} msg1] - set code2 [catch {interp eval $i {package require mod2::test2}} msg2] - set out0 [interp eval $i {test0::try0}] - set out1 [interp eval $i {mod1::test1::try1}] - set out2 [interp eval $i {mod2::test2::try2}] - - list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ - [lsort [list $path3 $path4 $path5]] -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ - $out0 $out1 $out2 -} -cleanup { - tcl::tm::path remove [file join $ZipMountPoint auto0 modules] - foreach path [lreverse $oldTm] { - tcl::tm::path add $path - } - safe::interpDelete $i -} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ - {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ - 0 0.5 0 1.0 0 2.0 --\ - {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ - ZIPDIR/auto0/modules/mod2} --\ - {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ - ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ - res0 res1 res2} -# See comments on lsort after test safe-zipfs-9.20. - -# cleanup -set ::auto_path $SaveAutoPath -zipfs unmount ${ZipMountPoint} -unset SaveAutoPath TestsDir ZipMountPoint PathMapp -rename mapList {} -rename mapAndSortList {} -::tcltest::cleanupTests -return + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. + } -cleanup { + } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ + {TCLLIB * ZIPDIR/auto0/auto1} -- {}} + + test safe-zipfs-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset); zipfs} -setup { + } -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB + } -cleanup { + safe::interpDelete $i + } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}} + test safe-zipfs-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset); zipfs} -setup { + } -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB + } -cleanup { + safe::interpDelete $i + } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 ok1 0 ok2 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}} + test safe-zipfs-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement; zipfs} -setup { + } -body { + # For complete correspondence to safe-stock87-9.11, include auto0 in access path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0] \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0] \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 + } -cleanup { + safe::interpDelete $i + } -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} + test safe-zipfs-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0; zipfs} -setup { + } -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 + } -cleanup { + safe::interpDelete $i + } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 1.2.3 0 2.3.4 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} + test safe-zipfs-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed; zipfs} -setup { + } -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ + $mappA -- $mappB + } -cleanup { + safe::interpDelete $i + } -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB*}} + test safe-zipfs-9.20 {check module loading; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] + } -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2 + } -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} -- res0 res1 res2} + # - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in + # tokenized form to the child's access path, and then adds all the + # descendants, discovered recursively by using glob. + # - The order of the directories in the list returned by glob is system-dependent, + # and therefore this is true also for (a) the order of token assignment to + # descendants of the [tcl::tm::list] roots; and (b) the order of those same + # directories in the access path. Both those things must be sorted before + # comparing with expected results. The test is therefore not totally strict, + # but will notice missing or surplus directories. + test safe-zipfs-9.21 {interpConfigure change the access path; check module loading; stale data case 1; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] + } -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 + } -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} + # See comments on lsort after test safe-zipfs-9.20. + test safe-zipfs-9.22 {interpConfigure change the access path; check module loading; stale data case 0; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] + } -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 + } -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} + # See comments on lsort after test safe-zipfs-9.20. + test safe-zipfs-9.23 {interpConfigure change the access path; check module loading; stale data case 3; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] + } -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 + } -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} + # See comments on lsort after test safe-zipfs-9.20. + test safe-zipfs-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case); zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] + } -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 + } -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} + # See comments on lsort after test safe-zipfs-9.20. + + # cleanup + set ::auto_path $SaveAutoPath + zipfs unmount ${ZipMountPoint} + unset SaveAutoPath TestsDir ZipMountPoint PathMapp + rename mapList {} + rename mapAndSortList {} + ::tcltest::cleanupTests + return +} [namespace current]] # Local Variables: # mode: tcl diff --git a/tests/safe.test b/tests/safe.test index db881c2..773b16f 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -24,6 +24,8 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] foreach i [interp children] { interp delete $i @@ -1159,58 +1161,58 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st res0 res1 res2} # See comments on lsort after test safe-9.20. -catch {teststaticpkg Safepkg1 0 0} +catch {teststaticlibrary Safepfx1 0 0} test safe-10.1 {testing statics loading} -constraints tcl::test -setup { set i [safe::interpCreate] } -body { - interp eval $i {load {} Safepkg1} + interp eval $i {load {} Safepfx1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure} test safe-10.1.1 {testing statics loading} -constraints tcl::test -setup { set i [safe::interpCreate] } -body { - catch {interp eval $i {load {} Safepkg1}} m o + catch {interp eval $i {load {} Safepfx1}} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure invoked from within -"load {} Safepkg1" +"load {} Safepfx1" invoked from within -"interp eval $i {load {} Safepkg1}"} +"interp eval $i {load {} Safepfx1}"} test safe-10.2 {testing statics loading / -nostatics} -constraints tcl::test -body { set i [safe::interpCreate -nostatics] - interp eval $i {load {} Safepkg1} + interp eval $i {load {} Safepfx1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {permission denied (static package)} +} -result {permission denied (static library)} test safe-10.3 {testing nested statics loading / no nested by default} -setup { set i [safe::interpCreate] } -constraints tcl::test -body { - interp eval $i {interp create x; load {} Safepkg1 x} + interp eval $i {interp create x; load {} Safepfx1 x} } -returnCodes error -cleanup { safe::interpDelete $i } -result {permission denied (nested load)} test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body { set i [safe::interpCreate -nestedloadok] - interp eval $i {interp create x; load {} Safepkg1 x} + interp eval $i {interp create x; load {} Safepfx1 x} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure} test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body { set i [safe::interpCreate -nestedloadok] - catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o + catch {interp eval $i {interp create x; load {} Safepfx1 x}} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure invoked from within -"load {} Safepkg1 x" +"load {} Safepfx1 x" invoked from within -"interp eval $i {interp create x; load {} Safepkg1 x}"} +"interp eval $i {interp create x; load {} Safepfx1 x}"} test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] diff --git a/tests/scan.test b/tests/scan.test index c125080..c6e7922 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -32,9 +32,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -44,19 +44,19 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -66,11 +66,11 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 @@ -639,18 +639,18 @@ test scan-7.5 {string and character scanning} -setup { test scan-7.6 {string and character scanning, unicode} -setup { set a {}; set b {}; set c {}; set d {} } -body { - list [scan "abc d\u00c7fghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d -} -result "4 abc d\u00c7f ghijk dum" + list [scan "abc dÇfghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d +} -result "4 abc dÇf ghijk dum" test scan-7.7 {string and character scanning, unicode} -setup { set a {}; set b {} } -body { - list [scan "ab\u00c7cdef" "ab%c%c" a b] $a $b + list [scan "abÇcdef" "ab%c%c" a b] $a $b } -result "2 199 99" test scan-7.8 {string and character scanning, unicode} -setup { set a {}; set b {} } -body { - list [scan "ab\ufeffdef" "%\[ab\ufeff\]" a] $a -} -result "1 ab\ufeff" + list [scan "ab\uFEFFdef" "%\[ab\uFEFF\]" a] $a +} -result "1 ab\uFEFF" test scan-8.1 {error conditions} -body { scan a diff --git a/tests/source.test b/tests/source.test index 47f1486..eee03ec 100644 --- a/tests/source.test +++ b/tests/source.test @@ -111,7 +111,7 @@ test source-2.7 {utf-8 with BOM} -setup { } -body { set out [open $sourcefile w] fconfigure $out -encoding utf-8 - puts $out "\ufeffset y new-y" + puts $out "\uFEFFset y new-y" close $out set y old-y source -encoding utf-8 $sourcefile @@ -199,7 +199,7 @@ test source-4.1 {continuation line parsing} -setup { test source-6.1 {source is binary ok} -setup { # Note [makeFile] writes in the system encoding. # [source] defaults to reading in the system encoding. - set sourcefile [makeFile [list set x "a b\0c"] source.file] + set sourcefile [makeFile [list set x "a b\x00c"] source.file] } -body { set x {} source $sourcefile @@ -208,7 +208,7 @@ test source-6.1 {source is binary ok} -setup { removeFile source.file } -result 5 test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} -setup { - set sourcefile [makeFile "set x ab\32c" source.file] + set sourcefile [makeFile "set x ab\x1Ac" source.file] } -body { set x {} source $sourcefile @@ -222,7 +222,7 @@ test source-7.1 {source -encoding test} -setup { file delete $sourcefile set f [open $sourcefile w] fconfigure $f -encoding utf-8 - puts $f "set symbol(square-root) \u221A; set x correct" + puts $f "set symbol(square-root) √; set x correct" close $f } -body { set x unset @@ -233,15 +233,15 @@ test source-7.1 {source -encoding test} -setup { } -result correct test source-7.2 {source -encoding test} -setup { # This tests for bad interactions between [source -encoding] - # and use of the Control-Z character (\u001A) as a cross-platform + # and use of the Control-Z character (\x1A) as a cross-platform # EOF character by [source]. Here we write out and the [source] a - # file that contains the byte \x1A, although not the character \u001A in + # file that contains the byte \x1A, although not the character \x1A in # the indicated encoding. set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] fconfigure $f -encoding utf-16 - puts $f "set symbol(square-root) \u221A; set x correct" + puts $f "set symbol(square-root) √; set x correct" close $f } -body { set x unset @@ -266,25 +266,25 @@ test source-7.5 {source -encoding: correct operation} -setup { file delete $sourcefile set f [open $sourcefile w] fconfigure $f -encoding utf-8 - puts $f "proc \u20ac {} {return foo}" + puts $f "proc € {} {return foo}" close $f } -body { source -encoding utf-8 $sourcefile - \u20ac + € } -cleanup { removeFile source.file - rename \u20ac {} + rename € {} } -result foo test source-7.6 {source -encoding: mismatch encoding error} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] fconfigure $f -encoding utf-8 - puts $f "proc \u20ac {} {return foo}" + puts $f "proc € {} {return foo}" close $f } -body { source -encoding ascii $sourcefile - \u20ac + € } -cleanup { removeFile source.file } -returnCodes error -match glob -result {invalid command name*} diff --git a/tests/split.test b/tests/split.test index 74879cf..a34c49d 100644 --- a/tests/split.test +++ b/tests/split.test @@ -49,20 +49,20 @@ test split-1.8 {basic split commands} { } {]\n} test split-1.9 {basic split commands} { proc foo {} { - set x ab\000c + set x ab\x00c set y [split $x {}] return $y } foo -} "a b \000 c" +} "a b \x00 c" test split-1.10 {basic split commands} { - split "a0ab1b2bbb3\000c4" ab\000c + split "a0ab1b2bbb3\x00c4" ab\x00c } {{} 0 {} 1 2 {} {} 3 {} 4} test split-1.11 {basic split commands} { split "12,3,45" {,} } {12 3 45} test split-1.12 {basic split commands} { - split "\u0001ab\u0001cd\u0001\u0001ef\u0001" \1 + split "\x01ab\x01cd\x01\x01ef\x01" \x01 } {{} ab cd {} ef {}} test split-1.13 {basic split commands} { split "12,34,56," {,} @@ -71,10 +71,10 @@ test split-1.14 {basic split commands} { split ",12,,,34,56," {,} } {{} 12 {} {} 34 56 {}} test split-1.15 {basic split commands} -body { - split "a\U1F4A9b" {} -} -result "a \U1F4A9 b" + split "a💩b" {} +} -result "a 💩 b" test split-1.16 {basic split commands} -body { - split "a\U1F4A9b" \U1F4A9 + split "a💩b" 💩 } -result "a b" test split-2.1 {split errors} { diff --git a/tests/string.test b/tests/string.test index 3775c0d..822899c 100644 --- a/tests/string.test +++ b/tests/string.test @@ -33,6 +33,7 @@ testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] testConstraint testevalex [expr {[info commands testevalex] ne {}}] testConstraint utf16 [expr {[string length \U010000] == 2}] testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint nodep [info exists tcl_precision] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -72,9 +73,9 @@ if {$noComp} { } -test string-1.1.$noComp {error conditions} { +test string-1.1.$noComp {error conditions} -body { list [catch {run {string gorp a b}} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -match glob -result {1 {unknown or ambiguous subcommand "gorp": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2.$noComp {error conditions} { list [catch {run {string}} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} @@ -119,16 +120,16 @@ test string-2.10.$noComp {string compare with special index} { list [catch {run {string compare -length end-3 abcde abxyz}} msg] $msg } {1 {expected integer but got "end-3"}} test string-2.11.$noComp {string compare, unicode} { - run {string compare ab\u7266 ab\u7267} + run {string compare ab牦 ab牧} } -1 test string-2.11.1.$noComp {string compare, unicode} { - run {string compare \334 \xDC} + run {string compare Ü Ü} } 0 test string-2.11.2.$noComp {string compare, unicode} { - run {string compare \334 \xFC} + run {string compare Ü ü} } -1 test string-2.11.3.$noComp {string compare, unicode} { - run {string compare \334\334\334\374\374 \334\334\334\334\334} + run {string compare ÜÜÜüü ÜÜÜÜÜ} } 1 test string-2.12.$noComp {string compare, high bit} { # This test will fail if the underlying comparison @@ -152,10 +153,10 @@ test string-2.15.$noComp {string compare -nocase} { run {string compare -nocase abcde abcde} } 0 test string-2.15.1.$noComp {string compare -nocase} { - run {string compare -nocase \334 \xDC} + run {string compare -nocase Ü Ü} } 0 test string-2.15.2.$noComp {string compare -nocase} { - run {string compare -nocase \334\334\334\374\xFC \334\334\334\334\334} + run {string compare -nocase ÜÜÜüü ÜÜÜÜÜ} } 0 test string-2.16.$noComp {string compare -nocase with length} { run {string compare -length 2 -nocase abcde Abxyz} @@ -172,7 +173,7 @@ test string-2.19.$noComp {string compare -nocase with excessive length} { test string-2.20.$noComp {string compare -len unicode} { # These are strings that are 6 BYTELENGTH long, but the length # shouldn't make a different because there are actually 3 CHARS long - run {string compare -len 5 \334\334\334 \334\334\374} + run {string compare -len 5 ÜÜÜ ÜÜü} } -1 test string-2.21.$noComp {string compare -nocase with special index} { list [catch {run {string compare -nocase -length end-3 Abcde abxyz}} msg] $msg @@ -237,7 +238,7 @@ test string-3.3.$noComp {string equal} { run {string equal abcde abcde} } 1 test string-3.4.$noComp {string equal -nocase} { - run {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334} + run {string equal -nocase ÜÜÜÜüüüü ÜÜÜÜÜÜÜÜ} } 1 test string-3.5.$noComp {string equal -nocase} { run {string equal -nocase abcde abdef} @@ -274,19 +275,19 @@ test string-3.15.$noComp {string equal with special index} { } {1 {expected integer but got "end-3"}} test string-3.16.$noComp {string equal, unicode} { - run {string equal ab\u7266 ab\u7267} + run {string equal ab牦 ab牧} } 0 test string-3.17.$noComp {string equal, unicode} { - run {string equal \334 \xDC} + run {string equal Ü Ü} } 1 test string-3.18.$noComp {string equal, unicode} { - run {string equal \334 \xFC} + run {string equal Ü ü} } 0 test string-3.19.$noComp {string equal, unicode} { - run {string equal \334\334\334\374\374 \334\334\334\334\334} + run {string equal ÜÜÜüü ÜÜÜÜÜ} } 0 test string-3.20.$noComp {string equal, high bit} { - # This test will fail if the underlying comparaison + # This test will fail if the underlying comparison # is using signed chars instead of unsigned chars. # (like SunOS's default memcmp thus the compat/memcmp.c) run {string equal "\x80" "@"} @@ -298,10 +299,10 @@ test string-3.21.$noComp {string equal -nocase} { run {string equal -nocase abcde Abdef} } 0 test string-3.22.$noComp {string equal, -nocase unicode} { - run {string equal -nocase \334 \xDC} + run {string equal -nocase Ü Ü} } 1 test string-3.23.$noComp {string equal, -nocase unicode} { - run {string equal -nocase \334\334\334\374\xFC \334\334\334\334\334} + run {string equal -nocase ÜÜÜüü ÜÜÜÜÜ} } 1 test string-3.24.$noComp {string equal -nocase with length} { run {string equal -length 2 -nocase abcde Abxyz} @@ -318,7 +319,7 @@ test string-3.27.$noComp {string equal -nocase with excessive length} { test string-3.28.$noComp {string equal -len unicode} { # These are strings that are 6 BYTELENGTH long, but the length # shouldn't make a different because there are actually 3 CHARS long - run {string equal -len 5 \334\334\334 \334\334\374} + run {string equal -len 5 ÜÜÜ ÜÜü} } 0 test string-3.29.$noComp {string equal -nocase with special index} { list [catch {run {string equal -nocase -length end-3 Abcde abxyz}} msg] $msg @@ -391,19 +392,19 @@ test string-4.8.$noComp {string first} { run {string first "" x123xx345xxx789xxx012} } -1 test string-4.9.$noComp {string first, unicode} { - run {string first x abc\u7266x} + run {string first x abc牦x} } 4 test string-4.10.$noComp {string first, unicode} { - run {string first \u7266 abc\u7266x} + run {string first 牦 abc牦x} } 3 test string-4.11.$noComp {string first, start index} { - run {string first \u7266 abc\u7266x 3} + run {string first 牦 abc牦x 3} } 3 test string-4.12.$noComp {string first, start index} -body { - run {string first \u7266 abc\u7266x 4} + run {string first 牦 abc牦x 4} } -result -1 test string-4.13.$noComp {string first, start index} -body { - run {string first \u7266 abc\u7266x end-2} + run {string first 牦 abc牦x end-2} } -result 3 test string-4.14.$noComp {string first, negative start index} -body { run {string first b abc -1} @@ -412,7 +413,7 @@ test string-4.15.$noComp {string first, ability to two-byte encoded utf-8 chars} # Test for a bug in Tcl 8.3 where test for all-single-byte-encoded # strings was incorrect, leading to an index returned by [string first] # which pointed past the end of the string. - set uchar \u057E ;# character with two-byte encoding in utf-8 + set uchar վ ;# character with two-byte encoding in utf-8 run {string first % %#$uchar$uchar#$uchar$uchar#% 3} } -result 8 test string-4.16.$noComp {string first, normal string vs pure unicode string} -body { @@ -469,13 +470,13 @@ test string-5.9.$noComp {string index} { run {string index abc end-1} } b test string-5.10.$noComp {string index, unicode} { - run {string index abc\u7266d 4} + run {string index abc牦d 4} } d test string-5.11.$noComp {string index, unicode} { - run {string index abc\u7266d 3} -} \u7266 + run {string index abc牦d 3} +} 牦 test string-5.12.$noComp {string index, unicode over char length, under byte length} -body { - run {string index \334\374\334\374 6} + run {string index ÜüÜü 6} } -result {} test string-5.13.$noComp {string index, bytearray object} { run {string index [binary format a5 fuz] 0} @@ -525,10 +526,10 @@ test string-6.4.$noComp {string is, too many args} { } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} test string-6.5.$noComp {string is, class check} { list [catch {run {string is bogus str}} msg] $msg -} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} +} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, unicode, wideinteger, wordchar, or xdigit}} test string-6.6.$noComp {string is, ambiguous class} { list [catch {run {string is al str}} msg] $msg -} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} +} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, unicode, wideinteger, wordchar, or xdigit}} test string-6.7.$noComp {string is alpha, all ok} { run {string is alpha -strict -failindex var abc} } 1 @@ -551,7 +552,7 @@ test string-6.12.$noComp {string is alnum, true} { test string-6.13.$noComp {string is alnum, false} { list [run {string is alnum -failindex var abc1.23}] $var } {0 4} -test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abc\xFC}" 1 +test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abcü}" 1 test string-6.15.$noComp {string is alpha, true} { run {string is alpha abc} } 1 @@ -559,7 +560,7 @@ test string-6.16.$noComp {string is alpha, false} { list [run {string is alpha -fail var a1bcde}] $var } {0 1} test string-6.17.$noComp {string is alpha, unicode} { - run {string is alpha abc\374} + run {string is alpha abcü} } 1 test string-6.18.$noComp {string is ascii, true} { run {string is ascii abc\x7Fend\x00} @@ -583,7 +584,7 @@ test string-6.24.$noComp {string is digit, true} { run {string is digit 0123456789} } 1 test string-6.25.$noComp {string is digit, false} { - list [run {string is digit -fail var 0123\xDC567}] $var + list [run {string is digit -fail var 0123Ü567}] $var } {0 4} test string-6.26.$noComp {string is digit, false} { list [run {string is digit -fail var +123567}] $var @@ -706,7 +707,7 @@ test string-6.60.$noComp {string is lower, true} { run {string is lower abc} } 1 test string-6.61.$noComp {string is lower, unicode true} { - run {string is lower abc\xFCue} + run {string is lower abcüue} } 1 test string-6.62.$noComp {string is lower, false} { list [run {string is lower -fail var aBc}] $var @@ -715,7 +716,7 @@ test string-6.63.$noComp {string is lower, false} { list [run {string is lower -fail var abc1}] $var } {0 3} test string-6.64.$noComp {string is lower, unicode false} { - list [run {string is lower -fail var ab\xDCUE}] $var + list [run {string is lower -fail var abÜUE}] $var } {0 2} test string-6.65.$noComp {string is space, true} { run {string is space " \t\n\v\f"} @@ -753,7 +754,7 @@ test string-6.75.$noComp {string is upper, true} { run {string is upper ABC} } 1 test string-6.76.$noComp {string is upper, unicode true} { - run {string is upper ABC\xDCUE} + run {string is upper ABCÜUE} } 1 test string-6.77.$noComp {string is upper, false} { list [run {string is upper -fail var AbC}] $var @@ -762,13 +763,13 @@ test string-6.78.$noComp {string is upper, false} { list [run {string is upper -fail var AB2C}] $var } {0 2} test string-6.79.$noComp {string is upper, unicode false} { - list [run {string is upper -fail var ABC\xFCue}] $var + list [run {string is upper -fail var ABCüue}] $var } {0 3} test string-6.80.$noComp {string is wordchar, true} { run {string is wordchar abc_123} } 1 test string-6.81.$noComp {string is wordchar, unicode true} { - run {string is wordchar abc\xFCab\xDCAB\u5001\U1D7CA} + run {string is wordchar abcüabÜAB倁\U1D7CA} } 1 test string-6.82.$noComp {string is wordchar, false} { list [run {string is wordchar -fail var abcd.ef}] $var @@ -961,6 +962,28 @@ test string-6.130.1.$noComp {string is entier, false on bad octal} { test string-6.131.$noComp {string is entier, false on bad hex} { list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var } {0 88} +test string-6.132.$noComp {string is unicode} { + run {string is unicode \U10FFFD\uD7FF\uE000\uFDCF\uFDF0} +} 1 +test string-6.133.$noComp {string is unicode, upper surrogate} { + run {string is unicode \uD800} +} 0 +test string-6.134.$noComp {string is unicode, lower surrogate} { + run {string is unicode \uDFFF} +} 0 +test string-6.135.$noComp {string is unicode, noncharacter} { + run {string is unicode \uFFFE} +} 0 +test string-6.136.$noComp {string is unicode, noncharacter} { + run {string is unicode \uFFFF} +} 0 +test string-6.137.$noComp {string is unicode, noncharacter} { + run {string is unicode \uFDD0} +} 0 +test string-6.138.$noComp {string is unicode, noncharacter} { + run {string is unicode \uFDEF} +} 0 + test string-7.1.$noComp {string last, not enough args} { list [catch {run {string last a}} msg] $msg @@ -981,22 +1004,22 @@ test string-7.6.$noComp {string last} { run {string las x xxxx123xx345x678} } 12 test string-7.7.$noComp {string last, unicode} { - run {string las x xxxx12\u7266xx345x678} + run {string las x xxxx12牦xx345x678} } 12 test string-7.8.$noComp {string last, unicode} { - run {string las \u7266 xxxx12\u7266xx345x678} + run {string las 牦 xxxx12牦xx345x678} } 6 test string-7.9.$noComp {string last, stop index} { - run {string las \u7266 xxxx12\u7266xx345x678} + run {string las 牦 xxxx12牦xx345x678} } 6 test string-7.10.$noComp {string last, unicode} { - run {string las \u7266 xxxx12\u7266xx345x678} + run {string las 牦 xxxx12牦xx345x678} } 6 test string-7.11.$noComp {string last, start index} { - run {string last \u7266 abc\u7266x 3} + run {string last 牦 abc牦x 3} } 3 test string-7.12.$noComp {string last, start index} { - run {string last \u7266 abc\u7266x 2} + run {string last 牦 abc牦x 2} } -1 test string-7.13.$noComp {string last, start index} { ## Constrain to last 'a' should work @@ -1007,22 +1030,22 @@ test string-7.14.$noComp {string last, start index} { run {string last ba badbad end-2} } 0 test string-7.15.$noComp {string last, start index} { - run {string last \334a \334ad\334ad 0} + run {string last Üa ÜadÜad 0} } -1 test string-7.16.$noComp {string last, start index} { - run {string last \334a \334ad\334ad end-1} + run {string last Üa ÜadÜad end-1} } 3 -test string-8.1.$noComp {string bytelength} { +test string-8.1.$noComp {string bytelength} nodep { list [catch {run {string bytelength}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.2.$noComp {string bytelength} { +test string-8.2.$noComp {string bytelength} nodep { list [catch {run {string bytelength a b}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.3.$noComp {string bytelength} { +test string-8.3.$noComp {string bytelength} nodep { run {string bytelength "\xC7"} } 2 -test string-8.4.$noComp {string bytelength} { +test string-8.4.$noComp {string bytelength} nodep { run {string b ""} } 0 @@ -1039,7 +1062,7 @@ test string-9.4.$noComp {string length} { run {string le ""} } 0 test string-9.5.$noComp {string length, unicode} { - run {string le "abcd\u7266"} + run {string le "abcd牦"} } 5 test string-9.6.$noComp {string length, bytearray object} { run {string length [binary format a5 foo]} @@ -1082,11 +1105,11 @@ test string-10.11.$noComp {string map, nulls} { run {string map {\x00 NULL blah \x00nix} {qwerty}} } {qwerty} test string-10.12.$noComp {string map, unicode} { - run {string map [list \374 ue UE \334] "a\374ueUE\000EU"} -} aueue\334\0EU + run {string map [list ü ue UE Ü] "aüueUE\x00EU"} +} aueueÜ\x00EU test string-10.13.$noComp {string map, -nocase unicode} { - run {string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU"} -} aue\334\334\0EU + run {string map -nocase [list ü ue UE Ü] "aüueUE\x00EU"} +} aueÜÜ\x00EU test string-10.14.$noComp {string map, -nocase null arguments} { run {string map -nocase {{} abc} foo} } foo @@ -1290,7 +1313,7 @@ test string-11.32.$noComp {string match nocase} { run {string match -n a A} } 1 test string-11.33.$noComp {string match nocase} { - run {string match -nocase a\334 A\374} + run {string match -nocase aÜ Aü} } 1 test string-11.34.$noComp {string match nocase} { run {string match -nocase a*f ABCDEf} @@ -1457,11 +1480,11 @@ test string-12.16.$noComp {string range} { run {string range abcdefghijklmnop end end-1} } {} test string-12.17.$noComp {string range, unicode} { - run {string range ab\u7266cdefghijklmnop 5 5} + run {string range ab牦cdefghijklmnop 5 5} } e test string-12.18.$noComp {string range, unicode} { - run {string range ab\u7266cdefghijklmnop 2 3} -} \u7266c + run {string range ab牦cdefghijklmnop 2 3} +} 牦c test string-12.19.$noComp {string range, bytearray object} { set b [binary format I* {0x50515253 0x52}] set r1 [run {string range $b 1 end-1}] @@ -1544,15 +1567,15 @@ test string-13.11.$noComp {string repeat} { run {string repeat def 1} } def test string-13.12.$noComp {string repeat} { - run {string repeat ab\u7266cd 3} -} ab\u7266cdab\u7266cdab\u7266cd + run {string repeat ab牦cd 3} +} ab牦cdab牦cdab牦cd test string-13.13.$noComp {string repeat} { run {string repeat \x00 3} } \x00\x00\x00 test string-13.14.$noComp {string repeat} { # The string range will ensure us that string repeat gets a unicode string - run {string repeat [run {string range ab\u7266cd 2 3}] 3} -} \u7266c\u7266c\u7266c + run {string repeat [run {string range ab牦cd 2 3}] 3} +} 牦c牦c牦c test string-14.1.$noComp {string replace} { list [catch {run {string replace}} msg] $msg @@ -1614,6 +1637,18 @@ test string-14.20.$noComp {string replace} { run {string replace [makeByteArray abcdefghijklmnop] end-10 end-2\ [makeByteArray NEW]} } {abcdeNEWop} +test string-14.21.$noComp {string replace (surrogates)} { + run {string replace \uD83D? 1 end \uDE02} +} \uD83D\uDE02 +test string-14.22.$noComp {string replace (surrogates)} { + run {string replace ?\uDE02 0 end-1 \uD83D} +} \uD83D\uDE02 +test string-14.23.$noComp {string replace \xC0 \x80} testbytestring { + run {string length [string replace [testbytestring \xC0]? 1 end [testbytestring \x80]]} +} 2 +test string-14.24.$noComp {string replace \xC0 \x80} testbytestring { + run {string length [string replace ?[testbytestring \x80] 0 end-1 [testbytestring \xC0]]} +} 2 test stringComp-14.21.$noComp {Bug 82e7f67325} { @@ -1805,9 +1840,9 @@ test string-19.3.$noComp {string trimleft, unicode default} { test string-20.1.$noComp {string trimright errors} { list [catch {run {string trimright}} msg] $msg } {1 {wrong # args: should be "string trimright string ?chars?"}} -test string-20.2.$noComp {string trimright errors} { +test string-20.2.$noComp {string trimright errors} -body { list [catch {run {string trimg a}} msg] $msg -} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -match glob -result {1 {unknown or ambiguous subcommand "trimg": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-20.3.$noComp {string trimright} { run {string trimright " XYZ "} } { XYZ} @@ -1846,7 +1881,7 @@ test string-20.8.$noComp {[c61818e4c9] [string trimright] fails when UtfPrev is lappend result [string map $m [run {string trimright $b [testbytestring \xA0]}]] lappend result [string map $m [run {string trimright $b \xE8\xA0}]] lappend result [string map $m [run {string trimright $b [testbytestring \xE8\xA0]}]] - lappend result [string map $m [run {string trimright $b \u0000}]] + lappend result [string map $m [run {string trimright $b \x00}]] } [list {*}[lrepeat 4 fooUV] {*}[lrepeat 2 fooU] {*}[lrepeat 2 foo] fooUV] test string-21.1.$noComp {string wordend} -body { @@ -1897,10 +1932,37 @@ test string-21.15.$noComp {string wordend, unicode} -body { test string-21.16.$noComp {string wordend, unicode} -constraints utf16 -body { run {string wordend "\U1D7CA\U1D7CA abc" 10} } -result 8 +test string-21.17.$noComp {string trim, unicode} { + run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02} +} "Hello world!" +test string-21.18.$noComp {string trimleft, unicode} { + run {string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02} +} "Hello world!\uD83D\uDE02" +test string-21.19.$noComp {string trimright, unicode} { + run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02} +} "\uD83D\uDE02Hello world!" +test string-21.20.$noComp {string trim, unicode} { + run {string trim "\uF602Hello world!\uF602" \uD83D\uDE02} +} "\uF602Hello world!\uF602" +test string-21.21.$noComp {string trimleft, unicode} { + run {string trimleft "\uF602Hello world!\uF602" \uD83D\uDE02} +} "\uF602Hello world!\uF602" +test string-21.22.$noComp {string trimright, unicode} { + run {string trimright "\uF602Hello world!\uF602" \uD83D\uDE02} +} "\uF602Hello world!\uF602" +test string-21.23.$noComp {string trim, unicode} { + run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} +} "\uD83D\uDE02Hello world!\uD83D\uDE02" +test string-21.24.$noComp {string trimleft, unicode} { + run {string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} +} "\uD83D\uDE02Hello world!\uD83D\uDE02" +test string-21.25.$noComp {string trimright, unicode} { + run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} +} "\uD83D\uDE02Hello world!\uD83D\uDE02" test string-22.1.$noComp {string wordstart} -body { list [catch {run {string word a}} msg] $msg -} -result {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -match glob -result {1 {unknown or ambiguous subcommand "word": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-22.2.$noComp {string wordstart} -body { list [catch {run {string wordstart a}} msg] $msg } -result {1 {wrong # args: should be "string wordstart string index"}} @@ -2059,6 +2121,24 @@ test string-24.15.$noComp {string reverse command - pure bytearray} { binary scan [run {tcl::string::reverse [binary format H* 010203]}] H* x set x } 030201 +test string-24.16.$noComp {string reverse command - surrogates} { + run {string reverse \u0444bulb\uD83D\uDE02} +} \uD83D\uDE02blub\u0444 +test string-24.17.$noComp {string reverse command - surrogates} { + run {string reverse \uD83D\uDE02hello\uD83D\uDE02} +} \uD83D\uDE02olleh\uD83D\uDE02 +test string-24.18.$noComp {string reverse command - surrogates} { + set s \u0444bulb\uD83D\uDE02 + # shim shimmery ... + string index $s 0 + run {string reverse $s} +} \uD83D\uDE02blub\u0444 +test string-24.19.$noComp {string reverse command - surrogates} { + set s \uD83D\uDE02hello\uD83D\uDE02 + # shim shimmery ... + string index $s 0 + run {string reverse $s} +} \uD83D\uDE02olleh\uD83D\uDE02 test string-25.1.$noComp {string is list} { run {string is list {a b c}} diff --git a/tests/stringObj.test b/tests/stringObj.test index 9937fa4..135830c 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -208,19 +208,19 @@ test stringObj-8.1 {DupStringInternalRep procedure} testobj { [teststringobj maxchars 2] [teststringobj get 2] } {5 10 0 abcde 5 5 0 abcde} test stringObj-8.2 {DupUnicodeInternalRep, mixed width chars} testobj { - set x abc\u00ef\u00bf\u00aeghi + set x abc\xEF\xBF\xAEghi string length $x set y $x - list [testobj objtype $x] [testobj objtype $y] [append x "\u00ae\u00bf\u00ef"] \ + list [testobj objtype $x] [testobj objtype $y] [append x "\xAE\xBF\xEF"] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "string string abc\u00ef\u00bf\u00aeghi\u00ae\u00bf\u00ef abc\u00ef\u00bf\u00aeghi string string" +} "string string abc\xEF\xBF\xAEghi\xAE\xBF\xEF abc\xEF\xBF\xAEghi string string" test stringObj-8.3 {DupUnicodeInternalRep, mixed width chars} testobj { - set x abc\u00ef\u00bf\u00aeghi + set x abc\xEF\xBF\xAEghi set y $x string length $x - list [testobj objtype $x] [testobj objtype $y] [append x "\u00ae\u00bf\u00ef"] \ + list [testobj objtype $x] [testobj objtype $y] [append x "\xAE\xBF\xEF"] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "string string abc\u00ef\u00bf\u00aeghi\u00ae\u00bf\u00ef abc\u00ef\u00bf\u00aeghi string string" +} "string string abc\xEF\xBF\xAEghi\xAE\xBF\xEF abc\xEF\xBF\xAEghi string string" test stringObj-8.4 {DupUnicodeInternalRep, all byte-size chars} testobj { set x abcdefghi string length $x @@ -237,31 +237,31 @@ test stringObj-8.5 {DupUnicodeInternalRep, all byte-size chars} testobj { } {string string abcdefghijkl abcdefghi string string} test stringObj-9.1 {TclAppendObjToObj, mixed src & dest} {testobj testdstring} { - set x abc\u00ef\u00bf\u00aeghi + set x abc\xEF\xBF\xAEghi testdstring free - testdstring append \u00ae\u00bf\u00ef -1 + testdstring append \xAE\xBF\xEF -1 set y [testdstring get] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "string none abc\u00ef\u00bf\u00aeghi\u00ae\u00bf\u00ef \u00ae\u00bf\u00ef string none" +} "string none abc\xEF\xBF\xAEghi\xAE\xBF\xEF \xAE\xBF\xEF string none" test stringObj-9.2 {TclAppendObjToObj, mixed src & dest} testobj { - set x abc\u00ef\u00bf\u00aeghi + set x abc\xEF\xBF\xAEghi string length $x list [testobj objtype $x] [append x $x] [testobj objtype $x] \ [append x $x] [testobj objtype $x] -} "string abc\u00ef\u00bf\u00aeghiabc\u00ef\u00bf\u00aeghi string\ -abc\u00ef\u00bf\u00aeghiabc\u00ef\u00bf\u00aeghiabc\u00ef\u00bf\u00aeghiabc\u00ef\u00bf\u00aeghi\ +} "string abc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghi string\ +abc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghi\ string" test stringObj-9.3 {TclAppendObjToObj, mixed src & 1-byte dest} {testobj testdstring} { set x abcdefghi testdstring free - testdstring append \u00ae\u00bf\u00ef -1 + testdstring append \xAE\xBF\xEF -1 set y [testdstring get] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "string none abcdefghi\u00ae\u00bf\u00ef \u00ae\u00bf\u00ef string none" +} "string none abcdefghi\xAE\xBF\xEF \xAE\xBF\xEF string none" test stringObj-9.4 {TclAppendObjToObj, 1-byte src & dest} {testobj testdstring} { set x abcdefghi testdstring free @@ -279,14 +279,14 @@ test stringObj-9.5 {TclAppendObjToObj, 1-byte src & dest} testobj { } {string abcdefghiabcdefghi string abcdefghiabcdefghiabcdefghiabcdefghi\ string} test stringObj-9.6 {TclAppendObjToObj, 1-byte src & mixed dest} {testobj testdstring} { - set x abc\u00ef\u00bf\u00aeghi + set x abc\xEF\xBF\xAEghi testdstring free testdstring append jkl -1 set y [testdstring get] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "string none abc\u00ef\u00bf\u00aeghijkl jkl string none" +} "string none abc\xEF\xBF\xAEghijkl jkl string none" test stringObj-9.7 {TclAppendObjToObj, integer src & dest} testobj { set x [expr {4 * 5}] set y [expr {4 + 5}] @@ -307,19 +307,19 @@ test stringObj-9.9 {TclAppendObjToObj, integer src & 1-byte dest} testobj { [set y] [testobj objtype $x] [testobj objtype $y] } {string int abcdefghi9 9 string int} test stringObj-9.10 {TclAppendObjToObj, integer src & mixed dest} testobj { - set x abc\u00ef\u00bf\u00aeghi + set x abc\xEF\xBF\xAEghi set y [expr {4 + 5}] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "string int abc\u00ef\u00bf\u00aeghi9 9 string int" +} "string int abc\xEF\xBF\xAEghi9 9 string int" test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} testobj { # bug 2678, in <=8.2.0, the second obj (the one to append) in # Tcl_AppendObjToObj was not correctly checked to see if it was all one # byte chars, so a unicode string would be added as one byte chars. set x abcdef set len [string length $x] - set y a\u00fcb\u00e5c\u00ef + set y a\xFCb\xE5c\xEF set len [string length $y] append x $y string length $x @@ -328,7 +328,7 @@ test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} tes lappend q [string index $x $i] } set q -} "a b c d e f a \u00fc b \u00e5 c \u00ef" +} "a b c d e f a \xFC b \xE5 c \xEF" test stringObj-10.1 {Tcl_GetRange with all byte-size chars} {testobj testdstring} { testdstring free @@ -338,41 +338,30 @@ test stringObj-10.1 {Tcl_GetRange with all byte-size chars} {testobj testdstring [testobj objtype $x] [testobj objtype $y] } [list none bcde string string] test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstring} { - # Because this test does not use \uXXXX notation below instead of - # hardcoding the values, it may fail in multibyte locales. However, we - # need to test that the parser produces untyped objects even when there - # are high-ASCII characters in the input (like "ï"). I don't know what - # else to do but inline those characters here. testdstring free - testdstring append "abc\u00ef\u00efdef" -1 + testdstring append "abcïïdef" -1 set x [testdstring get] list [testobj objtype $x] [set y [string range $x 1 end-1]] \ [testobj objtype $x] [testobj objtype $y] -} [list none "bc\u00EF\u00EFde" string string] +} [list none "bcïïde" string string] test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { - # set x "abcïïdef" - # Use \uXXXX notation below instead of hardcoding the values, otherwise - # the test will fail in multibyte locales. - set x "abc\u00EF\u00EFdef" + set x "abcïïdef" string length $x list [testobj objtype $x] [set y [string range $x 1 end-1]] \ [testobj objtype $x] [testobj objtype $y] -} [list string "bc\u00EF\u00EFde" string string] +} [list string "bcïïde" string string] test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj { - # set a "ïa¿b®cï¿d®" - # Use \uXXXX notation below instead of hardcoding the values, otherwise - # the test will fail in multibyte locales. - set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" + set a "ïa¿b®cï¿d®" set result [list] while {[string length $a] > 0} { set a [string range $a 1 end-1] lappend result $a } set result -} [list a\u00BFb\u00AEc\u00EF\u00BFd \ - \u00BFb\u00AEc\u00EF\u00BF \ - b\u00AEc\u00EF \ - \u00AEc \ +} [list a\xBFb\xAEc\xEF\xBFd \ + \xBFb\xAEc\xEF\xBF \ + b\xAEc\xEF \ + \xAEc \ {}] test stringObj-11.1 {UpdateStringOfString} testobj { @@ -394,15 +383,15 @@ test stringObj-12.3 {Tcl_GetUniChar with byte-size chars} testobj { list [string index $x end] [string index $x end-1] } {i h} test stringObj-12.4 {Tcl_GetUniChar with mixed width chars} testobj { - string index "\u00efa\u00bfb\u00aec\u00ae\u00bfd\u00ef" 0 -} "\u00ef" + string index "\xEFa\xBFb\xAEc\xAE\xBFd\xEF" 0 +} "\xEF" test stringObj-12.5 {Tcl_GetUniChar} testobj { - set x "\u00efa\u00bfb\u00aec\u00ae\u00bfd\u00ef" + set x "\xEFa\xBFb\xAEc\xAE\xBFd\xEF" list [string index $x 4] [string index $x 0] -} "\u00ae \u00ef" +} "\xAE \xEF" test stringObj-12.6 {Tcl_GetUniChar} testobj { - string index "\u00efa\u00bfb\u00aec\u00ef\u00bfd\u00ae" end -} "\u00ae" + string index "\xEFa\xBFb\xAEc\xEF\xBFd\xAE" end +} "\xAE" test stringObj-13.1 {Tcl_GetCharLength with byte-size chars} testobj { set a "" @@ -416,19 +405,19 @@ test stringObj-13.3 {Tcl_GetCharLength with byte-size chars} testobj { list [string length $a] [string length $a] } {6 6} test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj { - string length "\u00ae" + string length "\xAE" } 1 test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj { # string length "￮￮" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. - string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE" + string length "\xEF\xBF\xAE\xEF\xBF\xAE" } 6 test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} testobj { # set a "ïa¿b®cï¿d®" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. - set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" + set a "\xEFa\xBFb\xAEc\xEF\xBFd\xAE" list [string length $a] [string length $a] } {10 10} test stringObj-13.7 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} { diff --git a/tests/subst.test b/tests/subst.test index 03a1ce2..da59c3b 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -48,7 +48,7 @@ test subst-3.2 {backslash substitutions with utf chars} { # 'j' is just a char that doesn't mean anything, and \344 is 'ä' # that also doesn't mean anything, but is multi-byte in UTF-8. list [subst \j] [subst \\j] [subst \\344] [subst \\\344] -} "j j \344 \344" +} "j j ä ä" test subst-4.1 {variable substitutions} { set a 44 diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 193ba0a..1ee37d3 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -3,6 +3,18 @@ package require tcltest 2.5 namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] +if {[namespace which testdebug] ne {}} { + testConstraint debug [testdebug] + testConstraint purify [testpurify] + testConstraint debugpurify [ + expr { + ![testConstraint memory] + && + [testConstraint debug] + && + [testConstraint purify] + }] +} testConstraint fcopy [llength [info commands fcopy]] testConstraint fileevent [llength [info commands fileevent]] testConstraint thread [ diff --git a/tests/timer.test b/tests/timer.test index 1ad17ae..52c0b8a 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -367,7 +367,7 @@ test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NUL} -setup { } } -body { set x "hello world" - after 1 "set x ab\0cd" + after 1 "set x ab\x00cd" after 10 update string length $x @@ -378,7 +378,7 @@ test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NUL} -setup { } } -body { set x "hello world" - after 1 set x ab\0cd + after 1 set x ab\x00cd after 10 update string length $x @@ -389,8 +389,8 @@ test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup } } -body { set x "hello world" - after 1 set x ab\0cd - after cancel "set x ab\0ef" + after 1 set x ab\x00cd + after cancel "set x ab\x00ef" llength [after info] } -cleanup { foreach i [after info] { @@ -403,8 +403,8 @@ test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup } } -body { set x "hello world" - after 1 set x ab\0cd - after cancel set x ab\0ef + after 1 set x ab\x00cd + after cancel set x ab\x00ef llength [after info] } -cleanup { foreach i [after info] { @@ -417,7 +417,7 @@ test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup { } } -body { set x "hello world" - after idle "set x ab\0cd" + after idle "set x ab\x00cd" update string length $x } -result {5} @@ -427,7 +427,7 @@ test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup { } } -body { set x "hello world" - after idle set x ab\0cd + after idle set x ab\x00cd update string length $x } -result {5} @@ -438,7 +438,7 @@ test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NUL} -setup { } -body { set x "hello world" set id junk - set id [after 10 set x ab\0cd] + set id [after 10 set x ab\x00cd] update string length [lindex [lindex [after info $id] 0] 2] } -cleanup { diff --git a/tests/unixInit.test b/tests/unixInit.test index aa3d50a..2ea7d8e 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -126,7 +126,7 @@ test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup { set oldlibrary $env(TCL_LIBRARY) } } -body { - # ((str != NULL) && (str[0] != '\0')) + # ((str != NULL) && (str[0] != '\x00')) set env(TCL_LIBRARY) sparkly lindex [getlibpath] 0 } -cleanup { @@ -158,7 +158,7 @@ test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup { } } -body { # Child process translates env variable from native encoding. - set env(TCL_LIBRARY) "\xa7" + set env(TCL_LIBRARY) "§" lindex [getlibpath] 0 } -cleanup { unset -nocomplain env(TCL_LIBRARY) env(LANG) @@ -166,7 +166,7 @@ test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } -} -result "\xa7" +} -result "§" test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} { # cannot test } {} diff --git a/tests/unload.test b/tests/unload.test index 29f534d..24b5e8d 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -53,22 +53,22 @@ proc loadIfNotPresent {pkg args} { # Basic tests: parameter testing... test unload-1.1 {basic errors} -returnCodes error -body { unload -} -result {wrong # args: should be "unload ?-switch ...? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "unload ?-switch ...? fileName ?prefix? ?interp?"} test unload-1.2 {basic errors} -returnCodes error -body { unload a b c d -} -result {wrong # args: should be "unload ?-switch ...? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "unload ?-switch ...? fileName ?prefix? ?interp?"} test unload-1.3 {basic errors} -returnCodes error -body { unload a b foobar } -result {could not find interpreter "foobar"} test unload-1.4 {basic errors} -returnCodes error -body { unload {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test unload-1.5 {basic errors} -returnCodes error -body { unload {} {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test unload-1.6 {basic errors} -returnCodes error -body { unload {} Unknown -} -result {package "Unknown" is loaded statically and cannot be unloaded} +} -result {library with prefix "Unknown" is loaded statically and cannot be unloaded} test unload-1.7 {-nocomplain switch} { unload -nocomplain {} Unknown } {} diff --git a/tests/upvar.test b/tests/upvar.test index 82079b1..c31eaa1 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -249,6 +249,33 @@ test upvar-6.3 {retargeting an upvar} { p1 } {abcde 44} + + +test upvar-6.4 { + retargeting a variable created by upvar to itself is allowed +} -body { + catch { + unset x + } + catch { + unset y + } + set res {} + set x abcde + set res [catch { + upvar 0 x x + } cres copts] + lappend res [dict get $copts -errorcode] + upvar 0 x y + lappend res $y + upvar 0 y y + lappend res $y + return $res +} -cleanup { + upvar 0 {} y +} -result {1 {TCL UPVAR SELF} abcde abcde} + + test upvar-7.1 {upvar to same level} { set x 44 set y 55 diff --git a/tests/utf.test b/tests/utf.test index b6c23ba..477216c 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -21,7 +21,6 @@ testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}] testConstraint utf16 [expr {[string length [format %c 0x10000]] == 2}] testConstraint ucs4 [expr {[testConstraint fullutf] && [string length [format %c 0x10000]] == 1}] -testConstraint ucs2_utf16 [expr {![testConstraint ucs4]}] testConstraint Uesc [expr {"\U0041" eq "A"}] testConstraint pre388 [expr {"\x741" eq "A"}] @@ -50,7 +49,7 @@ test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { expr {"\xE0" eq [testbytestring \xC3\xA0]} } 1 test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring { - expr {"\u4E4E" eq [testbytestring \xE4\xB9\x8E]} + expr {"乎" eq [testbytestring \xE4\xB9\x8E]} } 1 test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { expr {[format %c 0x110000] eq [testbytestring \xEF\xBF\xBD]} @@ -58,10 +57,10 @@ test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { expr {[format %c -1] eq [testbytestring \xEF\xBF\xBD]} } 1 -test utf-1.7.0 {Tcl_UniCharToUtf: 4 byte sequences} {fullutf Uesc testbytestring} { +test utf-1.7.0 {Tcl_UniCharToUtf: 4 byte sequences} {fullutf testbytestring} { expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]} } 1 -test utf-1.7.1 {Tcl_UniCharToUtf: 4 byte sequences} {ucs2 Uesc testbytestring} { +test utf-1.7.1 {Tcl_UniCharToUtf: 4 byte sequences} {Uesc ucs2 testbytestring} { expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]} } 0 test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring { @@ -79,9 +78,31 @@ test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} { expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]} } 1 -test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc testbytestring} { +test utf-1.13.0 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc ucs2} { + expr {"\UD842" eq "\uD842"} +} 1 +test utf-1.13.1 {Tcl_UniCharToUtf: Invalid surrogate} {fullutf testbytestring} { expr {"\UD842" eq [testbytestring \xEF\xBF\xBD]} } 1 +test utf-1.14 {Tcl_UniCharToUtf: surrogate pairs from concat} { + set lo \uDE02 + return \uD83D$lo +} \uD83D\uDE02 +test utf-1.15 {Tcl_UniCharToUtf: surrogate pairs from concat} { + set hi \uD83D + return $hi\uDE02 +} \uD83D\uDE02 +test utf-1.16 {Tcl_UniCharToUtf: \xC0 + \x80} testbytestring { + set lo [testbytestring \x80] + string length [testbytestring \xC0]$lo +} 2 +test utf-1.17 {Tcl_UniCharToUtf: \xC0 + \x80} testbytestring { + set hi [testbytestring \xC0] + string length $hi[testbytestring \x80] +} 2 +test utf-1.18 {Tcl_UniCharToUtf: surrogate pairs from concat} { + string cat \uD83D \uDE02 +} \uD83D\uDE02 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" @@ -104,16 +125,22 @@ test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestrin test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { string length [testbytestring \xE4\xB9\x8E] } 1 -test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2_utf16} { +test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {ucs2 testbytestring} { string length [testbytestring \xF0\x90\x80\x80] } 2 -test utf-2.8.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs4} { - string length [testbytestring \xF0\x90\x80\x80] +test utf-2.8.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf16 { + string length 𐀀 +} 2 +test utf-2.8.2 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} ucs4 { + string length 𐀀 } 1 -test utf-2.9.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2} { +test utf-2.9.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {ucs2 testbytestring} { string length [testbytestring \xF4\x8F\xBF\xBF] } 2 -test utf-2.9.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {Uesc ucs4} { +test utf-2.9.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf16 { + string length \U10FFFF +} 2 +test utf-2.9.2 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} ucs4 { string length \U10FFFF } 1 test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { @@ -196,7 +223,7 @@ test utf-6.3 {Tcl_UtfNext} testutfnext { testutfnext AA } 1 test utf-6.4 {Tcl_UtfNext} {testutfnext testbytestring} { - testutfnext A[testbytestring \xA0] + testutfnext [testbytestring A\xA0] } 1 test utf-6.5 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext A[testbytestring \xD0] @@ -216,7 +243,10 @@ test utf-6.9 {Tcl_UtfNext} {testutfnext testbytestring} { test utf-6.10 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xA0]G } 1 -test utf-6.11 {Tcl_UtfNext} {testutfnext testbytestring} { +test utf-6.11.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xA0\xA0\x00] +} 1 +test utf-6.11.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xA0\xA0\x00] } 2 test utf-6.12 {Tcl_UtfNext} {testutfnext testbytestring} { @@ -273,19 +303,19 @@ test utf-6.28 {Tcl_UtfNext} {testutfnext testbytestring} { test utf-6.29 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xE8\xF8] } 1 -test utf-6.30.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { +test utf-6.30.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { testutfnext [testbytestring \xF2] } 1 -test utf-6.30.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { +test utf-6.30.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xF2\x00] } 1 test utf-6.31 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xF2]G } 1 -test utf-6.32.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { +test utf-6.32.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { testutfnext [testbytestring \xF2\xA0] } 1 -test utf-6.32.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { +test utf-6.32.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xF2\xA0\x00] } 1 test utf-6.33 {Tcl_UtfNext} {testutfnext testbytestring} { @@ -343,7 +373,7 @@ test utf-6.50 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xE8\xA0]G } 1 test utf-6.51 {Tcl_UtfNext} testutfnext { - testutfnext \u8820 + testutfnext 蠠 } 3 test utf-6.52 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xE8\xA0\xD0] @@ -376,30 +406,30 @@ test utf-6.61 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xF2\xA0\xF8] } 1 test utf-6.62 {Tcl_UtfNext} testutfnext { - testutfnext \u8820G + testutfnext 蠠G } 3 test utf-6.63 {Tcl_UtfNext} {testutfnext testbytestring} { - testutfnext \u8820[testbytestring \xA0] + testutfnext [testbytestring \xE8\xA0\xA0\xA0] } 3 test utf-6.64 {Tcl_UtfNext} {testutfnext testbytestring} { - testutfnext \u8820[testbytestring \xD0] + testutfnext 蠠[testbytestring \xD0] } 3 test utf-6.65 {Tcl_UtfNext} {testutfnext testbytestring} { - testutfnext \u8820[testbytestring \xE8] + testutfnext 蠠[testbytestring \xE8] } 3 test utf-6.66 {Tcl_UtfNext} {testutfnext testbytestring} { - testutfnext \u8820[testbytestring \xF2] + testutfnext 蠠[testbytestring \xF2] } 3 test utf-6.67 {Tcl_UtfNext} {testutfnext testbytestring} { - testutfnext \u8820[testbytestring \xF8] + testutfnext 蠠[testbytestring \xF8] } 3 test utf-6.68 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xF2\xA0\xA0]G } 1 -test utf-6.69.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { +test utf-6.69.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { testutfnext [testbytestring \xF2\xA0\xA0\xA0] } 1 -test utf-6.69.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { +test utf-6.69.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xF2\xA0\xA0\xA0] } 4 test utf-6.70 {Tcl_UtfNext} {testutfnext testbytestring} { @@ -414,40 +444,40 @@ test utf-6.72 {Tcl_UtfNext} {testutfnext testbytestring} { test utf-6.73 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xF2\xA0\xA0\xF8] } 1 -test utf-6.74.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { +test utf-6.74.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { testutfnext [testbytestring \xF2\xA0\xA0\xA0]G } 1 -test utf-6.74.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { +test utf-6.74.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xF2\xA0\xA0\xA0]G } 4 -test utf-6.75.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { +test utf-6.75.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] } 1 -test utf-6.75.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { +test utf-6.75.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] } 4 -test utf-6.76.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { +test utf-6.76.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0] } 1 -test utf-6.76.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { +test utf-6.76.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0] } 4 -test utf-6.77.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { +test utf-6.77.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8] } 1 -test utf-6.77.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { +test utf-6.77.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8] } 4 -test utf-6.78.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { +test utf-6.78.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2] } 1 -test utf-6.78.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { +test utf-6.78.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2] } 4 -test utf-6.79.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { +test utf-6.79.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8] } 1 -test utf-6.79.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { +test utf-6.79.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8] } 4 test utf-6.80 {Tcl_UtfNext - overlong sequences} testutfnext { @@ -471,37 +501,55 @@ test utf-6.85 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { test utf-6.86 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { testutfnext [testbytestring \xF0\x80\x80\x80] } 1 -test utf-6.87.0 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs2_utf16} { +test utf-6.87.0 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs2} { testutfnext [testbytestring \xF0\x90\x80\x80] } 1 -test utf-6.87.1 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs4} { +test utf-6.87.1 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xF0\x90\x80\x80] } 4 -test utf-6.88 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring} { +test utf-6.88.0 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xA0\xA0\x00] +} 1 +test utf-6.88.1 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xA0\xA0\x00] } 2 -test utf-6.89 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring} { +test utf-6.89.0 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \x80\x80\x00] +} 1 +test utf-6.89.1 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \x80\x80\x00] } 2 -test utf-6.90.0 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs2_utf16} { +test utf-6.90.0 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs2} { testutfnext [testbytestring \xF4\x8F\xBF\xBF] } 1 -test utf-6.90.1 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs4} { +test utf-6.90.1 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xF4\x8F\xBF\xBF] } 4 test utf-6.91 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring} { testutfnext [testbytestring \xF4\x90\x80\x80] } 1 -test utf-6.92 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring} { +test utf-6.92.0 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xA0\xA0\xA0] +} 1 +test utf-6.92.1 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xA0\xA0\xA0] } 3 -test utf-6.93 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring} { +test utf-6.93.0 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \x80\x80\x80] +} 1 +test utf-6.93.1 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \x80\x80\x80] } 3 -test utf-6.94 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} { +test utf-6.94.0 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xA0\xA0\xA0\xA0] +} 1 +test utf-6.94.1 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \xA0\xA0\xA0\xA0] } 3 -test utf-6.95 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} { +test utf-6.95.0 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \x80\x80\x80\x80] +} 1 +test utf-6.95.1 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring fullutf} { testutfnext [testbytestring \x80\x80\x80\x80] } 3 @@ -536,7 +584,7 @@ test utf-7.6 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xE8] } 1 test utf-7.6.1 {Tcl_UtfPrev} {testutfprev testbytestring} { - testutfprev A\u8820[testbytestring \xA0] 2 + testutfprev A[testbytestring \xE8\xA0\xA0\xA0] 2 } 1 test utf-7.6.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xE8\xF8\xA0\xA0] 2 @@ -551,13 +599,13 @@ test utf-7.7.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xD0\xF8\xA0\xA0] 2 } 1 test utf-7.8 {Tcl_UtfPrev} {testutfprev testbytestring} { - testutfprev A[testbytestring \xA0] + testutfprev [testbytestring A\xA0] } 1 test utf-7.8.1 {Tcl_UtfPrev} {testutfprev testbytestring} { - testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 2 + testutfprev [testbytestring A\xA0\xA0\xA0\xA0] 2 } 1 test utf-7.8.2 {Tcl_UtfPrev} {testutfprev testbytestring} { - testutfprev A[testbytestring \xA0\xF8\xA0\xA0] 2 + testutfprev [testbytestring A\xA0\xF8\xA0\xA0] 2 } 1 test utf-7.9 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0] @@ -590,7 +638,7 @@ test utf-7.11 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xE8\xA0] } 1 test utf-7.11.1 {Tcl_UtfPrev} {testutfprev testbytestring} { - testutfprev A\u8820[testbytestring \xA0] 3 + testutfprev A[testbytestring \xE8\xA0\xA0\xA0] 3 } 1 test utf-7.11.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xE8\xA0\xF8\xA0] 3 @@ -608,13 +656,13 @@ test utf-7.12.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xD0\xA0\xF8\xA0] 3 } 1 test utf-7.13 {Tcl_UtfPrev} {testutfprev testbytestring} { - testutfprev A[testbytestring \xA0\xA0] + testutfprev [testbytestring A\xA0\xA0] } 2 test utf-7.13.1 {Tcl_UtfPrev} {testutfprev testbytestring} { - testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 3 + testutfprev [testbytestring A\xA0\xA0\xA0\xA0] 3 } 2 test utf-7.13.2 {Tcl_UtfPrev} {testutfprev testbytestring} { - testutfprev A[testbytestring \xA0\xA0\xF8\xA0] 3 + testutfprev [testbytestring A\xA0\xA0\xF8\xA0] 3 } 2 test utf-7.14 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xA0] @@ -644,13 +692,13 @@ test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4 } 1 test utf-7.16 {Tcl_UtfPrev} testutfprev { - testutfprev A\u8820 + testutfprev A蠠 } 1 test utf-7.16.1 {Tcl_UtfPrev} {testutfprev testbytestring} { - testutfprev A\u8820[testbytestring \xA0] 4 + testutfprev A[testbytestring \xE8\xA0\xA0\xA0] 4 } 1 test utf-7.16.2 {Tcl_UtfPrev} {testutfprev testbytestring} { - testutfprev A\u8820[testbytestring \xF8] 4 + testutfprev A蠠[testbytestring \xF8] 4 } 1 test utf-7.17 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xD0\xA0\xA0] @@ -661,30 +709,33 @@ test utf-7.17.1 {Tcl_UtfPrev} {testutfprev testbytestring} { test utf-7.17.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xD0\xA0\xA0\xF8] 4 } 3 -test utf-7.18.0 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { - testutfprev A[testbytestring \xA0\xA0\xA0] -} 1 -test utf-7.18.1 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { - testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 4 -} 1 -test utf-7.18.2 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { - testutfprev A[testbytestring \xA0\xA0\xA0\xF8] 4 +test utf-7.18.0 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev [testbytestring A\xA0\xA0\xA0] +} 3 +test utf-7.18.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev [testbytestring A\xA0\xA0\xA0\xA0] 4 +} 3 +test utf-7.18.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev [testbytestring A\xA0\xA0\xA0\xF8] 4 +} 3 +test utf-7.19 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev [testbytestring A\xF8\xA0\xA0\xA0] +} 4 +test utf-7.20.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev [testbytestring A\xF2\xA0\xA0\xA0] +} 4 +test utf-7.20.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev [testbytestring A\xF2\xA0\xA0\xA0] } 1 -test utf-7.19 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { - testutfprev A[testbytestring \xF8\xA0\xA0\xA0] -} 2 -test utf-7.20 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { - testutfprev A[testbytestring \xF2\xA0\xA0\xA0] -} 2 -test utf-7.21 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { - testutfprev A\u8820[testbytestring \xA0] -} 2 -test utf-7.22 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { +test utf-7.21 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xA0\xA0\xA0] +} 4 +test utf-7.22 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xD0\xA0\xA0\xA0] -} 2 -test utf-7.23 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { - testutfprev A[testbytestring \xA0\xA0\xA0\xA0] -} 2 +} 4 +test utf-7.23 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev [testbytestring A\xA0\xA0\xA0\xA0] +} 4 test utf-7.24 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { testutfprev A[testbytestring \xC0\x81] } 2 @@ -706,9 +757,9 @@ test utf-7.28 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { test utf-7.28.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { testutfprev A[testbytestring \xE0\x80\x80] 2 } 1 -test utf-7.29 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring utf16} { +test utf-7.29 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { testutfprev A[testbytestring \xF0\x80\x80\x80] -} 2 +} 4 test utf-7.30 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { testutfprev A[testbytestring \xF0\x80\x80\x80] 4 } 3 @@ -736,9 +787,12 @@ test utf-7.37 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { test utf-7.38 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { testutfprev A[testbytestring \xE0\xA0\x80] 2 } 1 -test utf-7.39 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring utf16} { +test utf-7.39.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} { testutfprev A[testbytestring \xF0\x90\x80\x80] -} 2 +} 4 +test utf-7.39.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF0\x90\x80\x80] +} 1 test utf-7.40.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} { testutfprev A[testbytestring \xF0\x90\x80\x80] 4 } 3 @@ -763,39 +817,42 @@ test utf-7.44 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestrin test utf-7.45 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { testutfprev [testbytestring \xA0\xA0\xA0] } 2 -test utf-7.46 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring utf16} { +test utf-7.46 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { testutfprev [testbytestring \xA0\xA0\xA0\xA0] -} 1 +} 3 test utf-7.47 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} {testutfprev testbytestring} { testutfprev [testbytestring \xE8\xA0] } 0 test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} testutfprev { - testutfprev \u8820 2 + testutfprev 蠠 2 } 0 test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} { testutfprev [testbytestring \xE8\xA0\x00] 2 } 0 -test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring utf16} { +test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] -} 2 -test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} { +} 4 +test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] +} 1 +test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4 } 3 -test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} { +test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4 } 1 -test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} { +test utf-7.48.4 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3 } 2 -test utf-7.48.4 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} { +test utf-7.48.5 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3 } 1 -test utf-7.48.5 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { +test utf-7.48.6 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 2 } 1 -test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring utf16} { +test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { testutfprev A[testbytestring \xF4\x90\x80\x80] -} 2 +} 4 test utf-7.49.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { testutfprev A[testbytestring \xF4\x90\x80\x80] 4 } 3 @@ -810,14 +867,14 @@ test utf-8.1 {Tcl_UniCharAtIndex: index = 0} { string index abcd 0 } a test utf-8.2 {Tcl_UniCharAtIndex: index = 0} { - string index \u4E4E\u25A 0 -} \u4E4E + string index 乎ɚ 0 +} 乎 test utf-8.3 {Tcl_UniCharAtIndex: index > 0} { string index abcd 2 } c test utf-8.4 {Tcl_UniCharAtIndex: index > 0} { - string index \u4E4E\u25A\xFF\u543 2 -} \xFF + string index 乎ɚÿՃ 2 +} ÿ test utf-8.5.0 {Tcl_UniCharAtIndex: high surrogate} ucs2 { string index \uD842 0 } \uD842 @@ -834,116 +891,116 @@ test utf-8.7.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { string index \uD83D\uDE00G 0 } \uD83D test utf-8.7.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { - string index \uD83D\uDE00G 0 -} \U1F600 + string index 😀G 0 +} 😀 test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} utf16 { - string index \uD83D\uDE00G 0 -} \U1F600 + string index 😀G 0 +} 😀 test utf-8.8.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { string index \uD83D\uDE00G 1 } \uDE00 test utf-8.8.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { - string index \uD83D\uDE00G 1 + string index 😀G 1 } G test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} utf16 { - string index \uD83D\uDE00G 1 + string index 😀G 1 } {} test utf-8.9.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { string index \uD83D\uDE00G 2 } G test utf-8.9.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { - string index \uD83D\uDE00G 2 + string index 😀G 2 } {} test utf-8.9.2 {Tcl_UniCharAtIndex: Emoji} utf16 { - string index \uD83D\uDE00G 2 + string index 😀G 2 } G -test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} { - string index \U1F600G 0 +test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index 😀G 0 } \uFFFD -test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} { - string index \U1F600G 0 -} \U1F600 -test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} { - string index \U1F600G 0 -} \U1F600 -test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} { - string index \U1F600G 1 +test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index 😀G 0 +} 😀 +test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index 😀G 0 +} 😀 +test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index 😀G 1 } G -test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} { - string index \U1F600G 1 +test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index 😀G 1 } G -test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} { - string index \U1F600G 1 +test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index 😀G 1 } {} -test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} { - string index \U1F600G 2 +test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index 😀G 2 } {} -test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} { - string index \U1F600G 2 +test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index 😀G 2 } {} -test utf-8.12.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} { - string index \U1F600G 2 +test utf-8.12.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index 😀G 2 } G test utf-9.1 {Tcl_UtfAtIndex: index = 0} { string range abcd 0 2 } abc test utf-9.2 {Tcl_UtfAtIndex: index > 0} { - string range \u4E4E\u25A\xFF\u543klmnop 1 5 -} \u25A\xFF\u543kl + string range 乎ɚÿՃklmnop 1 5 +} ɚÿՃkl test utf-9.3.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 { string range \uD83D\uDE00G 0 0 } \uD83D test utf-9.3.1 {Tcl_UtfAtIndex: index = 0, Emoji} ucs4 { - string range \uD83D\uDE00G 0 0 -} \U1F600 + string range 😀G 0 0 +} 😀 test utf-9.3.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 { - string range \uD83D\uDE00G 0 0 -} \U1F600 + string range 😀G 0 0 +} 😀 test utf-9.4.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { string range \uD83D\uDE00G 1 1 } \uDE00 test utf-9.4.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { - string range \uD83D\uDE00G 1 1 + string range 😀G 1 1 } G test utf-9.4.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { - string range \uD83D\uDE00G 1 1 + string range 😀G 1 1 } {} test utf-9.5.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { string range \uD83D\uDE00G 2 2 } G test utf-9.5.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { - string range \uD83D\uDE00G 2 2 + string range 😀G 2 2 } {} test utf-9.5.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { - string range \uD83D\uDE00G 2 2 + string range 😀G 2 2 } G -test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs2} { - string range \U1f600G 0 0 +test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 { + string range 😀G 0 0 } \uFFFD -test utf-9.6.1 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs4} { - string range \U1f600G 0 0 -} \U1F600 -test utf-9.6.2 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc utf16} { - string range \U1f600G 0 0 -} \U1F600 -test utf-9.7.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} { - string range \U1f600G 1 1 +test utf-9.6.1 {Tcl_UtfAtIndex: index = 0, Emoji} ucs4 { + string range 😀G 0 0 +} 😀 +test utf-9.6.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 { + string range 😀G 0 0 +} 😀 +test utf-9.7.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { + string range 😀G 1 1 } G -test utf-9.7.1 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs4} { - string range \U1f600G 1 1 +test utf-9.7.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { + string range 😀G 1 1 } G -test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc utf16} { - string range \U1f600G 1 1 +test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { + string range 😀G 1 1 } {} -test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} { - string range \U1f600G 2 2 +test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { + string range 😀G 2 2 } {} -test utf-9.8.1 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs4} { - string range \U1f600G 2 2 +test utf-9.8.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { + string range 😀G 2 2 } {} -test utf-9.8.2 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc utf16} { - string range \U1f600G 2 2 +test utf-9.8.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { + string range 😀G 2 2 } G test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { @@ -962,10 +1019,10 @@ test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring { test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring { expr {"\u4E216" eq "[testbytestring \xE4\xB8\xA1]6"} } 1 -test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} {Uesc fullutf testbytestring} { +test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} {fullutf testbytestring} { expr {"\U1E2165" eq "[testbytestring \xF0\x9E\x88\x96]5"} } 1 -test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} {Uesc fullutf testbytestring} { +test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} {fullutf testbytestring} { expr {"\U10E2165" eq "[testbytestring \xF4\x8E\x88\x96]5"} } 1 @@ -1028,13 +1085,13 @@ bsCheck \U4E21 20001 Uesc bsCheck \U004E21 20001 Uesc bsCheck \U00004E21 20001 Uesc bsCheck \U0000004E21 78 Uesc -bsCheck \U00110000 69632 {Uesc fullutf} -bsCheck \U01100000 69632 {Uesc fullutf} -bsCheck \U11000000 69632 {Uesc fullutf} -bsCheck \U0010FFFF 1114111 {Uesc fullutf} -bsCheck \U010FFFF0 1114111 {Uesc fullutf} -bsCheck \U10FFFF00 1114111 {Uesc fullutf} -bsCheck \UFFFFFFFF 1048575 {Uesc fullutf} +bsCheck \U00110000 69632 fullutf +bsCheck \U01100000 69632 fullutf +bsCheck \U11000000 69632 fullutf +bsCheck \U0010FFFF 1114111 fullutf +bsCheck \U010FFFF0 1114111 fullutf +bsCheck \U10FFFF00 1114111 fullutf +bsCheck \UFFFFFFFF 1048575 fullutf test utf-11.1 {Tcl_UtfToUpper} { string toupper {} @@ -1046,17 +1103,17 @@ test utf-11.3 {Tcl_UtfToUpper} { string toupper \xE3gh } \xC3GH test utf-11.4 {Tcl_UtfToUpper} { - string toupper \u01E3gh -} \u01E2GH + string toupper ǣgh +} ǢGH test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} { - string toupper \u10D0\u1C90 -} \u1C90\u1C90 -test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} {Uesc fullutf} { - string toupper \U10428 -} \U10400 + string toupper აᲐ +} ᲐᲐ +test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} fullutf { + string toupper 𐐨 +} 𐐀 test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} fullutf { - string toupper \uD801\uDC28 -} \uD801\uDC00 + string toupper 𐐨 +} 𐐀 test utf-11.8 {Tcl_UtfToUpper low/high surrogate)} { string toupper \uDC24\uD824 } \uDC24\uD824 @@ -1068,23 +1125,23 @@ test utf-12.2 {Tcl_UtfToLower} { string tolower ABC } abc test utf-12.3 {Tcl_UtfToLower} { - string tolower \xC3GH -} \xE3gh + string tolower ÃGH +} ãgh test utf-12.4 {Tcl_UtfToLower} { - string tolower \u01E2GH -} \u01E3gh + string tolower ǢGH +} ǣgh test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} { - string tolower \u10D0\u1C90 -} \u10D0\u10D0 + string tolower აᲐ +} აა test utf-12.6 {Tcl_UtfToLower low/high surrogate)} { string tolower \uDC24\uD824 } \uDC24\uD824 -test utf-12.7 {Tcl_UtfToLower beyond U+FFFF} {Uesc fullutf} { - string tolower \U10400 -} \U10428 +test utf-12.7 {Tcl_UtfToLower beyond U+FFFF} fullutf { + string tolower 𐐀 +} 𐐨 test utf-12.8 {Tcl_UtfToLower beyond U+FFFF} fullutf { - string tolower \uD801\uDC00 -} \uD801\uDC28 + string tolower 𐐀 +} 𐐨 test utf-13.1 {Tcl_UtfToTitle} { string totitle {} @@ -1093,26 +1150,26 @@ test utf-13.2 {Tcl_UtfToTitle} { string totitle abc } Abc test utf-13.3 {Tcl_UtfToTitle} { - string totitle \xE3GH -} \xC3gh + string totitle ãGH +} Ãgh test utf-13.4 {Tcl_UtfToTitle} { - string totitle \u01F3AB -} \u01F2ab + string totitle dzAB +} Dzab test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { - string totitle \u10D0\u1C90 -} \u10D0\u1C90 + string totitle აᲐ +} აᲐ test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { - string totitle \u1C90\u10D0 -} \u1C90\u10D0 + string totitle Აა +} Აა test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} { string totitle \uDC24\uD824 } \uDC24\uD824 -test utf-13.8 {Tcl_UtfToTitle beyond U+FFFF} {Uesc fullutf} { - string totitle \U10428\U10400 -} \U10400\U10428 +test utf-13.8 {Tcl_UtfToTitle beyond U+FFFF} fullutf { + string totitle 𐐨𐐀 +} 𐐀𐐨 test utf-13.9 {Tcl_UtfToTitle beyond U+FFFF} fullutf { - string totitle \uD801\uDC28\uD801\uDC00 -} \uD801\uDC00\uD801\uDC28 + string totitle 𐐨𐐀 +} 𐐀𐐨 test utf-14.1 {Tcl_UtfNcasecmp} { string compare -nocase a b @@ -1131,8 +1188,8 @@ test utf-15.1 {Tcl_UniCharToUpper, negative delta} { string toupper aA } AA test utf-15.2 {Tcl_UniCharToUpper, positive delta} { - string toupper \u0178\xFF -} \u0178\u0178 + string toupper Ÿÿ +} ŸŸ test utf-15.3 {Tcl_UniCharToUpper, no delta} { string toupper ! } ! @@ -1141,25 +1198,25 @@ test utf-16.1 {Tcl_UniCharToLower, negative delta} { string tolower aA } aa test utf-16.2 {Tcl_UniCharToLower, positive delta} { - string tolower \u0178\xFF\uA78D\u01C5 -} \xFF\xFF\u0265\u01C6 + string tolower ŸÿꞍDž +} ÿÿɥdž test utf-17.1 {Tcl_UniCharToLower, no delta} { string tolower ! } ! test utf-18.1 {Tcl_UniCharToTitle, add one for title} { - string totitle \u01C4 -} \u01C5 + string totitle DŽ +} Dž test utf-18.2 {Tcl_UniCharToTitle, subtract one for title} { - string totitle \u01C6 -} \u01C5 + string totitle dž +} Dž test utf-18.3 {Tcl_UniCharToTitle, subtract delta for title (positive)} { - string totitle \u017F -} \x53 + string totitle ſ +} S test utf-18.4 {Tcl_UniCharToTitle, subtract delta for title (negative)} { - string totitle \xFF -} \u0178 + string totitle ÿ +} Ÿ test utf-18.5 {Tcl_UniCharToTitle, no delta} { string totitle ! } ! @@ -1173,25 +1230,7 @@ test utf-19.1 {TclUniCharLen} -body { test utf-20.1 {TclUniCharNcmp} ucs4 { string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0] } -1 -test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} ucs2 { - set one [format %c 0xFFFF] - set two [format %c 0x10000] - set first [string compare $one $two] - string range $one 0 0 - string range $two 0 0 - set second [string compare $one $two] - expr {($first == $second) ? "agree" : "disagree"} -} agree -test utf-20.2.1 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} {utf16 knownBug} { - set one [format %c 0xFFFF] - set two [format %c 0x10000] - set first [string compare $one $two] - string range $one 0 0 - string range $two 0 0 - set second [string compare $one $two] - expr {($first == $second) ? "agree" : "disagree"} -} agree -test utf-20.2.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} ucs4 { +test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} { set one [format %c 0xFFFF] set two [format %c 0x10000] set first [string compare $one $two] @@ -1203,23 +1242,23 @@ test utf-20.2.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} ucs4 { test utf-21.1 {TclUniCharIsAlnum} { # this returns 1 with Unicode 7 compliance - string is alnum \u1040\u021F\u0220 + string is alnum ၀ȟȠ } 1 test utf-21.2 {unicode alnum char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - list [regexp {^[[:alnum:]]+$} \u1040\u021F\u0220] [regexp {^\w+$} \u1040\u021F\u0220_\u203F\u2040\u2054\uFE33\uFE34\uFE4D\uFE4E\uFE4F\uFF3F] + list [regexp {^[[:alnum:]]+$} ၀ȟȠ] [regexp {^\w+$} ၀ȟȠ_‿⁀⁔︳︴﹍﹎﹏＿] } {1 1} test utf-21.3 {unicode print char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - regexp {^[[:print:]]+$} \uFBC1 + regexp {^[[:print:]]+$} ﯁ } 1 test utf-21.4 {TclUniCharIsGraph} { # [Bug 3464428] - string is graph \u0120 + string is graph Ġ } 1 test utf-21.5 {unicode graph char in regc_locale.c} { # [Bug 3464428] - regexp {^[[:graph:]]+$} \u0120 + regexp {^[[:graph:]]+$} Ġ } 1 test utf-21.6 {TclUniCharIsGraph} { # [Bug 3464428] @@ -1254,25 +1293,25 @@ test utf-22.1 {TclUniCharIsWordChar} { string wordend "xyz123_bar fg" 0 } 10 test utf-22.2 {TclUniCharIsWordChar} { - string wordend "x\u5080z123_bar\u203C fg" 0 + string wordend "x傀z123_bar‼ fg" 0 } 10 test utf-23.1 {TclUniCharIsAlpha} { # this returns 1 with Unicode 7 compliance - string is alpha \u021F\u0220\u037F\u052F + string is alpha ȟȠͿԯ } 1 test utf-23.2 {unicode alpha char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - regexp {^[[:alpha:]]+$} \u021F\u0220\u037F\u052F + regexp {^[[:alpha:]]+$} ȟȠͿԯ } 1 test utf-24.1 {TclUniCharIsDigit} { # this returns 1 with Unicode 7 compliance - string is digit \u1040\uABF0 + string is digit ၀꯰ } 1 test utf-24.2 {unicode digit char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - list [regexp {^[[:digit:]]+$} \u1040\uABF0] [regexp {^\d+$} \u1040\uABF0] + list [regexp {^[[:digit:]]+$} ၀꯰] [regexp {^\d+$} ၀꯰] } {1 1} test utf-24.3 {TclUniCharIsSpace} { @@ -1319,9 +1358,9 @@ UniCharCaseCmpTest > b a UniCharCaseCmpTest > B a UniCharCaseCmpTest > aBcB abca UniCharCaseCmpTest < \uFFFF [format %c 0x10000] ucs4 -UniCharCaseCmpTest < \uFFFF \U10000 {Uesc ucs4} +UniCharCaseCmpTest < \uFFFF \U10000 ucs4 UniCharCaseCmpTest > [format %c 0x10000] \uFFFF ucs4 -UniCharCaseCmpTest > \U10000 \uFFFF {Uesc ucs4} +UniCharCaseCmpTest > \U10000 \uFFFF ucs4 test utf-26.1 {Tcl_UniCharDString} -setup { diff --git a/tests/util.test b/tests/util.test index 29cf651..c3b9f2d 100644 --- a/tests/util.test +++ b/tests/util.test @@ -33,9 +33,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -45,23 +45,23 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) - binary scan \x00\x00\x00\x00\x00\x00\xf8\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\xFF d \ ieeeValues(-NaN) - binary scan \xef\xcd\xab\x89\x67\x45\xfb\xff d \ + binary scan \xEF\xCD\xAB\x89\x67\x45\xFB\xFF d \ ieeeValues(-NaN(3456789abcdef)) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -71,15 +71,15 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) - binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-NaN) - binary scan \xff\xfb\x45\x67\x89\xab\xcd\xef d \ + binary scan \xFF\xFB\x45\x67\x89\xAB\xCD\xEF d \ ieeeValues(-NaN(3456789abcdef)) set ieeeValues(littleEndian) 0 return 1 @@ -207,14 +207,17 @@ test util-4.5 {Tcl_ConcatObj - backslash-space at end of argument} { concat a { } c } {a c} test util-4.6 {Tcl_ConcatObj - utf-8 sequence with "whitespace" char} { - # Check for Bug #227512. If this violates C isspace, then it returns \xc3. - concat \xe0 -} \xe0 + # Check for Bug #227512. If this violates C isspace, then it returns \xC3. + concat \xE0 +} \xE0 test util-4.7 {Tcl_ConcatObj - refCount safety} testconcatobj { # Check for Bug #1447328 (actually, bugs in its original "fix"). One of the # symptoms was Bug #2055782. testconcatobj } {} +test util-4.8 {Tcl_ConcatObj - [Bug 26649439c7]} { + concat [list foo] [list #] +} {foo {#}} proc Wrapper_Tcl_StringMatch {pattern string} { # Forces use of Tcl_StringMatch, not Tcl_UniCharCaseMatch @@ -239,14 +242,14 @@ test util-5.6 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch *3*6*9 01234567890 } 0 test util-5.7 {Tcl_StringMatch: UTF-8} { - Wrapper_Tcl_StringMatch *u \u4e4fu + Wrapper_Tcl_StringMatch *u 乏u } 1 test util-5.8 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch a?c abc } 1 test util-5.9 {Tcl_StringMatch: UTF-8} { # skip one character in string - Wrapper_Tcl_StringMatch a?c a\u4e4fc + Wrapper_Tcl_StringMatch a?c a乏c } 1 test util-5.10 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch a??c abc @@ -259,15 +262,15 @@ test util-5.12 {Tcl_StringMatch} { } 1 test util-5.13 {Tcl_StringMatch: UTF-8} { # string += Tcl_UtfToUniChar(string, &ch); - Wrapper_Tcl_StringMatch "\[\u4e4fxy\]bc" "\u4e4fbc" + Wrapper_Tcl_StringMatch "\[乏xy\]bc" "乏bc" } 1 test util-5.14 {Tcl_StringMatch} { - # if ((*pattern == ']') || (*pattern == '\0')) + # if ((*pattern == ']') || (*pattern == '\x00')) # badly formed pattern Wrapper_Tcl_StringMatch {[]} {[]} } 0 test util-5.15 {Tcl_StringMatch} { - # if ((*pattern == ']') || (*pattern == '\0')) + # if ((*pattern == ']') || (*pattern == '\x00')) # badly formed pattern Wrapper_Tcl_StringMatch {[} {[} } 0 @@ -277,17 +280,17 @@ test util-5.16 {Tcl_StringMatch} { test util-5.17 {Tcl_StringMatch: UTF-8} { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # get 1 UTF-8 character - Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc" + Wrapper_Tcl_StringMatch "a\[a乏c]c" "a乏c" } 1 test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring { # pattern += Tcl_UtfToUniChar(pattern, &endChar); - # proper advance: wrong answer would match on UTF trail byte of \u4e4f - Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\x8fc] + # proper advance: wrong answer would match on UTF trail byte of 乏 + Wrapper_Tcl_StringMatch {a[a乏c]c} [testbytestring a\x8Fc] } 0 test util-5.19 {Tcl_StringMatch: UTF-8} { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # proper advance. - Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} "acc" + Wrapper_Tcl_StringMatch {a[a乏c]c} "acc" } 1 test util-5.20 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch {a[xyz]c} abc @@ -296,13 +299,13 @@ test util-5.21 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch {12[2-7]45} 12345 } 1 test util-5.22 {Tcl_StringMatch: UTF-8 range} { - Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "0" + Wrapper_Tcl_StringMatch "\[一-乏]" "0" } 0 test util-5.23 {Tcl_StringMatch: UTF-8 range} { - Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "\u4e33" + Wrapper_Tcl_StringMatch "\[一-乏]" "丳" } 1 test util-5.24 {Tcl_StringMatch: UTF-8 range} { - Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "\uff08" + Wrapper_Tcl_StringMatch "\[一-乏]" "（" } 0 test util-5.25 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12345 @@ -356,16 +359,16 @@ test util-5.41 {Tcl_StringMatch: skip correct number of ']'} { Wrapper_Tcl_StringMatch {[A-]]x} Ax } 1 test util-5.42 {Tcl_StringMatch: skip correct number of ']'} { - Wrapper_Tcl_StringMatch {[A-]]x} \ue1x + Wrapper_Tcl_StringMatch {[A-]]x} \xE1x } 0 test util-5.43 {Tcl_StringMatch: skip correct number of ']'} { - Wrapper_Tcl_StringMatch \[A-]\ue1]x \ue1x + Wrapper_Tcl_StringMatch \[A-]\xE1]x \xE1x } 1 test util-5.44 {Tcl_StringMatch: skip correct number of ']'} { Wrapper_Tcl_StringMatch {[A-]h]x} hx } 1 test util-5.45 {Tcl_StringMatch} { - # if (*pattern == '\0') + # if (*pattern == '\x00') # badly formed pattern, still treats as a set Wrapper_Tcl_StringMatch {[a} a } 1 @@ -388,7 +391,7 @@ test util-5.51 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch "" "" } 1 test util-5.52 {Tcl_StringMatch} { - Wrapper_Tcl_StringMatch \[a\u0000 a\x80 + Wrapper_Tcl_StringMatch \[a\x00 a\x80 } 0 @@ -483,27 +486,27 @@ test util-8.1 {TclNeedSpace - correct utf-8 handling} { # which calls on TclNeedSpace(). If [interp target] # is ever updated, this test will no longer test # TclNeedSpace. - interp create \u5420 - interp create [list \u5420 foo] - interp alias {} fooset [list \u5420 foo] set + interp create 吠 + interp create [list 吠 foo] + interp alias {} fooset [list 吠 foo] set set result [interp target {} fooset] - interp delete \u5420 + interp delete 吠 set result -} "\u5420 foo" +} "吠 foo" test util-8.2 {TclNeedSpace - correct utf-8 handling} testdstring { # Bug 411825 # This tests the same bug as the previous test, but # should be more future-proof, as the DString # operations will likely continue to call TclNeedSpace testdstring free - testdstring append \u5420 -1 + testdstring append 吠 -1 testdstring element foo llength [testdstring get] } 2 test util-8.3 {TclNeedSpace - correct utf-8 handling} testdstring { # Bug 411825 - new variant reported by Dossy Shiobara testdstring free - testdstring append \u00A0 -1 + testdstring append \xA0 -1 testdstring element foo llength [testdstring get] } 2 diff --git a/tests/var.test b/tests/var.test index a8d4b84..3ca1a76 100644 --- a/tests/var.test +++ b/tests/var.test @@ -203,27 +203,27 @@ test var-1.19 {TclLookupVar, right error message when parsing variable name} -bo [format set] thisvar(doesntexist) } -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable} test var-1.20 {TclLookupVar, regression on utf-8 variable names} -setup { - proc p [list \u20ac \xe4] {info vars} + proc p [list € ä] {info vars} } -body { # test variable with non-ascii name is available (euro and a-uml chars here): list \ [p 1 2] \ - [apply [list [list \u20ac \xe4] {info vars}] 1 2] \ - [apply [list [list [list \u20ac \u20ac] [list \xe4 \xe4]] {info vars}]] \ + [apply [list [list € ä] {info vars}] 1 2] \ + [apply [list [list [list € €] [list ä ä]] {info vars}]] \ } -cleanup { rename p {} -} -result [lrepeat 3 [list \u20ac \xe4]] +} -result [lrepeat 3 [list € ä]] test var-1.21 {TclLookupVar, regression on utf-8 variable names} -setup { - proc p [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]} + proc p [list [list € v€] [list ä vä]] {list [set €] [set ä]} } -body { # test variable with non-ascii name (and default) is resolvable (euro and a-uml chars here): list \ [p] \ - [apply [list [list \u20ac \xe4] {list [set \u20ac] [set \xe4]}] v\u20ac v\xe4] \ - [apply [list [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}]] \ + [apply [list [list € ä] {list [set €] [set ä]}] v€ vä] \ + [apply [list [list [list € v€] [list ä vä]] {list [set €] [set ä]}]] \ } -cleanup { rename p {} -} -result [lrepeat 3 [list v\u20ac v\xe4]] +} -result [lrepeat 3 [list v€ vä]] test var-2.1 {Tcl_LappendObjCmd, create var if new} { catch {unset x} diff --git a/tests/winDde.test b/tests/winDde.test index f57a226..925574b 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -37,6 +37,7 @@ proc createChildProcess {ddeServerName args} { file delete -force $::scriptName set f [open $::scriptName w+] + fconfigure $f -encoding utf-8 puts $f [list set ddeServerName $ddeServerName] puts $f [list load $::ddelib Dde] puts $f { @@ -96,7 +97,7 @@ proc createChildProcess {ddeServerName args} { # run the child server script. set f [open |[list [interpreter] $::scriptName] r] - fconfigure $f -buffering line + fconfigure $f -buffering line -encoding utf-8 gets $f line return $f } diff --git a/tests/winPipe.test b/tests/winPipe.test index 6252f96..28d4f5b 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -174,7 +174,7 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \ {win exec cat32} { set f [open "|[list $cat32]" r+] puts $f $big - puts $f \032 + puts $f \x1A flush $f set r [read $f 64] catch {close $f} diff --git a/tests/zipfs.test b/tests/zipfs.test index 8689268..bf9c969 100644 --- a/tests/zipfs.test +++ b/tests/zipfs.test @@ -270,6 +270,137 @@ test zipfs-3.4 {zipfs in child interpreters} -constraints zipfs -setup { } -returnCodes error -cleanup { interp delete $safe } -result {not allowed to invoke subcommand mkzip of zipfs} + +test zipfs-4.1 {zipfs lmkimg} -constraints zipfs -setup { + set baseImage [makeFile "return sourceWorking\n\x1A" base] + set targetImage [makeFile "" target] + set addFile [makeFile "return mountWorking" add.data] + file delete $targetImage +} -body { + zipfs lmkimg $targetImage [list $addFile test/add.tcl] {} $baseImage + zipfs mount ziptest $targetImage + try { + list [source $targetImage] [source //zipfs:/ziptest/test/add.tcl] + } finally { + zipfs unmount ziptest + } +} -cleanup { + removeFile $baseImage + removeFile $targetImage + removeFile $addFile +} -result {sourceWorking mountWorking} +test zipfs-4.2 {zipfs lmkimg: making an image from an image} -constraints zipfs -setup { + set baseImage [makeFile "return sourceWorking\n\x1A" base_image.tcl] + set midImage [makeFile "" mid_image.tcl] + set targetImage [makeFile "" target_image.tcl] + set addFile [makeFile "return mountWorking" add.data] + file delete $midImage $targetImage +} -body { + zipfs lmkimg $midImage [list $addFile test/ko.tcl] {} $baseImage + zipfs lmkimg $targetImage [list $addFile test/ok.tcl] {} $midImage + zipfs mount ziptest $targetImage + try { + list [glob -tails -directory //zipfs://ziptest/test *.tcl] \ + [if {[file size $midImage] == [file size $targetImage]} { + string cat equal + } else { + list mid=[file size $midImage] target=[file size $targetImage] + }] + } finally { + zipfs unmount ziptest + } +} -cleanup { + removeFile $baseImage + removeFile $midImage + removeFile $targetImage + removeFile $addFile +} -result {ok.tcl equal} +test zipfs-4.3 {zipfs lmkimg: stripping password} -constraints zipfs -setup { + set baseImage [makeFile "return sourceWorking\n\x1A" base_image.tcl] + set midImage [makeFile "" mid_image.tcl] + set targetImage [makeFile "" target_image.tcl] + set addFile [makeFile "return mountWorking" add.data] + file delete $midImage $targetImage +} -body { + set pass gorp + zipfs lmkimg $midImage [list $addFile test/add.tcl] $pass $baseImage + zipfs lmkimg $targetImage [list $addFile test/ok.tcl] {} $midImage + zipfs mount ziptest $targetImage + try { + glob -tails -directory //zipfs://ziptest/test *.tcl + } finally { + zipfs unmount ziptest + } +} -cleanup { + removeFile $baseImage + removeFile $midImage + removeFile $targetImage + removeFile $addFile +} -result {ok.tcl} +test zipfs-4.4 {zipfs lmkimg: final password} -constraints zipfs -setup { + set baseImage [makeFile "return sourceWorking\n\x1A" base_image.tcl] + set midImage [makeFile "" mid_image.tcl] + set targetImage [makeFile "" target_image.tcl] + set addFile [makeFile "return mountWorking" add.data] + file delete $midImage $targetImage +} -body { + set pass gorp + zipfs lmkimg $midImage [list $addFile test/add.tcl] {} $baseImage + zipfs lmkimg $targetImage [list $addFile test/ok.tcl] $pass $midImage + zipfs mount ziptest $targetImage + try { + glob -tails -directory //zipfs://ziptest/test *.tcl + } finally { + zipfs unmount ziptest + } +} -cleanup { + removeFile $baseImage + removeFile $midImage + removeFile $targetImage + removeFile $addFile +} -result {ok.tcl} +test zipfs-4.5 {zipfs lmkimg: making image from mounted} -constraints zipfs -setup { + set baseImage [makeFile "return sourceWorking\n\x1A" base_image.tcl] + set midImage [makeFile "" mid_image.tcl] + set targetImage [makeFile "" target_image.tcl] + set addFile [makeFile "return mountWorking" add.data] + file delete $midImage $targetImage +} -body { + zipfs lmkimg $midImage [list $addFile test/add.tcl] {} $baseImage + zipfs mount ziptest $midImage + set f [glob -directory //zipfs://ziptest/test *.tcl] + zipfs lmkimg $targetImage [list $f test/ok.tcl] {} $midImage + zipfs unmount ziptest + zipfs mount ziptest $targetImage + list $f [glob -directory //zipfs://ziptest/test *.tcl] +} -cleanup { + zipfs unmount ziptest + removeFile $baseImage + removeFile $midImage + removeFile $targetImage + removeFile $addFile +} -result {//zipfs://ziptest/test/add.tcl //zipfs://ziptest/test/ok.tcl} + +test zipfs-5.1 {zipfs mount_data: short data} -constraints zipfs -body { + zipfs mount_data gorp {} +} -returnCodes error -result {bad zip data} +test zipfs-5.2 {zipfs mount_data: short data} -constraints zipfs -body { + zipfs mount_data gorp gorpGORPgorp +} -returnCodes error -result {bad zip data} +test zipfs-5.3 {zipfs mount_data: short data} -constraints zipfs -body { + set data PK\x03\x04..................................... + append data PK\x01\x02..................................... + append data PK\x05\x06..................................... + zipfs mount_data gorp $data +} -returnCodes error -result {bad zip data} +test zipfs-5.4 {zipfs mount_data: bad arg count} -constraints zipfs -body { + zipfs mount_data gorp {} foobar +} -returnCodes error -result {wrong # args: should be "zipfs mount_data ?mountpoint? ?data?"} + +test zipfs-6.1 {zipfs mkkey} -constraints zipfs -body { + binary scan [zipfs mkkey gorp] cu* x + return $x +} -result {224 226 111 103 4 80 75 90 90} ::tcltest::cleanupTests return 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<version>/html diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index 47b8ad4..4f4acbb 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -1214,7 +1214,7 @@ proc genStubs::init {} { # Results: # Returns any values that were not assigned to variables. -if {[string length [namespace which lassign]] == 0} { +if {[namespace which lassign] ne ""} { proc lassign {valueList args} { if {[llength $args] == 0} { error "wrong # args: should be \"lassign list varName ?varName ...?\"" diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index 2d82bb1..b7a8520 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -1314,6 +1314,7 @@ proc make-manpage-section {outputDir sectionDescriptor} { set manual(wing-copyrights) {} makedirhier $outputDir/$manual(wing-file) set manual(wing-toc-fp) [open $outputDir/$manual(wing-file)/[indexfile] w] + fconfigure $manual(wing-toc-fp) -translation lf -encoding utf-8 # whistle puts stderr "scanning section $manual(wing-name)" # put the entry for this section into the short table of contents @@ -1364,6 +1365,7 @@ proc make-manpage-section {outputDir sectionDescriptor} { continue } set manual(infp) [open $manual(page)] + fconfigure $manual(infp) -encoding utf-8 set manual(text) {} set manual(partial-text) {} foreach p {.RS .DS .CS .SO} { diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index efb7a13..0e87531 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -67,7 +67,7 @@ proc findversion {top name useversion} { # to do # use glob matching instead of string matching or add # brace handling to [string matcch] - if {$useversion eq {} || [string match $useversion $major.$minor]} { + if {$useversion eq "" || [string match $useversion $major.$minor]} { set top [file dirname [file dirname $tclh]] set prefix [file dirname $top] return [list $prefix [file tail $top] $major $minor] @@ -172,17 +172,17 @@ proc parse_command_line {} { # Find Tcl (firstly using glob pattern / backwards compatible way) set tcldir [lindex [lsort [glob -nocomplain -tails -type d \ -directory $tcltkdir tcl$useversion]] end] - if {$tcldir ne {}} { + if {$tcldir ne ""} { # obtain version from generic header if we can: lassign [getversion [file join $tcltkdir $tcldir generic tcl.h]] major minor } else { lassign [findversion $tcltkdir tcl $useversion] tcltkdir tcldir major minor } - if {$tcldir eq {} && $opt_build_tcl} { + if {$tcldir eq "" && $opt_build_tcl} { puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir" exit 1 } - puts "using Tcl source directory $tcltkdir $tcldir" + puts "using Tcl source directory [file join $tcltkdir $tcldir]" } @@ -190,19 +190,19 @@ proc parse_command_line {} { # Find Tk (firstly using glob pattern / backwards compatible way) set tkdir [lindex [lsort [glob -nocomplain -tails -type d \ -directory $tcltkdir tk$useversion]] end] - if {$tkdir ne {}} { + if {$tkdir ne ""} { if {$major eq ""} { # obtain version from generic header if we can: - lassign [getversion [file join $tcltkdir $tcldir generic tk.h]] major minor + lassign [getversion [file join $tcltkdir $tkdir generic tk.h]] major minor } } else { lassign [findversion $tcltkdir tk $useversion] tcltkdir tkdir major minor } - if {$tkdir eq {} && $opt_build_tk} { + if {$tkdir eq "" && $opt_build_tk} { puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" exit 1 } - puts "using Tk source directory $tkdir" + puts "using Tk source directory [file join $tcltkdir $tkdir]" } puts "verbose messages are [expr {$verbose ? {on} : {off}}]" @@ -329,10 +329,12 @@ proc make-man-pages {html args} { makedirhier $html set cssfd [open $html/$::CSSFILE w] + fconfigure $cssfd -translation lf -encoding utf-8 puts $cssfd [css-stylesheet] close $cssfd set manual(short-toc-n) 1 set manual(short-toc-fp) [open $html/[indexfile] w] + fconfigure $manual(short-toc-fp) -translation lf -encoding utf-8 puts $manual(short-toc-fp) [htmlhead $overall_title $overall_title] puts $manual(short-toc-fp) "<dl class=\"keylist\">" set manual(merge-copyrights) {} @@ -370,6 +372,7 @@ proc make-man-pages {html args} { file delete -force -- $html/Keywords makedirhier $html/Keywords set keyfp [open $html/Keywords/[indexfile] w] + fconfigure $keyfp -translation lf -encoding utf-8 puts $keyfp [htmlhead "$tcltkdesc Keywords" "$tcltkdesc Keywords" \ $overall_title "../[indexfile]"] set letters {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} @@ -393,6 +396,7 @@ proc make-man-pages {html args} { } # Per-keyword page set afp [open $html/Keywords/$a.html w] + fconfigure $afp -translation lf -encoding utf-8 puts $afp [htmlhead "$tcltkdesc Keywords - $a" \ "$tcltkdesc Keywords - $a" \ $overall_title "../[indexfile]"] @@ -469,6 +473,7 @@ proc make-man-pages {html args} { puts -nonewline stderr . } set outfd [open $html/$manual(wing-file)/$manual(name).html w] + fconfigure $outfd -translation lf -encoding utf-8 puts $outfd [htmlhead "$manual($manual(wing-file)-$manual(name)-title)" \ $manual(name) $wing_name "[indexfile]" \ $overall_title "../[indexfile]"] @@ -511,6 +516,7 @@ proc plus-base {var root glob name dir desc} { if {$var} { if {[file exists $tcltkdir/$root/README]} { set f [open $tcltkdir/$root/README] + fconfigure $f -encoding utf-8 set d [read $f] close $f if {[regexp {This is the \w+ (\S+) source distribution} $d -> version]} { @@ -746,6 +752,7 @@ try { } trap {POSIX ENOENT} {} { set f [open [file join $pkgsDir $dir configure.ac]] } + fconfigure $f -encoding utf-8 foreach line [split [read $f] \n] { if {2 == [scan $line \ { AC_INIT ( [%[^]]] , [%[^]]] ) } n v]} { @@ -770,6 +777,7 @@ try { set packageDirNameMap {} if {$build_tcl} { set f [open $tcltkdir/$tcldir/pkgs/package.list.txt] + fconfigure $f -encoding utf-8 try { foreach line [split [read $f] \n] { if {[string trim $line] eq ""} continue diff --git a/tools/tsdPerf.c b/tools/tsdPerf.c index 7a599e0..4c96f28 100644 --- a/tools/tsdPerf.c +++ b/tools/tsdPerf.c @@ -1,6 +1,6 @@ #include <tcl.h> -extern DLLEXPORT Tcl_PackageInitProc Tsdperf_Init; +extern DLLEXPORT Tcl_LibraryInitProc Tsdperf_Init; static Tcl_ThreadDataKey key; diff --git a/unix/Makefile.in b/unix/Makefile.in index 00e29be..79dad02 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -209,7 +209,7 @@ TCL_LIB_FLAG = @TCL_LIB_FLAG@ #TCL_LIB_FLAG = -ltcl # support for embedded libraries on Darwin / Mac OS X -DYLIB_INSTALL_DIR = ${LIB_RUNTIME_DIR} +DYLIB_INSTALL_DIR = $(libdir) #-------------------------------------------------------------------------- # The information below is modified by the configure script when Makefile is @@ -268,6 +268,7 @@ TRACE_OPTS = VALGRIND = valgrind VALGRINDARGS = --tool=memcheck --num-callers=24 \ --leak-resolution=high --leak-check=yes --show-reachable=yes -v \ + --keep-debuginfo=yes \ --suppressions=$(TOOL_DIR)/valgrind_suppress #-------------------------------------------------------------------------- @@ -671,7 +672,8 @@ UNIX_SRCS = \ NOTIFY_SRCS = \ $(UNIX_DIR)/tclEpollNotfy.c \ $(UNIX_DIR)/tclKqueueNotfy.c \ - $(UNIX_DIR)/tclSelectNotfy.c + $(UNIX_DIR)/tclSelectNotfy.c \ + $(UNIX_DIR)/tclUnixNotfy.c DL_SRCS = \ $(UNIX_DIR)/tclLoadAix.c \ @@ -727,6 +729,7 @@ HOST_CC = @CC_FOR_BUILD@ HOST_EXEEXT = @EXEEXT_FOR_BUILD@ HOST_OBJEXT = @OBJEXT_FOR_BUILD@ ZIPFS_BUILD = @ZIPFS_BUILD@ +MACHER = @MACHER_PROG@ NATIVE_ZIP = @ZIP_PROG@ ZIP_PROG_OPTIONS = @ZIP_PROG_OPTIONS@ ZIP_PROG_VFSSEARCH = @ZIP_PROG_VFSSEARCH@ @@ -777,7 +780,7 @@ ${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} cp -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \ fi mv ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl - rm -rf ${TCL_VFS_PATH}/dde ${TCL_VFS_PATH}/reg + rm -rf ${TCL_VFS_PATH}/dde ${TCL_VFS_PATH}/registry @find ${TCL_VFS_ROOT} -type d -empty -delete @echo "creating ${TCL_ZIP_FILE} from ${TCL_VFS_PATH}" @(zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}' || \ @@ -792,7 +795,11 @@ ${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE} rm -f $@ @MAKE_LIB@ @if test "${ZIPFS_BUILD}" = "1" ; then \ + if test "x$(MACHER)" = "x" ; then \ cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \ + else $(MACHER) append ${LIB_FILE} ${TCL_ZIP_FILE} /tmp/macher_output; \ + mv /tmp/macher_output ${LIB_FILE}; chmod u+x ${LIB_FILE}; \ + fi; \ ${NATIVE_ZIP} -A ${LIB_FILE} \ || echo 'ignore zip-error by adjust sfx process (not executable?)'; \ fi @@ -819,7 +826,11 @@ ${TCL_EXE}: ${TCLSH_OBJS} ${TCL_LIB_FILE} ${TCL_STUB_LIB_FILE} ${TCL_ZIP_FILE} @TCL_BUILD_LIB_SPEC@ ${TCL_STUB_LIB_FILE} ${LIBS} @EXTRA_TCLSH_LIBS@ \ ${CC_SEARCH_FLAGS} -o ${TCL_EXE} @if test "${ZIPFS_BUILD}" = "2" ; then \ + if test "x$(MACHER)" = "x" ; then \ cat ${TCL_ZIP_FILE} >> ${TCL_EXE}; \ + else $(MACHER) append ${TCL_EXE} ${TCL_ZIP_FILE} /tmp/macher_output; \ + mv /tmp/macher_output ${TCL_EXE}; chmod u+x ${TCL_EXE}; \ + fi; \ ${NATIVE_ZIP} -A ${TCL_EXE} \ || echo 'ignore zip-error by adjust sfx process (not executable?)'; \ fi @@ -892,18 +903,13 @@ test-tcl: ${TCLTEST_EXE} $(SHELL_ENV) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) gdb-test: ${TCLTEST_EXE} - @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run - @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run - @echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run - $(GDB) ./${TCLTEST_EXE} --command=gdb.run - @rm gdb.run + $(SHELL_ENV) $(GDB) --args ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl \ + $(TESTFLAGS) -singleproc 1 lldb-test: ${TCLTEST_EXE} - @echo "settings set target.env-vars @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > lldb.run - @echo "settings set target.env-vars TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> lldb.run - $(LLDB) --source lldb.run ./${TCLTEST_EXE} -- $(TOP_DIR)/tests/all.tcl \ + $(SHELL_ENV) $(LLDB) -- ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl \ $(TESTFLAGS) -singleproc 1 - @rm lldb.run + # Useful target to launch a built tcltest with the proper path,... runtest: ${TCLTEST_EXE} @@ -936,6 +942,9 @@ shell: ${TCL_EXE} gdb: ${TCL_EXE} $(SHELL_ENV) $(GDB) ./${TCL_EXE} +lldb: ${TCL_EXE} + $(SHELL_ENV) $(LLDB) ./${TCL_EXE} + valgrind: ${TCL_EXE} ${TCLTEST_EXE} $(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} \ $(TOP_DIR)/tests/all.tcl -singleproc 1 -constraints valgrind \ @@ -1030,9 +1039,9 @@ install-libraries: libraries @for i in $(TOP_DIR)/library/cookiejar/*.gz; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done - @echo "Installing package http 2.10.0a1 as a Tcl Module" + @echo "Installing package http 2.10a1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \ - "$(MODULE_INSTALL_DIR)/8.6/http-2.10.0a1.tm" + "$(MODULE_INSTALL_DIR)/8.6/http-2.10a1.tm" @echo "Installing package opt 0.4.7" @for i in $(TOP_DIR)/library/opt/*.tcl; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ @@ -1514,7 +1523,6 @@ tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c $(CC) -c $(CC_SWITCHES) \ -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ - -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip \ $(GENERIC_DIR)/tclZipfs.c @@ -1761,13 +1769,13 @@ tclUnixFCmd.o: $(UNIX_DIR)/tclUnixFCmd.c tclUnixFile.o: $(UNIX_DIR)/tclUnixFile.c $(FSHDR) $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixFile.c -tclEpollNotfy.o: $(UNIX_DIR)/tclEpollNotfy.c +tclEpollNotfy.o: $(UNIX_DIR)/tclEpollNotfy.c $(UNIX_DIR)/tclUnixNotfy.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclEpollNotfy.c -tclKqueueNotfy.o: $(UNIX_DIR)/tclKqueueNotfy.c +tclKqueueNotfy.o: $(UNIX_DIR)/tclKqueueNotfy.c $(UNIX_DIR)/tclUnixNotfy.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclKqueueNotfy.c -tclSelectNotfy.o: $(UNIX_DIR)/tclSelectNotfy.c +tclSelectNotfy.o: $(UNIX_DIR)/tclSelectNotfy.c $(UNIX_DIR)/tclUnixNotfy.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclSelectNotfy.c tclUnixPipe.o: $(UNIX_DIR)/tclUnixPipe.c @@ -2209,7 +2217,7 @@ DISTROOT = /tmp/dist DISTNAME = tcl${VERSION}${PATCH_LEVEL} ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip DISTDIR = $(DISTROOT)/$(DISTNAME) -BUILTIN_PACKAGE_LIST = cookiejar http opt msgcat reg dde tcltest platform +BUILTIN_PACKAGE_LIST = cookiejar http opt msgcat registry dde tcltest platform $(UNIX_DIR)/configure: $(UNIX_DIR)/configure.ac $(UNIX_DIR)/tcl.m4 \ $(UNIX_DIR)/aclocal.m4 @@ -2256,7 +2264,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen mkdir $(DISTDIR)/library/$$i;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ done - cp -p $(TOP_DIR)/library/cookiejar/*.txt.gz $(DISTDIR)/library/cookiejar + cp -p $(TOP_DIR)/library/cookiejar/*.dat.gz $(DISTDIR)/library/cookiejar @mkdir $(DISTDIR)/library/encoding cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding @mkdir $(DISTDIR)/library/msgs @@ -2276,11 +2284,16 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen @( cd $(COMPAT_DIR)/zlib; find . -type f -print ) \ | ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \ | ( cd $(DISTDIR)/compat/zlib ; tar xfp - ) + @mkdir $(DISTDIR)/libtommath + @echo cp -r $(TOP_DIR)/libtommath $(DISTDIR)/libtommath + @( cd $(TOP_DIR)/libtommath; find . -type f -print ) \ + | ( cd $(TOP_DIR)/libtommath ; xargs tar cf - ) \ + | ( cd $(DISTDIR)/libtommath ; tar xfp - ) @mkdir $(DISTDIR)/tests cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ $(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \ - $(DISTDIR)/tests + $(TOP_DIR)/tests/auto-files.zip $(DISTDIR)/tests @mkdir $(DISTDIR)/tests/auto0 for i in auto1 auto2 ; \ do \ @@ -2329,8 +2342,6 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen cp -p $(TOOL_DIR)/README $(TOOL_DIR)/*.c $(TOOL_DIR)/*.svg \ $(TOOL_DIR)/*.tcl $(TOOL_DIR)/*.bmp \ $(TOOL_DIR)/valgrind_suppress $(DISTDIR)/tools - @mkdir $(DISTDIR)/libtommath - cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h $(DISTDIR)/libtommath @mkdir $(DISTDIR)/pkgs cp -p $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs cp -p $(TOP_DIR)/pkgs/package.list.txt $(DISTDIR)/pkgs diff --git a/unix/configure b/unix/configure index 50a035b..dbfb800 100755 --- a/unix/configure +++ b/unix/configure @@ -698,6 +698,7 @@ ZIP_INSTALL_OBJS ZIP_PROG_VFSSEARCH ZIP_PROG_OPTIONS ZIP_PROG +MACHER_PROG EXEEXT_FOR_BUILD CC_FOR_BUILD DTRACE @@ -7203,12 +7204,12 @@ then : AIX-*) ;; BSD/OS*) ;; CYGWIN_*|MINGW32_*|MSYS_*) ;; - HP_UX*) ;; + HP-UX*) ;; Darwin-*) ;; IRIX*) ;; Linux*|GNU*) ;; - NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;; - OSF1-V*) ;; + NetBSD-*|OpenBSD-*) ;; + OSF1-*) ;; SCO_SV-3.2*) ;; *) SHLIB_CFLAGS="-fPIC" ;; esac @@ -11097,11 +11098,41 @@ printf "%s\n" "$bfd_cv_build_exeext" >&6; } # Find a native zip implementation # + MACHER_PROG="" ZIP_PROG="" ZIP_PROG_OPTIONS="" ZIP_PROG_VFSSEARCH="" ZIP_INSTALL_OBJS="" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for macher" >&5 +printf %s "checking for macher... " >&6; } + if test ${ac_cv_path_macher+y} +then : + printf %s "(cached) " >&6 +else $as_nop + + search_path=`echo ${PATH} | sed -e 's/:/ /g'` + for dir in $search_path ; do + for j in `ls -r $dir/macher 2> /dev/null` \ + `ls -r $dir/macher 2> /dev/null` ; do + if test x"$ac_cv_path_macher" = x ; then + if test -f "$j" ; then + ac_cv_path_macher=$j + break + fi + fi + done + done + +fi + + if test -f "$ac_cv_path_macher" ; then + MACHER_PROG="$ac_cv_path_macher" + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MACHER_PROG" >&5 +printf "%s\n" "$MACHER_PROG" >&6; } + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found macher in environment" >&5 +printf "%s\n" "Found macher in environment" >&6; } + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for zip" >&5 printf %s "checking for zip... " >&6; } if test ${ac_cv_path_zip+y} @@ -11148,11 +11179,12 @@ printf "%s\n" "No zip found on PATH. Building minizip" >&6; } - ZIPFS_BUILD=1 - TCL_ZIP_FILE=libtcl${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}${TCL_PATCH_LEVEL}.zip + + ZIPFS_BUILD=1 + TCL_ZIP_FILE=libtcl${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}${TCL_PATCH_LEVEL}.zip else - ZIPFS_BUILD=0 - TCL_ZIP_FILE= + ZIPFS_BUILD=0 + TCL_ZIP_FILE= fi # Do checking message here to not mess up interleaved configure output { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5 diff --git a/unix/configure.ac b/unix/configure.ac index edf5f6d..067fc70 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -887,11 +887,11 @@ if test "$tcl_ok" = "yes" -a "x$enable_framework" != "xyes"; then # Find a native zip implementation # SC_ZIPFS_SUPPORT - ZIPFS_BUILD=1 - TCL_ZIP_FILE=libtcl${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}${TCL_PATCH_LEVEL}.zip + ZIPFS_BUILD=1 + TCL_ZIP_FILE=libtcl${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}${TCL_PATCH_LEVEL}.zip else - ZIPFS_BUILD=0 - TCL_ZIP_FILE= + ZIPFS_BUILD=0 + TCL_ZIP_FILE= fi # Do checking message here to not mess up interleaved configure output AC_MSG_CHECKING([for building with zipfs]) diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index ff1cf1f..5aa48a5 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -84,10 +84,13 @@ static TclOOStubs stubsCopy = { NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, - NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL +#ifdef Tcl_MethodIsPrivate + ,NULL +#endif }; -extern DLLEXPORT int +DLLEXPORT int Pkgooa_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index 0ab3e23..a822541 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -21,6 +21,7 @@ static int PkguaEqObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int PkguaQuoteObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static void CommandDeleted(ClientData clientData); /* * In the following hash table we are going to store a struct that holds all @@ -30,23 +31,32 @@ static int PkguaQuoteObjCmd(ClientData clientData, * need to keep the various command tokens we have registered, as they are the * only safe way to unregister our registered commands, even if they have been * renamed. - * - * Note that this code is utterly single-threaded. */ -static Tcl_HashTable interpTokenMap; -static int interpTokenMapInitialised = 0; +typedef struct ThreadSpecificData { + int interpTokenMapInitialised; + Tcl_HashTable interpTokenMap; +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; #define MAX_REGISTERED_COMMANDS 2 +static void +CommandDeleted(ClientData clientData) +{ + Tcl_Command *cmdToken = (Tcl_Command *)clientData; + *cmdToken = NULL; +} static void PkguaInitTokensHashTable(void) { - if (interpTokenMapInitialised) { + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); + + if (tsdPtr->interpTokenMapInitialised) { return; } - Tcl_InitHashTable(&interpTokenMap, TCL_ONE_WORD_KEYS); - interpTokenMapInitialised = 1; + Tcl_InitHashTable(&tsdPtr->interpTokenMap, TCL_ONE_WORD_KEYS); + tsdPtr->interpTokenMapInitialised = 1; } static void @@ -54,12 +64,13 @@ PkguaFreeTokensHashTable(void) { Tcl_HashSearch search; Tcl_HashEntry *entryPtr; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); - for (entryPtr = Tcl_FirstHashEntry(&interpTokenMap, &search); + for (entryPtr = Tcl_FirstHashEntry(&tsdPtr->interpTokenMap, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); } - interpTokenMapInitialised = 0; + tsdPtr->interpTokenMapInitialised = 0; } static Tcl_Command * @@ -68,13 +79,14 @@ PkguaInterpToTokens( { int newEntry; Tcl_Command *cmdTokens; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); Tcl_HashEntry *entryPtr = - Tcl_CreateHashEntry(&interpTokenMap, interp, &newEntry); + Tcl_CreateHashEntry(&tsdPtr->interpTokenMap, (char *) interp, &newEntry); if (newEntry) { cmdTokens = (Tcl_Command *) - Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS+1)); - for (newEntry=0 ; newEntry<MAX_REGISTERED_COMMANDS+1 ; ++newEntry) { + Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS)); + for (newEntry=0 ; newEntry<MAX_REGISTERED_COMMANDS ; ++newEntry) { cmdTokens[newEntry] = NULL; } Tcl_SetHashValue(entryPtr, cmdTokens); @@ -88,8 +100,9 @@ static void PkguaDeleteTokens( Tcl_Interp *interp) { + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); Tcl_HashEntry *entryPtr = - Tcl_FindHashEntry(&interpTokenMap, interp); + Tcl_FindHashEntry(&tsdPtr->interpTokenMap, (char *) interp); if (entryPtr) { Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); @@ -199,7 +212,7 @@ Pkgua_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ { - int code, cmdIndex = 0; + int code; Tcl_Command *cmdTokens; if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { @@ -207,7 +220,7 @@ Pkgua_Init( } /* - * Initialise our Hash table, where we store the registered command tokens + * Initialize our Hash table, where we store the registered command tokens * for each interpreter. */ @@ -221,12 +234,12 @@ Pkgua_Init( Tcl_SetVar2(interp, "::pkgua_loaded", NULL, ".", TCL_APPEND_VALUE); cmdTokens = PkguaInterpToTokens(interp); - cmdTokens[cmdIndex++] = - Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, NULL, - NULL); - cmdTokens[cmdIndex++] = + cmdTokens[0] = + Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, &cmdTokens[0], + CommandDeleted); + cmdTokens[1] = Tcl_CreateObjCommand(interp, "pkgua_quote", PkguaQuoteObjCmd, - NULL, NULL); + &cmdTokens[1], CommandDeleted); return TCL_OK; } diff --git a/unix/tcl.m4 b/unix/tcl.m4 index a8911f8..9cfec6b 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1782,12 +1782,12 @@ dnl # preprocessing tests use only CPPFLAGS. AIX-*) ;; BSD/OS*) ;; CYGWIN_*|MINGW32_*|MSYS_*) ;; - HP_UX*) ;; + HP-UX*) ;; Darwin-*) ;; IRIX*) ;; Linux*|GNU*) ;; - NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;; - OSF1-V*) ;; + NetBSD-*|OpenBSD-*) ;; + OSF1-*) ;; SCO_SV-3.2*) ;; *) SHLIB_CFLAGS="-fPIC" ;; esac]) @@ -3011,18 +3011,40 @@ AC_DEFUN([AX_CC_FOR_BUILD],[# Put a plausible default for CC_FOR_BUILD in Makefi # # Results: # Substitutes the following vars: -# ZIP_PROG +# MACHER_PROG +# ZIP_PROG # ZIP_PROG_OPTIONS # ZIP_PROG_VFSSEARCH # ZIP_INSTALL_OBJS #------------------------------------------------------------------------ AC_DEFUN([SC_ZIPFS_SUPPORT], [ + MACHER_PROG="" ZIP_PROG="" ZIP_PROG_OPTIONS="" ZIP_PROG_VFSSEARCH="" ZIP_INSTALL_OBJS="" + AC_MSG_CHECKING([for macher]) + AC_CACHE_VAL(ac_cv_path_macher, [ + search_path=`echo ${PATH} | sed -e 's/:/ /g'` + for dir in $search_path ; do + for j in `ls -r $dir/macher 2> /dev/null` \ + `ls -r $dir/macher 2> /dev/null` ; do + if test x"$ac_cv_path_macher" = x ; then + if test -f "$j" ; then + ac_cv_path_macher=$j + break + fi + fi + done + done + ]) + if test -f "$ac_cv_path_macher" ; then + MACHER_PROG="$ac_cv_path_macher" + AC_MSG_RESULT([$MACHER_PROG]) + AC_MSG_RESULT([Found macher in environment]) + fi AC_MSG_CHECKING([for zip]) AC_CACHE_VAL(ac_cv_path_zip, [ search_path=`echo ${PATH} | sed -e 's/:/ /g'` @@ -3054,6 +3076,7 @@ AC_DEFUN([SC_ZIPFS_SUPPORT], [ ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}" AC_MSG_RESULT([No zip found on PATH. Building minizip]) fi + AC_SUBST(MACHER_PROG) AC_SUBST(ZIP_PROG) AC_SUBST(ZIP_PROG_OPTIONS) AC_SUBST(ZIP_PROG_VFSSEARCH) diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 3587f35..f3caae7 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -15,15 +15,19 @@ #undef BUILD_tcl #undef STATIC_BUILD #include "tcl.h" +#if TCL_MAJOR_VERSION < 9 && TCL_MINOR_VERSION < 7 +# define Tcl_LibraryInitProc Tcl_PackageInitProc +# define Tcl_StaticLibrary Tcl_StaticPackage +#endif #ifdef TCL_TEST -extern Tcl_PackageInitProc Tcltest_Init; -extern Tcl_PackageInitProc Tcltest_SafeInit; +extern Tcl_LibraryInitProc Tcltest_Init; +extern Tcl_LibraryInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ #ifdef TCL_XT_TEST extern void XtToolkitInitialize(void); -extern Tcl_PackageInitProc Tclxttest_Init; +extern Tcl_LibraryInitProc Tclxttest_Init; #endif /* TCL_XT_TEST */ /* @@ -79,7 +83,8 @@ main( #ifdef TCL_LOCAL_MAIN_HOOK TCL_LOCAL_MAIN_HOOK(&argc, &argv); -#else +#elif !defined(_WIN32) || defined(UNICODE) + /* This doesn't work on Windows without UNICODE */ TclZipfs_AppHook(&argc, &argv); #endif @@ -124,7 +129,7 @@ Tcl_AppInit( if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); + Tcl_StaticLibrary(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); #endif /* TCL_TEST */ /* diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c index 3a99e6d..23c88b2 100644 --- a/unix/tclEpollNotfy.c +++ b/unix/tclEpollNotfy.c @@ -97,7 +97,7 @@ typedef struct ThreadSpecificData { * that are ready for I/O. */ pthread_mutex_t notifierMutex; /* Mutex protecting notifier termination in - * PlatformEventsFinalize. */ + * TclpFinalizeNotifier. */ #ifdef HAVE_EVENTFD int triggerEventFd; /* eventfd(2) used by other threads to wake * up this thread for inter-thread IPC. */ @@ -121,14 +121,13 @@ static Tcl_ThreadDataKey dataKey; static void PlatformEventsControl(FileHandler *filePtr, ThreadSpecificData *tsdPtr, int op, int isNew); -static void PlatformEventsFinalize(void); static void PlatformEventsInit(void); static int PlatformEventsTranslate(struct epoll_event *event); static int PlatformEventsWait(struct epoll_event *events, size_t numEvents, struct timeval *timePtr); - + /* - * Incorporate the base notifier API. + * Incorporate the base notifier implementation. */ #include "tclUnixNotfy.c" @@ -136,7 +135,7 @@ static int PlatformEventsWait(struct epoll_event *events, /* *---------------------------------------------------------------------- * - * Tcl_InitNotifier -- + * TclpInitNotifier -- * * Initializes the platform specific notifier state. * @@ -144,54 +143,21 @@ static int PlatformEventsWait(struct epoll_event *events, * Returns a handle to the notifier state for this thread. * * Side effects: - * If no initNotifierProc notifier hook exists, PlatformEventsInit - * is called. + * If no initNotifierProc notifier hook exists, PlatformEventsInit is + * called. * *---------------------------------------------------------------------- */ ClientData -Tcl_InitNotifier(void) +TclpInitNotifier(void) { - if (tclNotifierHooks.initNotifierProc) { - return tclNotifierHooks.initNotifierProc(); - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - PlatformEventsInit(); - return tsdPtr; - } + PlatformEventsInit(); + return tsdPtr; } -/* - *---------------------------------------------------------------------- - * - * Tcl_FinalizeNotifier -- - * - * This function is called to cleanup the notifier state before a thread - * is terminated. - * - * Results: - * None. - * - * Side effects: - * If no finalizeNotifierProc notifier hook exists, PlatformEvents- - * Finalize is called. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FinalizeNotifier( - ClientData clientData) -{ - if (tclNotifierHooks.finalizeNotifierProc) { - tclNotifierHooks.finalizeNotifierProc(clientData); - return; - } else { - PlatformEventsFinalize(); - } -} /* *---------------------------------------------------------------------- @@ -221,7 +187,7 @@ Tcl_FinalizeNotifier( *---------------------------------------------------------------------- */ -void +static void PlatformEventsControl( FileHandler *filePtr, ThreadSpecificData *tsdPtr, @@ -240,7 +206,8 @@ PlatformEventsControl( newEvent.events |= EPOLLOUT; } if (isNew) { - newPedPtr = (struct PlatformEventData *)ckalloc(sizeof(struct PlatformEventData)); + newPedPtr = (struct PlatformEventData *) + ckalloc(sizeof(struct PlatformEventData)); newPedPtr->filePtr = filePtr; newPedPtr->tsdPtr = tsdPtr; filePtr->pedPtr = newPedPtr; @@ -249,7 +216,7 @@ PlatformEventsControl( /* * N.B. As discussed in Tcl_WaitForEvent(), epoll(7) does not support - * regular files (S_IFREG.) Therefore, filePtr is in these cases simply + * regular files (S_IFREG). Therefore, filePtr is in these cases simply * added or deleted from the list of FileHandlers associated with regular * files belonging to tsdPtr. */ @@ -277,7 +244,7 @@ PlatformEventsControl( /* *---------------------------------------------------------------------- * - * PlatformEventsFinalize -- + * TclpFinalizeNotifier -- * * This function closes the eventfd and the epoll file descriptor and * frees the epoll_event structs owned by the thread of the caller. The @@ -299,8 +266,8 @@ PlatformEventsControl( */ void -PlatformEventsFinalize( - void) +TclpFinalizeNotifier( + TCL_UNUSED(ClientData)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -362,7 +329,7 @@ PlatformEventsFinalize( *---------------------------------------------------------------------- */ -void +static void PlatformEventsInit(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -372,7 +339,7 @@ PlatformEventsInit(void) if (errno) { Tcl_Panic("Tcl_InitNotifier: %s", "could not create mutex"); } - filePtr = (FileHandler *)ckalloc(sizeof(FileHandler)); + filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); #ifdef HAVE_EVENTFD tsdPtr->triggerEventFd = eventfd(0, EFD_CLOEXEC | EFD_NONBLOCK); if (tsdPtr->triggerEventFd <= 0) { @@ -393,7 +360,7 @@ PlatformEventsInit(void) PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1); if (!tsdPtr->readyEvents) { tsdPtr->maxReadyEvents = 512; - tsdPtr->readyEvents = (struct epoll_event *)ckalloc( + tsdPtr->readyEvents = (struct epoll_event *) ckalloc( tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0])); } LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr); @@ -416,7 +383,7 @@ PlatformEventsInit(void) *---------------------------------------------------------------------- */ -int +static int PlatformEventsTranslate( struct epoll_event *eventPtr) { @@ -457,7 +424,7 @@ PlatformEventsTranslate( *---------------------------------------------------------------------- */ -int +static int PlatformEventsWait( struct epoll_event *events, size_t numEvents, @@ -480,9 +447,9 @@ PlatformEventsWait( } else if (!timePtr->tv_sec && !timePtr->tv_usec) { timeout = 0; } else { - timeout = (int)timePtr->tv_sec * 1000; + timeout = (int) timePtr->tv_sec * 1000; if (timePtr->tv_usec) { - timeout += (int)timePtr->tv_usec / 1000; + timeout += (int) timePtr->tv_usec / 1000; } } @@ -493,7 +460,7 @@ PlatformEventsWait( */ gettimeofday(&tv0, NULL); - numFound = epoll_wait(tsdPtr->eventsFd, events, (int)numEvents, timeout); + numFound = epoll_wait(tsdPtr->eventsFd, events, (int) numEvents, timeout); gettimeofday(&tv1, NULL); if (timePtr && (timePtr->tv_sec && timePtr->tv_usec)) { timersub(&tv1, &tv0, &tv_delta); @@ -510,7 +477,7 @@ PlatformEventsWait( /* *---------------------------------------------------------------------- * - * Tcl_CreateFileHandler -- + * TclpCreateFileHandler -- * * This function registers a file handler with the epoll notifier of the * thread of the caller. @@ -526,7 +493,7 @@ PlatformEventsWait( */ void -Tcl_CreateFileHandler( +TclpCreateFileHandler( int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates @@ -536,44 +503,29 @@ Tcl_CreateFileHandler( * event. */ ClientData clientData) /* Arbitrary data to pass to proc. */ { - int isNew; - - if (tclNotifierHooks.createFileHandlerProc) { - tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); - return; - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FileHandler *filePtr; - - for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd == fd) { - break; - } - } - if (filePtr == NULL) { - filePtr = (FileHandler *)ckalloc(sizeof(FileHandler)); - filePtr->fd = fd; - filePtr->readyMask = 0; - filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; - tsdPtr->firstFileHandlerPtr = filePtr; - isNew = 1; - } else { - isNew = 0; - } - filePtr->proc = proc; - filePtr->clientData = clientData; - filePtr->mask = mask; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); + int isNew = (filePtr == NULL); - PlatformEventsControl(filePtr, tsdPtr, - isNew ? EPOLL_CTL_ADD : EPOLL_CTL_MOD, isNew); + if (isNew) { + filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr->fd = fd; + filePtr->readyMask = 0; + filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; + tsdPtr->firstFileHandlerPtr = filePtr; } + filePtr->proc = proc; + filePtr->clientData = clientData; + filePtr->mask = mask; + + PlatformEventsControl(filePtr, tsdPtr, + isNew ? EPOLL_CTL_ADD : EPOLL_CTL_MOD, isNew); } /* *---------------------------------------------------------------------- * - * Tcl_DeleteFileHandler -- + * TclpDeleteFileHandler -- * * Cancel a previously-arranged callback arrangement for a file on the * epoll file descriptor of the thread of the caller. @@ -591,60 +543,50 @@ Tcl_CreateFileHandler( */ void -Tcl_DeleteFileHandler( +TclpDeleteFileHandler( int fd) /* Stream id for which to remove callback * function. */ { - if (tclNotifierHooks.deleteFileHandlerProc) { - tclNotifierHooks.deleteFileHandlerProc(fd); - return; - } else { - FileHandler *filePtr, *prevPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileHandler *filePtr, *prevPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - /* - * Find the entry for the given file (and return if there isn't one). - */ + /* + * Find the entry for the given file (and return if there isn't one). + */ - for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { - if (filePtr == NULL) { - return; - } - if (filePtr->fd == fd) { - break; - } - } + filePtr = LookUpFileHandler(tsdPtr, fd, &prevPtr); + if (filePtr == NULL) { + return; + } - /* - * Update the check masks for this file. - */ + /* + * Update the check masks for this file. + */ - PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_DEL, 0); - if (filePtr->pedPtr) { - ckfree(filePtr->pedPtr); - } + PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_DEL, 0); + if (filePtr->pedPtr) { + ckfree(filePtr->pedPtr); + } - /* - * Clean up information in the callback record. - */ + /* + * Clean up information in the callback record. + */ - if (prevPtr == NULL) { - tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; - } else { - prevPtr->nextPtr = filePtr->nextPtr; - } - ckfree(filePtr); + if (prevPtr == NULL) { + tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; + } else { + prevPtr->nextPtr = filePtr->nextPtr; } + ckfree(filePtr); } /* *---------------------------------------------------------------------- * - * Tcl_WaitForEvent -- + * TclpWaitForEvent -- * * This function is called by Tcl_DoOneEvent to wait for new events on - * the message queue. If the block time is 0, then Tcl_WaitForEvent just + * the message queue. If the block time is 0, then TclpWaitForEvent just * polls without blocking. * * The waiting logic is implemented in PlatformEventsWait. @@ -660,172 +602,165 @@ Tcl_DeleteFileHandler( */ int -Tcl_WaitForEvent( +TclpWaitForEvent( const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { - if (tclNotifierHooks.waitForEventProc) { - return tclNotifierHooks.waitForEventProc(timePtr); - } else { - FileHandler *filePtr; - int mask; - Tcl_Time vTime; - /* - * Impl. notes: timeout & timeoutPtr are used if, and only if threads - * are not enabled. They are the arguments for the regular epoll_wait() - * used when the core is not thread-enabled. - */ + FileHandler *filePtr; + Tcl_Time vTime; + struct timeval timeout, *timeoutPtr; + /* Impl. notes: timeout & timeoutPtr are used + * if, and only if threads are not enabled. + * They are the arguments for the regular + * epoll_wait() used when the core is not + * thread-enabled. */ + int mask, numFound, numEvent; + struct PlatformEventData *pedPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + int numQueued; + ssize_t i; - struct timeval timeout, *timeoutPtr; - int numFound, numEvent; - struct PlatformEventData *pedPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - int numQueued; - ssize_t i; + /* + * Set up the timeout structure. Note that if there are no events to check + * for, we return with a negative result rather than blocking forever. + */ + if (timePtr != NULL) { /* - * Set up the timeout structure. Note that if there are no events to - * check for, we return with a negative result rather than blocking - * forever. + * TIP #233 (Virtualized Time). Is virtual time in effect? And do we + * actually have something to scale? If yes to both then we call the + * handler to do this scaling. */ - if (timePtr != NULL) { - /* - * TIP #233 (Virtualized Time). Is virtual time in effect? And do - * we actually have something to scale? If yes to both then we - * call the handler to do this scaling. - */ - - if (timePtr->sec != 0 || timePtr->usec != 0) { - vTime = *timePtr; - tclScaleTimeProcPtr(&vTime, tclTimeClientData); - timePtr = &vTime; - } - timeout.tv_sec = timePtr->sec; - timeout.tv_usec = timePtr->usec; - timeoutPtr = &timeout; - } else { - timeoutPtr = NULL; + if (timePtr->sec != 0 || timePtr->usec != 0) { + vTime = *timePtr; + TclScaleTime(&vTime); + timePtr = &vTime; } + timeout.tv_sec = timePtr->sec; + timeout.tv_usec = timePtr->usec; + timeoutPtr = &timeout; + } else { + timeoutPtr = NULL; + } - /* - * Walk the list of FileHandlers associated with regular files - * (S_IFREG) belonging to tsdPtr, queue Tcl events for them, and - * update their mask of events of interest. - * - * As epoll(7) does not support regular files, the behaviour of - * {select,poll}(2) is simply simulated here: fds associated with - * regular files are added to this list by PlatformEventsControl() and - * processed here before calling (and possibly blocking) on - * PlatformEventsWait(). - */ - - numQueued = 0; - LIST_FOREACH(filePtr, &tsdPtr->firstReadyFileHandlerPtr, readyNode) { - mask = 0; - if (filePtr->mask & TCL_READABLE) { - mask |= TCL_READABLE; - } - if (filePtr->mask & TCL_WRITABLE) { - mask |= TCL_WRITABLE; - } - - /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. - */ - - if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) - ckalloc(sizeof(FileHandlerEvent)); + /* + * Walk the list of FileHandlers associated with regular files (S_IFREG) + * belonging to tsdPtr, queue Tcl events for them, and update their mask + * of events of interest. + * + * As epoll(7) does not support regular files, the behaviour of + * {select,poll}(2) is simply simulated here: fds associated with regular + * files are added to this list by PlatformEventsControl() and processed + * here before calling (and possibly blocking) on PlatformEventsWait(). + */ - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - numQueued++; - } - filePtr->readyMask = mask; + numQueued = 0; + LIST_FOREACH(filePtr, &tsdPtr->firstReadyFileHandlerPtr, readyNode) { + mask = 0; + if (filePtr->mask & TCL_READABLE) { + mask |= TCL_READABLE; + } + if (filePtr->mask & TCL_WRITABLE) { + mask |= TCL_WRITABLE; } /* - * If any events were queued in the above loop, force - * PlatformEventsWait() to poll as there already are events that need - * to be processed at this point. + * Don't bother to queue an event if the mask was previously non-zero + * since an event must still be on the queue. */ - if (numQueued) { - timeout.tv_sec = 0; - timeout.tv_usec = 0; - timeoutPtr = &timeout; + if (filePtr->readyMask == 0) { + FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) + ckalloc(sizeof(FileHandlerEvent)); + + fileEvPtr->header.proc = FileHandlerEventProc; + fileEvPtr->fd = filePtr->fd; + Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); + numQueued++; } + filePtr->readyMask = mask; + } - /* - * Wait or poll for new events, queue Tcl events for the FileHandlers - * corresponding to them, and update the FileHandlers' mask of events - * of interest registered by the last call to Tcl_CreateFileHandler(). - * - * Events for the eventfd(2)/trigger pipe are processed here in order - * to facilitate inter-thread IPC. If another thread intends to wake - * up this thread whilst it's blocking on PlatformEventsWait(), it - * write(2)s to the eventfd(2)/trigger pipe (see Tcl_AlertNotifier(),) - * which in turn will cause PlatformEventsWait() to return - * immediately. - */ + /* + * If any events were queued in the above loop, force PlatformEventsWait() + * to poll as there already are events that need to be processed at this + * point. + */ + + if (numQueued) { + timeout.tv_sec = 0; + timeout.tv_usec = 0; + timeoutPtr = &timeout; + } + + /* + * Wait or poll for new events, queue Tcl events for the FileHandlers + * corresponding to them, and update the FileHandlers' mask of events of + * interest registered by the last call to Tcl_CreateFileHandler(). + * + * Events for the eventfd(2)/trigger pipe are processed here in order to + * facilitate inter-thread IPC. If another thread intends to wake up this + * thread whilst it's blocking on PlatformEventsWait(), it write(2)s to + * the eventfd(2)/trigger pipe (see Tcl_AlertNotifier(),) which in turn + * will cause PlatformEventsWait() to return immediately. + */ - numFound = PlatformEventsWait(tsdPtr->readyEvents, - tsdPtr->maxReadyEvents, timeoutPtr); - for (numEvent = 0; numEvent < numFound; numEvent++) { - pedPtr = (struct PlatformEventData*)tsdPtr->readyEvents[numEvent].data.ptr; - filePtr = pedPtr->filePtr; - mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]); + numFound = PlatformEventsWait(tsdPtr->readyEvents, + tsdPtr->maxReadyEvents, timeoutPtr); + for (numEvent = 0; numEvent < numFound; numEvent++) { + pedPtr = (struct PlatformEventData *) + tsdPtr->readyEvents[numEvent].data.ptr; + filePtr = pedPtr->filePtr; + mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]); #ifdef HAVE_EVENTFD - if (filePtr->fd == tsdPtr->triggerEventFd) { - uint64_t eventFdVal; - i = read(tsdPtr->triggerEventFd, &eventFdVal, - sizeof(eventFdVal)); - if ((i != sizeof(eventFdVal)) && (errno != EAGAIN)) { - Tcl_Panic( - "Tcl_WaitForEvent: read from %p->triggerEventFd: %s", - (void *) tsdPtr, strerror(errno)); - } - continue; + if (filePtr->fd == tsdPtr->triggerEventFd) { + uint64_t eventFdVal; + + i = read(tsdPtr->triggerEventFd, &eventFdVal, sizeof(eventFdVal)); + if ((i != sizeof(eventFdVal)) && (errno != EAGAIN)) { + Tcl_Panic("%s: read from %p->triggerEventFd: %s", + "Tcl_WaitForEvent", (void *) tsdPtr, strerror(errno)); } + continue; + } #else /* !HAVE_EVENTFD */ - if (filePtr->fd == tsdPtr->triggerPipe[0]) { - char triggerPipeVal; - i = read(tsdPtr->triggerPipe[0], &triggerPipeVal, - sizeof(triggerPipeVal)); - if ((i != sizeof(triggerPipeVal)) && (errno != EAGAIN)) { - Tcl_Panic( - "Tcl_WaitForEvent: read from %p->triggerPipe[0]: %s", - (void *) tsdPtr, strerror(errno)); - } - continue; + if (filePtr->fd == tsdPtr->triggerPipe[0]) { + char triggerPipeVal; + + i = read(tsdPtr->triggerPipe[0], &triggerPipeVal, + sizeof(triggerPipeVal)); + if ((i != sizeof(triggerPipeVal)) && (errno != EAGAIN)) { + Tcl_Panic("%s: read from %p->triggerPipe[0]: %s", + "Tcl_WaitForEvent", (void *) tsdPtr, strerror(errno)); } + continue; + } #endif /* HAVE_EVENTFD */ - if (!mask) { - continue; - } + if (!mask) { + continue; + } - /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. - */ + /* + * Don't bother to queue an event if the mask was previously non-zero + * since an event must still be on the queue. + */ - if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) - ckalloc(sizeof(FileHandlerEvent)); + if (filePtr->readyMask == 0) { + FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) + ckalloc(sizeof(FileHandlerEvent)); - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - } - filePtr->readyMask = mask; + fileEvPtr->header.proc = FileHandlerEventProc; + fileEvPtr->fd = filePtr->fd; + Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); } - return 0; + filePtr->readyMask = mask; } + return 0; } #endif /* NOTIFIER_EPOLL && TCL_THREADS */ +#else +TCL_MAC_EMPTY_FILE(unix_tclEpollNotfy_c) #endif /* !HAVE_COREFOUNDATION */ /* diff --git a/unix/tclKqueueNotfy.c b/unix/tclKqueueNotfy.c index 2f1d8e6..ab3732d 100644 --- a/unix/tclKqueueNotfy.c +++ b/unix/tclKqueueNotfy.c @@ -31,7 +31,8 @@ struct PlatformEventData; typedef struct FileHandler { - int fd; + int fd; /* File descriptor that this is describing a + * handler for. */ int mask; /* Mask of desired events: TCL_READABLE, * etc. */ int readyMask; /* Mask of events that have been seen since @@ -93,7 +94,7 @@ typedef struct ThreadSpecificData { * that are ready for I/O. */ pthread_mutex_t notifierMutex; /* Mutex protecting notifier termination in - * PlatformEventsFinalize. */ + * TclpFinalizeNotifier. */ int triggerPipe[2]; /* pipe(2) used by other threads to wake * up this thread for inter-thread IPC. */ int eventsFd; /* kqueue(2) file descriptor used to wait for @@ -111,73 +112,15 @@ static Tcl_ThreadDataKey dataKey; static void PlatformEventsControl(FileHandler *filePtr, ThreadSpecificData *tsdPtr, int op, int isNew); -static void PlatformEventsFinalize(void); -static void PlatformEventsInit(void); static int PlatformEventsTranslate(struct kevent *eventPtr); static int PlatformEventsWait(struct kevent *events, size_t numEvents, struct timeval *timePtr); - -#include "tclUnixNotfy.c" - -/* - *---------------------------------------------------------------------- - * - * Tcl_InitNotifier -- - * - * Initializes the platform specific notifier state. - * - * Results: - * Returns a handle to the notifier state for this thread. - * - * Side effects: - * If no initNotifierProc notifier hook exists, PlatformEventsInit - * is called. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_InitNotifier(void) -{ - if (tclNotifierHooks.initNotifierProc) { - return tclNotifierHooks.initNotifierProc(); - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - PlatformEventsInit(); - return tsdPtr; - } -} /* - *---------------------------------------------------------------------- - * - * Tcl_FinalizeNotifier -- - * - * This function is called to cleanup the notifier state before a thread - * is terminated. - * - * Results: - * None. - * - * Side effects: - * If no finalizeNotifierProc notifier hook exists, PlatformEvents- - * Finalize is called. - * - *---------------------------------------------------------------------- + * Incorporate the base notifier implementation. */ -void -Tcl_FinalizeNotifier( - ClientData clientData) -{ - if (tclNotifierHooks.finalizeNotifierProc) { - tclNotifierHooks.finalizeNotifierProc(clientData); - return; - } else { - PlatformEventsFinalize(); - } -} +#include "tclUnixNotfy.c" /* *---------------------------------------------------------------------- @@ -209,7 +152,7 @@ Tcl_FinalizeNotifier( *---------------------------------------------------------------------- */ -void +static void PlatformEventsControl( FileHandler *filePtr, ThreadSpecificData *tsdPtr, @@ -222,7 +165,8 @@ PlatformEventsControl( struct stat fdStat; if (isNew) { - newPedPtr = (struct PlatformEventData *)ckalloc(sizeof(struct PlatformEventData)); + newPedPtr = (struct PlatformEventData *) + ckalloc(sizeof(struct PlatformEventData)); newPedPtr->filePtr = filePtr; newPedPtr->tsdPtr = tsdPtr; filePtr->pedPtr = newPedPtr; @@ -257,12 +201,12 @@ PlatformEventsControl( switch (op) { case EV_ADD: if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) { - EV_SET(&changeList[numChanges], (uintptr_t)filePtr->fd, + EV_SET(&changeList[numChanges], (uintptr_t) filePtr->fd, EVFILT_READ, op, 0, 0, filePtr->pedPtr); numChanges++; } if (filePtr->mask & TCL_WRITABLE) { - EV_SET(&changeList[numChanges], (uintptr_t)filePtr->fd, + EV_SET(&changeList[numChanges], (uintptr_t) filePtr->fd, EVFILT_WRITE, op, 0, 0, filePtr->pedPtr); numChanges++; } @@ -284,13 +228,13 @@ PlatformEventsControl( * As one of these calls can fail, two separate kevent(2) calls are * made for EVFILT_{READ,WRITE}. */ - EV_SET(&changeList[0], (uintptr_t)filePtr->fd, EVFILT_READ, op, 0, 0, + EV_SET(&changeList[0], (uintptr_t) filePtr->fd, EVFILT_READ, op, 0, 0, NULL); if ((kevent(tsdPtr->eventsFd, changeList, 1, NULL, 0, NULL) == -1) && (errno != ENOENT)) { Tcl_Panic("kevent: %s", strerror(errno)); } - EV_SET(&changeList[0], (uintptr_t)filePtr->fd, EVFILT_WRITE, op, 0, 0, + EV_SET(&changeList[0], (uintptr_t) filePtr->fd, EVFILT_WRITE, op, 0, 0, NULL); if ((kevent(tsdPtr->eventsFd, changeList, 1, NULL, 0, NULL) == -1) && (errno != ENOENT)) { @@ -303,7 +247,7 @@ PlatformEventsControl( /* *---------------------------------------------------------------------- * - * PlatformEventsFinalize -- + * TclpFinalizeNotifier -- * * This function closes the pipe and the kqueue file descriptors and * frees the kevent structs owned by the thread of the caller. The above @@ -325,8 +269,8 @@ PlatformEventsControl( */ void -PlatformEventsFinalize( - void) +TclpFinalizeNotifier( + TCL_UNUSED(ClientData)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -356,14 +300,16 @@ PlatformEventsFinalize( /* *---------------------------------------------------------------------- * - * PlatformEventsInit -- + * TclpInitNotifier -- + * + * Initializes the platform specific notifier state. * * This function abstracts creating a kqueue fd via the kqueue system * call and allocating memory for the kevents structs in tsdPtr for the * thread of the caller. * * Results: - * None. + * Returns a handle to the notifier state for this thread. * * Side effects: * The following per-thread entities are initialised: @@ -380,8 +326,8 @@ PlatformEventsFinalize( *---------------------------------------------------------------------- */ -void -PlatformEventsInit(void) +ClientData +TclpInitNotifier(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); int i, fdFl; @@ -409,16 +355,18 @@ PlatformEventsInit(void) } else if (fcntl(tsdPtr->eventsFd, F_SETFD, FD_CLOEXEC) == -1) { Tcl_Panic("fcntl: %s", strerror(errno)); } - filePtr = (FileHandler *)ckalloc(sizeof(FileHandler)); + filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); filePtr->fd = tsdPtr->triggerPipe[0]; filePtr->mask = TCL_READABLE; PlatformEventsControl(filePtr, tsdPtr, EV_ADD, 1); if (!tsdPtr->readyEvents) { tsdPtr->maxReadyEvents = 512; - tsdPtr->readyEvents = (struct kevent *)ckalloc( + tsdPtr->readyEvents = (struct kevent *) ckalloc( tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0])); } LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr); + + return tsdPtr; } /* @@ -438,7 +386,7 @@ PlatformEventsInit(void) *---------------------------------------------------------------------- */ -int +static int PlatformEventsTranslate( struct kevent *eventPtr) { @@ -459,7 +407,7 @@ PlatformEventsTranslate( } return mask; } - + /* *---------------------------------------------------------------------- * @@ -483,7 +431,7 @@ PlatformEventsTranslate( *---------------------------------------------------------------------- */ -int +static int PlatformEventsWait( struct kevent *events, size_t numEvents, @@ -538,7 +486,7 @@ PlatformEventsWait( /* *---------------------------------------------------------------------- * - * Tcl_CreateFileHandler -- + * TclpCreateFileHandler -- * * This function registers a file handler with the kqueue notifier * of the thread of the caller. @@ -554,7 +502,7 @@ PlatformEventsWait( */ void -Tcl_CreateFileHandler( +TclpCreateFileHandler( int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates @@ -564,43 +512,28 @@ Tcl_CreateFileHandler( * event. */ ClientData clientData) /* Arbitrary data to pass to proc. */ { - int isNew; - - if (tclNotifierHooks.createFileHandlerProc) { - tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); - return; - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FileHandler *filePtr; - - for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd == fd) { - break; - } - } - if (filePtr == NULL) { - filePtr = (FileHandler *)ckalloc(sizeof(FileHandler)); - filePtr->fd = fd; - filePtr->readyMask = 0; - filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; - tsdPtr->firstFileHandlerPtr = filePtr; - isNew = 1; - } else { - isNew = 0; - } - filePtr->proc = proc; - filePtr->clientData = clientData; - filePtr->mask = mask; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); + int isNew = (filePtr == NULL); - PlatformEventsControl(filePtr, tsdPtr, EV_ADD, isNew); + if (isNew) { + filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr->fd = fd; + filePtr->readyMask = 0; + filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; + tsdPtr->firstFileHandlerPtr = filePtr; } + filePtr->proc = proc; + filePtr->clientData = clientData; + filePtr->mask = mask; + + PlatformEventsControl(filePtr, tsdPtr, EV_ADD, isNew); } /* *---------------------------------------------------------------------- * - * Tcl_DeleteFileHandler -- + * TclpDeleteFileHandler -- * * Cancel a previously-arranged callback arrangement for a file on the * kqueue of the thread of the caller. @@ -618,60 +551,50 @@ Tcl_CreateFileHandler( */ void -Tcl_DeleteFileHandler( +TclpDeleteFileHandler( int fd) /* Stream id for which to remove callback * function. */ { - if (tclNotifierHooks.deleteFileHandlerProc) { - tclNotifierHooks.deleteFileHandlerProc(fd); - return; - } else { - FileHandler *filePtr, *prevPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileHandler *filePtr, *prevPtr; - /* - * Find the entry for the given file (and return if there isn't one). - */ + /* + * Find the entry for the given file (and return if there isn't one). + */ - for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { - if (filePtr == NULL) { - return; - } - if (filePtr->fd == fd) { - break; - } - } + filePtr = LookUpFileHandler(tsdPtr, fd, &prevPtr); + if (filePtr == NULL) { + return; + } - /* - * Update the check masks for this file. - */ + /* + * Update the check masks for this file. + */ - PlatformEventsControl(filePtr, tsdPtr, EV_DELETE, 0); - if (filePtr->pedPtr) { - ckfree(filePtr->pedPtr); - } + PlatformEventsControl(filePtr, tsdPtr, EV_DELETE, 0); + if (filePtr->pedPtr) { + ckfree(filePtr->pedPtr); + } - /* - * Clean up information in the callback record. - */ + /* + * Clean up information in the callback record. + */ - if (prevPtr == NULL) { - tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; - } else { - prevPtr->nextPtr = filePtr->nextPtr; - } - ckfree(filePtr); + if (prevPtr == NULL) { + tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; + } else { + prevPtr->nextPtr = filePtr->nextPtr; } + ckfree(filePtr); } /* *---------------------------------------------------------------------- * - * Tcl_WaitForEvent -- + * TclpWaitForEvent -- * * This function is called by Tcl_DoOneEvent to wait for new events on - * the message queue. If the block time is 0, then Tcl_WaitForEvent just + * the message queue. If the block time is 0, then TclpWaitForEvent just * polls without blocking. * * The waiting logic is implemented in PlatformEventsWait. @@ -687,161 +610,157 @@ Tcl_DeleteFileHandler( */ int -Tcl_WaitForEvent( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ +TclpWaitForEvent( + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { - if (tclNotifierHooks.waitForEventProc) { - return tclNotifierHooks.waitForEventProc(timePtr); - } else { - FileHandler *filePtr; - int mask; - Tcl_Time vTime; - /* - * Impl. notes: timeout & timeoutPtr are used if, and only if threads - * are not enabled. They are the arguments for the regular epoll_wait() - * used when the core is not thread-enabled. - */ + FileHandler *filePtr; + int mask; + Tcl_Time vTime; + struct timeval timeout, *timeoutPtr; + /* Impl. notes: timeout & timeoutPtr are used + * if, and only if threads are not enabled. + * They are the arguments for the regular + * epoll_wait() used when the core is not + * thread-enabled. */ + int numFound, numEvent; + struct PlatformEventData *pedPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + int numQueued; + ssize_t i; + char buf[1]; - struct timeval timeout, *timeoutPtr; - int numFound, numEvent; - struct PlatformEventData *pedPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - int numQueued; - ssize_t i; - char buf[1]; + /* + * Set up the timeout structure. Note that if there are no events to check + * for, we return with a negative result rather than blocking forever. + */ + if (timePtr != NULL) { /* - * Set up the timeout structure. Note that if there are no events to - * check for, we return with a negative result rather than blocking - * forever. + * TIP #233 (Virtualized Time). Is virtual time in effect? And do we + * actually have something to scale? If yes to both then we call the + * handler to do this scaling. */ - if (timePtr != NULL) { - /* - * TIP #233 (Virtualized Time). Is virtual time in effect? And do - * we actually have something to scale? If yes to both then we - * call the handler to do this scaling. - */ - - if (timePtr->sec != 0 || timePtr->usec != 0) { - vTime = *timePtr; - tclScaleTimeProcPtr(&vTime, tclTimeClientData); - timePtr = &vTime; - } - timeout.tv_sec = timePtr->sec; - timeout.tv_usec = timePtr->usec; - timeoutPtr = &timeout; - } else { - timeoutPtr = NULL; + if (timePtr->sec != 0 || timePtr->usec != 0) { + vTime = *timePtr; + TclScaleTime(&vTime); + timePtr = &vTime; + } + timeout.tv_sec = timePtr->sec; + timeout.tv_usec = timePtr->usec; + timeoutPtr = &timeout; + } else { + timeoutPtr = NULL; + } + + /* + * Walk the list of FileHandlers associated with regular files (S_IFREG) + * belonging to tsdPtr, queue Tcl events for them, and update their mask + * of events of interest. + * + * kqueue(2), unlike epoll(7), does support regular files, but EVFILT_READ + * only `[r]eturns when the file pointer is not at the end of file' as + * opposed to unconditionally. While FreeBSD 11.0-RELEASE adds support for + * this mode (NOTE_FILE_POLL,) this is not used for reasons of + * compatibility. + * + * Therefore, the behaviour of {select,poll}(2) is simply simulated here: + * fds associated with regular files are added to this list by + * PlatformEventsControl() and processed here before calling (and possibly + * blocking) on PlatformEventsWait(). + */ + + numQueued = 0; + LIST_FOREACH(filePtr, &tsdPtr->firstReadyFileHandlerPtr, readyNode) { + mask = 0; + if (filePtr->mask & TCL_READABLE) { + mask |= TCL_READABLE; + } + if (filePtr->mask & TCL_WRITABLE) { + mask |= TCL_WRITABLE; } /* - * Walk the list of FileHandlers associated with regular files - * (S_IFREG) belonging to tsdPtr, queue Tcl events for them, and - * update their mask of events of interest. - * - * kqueue(2), unlike epoll(7), does support regular files, but - * EVFILT_READ only `[r]eturns when the file pointer is not at the end - * of file' as opposed to unconditionally. While FreeBSD 11.0-RELEASE - * adds support for this mode (NOTE_FILE_POLL,) this is not used for - * reasons of compatibility. - * - * Therefore, the behaviour of {select,poll}(2) is simply simulated - * here: fds associated with regular files are added to this list by - * PlatformEventsControl() and processed here before calling (and - * possibly blocking) on PlatformEventsWait(). + * Don't bother to queue an event if the mask was previously non-zero + * since an event must still be on the queue. */ - numQueued = 0; - LIST_FOREACH(filePtr, &tsdPtr->firstReadyFileHandlerPtr, readyNode) { - mask = 0; - if (filePtr->mask & TCL_READABLE) { - mask |= TCL_READABLE; - } - if (filePtr->mask & TCL_WRITABLE) { - mask |= TCL_WRITABLE; - } + if (filePtr->readyMask == 0) { + FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) + ckalloc(sizeof(FileHandlerEvent)); - /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. - */ + fileEvPtr->header.proc = FileHandlerEventProc; + fileEvPtr->fd = filePtr->fd; + Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); + numQueued++; + } + filePtr->readyMask = mask; + } - if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) - ckalloc(sizeof(FileHandlerEvent)); + /* + * If any events were queued in the above loop, force PlatformEventsWait() + * to poll as there already are events that need to be processed at this + * point. + */ - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - numQueued++; - } - filePtr->readyMask = mask; - } + if (numQueued) { + timeout.tv_sec = 0; + timeout.tv_usec = 0; + timeoutPtr = &timeout; + } - /* - * If any events were queued in the above loop, force PlatformEvents- - * Wait() to poll as there already are events that need to be processed - * at this point. - */ + /* + * Wait or poll for new events, queue Tcl events for the FileHandlers + * corresponding to them, and update the FileHandlers' mask of events of + * interest registered by the last call to Tcl_CreateFileHandler(). + * + * Events for the trigger pipe are processed here in order to facilitate + * inter-thread IPC. If another thread intends to wake up this thread + * whilst it's blocking on PlatformEventsWait(), it write(2)s to the other + * end of the pipe (see Tcl_AlertNotifier(),) which in turn will cause + * PlatformEventsWait() to return immediately. + */ - if (numQueued) { - timeout.tv_sec = 0; - timeout.tv_usec = 0; - timeoutPtr = &timeout; + numFound = PlatformEventsWait(tsdPtr->readyEvents, + tsdPtr->maxReadyEvents, timeoutPtr); + for (numEvent = 0; numEvent < numFound; numEvent++) { + pedPtr = (struct PlatformEventData *) + tsdPtr->readyEvents[numEvent].udata; + filePtr = pedPtr->filePtr; + mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]); + if (filePtr->fd == tsdPtr->triggerPipe[0]) { + i = read(tsdPtr->triggerPipe[0], buf, 1); + if ((i == -1) && (errno != EAGAIN)) { + Tcl_Panic("Tcl_WaitForEvent: read from %p->triggerPipe: %s", + (void *) tsdPtr, strerror(errno)); + } + continue; + } + if (!mask) { + continue; } /* - * Wait or poll for new events, queue Tcl events for the FileHandlers - * corresponding to them, and update the FileHandlers' mask of events - * of interest registered by the last call to Tcl_CreateFileHandler(). - * - * Events for the trigger pipe are processed here in order to facilitate - * inter-thread IPC. If another thread intends to wake up this thread - * whilst it's blocking on PlatformEventsWait(), it write(2)s to the - * other end of the pipe (see Tcl_AlertNotifier(),) which in turn will - * cause PlatformEventsWait() to return immediately. + * Don't bother to queue an event if the mask was previously non-zero + * since an event must still be on the queue. */ - numFound = PlatformEventsWait(tsdPtr->readyEvents, - tsdPtr->maxReadyEvents, timeoutPtr); - for (numEvent = 0; numEvent < numFound; numEvent++) { - pedPtr = (struct PlatformEventData *) - tsdPtr->readyEvents[numEvent].udata; - filePtr = pedPtr->filePtr; - mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]); - if (filePtr->fd == tsdPtr->triggerPipe[0]) { - i = read(tsdPtr->triggerPipe[0], buf, 1); - if ((i == -1) && (errno != EAGAIN)) { - Tcl_Panic("Tcl_WaitForEvent: read from %p->triggerPipe: %s", - (void *) tsdPtr, strerror(errno)); - } - continue; - } - if (!mask) { - continue; - } - - /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. - */ + if (filePtr->readyMask == 0) { + FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) + ckalloc(sizeof(FileHandlerEvent)); - if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) - ckalloc(sizeof(FileHandlerEvent)); - - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - } - filePtr->readyMask |= mask; + fileEvPtr->header.proc = FileHandlerEventProc; + fileEvPtr->fd = filePtr->fd; + Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); } - return 0; + filePtr->readyMask |= mask; } + return 0; } #endif /* NOTIFIER_KQUEUE && TCL_THREADS */ +#else +TCL_MAC_EMPTY_FILE(unix_tclKqueueNotfy_c) #endif /* !HAVE_COREFOUNDATION */ /* diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index 017793d..7cd48f2 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -336,7 +336,7 @@ FindSymbol( const char *symbol) /* Symbol name to look up. */ { Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *)loadHandle->clientData; - Tcl_PackageInitProc *proc = NULL; + Tcl_LibraryInitProc *proc = NULL; const char *errMsg = NULL; Tcl_DString ds; const char *native; @@ -344,7 +344,7 @@ FindSymbol( native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds); if (dyldLoadHandle->dlHandle) { #if TCL_DYLD_USE_DLFCN - proc = (Tcl_PackageInitProc *)dlsym(dyldLoadHandle->dlHandle, native); + proc = (Tcl_LibraryInitProc *)dlsym(dyldLoadHandle->dlHandle, native); if (!proc) { errMsg = dlerror(); } @@ -400,7 +400,7 @@ FindSymbol( dyldLoadHandle->modulePtr->module, native); } if (nsSymbol) { - proc = (Tcl_PackageInitProc *)NSAddressOfSymbol(nsSymbol); + proc = (Tcl_LibraryInitProc *)NSAddressOfSymbol(nsSymbol); } Tcl_DStringFree(&newName); #endif /* TCL_DYLD_USE_NSMODULE */ diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c index ee39326..2055210 100644 --- a/unix/tclLoadNext.c +++ b/unix/tclLoadNext.c @@ -133,7 +133,7 @@ FindSymbol( Tcl_LoadHandle loadHandle, const char *symbol) { - Tcl_PackageInitProc *proc = NULL; + Tcl_LibraryInitProc *proc = NULL; if (symbol) { char sym[strlen(symbol) + 2]; diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index 7fd0cf3..bb58871 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -89,7 +89,7 @@ TclpDlopen( */ native = Tcl_FSGetNativePath(pathPtr); - lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS); + lm = (Tcl_LibraryInitProc *) load(native, LDR_NOFLAGS); if (lm == LDR_NULL_MODULE) { /* @@ -101,7 +101,7 @@ TclpDlopen( Tcl_DString ds; native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); - lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS); + lm = (Tcl_LibraryInitProc *) load(native, LDR_NOFLAGS); Tcl_DStringFree(&ds); } diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index 11eaa83..5bf97eb 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -128,7 +128,7 @@ FindSymbol( const char *symbol) { Tcl_DString newName; - Tcl_PackageInitProc *proc = NULL; + Tcl_LibraryInitProc *proc = NULL; shl_t handle = (shl_t) loadHandle->clientData; /* diff --git a/unix/tclSelectNotfy.c b/unix/tclSelectNotfy.c index 1d16114..82f2ef7 100644 --- a/unix/tclSelectNotfy.c +++ b/unix/tclSelectNotfy.c @@ -216,8 +216,8 @@ extern "C" { typedef struct { void *hwnd; /* Messaging window. */ unsigned int *message; /* Message payload. */ - size_t wParam; /* Event-specific "word" parameter. */ - size_t lParam; /* Event-specific "long" parameter. */ + size_t wParam; /* Event-specific "word" parameter. */ + size_t lParam; /* Event-specific "long" parameter. */ int time; /* Event timestamp. */ int x; /* Event location (where meaningful). */ int y; @@ -244,8 +244,8 @@ extern void __stdcall CloseHandle(void *); extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char, void *); extern void *__stdcall CreateWindowExW(void *, const void *, const void *, - unsigned int, int, int, int, int, void *, void *, void *, - void *); + unsigned int, int, int, int, int, void *, void *, + void *, void *); extern unsigned int __stdcall DefWindowProcW(void *, int, void *, void *); extern unsigned char __stdcall DestroyWindow(void *); extern int __stdcall DispatchMessageW(const MSG *); @@ -271,14 +271,17 @@ static unsigned int __stdcall NotifierProc(void *hwnd, unsigned int message, } #endif #endif /* TCL_THREADS && __CYGWIN__ */ - +/* + * Incorporate the base notifier implementation. + */ + #include "tclUnixNotfy.c" /* *---------------------------------------------------------------------- * - * Tcl_InitNotifier -- + * TclpInitNotifier -- * * Initializes the platform specific notifier state. * @@ -292,75 +295,72 @@ static unsigned int __stdcall NotifierProc(void *hwnd, unsigned int message, */ ClientData -Tcl_InitNotifier(void) +TclpInitNotifier(void) { - if (tclNotifierHooks.initNotifierProc) { - return tclNotifierHooks.initNotifierProc(); - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); #if TCL_THREADS - tsdPtr->eventReady = 0; + tsdPtr->eventReady = 0; - /* - * Initialize thread specific condition variable for this thread. - */ - if (tsdPtr->waitCVinitialized == 0) { + /* + * Initialize thread specific condition variable for this thread. + */ + + if (tsdPtr->waitCVinitialized == 0) { #ifdef __CYGWIN__ - WNDCLASSW clazz; - - clazz.style = 0; - clazz.cbClsExtra = 0; - clazz.cbWndExtra = 0; - clazz.hInstance = TclWinGetTclInstance(); - clazz.hbrBackground = NULL; - clazz.lpszMenuName = NULL; - clazz.lpszClassName = className; - clazz.lpfnWndProc = (void *)NotifierProc; - clazz.hIcon = NULL; - clazz.hCursor = NULL; - - RegisterClassW(&clazz); - tsdPtr->hwnd = CreateWindowExW(NULL, clazz.lpszClassName, - clazz.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL, - clazz.hInstance, NULL); - tsdPtr->event = CreateEventW(NULL, 1 /* manual */, - 0 /* !signaled */, NULL); -#else - pthread_cond_init(&tsdPtr->waitCV, NULL); + WNDCLASSW clazz; + + clazz.style = 0; + clazz.cbClsExtra = 0; + clazz.cbWndExtra = 0; + clazz.hInstance = TclWinGetTclInstance(); + clazz.hbrBackground = NULL; + clazz.lpszMenuName = NULL; + clazz.lpszClassName = className; + clazz.lpfnWndProc = (void *) NotifierProc; + clazz.hIcon = NULL; + clazz.hCursor = NULL; + + RegisterClassW(&clazz); + tsdPtr->hwnd = CreateWindowExW(NULL, clazz.lpszClassName, + clazz.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL, + clazz.hInstance, NULL); + tsdPtr->event = CreateEventW(NULL, 1 /* manual */, + 0 /* !signaled */, NULL); +#else /* !__CYGWIN__ */ + pthread_cond_init(&tsdPtr->waitCV, NULL); #endif /* __CYGWIN__ */ - tsdPtr->waitCVinitialized = 1; - } + tsdPtr->waitCVinitialized = 1; + } - pthread_mutex_lock(¬ifierInitMutex); + pthread_mutex_lock(¬ifierInitMutex); #if defined(HAVE_PTHREAD_ATFORK) - /* - * Install pthread_atfork handlers to clean up the notifier in the - * child of a fork. - */ + /* + * Install pthread_atfork handlers to clean up the notifier in the child + * of a fork. + */ - if (!atForkInit) { - int result = pthread_atfork(NULL, NULL, AtForkChild); + if (!atForkInit) { + int result = pthread_atfork(NULL, NULL, AtForkChild); - if (result) { - Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed"); - } - atForkInit = 1; + if (result) { + Tcl_Panic("Tcl_InitNotifier: %s", "pthread_atfork failed"); } + atForkInit = 1; + } #endif /* HAVE_PTHREAD_ATFORK */ - notifierCount++; - pthread_mutex_unlock(¬ifierInitMutex); - + notifierCount++; + pthread_mutex_unlock(¬ifierInitMutex); #endif /* TCL_THREADS */ - return tsdPtr; - } + + return tsdPtr; } /* *---------------------------------------------------------------------- * - * Tcl_FinalizeNotifier -- + * TclpFinalizeNotifier -- * * This function is called to cleanup the notifier state before a thread * is terminated. @@ -376,67 +376,62 @@ Tcl_InitNotifier(void) */ void -Tcl_FinalizeNotifier( - ClientData clientData) +TclpFinalizeNotifier( + TCL_UNUSED(void *)) { - if (tclNotifierHooks.finalizeNotifierProc) { - tclNotifierHooks.finalizeNotifierProc(clientData); - return; - } else { #if TCL_THREADS - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - pthread_mutex_lock(¬ifierInitMutex); - notifierCount--; + pthread_mutex_lock(¬ifierInitMutex); + notifierCount--; - /* - * If this is the last thread to use the notifier, close the notifier - * pipe and wait for the background thread to terminate. - */ + /* + * If this is the last thread to use the notifier, close the notifier pipe + * and wait for the background thread to terminate. + */ - if (notifierCount == 0 && triggerPipe != -1) { - if (write(triggerPipe, "q", 1) != 1) { - Tcl_Panic("Tcl_FinalizeNotifier: %s", - "unable to write 'q' to triggerPipe"); - } - close(triggerPipe); - pthread_mutex_lock(¬ifierMutex); - while(triggerPipe != -1) { - pthread_cond_wait(¬ifierCV, ¬ifierMutex); - } - pthread_mutex_unlock(¬ifierMutex); - if (notifierThreadRunning) { - int result = pthread_join((pthread_t) notifierThread, NULL); + if (notifierCount == 0 && triggerPipe != -1) { + if (write(triggerPipe, "q", 1) != 1) { + Tcl_Panic("Tcl_FinalizeNotifier: %s", + "unable to write 'q' to triggerPipe"); + } + close(triggerPipe); + pthread_mutex_lock(¬ifierMutex); + while(triggerPipe != -1) { + pthread_cond_wait(¬ifierCV, ¬ifierMutex); + } + pthread_mutex_unlock(¬ifierMutex); + if (notifierThreadRunning) { + int result = pthread_join((pthread_t) notifierThread, NULL); - if (result) { - Tcl_Panic("Tcl_FinalizeNotifier: %s", - "unable to join notifier thread"); - } - notifierThreadRunning = 0; + if (result) { + Tcl_Panic("Tcl_FinalizeNotifier: %s", + "unable to join notifier thread"); } + notifierThreadRunning = 0; } + } - /* - * Clean up any synchronization objects in the thread local storage. - */ + /* + * Clean up any synchronization objects in the thread local storage. + */ #ifdef __CYGWIN__ - DestroyWindow(tsdPtr->hwnd); - CloseHandle(tsdPtr->event); -#else /* __CYGWIN__ */ - pthread_cond_destroy(&tsdPtr->waitCV); + DestroyWindow(tsdPtr->hwnd); + CloseHandle(tsdPtr->event); +#else /* !__CYGWIN__ */ + pthread_cond_destroy(&tsdPtr->waitCV); #endif /* __CYGWIN__ */ - tsdPtr->waitCVinitialized = 0; + tsdPtr->waitCVinitialized = 0; - pthread_mutex_unlock(¬ifierInitMutex); + pthread_mutex_unlock(¬ifierInitMutex); #endif /* TCL_THREADS */ - } } /* *---------------------------------------------------------------------- * - * Tcl_CreateFileHandler -- + * TclpCreateFileHandler -- * * This function registers a file handler with the select notifier. * @@ -450,7 +445,7 @@ Tcl_FinalizeNotifier( */ void -Tcl_CreateFileHandler( +TclpCreateFileHandler( int fd, /* Handle of stream to watch. */ int mask, /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates @@ -460,59 +455,48 @@ Tcl_CreateFileHandler( * event. */ ClientData clientData) /* Arbitrary data to pass to proc. */ { - if (tclNotifierHooks.createFileHandlerProc) { - tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); - return; - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FileHandler *filePtr; - - for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->fd == fd) { - break; - } - } - if (filePtr == NULL) { - filePtr = (FileHandler *)ckalloc(sizeof(FileHandler)); - filePtr->fd = fd; - filePtr->readyMask = 0; - filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; - tsdPtr->firstFileHandlerPtr = filePtr; - } - filePtr->proc = proc; - filePtr->clientData = clientData; - filePtr->mask = mask; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); + + if (filePtr == NULL) { + filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr->fd = fd; + filePtr->readyMask = 0; + filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; + tsdPtr->firstFileHandlerPtr = filePtr; + } + filePtr->proc = proc; + filePtr->clientData = clientData; + filePtr->mask = mask; - /* - * Update the check masks for this file. - */ + /* + * Update the check masks for this file. + */ - if (mask & TCL_READABLE) { - FD_SET(fd, &tsdPtr->checkMasks.readable); - } else { - FD_CLR(fd, &tsdPtr->checkMasks.readable); - } - if (mask & TCL_WRITABLE) { - FD_SET(fd, &tsdPtr->checkMasks.writable); - } else { - FD_CLR(fd, &tsdPtr->checkMasks.writable); - } - if (mask & TCL_EXCEPTION) { - FD_SET(fd, &tsdPtr->checkMasks.exception); - } else { - FD_CLR(fd, &tsdPtr->checkMasks.exception); - } - if (tsdPtr->numFdBits <= fd) { - tsdPtr->numFdBits = fd+1; - } + if (mask & TCL_READABLE) { + FD_SET(fd, &tsdPtr->checkMasks.readable); + } else { + FD_CLR(fd, &tsdPtr->checkMasks.readable); + } + if (mask & TCL_WRITABLE) { + FD_SET(fd, &tsdPtr->checkMasks.writable); + } else { + FD_CLR(fd, &tsdPtr->checkMasks.writable); + } + if (mask & TCL_EXCEPTION) { + FD_SET(fd, &tsdPtr->checkMasks.exception); + } else { + FD_CLR(fd, &tsdPtr->checkMasks.exception); + } + if (tsdPtr->numFdBits <= fd) { + tsdPtr->numFdBits = fd + 1; } } /* *---------------------------------------------------------------------- * - * Tcl_DeleteFileHandler -- + * TclpDeleteFileHandler -- * * Cancel a previously-arranged callback arrangement for a file. * @@ -526,75 +510,65 @@ Tcl_CreateFileHandler( */ void -Tcl_DeleteFileHandler( +TclpDeleteFileHandler( int fd) /* Stream id for which to remove callback * function. */ { - if (tclNotifierHooks.deleteFileHandlerProc) { - tclNotifierHooks.deleteFileHandlerProc(fd); - return; - } else { - FileHandler *filePtr, *prevPtr; - int i; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileHandler *filePtr, *prevPtr; + int i; - /* - * Find the entry for the given file (and return if there isn't one). - */ + /* + * Find the entry for the given file (and return if there isn't one). + */ - for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { - if (filePtr == NULL) { - return; - } - if (filePtr->fd == fd) { - break; - } - } + filePtr = LookUpFileHandler(tsdPtr, fd, &prevPtr); + if (filePtr == NULL) { + return; + } - /* - * Update the check masks for this file. - */ + /* + * Update the check masks for this file. + */ - if (filePtr->mask & TCL_READABLE) { - FD_CLR(fd, &tsdPtr->checkMasks.readable); - } - if (filePtr->mask & TCL_WRITABLE) { - FD_CLR(fd, &tsdPtr->checkMasks.writable); - } - if (filePtr->mask & TCL_EXCEPTION) { - FD_CLR(fd, &tsdPtr->checkMasks.exception); - } + if (filePtr->mask & TCL_READABLE) { + FD_CLR(fd, &tsdPtr->checkMasks.readable); + } + if (filePtr->mask & TCL_WRITABLE) { + FD_CLR(fd, &tsdPtr->checkMasks.writable); + } + if (filePtr->mask & TCL_EXCEPTION) { + FD_CLR(fd, &tsdPtr->checkMasks.exception); + } - /* - * Find current max fd. - */ + /* + * Find current max fd. + */ - if (fd+1 == tsdPtr->numFdBits) { - int numFdBits = 0; + if (fd + 1 == tsdPtr->numFdBits) { + int numFdBits = 0; - for (i = fd-1; i >= 0; i--) { - if (FD_ISSET(i, &tsdPtr->checkMasks.readable) - || FD_ISSET(i, &tsdPtr->checkMasks.writable) - || FD_ISSET(i, &tsdPtr->checkMasks.exception)) { - numFdBits = i+1; - break; - } + for (i = fd - 1; i >= 0; i--) { + if (FD_ISSET(i, &tsdPtr->checkMasks.readable) + || FD_ISSET(i, &tsdPtr->checkMasks.writable) + || FD_ISSET(i, &tsdPtr->checkMasks.exception)) { + numFdBits = i + 1; + break; } - tsdPtr->numFdBits = numFdBits; } + tsdPtr->numFdBits = numFdBits; + } - /* - * Clean up information in the callback record. - */ + /* + * Clean up information in the callback record. + */ - if (prevPtr == NULL) { - tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; - } else { - prevPtr->nextPtr = filePtr->nextPtr; - } - ckfree(filePtr); + if (prevPtr == NULL) { + tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; + } else { + prevPtr->nextPtr = filePtr->nextPtr; } + ckfree(filePtr); } #if defined(__CYGWIN__) @@ -625,7 +599,7 @@ NotifierProc( /* *---------------------------------------------------------------------- * - * Tcl_WaitForEvent -- + * TclpWaitForEvent -- * * This function is called by Tcl_DoOneEvent to wait for new events on * the message queue. If the block time is 0, then Tcl_WaitForEvent just @@ -641,265 +615,261 @@ NotifierProc( */ int -Tcl_WaitForEvent( +TclpWaitForEvent( const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { - if (tclNotifierHooks.waitForEventProc) { - return tclNotifierHooks.waitForEventProc(timePtr); - } else { - FileHandler *filePtr; - int mask; - Tcl_Time vTime; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileHandler *filePtr; + int mask; + Tcl_Time vTime; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); #if TCL_THREADS - int waitForFiles; + int waitForFiles; # ifdef __CYGWIN__ - MSG msg; + MSG msg; # endif /* __CYGWIN__ */ #else /* !TCL_THREADS */ - /* - * Impl. notes: timeout & timeoutPtr are used if, and only if threads - * are not enabled. They are the arguments for the regular select() - * used when the core is not thread-enabled. - */ + /* + * Impl. notes: timeout & timeoutPtr are used if, and only if threads are + * not enabled. They are the arguments for the regular select() used when + * the core is not thread-enabled. + */ - struct timeval timeout, *timeoutPtr; - int numFound; + struct timeval timeout, *timeoutPtr; + int numFound; #endif /* TCL_THREADS */ + /* + * Set up the timeout structure. Note that if there are no events to check + * for, we return with a negative result rather than blocking forever. + */ + + if (timePtr != NULL) { /* - * Set up the timeout structure. Note that if there are no events to - * check for, we return with a negative result rather than blocking - * forever. + * TIP #233 (Virtualized Time). Is virtual time in effect? And do we + * actually have something to scale? If yes to both then we call the + * handler to do this scaling. */ - if (timePtr != NULL) { - /* - * TIP #233 (Virtualized Time). Is virtual time in effect? And do - * we actually have something to scale? If yes to both then we - * call the handler to do this scaling. - */ - - if (timePtr->sec != 0 || timePtr->usec != 0) { - vTime = *timePtr; - tclScaleTimeProcPtr(&vTime, tclTimeClientData); - timePtr = &vTime; - } + if (timePtr->sec != 0 || timePtr->usec != 0) { + vTime = *timePtr; + TclScaleTime(&vTime); + timePtr = &vTime; + } #if !TCL_THREADS - timeout.tv_sec = timePtr->sec; - timeout.tv_usec = timePtr->usec; - timeoutPtr = &timeout; - } else if (tsdPtr->numFdBits == 0) { - /* - * If there are no threads, no timeout, and no fds registered, - * then there are no events possible and we must avoid deadlock. - * Note that this is not entirely correct because there might be a - * signal that could interrupt the select call, but we don't - * handle that case if we aren't using threads. - */ + timeout.tv_sec = timePtr->sec; + timeout.tv_usec = timePtr->usec; + timeoutPtr = &timeout; + } else if (tsdPtr->numFdBits == 0) { + /* + * If there are no threads, no timeout, and no fds registered, then + * there are no events possible and we must avoid deadlock. Note that + * this is not entirely correct because there might be a signal that + * could interrupt the select call, but we don't handle that case if + * we aren't using threads. + */ - return -1; - } else { - timeoutPtr = NULL; + return -1; + } else { + timeoutPtr = NULL; #endif /* !TCL_THREADS */ - } + } #if TCL_THREADS - /* - * Start notifier thread and place this thread on the list of - * interested threads, signal the notifier thread, and wait for a - * response or a timeout. - */ - StartNotifierThread("Tcl_WaitForEvent"); + /* + * Start notifier thread and place this thread on the list of interested + * threads, signal the notifier thread, and wait for a response or a + * timeout. + */ - pthread_mutex_lock(¬ifierMutex); + StartNotifierThread("Tcl_WaitForEvent"); + + pthread_mutex_lock(¬ifierMutex); - if (timePtr != NULL && timePtr->sec == 0 && (timePtr->usec == 0 + if (timePtr != NULL && timePtr->sec == 0 && (timePtr->usec == 0 #if defined(__APPLE__) && defined(__LP64__) - /* - * On 64-bit Darwin, pthread_cond_timedwait() appears to have - * a bug that causes it to wait forever when passed an - * absolute time which has already been exceeded by the system - * time; as a workaround, when given a very brief timeout, - * just do a poll. [Bug 1457797] - */ - || timePtr->usec < 10 -#endif /* __APPLE__ && __LP64__ */ - )) { /* - * Cannot emulate a polling select with a polling condition - * variable. Instead, pretend to wait for files and tell the - * notifier thread what we are doing. The notifier thread makes - * sure it goes through select with its select mask in the same - * state as ours currently is. We block until that happens. + * On 64-bit Darwin, pthread_cond_timedwait() appears to have a + * bug that causes it to wait forever when passed an absolute time + * which has already been exceeded by the system time; as a + * workaround, when given a very brief timeout, just do a poll. + * [Bug 1457797] */ + || timePtr->usec < 10 +#endif /* __APPLE__ && __LP64__ */ + )) { + /* + * Cannot emulate a polling select with a polling condition variable. + * Instead, pretend to wait for files and tell the notifier thread + * what we are doing. The notifier thread makes sure it goes through + * select with its select mask in the same state as ours currently is. + * We block until that happens. + */ - waitForFiles = 1; - tsdPtr->pollState = POLL_WANT; - timePtr = NULL; - } else { - waitForFiles = (tsdPtr->numFdBits > 0); - tsdPtr->pollState = 0; - } + waitForFiles = 1; + tsdPtr->pollState = POLL_WANT; + timePtr = NULL; + } else { + waitForFiles = (tsdPtr->numFdBits > 0); + tsdPtr->pollState = 0; + } - if (waitForFiles) { - /* - * Add the ThreadSpecificData structure of this thread to the list - * of ThreadSpecificData structures of all threads that are - * waiting on file events. - */ + if (waitForFiles) { + /* + * Add the ThreadSpecificData structure of this thread to the list of + * ThreadSpecificData structures of all threads that are waiting on + * file events. + */ - tsdPtr->nextPtr = waitingListPtr; - if (waitingListPtr) { - waitingListPtr->prevPtr = tsdPtr; - } - tsdPtr->prevPtr = 0; - waitingListPtr = tsdPtr; - tsdPtr->onList = 1; + tsdPtr->nextPtr = waitingListPtr; + if (waitingListPtr) { + waitingListPtr->prevPtr = tsdPtr; + } + tsdPtr->prevPtr = 0; + waitingListPtr = tsdPtr; + tsdPtr->onList = 1; - if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) { - Tcl_Panic("Tcl_WaitForEvent: %s", - "unable to write to triggerPipe"); - } + if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) { + Tcl_Panic("Tcl_WaitForEvent: %s", + "unable to write to triggerPipe"); } + } - FD_ZERO(&tsdPtr->readyMasks.readable); - FD_ZERO(&tsdPtr->readyMasks.writable); - FD_ZERO(&tsdPtr->readyMasks.exception); + FD_ZERO(&tsdPtr->readyMasks.readable); + FD_ZERO(&tsdPtr->readyMasks.writable); + FD_ZERO(&tsdPtr->readyMasks.exception); - if (!tsdPtr->eventReady) { + if (!tsdPtr->eventReady) { #ifdef __CYGWIN__ - if (!PeekMessageW(&msg, NULL, 0, 0, 0)) { - unsigned int timeout; + if (!PeekMessageW(&msg, NULL, 0, 0, 0)) { + unsigned int timeout; - if (timePtr) { - timeout = timePtr->sec * 1000 + timePtr->usec / 1000; - } else { - timeout = 0xFFFFFFFF; - } - pthread_mutex_unlock(¬ifierMutex); - MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, timeout, 1279); - pthread_mutex_lock(¬ifierMutex); + if (timePtr) { + timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + } else { + timeout = 0xFFFFFFFF; } + pthread_mutex_unlock(¬ifierMutex); + MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, timeout, 1279); + pthread_mutex_lock(¬ifierMutex); + } #else /* !__CYGWIN__ */ - if (timePtr != NULL) { - Tcl_Time now; - struct timespec ptime; + if (timePtr != NULL) { + Tcl_Time now; + struct timespec ptime; - Tcl_GetTime(&now); - ptime.tv_sec = timePtr->sec + now.sec + - (timePtr->usec + now.usec) / 1000000; - ptime.tv_nsec = 1000 * ((timePtr->usec + now.usec) % 1000000); + Tcl_GetTime(&now); + ptime.tv_sec = timePtr->sec + now.sec + + (timePtr->usec + now.usec) / 1000000; + ptime.tv_nsec = 1000 * ((timePtr->usec + now.usec) % 1000000); - pthread_cond_timedwait(&tsdPtr->waitCV, ¬ifierMutex, &ptime); - } else { - pthread_cond_wait(&tsdPtr->waitCV, ¬ifierMutex); - } -#endif /* __CYGWIN__ */ + pthread_cond_timedwait(&tsdPtr->waitCV, ¬ifierMutex, &ptime); + } else { + pthread_cond_wait(&tsdPtr->waitCV, ¬ifierMutex); } - tsdPtr->eventReady = 0; +#endif /* __CYGWIN__ */ + } + tsdPtr->eventReady = 0; #ifdef __CYGWIN__ - while (PeekMessageW(&msg, NULL, 0, 0, 0)) { - /* - * Retrieve and dispatch the message. - */ + while (PeekMessageW(&msg, NULL, 0, 0, 0)) { + /* + * Retrieve and dispatch the message. + */ - unsigned int result = GetMessageW(&msg, NULL, 0, 0); + unsigned int result = GetMessageW(&msg, NULL, 0, 0); - if (result == 0) { - PostQuitMessage(msg.wParam); - /* What to do here? */ - } else if (result != (unsigned int) -1) { - TranslateMessage(&msg); - DispatchMessageW(&msg); - } + if (result == 0) { + PostQuitMessage(msg.wParam); + /* What to do here? */ + } else if (result != (unsigned int) -1) { + TranslateMessage(&msg); + DispatchMessageW(&msg); } - ResetEvent(tsdPtr->event); + } + ResetEvent(tsdPtr->event); #endif /* __CYGWIN__ */ - if (waitForFiles && tsdPtr->onList) { - /* - * Remove the ThreadSpecificData structure of this thread from the - * waiting list. Alert the notifier thread to recompute its select - * masks - skipping this caused a hang when trying to close a pipe - * which the notifier thread was still doing a select on. - */ + if (waitForFiles && tsdPtr->onList) { + /* + * Remove the ThreadSpecificData structure of this thread from the + * waiting list. Alert the notifier thread to recompute its select + * masks - skipping this caused a hang when trying to close a pipe + * which the notifier thread was still doing a select on. + */ - if (tsdPtr->prevPtr) { - tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; - } else { - waitingListPtr = tsdPtr->nextPtr; - } - if (tsdPtr->nextPtr) { - tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; - } - tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; - tsdPtr->onList = 0; - if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) { - Tcl_Panic("Tcl_WaitForEvent: %s", - "unable to write to triggerPipe"); - } + if (tsdPtr->prevPtr) { + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + } else { + waitingListPtr = tsdPtr->nextPtr; + } + if (tsdPtr->nextPtr) { + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } + tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; + tsdPtr->onList = 0; + if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) { + Tcl_Panic("Tcl_WaitForEvent: %s", + "unable to write to triggerPipe"); + } + } #else /* !TCL_THREADS */ - tsdPtr->readyMasks = tsdPtr->checkMasks; - numFound = select(tsdPtr->numFdBits, &tsdPtr->readyMasks.readable, - &tsdPtr->readyMasks.writable, &tsdPtr->readyMasks.exception, - timeoutPtr); + tsdPtr->readyMasks = tsdPtr->checkMasks; + numFound = select(tsdPtr->numFdBits, &tsdPtr->readyMasks.readable, + &tsdPtr->readyMasks.writable, &tsdPtr->readyMasks.exception, + timeoutPtr); - /* - * Some systems don't clear the masks after an error, so we have to do - * it here. - */ + /* + * Some systems don't clear the masks after an error, so we have to do it + * here. + */ - if (numFound == -1) { - FD_ZERO(&tsdPtr->readyMasks.readable); - FD_ZERO(&tsdPtr->readyMasks.writable); - FD_ZERO(&tsdPtr->readyMasks.exception); - } + if (numFound == -1) { + FD_ZERO(&tsdPtr->readyMasks.readable); + FD_ZERO(&tsdPtr->readyMasks.writable); + FD_ZERO(&tsdPtr->readyMasks.exception); + } #endif /* TCL_THREADS */ - /* - * Queue all detected file events before returning. - */ + /* + * Queue all detected file events before returning. + */ - for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL); - filePtr = filePtr->nextPtr) { - mask = 0; - if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.readable)) { - mask |= TCL_READABLE; - } - if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.writable)) { - mask |= TCL_WRITABLE; - } - if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.exception)) { - mask |= TCL_EXCEPTION; - } + for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL); + filePtr = filePtr->nextPtr) { + mask = 0; + if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.readable)) { + mask |= TCL_READABLE; + } + if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.writable)) { + mask |= TCL_WRITABLE; + } + if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.exception)) { + mask |= TCL_EXCEPTION; + } - if (!mask) { - continue; - } + if (!mask) { + continue; + } - /* - * Don't bother to queue an event if the mask was previously - * non-zero since an event must still be on the queue. - */ + /* + * Don't bother to queue an event if the mask was previously non-zero + * since an event must still be on the queue. + */ - if (filePtr->readyMask == 0) { - FileHandlerEvent *fileEvPtr = - (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent)); + if (filePtr->readyMask == 0) { + FileHandlerEvent *fileEvPtr = + (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent)); - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->fd = filePtr->fd; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - } - filePtr->readyMask = mask; + fileEvPtr->header.proc = FileHandlerEventProc; + fileEvPtr->fd = filePtr->fd; + Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); } + filePtr->readyMask = mask; + } #if TCL_THREADS - pthread_mutex_unlock(¬ifierMutex); + pthread_mutex_unlock(¬ifierMutex); #endif /* TCL_THREADS */ - return 0; - } + return 0; } /* @@ -916,8 +886,9 @@ Tcl_WaitForEvent( * byte to a special pipe that the notifier thread is monitoring. * * Result: - * None. Once started, this routine never exits. It dies with the overall - * process. + * None. Once started, this routine normally never exits and usually dies + * with the overall process, but it can be shut down if the Tcl library + * is finalized. * * Side effects: * The trigger pipe used to signal the notifier thread is created when @@ -1048,7 +1019,7 @@ NotifierThreadProc( for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { found = 0; - for (i = tsdPtr->numFdBits-1; i >= 0; --i) { + for (i = tsdPtr->numFdBits - 1; i >= 0; --i) { if (FD_ISSET(i, &tsdPtr->checkMasks.readable) && FD_ISSET(i, &readableMask)) { FD_SET(i, &tsdPtr->readyMasks.readable); @@ -1113,6 +1084,8 @@ NotifierThreadProc( #endif /* TCL_THREADS */ #endif /* (!NOTIFIER_EPOLL && !NOTIFIER_KQUEUE) || !TCL_THREADS */ +#else +TCL_MAC_EMPTY_FILE(unix_tclSelectNotfy_c) #endif /* !HAVE_COREFOUNDATION */ /* diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 837aa59..4cb9af0 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -282,12 +282,15 @@ FileInputProc( * nonblocking, the read will never block. */ - bytesRead = read(fsPtr->fd, buf, (size_t) toRead); - if (bytesRead >= 0) { - return bytesRead; + do { + bytesRead = read(fsPtr->fd, buf, (size_t) toRead); + } while ((bytesRead < 0) && (errno == EINTR)); + + if (bytesRead < 0) { + *errorCodePtr = errno; + return -1; } - *errorCodePtr = errno; - return -1; + return bytesRead; } /* diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 74b4bf3..9e43c01 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -1009,6 +1009,9 @@ TclWinCPUID( : "a"(index)); #endif status = TCL_OK; +#else + (void)index; + (void)regsPtr; #endif return status; } diff --git a/unix/tclUnixEvent.c b/unix/tclUnixEvent.c index aff7797..0047dd9 100644 --- a/unix/tclUnixEvent.c +++ b/unix/tclUnixEvent.c @@ -64,7 +64,7 @@ Tcl_Sleep( } if ((vdelay.sec != 0) || (vdelay.usec != 0)) { - tclScaleTimeProcPtr(&vdelay, tclTimeClientData); + TclScaleTime(&vdelay); } delay.tv_sec = vdelay.sec; @@ -85,6 +85,8 @@ Tcl_Sleep( } } +#else +TCL_MAC_EMPTY_FILE(unix_tclUnixEvent_c) #endif /* HAVE_COREFOUNDATION */ /* * Local Variables: diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 4d08c1d..9e9a493 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -2350,7 +2350,7 @@ StatError( Tcl_Obj *fileName) /* The name of the file which caused the * error. */ { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s", TclGetString(fileName), Tcl_PosixError(interp))); } diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 203a118..1ab5d14 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -44,8 +44,8 @@ TclpFindExecutable( wchar_t buf[PATH_MAX]; char name[PATH_MAX * 3 + 1]; - GetModuleFileNameW(NULL, buf, PATH_MAX); - cygwin_conv_path(3, buf, name, PATH_MAX); + GetModuleFileNameW(NULL, buf, sizeof(buf)/sizeof(wchar_t)); + cygwin_conv_path(3, buf, name, sizeof(name)); length = strlen(name); if ((length > 4) && !strcasecmp(name + length - 4, ".exe")) { /* Strip '.exe' part. */ diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index d992d65..c1f00d5 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -2,10 +2,12 @@ * tclUnixNotfy.c -- * * This file contains subroutines shared by all notifier backend - * implementations on *nix platforms. + * implementations on *nix platforms. It is *included* by the epoll, + * kqueue and select notifier implementation files. * * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de> + * Copyright © 2021 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -45,8 +47,10 @@ static void AtForkChild(void); * *---------------------------------------------------------------------- */ + static void -StartNotifierThread(const char *proc) +StartNotifierThread( + const char *proc) { if (!notifierThreadRunning) { pthread_mutex_lock(¬ifierInitMutex); @@ -57,6 +61,7 @@ StartNotifierThread(const char *proc) } pthread_mutex_lock(¬ifierMutex); + /* * Wait for the notifier pipe to be created. */ @@ -76,7 +81,7 @@ StartNotifierThread(const char *proc) /* *---------------------------------------------------------------------- * - * Tcl_AlertNotifier -- + * TclpAlertNotifier -- * * Wake up the specified notifier from any thread. This routine is called * by the platform independent notifier code whenever the Tcl_ThreadAlert @@ -99,50 +104,97 @@ StartNotifierThread(const char *proc) */ void -Tcl_AlertNotifier( +TclpAlertNotifier( ClientData clientData) { - if (tclNotifierHooks.alertNotifierProc) { - tclNotifierHooks.alertNotifierProc(clientData); - return; - } else { #ifdef NOTIFIER_SELECT #if TCL_THREADS - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; - pthread_mutex_lock(¬ifierMutex); - tsdPtr->eventReady = 1; + pthread_mutex_lock(¬ifierMutex); + tsdPtr->eventReady = 1; # ifdef __CYGWIN__ - PostMessageW(tsdPtr->hwnd, 1024, 0, 0); + PostMessageW(tsdPtr->hwnd, 1024, 0, 0); # else - pthread_cond_broadcast(&tsdPtr->waitCV); + pthread_cond_broadcast(&tsdPtr->waitCV); # endif /* __CYGWIN__ */ - pthread_mutex_unlock(¬ifierMutex); + pthread_mutex_unlock(¬ifierMutex); #endif /* TCL_THREADS */ #else /* !NOTIFIER_SELECT */ - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; #if defined(NOTIFIER_EPOLL) && defined(HAVE_EVENTFD) - uint64_t eventFdVal = 1; - if (write(tsdPtr->triggerEventFd, &eventFdVal, - sizeof(eventFdVal)) != sizeof(eventFdVal)) { - Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerEventFd", - (void *)tsdPtr); - } + uint64_t eventFdVal = 1; + + if (write(tsdPtr->triggerEventFd, &eventFdVal, + sizeof(eventFdVal)) != sizeof(eventFdVal)) { + Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerEventFd", + (void *) tsdPtr); + } #else - if (write(tsdPtr->triggerPipe[1], "", 1) != 1) { - Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerPipe", - (void *)tsdPtr); - } + if (write(tsdPtr->triggerPipe[1], "", 1) != 1) { + Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerPipe", + (void *) tsdPtr); + } #endif /* NOTIFIER_EPOLL && HAVE_EVENTFD */ #endif /* NOTIFIER_SELECT */ +} + +/* + *---------------------------------------------------------------------- + * + * LookUpFileHandler -- + * + * Look up the file handler structure (and optionally the previous one in + * the chain) associated with a file descriptor. + * + * Returns: + * A pointer to the file handler, or NULL if it can't be found. + * + * Side effects: + * If prevPtrPtr is non-NULL, it will be written to if the file handler + * is found. + * + *---------------------------------------------------------------------- + */ + +static inline FileHandler * +LookUpFileHandler( + ThreadSpecificData *tsdPtr, /* Where to look things up. */ + int fd, /* What we are looking for. */ + FileHandler **prevPtrPtr) /* If non-NULL, where to report the previous + * pointer. */ +{ + FileHandler *filePtr, *prevPtr; + + /* + * Find the entry for the given file (and return if there isn't one). + */ + + for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; + prevPtr = filePtr, filePtr = filePtr->nextPtr) { + if (filePtr == NULL) { + return NULL; + } + if (filePtr->fd == fd) { + break; + } + } + + /* + * Report what we've found to our caller. + */ + + if (prevPtrPtr) { + *prevPtrPtr = prevPtr; } + return filePtr; } /* *---------------------------------------------------------------------- * - * Tcl_SetTimer -- + * TclpSetTimer -- * * This function sets the current notifier timer value. This interface is * not implemented in this notifier because we are always running inside @@ -158,19 +210,14 @@ Tcl_AlertNotifier( */ void -Tcl_SetTimer( - const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ +TclpSetTimer( + TCL_UNUSED(const Tcl_Time *)) /* Timeout value, may be NULL. */ { - if (tclNotifierHooks.setTimerProc) { - tclNotifierHooks.setTimerProc(timePtr); - return; - } else { - /* - * The interval timer doesn't do anything in this implementation, - * because the only event loop is via Tcl_DoOneEvent, which passes - * timeout values to Tcl_WaitForEvent. - */ - } + /* + * The interval timer doesn't do anything in this implementation, because + * the only event loop is via Tcl_DoOneEvent, which passes timeout values + * to Tcl_WaitForEvent. + */ } /* @@ -190,14 +237,11 @@ Tcl_SetTimer( */ void -Tcl_ServiceModeHook( +TclpServiceModeHook( int mode) /* Either TCL_SERVICE_ALL, or * TCL_SERVICE_NONE. */ { - if (tclNotifierHooks.serviceModeHookProc) { - tclNotifierHooks.serviceModeHookProc(mode); - return; - } else if (mode == TCL_SERVICE_ALL) { + if (mode == TCL_SERVICE_ALL) { #ifdef NOTIFIER_SELECT #if TCL_THREADS StartNotifierThread("Tcl_ServiceModeHook"); @@ -414,12 +458,9 @@ AtForkChild(void) Tcl_InitNotifier(); } #endif /* HAVE_PTHREAD_ATFORK */ - #endif /* TCL_THREADS */ - #endif /* NOTIFIER_SELECT */ -#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is - * in tclMacOSXNotify.c */ + /* *---------------------------------------------------------------------- * @@ -443,6 +484,9 @@ AtForkChild(void) *---------------------------------------------------------------------- */ +#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is + * in tclMacOSXNotify.c */ + int TclUnixWaitForFile( int fd, /* Handle for file on which to wait. */ @@ -563,9 +607,8 @@ TclUnixWaitForFile( || (abortTime.sec == now.sec && abortTime.usec > now.usec)); return result; } - #endif /* !HAVE_COREFOUNDATION */ - + /* * Local Variables: * mode: c diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index e2f1104..ece0202 100644 --- a/unix/tclUnixPort.h +++ b/unix/tclUnixPort.h @@ -95,6 +95,8 @@ extern "C" { # define GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS 0x00000004 # define HANDLE void * # define HINSTANCE void * +# define HMODULE void * +# define MAX_PATH 260 # define SOCKET unsigned int # define WSAEWOULDBLOCK 10035 typedef unsigned short WCHAR; diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index adeacb6..e0c7ac8 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -61,6 +61,23 @@ Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime; void *tclTimeClientData = NULL; /* + * Inlined version of Tcl_GetTime. + */ + +static inline void +GetTime( + Tcl_Time *timePtr) +{ + tclGetTimeProcPtr(timePtr, tclTimeClientData); +} + +static inline int +IsTimeNative(void) +{ + return tclGetTimeProcPtr == NativeGetTime; +} + +/* *---------------------------------------------------------------------- * * TclpGetSeconds -- @@ -105,8 +122,8 @@ TclpGetMicroseconds(void) { Tcl_Time time; - tclGetTimeProcPtr(&time, tclTimeClientData); - return ((long long)time.sec)*1000000 + time.usec; + GetTime(&time); + return ((long long) time.sec)*1000000 + time.usec; } /* @@ -134,10 +151,10 @@ TclpGetClicks(void) unsigned long now; #ifdef NO_GETTOD - if (tclGetTimeProcPtr != NativeGetTime) { + if (!IsTimeNative()) { Tcl_Time time; - tclGetTimeProcPtr(&time, tclTimeClientData); + GetTime(&time); now = time.sec*1000000 + time.usec; } else { /* @@ -147,12 +164,12 @@ TclpGetClicks(void) now = (unsigned long) times(&dummy); } -#else +#else /* !NO_GETTOD */ Tcl_Time time; - tclGetTimeProcPtr(&time, tclTimeClientData); + GetTime(&time); now = time.sec*1000000 + time.usec; -#endif +#endif /* NO_GETTOD */ return now; } @@ -182,17 +199,17 @@ TclpGetWideClicks(void) { long long now; - if (tclGetTimeProcPtr != NativeGetTime) { + if (!IsTimeNative()) { Tcl_Time time; - tclGetTimeProcPtr(&time, tclTimeClientData); - now = ((long long)time.sec)*1000000 + time.usec; + GetTime(&time); + now = ((long long) time.sec)*1000000 + time.usec; } else { #ifdef MAC_OSX_TCL now = (long long) (mach_absolute_time() & INT64_MAX); #else #error Wide high-resolution clicks not implemented on this platform -#endif +#endif /* MAC_OSX_TCL */ } return now; @@ -221,7 +238,7 @@ TclpWideClicksToNanoseconds( { double nsec; - if (tclGetTimeProcPtr != NativeGetTime) { + if (!IsTimeNative()) { nsec = clicks * 1000; } else { #ifdef MAC_OSX_TCL @@ -239,7 +256,7 @@ TclpWideClicksToNanoseconds( } #else #error Wide high-resolution clicks not implemented on this platform -#endif +#endif /* MAC_OSX_TCL */ } return nsec; @@ -266,7 +283,7 @@ TclpWideClicksToNanoseconds( double TclpWideClickInMicrosec(void) { - if (tclGetTimeProcPtr != NativeGetTime) { + if (!IsTimeNative()) { return 1.0; } else { #ifdef MAC_OSX_TCL @@ -286,7 +303,7 @@ TclpWideClickInMicrosec(void) } #else #error Wide high-resolution clicks not implemented on this platform -#endif +#endif /* MAC_OSX_TCL */ } } #endif /* TCL_WIDE_CLICKS */ @@ -315,7 +332,7 @@ void Tcl_GetTime( Tcl_Time *timePtr) /* Location to store time information. */ { - tclGetTimeProcPtr(timePtr, tclTimeClientData); + GetTime(timePtr); } /* @@ -578,7 +595,7 @@ SetTZIfNecessary(void) } else { ckfree(lastTZ); } - lastTZ = (char *)ckalloc(strlen(newTZ) + 1); + lastTZ = (char *) ckalloc(strlen(newTZ) + 1); strcpy(lastTZ, newTZ); } Tcl_MutexUnlock(&tmMutex); diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c index 68ee578..3d90135 100644 --- a/unix/tclXtNotify.c +++ b/unix/tclXtNotify.c @@ -132,7 +132,7 @@ TclSetAppContext( * after initialization, so we panic. */ - Tcl_Panic("TclSetAppContext: multiple application contexts"); + Tcl_Panic("TclSetAppContext: multiple application contexts"); } } else { /* @@ -359,7 +359,7 @@ CreateFileHandler( } } if (filePtr == NULL) { - filePtr = (FileHandler *)ckalloc(sizeof(FileHandler)); + filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->read = 0; filePtr->write = 0; @@ -496,7 +496,7 @@ FileProc( int *fd, XtInputId *id) { - FileHandler *filePtr = (FileHandler *)clientData; + FileHandler *filePtr = (FileHandler *) clientData; FileHandlerEvent *fileEvPtr; int mask = 0; @@ -525,7 +525,7 @@ FileProc( */ filePtr->readyMask |= mask; - fileEvPtr = (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent)); + fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c index afac493..882f497 100644 --- a/unix/tclXtTest.c +++ b/unix/tclXtTest.c @@ -16,7 +16,6 @@ #include "tcl.h" static Tcl_ObjCmdProc TesteventloopCmd; -extern DLLEXPORT Tcl_PackageInitProc Tclxttest_Init; /* * Functions defined in tclXtNotify.c for use by users of the Xt Notifier: @@ -44,7 +43,7 @@ extern XtAppContext TclSetAppContext(XtAppContext ctx); *---------------------------------------------------------------------- */ -int +DLLEXPORT int Tclxttest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { diff --git a/win/Makefile.in b/win/Makefile.in index cdaeec4..3d68bda 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -524,15 +524,6 @@ ${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} ${DDE_DLL_FILE} ${REG_DLL_FILE} @mkdir -p ${TCL_VFS_PATH} @echo "creating ${TCL_VFS_PATH} (prepare compression)" @( \ - $(LN) $$(find $(TOP_DIR)/library/* -maxdepth 0 -type f) ${TCL_VFS_PATH}/ && \ - (for D in $$(find $(TOP_DIR)/library/* -maxdepth 0 -type d); do \ - mkdir -p "${TCL_VFS_PATH}/$$(basename $$D)"; \ - $(LN) -s $$D/* ${TCL_VFS_PATH}/$$(basename $$D)/; \ - done) && \ - $(LN) ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl && \ - $(LN) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde/ && \ - $(LN) ${REG_DLL_FILE} ${TCL_VFS_PATH}/registry/ \ - ) || ( \ $(COPY) -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \ $(COPY) -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \ $(COPY) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde; \ @@ -869,8 +860,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done; - @echo "Installing package http 2.10.0a1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10.0a1.tm"; + @echo "Installing package http 2.10a1 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10a1.tm"; @echo "Installing package opt 0.4.7"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ diff --git a/win/configure b/win/configure index 4659c61..e484ff0 100755 --- a/win/configure +++ b/win/configure @@ -4365,7 +4365,7 @@ printf %s "checking compiler flags... " >&6; } SHLIB_LD_LIBS='${LIBS}' LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32" # mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't - LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32" + LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32 -lwinspool" STLIB_LD='${AR} cr' RC_OUT=-o RC_TYPE= @@ -4571,7 +4571,7 @@ printf "%s\n" " Using 64-bit $MACHINE mode" >&6; } LINKBIN="link" fi - LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" + LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib winspool.lib" SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" SHLIB_LD_LIBS='${LIBS}' diff --git a/win/makefile.vc b/win/makefile.vc index 49a82d2..b5bb1a0 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -954,24 +954,6 @@ install-binaries: @$(CPY) "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)\"
install-libraries: tclConfig tcl-nmake install-msgs install-tzdata
- @if not exist "$(SCRIPT_INSTALL_DIR)" \
- $(MKDIR) "$(SCRIPT_INSTALL_DIR)"
- @if not exist "$(SCRIPT_INSTALL_DIR)\opt0.4" \
- $(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
- @if not exist "$(SCRIPT_INSTALL_DIR)\cookiejar0.2" \
- $(MKDIR) "$(SCRIPT_INSTALL_DIR)\cookiejar0.2"
- @if not exist "$(MODULE_INSTALL_DIR)" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)"
- @if not exist "$(MODULE_INSTALL_DIR)\8.4" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4"
- @if not exist "$(MODULE_INSTALL_DIR)\8.4\platform" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4\platform"
- @if not exist "$(MODULE_INSTALL_DIR)\8.5" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.5"
- @if not exist "$(MODULE_INSTALL_DIR)\8.6" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.6"
- @if not exist "$(MODULE_INSTALL_DIR)\8.7" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.7"
@if not exist "$(LIB_INSTALL_DIR)\nmake" \
$(MKDIR) "$(LIB_INSTALL_DIR)\nmake"
@echo Installing header files
@@ -985,6 +967,8 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata @$(CPY) "$(TOMMATHDIR)\tommath.h" "$(INCLUDE_INSTALL_DIR)\"
!if !$(TCL_EMBED_SCRIPTS)
@echo Installing library files to $(SCRIPT_INSTALL_DIR)
+ @if not exist "$(SCRIPT_INSTALL_DIR)" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)"
@$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\"
@@ -1005,23 +989,39 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata @$(CPY) "$(OUT_DIR)\tcl.nmake" "$(LIB_INSTALL_DIR)\nmake\"
!if !$(TCL_EMBED_SCRIPTS)
@echo Installing package cookiejar $(PKG_COOKIEJAR_VER)
+ @if not exist "$(SCRIPT_INSTALL_DIR)\cookiejar0.2" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\cookiejar0.2"
@$(CPY) "$(ROOT)\library\cookiejar\*.tcl" \
"$(SCRIPT_INSTALL_DIR)\cookiejar0.2\"
@$(CPY) "$(ROOT)\library\cookiejar\*.gz" \
"$(SCRIPT_INSTALL_DIR)\cookiejar0.2\"
@echo Installing package opt $(PKG_OPT_VER)
+ @if not exist "$(SCRIPT_INSTALL_DIR)\opt0.4" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
@$(CPY) "$(ROOT)\library\opt\*.tcl" \
"$(SCRIPT_INSTALL_DIR)\opt0.4\"
+ @if not exist "$(MODULE_INSTALL_DIR)" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)"
@echo Installing package http $(PKG_HTTP_VER) as a Tcl Module
+ @if not exist "$(MODULE_INSTALL_DIR)\8.6" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.6"
@$(COPY) "$(ROOT)\library\http\http.tcl" \
"$(MODULE_INSTALL_DIR)\8.6\http-$(PKG_HTTP_VER).tm"
@echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module
+ @if not exist "$(MODULE_INSTALL_DIR)\8.7" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.7"
@$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \
"$(MODULE_INSTALL_DIR)\8.7\msgcat-$(PKG_MSGCAT_VER).tm"
@echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module
+ @if not exist "$(MODULE_INSTALL_DIR)\8.5" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.5"
@$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \
"$(MODULE_INSTALL_DIR)\8.5\tcltest-$(PKG_TCLTEST_VER).tm"
@echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module
+ @if not exist "$(MODULE_INSTALL_DIR)\8.4" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4"
+ @if not exist "$(MODULE_INSTALL_DIR)\8.4\platform" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4\platform"
@$(COPY) "$(ROOT)\library\platform\platform.tcl" \
"$(MODULE_INSTALL_DIR)\8.4\platform-$(PKG_PLATFORM_VER).tm"
@echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module
diff --git a/win/rules.vc b/win/rules.vc index 2ec5292..c24fce3 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1123,7 +1123,7 @@ STUBPREFIX = $(PROJECT)stub # TIP 430. Unused for 8.6 but no harm defining it to allow a common rules.vc
TCLSCRIPTZIPNAME = libtcl$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)$(TCL_PATCH_LETTER)$(TCL_RELEASE_SERIAL).zip
-TKSCRIPTZIPNAME = libtk$(TK_MAJOR_VERSION)$(TK_MINOR_VERSION)$(TK_PATCH_LETTER)$(TK_RELEASE_SERIAL).zip
+TKSCRIPTZIPNAME = libtk$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)$(TK_PATCH_LETTER)$(TK_RELEASE_SERIAL).zip
!if $(DOING_TCL)
TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe
@@ -1203,9 +1203,16 @@ TCLSH_NATIVE = $(TCLSH) !if $(DOING_TK) || $(NEED_TK)
WISHNAMEPREFIX = wish
WISHNAME = $(WISHNAMEPREFIX)$(TK_VERSION)$(SUFX).exe
-TKLIBNAME = $(PROJECT)$(TK_VERSION)$(SUFX).$(EXT)
-TKSTUBLIBNAME = tkstub$(TK_VERSION).lib
+TKLIBNAME8 = tk$(TK_VERSION)$(SUFX).$(EXT)
+TKLIBNAME9 = tcl9tk$(TK_VERSION)$(SUFX).$(EXT)
+!if $(TCL_MAJOR_VERSION) == 8
+TKLIBNAME = tk$(TK_VERSION)$(SUFX).$(EXT)
TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib
+!else
+TKLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).$(EXT)
+TKIMPLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).lib
+!endif
+TKSTUBLIBNAME = tkstub$(TK_VERSION).lib
!if $(DOING_TK)
WISH = $(OUT_DIR)\$(WISHNAME)
@@ -1253,7 +1260,13 @@ tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" # Various output paths
PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
-PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT)
+PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT)
+PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX).$(EXT)
+!if $(TCL_MAJOR_VERSION) == 8
+PRJLIBNAME = $(PRJLIBNAME8)
+!else
+PRJLIBNAME = $(PRJLIBNAME9)
+!endif
PRJLIB = $(OUT_DIR)\$(PRJLIBNAME)
PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib
@@ -1583,12 +1596,22 @@ default-target: $(DEFAULT_BUILD_TARGET) !if $(MULTIPLATFORM_INSTALL)
default-pkgindex:
+ @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl
@echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
- [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl
+ [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl
+ @echo } else { >> $(OUT_DIR)\pkgIndex.tcl
+ @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
+ [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME8)]] >> $(OUT_DIR)\pkgIndex.tcl
+ @echo } >> $(OUT_DIR)\pkgIndex.tcl
!else
default-pkgindex:
+ @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl
+ @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
+ [list load [file join $$dir $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl
+ @echo } else { >> $(OUT_DIR)\pkgIndex.tcl
@echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
- [list load [file join $$dir $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl
+ [list load [file join $$dir $(PRJLIBNAME8)]] >> $(OUT_DIR)\pkgIndex.tcl
+ @echo } >> $(OUT_DIR)\pkgIndex.tcl
!endif
default-pkgindex-tea:
@@ -1597,6 +1620,8 @@ default-pkgindex-tea: @PACKAGE_NAME@ $(PRJ_PACKAGE_TCLNAME)
@PACKAGE_TCLNAME@ $(PRJ_PACKAGE_TCLNAME)
@PKG_LIB_FILE@ $(PRJLIBNAME)
+@PKG_LIB_FILE8@ $(PRJLIBNAME8)
+@PKG_LIB_FILE9@ $(PRJLIBNAME9)
<<
default-install: default-install-binaries default-install-libraries
diff --git a/win/tcl.dsp b/win/tcl.dsp index 750aac9..cc9d173 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -824,7 +824,7 @@ SOURCE=..\doc\SplitPath.3 # End Source File
# Begin Source File
-SOURCE=..\doc\StaticPkg.3
+SOURCE=..\doc\StaticLibrary.3
# End Source File
# Begin Source File
@@ -631,7 +631,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_LD_LIBS='${LIBS}' LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32" # mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't - LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32" + LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32 -lwinspool" STLIB_LD='${AR} cr' RC_OUT=-o RC_TYPE= @@ -814,7 +814,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ LINKBIN="link" fi - LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" + LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib winspool.lib" SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" SHLIB_LD_LIBS='${LIBS}' @@ -1067,7 +1067,7 @@ AC_DEFUN([SC_PROG_TCLSH], [ AC_DEFUN([SC_BUILD_TCLSH], [ AC_MSG_CHECKING([for tclsh in Tcl build directory]) - BUILD_TCLSH=${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT} + BUILD_TCLSH=${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}\${EXESUFFIX} AC_MSG_RESULT($BUILD_TCLSH) AC_SUBST(BUILD_TCLSH) ]) diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 52ead8e..a10f8db 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -23,16 +23,20 @@ #include <locale.h> #include <stdlib.h> #include <tchar.h> +#if TCL_MAJOR_VERSION < 9 && TCL_MINOR_VERSION < 7 +# define Tcl_LibraryInitProc Tcl_PackageInitProc +# define Tcl_StaticLibrary Tcl_StaticPackage +#endif #ifdef TCL_TEST -extern Tcl_PackageInitProc Tcltest_Init; -extern Tcl_PackageInitProc Tcltest_SafeInit; +extern Tcl_LibraryInitProc Tcltest_Init; +extern Tcl_LibraryInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ #if defined(STATIC_BUILD) -extern Tcl_PackageInitProc Registry_Init; -extern Tcl_PackageInitProc Dde_Init; -extern Tcl_PackageInitProc Dde_SafeInit; +extern Tcl_LibraryInitProc Registry_Init; +extern Tcl_LibraryInitProc Dde_Init; +extern Tcl_LibraryInitProc Dde_SafeInit; #endif #if defined(__GNUC__) || defined(TCL_BROKEN_MAINARGS) @@ -168,19 +172,19 @@ Tcl_AppInit( if (Registry_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Registry", Registry_Init, NULL); + Tcl_StaticLibrary(interp, "Registry", Registry_Init, NULL); if (Dde_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Dde", Dde_Init, Dde_SafeInit); + Tcl_StaticLibrary(interp, "Dde", Dde_Init, Dde_SafeInit); #endif #ifdef TCL_TEST if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); + Tcl_StaticLibrary(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); #endif /* TCL_TEST */ /* diff --git a/win/tclWinChan.c b/win/tclWinChan.c index a4ec1ae..62991fc 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -421,7 +421,7 @@ FileCloseProc( && (GetStdHandle(STD_OUTPUT_HANDLE) != fileInfoPtr->handle) && (GetStdHandle(STD_ERROR_HANDLE) != fileInfoPtr->handle))) { if (CloseHandle(fileInfoPtr->handle) == FALSE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); errorCode = errno; } } @@ -497,7 +497,7 @@ FileSeekProc( DWORD winError = GetLastError(); if (winError != NO_ERROR) { - TclWinConvertError(winError); + Tcl_WinConvertError(winError); *errorCodePtr = errno; return -1; } @@ -509,7 +509,7 @@ FileSeekProc( DWORD winError = GetLastError(); if (winError != NO_ERROR) { - TclWinConvertError(winError); + Tcl_WinConvertError(winError); *errorCodePtr = errno; return -1; } @@ -573,7 +573,7 @@ FileWideSeekProc( DWORD winError = GetLastError(); if (winError != NO_ERROR) { - TclWinConvertError(winError); + Tcl_WinConvertError(winError); *errorCodePtr = errno; return -1; } @@ -616,7 +616,7 @@ FileTruncateProc( DWORD winError = GetLastError(); if (winError != NO_ERROR) { - TclWinConvertError(winError); + Tcl_WinConvertError(winError); return errno; } } @@ -632,7 +632,7 @@ FileTruncateProc( DWORD winError = GetLastError(); if (winError != NO_ERROR) { - TclWinConvertError(winError); + Tcl_WinConvertError(winError); return errno; } } @@ -643,7 +643,7 @@ FileTruncateProc( */ if (!SetEndOfFile(infoPtr->handle)) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return errno; } @@ -703,7 +703,7 @@ FileInputProc( return bytesRead; } - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); *errorCode = errno; if (errno == EPIPE) { return 0; @@ -752,7 +752,7 @@ FileOutputProc( if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); *errorCode = errno; return -1; } @@ -927,7 +927,7 @@ TclpOpenFileChannel( if (NativeIsComPort(nativeName)) { handle = TclWinSerialOpen(INVALID_HANDLE_VALUE, nativeName, accessMode); if (handle == INVALID_HANDLE_VALUE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open serial \"%s\": %s", @@ -984,7 +984,7 @@ TclpOpenFileChannel( err = TEST_FLAG(mode, O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; } - TclWinConvertError(err); + Tcl_WinConvertError(err); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open \"%s\": %s", @@ -1008,7 +1008,7 @@ TclpOpenFileChannel( handle = TclWinSerialOpen(handle, nativeName, accessMode); if (handle == INVALID_HANDLE_VALUE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't reopen serial \"%s\": %s", diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 0556646..c3ba814 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -602,7 +602,7 @@ ConsoleCloseProc( && (GetStdHandle(STD_OUTPUT_HANDLE) != consolePtr->handle) && (GetStdHandle(STD_ERROR_HANDLE) != consolePtr->handle))) { if (CloseHandle(consolePtr->handle) == FALSE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); errorCode = errno; } } @@ -772,7 +772,7 @@ ConsoleOutputProc( */ if (infoPtr->writeError) { - TclWinConvertError(infoPtr->writeError); + Tcl_WinConvertError(infoPtr->writeError); infoPtr->writeError = 0; goto error; } @@ -807,7 +807,7 @@ ConsoleOutputProc( if (WriteConsoleBytes(infoPtr->handle, buf, (DWORD) toWrite, &bytesWritten) == FALSE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); goto error; } } @@ -1065,7 +1065,7 @@ WaitForRead( * Check to see if the peek failed because of EOF. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (errno == EOF) { infoPtr->readFlags |= CONSOLE_EOF; @@ -1477,7 +1477,7 @@ ConsoleSetOptionProc( DWORD mode; if (GetConsoleMode(infoPtr->handle, &mode) == 0) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read console mode: %s", @@ -1509,7 +1509,7 @@ ConsoleSetOptionProc( return TCL_ERROR; } if (SetConsoleMode(infoPtr->handle, mode) == 0) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't set console mode: %s", @@ -1589,7 +1589,7 @@ ConsoleGetOptionProc( valid = 1; if (GetConsoleMode(infoPtr->handle, &mode) == 0) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read console mode: %s", @@ -1620,7 +1620,7 @@ ConsoleGetOptionProc( valid = 1; if (!GetConsoleScreenBufferInfo(infoPtr->handle, &consoleInfo)) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read console size: %s", diff --git a/win/tclWinError.c b/win/tclWinError.c index e85becc..7e5898b 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -334,7 +334,7 @@ static const unsigned char wsaErrorTable[] = { /* *---------------------------------------------------------------------- * - * TclWinConvertError -- + * Tcl_WinConvertError -- * * This routine converts a Win32 error into an errno value. * @@ -348,8 +348,8 @@ static const unsigned char wsaErrorTable[] = { */ void -TclWinConvertError( - DWORD errCode) /* Win32 error code. */ +Tcl_WinConvertError( + unsigned errCode) /* Win32 error code. */ { if (errCode >= sizeof(errorTable)/sizeof(errorTable[0])) { errCode -= WSAEWOULDBLOCK; diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index c88621c..3f6d7f4 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -279,7 +279,7 @@ DoRenameFile( return retval; } - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); srcAttr = GetFileAttributesW(nativeSrc); dstAttr = GetFileAttributesW(nativeDst); @@ -420,7 +420,7 @@ DoRenameFile( * be, but report this one. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); CreateDirectoryW(nativeDst, NULL); SetFileAttributesW(nativeDst, dstAttr); if (Tcl_GetErrno() == EACCES) { @@ -488,7 +488,7 @@ DoRenameFile( * error. Could happen if an open file refers to dst. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { /* * Decode the EACCES to a more meaningful error. @@ -669,7 +669,7 @@ DoCopyFile( return retval; } - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (Tcl_GetErrno() == EBADF) { Tcl_SetErrno(EACCES); return TCL_ERROR; @@ -706,7 +706,7 @@ DoCopyFile( * attributes of dst. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); SetFileAttributesW(nativeDst, dstAttr); } } @@ -766,7 +766,7 @@ TclpDeleteFile( if (DeleteFileW(path) != FALSE) { return TCL_OK; } - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { attr = GetFileAttributesW(path); @@ -797,7 +797,7 @@ TclpDeleteFile( (DeleteFileW(path) != FALSE)) { return TCL_OK; } - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (res != 0) { SetFileAttributesW(path, attr); } @@ -866,7 +866,7 @@ DoCreateDirectory( if (CreateDirectoryW(nativePath, NULL) == 0) { DWORD error = GetLastError(); - TclWinConvertError(error); + Tcl_WinConvertError(error); return TCL_ERROR; } return TCL_OK; @@ -1054,7 +1054,7 @@ DoRemoveJustDirectory( } } - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { attr = GetFileAttributesW(nativePath); @@ -1088,7 +1088,7 @@ DoRemoveJustDirectory( if (RemoveDirectoryW(nativePath) != FALSE) { return TCL_OK; } - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); SetFileAttributesW(nativePath, attr | FILE_ATTRIBUTE_READONLY); } @@ -1235,7 +1235,7 @@ TraverseWinTree( * Can't read directory. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); nativeErrfile = nativeSource; goto end; } @@ -1329,7 +1329,7 @@ TraverseWinTree( end: if (nativeErrfile != NULL) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (errorPtr != NULL) { Tcl_DStringInit(errorPtr); Tcl_WCharToUtfDString(nativeErrfile, -1, errorPtr); @@ -1384,7 +1384,7 @@ TraversalCopy( attr) != FALSE) { return TCL_OK; } - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); } break; case DOTREE_POSTD: @@ -1482,7 +1482,7 @@ StatError( Tcl_Obj *fileName) /* The name of the file which caused the * error. */ { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s", TclGetString(fileName), Tcl_PosixError(interp))); } @@ -2067,7 +2067,7 @@ TclpCreateTemporaryDirectory( */ if (error != ERROR_SUCCESS) { - TclWinConvertError(error); + Tcl_WinConvertError(error); Tcl_DStringFree(&base); return NULL; } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index f89b522..f54349b 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -209,7 +209,7 @@ WinLink( * Invalid file. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return -1; } @@ -233,7 +233,7 @@ WinLink( * Invalid file. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return -1; } @@ -247,7 +247,7 @@ WinLink( * The target doesn't exist. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* * It is a file. @@ -262,7 +262,7 @@ WinLink( return 0; } - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); } else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { if (CreateSymbolicLinkW(linkSourcePath, linkTargetPath, 0x2 /* SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE */)) { @@ -272,7 +272,7 @@ WinLink( return 0; } else { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); } } else { Tcl_SetErrno(ENODEV); @@ -327,7 +327,7 @@ WinReadLink( * Invalid file. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return NULL; } @@ -341,7 +341,7 @@ WinReadLink( * The source doesn't exist. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return NULL; } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { @@ -502,7 +502,7 @@ TclWinSymLinkDelete( * Error setting junction. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); CloseHandle(hFile); } else { CloseHandle(hFile); @@ -695,7 +695,7 @@ NativeReadReparse( * Error creating directory. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return -1; } @@ -709,7 +709,7 @@ NativeReadReparse( * Error setting junction. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); CloseHandle(hFile); return -1; } @@ -751,7 +751,7 @@ NativeWriteReparse( * Error creating directory. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return -1; } hFile = CreateFileW(linkDirPath, GENERIC_WRITE, 0, NULL, @@ -762,7 +762,7 @@ NativeWriteReparse( * Error creating directory. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return -1; } @@ -777,7 +777,7 @@ NativeWriteReparse( * Error setting junction. */ - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); CloseHandle(hFile); RemoveDirectoryW(linkDirPath); return -1; @@ -885,7 +885,7 @@ TclpFindExecutable( Tcl_SetPanicProc(tclWinDebugPanic); } - GetModuleFileNameW(NULL, wName, MAX_PATH); + GetModuleFileNameW(NULL, wName, sizeof(wName)/sizeof(WCHAR)); WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); TclWinNoBackslash(name); TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL); @@ -1057,7 +1057,7 @@ TclpMatchInDirectory( return TCL_OK; } - TclWinConvertError(err); + Tcl_WinConvertError(err); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read directory \"%s\": %s", @@ -1606,7 +1606,7 @@ NativeAccess( DWORD lasterror = GetLastError(); if (lasterror != ERROR_SHARING_VIOLATION) { - TclWinConvertError(lasterror); + Tcl_WinConvertError(lasterror); return -1; } } @@ -1732,7 +1732,7 @@ NativeAccess( * to EACCES - just what we want! */ - TclWinConvertError((DWORD) error); + Tcl_WinConvertError((DWORD) error); return -1; } @@ -1837,7 +1837,7 @@ NativeAccess( */ accessError: - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (sdPtr != NULL) { HeapFree(GetProcessHeap(), 0, sdPtr); } @@ -1894,7 +1894,6 @@ NativeIsExec( if ((_wcsicmp(path, L"exe") == 0) || (_wcsicmp(path, L"com") == 0) || (_wcsicmp(path, L"cmd") == 0) - || (_wcsicmp(path, L"cmd") == 0) || (_wcsicmp(path, L"bat") == 0)) { return 1; } @@ -1932,7 +1931,7 @@ TclpObjChdir( result = SetCurrentDirectoryW(nativePath); if (result == 0) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return -1; } return 0; @@ -1971,7 +1970,7 @@ TclpGetCwd( WCHAR *native; if (GetCurrentDirectoryW(MAX_PATH, buffer) == 0) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error getting working directory name: %s", @@ -2136,12 +2135,12 @@ NativeStat( DWORD lasterror = GetLastError(); if (lasterror != ERROR_SHARING_VIOLATION) { - TclWinConvertError(lasterror); + Tcl_WinConvertError(lasterror); return -1; } hFind = FindFirstFileW(nativePath, &ffd); if (hFind == INVALID_HANDLE_VALUE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return -1; } memcpy(&data, &ffd, sizeof(data)); @@ -2370,7 +2369,7 @@ TclpGetNativeCwd( WCHAR buffer[MAX_PATH]; if (GetCurrentDirectoryW(MAX_PATH, buffer) == 0) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return NULL; } @@ -3271,7 +3270,7 @@ TclpUtime( if (fileHandle == INVALID_HANDLE_VALUE || !SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); res = -1; } if (fileHandle != INVALID_HANDLE_VALUE) { diff --git a/win/tclWinInit.c b/win/tclWinInit.c index a50d9eb..2830a85 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -334,8 +334,8 @@ InitializeDefaultLibraryDir( char name[(MAX_PATH + LIBRARY_SIZE) * 3]; char *end, *p; - GetModuleFileNameW(hModule, wName, MAX_PATH); - WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, MAX_PATH * 3, NULL, NULL); + GetModuleFileNameW(hModule, wName, sizeof(wName)/sizeof(WCHAR)); + WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); end = strrchr(name, '\\'); *end = '\0'; @@ -382,8 +382,8 @@ InitializeSourceLibraryDir( char name[(MAX_PATH + LIBRARY_SIZE) * 3]; char *end, *p; - GetModuleFileNameW(hModule, wName, MAX_PATH); - WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, MAX_PATH * 3, NULL, NULL); + GetModuleFileNameW(hModule, wName, sizeof(wName)/sizeof(WCHAR)); + WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); end = strrchr(name, '\\'); *end = '\0'; diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 656148a..0f664f0 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -159,7 +159,7 @@ TclpDlopen( Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", -1); break; default: - TclWinConvertError(lastError); + Tcl_WinConvertError(lastError); Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1); } Tcl_SetObjResult(interp, errMsg); @@ -379,7 +379,7 @@ InitDLLDirectoryName(void) id *= 16777619; } - TclWinConvertError(lastError); + Tcl_WinConvertError(lastError); return TCL_ERROR; /* diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index fff7910..068675c 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -77,65 +77,62 @@ static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message, */ ClientData -Tcl_InitNotifier(void) +TclpInitNotifier(void) { - if (tclNotifierHooks.initNotifierProc) { - return tclNotifierHooks.initNotifierProc(); - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - TclpGlobalLock(); - if (!initialized) { - initialized = 1; - InitializeCriticalSection(¬ifierMutex); - } - TclpGlobalUnlock(); + TclpGlobalLock(); + if (!initialized) { + initialized = 1; + InitializeCriticalSection(¬ifierMutex); + } + TclpGlobalUnlock(); - /* - * Register Notifier window class if this is the first thread to use - * this module. - */ + /* + * Register Notifier window class if this is the first thread to use this + * module. + */ - EnterCriticalSection(¬ifierMutex); - if (notifierCount == 0) { - WNDCLASSW clazz; - - clazz.style = 0; - clazz.cbClsExtra = 0; - clazz.cbWndExtra = 0; - clazz.hInstance = TclWinGetTclInstance(); - clazz.hbrBackground = NULL; - clazz.lpszMenuName = NULL; - clazz.lpszClassName = className; - clazz.lpfnWndProc = NotifierProc; - clazz.hIcon = NULL; - clazz.hCursor = NULL; - - if (!RegisterClassW(&clazz)) { - Tcl_Panic("Unable to register TclNotifier window class"); - } + EnterCriticalSection(¬ifierMutex); + if (notifierCount == 0) { + WNDCLASSW clazz; + + clazz.style = 0; + clazz.cbClsExtra = 0; + clazz.cbWndExtra = 0; + clazz.hInstance = TclWinGetTclInstance(); + clazz.hbrBackground = NULL; + clazz.lpszMenuName = NULL; + clazz.lpszClassName = className; + clazz.lpfnWndProc = NotifierProc; + clazz.hIcon = NULL; + clazz.hCursor = NULL; + + if (!RegisterClassW(&clazz)) { + Tcl_Panic("Tcl_InitNotifier: %s", + "unable to register TclNotifier window class"); } - notifierCount++; - LeaveCriticalSection(¬ifierMutex); + } + notifierCount++; + LeaveCriticalSection(¬ifierMutex); - tsdPtr->pending = 0; - tsdPtr->timerActive = 0; + tsdPtr->pending = 0; + tsdPtr->timerActive = 0; - InitializeCriticalSection(&tsdPtr->crit); + InitializeCriticalSection(&tsdPtr->crit); - tsdPtr->hwnd = NULL; - tsdPtr->thread = GetCurrentThreadId(); - tsdPtr->event = CreateEventW(NULL, TRUE /* manual */, - FALSE /* !signaled */, NULL); + tsdPtr->hwnd = NULL; + tsdPtr->thread = GetCurrentThreadId(); + tsdPtr->event = CreateEventW(NULL, TRUE /* manual */, + FALSE /* !signaled */, NULL); - return tsdPtr; - } + return tsdPtr; } /* *---------------------------------------------------------------------- * - * Tcl_FinalizeNotifier -- + * TclpFinalizeNotifier -- * * This function is called to cleanup the notifier state before a thread * is terminated. @@ -150,62 +147,57 @@ Tcl_InitNotifier(void) */ void -Tcl_FinalizeNotifier( +TclpFinalizeNotifier( ClientData clientData) /* Pointer to notifier data. */ { - if (tclNotifierHooks.finalizeNotifierProc) { - tclNotifierHooks.finalizeNotifierProc(clientData); - return; - } else { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; - /* - * Only finalize the notifier if a notifier was installed in the - * current thread; there is a route in which this is not guaranteed to - * be true (when tclWin32Dll.c:DllMain() is called with the flag - * DLL_PROCESS_DETACH by the OS, which could be doing so from a thread - * that's never previously been involved with Tcl, e.g. the task - * manager) so this check is important. - * - * Fixes Bug #217982 reported by Hugh Vu and Gene Leache. - */ + /* + * Only finalize the notifier if a notifier was installed in the current + * thread; there is a route in which this is not guaranteed to be true + * (when tclWin32Dll.c:DllMain() is called with the flag + * DLL_PROCESS_DETACH by the OS, which could be doing so from a thread + * that's never previously been involved with Tcl, e.g. the task manager) + * so this check is important. + * + * Fixes Bug #217982 reported by Hugh Vu and Gene Leache. + */ - if (tsdPtr == NULL) { - return; - } + if (tsdPtr == NULL) { + return; + } - DeleteCriticalSection(&tsdPtr->crit); - CloseHandle(tsdPtr->event); + DeleteCriticalSection(&tsdPtr->crit); + CloseHandle(tsdPtr->event); - /* - * Clean up the timer and messaging window for this thread. - */ + /* + * Clean up the timer and messaging window for this thread. + */ - if (tsdPtr->hwnd) { - KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); - DestroyWindow(tsdPtr->hwnd); - } + if (tsdPtr->hwnd) { + KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); + DestroyWindow(tsdPtr->hwnd); + } - /* - * If this is the last thread to use the notifier, unregister the - * notifier window class. - */ + /* + * If this is the last thread to use the notifier, unregister the notifier + * window class. + */ - EnterCriticalSection(¬ifierMutex); - if (notifierCount) { - notifierCount--; - if (notifierCount == 0) { - UnregisterClassW(className, TclWinGetTclInstance()); - } + EnterCriticalSection(¬ifierMutex); + if (notifierCount) { + notifierCount--; + if (notifierCount == 0) { + UnregisterClassW(className, TclWinGetTclInstance()); } - LeaveCriticalSection(¬ifierMutex); } + LeaveCriticalSection(¬ifierMutex); } /* *---------------------------------------------------------------------- * - * Tcl_AlertNotifier -- + * TclpAlertNotifier -- * * Wake up the specified notifier from any thread. This routine is called * by the platform independent notifier code whenever the Tcl_ThreadAlert @@ -225,42 +217,37 @@ Tcl_FinalizeNotifier( */ void -Tcl_AlertNotifier( +TclpAlertNotifier( ClientData clientData) /* Pointer to thread data. */ { - if (tclNotifierHooks.alertNotifierProc) { - tclNotifierHooks.alertNotifierProc(clientData); - return; - } else { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; + + /* + * Note that we do not need to lock around access to the hwnd because the + * race condition has no effect since any race condition implies that the + * notifier thread is already awake. + */ + if (tsdPtr->hwnd) { /* - * Note that we do not need to lock around access to the hwnd because - * the race condition has no effect since any race condition implies - * that the notifier thread is already awake. + * We do need to lock around access to the pending flag. */ - if (tsdPtr->hwnd) { - /* - * We do need to lock around access to the pending flag. - */ - - EnterCriticalSection(&tsdPtr->crit); - if (!tsdPtr->pending) { - PostMessageW(tsdPtr->hwnd, WM_WAKEUP, 0, 0); - } - tsdPtr->pending = 1; - LeaveCriticalSection(&tsdPtr->crit); - } else { - SetEvent(tsdPtr->event); + EnterCriticalSection(&tsdPtr->crit); + if (!tsdPtr->pending) { + PostMessageW(tsdPtr->hwnd, WM_WAKEUP, 0, 0); } + tsdPtr->pending = 1; + LeaveCriticalSection(&tsdPtr->crit); + } else { + SetEvent(tsdPtr->event); } } /* *---------------------------------------------------------------------- * - * Tcl_SetTimer -- + * TclpSetTimer -- * * This procedure sets the current notifier timer value. The notifier * will ensure that Tcl_ServiceAll() is called after the specified @@ -276,54 +263,49 @@ Tcl_AlertNotifier( */ void -Tcl_SetTimer( +TclpSetTimer( const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { - if (tclNotifierHooks.setTimerProc) { - tclNotifierHooks.setTimerProc(timePtr); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + UINT timeout; + + /* + * We only need to set up an interval timer if we're being called from an + * external event loop. If we don't have a window handle then we just + * return immediately and let Tcl_WaitForEvent handle timeouts. + */ + + if (!tsdPtr->hwnd) { return; - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - UINT timeout; + } + if (!timePtr) { + timeout = 0; + } else { /* - * We only need to set up an interval timer if we're being called from - * an external event loop. If we don't have a window handle then we - * just return immediately and let Tcl_WaitForEvent handle timeouts. + * Make sure we pass a non-zero value into the timeout argument. + * Windows seems to get confused by zero length timers. */ - if (!tsdPtr->hwnd) { - return; + timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + if (timeout == 0) { + timeout = 1; } + } - if (!timePtr) { - timeout = 0; - } else { - /* - * Make sure we pass a non-zero value into the timeout argument. - * Windows seems to get confused by zero length timers. - */ - - timeout = timePtr->sec * 1000 + timePtr->usec / 1000; - if (timeout == 0) { - timeout = 1; - } - } - if (timeout != 0) { - tsdPtr->timerActive = 1; - SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, - timeout, NULL); - } else { - tsdPtr->timerActive = 0; - KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); - } + if (timeout != 0) { + tsdPtr->timerActive = 1; + SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, timeout, NULL); + } else { + tsdPtr->timerActive = 0; + KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); } } /* *---------------------------------------------------------------------- * - * Tcl_ServiceModeHook -- + * TclpServiceModeHook -- * * This function is invoked whenever the service mode changes. * @@ -338,40 +320,33 @@ Tcl_SetTimer( */ void -Tcl_ServiceModeHook( +TclpServiceModeHook( int mode) /* Either TCL_SERVICE_ALL, or * TCL_SERVICE_NONE. */ { - if (tclNotifierHooks.serviceModeHookProc) { - tclNotifierHooks.serviceModeHookProc(mode); - return; - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - /* - * If this is the first time that the notifier has been used from a - * modal loop, then create a communication window. Note that after this - * point, the application needs to service events in a timely fashion - * or Windows will hang waiting for the window to respond to - * synchronous system messages. At some point, we may want to consider - * destroying the window if we leave the modal loop, but for now we'll - * leave it around. - */ + /* + * If this is the first time that the notifier has been used from a modal + * loop, then create a communication window. Note that after this point, + * the application needs to service events in a timely fashion or Windows + * will hang waiting for the window to respond to synchronous system + * messages. At some point, we may want to consider destroying the window + * if we leave the modal loop, but for now we'll leave it around. + */ - if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { - tsdPtr->hwnd = CreateWindowW(className, className, - WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), - NULL); + if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { + tsdPtr->hwnd = CreateWindowW(className, className, WS_TILED, + 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); - /* - * Send an initial message to the window to ensure that we wake up - * the notifier once we get into the modal loop. This will force - * the notifier to recompute the timeout value and schedule a timer - * if one is needed. - */ + /* + * Send an initial message to the window to ensure that we wake up the + * notifier once we get into the modal loop. This will force the + * notifier to recompute the timeout value and schedule a timer if one + * is needed. + */ - Tcl_AlertNotifier(tsdPtr); - } + Tcl_AlertNotifier(tsdPtr); } } @@ -421,7 +396,7 @@ NotifierProc( /* *---------------------------------------------------------------------- * - * Tcl_WaitForEvent -- + * TclpWaitForEvent -- * * This function is called by Tcl_DoOneEvent to wait for new events on * the message queue. If the block time is 0, then Tcl_WaitForEvent just @@ -438,103 +413,99 @@ NotifierProc( */ int -Tcl_WaitForEvent( +TclpWaitForEvent( const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { - if (tclNotifierHooks.waitForEventProc) { - return tclNotifierHooks.waitForEventProc(timePtr); - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - MSG msg; - DWORD timeout, result; - int status; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + MSG msg; + DWORD timeout, result; + int status; + /* + * Compute the timeout in milliseconds. + */ + + if (timePtr) { /* - * Compute the timeout in milliseconds. + * TIP #233 (Virtualized Time). Convert virtual domain delay to + * real-time. */ - if (timePtr) { - /* - * TIP #233 (Virtualized Time). Convert virtual domain delay to - * real-time. - */ + Tcl_Time myTime; - Tcl_Time myTime; + myTime.sec = timePtr->sec; + myTime.usec = timePtr->usec; - myTime.sec = timePtr->sec; - myTime.usec = timePtr->usec; + if (myTime.sec != 0 || myTime.usec != 0) { + TclScaleTime(&myTime); + } - if (myTime.sec != 0 || myTime.usec != 0) { - tclScaleTimeProcPtr(&myTime, tclTimeClientData); - } + timeout = myTime.sec * 1000 + myTime.usec / 1000; + } else { + timeout = INFINITE; + } - timeout = myTime.sec * 1000 + myTime.usec / 1000; - } else { - timeout = INFINITE; - } + /* + * Check to see if there are any messages in the queue before waiting + * because MsgWaitForMultipleObjects will not wake up if there are events + * currently sitting in the queue. + */ + if (!PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) { /* - * Check to see if there are any messages in the queue before waiting - * because MsgWaitForMultipleObjects will not wake up if there are - * events currently sitting in the queue. + * Wait for something to happen (a signal from another thread, a + * message, or timeout) or loop servicing asynchronous procedure calls + * queued to this thread. */ - if (!PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) { - /* - * Wait for something to happen (a signal from another thread, a - * message, or timeout) or loop servicing asynchronous procedure - * calls queued to this thread. - */ - - again: + do { result = MsgWaitForMultipleObjectsEx(1, &tsdPtr->event, timeout, QS_ALLINPUT, MWMO_ALERTABLE); - if (result == WAIT_IO_COMPLETION) { - goto again; - } else if (result == WAIT_FAILED) { - status = -1; - goto end; - } + } while (result == WAIT_IO_COMPLETION); + + if (result == WAIT_FAILED) { + status = -1; + goto end; } + } + + /* + * Check to see if there are any messages to process. + */ + if (PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) { /* - * Check to see if there are any messages to process. + * Retrieve and dispatch the first message. */ - if (PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) { + result = GetMessageW(&msg, NULL, 0, 0); + if (result == 0) { /* - * Retrieve and dispatch the first message. + * We received a request to exit this thread (WM_QUIT), so + * propagate the quit message and start unwinding. */ - result = GetMessageW(&msg, NULL, 0, 0); - if (result == 0) { - /* - * We received a request to exit this thread (WM_QUIT), so - * propagate the quit message and start unwinding. - */ - - PostQuitMessage((int) msg.wParam); - status = -1; - } else if (result == (DWORD)-1) { - /* - * We got an error from the system. I have no idea why this - * would happen, so we'll just unwind. - */ - - status = -1; - } else { - TranslateMessage(&msg); - DispatchMessageW(&msg); - status = 1; - } + PostQuitMessage((int) msg.wParam); + status = -1; + } else if (result == (DWORD) -1) { + /* + * We got an error from the system. I have no idea why this would + * happen, so we'll just unwind. + */ + + status = -1; } else { - status = 0; + TranslateMessage(&msg); + DispatchMessageW(&msg); + status = 1; } - - end: - ResetEvent(tsdPtr->event); - return status; + } else { + status = 0; } + + end: + ResetEvent(tsdPtr->event); + return status; } /* @@ -588,7 +559,7 @@ Tcl_Sleep( * TIP #233: Scale delay from virtual to real-time. */ - tclScaleTimeProcPtr(&vdelay, tclTimeClientData); + TclScaleTime(&vdelay); sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; for (;;) { @@ -603,7 +574,7 @@ Tcl_Sleep( vdelay.sec = desired.sec - now.sec; vdelay.usec = desired.usec - now.usec; - tclScaleTimeProcPtr(&vdelay, tclTimeClientData); + TclScaleTime(&vdelay); sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; } } diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 90ac9ef..29b1c03 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -549,7 +549,7 @@ TclpOpenFile( accessMode = (GENERIC_READ | GENERIC_WRITE); break; default: - TclWinConvertError(ERROR_INVALID_FUNCTION); + Tcl_WinConvertError(ERROR_INVALID_FUNCTION); return NULL; } @@ -613,7 +613,7 @@ TclpOpenFile( if ((err & 0xFFFFL) == ERROR_OPEN_FAILED) { err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; } - TclWinConvertError(err); + Tcl_WinConvertError(err); return NULL; } @@ -719,7 +719,7 @@ TclpCreateTempFile( Tcl_DStringFree(&dstring); } - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); CloseHandle(handle); DeleteFileW(name); return NULL; @@ -784,7 +784,7 @@ TclpCreatePipe( return 1; } - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return 0; } @@ -825,7 +825,7 @@ TclpCloseFile( && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) { if (filePtr->handle != NULL && CloseHandle(filePtr->handle) == FALSE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); ckfree(filePtr); return -1; } @@ -1026,7 +1026,7 @@ TclpCreateProcess( 0, TRUE, DUPLICATE_SAME_ACCESS); } if (startInfo.hStdInput == INVALID_HANDLE_VALUE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't duplicate input handle: %s", Tcl_PosixError(interp))); @@ -1055,7 +1055,7 @@ TclpCreateProcess( &startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS); } if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't duplicate output handle: %s", Tcl_PosixError(interp))); @@ -1075,7 +1075,7 @@ TclpCreateProcess( 0, TRUE, DUPLICATE_SAME_ACCESS); } if (startInfo.hStdError == INVALID_HANDLE_VALUE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't duplicate error handle: %s", Tcl_PosixError(interp))); @@ -1137,7 +1137,7 @@ TclpCreateProcess( if (CreateProcessW(NULL, (WCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", argv[0], Tcl_PosixError(interp))); goto end; @@ -1387,7 +1387,7 @@ ApplicationType( Tcl_DStringFree(&nameBuf); if (applType == APPL_NONE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", originalName, Tcl_PosixError(interp))); return APPL_NONE; @@ -1866,7 +1866,7 @@ Tcl_CreatePipe( sec.bInheritHandle = FALSE; if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "pipe creation failed: %s", Tcl_PosixError(interp))); return TCL_ERROR; @@ -2224,7 +2224,7 @@ PipeInputProc( return bytesRead; } - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); if (errno == EPIPE) { infoPtr->readFlags |= PIPE_EOF; return 0; @@ -2283,7 +2283,7 @@ PipeOutputProc( */ if (infoPtr->writeError) { - TclWinConvertError(infoPtr->writeError); + Tcl_WinConvertError(infoPtr->writeError); infoPtr->writeError = 0; goto error; } @@ -2318,7 +2318,7 @@ PipeOutputProc( if (WriteFile(filePtr->handle, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); goto error; } } @@ -2850,7 +2850,7 @@ WaitForRead( if (PeekNamedPipe(handle, (LPVOID) NULL, (DWORD) 0, (LPDWORD) NULL, &count, (LPDWORD) NULL) != TRUE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); /* * Check to see if the peek failed because of EOF. @@ -3260,7 +3260,7 @@ TclpOpenTemporaryFile( TCL_READABLE|TCL_WRITABLE); gotError: - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return NULL; } diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 32f4c31..403c9d5 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -645,7 +645,7 @@ SerialCloseProc( && (GetStdHandle(STD_OUTPUT_HANDLE) != serialPtr->handle) && (GetStdHandle(STD_ERROR_HANDLE) != serialPtr->handle))) { if (CloseHandle(serialPtr->handle) == FALSE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); errorCode = errno; } } @@ -928,7 +928,7 @@ SerialInputProc( if (SerialBlockingRead(infoPtr, (LPVOID) buf, (DWORD) bufSize, &bytesRead, &infoPtr->osRead) == FALSE) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); *errorCode = errno; return -1; } @@ -1010,7 +1010,7 @@ SerialOutputProc( */ if (infoPtr->writeError) { - TclWinConvertError(infoPtr->writeError); + Tcl_WinConvertError(infoPtr->writeError); infoPtr->writeError = 0; goto error1; } @@ -1069,7 +1069,7 @@ SerialOutputProc( return (int) bytesWritten; writeError: - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); error: /* @@ -1936,7 +1936,7 @@ SerialSetOptionProc( if (!SetupComm(infoPtr->handle, inSize, outSize)) { if (interp != NULL) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't setup comm buffers: %s", Tcl_PosixError(interp))); @@ -1987,7 +1987,7 @@ SerialSetOptionProc( tout.ReadTotalTimeoutConstant = msec; if (!SetCommTimeouts(infoPtr->handle, &tout)) { if (interp != NULL) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't set comm timeouts: %s", Tcl_PosixError(interp))); @@ -2004,7 +2004,7 @@ SerialSetOptionProc( getStateFailed: if (interp != NULL) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't get comm state: %s", Tcl_PosixError(interp))); } @@ -2012,7 +2012,7 @@ SerialSetOptionProc( setStateFailed: if (interp != NULL) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't set comm state: %s", Tcl_PosixError(interp))); } @@ -2095,7 +2095,7 @@ SerialGetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't get comm state: %s", Tcl_PosixError(interp))); } @@ -2165,7 +2165,7 @@ SerialGetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't get comm state: %s", Tcl_PosixError(interp))); } @@ -2243,7 +2243,7 @@ SerialGetOptionProc( if (!GetCommModemStatus(infoPtr->handle, &status)) { if (interp != NULL) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't get tty status: %s", Tcl_PosixError(interp))); } diff --git a/win/tclWinSock.c b/win/tclWinSock.c index a31e1a2..60575df 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -882,7 +882,7 @@ TcpInputProc( if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING) || (error != WSAEWOULDBLOCK)) { - TclWinConvertError(error); + Tcl_WinConvertError(error); *errorCodePtr = Tcl_GetErrno(); bytesRead = -1; break; @@ -996,7 +996,7 @@ TcpOutputProc( break; } } else { - TclWinConvertError(error); + Tcl_WinConvertError(error); *errorCodePtr = Tcl_GetErrno(); written = -1; break; @@ -1064,7 +1064,7 @@ TcpCloseProc( statePtr->sockets = thisfd->next; if (closesocket(thisfd->fd) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_WinConvertError((DWORD) WSAGetLastError()); errorCode = Tcl_GetErrno(); } ckfree(thisfd); @@ -1154,11 +1154,11 @@ TcpClose2Proc( */ if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->sockets->fd, SD_RECEIVE) == SOCKET_ERROR)) { - TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_WinConvertError((DWORD) WSAGetLastError()); readError = Tcl_GetErrno(); } if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->sockets->fd, SD_SEND) == SOCKET_ERROR)) { - TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_WinConvertError((DWORD) WSAGetLastError()); writeError = Tcl_GetErrno(); } return (readError != 0) ? readError : writeError; @@ -1225,7 +1225,7 @@ TcpSetOptionProc( rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (const char *) &val, sizeof(BOOL)); if (rtn != 0) { - TclWinConvertError(WSAGetLastError()); + Tcl_WinConvertError(WSAGetLastError()); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't set socket option: %s", @@ -1247,7 +1247,7 @@ TcpSetOptionProc( rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (const char *) &val, sizeof(BOOL)); if (rtn != 0) { - TclWinConvertError(WSAGetLastError()); + Tcl_WinConvertError(WSAGetLastError()); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't set socket option: %s", @@ -1382,7 +1382,7 @@ TcpGetOptionProc( */ if (err) { - TclWinConvertError(err); + Tcl_WinConvertError(err); Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); } @@ -1452,7 +1452,7 @@ TcpGetOptionProc( */ if (len) { - TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_WinConvertError((DWORD) WSAGetLastError()); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't get peername: %s", @@ -1528,7 +1528,7 @@ TcpGetOptionProc( Tcl_DStringEndSublist(dsPtr); } else { if (interp) { - TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_WinConvertError((DWORD) WSAGetLastError()); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't get sockname: %s", Tcl_PosixError(interp))); } @@ -1780,7 +1780,7 @@ TcpConnect( */ if (statePtr->sockets->fd == INVALID_SOCKET) { - TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_WinConvertError((DWORD) WSAGetLastError()); continue; } @@ -1805,7 +1805,7 @@ TcpConnect( if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr, statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_WinConvertError((DWORD) WSAGetLastError()); continue; } @@ -1876,7 +1876,7 @@ TcpConnect( statePtr->addr->ai_addrlen); error = WSAGetLastError(); - TclWinConvertError(error); + Tcl_WinConvertError(error); if (async_connect && error == WSAEWOULDBLOCK) { /* @@ -1908,7 +1908,7 @@ TcpConnect( * Get signaled connect error. */ - TclWinConvertError((DWORD) statePtr->notifierConnectError); + Tcl_WinConvertError((DWORD) statePtr->notifierConnectError); /* * Clear eventual connect flag. @@ -2237,7 +2237,7 @@ Tcl_OpenTcpServerEx( sock = socket(addrPtr->ai_family, addrPtr->ai_socktype, addrPtr->ai_protocol); if (sock == INVALID_SOCKET) { - TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_WinConvertError((DWORD) WSAGetLastError()); continue; } @@ -2288,7 +2288,7 @@ Tcl_OpenTcpServerEx( if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_WinConvertError((DWORD) WSAGetLastError()); closesocket(sock); continue; } @@ -2313,7 +2313,7 @@ Tcl_OpenTcpServerEx( */ if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_WinConvertError((DWORD) WSAGetLastError()); closesocket(sock); continue; } @@ -2498,7 +2498,7 @@ InitSockets(void) windowClass.hCursor = NULL; if (!RegisterClassW(&windowClass)) { - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); goto initFailure; } } diff --git a/win/tclWinTest.c b/win/tclWinTest.c index e924b1a..f45b557 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -208,7 +208,7 @@ TestvolumetypeCmd( if (found == 0) { Tcl_AppendResult(interp, "could not get volume type for \"", (path?path:""), "\"", NULL); - TclWinConvertError(GetLastError()); + Tcl_WinConvertError(GetLastError()); return TCL_ERROR; } Tcl_AppendResult(interp, volType, NULL); diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 64890c4..45338dd 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -53,7 +53,8 @@ typedef struct { * initialized. */ int perfCounterAvailable; /* Flag == 1 if the hardware has a performance * counter. */ - DWORD calibrationInterv; /* Calibration interval in seconds (start 1 sec) */ + DWORD calibrationInterv; /* Calibration interval in seconds (start 1 + * sec) */ HANDLE calibrationThread; /* Handle to the thread that keeps the virtual * clock calibrated. */ HANDLE readyEvent; /* System event used to trigger the requesting @@ -122,7 +123,8 @@ static TimeInfo timeInfo = { */ static struct { int initialized; /* 1 if initialized, 0 otherwise */ - int perfCounter; /* 1 if performance counter usable for wide clicks */ + int perfCounter; /* 1 if performance counter usable for wide + * clicks */ double microsecsScale; /* Denominator scale between clock / microsecs */ } wideClick = {0, 0, 0.0}; @@ -156,6 +158,23 @@ Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime; ClientData tclTimeClientData = NULL; /* + * Inlined version of Tcl_GetTime. + */ + +static inline void +GetTime( + Tcl_Time *timePtr) +{ + tclGetTimeProcPtr(timePtr, tclTimeClientData); +} + +static inline int +IsTimeNative(void) +{ + return tclGetTimeProcPtr == NativeGetTime; +} + +/* *---------------------------------------------------------------------- * * TclpGetSeconds -- @@ -177,15 +196,16 @@ TclpGetSeconds(void) { long long usecSincePosixEpoch; - /* Try to use high resolution timer */ - if ( tclGetTimeProcPtr == NativeGetTime - && (usecSincePosixEpoch = NativeGetMicroseconds()) - ) { + /* + * Try to use high resolution timer + */ + + if (IsTimeNative() && (usecSincePosixEpoch = NativeGetMicroseconds())) { return usecSincePosixEpoch / 1000000; } else { Tcl_Time t; - tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */ + GetTime(&t); return t.sec; } } @@ -214,11 +234,12 @@ TclpGetClicks(void) { long long usecSincePosixEpoch; - /* Try to use high resolution timer */ - if ( tclGetTimeProcPtr == NativeGetTime - && (usecSincePosixEpoch = NativeGetMicroseconds()) - ) { - return (unsigned long)usecSincePosixEpoch; + /* + * Try to use high resolution timer. + */ + + if (IsTimeNative() && (usecSincePosixEpoch = NativeGetMicroseconds())) { + return (unsigned long) usecSincePosixEpoch; } else { /* * Use the Tcl_GetTime abstraction to get the time in microseconds, as @@ -227,8 +248,8 @@ TclpGetClicks(void) Tcl_Time now; /* Current Tcl time */ - tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ - return (unsigned long)(now.sec * 1000000) + now.usec; + GetTime(&now); + return (unsigned long) (now.sec * 1000000) + now.usec; } } @@ -264,6 +285,7 @@ TclpGetWideClicks(void) * is consistent across all processors. Therefore, the frequency need * only be queried upon application initialization. */ + if (QueryPerformanceFrequency(&perfCounterFreq)) { wideClick.perfCounter = 1; wideClick.microsecsScale = 1000000.0 / perfCounterFreq.QuadPart; @@ -310,7 +332,7 @@ double TclpWideClickInMicrosec(void) { if (!wideClick.initialized) { - (void)TclpGetWideClicks(); /* initialize */ + (void) TclpGetWideClicks(); /* initialize */ } return wideClick.microsecsScale; } @@ -337,21 +359,22 @@ TclpGetMicroseconds(void) { long long usecSincePosixEpoch; - /* Try to use high resolution timer */ - if ( tclGetTimeProcPtr == NativeGetTime - && (usecSincePosixEpoch = NativeGetMicroseconds()) - ) { + /* + * Try to use high resolution timer. + */ + + if (IsTimeNative() && (usecSincePosixEpoch = NativeGetMicroseconds())) { return usecSincePosixEpoch; } else { /* - * Use the Tcl_GetTime abstraction to get the time in microseconds, as - * nearly as we can, and return it. - */ + * Use the Tcl_GetTime abstraction to get the time in microseconds, as + * nearly as we can, and return it. + */ Tcl_Time now; - tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ - return (((long long)now.sec) * 1000000) + now.usec; + GetTime(&now); + return (((long long) now.sec) * 1000000) + now.usec; } } @@ -383,14 +406,15 @@ Tcl_GetTime( { long long usecSincePosixEpoch; - /* Try to use high resolution timer */ - if ( tclGetTimeProcPtr == NativeGetTime - && (usecSincePosixEpoch = NativeGetMicroseconds()) - ) { + /* + * Try to use high resolution timer. + */ + + if (IsTimeNative() && (usecSincePosixEpoch = NativeGetMicroseconds())) { timePtr->sec = (long) (usecSincePosixEpoch / 1000000); timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); } else { - tclGetTimeProcPtr(timePtr, tclTimeClientData); + GetTime(timePtr); } } @@ -424,6 +448,96 @@ NativeScaleTime( /* *---------------------------------------------------------------------- * + * IsPerfCounterAvailable -- + * + * Tests whether the performance counter is available, which is a gnarly + * problem on 32-bit systems. Also retrieves the nominal frequency of the + * performance counter. + * + * Results: + * 1 if the counter is available, 0 if not. + * + * Side effects: + * Updates fields of the timeInfo global. Make sure you hold the lock + * before calling this. + * + *---------------------------------------------------------------------- + */ + +static inline int +IsPerfCounterAvailable(void) +{ + timeInfo.perfCounterAvailable = + QueryPerformanceFrequency(&timeInfo.nominalFreq); + + /* + * Some hardware abstraction layers use the CPU clock in place of the + * real-time clock as a performance counter reference. This results in: + * - inconsistent results among the processors on multi-processor + * systems. + * - unpredictable changes in performance counter frequency on + * "gearshift" processors such as Transmeta and SpeedStep. + * + * There seems to be no way to test whether the performance counter is + * reliable, but a useful heuristic is that if its frequency is 1.193182 + * MHz or 3.579545 MHz, it's derived from a colorburst crystal and is + * therefore the RTC rather than the TSC. + * + * A sloppier but serviceable heuristic is that the RTC crystal is + * normally less than 15 MHz while the TSC crystal is virtually assured to + * be greater than 100 MHz. Since Win98SE appears to fiddle with the + * definition of the perf counter frequency (perhaps in an attempt to + * calibrate the clock?), we use the latter rule rather than an exact + * match. + * + * We also assume (perhaps questionably) that the vendors have gotten + * their act together on Win64, so bypass all this rubbish on that + * platform. + */ + +#if !defined(_WIN64) + if (timeInfo.perfCounterAvailable && + /* + * The following lines would do an exact match on crystal + * frequency: + * + * timeInfo.nominalFreq.QuadPart != (long long) 1193182 && + * timeInfo.nominalFreq.QuadPart != (long long) 3579545 && + */ + timeInfo.nominalFreq.QuadPart > (long long) 15000000) { + /* + * As an exception, if every logical processor on the system is on the + * same chip, we use the performance counter anyway, presuming that + * everyone's TSC is locked to the same oscillator. + */ + + SYSTEM_INFO systemInfo; + int regs[4]; + + GetSystemInfo(&systemInfo); + if (TclWinCPUID(0, regs) == TCL_OK + && regs[1] == 0x756E6547 /* "Genu" */ + && regs[3] == 0x49656E69 /* "ineI" */ + && regs[2] == 0x6C65746E /* "ntel" */ + && TclWinCPUID(1, regs) == TCL_OK + && ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */ + || ((regs[0] & 0x00F00000) /* Extended family */ + && (regs[3] & 0x10000000))) /* Hyperthread */ + && (((regs[1]&0x00FF0000) >> 16)/* CPU count */ + == (int)systemInfo.dwNumberOfProcessors)) { + timeInfo.perfCounterAvailable = TRUE; + } else { + timeInfo.perfCounterAvailable = FALSE; + } + } +#endif /* above code is Win32 only */ + + return timeInfo.perfCounterAvailable; +} + +/* + *---------------------------------------------------------------------- + * * NativeGetMicroseconds -- * * Gets the current system time in microseconds since the beginning @@ -449,10 +563,10 @@ NativeCalc100NsTicks( ULONGLONG fileTimeLastCall, LONGLONG perfCounterLastCall, LONGLONG curCounterFreq, - LONGLONG curCounter -) { + LONGLONG curCounter) +{ return fileTimeLastCall + - ((curCounter - perfCounterLastCall) * 10000000 / curCounterFreq); + ((curCounter - perfCounterLastCall) * 10000000 / curCounterFreq); } static long long @@ -468,83 +582,15 @@ NativeGetMicroseconds(void) if (!timeInfo.initialized) { TclpInitLock(); if (!timeInfo.initialized) { - timeInfo.posixEpoch.LowPart = 0xD53E8000; timeInfo.posixEpoch.HighPart = 0x019DB1DE; - timeInfo.perfCounterAvailable = - QueryPerformanceFrequency(&timeInfo.nominalFreq); - - /* - * Some hardware abstraction layers use the CPU clock in place of - * the real-time clock as a performance counter reference. This - * results in: - * - inconsistent results among the processors on - * multi-processor systems. - * - unpredictable changes in performance counter frequency on - * "gearshift" processors such as Transmeta and SpeedStep. - * - * There seems to be no way to test whether the performance - * counter is reliable, but a useful heuristic is that if its - * frequency is 1.193182 MHz or 3.579545 MHz, it's derived from a - * colorburst crystal and is therefore the RTC rather than the - * TSC. - * - * A sloppier but serviceable heuristic is that the RTC crystal is - * normally less than 15 MHz while the TSC crystal is virtually - * assured to be greater than 100 MHz. Since Win98SE appears to - * fiddle with the definition of the perf counter frequency - * (perhaps in an attempt to calibrate the clock?), we use the - * latter rule rather than an exact match. - * - * We also assume (perhaps questionably) that the vendors have - * gotten their act together on Win64, so bypass all this rubbish - * on that platform. - */ - -#if !defined(_WIN64) - if (timeInfo.perfCounterAvailable - /* - * The following lines would do an exact match on crystal - * frequency: - * && timeInfo.nominalFreq.QuadPart != (long long)1193182 - * && timeInfo.nominalFreq.QuadPart != (long long)3579545 - */ - && timeInfo.nominalFreq.QuadPart > (long long) 15000000){ - /* - * As an exception, if every logical processor on the system - * is on the same chip, we use the performance counter anyway, - * presuming that everyone's TSC is locked to the same - * oscillator. - */ - - SYSTEM_INFO systemInfo; - int regs[4]; - - GetSystemInfo(&systemInfo); - if (TclWinCPUID(0, regs) == TCL_OK - && regs[1] == 0x756E6547 /* "Genu" */ - && regs[3] == 0x49656E69 /* "ineI" */ - && regs[2] == 0x6C65746E /* "ntel" */ - && TclWinCPUID(1, regs) == TCL_OK - && ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */ - || ((regs[0] & 0x00F00000) /* Extended family */ - && (regs[3] & 0x10000000))) /* Hyperthread */ - && (((regs[1]&0x00FF0000) >> 16)/* CPU count */ - == (int)systemInfo.dwNumberOfProcessors)) { - timeInfo.perfCounterAvailable = TRUE; - } else { - timeInfo.perfCounterAvailable = FALSE; - } - } -#endif /* above code is Win32 only */ - /* * If the performance counter is available, start a thread to * calibrate it. */ - if (timeInfo.perfCounterAvailable) { + if (IsPerfCounterAvailable()) { DWORD id; InitializeCriticalSection(&timeInfo.cs); @@ -578,7 +624,8 @@ NativeGetMicroseconds(void) ULONGLONG fileTimeLastCall; LONGLONG perfCounterLastCall, curCounterFreq; - /* Copy with current data of calibration cycle */ + /* Copy with current data of calibration + * cycle. */ LARGE_INTEGER curCounter; /* Current performance counter. */ @@ -588,6 +635,7 @@ NativeGetMicroseconds(void) /* * Hold time section locked as short as possible */ + EnterCriticalSection(&timeInfo.cs); fileTimeLastCall = timeInfo.fileTimeLastCall.QuadPart; @@ -599,8 +647,12 @@ NativeGetMicroseconds(void) /* * If calibration cycle occurred after we get curCounter */ + if (curCounter.QuadPart <= perfCounterLastCall) { - /* Calibrated file-time is saved from posix in 100-ns ticks */ + /* + * Calibrated file-time is saved from posix in 100-ns ticks + */ + return fileTimeLastCall / 10; } @@ -615,11 +667,14 @@ NativeGetMicroseconds(void) */ if (curCounter.QuadPart - perfCounterLastCall < - 11 * curCounterFreq * timeInfo.calibrationInterv / 10 - ) { - /* Calibrated file-time is saved from posix in 100-ns ticks */ + 11 * curCounterFreq * timeInfo.calibrationInterv / 10) { + /* + * Calibrated file-time is saved from posix in 100-ns ticks. + */ + return NativeCalc100NsTicks(fileTimeLastCall, - perfCounterLastCall, curCounterFreq, curCounter.QuadPart) / 10; + perfCounterLastCall, curCounterFreq, + curCounter.QuadPart) / 10; } } @@ -656,18 +711,20 @@ NativeGetTime( /* * Try to use high resolution timer. */ - if ( (usecSincePosixEpoch = NativeGetMicroseconds()) ) { + + usecSincePosixEpoch = NativeGetMicroseconds(); + if (usecSincePosixEpoch) { timePtr->sec = (long) (usecSincePosixEpoch / 1000000); timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); } else { /* - * High resolution timer is not available. Just use ftime. - */ + * High resolution timer is not available. Just use ftime. + */ struct _timeb t; _ftime(&t); - timePtr->sec = (long)t.time; + timePtr->sec = (long) t.time; timePtr->usec = t.millitm * 1000; } } @@ -735,9 +792,9 @@ TclpGetDate( struct tm *tmPtr; time_t time; #if defined(_WIN64) || (defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400)) -# define t2 *t /* no need to cripple time to 32-bit */ +# define t2 *t /* no need to cripple time to 32-bit */ #else - time_t t2 = *(__time32_t *)t; + time_t t2 = *(__time32_t *) t; #endif if (!useGMT) { @@ -789,14 +846,14 @@ TclpGetDate( time -= 60; } - time = tmPtr->tm_min + time/60; + time = tmPtr->tm_min + time / 60; tmPtr->tm_min = (int)(time % 60); if (tmPtr->tm_min < 0) { tmPtr->tm_min += 60; time -= 60; } - time = tmPtr->tm_hour + time/60; + time = tmPtr->tm_hour + time / 60; tmPtr->tm_hour = (int)(time % 24); if (tmPtr->tm_hour < 0) { tmPtr->tm_hour += 24; @@ -804,9 +861,9 @@ TclpGetDate( } time /= 24; - tmPtr->tm_mday += (int)time; - tmPtr->tm_yday += (int)time; - tmPtr->tm_wday = (tmPtr->tm_wday + (int)time) % 7; + tmPtr->tm_mday += (int) time; + tmPtr->tm_yday += (int) time; + tmPtr->tm_wday = (tmPtr->tm_wday + (int) time) % 7; } } else { tmPtr = ComputeGMT(&t2); @@ -847,8 +904,8 @@ ComputeGMT( * Compute the 4 year span containing the specified time. */ - tmp = (long)(*tp / SECSPER4YEAR); - rem = (long)(*tp % SECSPER4YEAR); + tmp = (long) (*tp / SECSPER4YEAR); + rem = (long) (*tp % SECSPER4YEAR); /* * Correct for weird mod semantics so the remainder is always positive. @@ -915,7 +972,7 @@ ComputeGMT( * Compute day of week. Epoch started on a Thursday. */ - tmPtr->tm_wday = (long)(*tp / SECSPERDAY) + 4; + tmPtr->tm_wday = (long) (*tp / SECSPERDAY) + 4; if ((*tp % SECSPERDAY) < 0) { tmPtr->tm_wday--; } @@ -970,7 +1027,11 @@ CalibrationThread( QueryPerformanceFrequency(&timeInfo.curCounterFreq); timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime; timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime; - /* Calibrated file-time will be saved from posix in 100-ns ticks */ + + /* + * Calibrated file-time will be saved from posix in 100-ns ticks. + */ + timeInfo.fileTimeLastCall.QuadPart -= timeInfo.posixEpoch.QuadPart; ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart, @@ -1030,10 +1091,11 @@ UpdateTimeEachSecond(void) /* Current value returned from * QueryPerformanceCounter. */ FILETIME curSysTime; /* Current system time. */ - static LARGE_INTEGER lastFileTime; /* File time of the previous calibration */ + static LARGE_INTEGER lastFileTime; + /* File time of the previous calibration */ LARGE_INTEGER curFileTime; /* File time at the time this callback was * scheduled. */ - long long estFreq; /* Estimated perf counter frequency. */ + long long estFreq; /* Estimated perf counter frequency. */ long long vt0; /* Tcl time right now. */ long long vt1; /* Tcl time one second from now. */ long long tdiff; /* Difference between system clock and Tcl @@ -1049,12 +1111,17 @@ UpdateTimeEachSecond(void) curFileTime.LowPart = curSysTime.dwLowDateTime; curFileTime.HighPart = curSysTime.dwHighDateTime; curFileTime.QuadPart -= timeInfo.posixEpoch.QuadPart; - /* If calibration still not needed (check for possible time switch) */ - if ( curFileTime.QuadPart > lastFileTime.QuadPart - && curFileTime.QuadPart < lastFileTime.QuadPart + - (timeInfo.calibrationInterv * 10000000) - ) { - /* again in next one second */ + + /* + * If calibration still not needed (check for possible time switch) + */ + + if (curFileTime.QuadPart > lastFileTime.QuadPart && curFileTime.QuadPart < + lastFileTime.QuadPart + (timeInfo.calibrationInterv * 10000000)) { + /* + * Look again in next one second. + */ + return; } QueryPerformanceCounter(&curPerfCounter); @@ -1110,8 +1177,9 @@ UpdateTimeEachSecond(void) */ vt0 = NativeCalc100NsTicks(timeInfo.fileTimeLastCall.QuadPart, - timeInfo.perfCounterLastCall.QuadPart, timeInfo.curCounterFreq.QuadPart, - curPerfCounter.QuadPart); + timeInfo.perfCounterLastCall.QuadPart, + timeInfo.curCounterFreq.QuadPart, curPerfCounter.QuadPart); + /* * If we've gotten more than a second away from system time, then drifting * the clock is going to be pretty hopeless. Just let it jump. Otherwise, @@ -1120,17 +1188,25 @@ UpdateTimeEachSecond(void) tdiff = vt0 - curFileTime.QuadPart; if (tdiff > 10000000 || tdiff < -10000000) { - /* jump to current system time, use curent estimated frequency */ + /* + * Jump to current system time, use curent estimated frequency. + */ + vt0 = curFileTime.QuadPart; } else { - /* calculate new frequency and estimate drift to the next second */ + /* + * Calculate new frequency and estimate drift to the next second. + */ + vt1 = 20000000 + curFileTime.QuadPart; driftFreq = (estFreq * 20000000 / (vt1 - vt0)); + /* - * Avoid too large drifts (only half of the current difference), - * that allows also be more accurate (aspire to the smallest tdiff), - * so then we can prolong calibration interval by tdiff < 100000 + * Avoid too large drifts (only half of the current difference), that + * allows also be more accurate (aspire to the smallest tdiff), so + * then we can prolong calibration interval by tdiff < 100000 */ + driftFreq = timeInfo.curCounterFreq.QuadPart + (driftFreq - timeInfo.curCounterFreq.QuadPart) / 2; @@ -1138,50 +1214,78 @@ UpdateTimeEachSecond(void) * Average between estimated, 2 current and 5 drifted frequencies, * (do the soft drifting as possible) */ - estFreq = (estFreq + 2 * timeInfo.curCounterFreq.QuadPart + 5 * driftFreq) / 8; + + estFreq = (estFreq + 2 * timeInfo.curCounterFreq.QuadPart + + 5 * driftFreq) / 8; } - /* Avoid too large discrepancy from nominal frequency */ - if (estFreq > 1003*timeInfo.nominalFreq.QuadPart/1000) { - estFreq = 1003*timeInfo.nominalFreq.QuadPart/1000; + /* + * Avoid too large discrepancy from nominal frequency. + */ + + if (estFreq > 1003 * timeInfo.nominalFreq.QuadPart / 1000) { + estFreq = 1003 * timeInfo.nominalFreq.QuadPart / 1000; vt0 = curFileTime.QuadPart; - } else if (estFreq < 997*timeInfo.nominalFreq.QuadPart/1000) { - estFreq = 997*timeInfo.nominalFreq.QuadPart/1000; + } else if (estFreq < 997 * timeInfo.nominalFreq.QuadPart / 1000) { + estFreq = 997 * timeInfo.nominalFreq.QuadPart / 1000; vt0 = curFileTime.QuadPart; } else if (vt0 != curFileTime.QuadPart) { /* - * Be sure the clock ticks never backwards (avoid it by negative drifting) - * just compare native time (in 100-ns) before and hereafter using - * new calibrated values) and do a small adjustment (short time freeze) + * Be sure the clock ticks never backwards (avoid it by negative + * drifting). Just compare native time (in 100-ns) before and + * hereafter using new calibrated values) and do a small adjustment + * (short time freeze). */ + LARGE_INTEGER newPerfCounter; long long nt0, nt1; QueryPerformanceCounter(&newPerfCounter); nt0 = NativeCalc100NsTicks(timeInfo.fileTimeLastCall.QuadPart, - timeInfo.perfCounterLastCall.QuadPart, timeInfo.curCounterFreq.QuadPart, - newPerfCounter.QuadPart); + timeInfo.perfCounterLastCall.QuadPart, + timeInfo.curCounterFreq.QuadPart, newPerfCounter.QuadPart); nt1 = NativeCalc100NsTicks(vt0, - curPerfCounter.QuadPart, estFreq, - newPerfCounter.QuadPart); - if (nt0 > nt1) { /* drifted backwards, try to compensate with new base */ - /* first adjust with a micro jump (short frozen time is acceptable) */ + curPerfCounter.QuadPart, estFreq, newPerfCounter.QuadPart); + if (nt0 > nt1) { + /* + * Drifted backwards, try to compensate with new base. + * + * First adjust with a micro jump (short frozen time is + * acceptable). + */ vt0 += nt0 - nt1; - /* if drift unavoidable (e. g. we had a time switch), then reset it */ + + /* + * If drift unavoidable (e. g. we had a time switch), then reset + * it. + */ + vt1 = vt0 - curFileTime.QuadPart; if (vt1 > 10000000 || vt1 < -10000000) { - /* larger jump resp. shift relative new file-time */ + /* + * Larger jump resp. shift relative new file-time. + */ + vt0 = curFileTime.QuadPart; } } } - /* In lock commit new values to timeInfo (hold lock as short as possible) */ + /* + * In lock commit new values to timeInfo (hold lock as short as possible) + */ + EnterCriticalSection(&timeInfo.cs); - /* grow calibration interval up to 10 seconds (if still precise enough) */ + /* + * Grow calibration interval up to 10 seconds (if still precise enough) + */ + if (tdiff < -100000 || tdiff > 100000) { - /* too long drift - reset calibration interval to 1000 second */ + /* + * Too long drift. Reset calibration interval to 1000 second. + */ + timeInfo.calibrationInterv = 1; } else if (timeInfo.calibrationInterv < 10) { timeInfo.calibrationInterv++; @@ -1215,12 +1319,13 @@ UpdateTimeEachSecond(void) static void ResetCounterSamples( - unsigned long long fileTime, /* Current file time */ + unsigned long long fileTime,/* Current file time */ long long perfCounter, /* Current performance counter */ - long long perfFreq) /* Target performance frequency */ + long long perfFreq) /* Target performance frequency */ { int i; - for (i=SAMPLES-1 ; i>=0 ; --i) { + + for (i = SAMPLES - 1 ; i >= 0 ; --i) { timeInfo.perfCounterSample[i] = perfCounter; timeInfo.fileTimeSample[i] = fileTime; perfCounter -= perfFreq; @@ -1260,15 +1365,17 @@ AccumulateSample( long long perfCounter, unsigned long long fileTime) { - unsigned long long workFTSample; /* File time sample being removed from or + unsigned long long workFTSample; + /* File time sample being removed from or * added to the circular buffer. */ long long workPCSample; /* Performance counter sample being removed * from or added to the circular buffer. */ - unsigned long long lastFTSample; /* Last file time sample recorded */ + unsigned long long lastFTSample; + /* Last file time sample recorded */ long long lastPCSample; /* Last performance counter sample recorded */ long long FTdiff; /* Difference between last FT and current */ long long PCdiff; /* Difference between last PC and current */ - long long estFreq; /* Estimated performance counter frequency */ + long long estFreq; /* Estimated performance counter frequency */ /* * Test for jumps and reset the samples if we have one. @@ -1347,8 +1454,8 @@ TclpGmtime( #if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400) return gmtime(timePtr); #else - return _gmtime32((const __time32_t *)timePtr); -#endif + return _gmtime32((const __time32_t *) timePtr); +#endif /* _WIN64 || _USE_64BIT_TIME_T || _MSC_VER < 1400 */ } /* @@ -1382,8 +1489,8 @@ TclpLocaltime( #if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400) return localtime(timePtr); #else - return _localtime32((const __time32_t *)timePtr); -#endif + return _localtime32((const __time32_t *) timePtr); +#endif /* _WIN64 || _USE_64BIT_TIME_T || _MSC_VER < 1400 */ } #endif /* TCL_NO_DEPRECATED */ |