diff options
author | oehhar <harald.oehlmann@elmicron.de> | 2023-11-02 17:00:55 (GMT) |
---|---|---|
committer | oehhar <harald.oehlmann@elmicron.de> | 2023-11-02 17:00:55 (GMT) |
commit | 27bbe3b5e064f2f59c33401a0b613054db151642 (patch) | |
tree | fc25af316218a7ca1c7fa32df0226a6ec184e21a | |
parent | 35d2a8013960a923e171c730d36430400813aa76 (diff) | |
parent | 7d470ebdeae5cee9052c1cf794696f2968941110 (diff) | |
download | tcl-27bbe3b5e064f2f59c33401a0b613054db151642.zip tcl-27bbe3b5e064f2f59c33401a0b613054db151642.tar.gz tcl-27bbe3b5e064f2f59c33401a0b613054db151642.tar.bz2 |
Merge main
117 files changed, 2928 insertions, 2534 deletions
diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index b616d14..f97ec63 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -18,6 +18,7 @@ jobs: - "" - "CFLAGS=-DTCL_NO_DEPRECATED=1" - "--disable-shared" + - "--disable-zipfs" - "--enable-symbols" - "--enable-symbols=mem" - "--enable-symbols=all" diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index 30e695f..e998256 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -42,6 +42,7 @@ jobs: cfgopt: - "" - "--disable-shared" + - "--disable-zipfs" - "--enable-symbols" - "--enable-symbols=mem" - "--enable-symbols=all" diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 8af5ac7..b5ee266 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -24,6 +24,7 @@ jobs: - "" - "CHECKS=nodep" - "OPTS=static" + - "OPTS=noembed" - "OPTS=symbols" - "OPTS=symbols STATS=compdbg,memdbg" # Using powershell means we need to explicitly stop on failure @@ -67,6 +68,7 @@ jobs: - "" - "CFLAGS=-DTCL_NO_DEPRECATED=1" - "--disable-shared" + - "--disable-zipfs" - "--enable-symbols" - "--enable-symbols=mem" - "--enable-symbols=all" diff --git a/compat/zlib/contrib/minizip/crypt.h b/compat/zlib/contrib/minizip/crypt.h index f4b93b7..8bde464 100644 --- a/compat/zlib/contrib/minizip/crypt.h +++ b/compat/zlib/contrib/minizip/crypt.h @@ -50,7 +50,7 @@ static int update_keys(unsigned long* pkeys, const z_crc_t* pcrc_32_tab, int c) (*(pkeys+1)) += (*(pkeys+0)) & 0xff; (*(pkeys+1)) = (*(pkeys+1)) * 134775813L + 1; { - register int keyshift = (int)((*(pkeys+1)) >> 24); + int keyshift = (int)((*(pkeys+1)) >> 24); (*(pkeys+2)) = CRC32((*(pkeys+2)), keyshift); } return c; diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 33becf7..0b1d6d5 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -649,7 +649,7 @@ filesystem object. It returns 1 if the paths are equal, and 0 if they are different. If either path is NULL, 0 is always returned. .PP -\fBTcl_FSGetNormalizedPath\fR this important function attempts to extract +\fBTcl_FSGetNormalizedPath\fR attempts to extract from the given Tcl_Obj a unique normalized path representation, whose string value can be used as a unique identifier for the file. .PP diff --git a/doc/OpenTcp.3 b/doc/OpenTcp.3 index 5a0f559..602f081 100644 --- a/doc/OpenTcp.3 +++ b/doc/OpenTcp.3 @@ -50,7 +50,7 @@ If nonzero, the client socket is connected asynchronously to the server. .AP int backlog in Length of OS listen backlog queue. Use -1 for default value. .AP "unsigned int" flags in -ORed combination of \fBTCL_TCPSERVER\fR flags that specify additional +ORed combination of \fBTCL_TCPSERVER_*\fR flags that specify additional informations about the socket being created. .AP void *sock in Platform-specific handle for client TCP socket. @@ -173,7 +173,10 @@ replacement for the standard channel. .PP \fBTcl_OpenTcpServerEx\fR behaviour is identical to \fBTcl_OpenTcpServer\fR but gives more flexibility to the user by providing a mean to further customize some -aspects of the socket via the \fIflags\fR parameter. +aspects of the socket via the \fIflags\fR parameter. Available +flags (dependent on platform) are +\fITCL_TCPSERVER_REUSEADDR\fR +\fITCL_TCPSERVER_REUSEPORT\fR .SH "PLATFORM ISSUES" .PP On Unix platforms, the socket handle is a Unix file descriptor as @@ -29,6 +29,8 @@ for the file. The time is measured in the standard POSIX fashion as seconds from a fixed starting time (often January 1, 1970). If the file does not exist or its access time cannot be queried or set then an error is generated. On Windows, FAT file systems do not support access time. +On \fBzipfs\fR file systems, access time is mapped to the modification +time. .TP \fBfile attributes \fIname\fR .TP @@ -79,6 +81,19 @@ clears the readonly attribute of the file. \fB\-rsrclength\fR gives the length of the resource fork of the file, this attribute can only be set to the value 0, which results in the resource fork being stripped off the file. +.PP +On all platforms, files in \fBzipfs\fR mounted archives return the following +attributes. These are all read-only and cannot be directly set. +\fB-archive\fR gives the path of the mounted ZIP archive containing the file. +\fB-compsize\fR gives the compressed size of the file within the archive. +This is \fB0\fR for directories. +\fB-crc\fR gives the CRC of the file if present, else \fB0\fR. +\fB-mount\fR gives the path where the containing archive is mounted. +\fB-offset\fR gives the offset of the file within the archive. +\fB-uncompsize\fR gives the uncompressed size of the file. +This is \fB0\fR for directories. +Other attributes may be present in the returned list. These should +be ignored. .RE .TP \fBfile channels\fR ?\fIpattern\fR? @@ -275,6 +290,7 @@ the file (equivalent to Unix \fBtouch\fR). The time is measured in the standard POSIX fashion as seconds from a fixed starting time (often January 1, 1970). If the file does not exist or its modified time cannot be queried or set then an error is generated. +On \fBzipfs\fR file systems, modification time cannot be explicitly set. .TP \fBfile nativename \fIname\fR . diff --git a/doc/filename.n b/doc/filename.n index b44b17b..8e7d58a 100644 --- a/doc/filename.n +++ b/doc/filename.n @@ -119,6 +119,12 @@ Volume-relative path to a file \fBfoo\fR in the root directory of the current volume. This is not a valid UNC path, so the assumption is that the extra backslashes are superfluous. .RE +.TP +\fBZipfs\fR +On all platforms where \fBzipfs\fR support is enabled, paths within mounted +ZIP archives begin with the string returned by the \fBzipfs root\fR command. +Zipfs paths are case-sensitive on all platforms. +.RE .SH "TILDE SUBSTITUTION" .PP Unlike earlier versions of Tcl, Tcl 9 does not do implicit tilde substitution @@ -167,7 +173,7 @@ or dots with trailing characters .QW .....abc is illegal. .SH "SEE ALSO" -file(n), glob(n) +file(n), glob(n), zipfs(n) .SH KEYWORDS current directory, absolute file name, relative file name, volume-relative file name, portability diff --git a/doc/zipfs.3 b/doc/zipfs.3 index 10a9dd0..0418acd 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -91,20 +91,32 @@ The function \fImay\fR modify the variables pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the current implementation does not do so, but callers \fIshould not\fR assume that this will be true in the future. .PP -\fBTclZipfs_Mount\fR mounts the ZIP archive \fIzipname\fR on the mount point -given in \fImountpoint\fR using the optional ZIP password \fIpassword\fR. -Errors during that process are reported in the interpreter \fIinterp\fR. If -\fImountpoint\fR is a NULL pointer, information on all currently mounted ZIP -file systems is written into \fIinterp\fR's result as a sequence of mount -points and ZIP file names. The result of this call is a standard Tcl result +\fBTclZipfs_Mount\fR is used to mount ZIP archives and to retrieve information +about currently mounted archives. If \fImountpoint\fR and \fIzipname\fR are both +specified (i.e. non-NULL), the function mounts the ZIP archive \fIzipname\fR on +the mount point given in \fImountpoint\fR. If \fIpassword\fR is not NULL, it +should point to the NUL terminated password protecting the archive. If not under +the zipfs file system root, \fImountpoint\fR is normalized with respect to it. +For example, a mount point passed as either \fBmt\fR \fB/mt\fR would be +normalized to \fB//zipfs:/mt\fR. An error is raised if the mount point includes +a drive or UNC volume. On success, \fIinterp\fR's result is set to the +normalized mount point path. +.PP +If \fImountpoint\fR is a NULL pointer, information on all currently mounted ZIP +file systems is stored in \fIinterp\fR's result as a sequence of mount +points and ZIP file names. +.PP +If \fImountpoint\fR is not NULL but \fIzipfile\fR +is NULL, the path to the archive mounted at that mount point is stored +as \fIinterp\fR's result. The function returns a standard Tcl result code. .PP -\fBTclZipfs_MountBuffer\fR mounts the ZIP archive in the buffer pointed to by -\fIdata\fR on the mount point given in \fImountpoint\fR. The ZIP archive is -assumed to be not password protected. Errors during that process are reported -in the interpreter \fIinterp\fR. The \fIcopy\fR argument determines whether -the buffer is internally copied before mounting or not. The result of this -call is a standard Tcl result code. +\fBTclZipfs_MountBuffer\fR mounts the ZIP archive content \fIdata\fR on the +mount point given in \fImountpoint\fR. Both \fImountpoint\fR and \fIdata\fR must +be specified as non-NULL. The \fIcopy\fR argument determines whether the buffer +is internally copied before mounting or not. The ZIP archive is assumed to be +not password protected. On success, \fIinterp\fR's result is set to the +normalized mount point path. .PP \fBTclZipfs_Unmount\fR undoes the effect of \fBTclZipfs_Mount\fR, i.e., it unmounts the mounted ZIP file system that was mounted from \fIzipname\fR (at diff --git a/doc/zipfs.n b/doc/zipfs.n index f9cbdc5..0a05078 100644 --- a/doc/zipfs.n +++ b/doc/zipfs.n @@ -43,6 +43,12 @@ simple encryption, sufficient to prevent casual inspection of their contents but not able to prevent access by even a moderately determined attacker. Strong encryption, multi-part archives, platform metadata, zip64 formats and other compression methods like bzip2 are not supported. +.PP +Files within mounted archives can be written to but new files or directories +cannot be created. Further, modifications to files are limited to the +mounted archive in memory and are not persisted to disk. +.PP +Paths in mounted archives are case-sensitive on all platforms. .TP \fBzipfs canonical\fR ?\fImountpoint\fR? \fIfilename\fR ?\fIinZipfs\fR? . @@ -92,7 +98,9 @@ the \fBstring match\fR command. Alternatively, the \fB-regexp\fR option may be used to specify matching \fBpattern\fR as a regular expression. The file names are returned in arbitrary order. Note that path separators are treated as ordinary characters in the matching. Thus forward slashes should be used -as path separators in the pattern. +as path separators in the pattern. The returned paths only include those +actually in the archive and does not include intermediate directories in +mount paths. .TP \fBzipfs mount\fR .TP @@ -114,7 +122,13 @@ In the third form, the command mounts the ZIP archive \fIzipfile\fR as a Tcl vir filesystem at \fImountpoint\fR. After this command executes, files contained in \fIzipfile\fR will appear to Tcl to be regular files at the mount point. If \fImountpoint\fR is -specified as an empty string, it is defaulted to the file path. +specified as an empty string, it is defaulted to the \fB[zipfs root]\fR. +The command returns the normalized mount point path. +.PP +If not under the zipfs file system root, \fImountpoint\fR is normalized with +respect to it. For example, a mount point passed as either \fBmt\fR \fB/mt\fR +would be normalized to \fB//zipfs:/mt\fR. An error is raised if the mount point +includes a drive or UNC volume. .PP \fBNB:\fR because the current working directory is a concept maintained by the operating system, using \fBcd\fR into a mounted archive will only work in the @@ -135,9 +149,7 @@ on most platforms. \fBzipfs unmount \fImountpoint\fR . Unmounts a previously mounted ZIP archive mounted to \fImountpoint\fR. -If the current directory is located within the mounted archive, -the directory that was previously the current directory is restored -on the unmount. The command will fail with an error exception if +The command will fail with an error exception if there are any files within the mounted archive are open. .SS "ZIP CREATION COMMANDS" This package also provides several commands to aid the creation of ZIP diff --git a/generic/tcl.decls b/generic/tcl.decls index be45333..0d13dc3 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -267,7 +267,7 @@ declare 65 { # Removed in 9.0, replaced by macro. #declare 67 { # void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, -# int length) +# Tcl_Size length) #} declare 68 { void Tcl_AllowExceptions(Tcl_Interp *interp) @@ -1317,7 +1317,7 @@ declare 356 { # Removed in 9.0: #declare 357 { # Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, -# int count) +# Tcl_Size count) #} declare 358 { void Tcl_FreeParse(Tcl_Parse *parsePtr) diff --git a/generic/tcl.h b/generic/tcl.h index dfeb07b..6f6b6ae 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2127,7 +2127,11 @@ typedef struct Tcl_Config { */ typedef void (Tcl_LimitHandlerProc) (void *clientData, Tcl_Interp *interp); +#if TCL_MAJOR_VERSION > 8 +#define Tcl_LimitHandlerDeleteProc Tcl_FreeProc +#else typedef void (Tcl_LimitHandlerDeleteProc) (void *clientData); +#endif #if 0 /* diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 40a78a4..1a244db 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -565,7 +565,7 @@ TclNewArithSeriesObj( Tcl_SetObjResult( interp, Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); return TCL_ERROR; } @@ -892,7 +892,7 @@ TclArithSeriesGetElements( Tcl_SetObjResult( interp, Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return TCL_ERROR; } @@ -915,7 +915,7 @@ TclArithSeriesGetElements( Tcl_SetObjResult( interp, Tcl_ObjPrintf("value is not an arithseries")); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", (void *)NULL); } return TCL_ERROR; } diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index f3f8144..ce5ced6 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1385,7 +1385,7 @@ AssembleOneLine( if (opnd < 0 || opnd > 3) { Tcl_SetObjResult(interp, Tcl_NewStringObj("operand must be [0..3]", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", (void *)NULL); goto cleanup; } BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd); @@ -1626,7 +1626,7 @@ AssembleOneLine( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj("operand must be >=2", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", (void *)NULL); } goto cleanup; } @@ -1992,7 +1992,7 @@ CreateMirrorJumpTable( Tcl_SetObjResult(interp, Tcl_NewStringObj( "jump table must have an even number of list elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", (void *)NULL); } return TCL_ERROR; } @@ -2023,7 +2023,7 @@ CreateMirrorJumpTable( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "duplicate entry in jump table for \"%s\"", TclGetString(objv[i]))); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY", (void *)NULL); DeleteMirrorJumpTable(jtPtr); return TCL_ERROR; } @@ -2108,7 +2108,7 @@ GetNextOperand( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "assembly code may not contain substitutions", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", (void *)NULL); } return TCL_ERROR; } @@ -2331,7 +2331,7 @@ FindLocalVar( Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use this instruction to create a variable" " in a non-proc context", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", (void *)NULL); } return TCL_INDEX_NONE; } @@ -2366,7 +2366,7 @@ CheckNamespaceQualifiers( if ((*p == ':') && (p[1] == ':')) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "variable \"%s\" is not local", name)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, (void *)NULL); return TCL_ERROR; } } @@ -2402,7 +2402,7 @@ CheckOneByte( if (value < 0 || value > 0xFF) { result = Tcl_NewStringObj("operand does not fit in one byte", -1); Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -2437,7 +2437,7 @@ CheckSignedOneByte( if (value > 0x7F || value < -0x80) { result = Tcl_NewStringObj("operand does not fit in one byte", -1); Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -2470,7 +2470,7 @@ CheckNonNegative( if (value < 0) { result = Tcl_NewStringObj("operand must be nonnegative", -1); Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -2503,7 +2503,7 @@ CheckStrictlyPositive( if (value <= 0) { result = Tcl_NewStringObj("operand must be positive", -1); Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -2555,7 +2555,7 @@ DefineLabel( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "duplicate definition of label \"%s\"", labelName)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName, - NULL); + (void *)NULL); } return TCL_ERROR; } @@ -2956,7 +2956,7 @@ ReportUndefinedLabel( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "undefined label \"%s\"", TclGetString(jumpTarget))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", - TclGetString(jumpTarget), NULL); + TclGetString(jumpTarget), (void *)NULL); Tcl_SetErrorLine(interp, bbPtr->jumpLine); } } @@ -3241,7 +3241,7 @@ CheckNonThrowingBlock( "a context where an exception has been " "caught and not disposed of.", tclInstructionTable[opcode].name)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", (void *)NULL); AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); } return TCL_ERROR; @@ -3421,7 +3421,7 @@ StackCheckBasicBlock( */ Tcl_SetErrorLine(interp, blockPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (void *)NULL); } return TCL_ERROR; } @@ -3444,7 +3444,7 @@ StackCheckBasicBlock( if (initialStackDepth + blockPtr->minStackDepth < 0) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (void *)NULL); AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); Tcl_SetErrorLine(interp, blockPtr->startLine); } @@ -3463,7 +3463,7 @@ StackCheckBasicBlock( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "code pops stack below level of enclosing catch", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", -1); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", (void *)NULL); AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); Tcl_SetErrorLine(interp, blockPtr->startLine); } @@ -3591,7 +3591,7 @@ StackCheckExit( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "stack is unbalanced on exit from the code (depth=%d)", depth)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (void *)NULL); } return TCL_ERROR; } @@ -3736,7 +3736,7 @@ ProcessCatchesInBasicBlock( "execution reaches an instruction in inconsistent " "exception contexts", -1)); Tcl_SetErrorLine(interp, bbPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", (void *)NULL); } return TCL_ERROR; } @@ -3795,7 +3795,7 @@ ProcessCatchesInBasicBlock( Tcl_SetObjResult(interp, Tcl_NewStringObj( "endCatch without a corresponding beginCatch", -1)); Tcl_SetErrorLine(interp, bbPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", (void *)NULL); } return TCL_ERROR; } @@ -3871,7 +3871,7 @@ CheckForUnclosedCatches( "catch still active on exit from assembly code", -1)); Tcl_SetErrorLine(interp, assemEnvPtr->curr_bb->enclosingCatch->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", (void *)NULL); } return TCL_ERROR; } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3ceb427..8e5081c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -64,6 +64,41 @@ #endif /* !TCL_FPCLASSIFY_MODE */ +/* + * Bug 7371b6270b: to check C call stack depth, prefer an approach which is + * compatible with AddressSanitizer (ASan) use-after-return detection. + */ + +#if defined(_MSC_VER) && defined(HAVE_INTRIN_H) +#include <intrin.h> /* for _AddressOfReturnAddress() */ +#endif + +/* + * As suggested by + * https://clang.llvm.org/docs/LanguageExtensions.html#has-builtin + */ +#ifndef __has_builtin +#define __has_builtin(x) 0 /* for non-clang compilers */ +#endif + +void * +TclGetCStackPtr(void) +{ +#if defined( __GNUC__ ) || __has_builtin(__builtin_frame_address) + return __builtin_frame_address(0); +#elif defined(_MSC_VER) && defined(HAVE_INTRIN_H) + return _AddressOfReturnAddress(); +#else + ptrdiff_t unused = 0; + /* + * LLVM recommends using volatile: + * https://github.com/llvm/llvm-project/blob/llvmorg-10.0.0-rc1/clang/lib/Basic/Stack.cpp#L31 + */ + ptrdiff_t *volatile stackLevel = &unused; + return (void *)stackLevel; +#endif +} + #define INTERP_STACK_INITIAL_SIZE 2000 #define CORO_STACK_INITIAL_SIZE 200 @@ -141,7 +176,7 @@ static int CancelEvalProc(void *clientData, Tcl_Interp *interp, int code); static int CheckDoubleResult(Tcl_Interp *interp, double dResult); static void DeleteCoroutine(void *clientData); -static void DeleteInterpProc(Tcl_Interp *interp); +static Tcl_FreeProc DeleteInterpProc; static void DeleteOpCmdClientData(void *clientData); #ifdef USE_DTRACE static Tcl_ObjCmdProc DTraceObjCmd; @@ -149,6 +184,7 @@ static Tcl_NRPostProc DTraceCmdReturn; #else # define DTraceCmdReturn NULL #endif /* USE_DTRACE */ +static Tcl_ObjCmdProc InvokeStringCommand; static Tcl_ObjCmdProc ExprAbsFunc; static Tcl_ObjCmdProc ExprBinaryFunc; static Tcl_ObjCmdProc ExprBoolFunc; @@ -634,7 +670,7 @@ buildInfoObjCmd2( if (p) { memcpy(buf, (char *)clientData, p - (char *)clientData); buf[p - (char *)clientData] = '\0'; - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); } return TCL_OK; } else if (len == 10 && !strcmp(arg, "patchlevel")) { @@ -643,7 +679,7 @@ buildInfoObjCmd2( if (p) { memcpy(buf, (char *)clientData, p - (char *)clientData); buf[p - (char *)clientData] = '\0'; - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); } return TCL_OK; } else if (len == 6 && !strcmp(arg, "commit")) { @@ -653,9 +689,9 @@ buildInfoObjCmd2( char buf[80]; memcpy(buf, p+1, q - p - 1); buf[q - p - 1] = '\0'; - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); } else { - Tcl_AppendResult(interp, p+1, NULL); + Tcl_AppendResult(interp, p+1, (void *)NULL); } } return TCL_OK; @@ -669,29 +705,29 @@ buildInfoObjCmd2( char buf[16]; memcpy(buf, p+1, q - p - 1); buf[q - p - 1] = '\0'; - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); } else { - Tcl_AppendResult(interp, p+1, NULL); + Tcl_AppendResult(interp, p+1, (void *)NULL); } return TCL_OK; } p = strchr(p+1, '.'); } - Tcl_AppendResult(interp, "0", NULL); + Tcl_AppendResult(interp, "0", (void *)NULL); return TCL_OK; } const char *p = strchr((char *)clientData, '.'); while (p) { if (!strncmp(p+1, arg, len) && ((p[len+1] == '.') || (p[len+1] == '\0'))) { - Tcl_AppendResult(interp, "1", NULL); + Tcl_AppendResult(interp, "1", (void *)NULL); return TCL_OK; } p = strchr(p+1, '.'); } - Tcl_AppendResult(interp, "0", NULL); + Tcl_AppendResult(interp, "0", (void *)NULL); return TCL_OK; } - Tcl_AppendResult(interp, (char *)clientData, NULL); + Tcl_AppendResult(interp, (char *)clientData, (void *)NULL); return TCL_OK; } @@ -1033,10 +1069,10 @@ Tcl_CreateInterp(void) * Tcl_CreateCommand, because it's faster (there's no need to check for a * preexisting command by the same name). If a command has a Tcl_CmdProc * but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to - * TclInvokeStringCommand. This is an object-based wrapper function that + * InvokeStringCommand. This is an object-based wrapper function that * extracts strings, calls the string function, and creates an object for - * the result. Similarly, if a command has a Tcl_ObjCmdProc but no - * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. + * the result. If a command has a Tcl_ObjCmdProc but no + * Tcl_CmdProc, set the Tcl_CmdProc to NULL. */ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { @@ -1055,7 +1091,7 @@ Tcl_CreateInterp(void) cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = cmdInfoPtr->compileProc; - cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->proc = NULL; cmdPtr->clientData = cmdPtr; cmdPtr->objProc = cmdInfoPtr->objProc; cmdPtr->objClientData = NULL; @@ -1458,7 +1494,7 @@ BadEnsembleSubcommand( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "not allowed to invoke subcommand %s of %s", infoPtr->commandName, infoPtr->ensembleNsName)); - Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL); + Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", (void *)NULL); return TCL_ERROR; } @@ -1766,7 +1802,7 @@ Tcl_DeleteInterp( * Ensure that the interpreter is eventually deleted. */ - Tcl_EventuallyFree(interp, (Tcl_FreeProc *) DeleteInterpProc); + Tcl_EventuallyFree(interp, DeleteInterpProc); } /* @@ -1792,8 +1828,9 @@ Tcl_DeleteInterp( static void DeleteInterpProc( - Tcl_Interp *interp) /* Interpreter to delete. */ + void *blockPtr) /* Interpreter to delete. */ { + Tcl_Interp *interp = (Tcl_Interp *) blockPtr; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Tcl_HashSearch search; @@ -2153,7 +2190,7 @@ Tcl_HideCommand( Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use namespace qualifiers in hidden command" " token (rename)", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", (void *)NULL); return TCL_ERROR; } @@ -2178,7 +2215,7 @@ Tcl_HideCommand( Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only hide global namespace commands (use rename then hide)", -1)); - Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL); + Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", (void *)NULL); return TCL_ERROR; } @@ -2204,7 +2241,7 @@ Tcl_HideCommand( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "hidden command named \"%s\" already exists", hiddenCmdToken)); - Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL); + Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", (void *)NULL); return TCL_ERROR; } @@ -2308,7 +2345,7 @@ Tcl_ExposeCommand( Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot expose to a namespace (use expose to toplevel, then rename)", -1)); - Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL); + Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", (void *)NULL); return TCL_ERROR; } @@ -2325,7 +2362,7 @@ Tcl_ExposeCommand( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown hidden command \"%s\"", hiddenCmdToken)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", - hiddenCmdToken, NULL); + hiddenCmdToken, (void *)NULL); return TCL_ERROR; } cmdPtr = (Command *)Tcl_GetHashValue(hPtr); @@ -2363,7 +2400,7 @@ Tcl_ExposeCommand( if (!isNew) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "exposed command \"%s\" already exists", cmdName)); - Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL); + Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", (void *)NULL); return TCL_ERROR; } @@ -2444,7 +2481,7 @@ Tcl_ExposeCommand( * In the future, when cmdName is seen as the name of a command by * Tcl_Eval, proc will be called. To support the bytecode interpreter, * the command is created with a wrapper Tcl_ObjCmdProc - * (TclInvokeStringCommand) that eventually calls proc. When the command + * (InvokeStringCommand) that eventually calls proc. When the command * is deleted from the table, deleteProc will be called. See the manual * entry for details on the calling sequence. * @@ -2586,7 +2623,7 @@ Tcl_CreateCommand( cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = NULL; - cmdPtr->objProc = TclInvokeStringCommand; + cmdPtr->objProc = InvokeStringCommand; cmdPtr->objClientData = cmdPtr; cmdPtr->proc = proc; cmdPtr->clientData = clientData; @@ -2875,7 +2912,7 @@ TclCreateObjCommandInNs( cmdPtr->compileProc = NULL; cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; - cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->proc = NULL; cmdPtr->clientData = cmdPtr; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; @@ -2916,7 +2953,7 @@ TclCreateObjCommandInNs( /* *---------------------------------------------------------------------- * - * TclInvokeStringCommand -- + * InvokeStringCommand -- * * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based * Tcl_CmdProc if no object-based function exists for a command. A @@ -2929,13 +2966,13 @@ TclCreateObjCommandInNs( * * Side effects: * Besides those side effects of the called Tcl_CmdProc, - * TclInvokeStringCommand allocates and frees storage. + * InvokeStringCommand allocates and frees storage. * *---------------------------------------------------------------------- */ int -TclInvokeStringCommand( +InvokeStringCommand( void *clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -2964,71 +3001,6 @@ TclInvokeStringCommand( /* *---------------------------------------------------------------------- * - * TclInvokeObjectCommand -- - * - * "Wrapper" Tcl_CmdProc used to call an existing object-based - * Tcl_ObjCmdProc if no string-based function exists for a command. A - * pointer to this function is stored as the Tcl_CmdProc in a Command - * structure. It simply turns around and calls the object Tcl_ObjCmdProc - * in the Command structure. - * - * Results: - * A standard Tcl result value. - * - * Side effects: - * Besides those side effects of the called Tcl_ObjCmdProc, - * TclInvokeObjectCommand allocates and frees storage. - * - *---------------------------------------------------------------------- - */ - -int -TclInvokeObjectCommand( - void *clientData, /* Points to command's Command structure. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - Command *cmdPtr = ( Command *) clientData; - Tcl_Obj *objPtr; - int i, length, result; - Tcl_Obj **objv = (Tcl_Obj **) - TclStackAlloc(interp, (argc * sizeof(Tcl_Obj *))); - - for (i = 0; i < argc; i++) { - length = strlen(argv[i]); - TclNewStringObj(objPtr, argv[i], length); - Tcl_IncrRefCount(objPtr); - objv[i] = objPtr; - } - - /* - * Invoke the command's object-based Tcl_ObjCmdProc. - */ - - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, argc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, argc, objv); - } - - /* - * Decrement the ref counts for the argument objects created above, then - * free the objv array if malloc'ed storage was used. - */ - - for (i = 0; i < argc; i++) { - objPtr = objv[i]; - Tcl_DecrRefCount(objPtr); - } - TclStackFree(interp, objv); - return result; -} - -/* - *---------------------------------------------------------------------- - * * TclRenameCommand -- * * Called to give an existing Tcl command a different name. Both the old @@ -3078,7 +3050,7 @@ TclRenameCommand( "can't %s \"%s\": command doesn't exist", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", oldName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, (void *)NULL); return TCL_ERROR; } @@ -3109,7 +3081,7 @@ TclRenameCommand( if ((newNsPtr == NULL) || (newTail == NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't rename to \"%s\": bad command name", newName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (void *)NULL); result = TCL_ERROR; goto done; } @@ -3117,7 +3089,7 @@ TclRenameCommand( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't rename to \"%s\": command already exists", newName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME", - "TARGET_EXISTS", NULL); + "TARGET_EXISTS", (void *)NULL); result = TCL_ERROR; goto done; } @@ -3340,7 +3312,7 @@ Tcl_SetCommandInfoFromToken( cmdPtr->proc = infoPtr->proc; cmdPtr->clientData = infoPtr->clientData; if (infoPtr->objProc == NULL) { - cmdPtr->objProc = TclInvokeStringCommand; + cmdPtr->objProc = InvokeStringCommand; cmdPtr->objClientData = cmdPtr; cmdPtr->nreProc = NULL; } else { @@ -3452,7 +3424,7 @@ Tcl_GetCommandInfoFromToken( cmdPtr = (Command *) cmd; infoPtr->isNativeObjectProc = - (cmdPtr->objProc != TclInvokeStringCommand); + (cmdPtr->objProc != InvokeStringCommand); infoPtr->objProc = cmdPtr->objProc; infoPtr->objClientData = cmdPtr->objClientData; infoPtr->proc = cmdPtr->proc; @@ -4066,7 +4038,7 @@ TclInterpReady( Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to call eval in deleted interpreter", -1)); Tcl_SetErrorCode(interp, "TCL", "IDELETE", - "attempt to call eval in deleted interpreter", NULL); + "attempt to call eval in deleted interpreter", (void *)NULL); return TCL_ERROR; } @@ -4094,7 +4066,7 @@ TclInterpReady( Tcl_SetObjResult(interp, Tcl_NewStringObj( "too many nested evaluations (infinite loop?)", -1)); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", (void *)NULL); return TCL_ERROR; } @@ -4228,7 +4200,7 @@ Tcl_Canceled( } Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1)); - Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL); + Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, (void *)NULL); } /* @@ -4518,7 +4490,7 @@ EvalObjvCore( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to invoke a deleted command")); - Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); + Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", (void *)NULL); return TCL_ERROR; } } @@ -4893,7 +4865,7 @@ TEOV_NotFound( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid command name \"%s\"", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(objv[0]), NULL); + TclGetString(objv[0]), (void *)NULL); /* * Release any resources we locked and allocated during the handler @@ -6386,7 +6358,7 @@ ProcessUnexpectedResult( "command returned bad code: %d", returnCode)); } snprintf(buf, sizeof(buf), "%d", returnCode); - Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, NULL); + Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, (void *)NULL); } /* @@ -6677,7 +6649,7 @@ int TclObjInvoke( Tcl_Interp *interp, /* Interpreter in which command is to be * invoked. */ - int objc, /* Count of arguments. */ + Tcl_Size objc, /* Count of arguments. */ Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the * name of the command to invoke. */ int flags) /* Combination of flags controlling the call: @@ -6720,7 +6692,7 @@ TclNRInvoke( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid hidden command name \"%s\"", cmdName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName, - NULL); + (void *)NULL); return TCL_ERROR; } cmdPtr = (Command *)Tcl_GetHashValue(hPtr); @@ -6842,7 +6814,7 @@ Tcl_AppendObjToErrorInfo( iPtr->errorInfo = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { - Tcl_SetErrorCode(interp, "NONE", NULL); + Tcl_SetErrorCode(interp, "NONE", (void *)NULL); } } @@ -7210,7 +7182,7 @@ ExprIsqrtFunc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "square root of negative argument", -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "domain error: argument not in valid range", NULL); + "domain error: argument not in valid range", (void *)NULL); return TCL_ERROR; } @@ -8319,7 +8291,7 @@ MathFuncWrongNumArgs( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s arguments for math function \"%s\"", (found < expected ? "not enough" : "too many"), name)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL); } #ifdef USE_DTRACE @@ -8553,7 +8525,7 @@ Tcl_NRCallObjProc2( * Side effects: * If no command named "cmdName" already exists for interp, one is * created. Otherwise, if a command does exist, then if the object-based - * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand + * Tcl_ObjCmdProc is InvokeStringCommand, we assume Tcl_CreateCommand * was called previously for the same command and just set its * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old * command. @@ -8823,7 +8795,7 @@ TclNRTailcallObjCmd( if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "tailcall can only be called from a proc, lambda or method", -1)); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (void *)NULL); return TCL_ERROR; } @@ -8985,7 +8957,7 @@ TclNRYieldObjCmd( if (!corPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "yield can only be called in a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (void *)NULL); return TCL_ERROR; } @@ -9018,7 +8990,7 @@ TclNRYieldToObjCmd( if (!corPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto can only be called in a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (void *)NULL); return TCL_ERROR; } @@ -9026,7 +8998,7 @@ TclNRYieldToObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto called in deleted namespace", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", - NULL); + (void *)NULL); return TCL_ERROR; } @@ -9211,6 +9183,7 @@ TclNRCoroutineActivateCallback( TCL_UNUSED(int) /*result*/) { CoroutineData *corPtr = (CoroutineData *)data[0]; + void *stackLevel = TclGetCStackPtr(); if (!corPtr->stackLevel) { /* @@ -9227,7 +9200,7 @@ TclNRCoroutineActivateCallback( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = &corPtr; + corPtr->stackLevel = stackLevel; Tcl_Size numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; @@ -9241,7 +9214,7 @@ TclNRCoroutineActivateCallback( * Coroutine is active: yield */ - if (corPtr->stackLevel != &corPtr) { + if (corPtr->stackLevel != stackLevel) { NRE_callback *runPtr; iPtr->execEnvPtr = corPtr->callerEEPtr; @@ -9261,7 +9234,7 @@ TclNRCoroutineActivateCallback( Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot yield: C stack busy", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", - NULL); + (void *)NULL); return TCL_ERROR; } @@ -9350,7 +9323,7 @@ CoroTypeObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only get coroutine type of a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objv[1]), NULL); + TclGetString(objv[1]), (void *)NULL); return TCL_ERROR; } @@ -9380,7 +9353,7 @@ CoroTypeObjCmd( default: Tcl_SetObjResult(interp, Tcl_NewStringObj( "unknown coroutine type", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", (void *)NULL); return TCL_ERROR; } } @@ -9410,7 +9383,7 @@ GetCoroutineFromObj( if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objPtr), NULL); + TclGetString(objPtr), (void *)NULL); return NULL; } return (CoroutineData *)cmdPtr->objClientData; @@ -9443,7 +9416,7 @@ TclNRCoroInjectObjCmd( if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only inject a command into a suspended coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (void *)NULL); return TCL_ERROR; } @@ -9489,7 +9462,7 @@ TclNRCoroProbeObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only inject a probe command into a suspended coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (void *)NULL); return TCL_ERROR; } @@ -9680,7 +9653,7 @@ NRInjectObjCmd( if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only inject a command into a suspended coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (void *)NULL); return TCL_ERROR; } @@ -9710,7 +9683,7 @@ TclNRInterpCoroutine( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "coroutine \"%s\" is already running", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", (void *)NULL); return TCL_ERROR; } @@ -9734,7 +9707,7 @@ TclNRInterpCoroutine( Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong coro nargs; how did we get here? " "not implemented!", -1)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL); return TCL_ERROR; } /* fallthrough */ @@ -9788,14 +9761,14 @@ TclNRCoroutineObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", procName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", (void *)NULL); return TCL_ERROR; } if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, (void *)NULL); return TCL_ERROR; } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 9c32cd7..a09eacb 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -400,7 +400,7 @@ TclGetBytesFromObj( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "byte sequence length exceeds INT_MAX", -1)); - Tcl_SetErrorCode(interp, "TCL", "API", "OUTDATED", NULL); + Tcl_SetErrorCode(interp, "TCL", "API", "OUTDATED", (void *)NULL); } return NULL; } else { @@ -519,7 +519,7 @@ MakeByteArray( "expected byte sequence but character %" TCL_Z_MODIFIER "u was '%1s' (U+%06X)", dst - byteArrayPtr->bytes, src, ch)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", (void *)NULL); } Tcl_Free(byteArrayPtr); *byteArrayPtrPtr = NULL; @@ -2567,7 +2567,7 @@ BinaryDecodeHex( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid hexadecimal digit \"%c\" (U+%06X) at position %" TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL); return TCL_ERROR; } @@ -2636,7 +2636,7 @@ BinaryEncode64( Tcl_SetObjResult(interp, Tcl_NewStringObj( "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "LINE_LENGTH", NULL); + "LINE_LENGTH", (void *)NULL); return TCL_ERROR; } break; @@ -2764,7 +2764,7 @@ BinaryEncodeUu( Tcl_SetObjResult(interp, Tcl_NewStringObj( "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "LINE_LENGTH", NULL); + "LINE_LENGTH", (void *)NULL); return TCL_ERROR; } lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */ @@ -2793,7 +2793,7 @@ BinaryEncodeUu( "invalid wrapchar; will defeat decoding", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", - "ENCODE", "WRAPCHAR", NULL); + "ENCODE", "WRAPCHAR", (void *)NULL); return TCL_ERROR; } } @@ -3018,7 +3018,7 @@ BinaryDecodeUu( shortUu: Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data")); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", (void *)NULL); TclDecrRefCount(resultObj); return TCL_ERROR; @@ -3031,7 +3031,7 @@ BinaryDecodeUu( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid uuencode character \"%c\" (U+%06X) at position %" TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } @@ -3207,7 +3207,7 @@ BinaryDecode64( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid base64 character \"%c\" (U+%06X) at position %" TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } diff --git a/generic/tclClock.c b/generic/tclClock.c index a12e023..2511d7e 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1045,7 +1045,7 @@ ConvertUTCToLocalUsingC( if ((Tcl_WideInt) tock != fields->seconds) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "number too large to represent as a Posix time", -1)); - Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL); + Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", (void *)NULL); return TCL_ERROR; } TzsetIfNecessary(); @@ -1054,7 +1054,7 @@ ConvertUTCToLocalUsingC( Tcl_SetObjResult(interp, Tcl_NewStringObj( "localtime failed (clock value may be too " "large/small to represent)", -1)); - Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL); + Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", (void *)NULL); return TCL_ERROR; } @@ -1905,7 +1905,7 @@ ClockParseformatargsObjCmd( Tcl_WrongNumArgs(interp, 0, objv, "clock format clockval ?-format string? " "?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"); - Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", NULL); + Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", (void *)NULL); return TCL_ERROR; } @@ -1920,7 +1920,7 @@ ClockParseformatargsObjCmd( if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &optionIndex) != TCL_OK) { Tcl_SetErrorCode(interp, "CLOCK", "badOption", - TclGetString(objv[i]), NULL); + TclGetString(objv[i]), (void *)NULL); return TCL_ERROR; } switch (optionIndex) { @@ -1952,7 +1952,7 @@ ClockParseformatargsObjCmd( if ((saw & (1 << CLOCK_FORMAT_GMT)) && (saw & (1 << CLOCK_FORMAT_TIMEZONE))) { Tcl_SetObjResult(interp, litPtr[LIT_CANNOT_USE_GMT_AND_TIMEZONE]); - Tcl_SetErrorCode(interp, "CLOCK", "gmtWithTimezone", NULL); + Tcl_SetErrorCode(interp, "CLOCK", "gmtWithTimezone", (void *)NULL); return TCL_ERROR; } if (gmtFlag) { diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 4664ec8..92e0f51 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -742,7 +742,7 @@ EncodingDirsObjCmd( "expected directory list but got \"%s\"", TclGetString(dirListObj))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH", - NULL); + (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, dirListObj); @@ -1657,6 +1657,21 @@ FileAttrIsOwnedCmd( Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } + + Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(interp, objv[1]); + /* Note normPathPtr owned by Tcl, no need to free it */ + if (normPathPtr) { + if (TclIsZipfsPath(Tcl_GetString(normPathPtr))) { + return CheckAccess(interp, objv[1], F_OK); + } + /* Not zipfs, try native. */ + } + + /* + * Note use objv[1] below, NOT normPathPtr even if not NULL because + * for native paths we may not want links to be resolved. + */ + #if defined(_WIN32) value = TclWinFileOwned(objv[1]); #else @@ -1920,7 +1935,7 @@ PathFilesystemCmd( if (fsInfo == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", - TclGetString(objv[1]), NULL); + TclGetString(objv[1]), (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, fsInfo); @@ -2070,7 +2085,7 @@ PathSplitCmd( "could not read \"%s\": no such file or directory", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH", - NULL); + (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, res); @@ -2172,7 +2187,7 @@ FilesystemSeparatorCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", - TclGetString(objv[1]), NULL); + TclGetString(objv[1]), (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, separatorObj); @@ -2822,7 +2837,7 @@ EachloopCmd( (statePtr->resultList != NULL ? "lmap" : "foreach"))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", (statePtr->resultList != NULL ? "LMAP" : "FOREACH"), - "NEEDVARS", NULL); + "NEEDVARS", (void *)NULL); result = TCL_ERROR; goto done; } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 15d7939..6644d45 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -226,7 +226,7 @@ TclNRIfObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "wrong # args: no expression after \"%s\" argument", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL); return TCL_ERROR; } @@ -317,7 +317,7 @@ IfConditionCallback( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "wrong # args: no expression after \"%s\" argument", clause)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL); return TCL_ERROR; } if (!thenScriptIndex) { @@ -344,7 +344,7 @@ IfConditionCallback( Tcl_SetObjResult(interp, Tcl_NewStringObj( "wrong # args: extra words after \"else\" clause in \"if\" command", -1)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL); return TCL_ERROR; } if (thenScriptIndex) { @@ -361,7 +361,7 @@ IfConditionCallback( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "wrong # args: no script following \"%s\" argument", TclGetString(objv[i-1]))); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL); return TCL_ERROR; } @@ -490,7 +490,7 @@ InfoArgsCmd( if (procPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't a procedure", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, (void *)NULL); return TCL_ERROR; } @@ -552,7 +552,7 @@ InfoBodyCmd( if (procPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't a procedure", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, (void *)NULL); return TCL_ERROR; } @@ -973,7 +973,7 @@ InfoDefaultCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't a procedure", procName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName, - NULL); + (void *)NULL); return TCL_ERROR; } @@ -1006,7 +1006,7 @@ InfoDefaultCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\" doesn't have an argument \"%s\"", procName, argName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, (void *)NULL); return TCL_ERROR; } @@ -1189,7 +1189,7 @@ InfoFrameCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", - TclGetString(objv[1]), NULL); + TclGetString(objv[1]), (void *)NULL); code = TCL_ERROR; goto done; } @@ -1551,7 +1551,7 @@ InfoHostnameCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "unable to determine name of host", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", (void *)NULL); return TCL_ERROR; } @@ -1624,7 +1624,7 @@ InfoLevelCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", - TclGetString(objv[1]), NULL); + TclGetString(objv[1]), (void *)NULL); return TCL_ERROR; } @@ -1671,7 +1671,7 @@ InfoLibraryCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "no library has been specified for Tcl", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library", (void *)NULL); return TCL_ERROR; } @@ -2169,7 +2169,7 @@ InfoCmdTypeCmd( if (Tcl_IsSafe(interp) && (((Command *) command)->objProc == TclAliasObjCmd)) { - Tcl_AppendResult(interp, "native", NULL); + Tcl_AppendResult(interp, "native", (void *)NULL); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj(TclGetCommandTypeName(command), -1)); @@ -2684,7 +2684,7 @@ Tcl_LpopObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "index \"end\" out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" - "OUTOFRANGE", NULL); + "OUTOFRANGE", (void *)NULL); return TCL_ERROR; } @@ -3006,7 +3006,7 @@ Tcl_LrepeatObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad count \"%" TCL_LL_MODIFIER "d\": must be integer >= 0", elementCount)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG", - NULL); + (void *)NULL); return TCL_ERROR; } @@ -3022,7 +3022,7 @@ Tcl_LrepeatObjCmd( if (elementCount && objc > LIST_MAX/elementCount) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max length of a Tcl list (%" TCL_SIZE_MODIFIER "d elements) exceeded", LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); return TCL_ERROR; } totalElems = objc * elementCount; @@ -3440,7 +3440,7 @@ Tcl_LsearchObjCmd( if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing starting index", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); result = TCL_ERROR; goto done; } @@ -3464,7 +3464,7 @@ Tcl_LsearchObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-stride\" option must be " "followed by stride length", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); result = TCL_ERROR; goto done; } @@ -3476,7 +3476,7 @@ Tcl_LsearchObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "stride length must be at least 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BADSTRIDE", NULL); + "BADSTRIDE", (void *)NULL); result = TCL_ERROR; goto done; } @@ -3495,7 +3495,7 @@ Tcl_LsearchObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); result = TCL_ERROR; goto done; } @@ -3543,7 +3543,7 @@ Tcl_LsearchObjCmd( "index \"%s\" out of range", TclGetString(indices[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" - "OUTOFRANGE", NULL); + "OUTOFRANGE", (void *)NULL); result = TCL_ERROR; } if (result == TCL_ERROR) { @@ -3566,7 +3566,7 @@ Tcl_LsearchObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "-subindices cannot be used without -index option", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BAD_OPTION_MIX", NULL); + "BAD_OPTION_MIX", (void *)NULL); result = TCL_ERROR; goto done; } @@ -3575,7 +3575,7 @@ Tcl_LsearchObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "-bisect is not compatible with -all or -not", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BAD_OPTION_MIX", NULL); + "BAD_OPTION_MIX", (void *)NULL); result = TCL_ERROR; goto done; } @@ -3629,7 +3629,7 @@ Tcl_LsearchObjCmd( "list size must be a multiple of the stride length", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE", - NULL); + (void *)NULL); result = TCL_ERROR; goto done; } @@ -3645,7 +3645,7 @@ Tcl_LsearchObjCmd( "when used with \"-stride\", the leading \"-index\"" " value must be within the group", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BADINDEX", NULL); + "BADINDEX", (void *)NULL); result = TCL_ERROR; goto done; } @@ -4631,7 +4631,7 @@ Tcl_LsortObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-command\" option must be followed " "by comparison command", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -4656,7 +4656,7 @@ Tcl_LsortObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -4684,7 +4684,7 @@ Tcl_LsortObjCmd( "index \"%s\" out of range", TclGetString(indexv[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" - "OUTOFRANGE", NULL); + "OUTOFRANGE", (void *)NULL); result = TCL_ERROR; } if (result == TCL_ERROR) { @@ -4718,7 +4718,7 @@ Tcl_LsortObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-stride\" option must be " "followed by stride length", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -4730,7 +4730,7 @@ Tcl_LsortObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "stride length must be at least 2", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", - "BADSTRIDE", NULL); + "BADSTRIDE", (void *)NULL); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -4833,7 +4833,7 @@ Tcl_LsortObjCmd( "list size must be a multiple of the stride length", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE", - NULL); + (void *)NULL); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -4850,7 +4850,7 @@ Tcl_LsortObjCmd( "when used with \"-stride\", the leading \"-index\"" " value must be within the group", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", - "BADINDEX", NULL); + "BADINDEX", (void *)NULL); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -4912,7 +4912,7 @@ Tcl_LsortObjCmd( if (!elementArray) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no enough memory to proccess sort of %" TCL_Z_MODIFIER "u items", length)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -5368,7 +5368,7 @@ SortCompare( Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj( "-compare command returned non-integer result", -1)); Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", - "COMPARISONFAILED", NULL); + "COMPARISONFAILED", (void *)NULL); infoPtr->resultCode = TCL_ERROR; return 0; } @@ -5584,7 +5584,7 @@ SelectObjFromSublist( index, TclGetString(objPtr))); } Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", - "INDEXFAILED", NULL); + "INDEXFAILED", (void *)NULL); infoPtr->resultCode = TCL_ERROR; return NULL; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 36ddeea..eecf675 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -232,7 +232,7 @@ Tcl_RegexpObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "regexp match variables not allowed when using -inline", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP", - "MIX_VAR_INLINE", NULL); + "MIX_VAR_INLINE", (void *)NULL); goto optionError; } @@ -685,7 +685,7 @@ Tcl_RegsubObjCmd( "command prefix must be a list of at least one element", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGSUB", - "CMDEMPTY", NULL); + "CMDEMPTY", (void *)NULL); return TCL_ERROR; } regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); @@ -1978,7 +1978,7 @@ StringMapCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\": must be -nocase", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string, NULL); + string, (void *)NULL); return TCL_ERROR; } } @@ -2046,7 +2046,7 @@ StringMapCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("char map list unbalanced", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP", - "UNBALANCED", NULL); + "UNBALANCED", (void *)NULL); return TCL_ERROR; } } @@ -2251,7 +2251,7 @@ StringMatchCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\": must be -nocase", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string, NULL); + string, (void *)NULL); return TCL_ERROR; } } @@ -2669,7 +2669,7 @@ StringEqualCmd( "bad option \"%s\": must be -nocase or -length", string2)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string2, NULL); + string2, (void *)NULL); return TCL_ERROR; } } @@ -2769,7 +2769,7 @@ StringCmpOpts( "bad option \"%s\": must be -nocase or -length", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string, NULL); + string, (void *)NULL); return TCL_ERROR; } } @@ -3499,7 +3499,7 @@ TclNRSwitchObjCmd( "bad option \"%s\": %s option already found", TclGetString(objv[i]), options[mode])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "DOUBLEOPT", NULL); + "DOUBLEOPT", (void *)NULL); return TCL_ERROR; } foundmode = 1; @@ -3518,7 +3518,7 @@ TclNRSwitchObjCmd( "missing variable name argument to %s option", "-indexvar")); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "NOVAR", NULL); + "NOVAR", (void *)NULL); return TCL_ERROR; } indexVarObj = objv[i]; @@ -3531,7 +3531,7 @@ TclNRSwitchObjCmd( "missing variable name argument to %s option", "-matchvar")); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "NOVAR", NULL); + "NOVAR", (void *)NULL); return TCL_ERROR; } matchVarObj = objv[i]; @@ -3550,14 +3550,14 @@ TclNRSwitchObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s option requires -regexp option", "-indexvar")); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "MODERESTRICTION", NULL); + "MODERESTRICTION", (void *)NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s option requires -regexp option", "-matchvar")); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "MODERESTRICTION", NULL); + "MODERESTRICTION", (void *)NULL); return TCL_ERROR; } @@ -3612,7 +3612,7 @@ TclNRSwitchObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "extra switch pattern with no body", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", - NULL); + (void *)NULL); /* * Check if this can be due to a badly placed comment in the switch @@ -3630,7 +3630,7 @@ TclNRSwitchObjCmd( " placed outside of a switch body - see the" " \"switch\" documentation", -1); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "BADARM", "COMMENT?", NULL); + "BADARM", "COMMENT?", (void *)NULL); break; } } @@ -3649,7 +3649,7 @@ TclNRSwitchObjCmd( "no body specified for pattern \"%s\"", TclGetString(objv[objc-2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", - "FALLTHROUGH", NULL); + "FALLTHROUGH", (void *)NULL); return TCL_ERROR; } @@ -3980,7 +3980,7 @@ Tcl_ThrowObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "type must be non-empty list", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION", - NULL); + (void *)NULL); return TCL_ERROR; } @@ -4719,7 +4719,7 @@ TclNRTryObjCmd( "finally clause must be last", -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", - "NONTERMINAL", NULL); + "NONTERMINAL", (void *)NULL); return TCL_ERROR; } else if (i == objc-1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -4727,7 +4727,7 @@ TclNRTryObjCmd( " \"... finally script\"", -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", - "ARGUMENT", NULL); + "ARGUMENT", (void *)NULL); return TCL_ERROR; } finallyObj = objv[++i]; @@ -4740,7 +4740,7 @@ TclNRTryObjCmd( " variableList script\"", -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON", - "ARGUMENT", NULL); + "ARGUMENT", (void *)NULL); return TCL_ERROR; } if (TclGetCompletionCodeFromObj(interp, objv[i+1], @@ -4759,7 +4759,7 @@ TclNRTryObjCmd( -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", - "ARGUMENT", NULL); + "ARGUMENT", (void *)NULL); return TCL_ERROR; } code = 1; @@ -4769,7 +4769,7 @@ TclNRTryObjCmd( TclGetString(objv[i+1]))); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", - "EXNFORMAT", NULL); + "EXNFORMAT", (void *)NULL); return TCL_ERROR; } info[2] = objv[i+1]; @@ -4801,7 +4801,7 @@ TclNRTryObjCmd( "last non-finally clause must not have a body of \"-\"", -1)); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH", - NULL); + (void *)NULL); return TCL_ERROR; } if (!haveHandlers) { diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index fcabd37..41b8b65 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1479,7 +1479,7 @@ ParseExpr( parsePtr->string, (numBytes < limit) ? "" : "...")); if (errCode) { Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode, - subErrCode, NULL); + subErrCode, (void *)NULL); } } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c0723cd..e93fd4a 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2176,7 +2176,7 @@ TclCompileScript( if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "too many nested compilations (infinite loop?)", -1)); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", (void *)NULL); TclCompileSyntaxError(interp, envPtr); return; } @@ -2197,7 +2197,7 @@ TclCompileScript( Tcl_ObjPrintf("Script length %" TCL_SIZE_MODIFIER "d exceeds max permitted length %d.", numBytes, INT_MAX-1)); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "SCRIPTLENGTH", NULL); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "SCRIPTLENGTH", (void *)NULL); TclCompileSyntaxError(interp, envPtr); return; } diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 8f58ca8..9fb2fa7 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -229,7 +229,7 @@ QueryConfigObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", - TclGetString(pkgName), NULL); + TclGetString(pkgName), (void *)NULL); return TCL_ERROR; } @@ -244,7 +244,7 @@ QueryConfigObjCmd( || val == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } @@ -280,7 +280,7 @@ QueryConfigObjCmd( if (!listPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "insufficient memory to create list", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); return TCL_ERROR; } diff --git a/generic/tclDate.c b/generic/tclDate.c index 52bdf4c..15367bf 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2794,12 +2794,12 @@ TclClockOldscanObjCmd( if (status == 1) { Tcl_SetObjResult(interp, dateInfo.messages); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", (void *)NULL); return TCL_ERROR; } else if (status == 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1)); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); return TCL_ERROR; } else if (status != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned " @@ -2807,7 +2807,7 @@ TclClockOldscanObjCmd( "report this error as a " "bug in Tcl.", -1)); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "BUG", NULL); + Tcl_SetErrorCode(interp, "TCL", "BUG", (void *)NULL); return TCL_ERROR; } Tcl_DecrRefCount(dateInfo.messages); @@ -2815,31 +2815,31 @@ TclClockOldscanObjCmd( if (yyHaveDate > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one date in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (void *)NULL); return TCL_ERROR; } if (yyHaveTime > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time of day in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (void *)NULL); return TCL_ERROR; } if (yyHaveZone > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time zone in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (void *)NULL); return TCL_ERROR; } if (yyHaveDay > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one weekday in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (void *)NULL); return TCL_ERROR; } if (yyHaveOrdinalMonth > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one ordinal month in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (void *)NULL); return TCL_ERROR; } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 64d666f..7c56c49 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -131,7 +131,7 @@ typedef struct Dict { * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ - TCL_HASH_TYPE epoch; /* Epoch counter */ + size_t epoch; /* Epoch counter */ size_t refCount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested @@ -503,7 +503,7 @@ UpdateStringOfDict( ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; Tcl_Size i, length; - TCL_HASH_TYPE bytesNeeded = 0; + size_t bytesNeeded = 0; const char *elem; char *dst; @@ -731,7 +731,7 @@ SetDictFromAny( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing value to go with key", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", (void *)NULL); } errorInFindDictElement: DeleteChainTable(dict); @@ -826,7 +826,7 @@ TclTraceDictPath( "key \"%s\" not known in dictionary", TclGetString(keyv[i]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(keyv[i]), NULL); + TclGetString(keyv[i]), (void *)NULL); } return NULL; } @@ -1638,7 +1638,7 @@ DictGetCmd( "key \"%s\" not known in dictionary", TclGetString(objv[objc-1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(objv[objc-1]), NULL); + TclGetString(objv[objc-1]), (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, valuePtr); @@ -2515,7 +2515,7 @@ DictForNRCmd( if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); - Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", (void *)NULL); return TCL_ERROR; } searchPtr = (Tcl_DictSearch *)TclStackAlloc(interp, sizeof(Tcl_DictSearch)); @@ -2710,7 +2710,7 @@ DictMapNRCmd( if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); - Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", (void *)NULL); return TCL_ERROR; } storagePtr = (DictMapStorage *)TclStackAlloc(interp, sizeof(DictMapStorage)); @@ -3150,7 +3150,7 @@ DictFilterCmd( if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); - Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", NULL); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", (void *)NULL); return TCL_ERROR; } keyVarObj = varv[0]; diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index e8a620c..ee8da03 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -1345,7 +1345,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't a procedure", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } @@ -1395,7 +1395,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } @@ -1405,7 +1405,7 @@ Tcl_DisassembleObjCmd( "\"%s\" has no defined constructor", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "CONSRUCTOR", NULL); + "CONSRUCTOR", (void *)NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(methodPtr); @@ -1413,7 +1413,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "body not available for this kind of constructor", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); + "METHODTYPE", (void *)NULL); return TCL_ERROR; } @@ -1460,7 +1460,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } @@ -1470,7 +1470,7 @@ Tcl_DisassembleObjCmd( "\"%s\" has no defined destructor", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "DESRUCTOR", NULL); + "DESRUCTOR", (void *)NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(methodPtr); @@ -1478,7 +1478,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "body not available for this kind of destructor", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); + "METHODTYPE", (void *)NULL); return TCL_ERROR; } @@ -1525,7 +1525,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, @@ -1560,7 +1560,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[3]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[3]), NULL); + TclGetString(objv[3]), (void *)NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr)); @@ -1568,7 +1568,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "body not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); + "METHODTYPE", (void *)NULL); return TCL_ERROR; } if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) { @@ -1605,7 +1605,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not disassemble prebuilt bytecode", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "BYTECODE", NULL); + "BYTECODE", (void *)NULL); return TCL_ERROR; } if (clientData) { diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index cbb5e71..ed505f7 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1229,7 +1229,7 @@ Tcl_ExternalToUtfDStringEx( Tcl_NewStringObj( "Parameter error: TCL_ENCODING_{START,STOP} bits set in flags.", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALFLAGS", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALFLAGS", (void *)NULL); errno = EINVAL; return TCL_ERROR; } @@ -1303,7 +1303,7 @@ Tcl_ExternalToUtfDStringEx( nBytesProcessed, UCHAR(srcStart[nBytesProcessed]))); Tcl_SetErrorCode( - interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, NULL); + interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, (void *)NULL); } } if (result != TCL_OK) { @@ -1559,7 +1559,7 @@ Tcl_UtfToExternalDStringEx( Tcl_NewStringObj( "Parameter error: TCL_ENCODING_{START,STOP} bits set in flags.", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALFLAGS", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALFLAGS", (void *)NULL); errno = EINVAL; return TCL_ERROR; } @@ -1637,7 +1637,7 @@ Tcl_UtfToExternalDStringEx( pos, ucs4)); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", - buf, NULL); + buf, (void *)NULL); } } if (result != TCL_OK) { @@ -1894,7 +1894,7 @@ OpenEncodingFileChannel( if ((NULL == chan) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown encoding \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL); } Tcl_DecrRefCount(fileNameObj); Tcl_DecrRefCount(nameObj); @@ -1969,7 +1969,7 @@ LoadEncodingFile( if ((encoding == NULL) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid encoding file \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL); } Tcl_CloseEx(NULL, chan, 0); @@ -4316,7 +4316,7 @@ unilen4( static void InitializeEncodingSearchPath( char **valuePtr, - TCL_HASH_TYPE *lengthPtr, + size_t *lengthPtr, Tcl_Encoding *encodingPtr) { const char *bytes; @@ -4396,14 +4396,14 @@ TclEncodingProfileNameToId( profileName); for (i = 0; i < (numProfiles - 1); ++i) { Tcl_AppendStringsToObj( - errorObj, " ", encodingProfiles[i].name, ",", NULL); + errorObj, " ", encodingProfiles[i].name, ",", (void *)NULL); } Tcl_AppendStringsToObj( - errorObj, " or ", encodingProfiles[numProfiles-1].name, NULL); + errorObj, " or ", encodingProfiles[numProfiles-1].name, (void *)NULL); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode( - interp, "TCL", "ENCODING", "PROFILE", profileName, NULL); + interp, "TCL", "ENCODING", "PROFILE", profileName, (void *)NULL); } return TCL_ERROR; } @@ -4442,7 +4442,7 @@ TclEncodingProfileIdToName( "Internal error. Bad profile id \"%d\".", profileValue)); Tcl_SetErrorCode( - interp, "TCL", "ENCODING", "PROFILEID", NULL); + interp, "TCL", "ENCODING", "PROFILEID", (void *)NULL); } return NULL; } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 671656e..8614171 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -172,7 +172,7 @@ TclNamespaceEnsembleCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "tried to manipulate ensemble of deleted namespace", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (void *)NULL); } return TCL_ERROR; } @@ -291,7 +291,7 @@ TclNamespaceEnsembleCmd( "ensemble subcommand implementations " "must be non-empty lists", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", - "EMPTY_TARGET", NULL); + "EMPTY_TARGET", (void *)NULL); Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); @@ -307,7 +307,7 @@ TclNamespaceEnsembleCmd( Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr); if (nsPtr->parentPtr) { - Tcl_AppendStringsToObj(newCmd, "::", NULL); + Tcl_AppendStringsToObj(newCmd, "::", (void *)NULL); } Tcl_AppendObjToObj(newCmd, listv[0]); Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); @@ -579,7 +579,7 @@ TclNamespaceEnsembleCmd( "ensemble subcommand implementations " "must be non-empty lists", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", - "EMPTY_TARGET", NULL); + "EMPTY_TARGET", (void *)NULL); Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); @@ -600,7 +600,7 @@ TclNamespaceEnsembleCmd( Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr); if (nsPtr->parentPtr) { - Tcl_AppendStringsToObj(newCmd, "::", NULL); + Tcl_AppendStringsToObj(newCmd, "::", (void *)NULL); } Tcl_AppendObjToObj(newCmd, listv[0]); Tcl_ListObjReplace(NULL, newList, 0, 1, 1, @@ -627,7 +627,7 @@ TclNamespaceEnsembleCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "option -namespace is read-only", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY", - NULL); + (void *)NULL); goto freeMapAndError; case CONF_PREFIX: if (Tcl_GetBooleanFromObj(interp, objv[1], @@ -799,7 +799,7 @@ Tcl_SetEnsembleSubcommandList( if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL); return TCL_ERROR; } if (subcmdList != NULL) { @@ -875,7 +875,7 @@ Tcl_SetEnsembleParameterList( if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL); return TCL_ERROR; } if (paramList == NULL) { @@ -951,7 +951,7 @@ Tcl_SetEnsembleMappingDict( if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL); return TCL_ERROR; } if (mapDict != NULL) { @@ -979,7 +979,7 @@ Tcl_SetEnsembleMappingDict( "ensemble target is not a fully-qualified command", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", - "UNQUALIFIED_TARGET", NULL); + "UNQUALIFIED_TARGET", (void *)NULL); Tcl_DictObjDone(&search); return TCL_ERROR; } @@ -1051,7 +1051,7 @@ Tcl_SetEnsembleUnknownHandler( if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL); return TCL_ERROR; } if (unknownList != NULL) { @@ -1117,7 +1117,7 @@ Tcl_SetEnsembleFlags( if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL); return TCL_ERROR; } @@ -1194,7 +1194,7 @@ Tcl_GetEnsembleSubcommandList( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL); } return TCL_ERROR; } @@ -1236,7 +1236,7 @@ Tcl_GetEnsembleParameterList( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL); } return TCL_ERROR; } @@ -1278,7 +1278,7 @@ Tcl_GetEnsembleMappingDict( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL); } return TCL_ERROR; } @@ -1319,7 +1319,7 @@ Tcl_GetEnsembleUnknownHandler( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL); } return TCL_ERROR; } @@ -1360,7 +1360,7 @@ Tcl_GetEnsembleFlags( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL); } return TCL_ERROR; } @@ -1401,7 +1401,7 @@ Tcl_GetEnsembleNamespace( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL); } return TCL_ERROR; } @@ -1462,7 +1462,7 @@ Tcl_FindEnsemble( "\"%s\" is not an ensemble command", TclGetString(cmdNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", - TclGetString(cmdNameObj), NULL); + TclGetString(cmdNameObj), (void *)NULL); } return NULL; } @@ -1755,7 +1755,7 @@ NsEnsembleImplementationCmdNR( if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble activated for deleted namespace", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (void *)NULL); } return TCL_ERROR; } @@ -1968,7 +1968,7 @@ NsEnsembleImplementationCmdNR( Tcl_ResetResult(interp); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(subObj), NULL); + TclGetString(subObj), (void *)NULL); if (ensemblePtr->subcommandTable.numEntries == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown subcommand \"%s\": namespace %s does not" @@ -2328,7 +2328,7 @@ EnsembleUnknownCallback( Tcl_SetObjResult(interp, Tcl_NewStringObj( "unknown subcommand handler deleted its ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED", - NULL); + (void *)NULL); } result = TCL_ERROR; } @@ -2392,7 +2392,7 @@ EnsembleUnknownCallback( "ensemble unknown subcommand handler: "); Tcl_AppendObjToErrorInfo(interp, unknownCmd); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT", - NULL); + (void *)NULL); } else { Tcl_AddErrorInfo(interp, "\n (ensemble unknown subcommand handler)"); @@ -2726,7 +2726,7 @@ BuildEnsembleConfig( Tcl_AppendStringsToObj(cmdObj, ensemblePtr->nsPtr->fullName, (ensemblePtr->nsPtr->parentPtr ? "::" : ""), - nsCmdName, NULL); + nsCmdName, (void *)NULL); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 4365984..af76051 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -350,7 +350,7 @@ TclDefaultBgErrorHandlerObjCmd( if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-level\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) { @@ -363,7 +363,7 @@ TclDefaultBgErrorHandlerObjCmd( if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-code\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) { @@ -1082,7 +1082,7 @@ static const struct { #ifdef __INTEL_COMPILER ".icc-" STRINGIFY(__INTEL_COMPILER) #endif -#if (defined(_WIN32) && !defined(_WIN64)) || (ULONG_MAX == 0xffffffffUL) +#if (defined(_WIN32) || (ULONG_MAX == 0xffffffffUL)) && !defined(_WIN64) ".ilp32" #endif #ifdef TCL_MEM_DEBUG @@ -1568,7 +1568,7 @@ Tcl_VwaitObjCmd( Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "argument required for \"%s\"", vWaitOptionStrings[index])); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "ARGUMENT", NULL); + Tcl_SetErrorCode(interp, "TCL", "EVENT", "ARGUMENT", (void *)NULL); result = TCL_ERROR; goto done; } @@ -1580,7 +1580,7 @@ Tcl_VwaitObjCmd( Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_NewStringObj( "timeout must be positive", -1)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "NEGTIME", NULL); + Tcl_SetErrorCode(interp, "TCL", "EVENT", "NEGTIME", (void *)NULL); result = TCL_ERROR; goto done; } @@ -1660,7 +1660,7 @@ Tcl_VwaitObjCmd( TCL_TIMER_EVENTS | TCL_WINDOW_EVENTS)) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't wait: would block forever", -1)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL); + Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", (void *)NULL); result = TCL_ERROR; goto done; } @@ -1668,7 +1668,7 @@ Tcl_VwaitObjCmd( if ((timeout > 0) && ((mask & TCL_TIMER_EVENTS) == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "timer events disabled with timeout specified", -1)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_TIME", NULL); + Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_TIME", (void *)NULL); result = TCL_ERROR; goto done; } @@ -1696,7 +1696,7 @@ Tcl_VwaitObjCmd( if (vwaitItems[i].mask) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "file events disabled with channel(s) specified", -1)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_FILE_EVENT", NULL); + Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_FILE_EVENT", (void *)NULL); result = TCL_ERROR; goto done; } @@ -1735,7 +1735,7 @@ Tcl_VwaitObjCmd( if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "LIMIT", NULL); + Tcl_SetErrorCode(interp, "TCL", "EVENT", "LIMIT", (void *)NULL); break; } if ((numItems == 0) && (timeout == 0)) { @@ -1755,7 +1755,7 @@ Tcl_VwaitObjCmd( "can't wait: would wait forever" : "can't wait for variable(s)/channel(s): would wait forever", -1)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL); + Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", (void *)NULL); result = TCL_ERROR; goto done; } @@ -2055,7 +2055,7 @@ Tcl_CreateThread( Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */ void *clientData, /* The one argument to Main() */ - TCL_HASH_TYPE stackSize, /* Size of stack for the new thread */ + size_t stackSize, /* Size of stack for the new thread */ int flags) /* Flags controlling behaviour of the new * thread. */ { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 32de619..3f8f87a 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -635,7 +635,7 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, Tcl_Size *lengthPtr, const unsigned char **pcBeg, Tcl_Size *cmdIdxPtr); -static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, TCL_HASH_TYPE growth, +static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, size_t growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); @@ -643,8 +643,8 @@ static void InitByteCodeExecution(Tcl_Interp *interp); static inline int wordSkip(void *ptr); static void ReleaseDictIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ -static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, TCL_HASH_TYPE numWords); -static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, TCL_HASH_TYPE numWords); +static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, size_t numWords); +static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, size_t numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; static Tcl_NRPostProc FinalizeOONext; @@ -792,7 +792,7 @@ ExecEnv * TclCreateExecEnv( Tcl_Interp *interp, /* Interpreter for which the execution * environment is being created. */ - TCL_HASH_TYPE size) /* The initial stack size, in number of words + size_t size) /* The initial stack size, in number of words * [sizeof(Tcl_Obj*)] */ { ExecEnv *eePtr = (ExecEnv *)Tcl_Alloc(sizeof(ExecEnv)); @@ -974,12 +974,12 @@ static Tcl_Obj ** GrowEvaluationStack( ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation * stack to enlarge. */ - TCL_HASH_TYPE growth1, /* How much larger than the current used + size_t growth1, /* How much larger than the current used * size. */ int move) /* 1 if move words since last marker. */ { ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL; - TCL_HASH_TYPE newBytes; + size_t newBytes; Tcl_Size growth = growth1; Tcl_Size newElems, currElems, needed = growth - (esPtr->endPtr - esPtr->tosPtr); Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart; @@ -1126,7 +1126,7 @@ GrowEvaluationStack( static Tcl_Obj ** StackAllocWords( Tcl_Interp *interp, - TCL_HASH_TYPE numWords) + size_t numWords) { /* * Note that GrowEvaluationStack sets a marker in the stack. This marker @@ -1144,7 +1144,7 @@ StackAllocWords( static Tcl_Obj ** StackReallocWords( Tcl_Interp *interp, - TCL_HASH_TYPE numWords) + size_t numWords) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr = iPtr->execEnvPtr; @@ -1223,10 +1223,10 @@ TclStackFree( void * TclStackAlloc( Tcl_Interp *interp, - TCL_HASH_TYPE numBytes) + size_t numBytes) { Interp *iPtr = (Interp *) interp; - TCL_HASH_TYPE numWords; + size_t numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return Tcl_Alloc(numBytes); @@ -1239,13 +1239,13 @@ void * TclStackRealloc( Tcl_Interp *interp, void *ptr, - TCL_HASH_TYPE numBytes) + size_t numBytes) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr; ExecStack *esPtr; Tcl_Obj **markerPtr; - TCL_HASH_TYPE numWords; + size_t numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return Tcl_Realloc(ptr, numBytes); @@ -1888,10 +1888,10 @@ TclNRExecuteByteCode( { Interp *iPtr = (Interp *) interp; TEBCdata *TD; - TCL_HASH_TYPE size = sizeof(TEBCdata) - 1 + size_t size = sizeof(TEBCdata) - 1 + (codePtr->maxStackDepth + codePtr->maxExceptDepth) * sizeof(void *); - TCL_HASH_TYPE numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); + size_t numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); TclPreserveByteCode(codePtr); @@ -2379,7 +2379,7 @@ TEBCresume( "yield can only be called in a coroutine", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", - NULL); + (void *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -2410,7 +2410,7 @@ TEBCresume( "yieldto can only be called in a coroutine", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", - NULL); + (void *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -2421,7 +2421,7 @@ TEBCresume( "yieldto called in deleted namespace", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", - NULL); + (void *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -2483,7 +2483,7 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_NewStringObj( "tailcall can only be called from a proc or lambda", -1)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (void *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -3999,7 +3999,7 @@ TEBCresume( TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", "variable isn't array", opnd); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (void *)NULL); CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; @@ -4300,7 +4300,7 @@ TEBCresume( TRACE_ERROR(interp); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", - TclGetString(OBJ_AT_TOS), NULL); + TclGetString(OBJ_AT_TOS), (void *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4340,7 +4340,7 @@ TEBCresume( "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS))); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(OBJ_AT_TOS), NULL); + TclGetString(OBJ_AT_TOS), (void *)NULL); CACHE_STACK_INFO(); TRACE_APPEND(("ERROR: not command\n")); goto gotError; @@ -4369,7 +4369,7 @@ TEBCresume( "self may only be called from inside a method", -1)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4397,7 +4397,7 @@ TEBCresume( "nextto may only be called from inside a method", -1)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4418,7 +4418,7 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(valuePtr))); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", (void *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4470,7 +4470,7 @@ TEBCresume( methodType, TclGetString(valuePtr))); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", - NULL); + (void *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4478,7 +4478,7 @@ TEBCresume( "%s has no non-filter implementation by \"%s\"", methodType, TclGetString(valuePtr))); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", (void *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4496,7 +4496,7 @@ TEBCresume( "next may only be called from inside a method", -1)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4525,7 +4525,7 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no next %s implementation", methodType)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", (void *)NULL); CACHE_STACK_INFO(); goto gotError; #ifdef TCL_COMPILE_DEBUG @@ -5101,7 +5101,7 @@ TEBCresume( case INST_LREPLACE4: { - TCL_HASH_TYPE numToDelete, numNewElems; + size_t numToDelete, numNewElems; int end_indicator; int haveSecondIndex, flags; Tcl_Obj *fromIdxObj, *toIdxObj; @@ -5904,7 +5904,7 @@ TEBCresume( DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", - NULL); + (void *)NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; @@ -5953,7 +5953,7 @@ TEBCresume( DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", - NULL); + (void *)NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; @@ -5975,7 +5975,7 @@ TEBCresume( #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", NULL); + "integer value too large to represent", (void *)NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; @@ -6808,7 +6808,7 @@ TEBCresume( TclGetString(OBJ_AT_TOS))); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); + TclGetString(OBJ_AT_TOS), (void *)NULL); CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; @@ -7513,14 +7513,14 @@ TEBCresume( divideByZero: Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", (void *)NULL); CACHE_STACK_INFO(); goto gotError; outOfMemory: Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "OUTOFMEMORY", "out of memory", NULL); + Tcl_SetErrorCode(interp, "ARITH", "OUTOFMEMORY", "out of memory", (void *)NULL); CACHE_STACK_INFO(); goto gotError; @@ -7534,7 +7534,7 @@ TEBCresume( "exponentiation of zero by negative power", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "exponentiation of zero by negative power", NULL); + "exponentiation of zero by negative power", (void *)NULL); CACHE_STACK_INFO(); /* @@ -8048,7 +8048,7 @@ ExecuteExtendedBinaryMathOp( } Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); - err = mp_init_multi(&bigResult, &bigRemainder, NULL); + err = mp_init_multi(&bigResult, &bigRemainder, (void *)NULL); if (err == MP_OKAY) { err = mp_div(&big1, &big2, &bigResult, &bigRemainder); } @@ -9081,7 +9081,7 @@ IllegalExprOperandType( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use %s \"%s\" as operand of \"%s\"", description, TclGetString(opndPtr), op)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, (void *)NULL); } /* @@ -9459,23 +9459,23 @@ TclExprFloatError( if ((errno == EDOM) || isnan(value)) { s = "domain error: argument not in valid range"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (void *)NULL); } else if ((errno == ERANGE) || isinf(value)) { if (value == 0.0) { s = "floating-point value too small to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (void *)NULL); } else { s = "floating-point value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (void *)NULL); } } else { Tcl_Obj *objPtr = Tcl_ObjPrintf( "unknown floating-point error, errno = %d", errno); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", - TclGetString(objPtr), NULL); + TclGetString(objPtr), (void *)NULL); Tcl_SetObjResult(interp, objPtr); } } diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 68eaab5..4cea92e 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1115,7 +1115,7 @@ TclFileAttrsCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); + Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", (void *)NULL); goto end; } @@ -1139,7 +1139,7 @@ TclFileAttrsCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); + Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", (void *)NULL); goto end; } @@ -1152,7 +1152,7 @@ TclFileAttrsCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR", - "NOVALUE", NULL); + "NOVALUE", (void *)NULL); goto end; } if (Tcl_FSFileAttrsSet(interp, index, filePtr, diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 8a58459..df9c5fa 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1172,7 +1172,7 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-directory\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); return TCL_ERROR; } if (dir != PATH_NONE) { @@ -1182,7 +1182,7 @@ Tcl_GlobObjCmd( : "\"-directory\" cannot be used with \"-path\"", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", - "BADOPTIONCOMBINATION", NULL); + "BADOPTIONCOMBINATION", (void *)NULL); return TCL_ERROR; } dir = PATH_DIR; @@ -1200,7 +1200,7 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-path\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); return TCL_ERROR; } if (dir != PATH_NONE) { @@ -1210,7 +1210,7 @@ Tcl_GlobObjCmd( : "\"-path\" cannot be used with \"-dictionary\"", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", - "BADOPTIONCOMBINATION", NULL); + "BADOPTIONCOMBINATION", (void *)NULL); return TCL_ERROR; } dir = PATH_GENERAL; @@ -1221,7 +1221,7 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-types\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); return TCL_ERROR; } typePtr = objv[i+1]; @@ -1242,7 +1242,7 @@ Tcl_GlobObjCmd( "\"-tails\" must be used with either " "\"-directory\" or \"-path\"", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", - "BADOPTIONCOMBINATION", NULL); + "BADOPTIONCOMBINATION", (void *)NULL); return TCL_ERROR; } @@ -1306,11 +1306,15 @@ Tcl_GlobObjCmd( * We must ensure that we haven't cut off too much, and turned * a valid path like '/' or 'C:/' into an incorrect path like * '' or 'C:'. The way we do this is to add a separator if - * there are none presently in the prefix. + * there are none presently in the prefix. Similar treatment + * for the zipfs volume. */ - if (strpbrk(TclGetString(pathOrDir), "\\/") == NULL) { + const char *temp = TclGetString(pathOrDir); + if (strpbrk(temp, "\\/") == NULL) { Tcl_AppendToObj(pathOrDir, last-1, 1); + } else if (!strcmp(temp, "//zipfs:")) { + Tcl_AppendToObj(pathOrDir, "/", 1); } } @@ -1452,7 +1456,7 @@ Tcl_GlobObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument to \"-types\": %s", TclGetString(look))); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (void *)NULL); result = TCL_ERROR; join = 0; goto endOfGlob; @@ -1462,7 +1466,7 @@ Tcl_GlobObjCmd( "only one MacOS type or creator argument" " to \"-types\" allowed", -1)); result = TCL_ERROR; - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (void *)NULL); join = 0; goto endOfGlob; } @@ -2035,14 +2039,14 @@ DoGlob( Tcl_SetObjResult(interp, Tcl_NewStringObj( "unmatched open-brace in file name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", - NULL); + (void *)NULL); return TCL_ERROR; } else if (*p == '}') { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unmatched close-brace in file name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", - NULL); + (void *)NULL); return TCL_ERROR; } } diff --git a/generic/tclHash.c b/generic/tclHash.c index cb1e3c7..4703cd2 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -36,7 +36,7 @@ static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); +static size_t HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the string hash key methods. @@ -45,7 +45,7 @@ static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); +static size_t HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Function prototypes for static functions in this file: @@ -247,7 +247,7 @@ CreateHashEntry( { Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; - TCL_HASH_TYPE hash, index; + size_t hash, index; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; @@ -369,7 +369,7 @@ Tcl_DeleteHashEntry( const Tcl_HashKeyType *typePtr; Tcl_HashTable *tablePtr; Tcl_HashEntry **bucketPtr; - TCL_HASH_TYPE index; + size_t index; tablePtr = entryPtr->tablePtr; @@ -588,7 +588,7 @@ Tcl_HashStats( { #define NUM_COUNTERS 10 Tcl_Size i; - TCL_HASH_TYPE count[NUM_COUNTERS], overflow, j; + size_t count[NUM_COUNTERS], overflow, j; double average, tmp; Tcl_HashEntry *hPtr; char *result, *p; @@ -660,8 +660,8 @@ AllocArrayEntry( void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_HashEntry *hPtr; - TCL_HASH_TYPE count = tablePtr->keyType * sizeof(int); - TCL_HASH_TYPE size = offsetof(Tcl_HashEntry, key) + count; + size_t count = tablePtr->keyType * sizeof(int); + size_t size = offsetof(Tcl_HashEntry, key) + count; if (size < sizeof(Tcl_HashEntry)) { size = sizeof(Tcl_HashEntry); @@ -719,13 +719,13 @@ CompareArrayKeys( *---------------------------------------------------------------------- */ -static TCL_HASH_TYPE +static size_t HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ { const int *array = (const int *) keyPtr; - TCL_HASH_TYPE result; + size_t result; int count; for (result = 0, count = tablePtr->keyType; count > 0; @@ -813,13 +813,13 @@ CompareStringKeys( *---------------------------------------------------------------------- */ -static TCL_HASH_TYPE +static size_t HashStringKey( TCL_UNUSED(Tcl_HashTable *), void *keyPtr) /* Key from which to compute hash value. */ { const char *string = (const char *)keyPtr; - TCL_HASH_TYPE result; + size_t result; char c; /* @@ -937,7 +937,7 @@ static void RebuildTable( Tcl_HashTable *tablePtr) /* Table to enlarge. */ { - TCL_HASH_TYPE count, index, oldSize = tablePtr->numBuckets; + size_t count, index, oldSize = tablePtr->numBuckets; Tcl_HashEntry **oldBuckets = tablePtr->buckets; Tcl_HashEntry **oldChainPtr, **newChainPtr; Tcl_HashEntry *hPtr; diff --git a/generic/tclIO.c b/generic/tclIO.c index fdaf9b7..e304b48 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1465,7 +1465,7 @@ Tcl_GetChannel( if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can not find channel named \"%s\"", chanName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanName, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanName, (void *)NULL); return NULL; } @@ -9735,12 +9735,12 @@ CopyData( if (interp) { TclNewObj(errObj); Tcl_AppendStringsToObj(errObj, "error reading \"", - Tcl_GetChannelName(inChan), "\": ", NULL); + Tcl_GetChannelName(inChan), "\": ", (void *)NULL); if (msg != NULL) { Tcl_AppendObjToObj(errObj, msg); } else { Tcl_AppendStringsToObj(errObj, Tcl_PosixError(interp), - NULL); + (void *)NULL); } } if (msg != NULL) { @@ -9811,12 +9811,12 @@ CopyData( if (interp) { TclNewObj(errObj); Tcl_AppendStringsToObj(errObj, "error writing \"", - Tcl_GetChannelName(outChan), "\": ", NULL); + Tcl_GetChannelName(outChan), "\": ", (void *)NULL); if (msg != NULL) { Tcl_AppendObjToObj(errObj, msg); } else { Tcl_AppendStringsToObj(errObj, Tcl_PosixError(interp), - NULL); + (void *)NULL); } } if (msg != NULL) { diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 37be141..a664893 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -424,7 +424,7 @@ Tcl_ReadObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected non-negative integer but got \"%s\"", TclGetString(objv[i]))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (void *)NULL); return TCL_ERROR; } } diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index f577599..b2b959d 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -474,7 +474,7 @@ ExecuteCallback( } nonBytes: Tcl_AppendResult(interp, "chan transform callback received non-bytes", - NULL); + (void *)NULL); Tcl_Release(eval); return TCL_ERROR; diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index f313ab7..6ba6ad8 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -448,7 +448,7 @@ static Tcl_Obj * DecodeEventMask(int mask); static ReflectedChannel * NewReflectedChannel(Tcl_Interp *interp, Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj); static Tcl_Obj * NextHandle(void); -static void FreeReflectedChannel(ReflectedChannel *rcPtr); +static Tcl_FreeProc FreeReflectedChannel; static int InvokeTclMethod(ReflectedChannel *rcPtr, MethodName method, Tcl_Obj *argOneObj, Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr); @@ -874,7 +874,7 @@ TclChanPostEventObjCmd( if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can not find reflected channel named \"%s\"", chanId)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, (void *)NULL); return TCL_ERROR; } @@ -1230,7 +1230,7 @@ ReflectClose( if (rcPtr->writeTimer != NULL) { Tcl_DeleteTimerHandler(rcPtr->writeTimer); } - Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, FreeReflectedChannel); return EOK; } @@ -1305,7 +1305,7 @@ ReflectClose( if (rcPtr->writeTimer != NULL) { Tcl_DeleteTimerHandler(rcPtr->writeTimer); } - Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree(rcPtr, FreeReflectedChannel); return (result == TCL_OK) ? EOK : EINVAL; } @@ -2318,8 +2318,9 @@ NextHandle(void) static void FreeReflectedChannel( - ReflectedChannel *rcPtr) + void *blockPtr) { + ReflectedChannel *rcPtr = (ReflectedChannel *) blockPtr; Channel *chanPtr = (Channel *) rcPtr->chan; TclChannelRelease((Tcl_Channel)chanPtr); diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 90e7195..9328de8 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -413,7 +413,7 @@ static ReflectedTransform * NewReflectedTransform(Tcl_Interp *interp, Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj, Tcl_Channel parentChan); static Tcl_Obj * NextHandle(void); -static void FreeReflectedTransform(ReflectedTransform *rtPtr); +static Tcl_FreeProc FreeReflectedTransform; static void FreeReflectedTransformArgs(ReflectedTransform *rtPtr); static int InvokeTclMethod(ReflectedTransform *rtPtr, const char *method, Tcl_Obj *argOneObj, @@ -713,7 +713,7 @@ TclChanPushObjCmd( * structure. */ - Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, FreeReflectedTransform); return TCL_ERROR; #undef CHAN @@ -923,7 +923,7 @@ ReflectClose( } #endif /* TCL_THREADS */ - Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, FreeReflectedTransform); return EOK; } @@ -940,7 +940,7 @@ ReflectClose( #if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { Tcl_EventuallyFree(rtPtr, - (Tcl_FreeProc *) FreeReflectedTransform); + FreeReflectedTransform); return errorCode; } #endif /* TCL_THREADS */ @@ -954,7 +954,7 @@ ReflectClose( #if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { Tcl_EventuallyFree(rtPtr, - (Tcl_FreeProc *) FreeReflectedTransform); + FreeReflectedTransform); return errorCode; } #endif /* TCL_THREADS */ @@ -974,7 +974,7 @@ ReflectClose( ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p); result = p.base.code; - Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, FreeReflectedTransform); if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); @@ -1033,7 +1033,7 @@ ReflectClose( #endif /* TCL_THREADS */ } - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); + Tcl_EventuallyFree(rtPtr, FreeReflectedTransform); return errorCodeSet ? errorCode : ((result == TCL_OK) ? EOK : EINVAL); } @@ -1870,8 +1870,9 @@ FreeReflectedTransformArgs( static void FreeReflectedTransform( - ReflectedTransform *rtPtr) + void *blockPtr) { + ReflectedTransform *rtPtr = (ReflectedTransform *) blockPtr; TimerKill(rtPtr); ResultClear(&rtPtr->result); diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 306ba41..921d79e 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -761,6 +761,7 @@ TclFinalizeFilesystem(void) * needed. */ + TclZipfsFinalize(); fsRecPtr = filesystemList; while (fsRecPtr != NULL) { FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; @@ -2052,7 +2053,7 @@ Tcl_PosixError( msg = Tcl_ErrnoMsg(errno); id = Tcl_ErrnoId(); if (interp) { - Tcl_SetErrorCode(interp, "POSIX", id, msg, NULL); + Tcl_SetErrorCode(interp, "POSIX", id, msg, (void *)NULL); } return msg; } @@ -2282,11 +2283,17 @@ Tcl_FSUtime( * times to use. Should not be modified. */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + int err; - if (fsPtr != NULL && fsPtr->utimeProc != NULL) { - return fsPtr->utimeProc(pathPtr, tval); + if (fsPtr == NULL) { + err = ENOENT; + } else { + if (fsPtr->utimeProc != NULL) { + return fsPtr->utimeProc(pathPtr, tval); + } + err = ENOTSUP; } - /* TODO: set errno here? Tcl_SetErrno(ENOENT); */ + Tcl_SetErrno(err); return -1; } @@ -3604,91 +3611,6 @@ Tcl_FSUnloadFile( } /* - *---------------------------------------------------------------------- - * - * TclFSUnloadTempFile -- - * - * Unloads an object loaded via temporary file from a virtual filesystem - * to a native filesystem. - * - * Results: - * None. - * - * Side effects: - * Frees resources for the loaded object and deletes the temporary file. - * - *---------------------------------------------------------------------- - */ - -void -TclFSUnloadTempFile( - Tcl_LoadHandle loadHandle) /* A handle for the object, as provided by a - * previous call to Tcl_FSLoadFile(). */ -{ - FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle; - - if (tvdlPtr == NULL) { - /* - * tvdlPtr was provided by Tcl_LoadFile so it should not be NULL here. - */ - return; - } - - if (tvdlPtr->unloadProcPtr != NULL) { - /* - * 'unloadProcPtr' must be called first so that the shared library is - * actually unloaded by the OS. Otherwise, the following 'delete' may - * well fail because the shared library is still in use. - */ - - tvdlPtr->unloadProcPtr(tvdlPtr->loadHandle); - } - - if (tvdlPtr->divertedFilesystem == NULL) { - /* - * Call the function for the native fileystem, which works even at this - * late stage. - */ - - TclpDeleteFile(tvdlPtr->divertedFileNativeRep); - NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep); - } else { - /* - * Remove the temporary file that was created. If encodings have - * already been freed because the interpreter is exiting this may - * crash. - */ - - if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile) - != TCL_OK) { - /* - * This may have happened because Tcl is exiting and encodings may - * have already been deleted, or something else the filesystem - * depends on may be gone. - * - * TO DO: Figure out how to delete this file more robustly, or - * give the filesystem the information it needs to delete the file - * more robustly. One problem might be that the filesystem cannot - * extract the information it needs from the above pathname object - * because Tcl's entire filesystem apparatus (the code in this - * file) has been finalized and there is no way to get the native - * handle of the file. - */ - } - - /* - * This also decrements the refCount of the Tcl_Filesystem - * corresponding to this file. which might case filesystem to be freed - * if Tcl is exiting. - */ - - Tcl_DecrRefCount(tvdlPtr->divertedFile); - } - - Tcl_Free(tvdlPtr); -} - -/* *--------------------------------------------------------------------------- * * Tcl_FSLink -- @@ -3732,8 +3654,13 @@ Tcl_FSLink( { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL && fsPtr->linkProc != NULL) { - return fsPtr->linkProc(pathPtr, toPtr, linkAction); + if (fsPtr) { + if (fsPtr->linkProc == NULL) { + Tcl_SetErrno(ENOTSUP); + return NULL; + } else { + return fsPtr->linkProc(pathPtr, toPtr, linkAction); + } } /* @@ -4304,11 +4231,17 @@ Tcl_FSDeleteFile( Tcl_Obj *pathPtr) /* Pathname of file to be removed (UTF-8). */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + int err; - if (fsPtr != NULL && fsPtr->deleteFileProc != NULL) { - return fsPtr->deleteFileProc(pathPtr); + if (fsPtr == NULL) { + err = ENOENT; + } else { + if (fsPtr->deleteFileProc != NULL) { + return fsPtr->deleteFileProc(pathPtr); + } + err = ENOTSUP; } - Tcl_SetErrno(ENOENT); + Tcl_SetErrno(err); return -1; } @@ -4335,11 +4268,17 @@ Tcl_FSCreateDirectory( Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + int err; - if (fsPtr != NULL && fsPtr->createDirectoryProc != NULL) { - return fsPtr->createDirectoryProc(pathPtr); + if (fsPtr == NULL) { + err = ENOENT; + } else { + if (fsPtr->createDirectoryProc != NULL) { + return fsPtr->createDirectoryProc(pathPtr); + } + err = ENOTSUP; } - Tcl_SetErrno(ENOENT); + Tcl_SetErrno(err); return -1; } @@ -4420,10 +4359,14 @@ Tcl_FSRemoveDirectory( { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr == NULL || fsPtr->removeDirectoryProc == NULL) { + if (fsPtr == NULL) { Tcl_SetErrno(ENOENT); return -1; } + if (fsPtr->removeDirectoryProc == NULL) { + Tcl_SetErrno(ENOTSUP); + return -1; + } if (recursive) { Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 3134b66..7decf1f 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -334,29 +334,29 @@ Tcl_GetIndexFromObjStruct( } Tcl_AppendStringsToObj(resultPtr, (numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "), - msg, " \"", key, NULL); + msg, " \"", key, (void *)NULL); if (*entryPtr == NULL) { - Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL); + Tcl_AppendStringsToObj(resultPtr, "\": no valid options", (void *)NULL); } else { Tcl_AppendStringsToObj(resultPtr, "\": must be ", - *entryPtr, NULL); + *entryPtr, (void *)NULL); entryPtr = NEXT_ENTRY(entryPtr, offset); while (*entryPtr != NULL) { if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_NULL_OK)) { Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""), - " or ", *entryPtr, NULL); + " or ", *entryPtr, (void *)NULL); } else if (**entryPtr) { - Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL); + Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, (void *)NULL); count++; } entryPtr = NEXT_ENTRY(entryPtr, offset); } if ((flags & TCL_NULL_OK)) { - Tcl_AppendStringsToObj(resultPtr, ", or \"\"", NULL); + Tcl_AppendStringsToObj(resultPtr, ", or \"\"", (void *)NULL); } } Tcl_SetObjResult(interp, resultPtr); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, (void *)NULL); } return TCL_ERROR; } @@ -537,7 +537,7 @@ PrefixMatchObjCmd( if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing value for -message", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", (void *)NULL); return TCL_ERROR; } i++; @@ -547,7 +547,7 @@ PrefixMatchObjCmd( if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing value for -error", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", (void *)NULL); return TCL_ERROR; } i++; @@ -559,7 +559,7 @@ PrefixMatchObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "error options must have an even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", (void *)NULL); return TCL_ERROR; } errorPtr = objv[i]; @@ -893,7 +893,7 @@ Tcl_WrongNumArgs( */ if (i<toPrint-1 || objc!=0 || message!=NULL) { - Tcl_AppendStringsToObj(objPtr, " ", NULL); + Tcl_AppendStringsToObj(objPtr, " ", (void *)NULL); } } } @@ -915,7 +915,7 @@ Tcl_WrongNumArgs( if ((irPtr = TclFetchInternalRep(objv[i], &tclIndexType))) { IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; - Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); + Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (void *)NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). @@ -943,7 +943,7 @@ Tcl_WrongNumArgs( */ if (i + 1 < objc || message!=NULL) { - Tcl_AppendStringsToObj(objPtr, " ", NULL); + Tcl_AppendStringsToObj(objPtr, " ", (void *)NULL); } } @@ -954,10 +954,10 @@ Tcl_WrongNumArgs( */ if (message != NULL) { - Tcl_AppendStringsToObj(objPtr, message, NULL); + Tcl_AppendStringsToObj(objPtr, message, (void *)NULL); } - Tcl_AppendStringsToObj(objPtr, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + Tcl_AppendStringsToObj(objPtr, "\"", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL); Tcl_SetObjResult(interp, objPtr); } @@ -1379,7 +1379,7 @@ TclGetCompletionCodeFromObj( "bad completion code \"%s\": must be" " ok, error, return, break, continue, or an integer", TclGetString(value))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", (void *)NULL); } return TCL_ERROR; } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index bc0285c..36c6159 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -137,14 +137,15 @@ declare 46 { declare 51 { int TclInterpInit(Tcl_Interp *interp) } -declare 53 { - int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp, - int argc, const char **argv) -} -declare 54 { - int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -} +# Removed in 9.0 +#declare 53 { +# int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp, +# Tcl_Size argc, const char **argv) +#} +#declare 54 { +# int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp, +# Tcl_Size objc, Tcl_Obj *const objv[]) +#} declare 55 { Proc *TclIsProc(Command *cmdPtr) } @@ -162,12 +163,13 @@ declare 61 { declare 62 { int TclObjCommandComplete(Tcl_Obj *cmdPtr) } -declare 63 { - int TclObjInterpProc(void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -} +# Removed in 9.0: +#declare 63 { +# int TclObjInterpProc(void *clientData, Tcl_Interp *interp, +# Tcl_Size objc, Tcl_Obj *const objv[]) +#} declare 64 { - int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], + int TclObjInvoke(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags) } declare 69 { @@ -548,8 +550,26 @@ declare 217 { declare 218 { void TclPopStackFrame(Tcl_Interp *interp) } +# TIP 431: temporary directory creation function +declare 219 { + Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj) +} # for use in tclTest.c + +# TIP 625: for unit testing - create list objects with span +declare 221 { + Tcl_Obj *TclListTestObj(size_t length, size_t leadingSpace, size_t endSpace) +} +# TIP 625: for unit testing - check list invariants +declare 222 { + void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj) +} +# Bug 7371b6270b +declare 223 { + void *TclGetCStackPtr(void) +} declare 224 { TclPlatformType *TclGetPlatform(void) } @@ -609,7 +629,7 @@ declare 237 { # include NRE.h too. declare 238 { int TclNRInterpProc(void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) + Tcl_Size objc, Tcl_Obj *const objv[]) } declare 239 { int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, @@ -698,20 +718,8 @@ declare 257 { Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) } -# TIP 431: temporary directory creation function -declare 258 { - Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj) -} - -# TIP 625: for unit testing - create list objects with span -declare 260 { - Tcl_Obj *TclListTestObj(size_t length, size_t leadingSpace, size_t endSpace) -} - -# TIP 625: for unit testing - check list invariants declare 261 { - void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj) + void TclUnusedStubEntry(void) } ############################################################################## diff --git a/generic/tclInt.h b/generic/tclInt.h index fa9bb26..984b5c5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3327,7 +3327,6 @@ MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp, void *clientData, Tcl_CmdDeleteProc *deleteProc); MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); -MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); MODULE_SCOPE int * TclGetAsyncReadyPtr(void); MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, @@ -3558,6 +3557,9 @@ MODULE_SCOPE Tcl_Size TclTrimLeft(const char *bytes, Tcl_Size numBytes, MODULE_SCOPE Tcl_Size TclTrimRight(const char *bytes, Tcl_Size numBytes, const char *trim, Tcl_Size numTrim); MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); +MODULE_SCOPE int TclObjInterpProc(void *clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); @@ -3603,8 +3605,9 @@ MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr); MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, Tcl_Size length); /* Tip 430 */ -MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); -MODULE_SCOPE int TclIsZipfsPath(const char *path); +MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); +MODULE_SCOPE int TclIsZipfsPath(const char *path); +MODULE_SCOPE void TclZipfsFinalize(void); /* * Many parsing tasks need a common definition of whitespace. diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 3dfb252..40b02d6 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -144,14 +144,8 @@ EXTERN int TclInExit(void); /* 51 */ EXTERN int TclInterpInit(Tcl_Interp *interp); /* Slot 52 is reserved */ -/* 53 */ -EXTERN int TclInvokeObjectCommand(void *clientData, - Tcl_Interp *interp, int argc, - const char **argv); -/* 54 */ -EXTERN int TclInvokeStringCommand(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +/* Slot 53 is reserved */ +/* Slot 54 is reserved */ /* 55 */ EXTERN Proc * TclIsProc(Command *cmdPtr); /* Slot 56 is reserved */ @@ -168,12 +162,9 @@ EXTERN int TclNeedSpace(const char *start, const char *end); EXTERN Tcl_Obj * TclNewProcBodyObj(Proc *procPtr); /* 62 */ EXTERN int TclObjCommandComplete(Tcl_Obj *cmdPtr); -/* 63 */ -EXTERN int TclObjInterpProc(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +/* Slot 63 is reserved */ /* 64 */ -EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc, +EXTERN int TclObjInvoke(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* Slot 65 is reserved */ /* Slot 66 is reserved */ @@ -462,11 +453,18 @@ EXTERN int TclPushStackFrame(Tcl_Interp *interp, int isProcCallFrame); /* 218 */ EXTERN void TclPopStackFrame(Tcl_Interp *interp); -/* Slot 219 is reserved */ +/* 219 */ +EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj); /* Slot 220 is reserved */ -/* Slot 221 is reserved */ -/* Slot 222 is reserved */ -/* Slot 223 is reserved */ +/* 221 */ +EXTERN Tcl_Obj * TclListTestObj(size_t length, size_t leadingSpace, + size_t endSpace); +/* 222 */ +EXTERN void TclListObjValidate(Tcl_Interp *interp, + Tcl_Obj *listObj); +/* 223 */ +EXTERN void * TclGetCStackPtr(void); /* 224 */ EXTERN TclPlatformType * TclGetPlatform(void); /* 225 */ @@ -506,7 +504,7 @@ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ EXTERN int TclNRInterpProc(void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); + Tcl_Size objc, Tcl_Obj *const objv[]); /* 239 */ EXTERN int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Size skip, @@ -574,16 +572,11 @@ 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); +/* Slot 258 is reserved */ /* Slot 259 is reserved */ -/* 260 */ -EXTERN Tcl_Obj * TclListTestObj(size_t length, size_t leadingSpace, - size_t endSpace); +/* Slot 260 is reserved */ /* 261 */ -EXTERN void TclListObjValidate(Tcl_Interp *interp, - Tcl_Obj *listObj); +EXTERN void TclUnusedStubEntry(void); typedef struct TclIntStubs { int magic; @@ -642,8 +635,8 @@ typedef struct TclIntStubs { void (*reserved50)(void); int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */ void (*reserved52)(void); - int (*tclInvokeObjectCommand) (void *clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */ - int (*tclInvokeStringCommand) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */ + void (*reserved53)(void); + void (*reserved54)(void); Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */ void (*reserved56)(void); void (*reserved57)(void); @@ -652,8 +645,8 @@ typedef struct TclIntStubs { int (*tclNeedSpace) (const char *start, const char *end); /* 60 */ Tcl_Obj * (*tclNewProcBodyObj) (Proc *procPtr); /* 61 */ int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */ - int (*tclObjInterpProc) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 63 */ - int (*tclObjInvoke) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 64 */ + void (*reserved63)(void); + int (*tclObjInvoke) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 64 */ void (*reserved65)(void); void (*reserved66)(void); void (*reserved67)(void); @@ -808,11 +801,11 @@ typedef struct TclIntStubs { void (*tclStackFree) (Tcl_Interp *interp, void *freePtr); /* 216 */ int (*tclPushStackFrame) (Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */ void (*tclPopStackFrame) (Tcl_Interp *interp); /* 218 */ - void (*reserved219)(void); + Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 219 */ void (*reserved220)(void); - void (*reserved221)(void); - void (*reserved222)(void); - void (*reserved223)(void); + Tcl_Obj * (*tclListTestObj) (size_t length, size_t leadingSpace, size_t endSpace); /* 221 */ + void (*tclListObjValidate) (Tcl_Interp *interp, Tcl_Obj *listObj); /* 222 */ + void * (*tclGetCStackPtr) (void); /* 223 */ TclPlatformType * (*tclGetPlatform) (void); /* 224 */ Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, Tcl_Size keyc, Tcl_Obj *const keyv[], int flags); /* 225 */ int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */ @@ -827,7 +820,7 @@ typedef struct TclIntStubs { void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ void (*reserved236)(void); int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ - int (*tclNRInterpProc) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ + int (*tclNRInterpProc) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Size skip, ProcErrorProc *errorProc); /* 239 */ int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */ @@ -847,10 +840,10 @@ typedef struct TclIntStubs { 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, int flags); /* 256 */ void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ - Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ + void (*reserved258)(void); void (*reserved259)(void); - Tcl_Obj * (*tclListTestObj) (size_t length, size_t leadingSpace, size_t endSpace); /* 260 */ - void (*tclListObjValidate) (Tcl_Interp *interp, Tcl_Obj *listObj); /* 261 */ + void (*reserved260)(void); + void (*tclUnusedStubEntry) (void); /* 261 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; @@ -944,10 +937,8 @@ extern const TclIntStubs *tclIntStubsPtr; #define TclInterpInit \ (tclIntStubsPtr->tclInterpInit) /* 51 */ /* Slot 52 is reserved */ -#define TclInvokeObjectCommand \ - (tclIntStubsPtr->tclInvokeObjectCommand) /* 53 */ -#define TclInvokeStringCommand \ - (tclIntStubsPtr->tclInvokeStringCommand) /* 54 */ +/* Slot 53 is reserved */ +/* Slot 54 is reserved */ #define TclIsProc \ (tclIntStubsPtr->tclIsProc) /* 55 */ /* Slot 56 is reserved */ @@ -961,8 +952,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclNewProcBodyObj) /* 61 */ #define TclObjCommandComplete \ (tclIntStubsPtr->tclObjCommandComplete) /* 62 */ -#define TclObjInterpProc \ - (tclIntStubsPtr->tclObjInterpProc) /* 63 */ +/* Slot 63 is reserved */ #define TclObjInvoke \ (tclIntStubsPtr->tclObjInvoke) /* 64 */ /* Slot 65 is reserved */ @@ -1192,11 +1182,15 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclPushStackFrame) /* 217 */ #define TclPopStackFrame \ (tclIntStubsPtr->tclPopStackFrame) /* 218 */ -/* Slot 219 is reserved */ +#define TclpCreateTemporaryDirectory \ + (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 219 */ /* Slot 220 is reserved */ -/* Slot 221 is reserved */ -/* Slot 222 is reserved */ -/* Slot 223 is reserved */ +#define TclListTestObj \ + (tclIntStubsPtr->tclListTestObj) /* 221 */ +#define TclListObjValidate \ + (tclIntStubsPtr->tclListObjValidate) /* 222 */ +#define TclGetCStackPtr \ + (tclIntStubsPtr->tclGetCStackPtr) /* 223 */ #define TclGetPlatform \ (tclIntStubsPtr->tclGetPlatform) /* 224 */ #define TclTraceDictPath \ @@ -1263,13 +1257,11 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticLibrary \ (tclIntStubsPtr->tclStaticLibrary) /* 257 */ -#define TclpCreateTemporaryDirectory \ - (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ +/* Slot 258 is reserved */ /* Slot 259 is reserved */ -#define TclListTestObj \ - (tclIntStubsPtr->tclListTestObj) /* 260 */ -#define TclListObjValidate \ - (tclIntStubsPtr->tclListObjValidate) /* 261 */ +/* Slot 260 is reserved */ +#define TclUnusedStubEntry \ + (tclIntStubsPtr->tclUnusedStubEntry) /* 261 */ #endif /* defined(USE_TCL_STUBS) */ @@ -1288,9 +1280,11 @@ extern const TclIntStubs *tclIntStubsPtr; #undef TclpGetSeconds #define TclpGetSeconds() \ ((unsigned long)tclIntStubsPtr->tclpGetSeconds()) +#undef TclGetObjInterpProc2 +#define TclGetObjInterpProc2 TclGetObjInterpProc #endif -#undef TclObjInterpProc +#undef TclUnusedStubEntry #define TclObjInterpProc TclGetObjInterpProc() #define TclObjInterpProc2 TclGetObjInterpProc2() diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 3886fc7..fa6cf80 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -875,7 +875,7 @@ NRInterpCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot delete the current interpreter", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "DELETESELF", NULL); + "DELETESELF", (void *)NULL); return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; @@ -1120,7 +1120,7 @@ NRInterpCmd( "alias \"%s\" in path \"%s\" not found", aliasName, TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, - NULL); + (void *)NULL); return TCL_ERROR; } aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); @@ -1129,7 +1129,7 @@ NRInterpCmd( "target interpreter for alias \"%s\" in path \"%s\" is " "not my descendant", aliasName, TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "TARGETSHROUDED", NULL); + "TARGETSHROUDED", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -1309,7 +1309,7 @@ Tcl_GetAlias( if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", aliasName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, (void *)NULL); return TCL_ERROR; } aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); @@ -1371,7 +1371,7 @@ Tcl_GetAliasObj( if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", aliasName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, (void *)NULL); return TCL_ERROR; } aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); @@ -1478,7 +1478,7 @@ TclPreventAliasLoop( "cannot define or rename alias \"%s\": would create a loop", Tcl_GetCommandName(cmdInterp, cmd))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "ALIASLOOP", NULL); + "ALIASLOOP", (void *)NULL); return TCL_ERROR; } @@ -1699,7 +1699,7 @@ AliasDelete( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", TclGetString(namePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", - TclGetString(namePtr), NULL); + TclGetString(namePtr), (void *)NULL); return TCL_ERROR; } aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); @@ -2351,7 +2351,7 @@ GetInterp( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not find interpreter \"%s\"", TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP", - TclGetString(pathPtr), NULL); + TclGetString(pathPtr), (void *)NULL); } return searchInterp; } @@ -2389,7 +2389,7 @@ ChildBgerror( Tcl_SetObjResult(interp, Tcl_NewStringObj( "cmdPrefix must be list of length >= 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BGERRORFORMAT", NULL); + "BGERRORFORMAT", (void *)NULL); return TCL_ERROR; } TclSetBgErrorHandler(childInterp, objv[0]); @@ -2957,7 +2957,7 @@ ChildExpose( "permission denied: safe interpreter cannot expose commands", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", - NULL); + (void *)NULL); return TCL_ERROR; } @@ -3002,7 +3002,7 @@ ChildRecursionLimit( Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: " "safe interpreters cannot change recursion limit", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", - NULL); + (void *)NULL); return TCL_ERROR; } if (TclGetWideIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { @@ -3011,8 +3011,8 @@ ChildRecursionLimit( if (limit <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "recursion limit must be > 0", -1)); - Tcl_SetErrorCode( - interp, "TCL", "OPERATION", "INTERP", "BADLIMIT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT", + (void *)NULL); return TCL_ERROR; } Tcl_SetRecursionLimit(childInterp, limit); @@ -3020,7 +3020,7 @@ ChildRecursionLimit( if (interp == childInterp && iPtr->numLevels > limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); - Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL); + Tcl_SetErrorCode(interp, "TCL", "RECURSION", (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, objv[0]); @@ -3063,7 +3063,7 @@ ChildHide( "permission denied: safe interpreter cannot hide commands", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", - NULL); + (void *)NULL); return TCL_ERROR; } @@ -3148,7 +3148,7 @@ ChildInvokeHidden( "not allowed to invoke hidden commands from safe interpreter", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", - NULL); + (void *)NULL); return TCL_ERROR; } @@ -3225,7 +3225,7 @@ ChildMarkTrusted( "permission denied: safe interpreter cannot mark trusted", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", - NULL); + (void *)NULL); return TCL_ERROR; } ((Interp *) childInterp)->flags &= ~SAFE_INTERP; @@ -3477,7 +3477,7 @@ Tcl_LimitCheck( } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command count limit exceeded", -1)); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", (void *)NULL); Tcl_Release(interp); return TCL_ERROR; } @@ -3503,7 +3503,7 @@ Tcl_LimitCheck( } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "time limit exceeded", -1)); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", (void *)NULL); Tcl_Release(interp); return TCL_ERROR; } @@ -3615,8 +3615,8 @@ Tcl_LimitAddHandler( * Convert everything into a real deletion callback. */ - if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) { - deleteProc = (Tcl_LimitHandlerDeleteProc *) TclpFree; + if (deleteProc == TCL_DYNAMIC) { + deleteProc = TclpFree; } /* @@ -4506,7 +4506,7 @@ ChildCommandLimitCmd( if (interp == childInterp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "limits on current interpreter inaccessible", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", (void *)NULL); return TCL_ERROR; } @@ -4606,7 +4606,7 @@ ChildCommandLimitCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "granularity must be at least 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BADVALUE", NULL); + "BADVALUE", (void *)NULL); return TCL_ERROR; } break; @@ -4623,7 +4623,7 @@ ChildCommandLimitCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "command limit value must be at least 0", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BADVALUE", NULL); + "BADVALUE", (void *)NULL); return TCL_ERROR; } break; @@ -4694,7 +4694,7 @@ ChildTimeLimitCmd( if (interp == childInterp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "limits on current interpreter inaccessible", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", (void *)NULL); return TCL_ERROR; } @@ -4815,7 +4815,7 @@ ChildTimeLimitCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "granularity must be at least 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BADVALUE", NULL); + "BADVALUE", (void *)NULL); return TCL_ERROR; } break; @@ -4832,7 +4832,7 @@ ChildTimeLimitCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "milliseconds must be non-negative", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BADVALUE", NULL); + "BADVALUE", (void *)NULL); return TCL_ERROR; } limitMoment.usec = tmp*1000; @@ -4850,7 +4850,7 @@ ChildTimeLimitCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "seconds must be non-negative", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BADVALUE", NULL); + "BADVALUE", (void *)NULL); return TCL_ERROR; } limitMoment.sec = (long long)tmp; @@ -4869,7 +4869,7 @@ ChildTimeLimitCmd( "may only set -milliseconds if -seconds is not " "also being reset", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BADUSAGE", NULL); + "BADUSAGE", (void *)NULL); return TCL_ERROR; } if (milliLen == 0 && (secObj == NULL || secLen > 0)) { @@ -4877,7 +4877,7 @@ ChildTimeLimitCmd( "may only reset -milliseconds if -seconds is " "also being reset", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BADUSAGE", NULL); + "BADUSAGE", (void *)NULL); return TCL_ERROR; } } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 546f444..4b3d178 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -472,7 +472,7 @@ MemoryAllocationError( "list construction failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", size)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return TCL_ERROR; } @@ -499,7 +499,7 @@ ListLimitExceededError(Tcl_Interp *interp) Tcl_SetObjResult( interp, Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return TCL_ERROR; } @@ -2981,7 +2981,7 @@ TclLsetFlat( "VALUE", "INDEX" "OUTOFRANGE", - NULL); + (void *)NULL); } result = TCL_ERROR; break; @@ -3171,7 +3171,7 @@ TclListObjSetElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%" TCL_SIZE_MODIFIER "u\" out of range", index)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", - "OUTOFRANGE", NULL); + "OUTOFRANGE", (void *)NULL); } return TCL_ERROR; } @@ -3480,7 +3480,7 @@ UpdateStringOfList( # define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; Tcl_Size numElems, i, length; - TCL_HASH_TYPE bytesNeeded = 0; + size_t bytesNeeded = 0; const char *elem, *start; char *dst; Tcl_Obj **elemPtrs; diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 9051b45..9d89586 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -179,7 +179,7 @@ TclCreateLiteral( const char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ Tcl_Size length, /* Number of bytes in the string. */ - TCL_HASH_TYPE hash, /* The string's hash. If the value is + size_t hash, /* The string's hash. If the value is * TCL_INDEX_NONE, it will be computed here. */ int *newPtr, Namespace *nsPtr, @@ -195,7 +195,7 @@ TclCreateLiteral( * Is it in the interpreter's global literal table? */ - if (hash == (TCL_HASH_TYPE) TCL_INDEX_NONE) { + if (hash == (size_t) TCL_INDEX_NONE) { hash = HashString(bytes, length); } globalHash = (hash & globalTablePtr->mask); diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 0e59c7b..a2d1919 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -194,7 +194,7 @@ Tcl_LoadObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "must specify either file name or prefix", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", - NULL); + (void *)NULL); code = TCL_ERROR; goto done; } @@ -260,7 +260,7 @@ Tcl_LoadObjCmd( "file \"%s\" is already loaded for prefix \"%s\"", fullFileName, libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "SPLITPERSONALITY", NULL); + "SPLITPERSONALITY", (void *)NULL); code = TCL_ERROR; Tcl_MutexUnlock(&libraryMutex); goto done; @@ -297,7 +297,7 @@ Tcl_LoadObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no library with prefix \"%s\" is loaded statically", prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", - NULL); + (void *)NULL); code = TCL_ERROR; goto done; } @@ -359,7 +359,7 @@ Tcl_LoadObjCmd( "couldn't figure out prefix for %s", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "WHATLIBRARY", NULL); + "WHATLIBRARY", (void *)NULL); code = TCL_ERROR; goto done; } @@ -456,7 +456,7 @@ Tcl_LoadObjCmd( "can't use library in a safe interpreter: no" " %s_SafeInit procedure", libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", - NULL); + (void *)NULL); code = TCL_ERROR; goto done; } @@ -467,7 +467,7 @@ Tcl_LoadObjCmd( "can't attach library to interpreter: no %s_Init procedure", libraryPtr->prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", - NULL); + (void *)NULL); code = TCL_ERROR; goto done; } @@ -627,7 +627,7 @@ Tcl_UnloadObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "must specify either file name or prefix", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", - NULL); + (void *)NULL); code = TCL_ERROR; goto done; } @@ -695,7 +695,7 @@ Tcl_UnloadObjCmd( "library with prefix \"%s\" is loaded statically and cannot be unloaded", prefix)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", - NULL); + (void *)NULL); code = TCL_ERROR; goto done; } @@ -707,7 +707,7 @@ Tcl_UnloadObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" has never been loaded", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", - NULL); + (void *)NULL); code = TCL_ERROR; goto done; } @@ -737,7 +737,7 @@ Tcl_UnloadObjCmd( "file \"%s\" has never been loaded in this interpreter", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", - NULL); + (void *)NULL); code = TCL_ERROR; goto done; } @@ -800,7 +800,7 @@ UnloadLibrary( "file \"%s\" cannot be unloaded under a safe interpreter", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - NULL); + (void *)NULL); code = TCL_ERROR; goto done; } @@ -813,7 +813,7 @@ UnloadLibrary( "file \"%s\" cannot be unloaded under a trusted interpreter", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - NULL); + (void *)NULL); code = TCL_ERROR; goto done; } diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 4d1be5c..0e82527 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -717,7 +717,7 @@ Tcl_CreateNamespace( Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace" " \"\": only global namespace can have empty name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", - "CREATEGLOBAL", NULL); + "CREATEGLOBAL", (void *)NULL); Tcl_DStringFree(&tmpBuffer); return NULL; } @@ -756,7 +756,7 @@ Tcl_CreateNamespace( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create namespace \"%s\": already exists", name)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", - "CREATEEXISTING", NULL); + "CREATEEXISTING", (void *)NULL); Tcl_DStringFree(&tmpBuffer); return NULL; } @@ -1436,7 +1436,7 @@ Tcl_Export( if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern" " \"%s\": pattern can't specify a namespace", pattern)); - Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); + Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", (void *)NULL); return TCL_ERROR; } @@ -1642,7 +1642,7 @@ Tcl_Import( if (strlen(pattern) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", (void *)NULL); return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, @@ -1651,7 +1651,7 @@ Tcl_Import( if (importNsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown namespace in import pattern \"%s\"", pattern)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, (void *)NULL); return TCL_ERROR; } if (importNsPtr == nsPtr) { @@ -1659,12 +1659,12 @@ Tcl_Import( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no namespace specified in import pattern \"%s\"", pattern)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", (void *)NULL); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "import pattern \"%s\" tries to import from namespace" " \"%s\" into itself", pattern, importNsPtr->name)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", (void *)NULL); } return TCL_ERROR; } @@ -1787,7 +1787,7 @@ DoImport( " containing command \"%s\"", pattern, Tcl_DStringValue(&ds))); Tcl_DStringFree(&ds); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", (void *)NULL); return TCL_ERROR; } } @@ -1829,7 +1829,7 @@ DoImport( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't import command \"%s\": already exists", cmdName)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -1899,7 +1899,7 @@ Tcl_ForgetImport( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown namespace in namespace forget pattern \"%s\"", pattern)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, (void *)NULL); return TCL_ERROR; } @@ -2534,7 +2534,7 @@ Tcl_FindNamespace( if (flags & TCL_LEAVE_ERR_MSG) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown namespace \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, (void *)NULL); } return NULL; } @@ -2724,7 +2724,7 @@ Tcl_FindCommand( if (flags & TCL_LEAVE_ERR_MSG) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown command \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, (void *)NULL); } return NULL; } @@ -2918,7 +2918,7 @@ TclGetNamespaceFromObj( "namespace \"%s\" not found in \"%s\"", name, Tcl_GetStringResult(interp))); } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -3310,7 +3310,7 @@ NamespaceDeleteCmd( "unknown namespace \"%s\" in namespace delete command", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", - TclGetString(objv[i]), NULL); + TclGetString(objv[i]), (void *)NULL); return TCL_ERROR; } } @@ -3944,7 +3944,7 @@ NamespaceOriginCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid command name \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(objv[1]), NULL); + TclGetString(objv[1]), (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, resultPtr); diff --git a/generic/tclOO.c b/generic/tclOO.c index d9cabe6..1d72fb0 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -457,6 +457,7 @@ InitClassSystemRoots( fPtr->objectCls = &fakeCls; /* referenced in TclOOAllocClass to increment the refCount. */ fakeCls.thisPtr = &fakeObject; + fakeObject.refCount = 0; /* Do not increment an uninitialized value. */ fPtr->objectCls = TclOOAllocClass(interp, AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); @@ -1864,7 +1865,7 @@ TclNewObjectInstanceCommon( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create object \"%s\": command already exists with" " that name", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", (void *)NULL); return NULL; } } @@ -1918,7 +1919,7 @@ FinalizeAlloc( if (result != TCL_ERROR && Destructing(oPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "object deleted in constructor", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", (void *)NULL); result = TCL_ERROR; } if (result != TCL_OK) { @@ -1989,7 +1990,7 @@ Tcl_CopyObjectInstance( if (IsRootClass(oPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not clone the class of classes", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", (void *)NULL); return NULL; } @@ -2754,7 +2755,7 @@ TclOOObjectCmdCore( "impossible to invoke method \"%s\": no defined method or" " unknown method", TclGetString(methodNamePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED", - TclGetString(methodNamePtr), NULL); + TclGetString(methodNamePtr), (void *)NULL); return TCL_ERROR; } } else { @@ -2771,7 +2772,7 @@ TclOOObjectCmdCore( "impossible to invoke method \"%s\": no defined method or" " unknown method", TclGetString(methodNamePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(methodNamePtr), NULL); + TclGetString(methodNamePtr), (void *)NULL); return TCL_ERROR; } } @@ -2798,7 +2799,7 @@ TclOOObjectCmdCore( Tcl_SetObjResult(interp, Tcl_NewStringObj( "no valid method implementation", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(methodNamePtr), NULL); + TclGetString(methodNamePtr), (void *)NULL); TclOODeleteContext(contextPtr); return TCL_ERROR; } @@ -2879,7 +2880,7 @@ Tcl_ObjectContextInvokeNext( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no next %s implementation", methodType)); - Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", (void *)NULL); return TCL_ERROR; } @@ -2948,7 +2949,7 @@ TclNRObjectContextInvokeNext( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no next %s implementation", methodType)); - Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", (void *)NULL); return TCL_ERROR; } @@ -3027,7 +3028,7 @@ Tcl_GetObjectFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s does not refer to an object", TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr), - NULL); + (void *)NULL); return NULL; } diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index e644a2f..5a38dee 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -197,7 +197,7 @@ TclOO_Class_Create( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "object \"%s\" is not a class", TclGetString(cmdnameObj))); - Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (void *)NULL); return TCL_ERROR; } @@ -215,7 +215,7 @@ TclOO_Class_Create( if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "object name must not be empty", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (void *)NULL); return TCL_ERROR; } @@ -262,7 +262,7 @@ TclOO_Class_CreateNs( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "object \"%s\" is not a class", TclGetString(cmdnameObj))); - Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (void *)NULL); return TCL_ERROR; } @@ -280,7 +280,7 @@ TclOO_Class_CreateNs( if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "object name must not be empty", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (void *)NULL); return TCL_ERROR; } nsName = Tcl_GetStringFromObj( @@ -288,7 +288,7 @@ TclOO_Class_CreateNs( if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "namespace name must not be empty", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (void *)NULL); return TCL_ERROR; } @@ -333,7 +333,7 @@ TclOO_Class_New( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "object \"%s\" is not a class", TclGetString(cmdnameObj))); - Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (void *)NULL); return TCL_ERROR; } @@ -592,7 +592,7 @@ TclOO_Object_Unknown( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "object \"%s\" has no %s", TclGetString(tmpBuf), piece)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[skip]), NULL); + TclGetString(objv[skip]), (void *)NULL); return TCL_ERROR; } @@ -611,7 +611,7 @@ TclOO_Object_Unknown( Tcl_Free((void *)methodNames); Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[skip]), NULL); + TclGetString(objv[skip]), (void *)NULL); return TCL_ERROR; } @@ -668,7 +668,7 @@ TclOO_Object_LinkVar( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "variable name \"%s\" illegal: must not contain namespace" " separator", varName)); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", (void *)NULL); return TCL_ERROR; } @@ -697,7 +697,7 @@ TclOO_Object_LinkVar( TclVarErrMsg(interp, varName, NULL, "define", "name refers to an element in an array"); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", (void *)NULL); return TCL_ERROR; } @@ -825,7 +825,7 @@ TclOO_Object_VarName( TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar); Tcl_DecrRefCount(varNamePtr); if (varPtr == NULL) { - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (void *)NULL); return TCL_ERROR; } @@ -886,7 +886,7 @@ TclOONextObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s may only be called from inside a method", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL); return TCL_ERROR; } context = (Tcl_ObjectContext)framePtr->clientData; @@ -926,7 +926,7 @@ TclOONextToObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s may only be called from inside a method", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL); return TCL_ERROR; } contextPtr = (CallContext *)framePtr->clientData; @@ -947,7 +947,7 @@ TclOONextToObjCmd( if (classPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", (void *)NULL); return TCL_ERROR; } @@ -996,14 +996,14 @@ TclOONextToObjCmd( "%s implementation by \"%s\" not reachable from here", methodType, TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", - NULL); + (void *)NULL); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s has no non-filter implementation by \"%s\"", methodType, TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", (void *)NULL); return TCL_ERROR; } @@ -1065,7 +1065,7 @@ TclOOSelfObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s may only be called from inside a method", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL); return TCL_ERROR; } @@ -1100,7 +1100,7 @@ TclOOSelfObjCmd( if (clsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "method not defined by a class", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (void *)NULL); return TCL_ERROR; } @@ -1121,7 +1121,7 @@ TclOOSelfObjCmd( if (!CurrentlyInvoked(contextPtr).isFilter) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "not inside a filtering context", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (void *)NULL); return TCL_ERROR; } else { struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr); @@ -1147,7 +1147,7 @@ TclOOSelfObjCmd( !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){ Tcl_SetObjResult(interp, Tcl_NewStringObj( "caller is not an object", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL); return TCL_ERROR; } else { CallContext *callerPtr = (CallContext *)framePtr->callerVarPtr->clientData; @@ -1215,7 +1215,7 @@ TclOOSelfObjCmd( if (!CurrentlyInvoked(contextPtr).isFilter) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "not inside a filtering context", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (void *)NULL); return TCL_ERROR; } else { Method *mPtr; diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 7a88ab7..c22399a 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -674,7 +674,7 @@ RenameDeleteMethod( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "method %s does not exist", TclGetString(fromPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(fromPtr), NULL); + TclGetString(fromPtr), (void *)NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, fromPtr); @@ -688,14 +688,14 @@ RenameDeleteMethod( renameToSelf: Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot rename method to itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", (void *)NULL); return TCL_ERROR; } else if (!isNew) { renameToExisting: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "method called %s already exists", TclGetString(toPtr))); - Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", (void *)NULL); return TCL_ERROR; } } @@ -764,7 +764,7 @@ TclOOUnknownDefinition( if (objc < 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad call of unknown handler", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", (void *)NULL); return TCL_ERROR; } if (TclOOGetDefineCmdContext(interp) == NULL) { @@ -811,7 +811,7 @@ TclOOUnknownDefinition( noMatch: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid command name \"%s\"", soughtStr)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, (void *)NULL); return TCL_ERROR; } @@ -901,7 +901,7 @@ InitDefineContext( if (namespacePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "no definition namespace available", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -942,7 +942,7 @@ TclOOGetDefineCmdContext( Tcl_SetObjResult(interp, Tcl_NewStringObj( "this command may only be called from within the context of" " an ::oo::define or ::oo::objdefine command", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return NULL; } object = (Tcl_Object)iPtr->varFramePtr->clientData; @@ -950,7 +950,7 @@ TclOOGetDefineCmdContext( Tcl_SetObjResult(interp, Tcl_NewStringObj( "this command cannot be called when the object has been" " deleted", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return NULL; } return object; @@ -994,7 +994,7 @@ GetClassInOuterContext( if (oPtr->classPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(className), NULL); + TclGetString(className), (void *)NULL); return NULL; } return oPtr->classPtr; @@ -1170,7 +1170,7 @@ TclOODefineObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s does not refer to a class", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[1]), NULL); + TclGetString(objv[1]), (void *)NULL); return TCL_ERROR; } @@ -1492,13 +1492,13 @@ TclOODefineClassObjCmd( if (oPtr->flags & ROOT_OBJECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not modify the class of the root object class", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } if (oPtr->flags & ROOT_CLASS) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not modify the class of the class of classes", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -1518,7 +1518,7 @@ TclOODefineClassObjCmd( if (oPtr == clsPtr->thisPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not change classes into an instance of themselves", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -1671,14 +1671,14 @@ TclOODefineDefnNsObjCmd( if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not modify the definition namespace of the root classes", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -1755,7 +1755,7 @@ TclOODefineDeleteMethodObjCmd( if (!isInstanceDeleteMethod && !oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -1881,7 +1881,7 @@ TclOODefineExportObjCmd( if (!isInstanceExport && !clsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -1975,7 +1975,7 @@ TclOODefineForwardObjCmd( if (!isInstanceForward && !oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) @@ -2053,7 +2053,7 @@ TclOODefineMethodObjCmd( if (!isInstanceMethod && !oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } if (objc == 5) { @@ -2132,7 +2132,7 @@ TclOODefineRenameMethodObjCmd( if (!isInstanceRenameMethod && !oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -2194,7 +2194,7 @@ TclOODefineUnexportObjCmd( if (!isInstanceUnexport && !clsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -2390,7 +2390,7 @@ ClassFilterGet( } else if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -2426,7 +2426,7 @@ ClassFilterSet( } else if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } else if (TclListObjGetElementsM(interp, objv[0], &filterc, &filterv) != TCL_OK) { @@ -2471,7 +2471,7 @@ ClassMixinGet( } else if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -2510,7 +2510,7 @@ ClassMixinSet( } else if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } else if (TclListObjGetElementsM(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { @@ -2529,7 +2529,7 @@ ClassMixinSet( if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not mix a class into itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", (void *)NULL); goto freeAndError; } } @@ -2577,7 +2577,7 @@ ClassSuperGet( } else if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -2616,12 +2616,12 @@ ClassSuperSet( } else if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not modify the superclass of the root object", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } else if (TclListObjGetElementsM(interp, objv[0], &superc, &superv) != TCL_OK) { @@ -2662,14 +2662,14 @@ ClassSuperSet( Tcl_SetObjResult(interp, Tcl_NewStringObj( "class should only be a direct superclass once", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",(void *)NULL); goto failedAfterAlloc; } } if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to form circular dependency graph", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", (void *)NULL); failedAfterAlloc: for (; i-- > 0 ;) { TclOODecrRefCount(superclasses[i]->thisPtr); @@ -2744,7 +2744,7 @@ ClassVarsGet( } else if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -2791,7 +2791,7 @@ ClassVarsSet( } else if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } else if (TclListObjGetElementsM(interp, objv[0], &varc, &varv) != TCL_OK) { @@ -2805,14 +2805,14 @@ ClassVarsSet( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid declared variable name \"%s\": must not %s", varName, "contain namespace separators")); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (void *)NULL); return TCL_ERROR; } if (Tcl_StringMatch(varName, "*(*)")) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid declared variable name \"%s\": must not %s", varName, "refer to an array element")); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (void *)NULL); return TCL_ERROR; } } @@ -3061,14 +3061,14 @@ ObjVarsSet( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid declared variable name \"%s\": must not %s", varName, "contain namespace separators")); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (void *)NULL); return TCL_ERROR; } if (Tcl_StringMatch(varName, "*(*)")) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid declared variable name \"%s\": must not %s", varName, "refer to an array element")); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (void *)NULL); return TCL_ERROR; } } @@ -3225,7 +3225,7 @@ ClassRPropsGet( } else if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -3261,7 +3261,7 @@ ClassRPropsSet( } else if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) { @@ -3422,7 +3422,7 @@ ClassWPropsGet( } else if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } @@ -3458,7 +3458,7 @@ ClassWPropsSet( } else if (!oPtr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); return TCL_ERROR; } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, &varv) != TCL_OK) { diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index e71cddc..eba658b 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -158,7 +158,7 @@ GetClassFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objPtr), NULL); + TclGetString(objPtr), (void *)NULL); return NULL; } return oPtr->classPtr; @@ -263,7 +263,7 @@ InfoObjectDefnCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr)); @@ -271,7 +271,7 @@ InfoObjectDefnCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "definition not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } @@ -374,7 +374,7 @@ InfoObjectForwardCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr)); @@ -383,7 +383,7 @@ InfoObjectForwardCmd( "prefix argument list not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } @@ -578,7 +578,7 @@ InfoObjectMethodsCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "missing option for -scope")); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", - NULL); + (void *)NULL); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, @@ -671,7 +671,7 @@ InfoObjectMethodTypeCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } mPtr = (Method *)Tcl_GetHashValue(hPtr); @@ -949,7 +949,7 @@ InfoClassConstrCmd( if (procPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "definition not available for this kind of method", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", (void *)NULL); return TCL_ERROR; } @@ -1009,7 +1009,7 @@ InfoClassDefnCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr)); @@ -1017,7 +1017,7 @@ InfoClassDefnCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "definition not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } @@ -1127,7 +1127,7 @@ InfoClassDestrCmd( if (procPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "definition not available for this kind of method", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", (void *)NULL); return TCL_ERROR; } @@ -1207,7 +1207,7 @@ InfoClassForwardCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr)); @@ -1216,7 +1216,7 @@ InfoClassForwardCmd( "prefix argument list not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } @@ -1337,7 +1337,7 @@ InfoClassMethodsCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "missing option for -scope")); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", - NULL); + (void *)NULL); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, @@ -1424,7 +1424,7 @@ InfoClassMethodTypeCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (void *)NULL); return TCL_ERROR; } mPtr = (Method *)Tcl_GetHashValue(hPtr); diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 7a941b8..4711695 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1482,7 +1482,7 @@ TclOONewForwardInstanceMethod( if (prefixLen < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "method forward prefix must be non-empty", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", (void *)NULL); return NULL; } @@ -1521,7 +1521,7 @@ TclOONewForwardMethod( if (prefixLen < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "method forward prefix must be non-empty", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", (void *)NULL); return NULL; } diff --git a/generic/tclObj.c b/generic/tclObj.c index 6dcd733..aed24cd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -950,7 +950,7 @@ Tcl_ConvertToType( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't convert value to type %s", typePtr->name)); - Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", NULL); + Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", (void *)NULL); } return TCL_ERROR; } @@ -2140,7 +2140,7 @@ TclSetBooleanFromAny( Tcl_AppendLimitedToObj(msg, str, length, 50, ""); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", (void *)NULL); } return TCL_ERROR; } @@ -2429,7 +2429,7 @@ Tcl_GetDoubleFromObj( Tcl_SetObjResult(interp, Tcl_NewStringObj( "floating point value is Not a Number", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", - NULL); + (void *)NULL); } return TCL_ERROR; } @@ -2560,7 +2560,7 @@ Tcl_GetIntFromObj( const char *s = "integer value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL); } return TCL_ERROR; } @@ -2683,7 +2683,7 @@ Tcl_GetLongFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL); } return TCL_ERROR; } @@ -2727,7 +2727,7 @@ Tcl_GetLongFromObj( Tcl_Obj *msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL); } return TCL_ERROR; } @@ -2924,7 +2924,7 @@ Tcl_GetWideIntFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL); } return TCL_ERROR; } @@ -2962,7 +2962,7 @@ Tcl_GetWideIntFromObj( Tcl_Obj *msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL); } return TCL_ERROR; } @@ -3007,7 +3007,7 @@ Tcl_GetWideUIntFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected unsigned integer but got \"%s\"", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL); } return TCL_ERROR; } @@ -3046,7 +3046,7 @@ Tcl_GetWideUIntFromObj( Tcl_Obj *msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL); } return TCL_ERROR; } @@ -3093,7 +3093,7 @@ TclGetWideBitsFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL); } return TCL_ERROR; } @@ -3408,7 +3408,7 @@ GetBignumFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL); } return TCL_ERROR; } @@ -3658,9 +3658,9 @@ Tcl_GetNumber( } if (numBytes > INT_MAX) { if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return TCL_ERROR; } @@ -4154,7 +4154,7 @@ TclFreeObjEntry( *---------------------------------------------------------------------- */ -TCL_HASH_TYPE +size_t TclHashObjKey( TCL_UNUSED(Tcl_HashTable *), void *keyPtr) /* Key from which to compute hash value. */ @@ -4162,7 +4162,7 @@ TclHashObjKey( Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; Tcl_Size length; const char *string = Tcl_GetStringFromObj(objPtr, &length); - TCL_HASH_TYPE result = 0; + size_t result = 0; /* * I tried a zillion different hash functions and asked many other people diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 17db0d0..fbd7879 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2492,7 +2492,7 @@ MakeTildeRelativePath( "couldn't find HOME environment variable to" " expand path", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", - "HOMELESS", NULL); + "HOMELESS", (void *)NULL); } return TCL_ERROR; } @@ -2504,7 +2504,7 @@ MakeTildeRelativePath( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "user \"%s\" doesn't exist", user)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", - NULL); + (void *)NULL); } return TCL_ERROR; } diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 2eff765..7e51d57 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -111,7 +111,7 @@ FileForRedirect( Tcl_GetChannelName(chan), ((writing) ? "writing" : "reading"))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "BADCHAN", NULL); + "BADCHAN", (void *)NULL); } return NULL; } @@ -155,7 +155,7 @@ FileForRedirect( badLastArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't specify \"%s\" as last word in command", arg)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", (void *)NULL); return NULL; } @@ -514,7 +514,7 @@ TclCreatePipeline( Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal use of | or |& in command", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "PIPESYNTAX", NULL); + "PIPESYNTAX", (void *)NULL); goto error; } } @@ -543,7 +543,7 @@ TclCreatePipeline( "can't specify \"%s\" as last word in command", argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "PIPESYNTAX", NULL); + "PIPESYNTAX", (void *)NULL); goto error; } skip = 2; @@ -660,7 +660,7 @@ TclCreatePipeline( "must specify \"%s\" as last word in command", argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "PIPESYNTAX", NULL); + "PIPESYNTAX", (void *)NULL); goto error; } errorFile = outputFile; @@ -702,7 +702,7 @@ TclCreatePipeline( Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal use of | or |& in command", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", - NULL); + (void *)NULL); goto error; } @@ -1056,7 +1056,7 @@ Tcl_OpenCommandChannel( "can't read output from command:" " standard output was redirected", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "BADREDIRECT", NULL); + "BADREDIRECT", (void *)NULL); goto error; } if ((flags & TCL_STDIN) && (inPipe == NULL)) { @@ -1064,7 +1064,7 @@ Tcl_OpenCommandChannel( "can't write input to command:" " standard input was redirected", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "BADREDIRECT", NULL); + "BADREDIRECT", (void *)NULL); goto error; } } @@ -1075,7 +1075,7 @@ Tcl_OpenCommandChannel( if (channel == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "pipe for command could not be created", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", (void *)NULL); goto error; } return channel; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 3ff7755..3b5580f 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -192,7 +192,7 @@ Tcl_PkgProvideEx( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "conflicting versions provided for package \"%s\": %s, then %s", name, Tcl_GetString(pkgPtr->version), version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", (void *)NULL); return TCL_ERROR; } @@ -389,7 +389,7 @@ Tcl_PkgRequireEx( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Cannot load package \"%s\" in standalone executable:" " This package is not compiled with stub support", name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", (void *)NULL); return NULL; } @@ -409,7 +409,7 @@ Tcl_PkgRequireEx( } ov = Tcl_NewStringObj(version, -1); if (exact) { - Tcl_AppendStringsToObj(ov, "-", version, NULL); + Tcl_AppendStringsToObj(ov, "-", version, (void *)NULL); } Tcl_IncrRefCount(ov); if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { @@ -559,7 +559,7 @@ PkgRequireCoreStep2( if ((result != TCL_OK) && (result != TCL_ERROR)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad return code: %d", result)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", (void *)NULL); result = TCL_ERROR; } if (result == TCL_ERROR) { @@ -596,7 +596,7 @@ PkgRequireCoreFinal( if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", (void *)NULL); AddRequirementsToResult(interp, reqc, reqv); return TCL_ERROR; } @@ -617,7 +617,7 @@ PkgRequireCoreFinal( "version conflict for package \"%s\": have %s, need", name, Tcl_GetString(reqPtr->pkgPtr->version))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", - NULL); + (void *)NULL); AddRequirementsToResult(interp, reqc, reqv); return TCL_ERROR; } @@ -670,7 +670,7 @@ SelectPackage( " attempt to provide %s %s requires %s", name, (char *) pkgPtr->clientData, name)); AddRequirementsToResult(interp, reqc, reqv); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", (void *)NULL); return TCL_ERROR; } @@ -876,7 +876,7 @@ SelectPackageFinal( " no version of package %s provided", name, versionToProvide, name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", - NULL); + (void *)NULL); } else { char *pvi, *vi; @@ -900,7 +900,7 @@ SelectPackageFinal( name, versionToProvide, name, Tcl_GetString(reqPtr->pkgPtr->version))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", NULL); + "WRONGPROVIDE", (void *)NULL); } } } @@ -912,7 +912,7 @@ SelectPackageFinal( "attempt to provide package %s %s failed:" " bad return code: %s", name, versionToProvide, TclGetString(codePtr))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", (void *)NULL); TclDecrRefCount(codePtr); result = TCL_ERROR; } @@ -1018,7 +1018,7 @@ Tcl_PkgPresentEx( if (foundVersion == NULL) { Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, - NULL); + (void *)NULL); } return foundVersion; } @@ -1031,7 +1031,7 @@ Tcl_PkgPresentEx( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "package %s is not present", name)); } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, (void *)NULL); return NULL; } @@ -1354,7 +1354,7 @@ TclNRPackageObjCmd( */ ov = Tcl_NewStringObj(version, -1); - Tcl_AppendStringsToObj(ov, "-", version, NULL); + Tcl_AppendStringsToObj(ov, "-", version, (void *)NULL); version = NULL; argv3 = TclGetString(objv[3]); Tcl_IncrRefCount(objv[3]); @@ -1756,7 +1756,7 @@ CheckVersionAndConvert( Tcl_Free(ibuf); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected version number but got \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", (void *)NULL); return TCL_ERROR; } @@ -2019,7 +2019,7 @@ CheckRequirement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected versionMin-versionMax but got \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", (void *)NULL); return TCL_ERROR; } diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index ff4b45b..36a9537 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -292,7 +292,7 @@ Tcl_EventuallyFree( if (freeProc == TCL_DYNAMIC) { Tcl_Free(clientData); } else { - freeProc((char *)clientData); + freeProc(clientData); } } diff --git a/generic/tclProc.c b/generic/tclProc.c index 85e5c6f..c789768 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -51,6 +51,7 @@ static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static Tcl_NRPostProc ApplyNR2; static Tcl_NRPostProc InterpProcNR2; static Tcl_NRPostProc Uplevel_Callback; +static Tcl_ObjCmdProc NRInterpProc; /* * The ProcBodyObjType type @@ -184,14 +185,14 @@ Tcl_ProcObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (void *)NULL); return TCL_ERROR; } if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (void *)NULL); return TCL_ERROR; } @@ -208,7 +209,7 @@ Tcl_ProcObjCmd( } cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr, - TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc); + TclObjInterpProc, NRInterpProc, procPtr, TclProcDeleteProc); /* * Now initialize the new procedure's cmdPtr field. This will be used @@ -499,7 +500,7 @@ TclCreateProc( "precompiled header expects %" TCL_SIZE_MODIFIER "u", procName, numArgs, procPtr->numArgs)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", NULL); + "BYTECODELIES", (void *)NULL); goto procError; } localPtr = procPtr->firstLocalPtr; @@ -529,14 +530,14 @@ TclCreateProc( Tcl_AppendToObj(errorObj, "\"", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); + "FORMALARGUMENTFORMAT", (void *)NULL); goto procError; } if ((fieldCount == 0) || (Tcl_GetCharLength(fieldValues[0]) == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); + "FORMALARGUMENTFORMAT", (void *)NULL); goto procError; } @@ -555,7 +556,7 @@ TclCreateProc( "formal parameter \"%s\" is an array element", TclGetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); + "FORMALARGUMENTFORMAT", (void *)NULL); goto procError; } } else if (*argnamei == ':' && *(argnamei+1) == ':') { @@ -565,7 +566,7 @@ TclCreateProc( Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); + "FORMALARGUMENTFORMAT", (void *)NULL); goto procError; } argnamei++; @@ -593,7 +594,7 @@ TclCreateProc( "procedure \"%s\": formal parameter %" TCL_SIZE_MODIFIER "u is " "inconsistent with precompiled body", procName, i)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", NULL); + "BYTECODELIES", (void *)NULL); goto procError; } @@ -616,7 +617,7 @@ TclCreateProc( "default value inconsistent with precompiled body", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", NULL); + "BYTECODELIES", (void *)NULL); goto procError; } } @@ -844,7 +845,7 @@ badLevel: name = objPtr ? TclGetString(objPtr) : "1" ; } Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, (void *)NULL); return -1; } @@ -1095,7 +1096,7 @@ ProcWrongNumArgs( if (defPtr->value.objPtr != NULL) { TclNewObj(argObj); - Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL); + Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", (void *)NULL); } else if (defPtr->flags & VAR_IS_ARGS) { numArgs--; final = "?arg ...?"; @@ -1610,7 +1611,7 @@ TclObjInterpProc( * Not used much in the core; external interface for iTcl */ - return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv); + return Tcl_NRCallObjProc(interp, NRInterpProc, clientData, objc, objv); } int @@ -1619,7 +1620,7 @@ TclNRInterpProc( * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ - int objc, /* Count of number of arguments to this + Tcl_Size objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { @@ -1633,12 +1634,12 @@ TclNRInterpProc( } static int -NRInterpProc2( +NRInterpProc( void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp, /* Interpreter in which procedure was * invoked. */ - Tcl_Size objc, /* Count of number of arguments to this + int objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { @@ -1665,7 +1666,7 @@ ObjInterpProc2( * Not used much in the core; external interface for iTcl */ - return Tcl_NRCallObjProc2(interp, NRInterpProc2, clientData, objc, objv); + return Tcl_NRCallObjProc2(interp, TclNRInterpProc, clientData, objc, objv); } @@ -1859,7 +1860,7 @@ InterpProcNR2( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invoked \"%s\" outside of a loop", ((result == TCL_BREAK) ? "break" : "continue"))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", (void *)NULL); result = TCL_ERROR; /* FALLTHRU */ @@ -1943,7 +1944,7 @@ TclProcCompileProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "a precompiled script jumped interps", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "CROSSINTERPBYTECODE", NULL); + "CROSSINTERPBYTECODE", (void *)NULL); return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; @@ -1968,7 +1969,7 @@ TclProcCompileProc( TclNewLiteralStringObj(message, "Compiling "); Tcl_IncrRefCount(message); - Tcl_AppendStringsToObj(message, description, " \"", NULL); + Tcl_AppendStringsToObj(message, description, " \"", (void *)NULL); Tcl_AppendLimitedToObj(message, procName, TCL_INDEX_NONE, 50, NULL); fprintf(stdout, "%s\"\n", TclGetString(message)); Tcl_DecrRefCount(message); @@ -2461,7 +2462,7 @@ SetLambdaFromAny( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't interpret \"%s\" as a lambda expression", Tcl_GetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (void *)NULL); return TCL_ERROR; } result = TclListObjGetElementsM(NULL, objPtr, &objc, &objv); @@ -2469,7 +2470,7 @@ SetLambdaFromAny( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't interpret \"%s\" as a lambda expression", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (void *)NULL); return TCL_ERROR; } diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index dfdf12d..83cd415 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -732,7 +732,7 @@ TclRegError( snprintf(cbuf, sizeof(cbuf), "%d", status); (void) TclReError(REG_ITOA, cbuf, sizeof(cbuf)); - Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL); + Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, (void *)NULL); } /* diff --git a/generic/tclResult.c b/generic/tclResult.c index be8c2fd..8ab66ae 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -766,7 +766,7 @@ TclProcessReturn( if (valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } else { - Tcl_SetErrorCode(interp, "NONE", NULL); + Tcl_SetErrorCode(interp, "NONE", (void *)NULL); } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], @@ -846,7 +846,7 @@ TclMergeReturnOptions( "bad %s value: expected dictionary but got \"%s\"", compare, TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", - NULL); + (void *)NULL); goto error; } @@ -895,7 +895,7 @@ TclMergeReturnOptions( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad -level value: expected non-negative integer but got" " \"%s\"", TclGetString(valuePtr))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", (void *)NULL); goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]); @@ -918,7 +918,7 @@ TclMergeReturnOptions( "bad -errorcode value: expected a list but got \"%s\"", TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE", - NULL); + (void *)NULL); goto error; } } @@ -940,7 +940,7 @@ TclMergeReturnOptions( "bad -errorstack value: expected a list but got \"%s\"", TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", - NULL); + (void *)NULL); goto error; } if (length % 2) { @@ -952,7 +952,7 @@ TclMergeReturnOptions( "forbidden odd-sized list for -errorstack: \"%s\"", TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", - "ODDSIZEDLIST_ERRORSTACK", NULL); + "ODDSIZEDLIST_ERRORSTACK", (void *)NULL); goto error; } } @@ -1106,7 +1106,7 @@ Tcl_SetReturnOptions( || (objc % 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected dict but got \"%s\"", TclGetString(options))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", (void *)NULL); code = TCL_ERROR; } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv, &mergedOpts, &code, &level)) { diff --git a/generic/tclScan.c b/generic/tclScan.c index d3a8036..222b06d 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -345,7 +345,7 @@ ValidateFormat( Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot mix \"%\" and \"%n$\" conversion specifiers", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", (void *)NULL); goto error; } @@ -368,7 +368,7 @@ ValidateFormat( ull, (Tcl_Size)TCL_SIZE_MAX-1)); Tcl_SetErrorCode( - interp, "TCL", "FORMAT", "WIDTHLIMIT", NULL); + interp, "TCL", "FORMAT", "WIDTHLIMIT", (void *)NULL); goto error; } flags |= SCAN_WIDTH; @@ -409,7 +409,7 @@ ValidateFormat( Tcl_SetObjResult(interp, Tcl_NewStringObj( "field width may not be specified in %c conversion", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", (void *)NULL); goto error; } /* FALLTHRU */ @@ -423,7 +423,7 @@ ValidateFormat( Tcl_AppendToObj(errorMsg, buf, -1); Tcl_AppendToObj(errorMsg, " conversion", -1); Tcl_SetObjResult(interp, errorMsg); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", (void *)NULL); goto error; } /* @@ -475,7 +475,7 @@ ValidateFormat( badSet: Tcl_SetObjResult(interp, Tcl_NewStringObj( "unmatched [ in format string", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", (void *)NULL); goto error; default: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; @@ -484,7 +484,7 @@ ValidateFormat( Tcl_AppendToObj(errorMsg, buf, -1); Tcl_AppendToObj(errorMsg, "\"", -1); Tcl_SetObjResult(interp, errorMsg); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", (void *)NULL); goto error; } if (!(flags & SCAN_SUPPRESS)) { @@ -531,7 +531,7 @@ ValidateFormat( Tcl_SetObjResult(interp, Tcl_NewStringObj( "variable is assigned by multiple \"%n$\" conversion specifiers", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", (void *)NULL); goto error; } else if (!xpgSize && (nassign[i] == 0)) { /* @@ -542,7 +542,7 @@ ValidateFormat( Tcl_SetObjResult(interp, Tcl_NewStringObj( "variable is not assigned by any conversion specifiers", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", (void *)NULL); goto error; } } @@ -554,12 +554,12 @@ ValidateFormat( if (gotXpg) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"%n$\" argument index out of range", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", (void *)NULL); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj( "different numbers of variable names and field specifiers", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", (void *)NULL); } error: @@ -954,7 +954,7 @@ Tcl_ScanObjCmd( if (mp_init_u64(&big, (Tcl_WideUInt)wideValue) != MP_OKAY) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "insufficient memory to create bignum", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); return TCL_ERROR; } else { Tcl_SetBignumObj(objPtr, &big); @@ -982,7 +982,7 @@ Tcl_ScanObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "unsigned bignum scans are invalid", -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", - "BADUNSIGNED",NULL); + "BADUNSIGNED", (void *)NULL); return TCL_ERROR; } } @@ -1000,7 +1000,7 @@ Tcl_ScanObjCmd( if (mp_init_u64(&big, (unsigned long)value) != MP_OKAY) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "insufficient memory to create bignum", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); return TCL_ERROR; } else { Tcl_SetBignumObj(objPtr, &big); diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 8f69627..a3bc2d4 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1532,7 +1532,7 @@ TclParseNumber( Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, ""); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (void *)NULL); } } @@ -3653,7 +3653,7 @@ ShorteningBignumConversionPowD( if (m2plus > m2minus) { mp_clear(&mplus); } - mp_clear_multi(&b, &mminus, &temp, NULL); + mp_clear_multi(&b, &mminus, &temp, (void *)NULL); *s = '\0'; *decpt = k; if (endPtr) { @@ -4090,7 +4090,7 @@ ShorteningBignumConversion( if (m2plus > m2minus) { mp_clear(&mplus); } - mp_clear_multi(&b, &mminus, &dig, &S, NULL); + mp_clear_multi(&b, &mminus, &dig, &S, (void *)NULL); *s = '\0'; *decpt = k; if (endPtr) { @@ -4265,7 +4265,7 @@ StrictBignumConversion( * string. */ - mp_clear_multi(&b, &S, &dig, NULL); + mp_clear_multi(&b, &S, &dig, (void *)NULL); *s = '\0'; *decpt = k; if (endPtr) { @@ -4795,7 +4795,7 @@ Tcl_InitBignumFromDouble( const char *s = "integer value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL); } return TCL_ERROR; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index dcdc71b..b1f14b5 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2521,7 +2521,7 @@ Tcl_AppendFormatToObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad field specifier \"%c\"", ch)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", (void *)NULL); } goto error; } @@ -2581,7 +2581,7 @@ Tcl_AppendFormatToObj( errorMsg: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, (void *)NULL); } error: Tcl_SetObjLength(appendObj, originalLength); @@ -2981,7 +2981,7 @@ TclStringRepeat( Tcl_ObjPrintf("max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return NULL; } @@ -3020,7 +3020,7 @@ TclStringRepeat( "string size overflow: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", STRING_SIZE(count*length))); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return NULL; } @@ -3048,7 +3048,7 @@ TclStringRepeat( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "string size overflow: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", count*length)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return NULL; } @@ -3359,7 +3359,7 @@ TclStringCat( "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", STRING_SIZE(length))); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return NULL; } @@ -3376,7 +3376,7 @@ TclStringCat( "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", STRING_SIZE(length))); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return NULL; } @@ -3407,7 +3407,7 @@ TclStringCat( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", length)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return NULL; } @@ -3423,7 +3423,7 @@ TclStringCat( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", length)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return NULL; } @@ -3449,7 +3449,7 @@ TclStringCat( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return NULL; } @@ -4090,7 +4090,7 @@ TclStringReplace( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return NULL; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 83133f9..754023c 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -112,7 +112,7 @@ int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, if (objcPtr) { if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { - Tcl_AppendResult(interp, "List too large to be processed", NULL); + Tcl_AppendResult(interp, "List too large to be processed", (void *)NULL); } return TCL_ERROR; } @@ -127,7 +127,7 @@ int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, if (lengthPtr) { if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { - Tcl_AppendResult(interp, "List too large to be processed", NULL); + Tcl_AppendResult(interp, "List too large to be processed", (void *)NULL); } return TCL_ERROR; } @@ -142,7 +142,7 @@ int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, if (sizePtr) { if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { - Tcl_AppendResult(interp, "Dict too large to be processed", NULL); + Tcl_AppendResult(interp, "Dict too large to be processed", (void *)NULL); } return TCL_ERROR; } @@ -157,7 +157,7 @@ int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr, if (argcPtr) { if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { - Tcl_AppendResult(interp, "List too large to be processed", NULL); + Tcl_AppendResult(interp, "List too large to be processed", (void *)NULL); } Tcl_Free((void *)*argvPtr); return TCL_ERROR; @@ -458,8 +458,8 @@ static const TclIntStubs tclIntStubs = { 0, /* 50 */ TclInterpInit, /* 51 */ 0, /* 52 */ - TclInvokeObjectCommand, /* 53 */ - TclInvokeStringCommand, /* 54 */ + 0, /* 53 */ + 0, /* 54 */ TclIsProc, /* 55 */ 0, /* 56 */ 0, /* 57 */ @@ -468,7 +468,7 @@ static const TclIntStubs tclIntStubs = { TclNeedSpace, /* 60 */ TclNewProcBodyObj, /* 61 */ TclObjCommandComplete, /* 62 */ - TclObjInterpProc, /* 63 */ + 0, /* 63 */ TclObjInvoke, /* 64 */ 0, /* 65 */ 0, /* 66 */ @@ -624,11 +624,11 @@ static const TclIntStubs tclIntStubs = { TclStackFree, /* 216 */ TclPushStackFrame, /* 217 */ TclPopStackFrame, /* 218 */ - 0, /* 219 */ + TclpCreateTemporaryDirectory, /* 219 */ 0, /* 220 */ - 0, /* 221 */ - 0, /* 222 */ - 0, /* 223 */ + TclListTestObj, /* 221 */ + TclListObjValidate, /* 222 */ + TclGetCStackPtr, /* 223 */ TclGetPlatform, /* 224 */ TclTraceDictPath, /* 225 */ TclObjBeingDeleted, /* 226 */ @@ -663,10 +663,10 @@ static const TclIntStubs tclIntStubs = { TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ TclStaticLibrary, /* 257 */ - TclpCreateTemporaryDirectory, /* 258 */ + 0, /* 258 */ 0, /* 259 */ - TclListTestObj, /* 260 */ - TclListObjValidate, /* 261 */ + 0, /* 260 */ + TclUnusedStubEntry, /* 261 */ }; static const TclIntPlatStubs tclIntPlatStubs = { diff --git a/generic/tclTest.c b/generic/tclTest.c index 89b1518..fc0213e 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -213,7 +213,7 @@ static Tcl_ObjCmdProc NoopObjCmd; static Tcl_CmdObjTraceProc ObjTraceProc; static void ObjTraceDeleteProc(void *clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); -static void SpecialFree(void *blockPtr); +static Tcl_FreeProc SpecialFree; static int StaticInitProc(Tcl_Interp *interp); static Tcl_CmdProc TestasyncCmd; static Tcl_ObjCmdProc TestbumpinterpepochObjCmd; @@ -859,7 +859,7 @@ TestasyncCmd( if (argc < 2) { wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_AppendResult(interp, "wrong # args", (void *)NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { @@ -948,7 +948,7 @@ TestasyncCmd( if (Tcl_CreateThread(&threadID, AsyncThreadProc, INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { - Tcl_AppendResult(interp, "can't create thread", NULL); + Tcl_AppendResult(interp, "can't create thread", (void *)NULL); Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } @@ -958,7 +958,7 @@ TestasyncCmd( Tcl_MutexUnlock(&asyncTestMutex); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be create, delete, int, mark, or marklater", NULL); + "\": must be create, delete, int, mark, or marklater", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -1178,34 +1178,34 @@ TestcmdinfoObjCmd( break; case CMDINFO_GET: if (Tcl_GetCommandInfo(interp, Tcl_GetString(objv[2]), &info) ==0) { - Tcl_AppendResult(interp, "??", NULL); + Tcl_AppendResult(interp, "??", (void *)NULL); return TCL_OK; } if (info.proc == CmdProc1) { Tcl_AppendResult(interp, "CmdProc1", " ", - (char *) info.clientData, NULL); + (char *) info.clientData, (void *)NULL); } else if (info.proc == CmdProc2) { Tcl_AppendResult(interp, "CmdProc2", " ", - (char *) info.clientData, NULL); + (char *) info.clientData, (void *)NULL); } else { - Tcl_AppendResult(interp, "unknown", NULL); + Tcl_AppendResult(interp, "unknown", (void *)NULL); } if (info.deleteProc == CmdDelProc1) { Tcl_AppendResult(interp, " CmdDelProc1", " ", - (char *) info.deleteData, NULL); + (char *) info.deleteData, (void *)NULL); } else if (info.deleteProc == CmdDelProc2) { Tcl_AppendResult(interp, " CmdDelProc2", " ", - (char *) info.deleteData, NULL); + (char *) info.deleteData, (void *)NULL); } else { - Tcl_AppendResult(interp, " unknown", NULL); + Tcl_AppendResult(interp, " unknown", (void *)NULL); } - Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, NULL); + Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, (void *)NULL); if (info.isNativeObjectProc == 0) { - Tcl_AppendResult(interp, " stringProc", NULL); + Tcl_AppendResult(interp, " stringProc", (void *)NULL); } else if (info.isNativeObjectProc == 1) { - Tcl_AppendResult(interp, " nativeObjectProc", NULL); + Tcl_AppendResult(interp, " nativeObjectProc", (void *)NULL); } else if (info.isNativeObjectProc == 2) { - Tcl_AppendResult(interp, " nativeObjectProc2", NULL); + Tcl_AppendResult(interp, " nativeObjectProc2", (void *)NULL); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf("Invalid isNativeObjectProc value %d", info.isNativeObjectProc)); @@ -1241,7 +1241,7 @@ CmdProc0( TCL_UNUSED(const char **) /*argv*/) { TestCommandTokenRef *refPtr = (TestCommandTokenRef *) clientData; - Tcl_AppendResult(interp, "CmdProc1 ", refPtr->value, NULL); + Tcl_AppendResult(interp, "CmdProc1 ", refPtr->value, (void *)NULL); return TCL_OK; } @@ -1252,7 +1252,7 @@ CmdProc1( TCL_UNUSED(int) /*argc*/, TCL_UNUSED(const char **) /*argv*/) { - Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, NULL); + Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, (void *)NULL); return TCL_OK; } @@ -1263,7 +1263,7 @@ CmdProc2( TCL_UNUSED(int) /*argc*/, TCL_UNUSED(const char **) /*argv*/) { - Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, NULL); + Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, (void *)NULL); return TCL_OK; } @@ -1337,7 +1337,7 @@ TestcmdtokenCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option arg\"", NULL); + " option arg\"", (void *)NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { @@ -1350,11 +1350,11 @@ TestcmdtokenCmd( refPtr->nextPtr = firstCommandTokenRef; firstCommandTokenRef = refPtr; snprintf(buf, sizeof(buf), "%d", refPtr->id); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); } else { if (sscanf(argv[2], "%d", &id) != 1) { Tcl_AppendResult(interp, "bad command token \"", argv[2], - "\"", NULL); + "\"", (void *)NULL); return TCL_ERROR; } @@ -1367,7 +1367,7 @@ TestcmdtokenCmd( if (refPtr == NULL) { Tcl_AppendResult(interp, "bad command token \"", argv[2], - "\"", NULL); + "\"", (void *)NULL); return TCL_ERROR; } @@ -1383,7 +1383,7 @@ TestcmdtokenCmd( Tcl_DecrRefCount(objPtr); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be create, name, or free", NULL); + "\": must be create, name, or free", (void *)NULL); return TCL_ERROR; } } @@ -1421,7 +1421,7 @@ TestcmdtraceCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option script\"", NULL); + " option script\"", (void *)NULL); return TCL_ERROR; } @@ -1431,7 +1431,7 @@ TestcmdtraceCmd( result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); + Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), (void *)NULL); } Tcl_DeleteTrace(interp, cmdTrace); Tcl_DStringFree(&buffer); @@ -1453,7 +1453,7 @@ TestcmdtraceCmd( result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); + Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), (void *)NULL); } Tcl_DeleteTrace(interp, cmdTrace); Tcl_DStringFree(&buffer); @@ -1471,7 +1471,7 @@ TestcmdtraceCmd( result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); Tcl_DeleteTrace(interp, cmdTrace); if (!deleteCalled) { - Tcl_AppendResult(interp, "Delete wasn't called", NULL); + Tcl_AppendResult(interp, "Delete wasn't called", (void *)NULL); return TCL_ERROR; } else { return result; @@ -1485,14 +1485,14 @@ TestcmdtraceCmd( result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); + Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), (void *)NULL); } Tcl_DeleteTrace(interp, t2); Tcl_DeleteTrace(interp, t1); Tcl_DStringFree(&buffer); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be tracetest, deletetest, doubletest or resulttest", NULL); + "\": must be tracetest, deletetest, doubletest or resulttest", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -1610,7 +1610,7 @@ TestcreatecommandCmd( { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option\"", NULL); + " option\"", (void *)NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { @@ -1625,7 +1625,7 @@ TestcreatecommandCmd( Tcl_DeleteCommand(interp, "value:at:"); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be create, delete, create2, or delete2", NULL); + "\": must be create, delete, create2, or delete2", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -1645,11 +1645,11 @@ CreatedCommandProc( &info); if (!found) { Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand", - NULL); + (void *)NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "CreatedCommandProc in ", - info.namespacePtr->fullName, NULL); + info.namespacePtr->fullName, (void *)NULL); return TCL_OK; } @@ -1666,11 +1666,11 @@ CreatedCommandProc2( found = Tcl_GetCommandInfo(interp, "value:at:", &info); if (!found) { Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand", - NULL); + (void *)NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "CreatedCommandProc2 in ", - info.namespacePtr->fullName, NULL); + info.namespacePtr->fullName, (void *)NULL); return TCL_OK; } @@ -1766,7 +1766,7 @@ TestdelCmd( Tcl_Interp *child; if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_AppendResult(interp, "wrong # args", (void *)NULL); return TCL_ERROR; } @@ -1794,7 +1794,7 @@ DelCmdProc( { DelCmd *dPtr = (DelCmd *) clientData; - Tcl_AppendResult(interp, dPtr->deleteCmd, NULL); + Tcl_AppendResult(interp, dPtr->deleteCmd, (void *)NULL); Tcl_Free(dPtr->deleteCmd); Tcl_Free(dPtr); return TCL_OK; @@ -1839,7 +1839,7 @@ TestdelassocdataCmd( { if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " data_key\"", NULL); + " data_key\"", (void *)NULL); return TCL_ERROR; } Tcl_DeleteAssocData(interp, argv[1]); @@ -1965,7 +1965,7 @@ TestdstringCmd( if (argc < 2) { wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_AppendResult(interp, "wrong # args", (void *)NULL); return TCL_ERROR; } if (strcmp(argv[1], "append") == 0) { @@ -2001,9 +2001,9 @@ TestdstringCmd( goto wrongNumArgs; } if (strcmp(argv[2], "staticsmall") == 0) { - Tcl_AppendResult(interp, "short", NULL); + Tcl_AppendResult(interp, "short", (void *)NULL); } else if (strcmp(argv[2], "staticlarge") == 0) { - Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL); + Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", (void *)NULL); } else if (strcmp(argv[2], "free") == 0) { char *s = (char *)Tcl_Alloc(100); strcpy(s, "This is a malloc-ed string"); @@ -2015,7 +2015,7 @@ TestdstringCmd( } else { Tcl_AppendResult(interp, "bad gresult option \"", argv[2], "\": must be staticsmall, staticlarge, free, or special", - NULL); + (void *)NULL); return TCL_ERROR; } Tcl_DStringGetResult(interp, &dstring); @@ -2051,7 +2051,7 @@ TestdstringCmd( } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be append, element, end, free, get, gresult, length, " - "result, start, toobj, or trunc", NULL); + "result, start, toobj, or trunc", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -2063,7 +2063,11 @@ TestdstringCmd( */ static void SpecialFree( +#if TCL_MAJOR_VERSION > 8 void *blockPtr /* Block to free. */ +#else + char *blockPtr /* Block to free. */ +#endif ) { Tcl_Free(((char *)blockPtr) - 16); } @@ -2517,7 +2521,7 @@ TestevalexObjCmd( const char *global = Tcl_GetString(objv[2]); if (strcmp(global, "global") != 0) { Tcl_AppendResult(interp, "bad value \"", global, - "\": must be global", NULL); + "\": must be global", (void *)NULL); return TCL_ERROR; } flags = TCL_EVAL_GLOBAL; @@ -2786,7 +2790,7 @@ TestexithandlerCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " create|delete value\"", NULL); + " create|delete value\"", (void *)NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { @@ -2800,7 +2804,7 @@ TestexithandlerCmd( INT2PTR(value)); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be create or delete", NULL); + "\": must be create or delete", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -2864,16 +2868,16 @@ TestexprlongCmd( if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " expression\"", NULL); + " expression\"", (void *)NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_AppendResult(interp, "This is a result", (void *)NULL); result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; } snprintf(buf, sizeof(buf), ": %ld", exprResult); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); return TCL_OK; } @@ -2909,13 +2913,13 @@ TestexprlongobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_AppendResult(interp, "This is a result", (void *)NULL); result = Tcl_ExprLongObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; } snprintf(buf, sizeof(buf), ": %ld", exprResult); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); return TCL_OK; } @@ -2949,17 +2953,17 @@ TestexprdoubleCmd( if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " expression\"", NULL); + " expression\"", (void *)NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_AppendResult(interp, "This is a result", (void *)NULL); result = Tcl_ExprDouble(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; } strcpy(buf, ": "); Tcl_PrintDouble(interp, exprResult, buf+2); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); return TCL_OK; } @@ -2995,14 +2999,14 @@ TestexprdoubleobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_AppendResult(interp, "This is a result", (void *)NULL); result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; } strcpy(buf, ": "); Tcl_PrintDouble(interp, exprResult, buf+2); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); return TCL_OK; } @@ -3031,7 +3035,7 @@ TestexprstringCmd( { if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " expression\"", NULL); + " expression\"", (void *)NULL); return TCL_ERROR; } return Tcl_ExprString(interp, argv[1]); @@ -3080,7 +3084,7 @@ TestfilelinkCmd( Tcl_AppendResult(interp, "could not create link from \"", Tcl_GetString(objv[1]), "\" to \"", Tcl_GetString(objv[2]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_PosixError(interp), (void *)NULL); return TCL_ERROR; } } else { @@ -3089,7 +3093,7 @@ TestfilelinkCmd( if (contents == NULL) { Tcl_AppendResult(interp, "could not read link \"", Tcl_GetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_PosixError(interp), (void *)NULL); return TCL_ERROR; } } @@ -3132,12 +3136,12 @@ TestgetassocdataCmd( if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " data_key\"", NULL); + " data_key\"", (void *)NULL); return TCL_ERROR; } res = (char *) Tcl_GetAssocData(interp, argv[1], NULL); if (res != NULL) { - Tcl_AppendResult(interp, res, NULL); + Tcl_AppendResult(interp, res, (void *)NULL); } return TCL_OK; } @@ -3173,11 +3177,11 @@ TestgetplatformCmd( if (argc != 1) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - NULL); + (void *)NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, platformStrings[*platform], NULL); + Tcl_AppendResult(interp, platformStrings[*platform], (void *)NULL); return TCL_OK; } @@ -3210,7 +3214,7 @@ TestinterpdeleteCmd( if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " path\"", NULL); + " path\"", (void *)NULL); return TCL_ERROR; } childToDelete = Tcl_GetChild(interp, argv[1]); @@ -3268,7 +3272,7 @@ TestlinkCmd( if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option ?arg arg arg arg arg arg arg arg arg arg arg arg" - " arg arg?\"", NULL); + " arg arg?\"", (void *)NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { @@ -3276,7 +3280,7 @@ TestlinkCmd( Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " intRO realRO boolRO stringRO wideRO charRO ucharRO shortRO" - " ushortRO uintRO longRO ulongRO floatRO uwideRO\"", NULL); + " ushortRO uintRO longRO ulongRO floatRO uwideRO\"", (void *)NULL); return TCL_ERROR; } if (created) { @@ -3485,7 +3489,7 @@ TestlinkCmd( argv[0], " ", argv[1], " intValue realValue boolValue stringValue wideValue" " charValue ucharValue shortValue ushortValue uintValue" - " longValue ulongValue floatValue uwideValue\"", NULL); + " longValue ulongValue floatValue uwideValue\"", (void *)NULL); return TCL_ERROR; } if (argv[2][0] != 0) { @@ -3589,7 +3593,7 @@ TestlinkCmd( argv[0], " ", argv[1], " intValue realValue boolValue stringValue wideValue" " charValue ucharValue shortValue ushortValue uintValue" - " longValue ulongValue floatValue uwideValue\"", NULL); + " longValue ulongValue floatValue uwideValue\"", (void *)NULL); return TCL_ERROR; } if (argv[2][0] != 0) { @@ -3701,7 +3705,7 @@ TestlinkCmd( } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be create, delete, get, set, or update", NULL); + "\": should be create, delete, get, set, or update", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -3900,7 +3904,7 @@ TestlistrepCmd( } resultObj = TclListTestObj(length, leadSpace, endSpace); if (resultObj == NULL) { - Tcl_AppendResult(interp, "List capacity exceeded", NULL); + Tcl_AppendResult(interp, "List capacity exceeded", (void *)NULL); return TCL_ERROR; } } @@ -4596,7 +4600,7 @@ TestregexpObjCmd( value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", - varName, "\"", NULL); + varName, "\"", (void *)NULL); return TCL_ERROR; } } else if (cflags & TCL_REG_CANMATCH) { @@ -4610,7 +4614,7 @@ TestregexpObjCmd( value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", - varName, "\"", NULL); + varName, "\"", (void *)NULL); return TCL_ERROR; } } @@ -4831,7 +4835,7 @@ TestsetassocdataCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " data_key data_item\"", NULL); + " data_key data_item\"", (void *)NULL); return TCL_ERROR; } @@ -4884,7 +4888,7 @@ TestsetplatformCmd( if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " platform\"", NULL); + " platform\"", (void *)NULL); return TCL_ERROR; } @@ -4895,7 +4899,7 @@ TestsetplatformCmd( *platform = TCL_PLATFORM_WINDOWS; } else { Tcl_AppendResult(interp, "unsupported platform: should be one of " - "unix, or windows", NULL); + "unix, or windows", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -4930,7 +4934,7 @@ TeststaticlibraryCmd( if (argc != 4) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " prefix safe loaded\"", NULL); + argv[0], " prefix safe loaded\"", (void *)NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) { @@ -4982,14 +4986,14 @@ TesttranslatefilenameCmd( if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " path\"", NULL); + argv[0], " path\"", (void *)NULL); return TCL_ERROR; } result = Tcl_TranslateFileName(interp, argv[1], &buffer); if (result == NULL) { return TCL_ERROR; } - Tcl_AppendResult(interp, result, NULL); + Tcl_AppendResult(interp, result, (void *)NULL); Tcl_DStringFree(&buffer); return TCL_OK; } @@ -5022,7 +5026,7 @@ TestupvarCmd( if ((argc != 5) && (argc != 6)) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " level name ?name2? dest global\"", NULL); + argv[0], " level name ?name2? dest global\"", (void *)NULL); return TCL_ERROR; } @@ -5071,28 +5075,28 @@ TestseterrorcodeCmd( const char **argv) /* Argument strings. */ { if (argc > 6) { - Tcl_AppendResult(interp, "too many args", NULL); + Tcl_AppendResult(interp, "too many args", (void *)NULL); return TCL_ERROR; } switch (argc) { case 1: - Tcl_SetErrorCode(interp, "NONE", NULL); + Tcl_SetErrorCode(interp, "NONE", (void *)NULL); break; case 2: - Tcl_SetErrorCode(interp, argv[1], NULL); + Tcl_SetErrorCode(interp, argv[1], (void *)NULL); break; case 3: - Tcl_SetErrorCode(interp, argv[1], argv[2], NULL); + Tcl_SetErrorCode(interp, argv[1], argv[2], (void *)NULL); break; case 4: - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL); + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], (void *)NULL); break; case 5: - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL); + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], (void *)NULL); break; case 6: Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], - argv[5], NULL); + argv[5], (void *)NULL); } return TCL_ERROR; } @@ -5156,13 +5160,13 @@ TestfeventCmd( if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg ...?", NULL); + " option ?arg ...?", (void *)NULL); return TCL_ERROR; } if (strcmp(argv[1], "cmd") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " cmd script", NULL); + " cmd script", (void *)NULL); return TCL_ERROR; } if (interp2 != NULL) { @@ -5172,7 +5176,7 @@ TestfeventCmd( } else { Tcl_AppendResult(interp, "called \"testfevent code\" before \"testfevent create\"", - NULL); + (void *)NULL); return TCL_ERROR; } } else if (strcmp(argv[1], "create") == 0) { @@ -5288,11 +5292,11 @@ TestfileCmd( if (result != TCL_OK) { if (error != NULL) { if (Tcl_GetString(error)[0] != '\0') { - Tcl_AppendResult(interp, Tcl_GetString(error), " ", NULL); + Tcl_AppendResult(interp, Tcl_GetString(error), " ", (void *)NULL); } Tcl_DecrRefCount(error); } - Tcl_AppendResult(interp, Tcl_ErrnoId(), NULL); + Tcl_AppendResult(interp, Tcl_ErrnoId(), (void *)NULL); } end: @@ -5733,7 +5737,7 @@ TestsetbytearraylengthObjCmd( if (obj != objv[1]) { Tcl_DecrRefCount(obj); } - Tcl_AppendResult(interp, "expected bytes", NULL); + Tcl_AppendResult(interp, "expected bytes", (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, obj); @@ -5794,7 +5798,7 @@ TestbytestringObjCmd( #endif if (x.m != 1) { - Tcl_AppendResult(interp, "Tcl_GetBytesFromObj() overwrites variable", NULL); + Tcl_AppendResult(interp, "Tcl_GetBytesFromObj() overwrites variable", (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewStringObj(p, x.n)); @@ -5829,7 +5833,7 @@ TestsetCmd( const char *value; if (argc == 2) { - Tcl_AppendResult(interp, "before get", NULL); + Tcl_AppendResult(interp, "before get", (void *)NULL); value = Tcl_GetVar2(interp, argv[1], NULL, flags); if (value == NULL) { return TCL_ERROR; @@ -5837,7 +5841,7 @@ TestsetCmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 3) { - Tcl_AppendResult(interp, "before set", NULL); + Tcl_AppendResult(interp, "before set", (void *)NULL); value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -5846,7 +5850,7 @@ TestsetCmd( return TCL_OK; } else { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName ?newValue?\"", NULL); + argv[0], " varName ?newValue?\"", (void *)NULL); return TCL_ERROR; } } @@ -5861,7 +5865,7 @@ Testset2Cmd( const char *value; if (argc == 3) { - Tcl_AppendResult(interp, "before get", NULL); + Tcl_AppendResult(interp, "before get", (void *)NULL); value = Tcl_GetVar2(interp, argv[1], argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -5869,7 +5873,7 @@ Testset2Cmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 4) { - Tcl_AppendResult(interp, "before set", NULL); + Tcl_AppendResult(interp, "before set", (void *)NULL); value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags); if (value == NULL) { return TCL_ERROR; @@ -5878,7 +5882,7 @@ Testset2Cmd( return TCL_OK; } else { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName elemName ?newValue?\"", NULL); + argv[0], " varName elemName ?newValue?\"", (void *)NULL); return TCL_ERROR; } } @@ -5913,7 +5917,7 @@ TestmainthreadCmd( Tcl_SetObjResult(interp, idObj); return TCL_OK; } else { - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_AppendResult(interp, "wrong # args", (void *)NULL); return TCL_ERROR; } } @@ -6039,7 +6043,7 @@ TestChannelCmd( if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " subcommand ?additional args..?\"", NULL); + " subcommand ?additional args..?\"", (void *)NULL); return TCL_ERROR; } cmdName = argv[1]; @@ -6122,7 +6126,7 @@ TestChannelCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " cut channelName\"", NULL); + " cut channelName\"", (void *)NULL); return TCL_ERROR; } @@ -6145,7 +6149,7 @@ TestChannelCmd( (strncmp(cmdName, "clearchannelhandlers", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " clearchannelhandlers channelName\"", NULL); + " clearchannelhandlers channelName\"", (void *)NULL); return TCL_ERROR; } Tcl_ClearChannelHandlers(chan); @@ -6155,7 +6159,7 @@ TestChannelCmd( if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " info channelName\"", NULL); + " info channelName\"", (void *)NULL); return TCL_ERROR; } Tcl_AppendElement(interp, argv[2]); @@ -6247,40 +6251,40 @@ TestChannelCmd( if ((cmdName[0] == 'i') && (strncmp(cmdName, "inputbuffered", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } IOQueued = Tcl_InputBuffered(chan); TclFormatInt(buf, IOQueued); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); return TCL_OK; } if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } TclFormatInt(buf, Tcl_IsChannelShared(chan)); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); return TCL_OK; } if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } TclFormatInt(buf, Tcl_IsStandardChannel(chan)); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); return TCL_OK; } if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } @@ -6299,7 +6303,7 @@ TestChannelCmd( if ((cmdName[0] == 'm') && (strncmp(cmdName, "maxmode", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } @@ -6318,7 +6322,7 @@ TestChannelCmd( if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-rd", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } @@ -6327,7 +6331,7 @@ TestChannelCmd( if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-wr", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } @@ -6336,7 +6340,7 @@ TestChannelCmd( if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } @@ -6347,10 +6351,10 @@ TestChannelCmd( if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, statePtr->channelName, NULL); + Tcl_AppendResult(interp, statePtr->channelName, (void *)NULL); return TCL_OK; } @@ -6370,25 +6374,25 @@ TestChannelCmd( if ((cmdName[0] == 'o') && (strncmp(cmdName, "outputbuffered", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } IOQueued = Tcl_OutputBuffered(chan); TclFormatInt(buf, IOQueued); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); return TCL_OK; } if ((cmdName[0] == 'q') && (strncmp(cmdName, "queuedcr", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } Tcl_AppendResult(interp, - (statePtr->flags & INPUT_SAW_CR) ? "1" : "0", NULL); + (statePtr->flags & INPUT_SAW_CR) ? "1" : "0", (void *)NULL); return TCL_OK; } @@ -6411,12 +6415,12 @@ TestChannelCmd( if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } TclFormatInt(buf, statePtr->refCount); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); return TCL_OK; } @@ -6429,7 +6433,7 @@ TestChannelCmd( if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } @@ -6443,10 +6447,10 @@ TestChannelCmd( if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", NULL); + Tcl_AppendResult(interp, "channel name required", (void *)NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), NULL); + Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), (void *)NULL); return TCL_OK; } @@ -6473,12 +6477,12 @@ TestChannelCmd( if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " transform channelId -command cmd\"", NULL); + " transform channelId -command cmd\"", (void *)NULL); return TCL_ERROR; } if (strcmp(argv[3], "-command") != 0) { Tcl_AppendResult(interp, "bad argument \"", argv[3], - "\": should be \"-command\"", NULL); + "\": should be \"-command\"", (void *)NULL); return TCL_ERROR; } @@ -6493,7 +6497,7 @@ TestChannelCmd( if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " unstack channel\"", NULL); + " unstack channel\"", (void *)NULL); return TCL_ERROR; } return Tcl_UnstackChannel(interp, chan); @@ -6501,7 +6505,7 @@ TestChannelCmd( Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be " "cut, clearchannelhandlers, info, isshared, mode, open, " - "readable, splice, writable, transform, unstack", NULL); + "readable, splice, writable, transform, unstack", (void *)NULL); return TCL_ERROR; } @@ -6538,7 +6542,7 @@ TestChannelEventCmd( if ((argc < 3) || (argc > 5)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName cmd ?arg1? ?arg2?\"", NULL); + " channelName cmd ?arg1? ?arg2?\"", (void *)NULL); return TCL_ERROR; } chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL); @@ -6552,7 +6556,7 @@ TestChannelEventCmd( if ((cmd[0] == 'a') && (strncmp(cmd, "add", len) == 0)) { if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName add eventSpec script\"", NULL); + " channelName add eventSpec script\"", (void *)NULL); return TCL_ERROR; } if (strcmp(argv[3], "readable") == 0) { @@ -6563,7 +6567,7 @@ TestChannelEventCmd( mask = 0; } else { Tcl_AppendResult(interp, "bad event name \"", argv[3], - "\": must be readable, writable, or none", NULL); + "\": must be readable, writable, or none", (void *)NULL); return TCL_ERROR; } @@ -6586,7 +6590,7 @@ TestChannelEventCmd( if ((cmd[0] == 'd') && (strncmp(cmd, "delete", len) == 0)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName delete index\"", NULL); + " channelName delete index\"", (void *)NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { @@ -6594,7 +6598,7 @@ TestChannelEventCmd( } if (index < 0) { Tcl_AppendResult(interp, "bad event index: ", argv[3], - ": must be nonnegative", NULL); + ": must be nonnegative", (void *)NULL); return TCL_ERROR; } for (i = 0, esPtr = statePtr->scriptRecordPtr; @@ -6604,7 +6608,7 @@ TestChannelEventCmd( } if (esPtr == NULL) { Tcl_AppendResult(interp, "bad event index ", argv[3], - ": out of range", NULL); + ": out of range", (void *)NULL); return TCL_ERROR; } if (esPtr == statePtr->scriptRecordPtr) { @@ -6632,7 +6636,7 @@ TestChannelEventCmd( if ((cmd[0] == 'l') && (strncmp(cmd, "list", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName list\"", NULL); + " channelName list\"", (void *)NULL); return TCL_ERROR; } resultListPtr = Tcl_GetObjResult(interp); @@ -6655,7 +6659,7 @@ TestChannelEventCmd( if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName removeall\"", NULL); + " channelName removeall\"", (void *)NULL); return TCL_ERROR; } for (esPtr = statePtr->scriptRecordPtr; @@ -6674,7 +6678,7 @@ TestChannelEventCmd( if ((cmd[0] == 's') && (strncmp(cmd, "set", len) == 0)) { if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName delete index event\"", NULL); + " channelName delete index event\"", (void *)NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { @@ -6682,7 +6686,7 @@ TestChannelEventCmd( } if (index < 0) { Tcl_AppendResult(interp, "bad event index: ", argv[3], - ": must be nonnegative", NULL); + ": must be nonnegative", (void *)NULL); return TCL_ERROR; } for (i = 0, esPtr = statePtr->scriptRecordPtr; @@ -6692,7 +6696,7 @@ TestChannelEventCmd( } if (esPtr == NULL) { Tcl_AppendResult(interp, "bad event index ", argv[3], - ": out of range", NULL); + ": out of range", (void *)NULL); return TCL_ERROR; } @@ -6704,7 +6708,7 @@ TestChannelEventCmd( mask = 0; } else { Tcl_AppendResult(interp, "bad event name \"", argv[4], - "\": must be readable, writable, or none", NULL); + "\": must be readable, writable, or none", (void *)NULL); return TCL_ERROR; } esPtr->mask = mask; @@ -6713,7 +6717,7 @@ TestChannelEventCmd( return TCL_OK; } Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of " - "add, delete, list, set, or removeall", NULL); + "add, delete, list, set, or removeall", (void *)NULL); return TCL_ERROR; } @@ -6750,7 +6754,7 @@ TestSocketCmd( if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " subcommand ?additional args..?\"", NULL); + " subcommand ?additional args..?\"", (void *)NULL); return TCL_ERROR; } cmdName = argv[1]; @@ -6767,18 +6771,18 @@ TestSocketCmd( */ if (argc < 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " testflags channel flags\"", NULL); + " testflags channel flags\"", (void *)NULL); return TCL_ERROR; } hChannel = Tcl_GetChannel(interp, argv[2], &modePtr); if ( NULL == hChannel ) { - Tcl_AppendResult(interp, "unknown channel:", argv[2], NULL); + Tcl_AppendResult(interp, "unknown channel:", argv[2], (void *)NULL); return TCL_ERROR; } statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel); if ( NULL == statePtr) { Tcl_AppendResult(interp, "No channel instance data:", argv[2], - NULL); + (void *)NULL); return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[3], &testMode) != TCL_OK) { @@ -6793,7 +6797,7 @@ TestSocketCmd( } Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be " - "testflags", NULL); + "testflags", (void *)NULL); return TCL_ERROR; } @@ -6827,7 +6831,7 @@ TestServiceModeCmd( int newmode, oldmode; if (argc > 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?newmode?\"", NULL); + " ?newmode?\"", (void *)NULL); return TCL_ERROR; } oldmode = (Tcl_GetServiceMode() != TCL_SERVICE_NONE); @@ -6889,7 +6893,7 @@ TestWrongNumArgsObjCmd( * Asked for more arguments than were given. */ insufArgs: - Tcl_AppendResult(interp, "insufficient arguments", NULL); + Tcl_AppendResult(interp, "insufficient arguments", (void *)NULL); return TCL_ERROR; } @@ -6942,15 +6946,15 @@ TestGetIndexFromObjStructObjCmd( return TCL_ERROR; } if (idx[0] != 85 || idx[2] != 85) { - Tcl_AppendResult(interp, "Tcl_GetIndexFromObjStruct overwrites bytes near index variable", NULL); + Tcl_AppendResult(interp, "Tcl_GetIndexFromObjStruct overwrites bytes near index variable", (void *)NULL); return TCL_ERROR; } else if (idx[1] != target) { char buffer[64]; snprintf(buffer, sizeof(buffer), "%d", idx[1]); Tcl_AppendResult(interp, "index value comparison failed: got ", - buffer, NULL); + buffer, (void *)NULL); snprintf(buffer, sizeof(buffer), "%d", target); - Tcl_AppendResult(interp, " when ", buffer, " expected", NULL); + Tcl_AppendResult(interp, " when ", buffer, " expected", (void *)NULL); return TCL_ERROR; } Tcl_WrongNumArgs(interp, objc, objv, NULL); @@ -7457,7 +7461,7 @@ SimpleOpenFileChannel( Tcl_Channel chan; if ((mode != 0) && !(mode & O_RDONLY)) { - Tcl_AppendResult(interp, "read-only", NULL); + Tcl_AppendResult(interp, "read-only", (void *)NULL); return NULL; } @@ -7543,7 +7547,7 @@ TestUtfNextCmd( /* Run Tcl_UtfNext with many more possible bytes at src[-1], all should give the same result */ result = Tcl_UtfNext(buffer + 1); if (first != result) { - Tcl_AppendResult(interp, "Tcl_UtfNext is not supposed to read src[-1]", NULL); + Tcl_AppendResult(interp, "Tcl_UtfNext is not supposed to read src[-1]", (void *)NULL); return TCL_ERROR; } } @@ -7815,7 +7819,7 @@ TestHashSystemHashCmd( Tcl_InitCustomHashTable(&hash, TCL_CUSTOM_TYPE_KEYS, &hkType); if (hash.numEntries != 0) { - Tcl_AppendResult(interp, "non-zero initial size", NULL); + Tcl_AppendResult(interp, "non-zero initial size", (void *)NULL); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } @@ -7832,7 +7836,7 @@ TestHashSystemHashCmd( } if (hash.numEntries != (Tcl_Size)limit) { - Tcl_AppendResult(interp, "unexpected maximal size", NULL); + Tcl_AppendResult(interp, "unexpected maximal size", (void *)NULL); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } @@ -7855,13 +7859,13 @@ TestHashSystemHashCmd( } if (hash.numEntries != 0) { - Tcl_AppendResult(interp, "non-zero final size", NULL); + Tcl_AppendResult(interp, "non-zero final size", (void *)NULL); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } Tcl_DeleteHashTable(&hash); - Tcl_AppendResult(interp, "OK", NULL); + Tcl_AppendResult(interp, "OK", (void *)NULL); return TCL_OK; } @@ -7877,7 +7881,7 @@ TestgetintCmd( const char **argv) { if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_AppendResult(interp, "wrong # args", (void *)NULL); return TCL_ERROR; } else { int val, i, total=0; @@ -7904,7 +7908,7 @@ TestlongsizeCmd( TCL_UNUSED(const char **) /*argv*/) { if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_AppendResult(interp, "wrong # args", (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(long))); @@ -7917,22 +7921,22 @@ NREUnwind_callback( Tcl_Interp *interp, TCL_UNUSED(int) /*result*/) { - int none; + void *cStackPtr = TclGetCStackPtr(); if (data[0] == INT2PTR(-1)) { - Tcl_NRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1), + Tcl_NRAddCallback(interp, NREUnwind_callback, cStackPtr, INT2PTR(-1), INT2PTR(-1), NULL); } else if (data[1] == INT2PTR(-1)) { - Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], &none, + Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], cStackPtr, INT2PTR(-1), NULL); } else if (data[2] == INT2PTR(-1)) { Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], data[1], - &none, NULL); + cStackPtr, NULL); } else { Tcl_Obj *idata[3]; idata[0] = Tcl_NewWideIntObj(((char *) data[1] - (char *) data[0])); idata[1] = Tcl_NewWideIntObj(((char *) data[2] - (char *) data[0])); - idata[2] = Tcl_NewWideIntObj(((char *) &none - (char *) data[0])); + idata[2] = Tcl_NewWideIntObj(((char *) cStackPtr - (char *) data[0])); Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata)); } return TCL_OK; @@ -7971,10 +7975,10 @@ TestNRELevels( NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr; if (refDepth == NULL) { - refDepth = &depth; + refDepth = (ptrdiff_t *)TclGetCStackPtr(); } - depth = (refDepth - &depth); + depth = (refDepth - (ptrdiff_t *)TclGetCStackPtr()); levels[0] = Tcl_NewWideIntObj(depth); levels[1] = Tcl_NewWideIntObj(iPtr->numLevels); @@ -8055,21 +8059,21 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (a) concatObj does not have refCount 0", NULL); + "\n\t* (a) concatObj does not have refCount 0", (void *)NULL); } if (concatPtr == tmpPtr) { result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (a) concatObj is not a new obj ", - NULL); + (void *)NULL); switch (tmpPtr->refCount) { case 0: - Tcl_AppendResult(interp, "(no new refCount)", NULL); + Tcl_AppendResult(interp, "(no new refCount)", (void *)NULL); break; case 1: - Tcl_AppendResult(interp, "(refCount added)", NULL); + Tcl_AppendResult(interp, "(refCount added)", (void *)NULL); break; default: - Tcl_AppendResult(interp, "(more than one refCount added!)", NULL); + Tcl_AppendResult(interp, "(more than one refCount added!)", (void *)NULL); Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); } tmpPtr = Tcl_DuplicateObj(list1Ptr); @@ -8082,26 +8086,26 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (b) concatObj does not have refCount 0", NULL); + "\n\t* (b) concatObj does not have refCount 0", (void *)NULL); } if (concatPtr == tmpPtr) { result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (b) concatObj is not a new obj ", - NULL); + (void *)NULL); switch (tmpPtr->refCount) { case 0: - Tcl_AppendResult(interp, "(refCount removed?)", NULL); + Tcl_AppendResult(interp, "(refCount removed?)", (void *)NULL); Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); break; case 1: - Tcl_AppendResult(interp, "(no new refCount)", NULL); + Tcl_AppendResult(interp, "(no new refCount)", (void *)NULL); break; case 2: - Tcl_AppendResult(interp, "(refCount added)", NULL); + Tcl_AppendResult(interp, "(refCount added)", (void *)NULL); Tcl_DecrRefCount(tmpPtr); break; default: - Tcl_AppendResult(interp, "(more than one refCount added!)", NULL); + Tcl_AppendResult(interp, "(more than one refCount added!)", (void *)NULL); Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); } tmpPtr = Tcl_DuplicateObj(list1Ptr); @@ -8116,21 +8120,21 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (c) concatObj does not have refCount 0", NULL); + "\n\t* (c) concatObj does not have refCount 0", (void *)NULL); } if (concatPtr == tmpPtr) { result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (c) concatObj is not a new obj ", - NULL); + (void *)NULL); switch (tmpPtr->refCount) { case 0: - Tcl_AppendResult(interp, "(no new refCount)", NULL); + Tcl_AppendResult(interp, "(no new refCount)", (void *)NULL); break; case 1: - Tcl_AppendResult(interp, "(refCount added)", NULL); + Tcl_AppendResult(interp, "(refCount added)", (void *)NULL); break; default: - Tcl_AppendResult(interp, "(more than one refCount added!)", NULL); + Tcl_AppendResult(interp, "(more than one refCount added!)", (void *)NULL); Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); } tmpPtr = Tcl_DuplicateObj(list1Ptr); @@ -8143,26 +8147,26 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (d) concatObj does not have refCount 0", NULL); + "\n\t* (d) concatObj does not have refCount 0", (void *)NULL); } if (concatPtr == tmpPtr) { result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (d) concatObj is not a new obj ", - NULL); + (void *)NULL); switch (tmpPtr->refCount) { case 0: - Tcl_AppendResult(interp, "(refCount removed?)", NULL); + Tcl_AppendResult(interp, "(refCount removed?)", (void *)NULL); Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); break; case 1: - Tcl_AppendResult(interp, "(no new refCount)", NULL); + Tcl_AppendResult(interp, "(no new refCount)", (void *)NULL); break; case 2: - Tcl_AppendResult(interp, "(refCount added)", NULL); + Tcl_AppendResult(interp, "(refCount added)", (void *)NULL); Tcl_DecrRefCount(tmpPtr); break; default: - Tcl_AppendResult(interp, "(more than one refCount added!)", NULL); + Tcl_AppendResult(interp, "(more than one refCount added!)", (void *)NULL); Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()"); } tmpPtr = Tcl_DuplicateObj(list1Ptr); @@ -8181,20 +8185,20 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (e) concatObj does not have refCount 0", NULL); + "\n\t* (e) concatObj does not have refCount 0", (void *)NULL); } if (concatPtr == tmpPtr) { result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (e) concatObj is not a new obj ", - NULL); + (void *)NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); switch (tmpPtr->refCount) { case 3: - Tcl_AppendResult(interp, "(failed to concat)", NULL); + Tcl_AppendResult(interp, "(failed to concat)", (void *)NULL); break; default: - Tcl_AppendResult(interp, "(corrupted input!)", NULL); + Tcl_AppendResult(interp, "(corrupted input!)", (void *)NULL); } if (Tcl_IsShared(tmpPtr)) { Tcl_DecrRefCount(tmpPtr); @@ -8211,20 +8215,20 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (f) concatObj does not have refCount 0", NULL); + "\n\t* (f) concatObj does not have refCount 0", (void *)NULL); } if (concatPtr == tmpPtr) { result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (f) concatObj is not a new obj ", - NULL); + (void *)NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); switch (tmpPtr->refCount) { case 3: - Tcl_AppendResult(interp, "(failed to concat)", NULL); + Tcl_AppendResult(interp, "(failed to concat)", (void *)NULL); break; default: - Tcl_AppendResult(interp, "(corrupted input!)", NULL); + Tcl_AppendResult(interp, "(corrupted input!)", (void *)NULL); } if (Tcl_IsShared(tmpPtr)) { Tcl_DecrRefCount(tmpPtr); @@ -8242,20 +8246,20 @@ TestconcatobjCmd( if (concatPtr->refCount != 0) { result = TCL_ERROR; Tcl_AppendResult(interp, - "\n\t* (g) concatObj does not have refCount 0", NULL); + "\n\t* (g) concatObj does not have refCount 0", (void *)NULL); } if (concatPtr == tmpPtr) { result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (g) concatObj is not a new obj ", - NULL); + (void *)NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); switch (tmpPtr->refCount) { case 3: - Tcl_AppendResult(interp, "(failed to concat)", NULL); + Tcl_AppendResult(interp, "(failed to concat)", (void *)NULL); break; default: - Tcl_AppendResult(interp, "(corrupted input!)", NULL); + Tcl_AppendResult(interp, "(corrupted input!)", (void *)NULL); } Tcl_DecrRefCount(tmpPtr); if (Tcl_IsShared(tmpPtr)) { @@ -8629,7 +8633,7 @@ TestInterpResolverCmd( if (objc == 3) { interp = Tcl_GetChild(interp, Tcl_GetString(objv[2])); if (interp == NULL) { - Tcl_AppendResult(interp, "provided interpreter not found", NULL); + Tcl_AppendResult(interp, "provided interpreter not found", (void *)NULL); return TCL_ERROR; } } @@ -8645,7 +8649,7 @@ TestInterpResolverCmd( case 0: /*down*/ if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) { Tcl_AppendResult(interp, "could not remove the resolver scheme", - NULL); + (void *)NULL); return TCL_ERROR; } } diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 682b41d..1661d55 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -418,7 +418,7 @@ TestbooleanobjCmd( } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", Tcl_GetString(objv[1]), - "\": must be set, get, or not", NULL); + "\": must be set, get, or not", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -535,7 +535,7 @@ TestdoubleobjCmd( } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", Tcl_GetString(objv[1]), - "\": must be set, get, mult10, or div10", NULL); + "\": must be set, get, mult10, or div10", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -824,7 +824,7 @@ TestintobjCmd( } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", Tcl_GetString(objv[1]), - "\": must be set, get, get2, mult10, or div10", NULL); + "\": must be set, get, get2, mult10, or div10", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -1234,7 +1234,7 @@ TestobjCmd( } if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "no type ", Tcl_GetString(objv[3]), " found", NULL); + "no type ", Tcl_GetString(objv[3]), " found", (void *)NULL); return TCL_ERROR; } if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) @@ -1391,7 +1391,7 @@ TeststringobjCmd( Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1], strings[2], strings[3], strings[4], strings[5], strings[6], strings[7], strings[8], strings[9], - strings[10], strings[11]); + strings[10], strings[11], (void *)NULL); Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 2: /* get */ diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 381ff02..a86499e 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -263,7 +263,7 @@ ProcBodyTestProcObjCmd( if (cmdPtr->objClientData != TclIsProc(cmdPtr)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "command \"", fullName, "\" is not a Tcl procedure", NULL); + "command \"", fullName, "\" is not a Tcl procedure", (void *)NULL); return TCL_ERROR; } @@ -274,7 +274,7 @@ ProcBodyTestProcObjCmd( procPtr = (Proc *) cmdPtr->objClientData; if (procPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "procedure \"", - fullName, "\" does not have a Proc struct!", NULL); + fullName, "\" does not have a Proc struct!", (void *)NULL); return TCL_ERROR; } @@ -286,7 +286,7 @@ ProcBodyTestProcObjCmd( if (bodyObjPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "failed to create a procbody object for procedure \"", - fullName, "\"", NULL); + fullName, "\"", (void *)NULL); return TCL_ERROR; } Tcl_IncrRefCount(bodyObjPtr); diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index c87a7ba..f0db075 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -369,7 +369,7 @@ ThreadObjCmd( char buf[TCL_INTEGER_SPACE]; snprintf(buf, sizeof(buf), "%" TCL_LL_MODIFIER "d", (long long)id); - Tcl_AppendResult(interp, "cannot join thread ", buf, NULL); + Tcl_AppendResult(interp, "cannot join thread ", buf, (void *)NULL); } return result; } @@ -507,7 +507,7 @@ ThreadCreate( if (Tcl_CreateThread(&id, NewTestThread, &ctrl, TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); - Tcl_AppendResult(interp, "can't create a new thread", NULL); + Tcl_AppendResult(interp, "can't create a new thread", (void *)NULL); return TCL_ERROR; } @@ -818,7 +818,7 @@ ThreadSend( } if (!found) { Tcl_MutexUnlock(&threadMutex); - Tcl_AppendResult(interp, "invalid thread id", NULL); + Tcl_AppendResult(interp, "invalid thread id", (void *)NULL); return TCL_ERROR; } @@ -912,7 +912,7 @@ ThreadSend( if (resultPtr->code != TCL_OK) { if (resultPtr->errorCode) { - Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL); + Tcl_SetErrorCode(interp, resultPtr->errorCode, (void *)NULL); Tcl_Free(resultPtr->errorCode); } if (resultPtr->errorInfo) { @@ -920,7 +920,7 @@ ThreadSend( Tcl_Free(resultPtr->errorInfo); } } - Tcl_AppendResult(interp, resultPtr->result, NULL); + Tcl_AppendResult(interp, resultPtr->result, (void *)NULL); Tcl_ConditionFinalize(&resultPtr->done); code = resultPtr->code; @@ -971,7 +971,7 @@ ThreadCancel( } if (!found) { Tcl_MutexUnlock(&threadMutex); - Tcl_AppendResult(interp, "invalid thread id", NULL); + Tcl_AppendResult(interp, "invalid thread id", (void *)NULL); return TCL_ERROR; } diff --git a/generic/tclTimer.c b/generic/tclTimer.c index b1a43a5..528958c 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -826,7 +826,7 @@ Tcl_AfterObjCmd( "bad argument \"%s\": must be" " cancel, idle, info, or an integer", arg)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument", - arg, NULL); + arg, (void *)NULL); return TCL_ERROR; } } @@ -965,7 +965,7 @@ Tcl_AfterObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "event \"%s\" doesn't exist", eventStr)); - Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL); + Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, (void *)NULL); return TCL_ERROR; } else { Tcl_Obj *resultListPtr; diff --git a/generic/tclTrace.c b/generic/tclTrace.c index b1e1e44..15da56e 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -319,7 +319,7 @@ TraceExecutionObjCmd( "bad operation list \"\": must be one or more of" " enter, leave, enterstep, or leavestep", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", - NULL); + (void *)NULL); return TCL_ERROR; } result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs); @@ -561,7 +561,7 @@ TraceCommandObjCmd( "bad operation list \"\": must be one or more of" " delete or rename", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", - NULL); + (void *)NULL); return TCL_ERROR; } result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs); @@ -760,7 +760,7 @@ TraceVariableObjCmd( "bad operation list \"\": must be one or more of" " array, read, unset, or write", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", - NULL); + (void *)NULL); return TCL_ERROR; } result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 485e65b..579d822 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -658,7 +658,7 @@ FindElement( "%s element in braces followed by \"%.*s\" " "instead of space", typeStr, (int) (p2-p), p)); Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK", - NULL); + (void *)NULL); } return TCL_ERROR; } @@ -710,7 +710,7 @@ FindElement( "%s element in quotes followed by \"%.*s\" " "instead of space", typeStr, (int) (p2-p), p)); Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK", - NULL); + (void *)NULL); } return TCL_ERROR; } @@ -743,7 +743,7 @@ FindElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unmatched open brace in %s", typeStr)); Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "BRACE", - NULL); + (void *)NULL); } return TCL_ERROR; } else if (inQuotes) { @@ -751,7 +751,7 @@ FindElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unmatched open quote in %s", typeStr)); Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "QUOTE", - NULL); + (void *)NULL); } return TCL_ERROR; } @@ -902,7 +902,7 @@ Tcl_SplitList( Tcl_SetObjResult(interp, Tcl_NewStringObj( "internal error in Tcl_SplitList", -1)); Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", - NULL); + (void *)NULL); } return TCL_ERROR; } @@ -3732,7 +3732,7 @@ GetEndOffsetFromObj( if (!strncmp(bytes, "end-", 4)) { bytes += 4; } - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", (void *)NULL); } return TCL_ERROR; @@ -3925,12 +3925,7 @@ rangeerror: Tcl_SetObjResult( interp, Tcl_ObjPrintf("index \"%s\" out of range", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, - "TCL", - "VALUE", - "INDEX" - "OUTOFRANGE", - NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", (void *)NULL); } return TCL_ERROR; } @@ -4626,7 +4621,7 @@ TclReToGlob( invalidGlob: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); - Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); + Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, (void *)NULL); } Tcl_DStringFree(dsPtr); return TCL_ERROR; diff --git a/generic/tclVar.c b/generic/tclVar.c index 31312e1..5bb4db3 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -343,7 +343,7 @@ NotArrayError( Tcl_SetObjResult(interp, Tcl_ObjPrintf("\"%s\" isn't an array", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, (void *)NULL); return TCL_ERROR; } @@ -647,7 +647,7 @@ TclObjLookupVarEx( if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, NOSUCHVAR, -1); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", (void *)NULL); } return NULL; } @@ -673,7 +673,7 @@ TclObjLookupVarEx( TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", - NULL); + (void *)NULL); } return NULL; } @@ -701,7 +701,7 @@ TclObjLookupVarEx( if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, errMsg, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(part1Ptr), NULL); + TclGetString(part1Ptr), (void *)NULL); } return NULL; } @@ -1085,7 +1085,7 @@ TclLookupArrayElement( TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NOSUCHVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); + arrayNamePtr?TclGetString(arrayNamePtr):NULL, (void *)NULL); } return NULL; } @@ -1100,7 +1100,7 @@ TclLookupArrayElement( TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, DANGLINGVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); + arrayNamePtr?TclGetString(arrayNamePtr):NULL, (void *)NULL); } return NULL; } @@ -1111,7 +1111,7 @@ TclLookupArrayElement( TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NEEDARRAY, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); + arrayNamePtr?TclGetString(arrayNamePtr):NULL, (void *)NULL); } return NULL; } @@ -1132,7 +1132,7 @@ TclLookupArrayElement( TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NOSUCHELEMENT, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", - TclGetString(elNamePtr), NULL); + TclGetString(elNamePtr), (void *)NULL); } } } @@ -1453,7 +1453,7 @@ TclPtrGetVarIdx( */ errorReturn: - Tcl_SetErrorCode(interp, "TCL", "READ", "VARNAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "READ", "VARNAME", (void *)NULL); if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); } @@ -1931,11 +1931,11 @@ TclPtrSetVarIdx( if (TclIsVarArrayElement(varPtr)) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", DANGLINGELEMENT, index); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", (void *)NULL); } else { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", DANGLINGVAR, index); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", (void *)NULL); } } goto earlyError; @@ -1948,7 +1948,7 @@ TclPtrSetVarIdx( if (TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISARRAY,index); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (void *)NULL); } goto earlyError; } @@ -2043,7 +2043,7 @@ TclPtrSetVarIdx( cleanup: if (resultPtr == NULL) { - Tcl_SetErrorCode(interp, "TCL", "WRITE", "VARNAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "VARNAME", (void *)NULL); } if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); @@ -2470,7 +2470,7 @@ TclPtrUnsetVarIdx( if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", ((initialArrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); - Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", (void *)NULL); } } @@ -3073,7 +3073,7 @@ ArrayForNRCmd( if (numVars != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have two variable names", -1)); - Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", (void *)NULL); return TCL_ERROR; } @@ -3174,7 +3174,7 @@ ArrayForLoopCallback( if (done == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "array changed during iteration", -1)); - Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL); + Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", (void *)NULL); varPtr->flags |= TCL_LEAVE_ERR_MSG; result = done; } @@ -3989,7 +3989,7 @@ ArraySetCmd( CleanupVar(varPtr, arrayPtr); TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(arrayNameObj), NULL); + TclGetString(arrayNameObj), (void *)NULL); return TCL_ERROR; } @@ -4057,7 +4057,7 @@ ArraySetCmd( if (elemLen & 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "list must have an even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", (void *)NULL); return TCL_ERROR; } if (elemLen == 0) { @@ -4116,7 +4116,7 @@ ArraySetCmd( TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", NEEDARRAY, -1); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (void *)NULL); return TCL_ERROR; } } @@ -4500,7 +4500,7 @@ ObjMakeUpvar( "bad variable name \"%s\": can't create namespace " "variable that refers to procedure variable", TclGetString(myNamePtr))); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", (void *)NULL); return TCL_ERROR; } } @@ -4616,7 +4616,7 @@ TclPtrObjMakeUpvarIdx( "bad variable name \"%s\": can't create a scalar " "variable that looks like an array element", myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", - NULL); + (void *)NULL); return TCL_ERROR; } } @@ -4635,7 +4635,7 @@ TclPtrObjMakeUpvarIdx( if (varPtr == NULL) { TclObjVarErrMsg(interp, myNamePtr, NULL, "create", errMsg, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(myNamePtr), NULL); + TclGetString(myNamePtr), (void *)NULL); return TCL_ERROR; } } @@ -4643,14 +4643,14 @@ TclPtrObjMakeUpvarIdx( if (varPtr == otherPtr) { Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_NewStringObj( "can't upvar from variable to itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", (void *)NULL); return TCL_ERROR; } if (TclIsVarTraced(varPtr)) { Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( "variable \"%s\" has traces: can't use for upvar", myName)); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", (void *)NULL); return TCL_ERROR; } else if (!TclIsVarUndefined(varPtr)) { Var *linkPtr; @@ -4665,7 +4665,7 @@ TclPtrObjMakeUpvarIdx( if (!TclIsVarLink(varPtr)) { Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( "variable \"%s\" already exists", myName)); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", (void *)NULL); return TCL_ERROR; } @@ -4960,7 +4960,7 @@ Tcl_VariableObjCmd( TclObjVarErrMsg(interp, varNamePtr, NULL, "define", ISARRAYELEMENT, -1); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", (void *)NULL); return TCL_ERROR; } @@ -5111,7 +5111,7 @@ Tcl_UpvarObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(levelObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", - TclGetString(levelObj), NULL); + TclGetString(levelObj), (void *)NULL); return TCL_ERROR; } @@ -5202,7 +5202,7 @@ ParseSearchId( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't find search \"%s\"", handle)); } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, (void *)NULL); return NULL; } @@ -5846,7 +5846,7 @@ ObjFindNamespaceVar( if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown variable \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, (void *)NULL); } return (Tcl_Var) varPtr; } @@ -6515,7 +6515,7 @@ ArrayDefaultCmd( /* Array default must exist. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "array has no default value", -1)); - Tcl_SetErrorCode(interp, "TCL", "READ", "ARRAY", "DEFAULT", NULL); + Tcl_SetErrorCode(interp, "TCL", "READ", "ARRAY", "DEFAULT", (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, defaultValueObj); @@ -6545,7 +6545,7 @@ ArrayDefaultCmd( TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(arrayNameObj), NULL); + TclGetString(arrayNameObj), (void *)NULL); return TCL_ERROR; } if (!TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { @@ -6555,7 +6555,7 @@ ArrayDefaultCmd( TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", NEEDARRAY, -1); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (void *)NULL); return TCL_ERROR; } diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 65d39d4..5c9de24 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -16,7 +16,7 @@ * projects. * * Helpful docs: - * https://pkware.cachefly.net/webdocs/APPNOTE/APPNOTE-6.3.9.TXT + * https://pkware.cachefly.net/webdocs/APPNOTE/APPNOTE-6.3.9.TXT * https://libzip.org/specifications/appnote_iz.txt */ @@ -56,7 +56,7 @@ if (interp) { \ Tcl_SetObjResult(interp, Tcl_NewStringObj( \ "out of memory", -1)); \ - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); \ + Tcl_SetErrorCode(interp, "TCL", "MALLOC", (void *)NULL); \ } \ } while (0) #define ZIPFS_POSIX_ERROR(interp,errstr) \ @@ -69,7 +69,7 @@ #define ZIPFS_ERROR_CODE(interp,errcode) \ do { \ if (interp) { \ - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", errcode, NULL); \ + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", errcode, (void *)NULL); \ } \ } while (0) @@ -161,17 +161,10 @@ static const z_crc_t* crc32tab; #define ZIP_COMPMETH_DEFLATED 8 #define ZIP_PASSWORD_END_SIG 0x5a5a4b50 +#define ZIP_CRYPT_HDR_LEN 12 -#define DEFAULT_WRITE_MAX_SIZE (2 * 1024 * 1024) - -/* - * Windows drive letters. - */ - -#ifdef _WIN32 -static const char drvletters[] = - "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; -#endif /* _WIN32 */ +#define ZIP_MAX_FILE_SIZE INT_MAX +#define DEFAULT_WRITE_MAX_SIZE ZIP_MAX_FILE_SIZE /* * Mutex to protect localtime(3) when no reentrant version available. @@ -244,25 +237,39 @@ typedef struct ZipEntry { /* * File channel for file contained in mounted ZIP archive. + * + * Regarding data buffers: + * For READ-ONLY files that are not encrypted and not compressed (zip STORE + * method), ubuf points directly to the mapped zip file data in memory. No + * additional storage is allocated and so ubufToFree is NULL. + * + * In all other combinations of compression and encryption or if channel is + * writable, storage is allocated for the decrypted and/or uncompressed data + * and a pointer to it is stored in ubufToFree and ubuf. When channel is + * closed, ubufToFree is freed if not NULL. ubuf is irrelevant since it may + * or may not point to allocated storage as above. */ typedef struct ZipChannel { ZipFile *zipFilePtr; /* The ZIP file holding this channel */ ZipEntry *zipEntryPtr; /* Pointer back to virtual file */ - size_t maxWrite; /* Maximum size for write */ - size_t numBytes; /* Number of bytes of uncompressed data */ - size_t numRead; /* Position of next byte to be read from the - * channel */ + Tcl_Size maxWrite; /* Maximum size for write */ + Tcl_Size numBytes; /* Number of bytes of uncompressed data */ + Tcl_Size cursor; /* Seek position for next read or write*/ unsigned char *ubuf; /* Pointer to the uncompressed data */ unsigned char *ubufToFree; /* NULL if ubuf points to memory that does not need freeing. Else memory to free (ubuf may point *inside* the block) */ + Tcl_Size ubufSize; /* Size of allocated ubufToFree */ int iscompr; /* True if data is compressed */ int isDirectory; /* Set to 1 if directory, or -1 if root */ int isEncrypted; /* True if data is encrypted */ - int isWriting; /* True if open for writing */ + int mode; /* O_WRITE, O_APPEND, O_TRUNC etc.*/ unsigned long keys[3]; /* Key for decryption */ } ZipChannel; +static inline int ZipChannelWritable(ZipChannel *info) { + return (info->mode & (O_WRONLY | O_RDWR)) != 0; +} /* * Global variables. @@ -319,6 +326,7 @@ static int InitWritableChannel(Tcl_Interp *interp, ZipChannel *info, ZipEntry *z, int trunc); static int ListMountPoints(Tcl_Interp *interp); static int ContainsMountPoint(const char *path, int pathLen); +static void CleanupMount(ZipFile *zf); static void SerializeCentralDirectoryEntry( const unsigned char *start, const unsigned char *end, unsigned char *buf, @@ -332,9 +340,11 @@ static void SerializeLocalEntryHeader( const unsigned char *start, const unsigned char *end, unsigned char *buf, ZipEntry *z, int nameLength, int align); -static int IsCryptHeaderValid(ZipEntry *z, unsigned char cryptHdr[12]); +static int IsCryptHeaderValid(ZipEntry *z, + unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]); static int DecodeCryptHeader(Tcl_Interp *interp, ZipEntry *z, - unsigned long keys[3], unsigned char cryptHdr[12]); + unsigned long keys[3], + unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]); #if !defined(STATIC_BUILD) static int ZipfsAppHookFindTclInit(const char *archive); #endif @@ -364,10 +374,7 @@ static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); static int ZipMapArchive(Tcl_Interp *interp, ZipFile *zf, void *handle); -static void ZipfsExitHandler(void *clientData); -static void ZipfsMountExitHandler(void *clientData); static void ZipfsSetup(void); -static void ZipfsFinalize(void); static int ZipChannelClose(void *instanceData, Tcl_Interp *interp, int flags); static Tcl_DriverGetHandleProc ZipChannelGetFile; @@ -461,7 +468,18 @@ static Tcl_ChannelType ZipChannelType = { */ int TclIsZipfsPath (const char *path) { +#ifdef _WIN32 return strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) ? 0 : ZIPFS_VOLUME_LEN; +#else + int i; + for (i = 0; i < ZIPFS_VOLUME_LEN; ++i) { + if (path[i] != ZIPFS_VOLUME[i] && + (path[i] != '\\' || ZIPFS_VOLUME[i] != '/')) { + return 0; + } + } + return ZIPFS_VOLUME_LEN; +#endif } /* @@ -737,11 +755,11 @@ CountSlashes( *------------------------------------------------------------------------ */ static int IsCryptHeaderValid( - ZipEntry *z, - unsigned char cryptHeader[12] + ZipEntry *z, + unsigned char cryptHeader[ZIP_CRYPT_HDR_LEN] ) { - /* + /* * There are multiple possibilities. The last one or two bytes of the * encryption header should match the last one or two bytes of the * CRC of the file. Or the last byte of the encryption header should @@ -789,7 +807,7 @@ DecodeCryptHeader(Tcl_Interp *interp, ZipEntry *z, unsigned long keys[3],/* Updated on success. Must have been initialized by caller. */ - unsigned char cryptHeader[12]) /* From zip file content */ + unsigned char cryptHeader[ZIP_CRYPT_HDR_LEN]) /* From zip file content */ { int i; int ch; @@ -803,9 +821,9 @@ DecodeCryptHeader(Tcl_Interp *interp, passBuf[i] = '\0'; init_keys(passBuf, keys, crc32tab); memset(passBuf, 0, sizeof(passBuf)); - unsigned char encheader[12]; - memcpy(encheader, cryptHeader, 12); - for (i = 0; i < 12; i++) { + unsigned char encheader[ZIP_CRYPT_HDR_LEN]; + memcpy(encheader, cryptHeader, ZIP_CRYPT_HDR_LEN); + for (i = 0; i < ZIP_CRYPT_HDR_LEN; i++) { ch = cryptHeader[i]; ch ^= decrypt_byte(keys, crc32tab); encheader[i] = ch; @@ -848,7 +866,7 @@ static char * DecodeZipEntryText( const unsigned char *inputBytes, unsigned int inputLength, - Tcl_DString *dstPtr) + Tcl_DString *dstPtr) /* Must have been initialized by caller! */ { Tcl_Encoding encoding; const char *src; @@ -856,7 +874,6 @@ DecodeZipEntryText( int dstLen, srcLen = inputLength, flags; Tcl_EncodingState state; - Tcl_DStringInit(dstPtr); if (inputLength < 1) { return Tcl_DStringValue(dstPtr); } @@ -928,177 +945,170 @@ DecodeZipEntryText( } /* - *------------------------------------------------------------------------- + *------------------------------------------------------------------------ * - * CanonicalPath -- + * NormalizeMountPoint -- * - * This function computes the canonical path from a directory and file - * name components into the specified Tcl_DString. + * Converts the passed path into a normalized zipfs mount point + * of the form //zipfs:/some/path. On Windows any \ path separators + * are converted to /. * - * Results: - * Returns the pointer to the canonical path contained in the specified - * Tcl_DString. + * Mount points with a volume will raise an error unless the volume is + * zipfs root. Thus D:/foo is not a valid mount point. * - * Side effects: - * Modifies the specified Tcl_DString. + * Relative paths and absolute paths without a volume are mapped under + * the zipfs root. * - *------------------------------------------------------------------------- + * The empty string is mapped to the zipfs root. + * + * dsPtr is initialized by the function and must be cleared by caller + * on a successful return. + * + * Results: + * TCL_OK on success with normalized mount path in dsPtr + * TCL_ERROR on fail with error message in interp if not NULL + * + *------------------------------------------------------------------------ */ - -static char * -CanonicalPath( - const char *root, - const char *tail, - Tcl_DString *dsPtr, - int inZipfs) +static int +NormalizeMountPoint(Tcl_Interp *interp, + const char *mountPath, + Tcl_DString *dsPtr) /* Must be initialized by caller! */ { - char *path; - int i, j, c, isUNC = 0, isVfs = 0, n = 0; - int haveZipfsPath = 1; - -#ifdef _WIN32 - if (tail[0] != '\0' && strchr(drvletters, tail[0]) && tail[1] == ':') { - tail += 2; - haveZipfsPath = 0; - } - /* UNC style path */ - if (tail[0] == '\\') { - root = ""; - ++tail; - haveZipfsPath = 0; - } - if (tail[0] == '\\') { - root = "/"; - ++tail; - haveZipfsPath = 0; - } -#endif /* _WIN32 */ + const char *joiner[2]; + char *joinedPath; + Tcl_Obj *unnormalizedObj; + Tcl_Obj *normalizedObj; + const char *normalizedPath; + Tcl_Size normalizedLen; + Tcl_DString dsJoin; - if (haveZipfsPath) { - /* UNC style path */ - if (root && strncmp(root, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) { - isVfs = 1; - } else if (tail && - strncmp(tail, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) { - isVfs = 2; - } - if (isVfs != 1 && (root[0] == '/') && (root[1] == '/')) { - isUNC = 1; - } - } + /* + * Several things need to happen here + * - Absolute paths containing volumes (drive letter or UNC) raise error + * except of course if the volume is zipfs root + * - \ -> / and // -> / conversions (except if UNC which is error) + * - . and .. have to be dealt with + * The first is explicitly checked, the others are dealt with a + * combination file join and normalize. Easier than doing it ourselves + * and not performance sensitive anyways. + */ - if (isVfs != 2) { - if (tail[0] == '/') { - if (isVfs != 1) { - root = ""; - } - ++tail; - isUNC = 0; - } - if (tail[0] == '/') { - if (isVfs != 1) { - root = "/"; - } - ++tail; - isUNC = 1; - } - } - i = strlen(root); - j = strlen(tail); - - switch (isVfs) { - case 1: - if (i > ZIPFS_VOLUME_LEN) { - Tcl_DStringSetLength(dsPtr, i + j + 1); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - path[i++] = '/'; - memcpy(path + i, tail, j); - } else { - Tcl_DStringSetLength(dsPtr, i + j); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - memcpy(path + i, tail, j); - } - break; - case 2: - Tcl_DStringSetLength(dsPtr, j); - path = Tcl_DStringValue(dsPtr); - memcpy(path, tail, j); - break; - default: - if (inZipfs) { - /* pathLen = zipfs vol len + root len + separator + tail len */ - Tcl_DStringInit(dsPtr); - (void) Tcl_DStringAppend(dsPtr, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN); - if (i) { - (void) Tcl_DStringAppend(dsPtr, root, i); - if (root[i-1] != '/') { - Tcl_DStringAppend(dsPtr, "/", 1); - } - } - path = Tcl_DStringAppend(dsPtr, tail, j); - } else { - Tcl_DStringSetLength(dsPtr, i + j + 1); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - path[i++] = '/'; - memcpy(path + i, tail, j); - } - break; - } + joiner[0] = ZIPFS_VOLUME; + joiner[1] = mountPath; + Tcl_DStringInit(&dsJoin); + joinedPath = Tcl_JoinPath(2, joiner, &dsJoin); -#ifdef _WIN32 - for (i = 0; path[i] != '\0'; i++) { - if (path[i] == '\\') { - path[i] = '/'; - } - } -#endif /* _WIN32 */ + /* Now joinedPath has all \ -> / and // -> / (except UNC) converted. */ - if (inZipfs) { - n = ZIPFS_VOLUME_LEN; + if (!strncmp(ZIPFS_VOLUME, joinedPath, ZIPFS_VOLUME_LEN)) { + unnormalizedObj = Tcl_DStringToObj(&dsJoin); } else { - n = 0; - } + if (joinedPath[0] != '/' || joinedPath[1] == '/') { + /* mount path was D:/x, D:x or //unc */ + goto invalidMountPath; + } + unnormalizedObj = Tcl_ObjPrintf(ZIPFS_VOLUME "%s", joinedPath + 1); + } + Tcl_IncrRefCount(unnormalizedObj); + normalizedObj = Tcl_FSGetNormalizedPath(interp, unnormalizedObj); + if (normalizedObj == NULL) { + Tcl_DecrRefCount(unnormalizedObj); + goto errorReturn; + } + Tcl_IncrRefCount(normalizedObj); /* BEFORE DecrRefCount on unnormalizedObj */ + Tcl_DecrRefCount(unnormalizedObj); + + /* normalizedObj owned by Tcl!! Do NOT DecrRef without an IncrRef */ + normalizedPath = Tcl_GetStringFromObj(normalizedObj, &normalizedLen); + Tcl_DStringFree(&dsJoin); + Tcl_DStringAppend(dsPtr, normalizedPath, normalizedLen); + Tcl_DecrRefCount(normalizedObj); + return TCL_OK; - for (i = j = n; (c = path[i]) != '\0'; i++) { - if (c == '/') { - int c2 = path[i + 1]; +invalidMountPath: + if (interp) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Invalid mount path \"%s\"", mountPath)); + ZIPFS_ERROR_CODE(interp, "MOUNT_PATH"); + } - if (c2 == '\0' || c2 == '/') { - continue; - } - if (c2 == '.') { - int c3 = path[i + 2]; +errorReturn: + Tcl_DStringFree(&dsJoin); + return TCL_ERROR; +} - if ((c3 == '/') || (c3 == '\0')) { - i++; - continue; - } - if ((c3 == '.') - && ((path[i + 3] == '/') || (path[i + 3] == '\0'))) { - i += 2; - while ((j > 0) && (path[j - 1] != '/')) { - j--; - } - if (j > isUNC) { - --j; - while ((j > 1 + isUNC) && (path[j - 2] == '/')) { - j--; - } - } - continue; - } - } - } - path[j++] = c; - } - if (j == 0) { - path[j++] = '/'; +/* + *------------------------------------------------------------------------ + * + * MapPathToZipfs -- + * + * Maps a path as stored in a zip archive to its normalized location + * under a given zipfs mount point. Relative paths and Unix style + * absolute paths go directly under the mount point. Volume relative + * paths and absolute paths that have a volume (drive or UNC) are + * stripped of the volume before joining the mount point. + * + * Results: + * Pointer to normalized path. + * + * Side effects: + * Stores mapped path in dsPtr. + * + *------------------------------------------------------------------------ + */ +static char * +MapPathToZipfs(Tcl_Interp *interp, + const char *mountPath, /* Must be fully normalized */ + const char *path, /* Archive content path to map */ + Tcl_DString *dsPtr) /* Must be initialized and cleared + by caller */ +{ + const char *joiner[2]; + char *joinedPath; + Tcl_Obj *unnormalizedObj; + Tcl_Obj *normalizedObj; + const char *normalizedPath; + Tcl_Size normalizedLen; + Tcl_DString dsJoin; + + assert(TclIsZipfsPath(mountPath)); + + joiner[0] = mountPath; + joiner[1] = path; +#ifndef _WIN32 + /* On Unix C:/foo/bat is not treated as absolute by JoinPath so check ourself */ + if (path[0] && path[1] == ':') { + joiner[1] += 2; } - path[j] = 0; - Tcl_DStringSetLength(dsPtr, j); +#endif + Tcl_DStringInit(&dsJoin); + joinedPath = Tcl_JoinPath(2, joiner, &dsJoin); + + if (strncmp(ZIPFS_VOLUME, joinedPath, ZIPFS_VOLUME_LEN)) { + /* path was not relative. Strip off the volume (e.g. UNC) */ + Tcl_Size numParts; + const char **partsPtr; + Tcl_SplitPath(path, &numParts, &partsPtr); + Tcl_DStringFree(&dsJoin); + partsPtr[0] = mountPath; + (void)Tcl_JoinPath(numParts, partsPtr, &dsJoin); + Tcl_Free(partsPtr); + } + unnormalizedObj = Tcl_DStringToObj(&dsJoin); /* Also resets dsJoin */ + Tcl_IncrRefCount(unnormalizedObj); + normalizedObj = Tcl_FSGetNormalizedPath(interp, unnormalizedObj); + if (normalizedObj == NULL) { + /* Should not happen but continue... */ + normalizedObj = unnormalizedObj; + } + Tcl_IncrRefCount(normalizedObj); /* BEFORE DecrRefCount on unnormalizedObj */ + Tcl_DecrRefCount(unnormalizedObj); + + /* normalizedObj owned by Tcl!! Do NOT DecrRef without an IncrRef */ + normalizedPath = Tcl_GetStringFromObj(normalizedObj, &normalizedLen); + Tcl_DStringAppend(dsPtr, normalizedPath, normalizedLen); + Tcl_DecrRefCount(normalizedObj); return Tcl_DStringValue(dsPtr); } @@ -1384,7 +1394,7 @@ ZipFSFindTOC( ZipFile *zf) { size_t i, minoff; - const unsigned char *p, *q; + const unsigned char *eocdPtr; /* End of Central Directory Record */ const unsigned char *start = zf->data; const unsigned char *end = zf->data + zf->length; @@ -1394,18 +1404,18 @@ ZipFSFindTOC( * on the end of executables; digital signatures can also go there. */ - p = zf->data + zf->length - ZIP_CENTRAL_END_LEN; - while (p >= start) { - if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) { - if (ZipReadInt(start, end, p) == ZIP_CENTRAL_END_SIG) { + eocdPtr = zf->data + zf->length - ZIP_CENTRAL_END_LEN; + while (eocdPtr >= start) { + if (*eocdPtr == (ZIP_CENTRAL_END_SIG & 0xFF)) { + if (ZipReadInt(start, end, eocdPtr) == ZIP_CENTRAL_END_SIG) { break; } - p -= ZIP_SIG_LEN; + eocdPtr -= ZIP_SIG_LEN; } else { - --p; + --eocdPtr; } } - if (p < zf->data) { + if (eocdPtr < 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. @@ -1417,16 +1427,24 @@ ZipFSFindTOC( } ZIPFS_ERROR(interp, "archive directory end signature not found"); ZIPFS_ERROR_CODE(interp, "END_SIG"); - goto error; + + error: + ZipFSCloseArchive(interp, zf); + return TCL_ERROR; + } - /* p -> End of Central Directory (EOCD) record at this point */ + /* + * eocdPtr -> End of Central Directory (EOCD) record at this point. + * Note this is not same as "end of Central Directory" :-) as EOCD + * is a record/structure in the ZIP spec terminology + */ /* * How many files in the archive? If that's bogus, we're done here. */ - zf->numFiles = ZipReadShort(start, end, p + ZIP_CENTRAL_ENTS_OFFS); + zf->numFiles = ZipReadShort(start, end, eocdPtr + ZIP_CENTRAL_ENTS_OFFS); if (zf->numFiles == 0) { if (!needZip) { zf->baseOffset = zf->passOffset = zf->length; @@ -1445,9 +1463,9 @@ ZipFSFindTOC( * cdirSize. NOTE: offset into archive does NOT mean offset into * (zf->data) as other data may precede the archive in the file. */ - ptrdiff_t eocdDataOffset = p - zf->data; - unsigned int cdirZipOffset = ZipReadInt(start, end, p + ZIP_CENTRAL_DIRSTART_OFFS); - unsigned int cdirSize = ZipReadInt(start, end, p + ZIP_CENTRAL_DIRSIZE_OFFS); + ptrdiff_t eocdDataOffset = eocdPtr - zf->data; + unsigned int cdirZipOffset = ZipReadInt(start, end, eocdPtr + ZIP_CENTRAL_DIRSTART_OFFS); + unsigned int cdirSize = ZipReadInt(start, end, eocdPtr + ZIP_CENTRAL_DIRSIZE_OFFS); /* * As computed above, @@ -1483,39 +1501,29 @@ ZipFSFindTOC( zf->directoryOffset = cdirZipOffset + zf->baseOffset; zf->directorySize = cdirSize; - const unsigned char *const cdirStart = p - cdirSize; /* Start of CD */ - - /* - * Original pointer based validation replaced by simpler checks above. - * Ensure still holds. The assigments to p, q are only there for use in - * the asserts. May be removed at some future date. - */ - q = zf->data + cdirZipOffset; - p -= cdirSize; - assert(!((p < q) || (p < zf->data) || (p > zf->data + zf->length) || - (q < zf->data) || (q > zf->data + zf->length))); - /* * Read the central directory. */ + const unsigned char *const cdirStart = eocdPtr - cdirSize; /* Start of CD */ + const unsigned char *dirEntry; minoff = zf->length; - for (q = cdirStart, i = 0; i < zf->numFiles; i++) { - if ((q-cdirStart) + ZIP_CENTRAL_HEADER_LEN > (ptrdiff_t)zf->directorySize) { + for (dirEntry = cdirStart, i = 0; i < zf->numFiles; i++) { + if ((dirEntry-cdirStart) + ZIP_CENTRAL_HEADER_LEN > (ptrdiff_t)zf->directorySize) { ZIPFS_ERROR(interp, "truncated directory"); ZIPFS_ERROR_CODE(interp, "TRUNC_DIR"); goto error; } - if (ZipReadInt(start, end, q) != ZIP_CENTRAL_HEADER_SIG) { + if (ZipReadInt(start, end, dirEntry) != ZIP_CENTRAL_HEADER_SIG) { ZIPFS_ERROR(interp, "wrong header signature"); ZIPFS_ERROR_CODE(interp, "HDR_SIG"); goto error; } - int pathlen = ZipReadShort(start, end, q + ZIP_CENTRAL_PATHLEN_OFFS); - int comlen = ZipReadShort(start, end, q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - int extra = ZipReadShort(start, end, q + ZIP_CENTRAL_EXTRALEN_OFFS); - size_t localhdr_off = ZipReadInt(start, end, q + ZIP_CENTRAL_LOCALHDR_OFFS); + int pathlen = ZipReadShort(start, end, dirEntry + ZIP_CENTRAL_PATHLEN_OFFS); + int comlen = ZipReadShort(start, end, dirEntry + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + int extra = ZipReadShort(start, end, dirEntry + ZIP_CENTRAL_EXTRALEN_OFFS); + size_t localhdr_off = ZipReadInt(start, end, dirEntry + ZIP_CENTRAL_LOCALHDR_OFFS); const unsigned char *localP = zf->data + zf->baseOffset + localhdr_off; - if (localP > (p - ZIP_LOCAL_HEADER_LEN) || + if (localP > (cdirStart - ZIP_LOCAL_HEADER_LEN) || ZipReadInt(start, end, localP) != ZIP_LOCAL_HEADER_SIG) { ZIPFS_ERROR(interp, "Failed to find local header"); ZIPFS_ERROR_CODE(interp, "LCL_HDR"); @@ -1524,9 +1532,9 @@ ZipFSFindTOC( if (localhdr_off < minoff) { minoff = localhdr_off; } - q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; + dirEntry += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; } - if ((q-cdirStart) < (ptrdiff_t) zf->directorySize) { + if ((dirEntry-cdirStart) < (ptrdiff_t) zf->directorySize) { /* file count and dir size do not match */ ZIPFS_ERROR(interp, "short file count"); ZIPFS_ERROR_CODE(interp, "FILE_COUNT"); @@ -1538,9 +1546,11 @@ ZipFSFindTOC( /* * If there's also an encoded password, extract that too (but don't decode * yet). + * TODO - is this even part of the ZIP "standard". The idea of storing + * a password with the archive seems absurd, encoded or not. */ - q = zf->data + zf->passOffset; + unsigned char *q = zf->data + zf->passOffset; if ((zf->passOffset >= 6) && (start < q-4) && (ZipReadInt(start, end, q - 4) == ZIP_PASSWORD_END_SIG)) { const unsigned char *passPtr; @@ -1555,10 +1565,6 @@ ZipFSFindTOC( } return TCL_OK; - - error: - ZipFSCloseArchive(interp, zf); - return TCL_ERROR; } /* @@ -1663,9 +1669,15 @@ ZipFSOpenArchive( ZIPFS_POSIX_ERROR(interp, "file read error"); goto error; } - Tcl_Close(interp, zf->chan); - zf->chan = NULL; } + /* + * Close the Tcl channel. If the file was mapped, the mapping is + * unaffected. It is important to close the channel otherwise there is a + * potential chicken and egg issue at finalization time as the channels + * are closed before the file systems are dismounted. + */ + Tcl_Close(interp, zf->chan); + zf->chan = NULL; return ZipFSFindTOC(interp, needZip, zf); /* @@ -1714,6 +1726,11 @@ ZipMapArchive( ZIPFS_POSIX_ERROR(interp, "truncated file"); return TCL_ERROR; } + if (zf->length > TCL_SIZE_MAX) { + Tcl_SetErrno(EFBIG); + ZIPFS_POSIX_ERROR(interp, "zip archive too big"); + return TCL_ERROR; + } /* * Map the file. @@ -1812,7 +1829,7 @@ static int ZipFSCatalogFilesystem( Tcl_Interp *interp, /* Current interpreter. NULLable. */ ZipFile *zf, /* Temporary buffer hold archive descriptors */ - const char *mountPoint, /* Mount point path. */ + const char *mountPoint, /* Mount point path. Must be fully normalized */ const char *passwd, /* Password for opening the ZIP, or NULL if * the ZIP is unprotected. */ const char *zipname) /* Path to ZIP file to build a catalog of. */ @@ -1822,9 +1839,13 @@ ZipFSCatalogFilesystem( ZipFile *zf0; ZipEntry *z; Tcl_HashEntry *hPtr; - Tcl_DString ds, dsm, fpBuf; + Tcl_DString ds, fpBuf; unsigned char *q; + assert(TclIsZipfsPath(mountPoint)); /* Caller should have normalized */ + + Tcl_DStringInit(&ds); + /* * Basic verification of the password for sanity. */ @@ -1854,17 +1875,6 @@ ZipFSCatalogFilesystem( WriteLock(); - /* - * Mount point sometimes is a relative or otherwise denormalized path. - * But an absolute name is needed as mount point here. - */ - - Tcl_DStringInit(&ds); - Tcl_DStringInit(&dsm); - if (strcmp(mountPoint, "/") == 0) { - mountPoint = ""; - } - mountPoint = CanonicalPath("", mountPoint, &dsm, 1); hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew); if (!isNew) { if (interp) { @@ -1875,17 +1885,16 @@ ZipFSCatalogFilesystem( } Unlock(); ZipFSCloseArchive(interp, zf); + Tcl_DStringFree(&ds); Tcl_Free(zf); return TCL_ERROR; } - Unlock(); /* * 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); @@ -1903,6 +1912,7 @@ ZipFSCatalogFilesystem( } zf->passBuf[k] = '\0'; } + /* TODO - is this test necessary? When will mountPoint[0] be \0 ? */ if (mountPoint[0] != '\0') { hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mountPoint, &isNew); if (isNew) { @@ -1919,6 +1929,9 @@ ZipFSCatalogFilesystem( if (!strcmp(z->name, ZIPFS_VOLUME)) { z->flags |= ZE_F_VOLUME; /* Mark as root volume */ } + Tcl_Time t; + Tcl_GetTime(&t); + z->timestamp = t.sec; z->next = zf->entries; zf->entries = z; } @@ -1936,6 +1949,7 @@ ZipFSCatalogFilesystem( pathlen = ZipReadShort(start, end, q + ZIP_CENTRAL_PATHLEN_OFFS); comlen = ZipReadShort(start, end, q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); extra = ZipReadShort(start, end, q + ZIP_CENTRAL_EXTRALEN_OFFS); + Tcl_DStringSetLength(&ds, 0); path = DecodeZipEntryText(q + ZIP_CENTRAL_HEADER_LEN, pathlen, &ds); if ((pathlen > 0) && (path[pathlen - 1] == '/')) { Tcl_DStringSetLength(&ds, pathlen - 1); @@ -1999,7 +2013,7 @@ ZipFSCatalogFilesystem( } Tcl_DStringSetLength(&fpBuf, 0); - fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1); + fullpath = MapPathToZipfs(interp, mountPoint, path, &fpBuf); z = AllocateZipEntry(); z->depth = CountSlashes(fullpath); assert(z->depth >= ZIPFS_ROOTDIR_DEPTH); @@ -2007,7 +2021,7 @@ ZipFSCatalogFilesystem( z->isDirectory = isdir; z->isEncrypted = (ZipReadShort(start, end, lq + ZIP_LOCAL_FLAGS_OFFS) & 1) - && (nbcompr > 12); + && (nbcompr > ZIP_CRYPT_HDR_LEN); z->offset = offs; if (gq) { z->crc32 = ZipReadInt(start, end, gq + ZIP_CENTRAL_CRC32_OFFS); @@ -2090,10 +2104,10 @@ ZipFSCatalogFilesystem( nextent: q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; } + Unlock(); Tcl_DStringFree(&fpBuf); Tcl_DStringFree(&ds); Tcl_FSMountsChanged(NULL); - Unlock(); return TCL_OK; } @@ -2133,7 +2147,6 @@ ZipfsSetup(void) Tcl_Alloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1); strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING); ZipFS.initialized = 1; - Tcl_CreateExitHandler(ZipfsExitHandler, NULL); } /* @@ -2187,6 +2200,42 @@ ListMountPoints( } /* + *------------------------------------------------------------------------ + * + * CleanupMount -- + * + * Releases all resources associated with a mounted archive. There + * must not be any open files in the archive. + * + * Caller MUST be holding WriteLock() before calling this function. + * + * Results: + * None. + * + * Side effects: + * Memory associated with the mounted archive is deallocated. + *------------------------------------------------------------------------ + */ +static void +CleanupMount(ZipFile *zf) /* Mount point */ +{ + ZipEntry *z, *znext; + Tcl_HashEntry *hPtr; + for (z = zf->entries; z; z = znext) { + znext = z->next; + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + } + if (z->data) { + Tcl_Free(z->data); + } + Tcl_Free(z); + } + zf->entries = NULL; +} + +/* *------------------------------------------------------------------------- * * DescribeMounted -- @@ -2242,13 +2291,13 @@ DescribeMounted( int TclZipfs_Mount( Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *zipname, /* Path to ZIP file to mount; should be - * normalized. */ + const char *zipname, /* Path to ZIP file to mount */ const char *mountPoint, /* Mount point path. */ const char *passwd) /* Password for opening the ZIP, or NULL if * the ZIP is unprotected. */ { ZipFile *zf; + int ret; ReadLock(); if (!ZipFS.initialized) { @@ -2259,45 +2308,78 @@ TclZipfs_Mount( * No mount point, so list all mount points and what is mounted there. */ - if (!mountPoint) { - int ret = ListMountPoints(interp); + if (mountPoint == NULL) { + ret = ListMountPoints(interp); Unlock(); return ret; } - /* - * Mount point but no file, so describe what is mounted at that mount - * point. - */ + Tcl_DString ds; + Tcl_DStringInit(&ds); + ret = NormalizeMountPoint(interp, mountPoint, &ds); + if (ret != TCL_OK) { + Unlock(); + return ret; + } + mountPoint = Tcl_DStringValue(&ds); if (!zipname) { - DescribeMounted(interp, mountPoint); + /* + * Mount point but no file, so describe what is mounted at that mount + * point. + */ + + ret = DescribeMounted(interp, mountPoint); Unlock(); - return TCL_OK; - } - Unlock(); + } else { + /* Have both a mount point and a file (name) to mount there. */ - /* - * Have both a mount point and a file (name) to mount there. - */ + Tcl_Obj *zipPathObj; + Tcl_Obj *normZipPathObj; - if (passwd && IsPasswordValid(interp, passwd, strlen(passwd)) != TCL_OK) { - return TCL_ERROR; - } - zf = AllocateZipFile(interp, strlen(mountPoint)); - if (!zf) { - return TCL_ERROR; - } - if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) { - Tcl_Free(zf); - return TCL_ERROR; - } - if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname) - != TCL_OK) { - /* zf would have been freed! */ - return TCL_ERROR; + Unlock(); + + zipPathObj = Tcl_NewStringObj(zipname, -1); + Tcl_IncrRefCount(zipPathObj); + normZipPathObj = Tcl_FSGetNormalizedPath(interp, zipPathObj); + if (normZipPathObj == NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("could not normalize zip filename \"%s\"", zipname)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NORMALIZE", (void *)NULL); + ret = TCL_ERROR; + } else { + Tcl_IncrRefCount(normZipPathObj); + const char *normPath = Tcl_GetString(normZipPathObj); + if (passwd == NULL || + (ret = IsPasswordValid(interp, passwd, strlen(passwd))) == + TCL_OK) { + zf = AllocateZipFile(interp, strlen(mountPoint)); + if (zf == NULL) { + ret = TCL_ERROR; + } + else { + ret = ZipFSOpenArchive(interp, normPath, 1, zf); + if (ret != TCL_OK) { + Tcl_Free(zf); + } + else { + ret = ZipFSCatalogFilesystem( + interp, zf, mountPoint, passwd, normPath); + /* Note zf is already freed on error! */ + } + } + } + Tcl_DecrRefCount(normZipPathObj); + if (ret == TCL_OK && interp) { + Tcl_DStringResult(interp, &ds); + } + } + Tcl_DecrRefCount(zipPathObj); } - return TCL_OK; + + Tcl_DStringFree(&ds); + return ret; } /* @@ -2306,7 +2388,7 @@ TclZipfs_Mount( * TclZipfs_MountBuffer -- * * This procedure is invoked to mount a given ZIP archive file on a given - * mountpoint with optional ZIP password. + * mountpoint. * * Results: * A standard Tcl result. @@ -2327,73 +2409,80 @@ TclZipfs_MountBuffer( int copy) { ZipFile *zf; + int ret; + if (mountPoint == NULL || data == NULL) { + ZIPFS_ERROR(interp, "mount point and/or data are null"); + return TCL_ERROR; + } + + /* TODO - how come a *read* lock suffices for initialzing ? */ ReadLock(); if (!ZipFS.initialized) { ZipfsSetup(); } - /* - * No mount point, so list all mount points and what is mounted there. - */ - - if (!mountPoint) { - int ret = ListMountPoints(interp); + Tcl_DString ds; + Tcl_DStringInit(&ds); + ret = NormalizeMountPoint(interp, mountPoint, &ds); + if (ret != TCL_OK) { Unlock(); return ret; } + mountPoint = Tcl_DStringValue(&ds); - /* - * Mount point but no data, so describe what is mounted at that mount - * point. - */ - - if (!data) { - DescribeMounted(interp, mountPoint); - Unlock(); - return TCL_OK; - } Unlock(); /* * Have both a mount point and data to mount there. * What's the magic about 64 * 1024 * 1024 ? */ + ret = TCL_ERROR; if ((datalen <= ZIP_CENTRAL_END_LEN) || (datalen - ZIP_CENTRAL_END_LEN) > (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) { ZIPFS_ERROR(interp, "illegal file size"); ZIPFS_ERROR_CODE(interp, "FILE_SIZE"); - return TCL_ERROR; + goto done; } - zf = AllocateZipFile(interp, strlen(mountPoint)); - if (!zf) { - return TCL_ERROR; + if (zf == NULL) { + goto done; } zf->isMemBuffer = 1; zf->length = datalen; + if (copy) { - zf->data = (unsigned char *) Tcl_AttemptAlloc(datalen); - if (!zf->data) { + zf->data = (unsigned char *)Tcl_AttemptAlloc(datalen); + if (zf->data == NULL) { ZipFSCloseArchive(interp, zf); Tcl_Free(zf); ZIPFS_MEM_ERROR(interp); - return TCL_ERROR; + goto done; } memcpy(zf->data, data, datalen); zf->ptrToFree = zf->data; - } else { - zf->data = (unsigned char *) data; + } + else { + zf->data = (unsigned char *)data; zf->ptrToFree = NULL; } - if (ZipFSFindTOC(interp, 1, zf) != TCL_OK) { + ret = ZipFSFindTOC(interp, 1, zf); + if (ret != TCL_OK) { Tcl_Free(zf); - return TCL_ERROR; } - /* Note ZipFSCatalogFilesystem will free zf on error */ - return ZipFSCatalogFilesystem( - interp, zf, mountPoint, NULL, "Memory Buffer"); + else { + /* Note ZipFSCatalogFilesystem will free zf on error */ + ret = ZipFSCatalogFilesystem( + interp, zf, mountPoint, NULL, "Memory Buffer"); + } + if (ret == TCL_OK && interp) { + Tcl_DStringResult(interp, &ds); + } + +done: + Tcl_DStringFree(&ds); + return ret; } /* @@ -2418,11 +2507,12 @@ TclZipfs_Unmount( const char *mountPoint) /* Mount point path. */ { ZipFile *zf; - ZipEntry *z, *znext; Tcl_HashEntry *hPtr; Tcl_DString dsm; int ret = TCL_OK, unmounted = 0; + Tcl_DStringInit(&dsm); + WriteLock(); if (!ZipFS.initialized) { goto done; @@ -2433,8 +2523,10 @@ TclZipfs_Unmount( * But an absolute name is needed as mount point here. */ - Tcl_DStringInit(&dsm); - mountPoint = CanonicalPath("", mountPoint, &dsm, 1); + if (NormalizeMountPoint(interp, mountPoint, &dsm) != TCL_OK) { + goto done; + } + mountPoint = Tcl_DStringValue(&dsm); hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); /* don't report no-such-mount as an error */ @@ -2456,24 +2548,15 @@ TclZipfs_Unmount( * still cleaning things up. */ - for (z = zf->entries; z; z = znext) { - znext = z->next; - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - } - if (z->data) { - Tcl_Free(z->data); - } - Tcl_Free(z); - } + CleanupMount(zf); ZipFSCloseArchive(interp, zf); - Tcl_DeleteExitHandler(ZipfsMountExitHandler, zf); + Tcl_Free(zf); unmounted = 1; done: Unlock(); + Tcl_DStringFree(&dsm); if (unmounted) { Tcl_FSMountsChanged(NULL); } @@ -2504,7 +2587,6 @@ ZipFSMountObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { const char *mountPoint = NULL, *zipFile = NULL, *password = NULL; - Tcl_Obj *zipFileObj = NULL; int result; if (objc > 4) { @@ -2521,16 +2603,7 @@ ZipFSMountObjCmd( mountPoint = Tcl_GetString(objv[1]); } else { /* 2 < objc < 4 */ - zipFileObj = Tcl_FSGetNormalizedPath(interp, objv[1]); - 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); + zipFile = Tcl_GetString(objv[1]); mountPoint = Tcl_GetString(objv[2]); if (objc > 3) { password = Tcl_GetString(objv[3]); @@ -2539,9 +2612,6 @@ ZipFSMountObjCmd( } result = TclZipfs_Mount(interp, zipFile, mountPoint, password); - if (zipFileObj != NULL) { - Tcl_DecrRefCount(zipFileObj); - } return result; } @@ -2568,32 +2638,16 @@ ZipFSMountBufferObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *mountPoint; /* Mount point path. */ - unsigned char *data; + const char *mountPoint = NULL; /* Mount point path. */ + unsigned char *data = NULL; Tcl_Size length; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?data? ?mountpoint?"); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "data mountpoint"); return TCL_ERROR; } - if (objc < 2) { - int ret; - - ReadLock(); - ret = ListMountPoints(interp); - Unlock(); - return ret; - } - - if (objc < 3) { - ReadLock(); - DescribeMounted(interp, TclGetString(objv[1])); - Unlock(); - return TCL_OK; - } - data = Tcl_GetBytesFromObj(interp, objv[1], &length); - mountPoint = TclGetString(objv[2]); + mountPoint = Tcl_GetString(objv[2]); if (data == NULL) { return TCL_ERROR; } @@ -2953,30 +3007,30 @@ ZipAddFile( if (passwd) { int i, ch, tmp; - unsigned char kvbuf[24]; + unsigned char kvbuf[2*ZIP_CRYPT_HDR_LEN]; init_keys(passwd, keys, crc32tab); - for (i = 0; i < 12 - 2; i++) { + for (i = 0; i < ZIP_CRYPT_HDR_LEN - 2; i++) { if (RandomChar(interp, i, &ch) != TCL_OK) { Tcl_Close(interp, in); return TCL_ERROR; } - kvbuf[i + 12] = UCHAR(zencode(keys, crc32tab, ch, tmp)); + kvbuf[i + ZIP_CRYPT_HDR_LEN] = UCHAR(zencode(keys, crc32tab, ch, tmp)); } Tcl_ResetResult(interp); init_keys(passwd, keys, crc32tab); - for (i = 0; i < 12 - 2; i++) { - kvbuf[i] = UCHAR(zencode(keys, crc32tab, kvbuf[i + 12], tmp)); + for (i = 0; i < ZIP_CRYPT_HDR_LEN - 2; i++) { + kvbuf[i] = UCHAR(zencode(keys, crc32tab, kvbuf[i + ZIP_CRYPT_HDR_LEN], tmp)); } kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 16, tmp)); kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 24, tmp)); - len = Tcl_Write(out, (char *) kvbuf, 12); - memset(kvbuf, 0, 24); - if (len != 12) { + len = Tcl_Write(out, (char *) kvbuf, ZIP_CRYPT_HDR_LEN); + memset(kvbuf, 0, sizeof(kvbuf)); + if (len != ZIP_CRYPT_HDR_LEN) { goto writeErrorWithChannelOpen; } memcpy(keys0, keys, sizeof(keys0)); - nbytecompr += 12; + nbytecompr += ZIP_CRYPT_HDR_LEN; } /* @@ -3068,7 +3122,7 @@ ZipAddFile( Tcl_DStringFree(&zpathDs); return TCL_ERROR; } - nbytecompr = (passwd ? 12 : 0); + nbytecompr = (passwd ? ZIP_CRYPT_HDR_LEN : 0); while (1) { len = Tcl_Read(in, buf, bufsize); if (len < 0) { @@ -3905,34 +3959,30 @@ ZipFSCanonicalObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - char *mntpoint = NULL; - char *filename = NULL; - char *result; - Tcl_DString dPath; + const char *mntPoint = NULL; + Tcl_DString dsPath, dsMount; - if (objc < 2 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? filename ?inZipfs?"); + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? filename"); return TCL_ERROR; } - Tcl_DStringInit(&dPath); + + Tcl_DStringInit(&dsPath); + Tcl_DStringInit(&dsMount); + if (objc == 2) { - filename = TclGetString(objv[1]); - result = CanonicalPath("", filename, &dPath, 1); - } else if (objc == 3) { - mntpoint = TclGetString(objv[1]); - filename = TclGetString(objv[2]); - result = CanonicalPath(mntpoint, filename, &dPath, 1); + mntPoint = ZIPFS_VOLUME; } else { - int zipfs = 0; - - if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) { + if (NormalizeMountPoint(interp, Tcl_GetString(objv[1]), &dsMount) != TCL_OK) { return TCL_ERROR; } - mntpoint = TclGetString(objv[1]); - filename = TclGetString(objv[2]); - result = CanonicalPath(mntpoint, filename, &dPath, zipfs); + mntPoint = Tcl_DStringValue(&dsMount); } - Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); + (void)MapPathToZipfs(interp, + mntPoint, + Tcl_GetString(objv[objc - 1]), + &dsPath); + Tcl_SetObjResult(interp, Tcl_DStringToObj(&dsPath)); return TCL_OK; } @@ -4313,12 +4363,10 @@ ZipChannelClose( info->isEncrypted = 0; memset(info->keys, 0, sizeof(info->keys)); } - if (info->isWriting) { + WriteLock(); + if (ZipChannelWritable(info)) { /* * Copy channel data back into original file in archive. - * TODO - there seems to be no locking here to protect access from - * multiple threads. The channel (info) may be thread specific (?) - * but the ZipEntry is not afaict */ ZipEntry *z = info->zipEntryPtr; assert(info->ubufToFree && info->ubuf); @@ -4332,12 +4380,13 @@ ZipChannelClose( } info->ubufToFree = NULL; /* Now newdata! */ info->ubuf = NULL; + info->ubufSize = 0; /* Replace old content */ if (z->data) { Tcl_Free(z->data); } - z->data = newdata; /* May be NULL */ + z->data = newdata; /* May be NULL when ubufToFree was NULL */ z->numBytes = z->numCompressedBytes = info->numBytes; assert(z->data || z->numBytes == 0); z->compressMethod = ZIP_COMPMETH_STORED; @@ -4347,7 +4396,6 @@ ZipChannelClose( z->offset = 0; z->crc32 = 0; } - WriteLock(); info->zipFilePtr->numOpen--; Unlock(); if (info->ubufToFree) { @@ -4355,6 +4403,7 @@ ZipChannelClose( Tcl_Free(info->ubufToFree); info->ubuf = NULL; info->ubufToFree = NULL; + info->ubufSize = 0; } Tcl_Free(info); return TCL_OK; @@ -4384,7 +4433,7 @@ ZipChannelRead( int *errloc) { ZipChannel *info = (ZipChannel *) instanceData; - unsigned long nextpos; + Tcl_Size nextpos; if (info->isDirectory < 0) { /* @@ -4392,16 +4441,16 @@ ZipChannelRead( * data in front of ZIP, i.e. the executable itself. */ - nextpos = info->numRead + toRead; - if (nextpos > info->zipFilePtr->baseOffset) { - toRead = info->zipFilePtr->baseOffset - info->numRead; + nextpos = info->cursor + toRead; + if ((size_t)nextpos > info->zipFilePtr->baseOffset) { + toRead = info->zipFilePtr->baseOffset - info->cursor; nextpos = info->zipFilePtr->baseOffset; } if (toRead == 0) { return 0; } memcpy(buf, info->zipFilePtr->data, toRead); - info->numRead = nextpos; + info->cursor = nextpos; *errloc = 0; return toRead; } @@ -4409,9 +4458,9 @@ ZipChannelRead( *errloc = EISDIR; return -1; } - nextpos = info->numRead + toRead; + nextpos = info->cursor + toRead; if (nextpos > info->numBytes) { - toRead = info->numBytes - info->numRead; + toRead = info->numBytes - info->cursor; nextpos = info->numBytes; } if (toRead == 0) { @@ -4419,16 +4468,20 @@ ZipChannelRead( } if (info->isEncrypted) { int i; - + /* + * TODO - when is this code ever exercised? Cannot reach it from + * tests. In particular, decryption is always done at channel open + * to allow for seeks and random reads. + */ for (i = 0; i < toRead; i++) { - int ch = info->ubuf[i + info->numRead]; + int ch = info->ubuf[i + info->cursor]; buf[i] = zdecode(info->keys, crc32tab, ch); } } else { - memcpy(buf, info->ubuf + info->numRead, toRead); + memcpy(buf, info->ubuf + info->cursor, toRead); } - info->numRead = nextpos; + info->cursor = nextpos; *errloc = 0; return toRead; } @@ -4459,21 +4512,57 @@ ZipChannelWrite( ZipChannel *info = (ZipChannel *) instanceData; unsigned long nextpos; - if (toWrite == 0 || !info->isWriting) { + if (!ZipChannelWritable(info)) { *errloc = EINVAL; return -1; } - assert(info->maxWrite >= info->numRead); - if (toWrite > (int) (info->maxWrite - info->numRead)) { + + assert(info->ubuf == info->ubufToFree); + assert(info->ubufToFree && info->ubufSize > 0); + assert(info->ubufSize <= info->maxWrite); + assert(info->numBytes <= info->ubufSize); + assert(info->cursor <= info->numBytes); + + if (toWrite == 0) { + *errloc = 0; + return 0; + } + + if (info->mode & O_APPEND) { + info->cursor = info->numBytes; + } + + if (toWrite > (info->maxWrite - info->cursor)) { + /* File would grow beyond max size permitted */ /* Don't do partial writes in error case. Or should we? */ *errloc = EFBIG; return -1; } - nextpos = info->numRead + toWrite; - memcpy(info->ubuf + info->numRead, buf, toWrite); - info->numRead = nextpos; - if (info->numRead > info->numBytes) { - info->numBytes = info->numRead; + + if (toWrite > (info->ubufSize - info->cursor)) { + /* grow the buffer. We have already checked will not exceed maxWrite */ + Tcl_Size needed = info->cursor + toWrite; + /* Tack on a bit for future growth. */ + if (needed < (info->maxWrite - needed/2)) { + needed += needed / 2; + } else { + needed = info->maxWrite; + } + unsigned char *newBuf = + (unsigned char *)Tcl_AttemptRealloc(info->ubufToFree, needed); + if (newBuf == NULL) { + *errloc = ENOMEM; + return -1; + } + info->ubufToFree = newBuf; + info->ubuf = info->ubufToFree; + info->ubufSize = needed; + } + nextpos = info->cursor + toWrite; + memcpy(info->ubuf + info->cursor, buf, toWrite); + info->cursor = nextpos; + if (info->cursor > info->numBytes) { + info->numBytes = info->cursor; } *errloc = 0; return toWrite; @@ -4503,9 +4592,9 @@ ZipChannelWideSeek( int *errloc) { ZipChannel *info = (ZipChannel *) instanceData; - size_t end; + Tcl_Size end; - if (!info->isWriting && (info->isDirectory < 0)) { + if (!ZipChannelWritable(info) && (info->isDirectory < 0)) { /* * Special case: when executable combined with ZIP archive file, seek * within front of ZIP, i.e. the executable itself. @@ -4519,7 +4608,7 @@ ZipChannelWideSeek( } switch (mode) { case SEEK_CUR: - offset += info->numRead; + offset += info->cursor; break; case SEEK_END: offset += end; @@ -4530,24 +4619,24 @@ ZipChannelWideSeek( *errloc = EINVAL; return -1; } - if (offset < 0) { + if (offset < 0 || offset > TCL_SIZE_MAX) { *errloc = EINVAL; return -1; } - if (info->isWriting) { - if ((size_t) offset > info->maxWrite) { + if (ZipChannelWritable(info)) { + if (offset > info->maxWrite) { *errloc = EINVAL; return -1; } - if ((size_t) offset > info->numBytes) { + if (offset > info->numBytes) { info->numBytes = offset; } - } else if ((size_t) offset > end) { + } else if (offset > end) { *errloc = EINVAL; return -1; } - info->numRead = (size_t) offset; - return info->numRead; + info->cursor = (Tcl_Size) offset; + return info->cursor; } /* @@ -4633,16 +4722,28 @@ ZipChannelOpen( /* Check for unsupported modes. */ - if ((mode & O_APPEND) || ((ZipFS.wrmax <= 0) && wr)) { + if ((ZipFS.wrmax <= 0) && wr) { Tcl_SetErrno(EACCES); if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s not supported: %s", - mode & O_APPEND ? "append mode" : "write access", - Tcl_PosixError(interp))); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("writes not permitted: %s", + Tcl_PosixError(interp))); + } + return NULL; + } + + if ((mode & (O_APPEND|O_TRUNC)) && !wr) { + Tcl_SetErrno(EINVAL); + if (interp) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Invalid flags 0x%x. O_APPEND and " + "O_TRUNC require write access: %s", + mode, + Tcl_PosixError(interp))); } return NULL; } + /* * Is the file there? */ @@ -4650,11 +4751,13 @@ ZipChannelOpen( WriteLock(); z = ZipFSLookup(filename); if (!z) { - Tcl_SetErrno(ENOENT); + Tcl_SetErrno(wr ? ENOTSUP : ENOENT); if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file not found \"%s\": %s", filename, - Tcl_PosixError(interp))); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("file \"%s\" not %s: %s", + filename, + wr ? "created" : "found", + Tcl_PosixError(interp))); } goto error; } @@ -4667,9 +4770,7 @@ ZipChannelOpen( goto error; } - /* - * Do we support opening the file that way? - */ + /* Do we support opening the file that way? */ if (wr && z->isDirectory) { Tcl_SetErrno(EISDIR); @@ -4701,7 +4802,7 @@ ZipChannelOpen( } if (z->isEncrypted) { - if (z->numCompressedBytes < 12) { + if (z->numCompressedBytes < ZIP_CRYPT_HDR_LEN) { ZIPFS_ERROR(interp, "decryption failed: truncated decryption header"); ZIPFS_ERROR_CODE(interp, "DECRYPT"); @@ -4723,7 +4824,7 @@ ZipChannelOpen( if (wr) { /* Set up a writable channel. */ - if (InitWritableChannel(interp, info, z, mode & O_TRUNC) == TCL_ERROR) { + if (InitWritableChannel(interp, info, z, mode) == TCL_ERROR) { Tcl_Free(info); goto error; } @@ -4733,6 +4834,7 @@ ZipChannelOpen( info->numBytes = z->numBytes; info->ubuf = z->data; info->ubufToFree = NULL; /* Not dynamically allocated */ + info->ubufSize = 0; } else { /* * Set up a readable channel. @@ -4758,6 +4860,7 @@ ZipChannelOpen( ZIPFS_ERROR_CODE(interp, "CRC_FAILED"); if (info->ubufToFree) { Tcl_Free(info->ubufToFree); + info->ubufSize = 0; } Tcl_Free(info); goto error; @@ -4804,7 +4907,7 @@ InitWritableChannel( 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 mode) /* O_APPEND, O_TRUNC */ { int i, ch; unsigned char *cbuf = NULL; @@ -4813,28 +4916,26 @@ InitWritableChannel( * Set up a writable channel. */ - info->isWriting = 1; + info->mode = mode; info->maxWrite = ZipFS.wrmax; - info->ubufToFree = - (unsigned char *)Tcl_AttemptAlloc(info->maxWrite ? info->maxWrite : 1); + info->ubufSize = z->numBytes ? z->numBytes : 1; + info->ubufToFree = (unsigned char *)Tcl_AttemptAlloc(info->ubufSize); info->ubuf = info->ubufToFree; - if (!info->ubuf) { + if (info->ubufToFree == NULL) { goto memoryError; } - /* TODO - why is the memset necessary? Not cheap for default maxWrite. */ - memset(info->ubuf, 0, info->maxWrite); if (z->isEncrypted) { - assert(z->numCompressedBytes >= 12); /* caller should have checked*/ + assert(z->numCompressedBytes >= ZIP_CRYPT_HDR_LEN); /* caller should have checked*/ if (DecodeCryptHeader( interp, z, info->keys, z->zipFilePtr->data + z->offset) != TCL_OK) { goto error_cleanup; } } - - if (trunc) { + + if (mode & O_TRUNC) { /* * Truncate; nothing there. */ @@ -4845,9 +4946,7 @@ InitWritableChannel( /* * Already got uncompressed data. */ - if (z->numBytes > (int) info->maxWrite) - goto tooBigError; - + assert(info->ubufSize >= z->numBytes); memcpy(info->ubuf, z->data, z->numBytes); info->numBytes = z->numBytes; } else { @@ -4858,7 +4957,7 @@ InitWritableChannel( unsigned char *zbuf = z->zipFilePtr->data + z->offset; if (z->isEncrypted) { - zbuf += 12; + zbuf += ZIP_CRYPT_HDR_LEN; } if (z->compressMethod == ZIP_COMPMETH_DEFLATED) { @@ -4873,10 +4972,10 @@ InitWritableChannel( if (z->isEncrypted) { unsigned int j; - /* Min length 12 for keys should already been checked. */ - assert(stream.avail_in >= 12); + /* Min length ZIP_CRYPT_HDR_LEN for keys should already been checked. */ + assert(stream.avail_in >= ZIP_CRYPT_HDR_LEN); - stream.avail_in -= 12; + stream.avail_in -= ZIP_CRYPT_HDR_LEN; cbuf = (unsigned char *) Tcl_AttemptAlloc(stream.avail_in ? stream.avail_in : 1); if (!cbuf) { goto memoryError; @@ -4890,7 +4989,7 @@ InitWritableChannel( stream.next_in = zbuf; } stream.next_out = info->ubuf; - stream.avail_out = info->maxWrite; + stream.avail_out = info->ubufSize; if (inflateInit2(&stream, -15) != Z_OK) { goto corruptionError; } @@ -4911,10 +5010,11 @@ InitWritableChannel( /* * Need to decrypt some otherwise-simple stored data. */ - if (z->numCompressedBytes <= 12 || - (z->numCompressedBytes - 12) != z->numBytes) + if (z->numCompressedBytes <= ZIP_CRYPT_HDR_LEN || + (z->numCompressedBytes - ZIP_CRYPT_HDR_LEN) != z->numBytes) goto corruptionError; - int len = z->numCompressedBytes - 12; + int len = z->numCompressedBytes - ZIP_CRYPT_HDR_LEN; + assert(len <= info->ubufSize); for (i = 0; i < len; i++) { ch = zbuf[i]; info->ubuf[i] = zdecode(info->keys, crc32tab, ch); @@ -4925,24 +5025,22 @@ InitWritableChannel( /* * Simple stored data. Copy into our working buffer. */ + assert(info->ubufSize >= z->numBytes); memcpy(info->ubuf, zbuf, z->numBytes); info->numBytes = z->numBytes; } memset(info->keys, 0, sizeof(info->keys)); } + if (mode & O_APPEND) { + info->cursor = info->numBytes; + } - assert(info->numBytes == 0 || (int) info->numBytes == z->numBytes); return TCL_OK; memoryError: ZIPFS_MEM_ERROR(interp); goto error_cleanup; - tooBigError: - Tcl_SetErrno(EFBIG); - ZIPFS_POSIX_ERROR(interp, "file size exceeds max writable"); - goto error_cleanup; - corruptionError: if (cbuf) { memset(info->keys, 0, sizeof(info->keys)); @@ -4956,6 +5054,7 @@ InitWritableChannel( Tcl_Free(info->ubufToFree); info->ubufToFree = NULL; info->ubuf = NULL; + info->ubufSize = 0; } return TCL_ERROR; } @@ -4993,19 +5092,21 @@ InitReadableChannel( info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED); info->ubuf = z->zipFilePtr->data + z->offset; info->ubufToFree = NULL; /* ubuf memory not allocated */ + info->ubufSize = 0; info->isDirectory = z->isDirectory; info->isEncrypted = z->isEncrypted; + info->mode = O_RDONLY; /* Caller must validate - bug [6ed3447a7e] */ assert(z->numBytes >= 0 && z->numCompressedBytes >= 0); info->numBytes = z->numBytes; if (info->isEncrypted) { - assert(z->numCompressedBytes >= 12); /* caller should have checked*/ + assert(z->numCompressedBytes >= ZIP_CRYPT_HDR_LEN); /* caller should have checked*/ if (DecodeCryptHeader(interp, z, info->keys, info->ubuf) != TCL_OK) { goto error_cleanup; } - info->ubuf += 12; + info->ubuf += ZIP_CRYPT_HDR_LEN; } if (info->iscompr) { @@ -5014,7 +5115,9 @@ InitReadableChannel( unsigned int j; /* - * Data to decode is compressed, and possibly encrpyted too. + * Data to decode is compressed, and possibly encrpyted too. If + * encrypted, local variable ubuf is used to hold the decrypted but + * still compressed data. */ memset(&stream, 0, sizeof(z_stream)); @@ -5023,8 +5126,8 @@ InitReadableChannel( stream.opaque = Z_NULL; stream.avail_in = z->numCompressedBytes; if (info->isEncrypted) { - assert(stream.avail_in >= 12); - stream.avail_in -= 12; + assert(stream.avail_in >= ZIP_CRYPT_HDR_LEN); + stream.avail_in -= ZIP_CRYPT_HDR_LEN; ubuf = (unsigned char *) Tcl_AttemptAlloc(stream.avail_in ? stream.avail_in : 1); if (!ubuf) { goto memoryError; @@ -5038,8 +5141,9 @@ InitReadableChannel( } else { stream.next_in = info->ubuf; } - info->ubufToFree = (unsigned char *) - Tcl_AttemptAlloc(info->numBytes ? info->numBytes : 1); + + info->ubufSize = info->numBytes ? info->numBytes : 1; + info->ubufToFree = (unsigned char *)Tcl_AttemptAlloc(info->ubufSize); info->ubuf = info->ubufToFree; stream.next_out = info->ubuf; if (!info->ubuf) { @@ -5070,7 +5174,6 @@ InitReadableChannel( memset(info->keys, 0, sizeof(info->keys)); Tcl_Free(ubuf); } - return TCL_OK; } else if (info->isEncrypted) { unsigned int j, len; @@ -5078,9 +5181,10 @@ InitReadableChannel( * Decode encrypted but uncompressed file, since we support Tcl_Seek() * on it, and it can be randomly accessed later. */ - if (z->numCompressedBytes <= 12 || (z->numCompressedBytes - 12) != z->numBytes) + if (z->numCompressedBytes <= ZIP_CRYPT_HDR_LEN || + (z->numCompressedBytes - ZIP_CRYPT_HDR_LEN) != z->numBytes) goto corruptionError; - len = z->numCompressedBytes - 12; + len = z->numCompressedBytes - ZIP_CRYPT_HDR_LEN; ubuf = (unsigned char *) Tcl_AttemptAlloc(len); if (ubuf == NULL) { goto memoryError; @@ -5089,6 +5193,7 @@ InitReadableChannel( ch = info->ubuf[j]; ubuf[j] = zdecode(info->keys, crc32tab, ch); } + info->ubufSize = len; info->ubufToFree = ubuf; info->ubuf = info->ubufToFree; ubuf = NULL; /* So it does not inadvertently get free on future changes */ @@ -5113,6 +5218,7 @@ InitReadableChannel( Tcl_Free(info->ubufToFree); info->ubufToFree = NULL; info->ubuf = NULL; + info->ubufSize = 0; } return TCL_ERROR; @@ -5141,7 +5247,7 @@ ZipEntryStat( Tcl_StatBuf *buf) { ZipEntry *z; - int ret = -1; + int ret; ReadLock(); z = ZipFSLookup(path); @@ -5160,8 +5266,14 @@ ZipEntryStat( } else if (ContainsMountPoint(path, -1)) { /* An intermediate dir under which a mount exists */ memset(buf, 0, sizeof(Tcl_StatBuf)); + Tcl_Time t; + Tcl_GetTime(&t); + buf->st_atime = buf->st_mtime = buf->st_ctime = t.sec; buf->st_mode = S_IFDIR | 0555; ret = 0; + } else { + Tcl_SetErrno(ENOENT); + ret = -1; } Unlock(); return ret; @@ -5189,18 +5301,26 @@ ZipEntryAccess( char *path, int mode) { - if (mode & 3) { + if (mode & X_OK) { return -1; } ReadLock(); int access; ZipEntry *z = ZipFSLookup(path); - /* Could a real zip entry or an intermediate directory of a mount point */ - if (z || ContainsMountPoint(path, -1)) { - access = 0; + if (z) { + /* Currently existing files read/write but dirs are read-only */ + access = (z->isDirectory && (mode & W_OK)) ? -1 : 0; } else { - access = -1; + if (mode & W_OK) { + access = -1; + } else { + /* + * Even if entry does not exist, could be intermediate dir + * containing a mount point + */ + access = ContainsMountPoint(path, -1) ? 0 : -1; + } } Unlock(); return access; @@ -5381,13 +5501,13 @@ ZipFSMatchInDirectoryProc( 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, mounts = 0; Tcl_Size prefixLen, len, strip = 0; char *pat, *prefix, *path; Tcl_DString dsPref, *prefixBuf = NULL; + int foundInHash, notDuplicate; + ZipEntry *z; if (!normPathPtr) { return -1; @@ -5437,7 +5557,7 @@ ZipFSMatchInDirectoryProc( } /* Does the path exist in the hash table? */ - ZipEntry *z = ZipFSLookup(path); + z = ZipFSLookup(path); if (z) { /* * Can we skip the complexity of actual globbing? Without a pattern, @@ -5463,6 +5583,8 @@ ZipFSMatchInDirectoryProc( } } + foundInHash = (z != NULL); + /* * 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 @@ -5482,20 +5604,62 @@ ZipFSMatchInDirectoryProc( memcpy(pat + len, pattern, l + 1); scnt = CountSlashes(pat); - for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - hPtr; hPtr = Tcl_NextHashEntry(&search)) { - z = (ZipEntry *) Tcl_GetHashValue(hPtr); + Tcl_HashTable duplicates; + notDuplicate = 0; + Tcl_InitHashTable(&duplicates, TCL_STRING_KEYS); - if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory) - || (!dirOnly && z->isDirectory))) { - continue; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + if (foundInHash) { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + z = (ZipEntry *)Tcl_GetHashValue(hPtr); + + if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory) || + (!dirOnly && z->isDirectory))) { + continue; + } + if ((z->depth == scnt) && + ((z->flags & ZE_F_VOLUME) == 0) /* Bug 14db54d81e */ + && Tcl_StringCaseMatch(z->name, pat, 0)) { + Tcl_CreateHashEntry(&duplicates, z->name + strip, ¬Duplicate); + assert(notDuplicate); + AppendWithPrefix(result, prefixBuf, z->name + strip, -1); + } } - if ((z->depth == scnt) && - ((z->flags & ZE_F_VOLUME) == 0) /* Bug 14db54d81e */ - && Tcl_StringCaseMatch(z->name, pat, 0)) { - AppendWithPrefix(result, prefixBuf, z->name + strip, -1); + } + if (dirOnly) { + /* + * Also check paths that are ancestors of a mount. e.g. glob + * //zipfs:/a/? with mount at //zipfs:/a/b/c. Also have to be + * careful about duplicates, such as when another mount is + * //zipfs:/a/b/d + */ + Tcl_DString ds; + Tcl_DStringInit(&ds); + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + ZipFile *zf = (ZipFile *)Tcl_GetHashValue(hPtr); + if (Tcl_StringCaseMatch(zf->mountPoint, pat, 0)) { + const char *tail = zf->mountPoint + len; + if (*tail == '\0') + continue; + const char *end = strchr(tail, '/'); + Tcl_DStringAppend(&ds, + zf->mountPoint + strip, + end ? (Tcl_Size)(end - zf->mountPoint) : -1); + const char *matchedPath = Tcl_DStringValue(&ds); + (void)Tcl_CreateHashEntry( + &duplicates, matchedPath, ¬Duplicate); + if (notDuplicate) { + AppendWithPrefix( + result, prefixBuf, matchedPath, Tcl_DStringLength(&ds)); + } + Tcl_DStringFree(&ds); + } } } + Tcl_DeleteHashTable(&duplicates); Tcl_Free(pat); end: @@ -5617,8 +5781,6 @@ ZipFSPathInFilesystemProc( Tcl_Obj *pathPtr, TCL_UNUSED(void **)) { - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; Tcl_Size len; char *path; @@ -5627,92 +5789,13 @@ ZipFSPathInFilesystemProc( return -1; } path = Tcl_GetStringFromObj(pathPtr, &len); - /* - * TODO - why not make ZIPFS_VOLUME both necessary AND sufficient? - * Currently we only claim ownership if there is a matching mount. - */ - if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) { - return -1; - } else if (len == ZIPFS_VOLUME_LEN && ZipFS.zipHash.numEntries != 0) { - /* zipfs root and at least one entry */ - return TCL_OK; - } - - int ret = TCL_OK; - - ReadLock(); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); - if (hPtr) { - goto endloop; - } /* - * Not in hash table but still could be owned by zipfs in two other cases: - * Assuming there is a mount point //zipfs:/a/b/c, - * 1. The path is under the mount point, e.g. //zipfs:/a/b/c/f but that - * file does not exist. - * 2. The path is an intermediate directory in a mount point, e.g. - * //zipfs:/a/b + * Claim any path under ZIPFS_VOLUME as ours. This is both a necessary + * and sufficient condition as zipfs mounts at arbitrary paths are + * not permitted (unlike Androwish). */ - - for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); - - if (zf->mountPointLen == 0) { - /* - * Mounted on the root (/) - * TODO - a holdover from androwish? Tcl does not allow mounting - * outside of the //zipfs:/ area. - */ - ZipEntry *z; - - for (z = zf->topEnts; z != NULL; z = z->tnext) { - if (strncmp(path, z->name, len) == 0) { - int lenz = (int)strlen(z->name); - if (len == lenz) { - /* Would have been in hash table? But nm ... */ - goto endloop; - } else if (len > lenz) { - /* Case 1 above */ - if (path[lenz] == '/') { - goto endloop; - } - } else { /* len < lenz */ - /* Case 2 above */ - if (z->name[len] == '/') { - goto endloop; - } - } - } - } - } else { - /* Not mounted on root - the norm in Tcl core */ - - /* Lengths are known so check them before strnmp for efficiency*/ - assert(len != ZIPFS_VOLUME_LEN); /* Else already handled at top */ - if (len == zf->mountPointLen) { - /* A non-root or root mount. */ - goto endloop; - } else if (len > zf->mountPointLen) { - /* Case 1 above */ - if (path[zf->mountPointLen] == '/' && - strncmp(path, zf->mountPoint, zf->mountPointLen) == 0) { - goto endloop; - } - } else { /* len < zf->mountPointLen */ - if (zf->mountPoint[len] == '/' && - strncmp(path, zf->mountPoint, len) == 0) { - goto endloop; - } - } - } - } - ret = -1; /* Not our file */ - - endloop: - Unlock(); - return ret; + return strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) ? -1 : TCL_OK; } /* @@ -5827,34 +5910,39 @@ ZipFSFileAttrsGetProc( path = Tcl_GetStringFromObj(pathPtr, &len); ReadLock(); z = ZipFSLookup(path); - if (!z) { + if (!z && !ContainsMountPoint(path, -1)) { Tcl_SetErrno(ENOENT); ZIPFS_POSIX_ERROR(interp, "file not found"); ret = TCL_ERROR; goto done; } + /* z == NULL for intermediate directories that are ancestors of mounts */ switch (index) { case ZIP_ATTR_UNCOMPSIZE: - TclNewIntObj(*objPtrRef, z->numBytes); + TclNewIntObj(*objPtrRef, z ? z->numBytes : 0); break; case ZIP_ATTR_COMPSIZE: - TclNewIntObj(*objPtrRef, z->numCompressedBytes); + TclNewIntObj(*objPtrRef, z ? z->numCompressedBytes : 0); break; case ZIP_ATTR_OFFSET: - TclNewIntObj(*objPtrRef, z->offset); + TclNewIntObj(*objPtrRef, z ? z->offset : 0); break; case ZIP_ATTR_MOUNT: - *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint, - z->zipFilePtr->mountPointLen); + if (z) { + *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint, + z->zipFilePtr->mountPointLen); + } else { + *objPtrRef = Tcl_NewStringObj("", 0); + } break; case ZIP_ATTR_ARCHIVE: - *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1); + *objPtrRef = Tcl_NewStringObj(z ? z->zipFilePtr->name : "", -1); break; case ZIP_ATTR_PERMISSIONS: *objPtrRef = Tcl_NewStringObj("0o555", -1); break; case ZIP_ATTR_CRC: - TclNewIntObj(*objPtrRef, z->crc32); + TclNewIntObj(*objPtrRef, z ? z->crc32 : 0); break; default: ZIPFS_ERROR(interp, "unknown attribute"); @@ -6179,53 +6267,54 @@ ZipfsAppHookFindTclInit( } #endif -static void -ZipfsExitHandler( - TCL_UNUSED(void *) -) +/* + *------------------------------------------------------------------------ + * + * TclZipfsFinalize -- + * + * Frees all zipfs resources IRRESPECTIVE of open channels (there should + * not be any!) etc. To be called at process exit time (from + * Tcl_Finalize->TclFinalizeFilesystem) + * + * Results: + * None. + * + * Side effects: + * Frees up archives loaded into memory. + * + *------------------------------------------------------------------------ + */ +void TclZipfsFinalize(void) { - 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 - */ - } + WriteLock(); + if (!ZipFS.initialized) { + Unlock(); + return; } -} - -static void -ZipfsFinalize(void) { - Tcl_FSUnregister(&zipfsFilesystem); - Tcl_DeleteHashTable(&ZipFS.fileHash); - Tcl_Free(ZipFS.fallbackEntryEncoding); - ZipFS.initialized = -1; -} - -static void -ZipfsMountExitHandler( - void *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"); + Tcl_HashEntry *hPtr; + Tcl_HashSearch zipSearch; + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &zipSearch); hPtr; + hPtr = Tcl_NextHashEntry(&zipSearch)) { + ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + CleanupMount(zf); /* Frees file entries belonging to the archive */ + ZipFSCloseArchive(NULL, zf); + Tcl_Free(zf); } - hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); - if (hPtr == NULL) { - ZipfsFinalize(); + Tcl_FSUnregister(&zipfsFilesystem); + Tcl_DeleteHashTable(&ZipFS.fileHash); + Tcl_DeleteHashTable(&ZipFS.zipHash); + if (ZipFS.fallbackEntryEncoding) { + Tcl_Free(ZipFS.fallbackEntryEncoding); + ZipFS.fallbackEntryEncoding = NULL; } + ZipFS.initialized = 0; + Unlock(); } - + /* *------------------------------------------------------------------------- * diff --git a/generic/tclZlib.c b/generic/tclZlib.c index e083243..5a63dcf 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -320,7 +320,7 @@ ConvertError( * type is known). */ - Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL); + Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, (void *)NULL); } static Tcl_Obj * @@ -453,9 +453,9 @@ GenerateHeader( if (interp) { if (result == TCL_CONVERT_UNKNOWN) { Tcl_AppendResult( - interp, "Comment contains characters > 0xFF", NULL); + interp, "Comment contains characters > 0xFF", (void *)NULL); } else { - Tcl_AppendResult(interp, "Comment too large for zip", NULL); + Tcl_AppendResult(interp, "Comment too large for zip", (void *)NULL); } } result = TCL_ERROR; /* TCL_CONVERT_* -> TCL_ERROR*/ @@ -488,10 +488,10 @@ GenerateHeader( if (interp) { if (result == TCL_CONVERT_UNKNOWN) { Tcl_AppendResult( - interp, "Filename contains characters > 0xFF", NULL); + interp, "Filename contains characters > 0xFF", (void *)NULL); } else { Tcl_AppendResult( - interp, "Filename too large for zip", NULL); + interp, "Filename too large for zip", (void *)NULL); } } result = TCL_ERROR; /* TCL_CONVERT_* -> TCL_ERROR*/ @@ -850,7 +850,7 @@ Tcl_ZlibStreamInit( NULL, 0) != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "BUG: Stream command name already exists", -1)); - Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL); + Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", (void *)NULL); Tcl_DStringFree(&cmdname); goto error; } @@ -1242,7 +1242,7 @@ Tcl_ZlibStreamPut( if (zshPtr->interp) { Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj( "already past compressed stream end", -1)); - Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL); + Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", (void *)NULL); } return TCL_ERROR; } @@ -1474,7 +1474,7 @@ Tcl_ZlibStreamGet( "unexpected zlib internal state during" " decompression", -1)); Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE", - NULL); + (void *)NULL); } Tcl_SetByteArrayLength(data, existing); return TCL_ERROR; @@ -2240,7 +2240,7 @@ ZlibCmd( badLevel: Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", (void *)NULL); if (extraInfoStr) { Tcl_AddErrorInfo(interp, extraInfoStr); } @@ -2249,7 +2249,7 @@ ZlibCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "buffer size must be %d to %d", MIN_NONSTREAM_BUFFER_SIZE, MAX_BUFFER_SIZE)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", (void *)NULL); return TCL_ERROR; } @@ -2384,7 +2384,7 @@ ZlibStreamSubcmd( return TCL_ERROR; } else if (level < 0 || level > 9) { Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", (void *)NULL); Tcl_AddErrorInfo(interp, "\n (in -level option)"); return TCL_ERROR; } @@ -2503,13 +2503,13 @@ ZlibPushSubcmd( if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "compression may only be applied to writable channels", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", (void *)NULL); return TCL_ERROR; } if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "decompression may only be applied to readable channels",TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", (void *)NULL); return TCL_ERROR; } @@ -2526,7 +2526,7 @@ ZlibPushSubcmd( if (++i > objc-1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value missing for %s option", pushOptions[option])); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (void *)NULL); return TCL_ERROR; } switch (option) { @@ -2544,7 +2544,7 @@ ZlibPushSubcmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "level must be 0 to 9", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", - NULL); + (void *)NULL); goto genericOptionError; } break; @@ -2556,7 +2556,7 @@ ZlibPushSubcmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "read ahead limit must be 1 to %d", MAX_BUFFER_SIZE)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", (void *)NULL); goto genericOptionError; } break; @@ -2565,7 +2565,7 @@ ZlibPushSubcmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "a compression dictionary may not be set in the " "gzip format", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", (void *)NULL); goto genericOptionError; } compDictObj = objv[i]; @@ -2777,7 +2777,7 @@ ZlibStreamAddCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-buffer\" option must be followed by integer " "decompression buffersize", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (void *)NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) { @@ -2787,7 +2787,7 @@ ZlibStreamAddCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "buffer size must be 1 to %d", MAX_BUFFER_SIZE)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", (void *)NULL); return TCL_ERROR; } break; @@ -2796,7 +2796,7 @@ ZlibStreamAddCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-dictionary\" option must be followed by" " compression dictionary bytes", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (void *)NULL); return TCL_ERROR; } compDictObj = objv[++i]; @@ -2807,7 +2807,7 @@ ZlibStreamAddCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-flush\", \"-fullflush\" and \"-finalize\" options" " are mutually exclusive", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", (void *)NULL); return TCL_ERROR; } } @@ -2904,7 +2904,7 @@ ZlibStreamPutCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-dictionary\" option must be followed by" " compression dictionary bytes", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (void *)NULL); return TCL_ERROR; } compDictObj = objv[++i]; @@ -2914,7 +2914,7 @@ ZlibStreamPutCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-flush\", \"-fullflush\" and \"-finalize\" options" " are mutually exclusive", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", (void *)NULL); return TCL_ERROR; } } @@ -2962,7 +2962,7 @@ ZlibStreamHeaderCmd( || zshPtr->format != TCL_ZLIB_FORMAT_GZIP) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "only gunzip streams can produce header information", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL); + Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", (void *)NULL); return TCL_ERROR; } @@ -3407,7 +3407,7 @@ ZlibTransformSetOption( /* not used */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown -flush type \"%s\": must be full or sync", value)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", (void *)NULL); return TCL_ERROR; } @@ -3426,7 +3426,7 @@ ZlibTransformSetOption( /* not used */ } else if (newLimit < 1 || newLimit > MAX_BUFFER_SIZE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "-limit must be between 1 and 65536", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", (void *)NULL); return TCL_ERROR; } } diff --git a/libtommath/bn_mp_div.c b/libtommath/bn_mp_div.c index 71de55b..bca227d 100644 --- a/libtommath/bn_mp_div.c +++ b/libtommath/bn_mp_div.c @@ -31,7 +31,7 @@ mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) } /* init our temps */ - if ((err = mp_init_multi(&ta, &tb, &tq, &q, NULL)) != MP_OKAY) { + if ((err = mp_init_multi(&ta, &tb, &tq, &q, (void *)NULL)) != MP_OKAY) { return err; } @@ -64,7 +64,7 @@ mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) d->sign = MP_IS_ZERO(d) ? MP_ZPOS : n; } LBL_ERR: - mp_clear_multi(&ta, &tb, &tq, &q, NULL); + mp_clear_multi(&ta, &tb, &tq, &q, (void *)NULL); return err; } diff --git a/libtommath/bn_s_mp_balance_mul.c b/libtommath/bn_s_mp_balance_mul.c index 7ece5d7..557cc1d 100644 --- a/libtommath/bn_s_mp_balance_mul.c +++ b/libtommath/bn_s_mp_balance_mul.c @@ -19,7 +19,7 @@ mp_err s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c) if ((err = mp_init_size(&a0, bsize + 2)) != MP_OKAY) { return err; } - if ((err = mp_init_multi(&tmp, &r, NULL)) != MP_OKAY) { + if ((err = mp_init_multi(&tmp, &r, (void *)NULL)) != MP_OKAY) { mp_clear(&a0); return err; } @@ -75,7 +75,7 @@ mp_err s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c) mp_exch(&r,c); LBL_ERR: - mp_clear_multi(&a0, &tmp, &r,NULL); + mp_clear_multi(&a0, &tmp, &r, (void *)NULL); return err; } #endif diff --git a/libtommath/bn_s_mp_toom_mul.c b/libtommath/bn_s_mp_toom_mul.c index 86901b0..c7db3a5 100644 --- a/libtommath/bn_s_mp_toom_mul.c +++ b/libtommath/bn_s_mp_toom_mul.c @@ -36,7 +36,7 @@ mp_err s_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) mp_err err; /* init temps */ - if ((err = mp_init_multi(&S1, &S2, &T1, NULL)) != MP_OKAY) { + if ((err = mp_init_multi(&S1, &S2, &T1, (void *)NULL)) != MP_OKAY) { return err; } @@ -208,7 +208,7 @@ LBL_ERRa2: LBL_ERRa1: mp_clear(&a0); LBL_ERRa0: - mp_clear_multi(&S1, &S2, &T1, NULL); + mp_clear_multi(&S1, &S2, &T1, (void *)NULL); return err; } diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index e4604dc..332e0a4 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -204,7 +204,7 @@ TclMacOSXGetFileAttribute( #else Tcl_SetObjResult(interp, Tcl_NewStringObj( "Mac OS X file attributes not supported", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); + Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (void *)NULL); return TCL_ERROR; #endif /* HAVE_GETATTRLIST */ } @@ -336,7 +336,7 @@ TclMacOSXSetFileAttribute( if (newRsrcForkSize != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "setting nonzero rsrclength not supported", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); + Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (void *)NULL); return TCL_ERROR; } @@ -377,7 +377,7 @@ TclMacOSXSetFileAttribute( #else Tcl_SetObjResult(interp, Tcl_NewStringObj( "Mac OS X file attributes not supported", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); + Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (void *)NULL); return TCL_ERROR; #endif } @@ -649,7 +649,7 @@ SetOSTypeFromAny( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected Macintosh OS type but got \"%s\": ", string)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "MAC_OSTYPE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "MAC_OSTYPE", (void *)NULL); } result = TCL_ERROR; } else { diff --git a/tests/assemble.test b/tests/assemble.test index d4e44f8..0a7631a 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -141,6 +141,7 @@ test assemble-3.1 {wrong # args, compiled path} { -returnCodes error -match glob -result {wrong # args:*} + -cleanup {rename x {}} } test assemble-3.2 {wrong # args, compiled path} { -body { @@ -235,6 +236,7 @@ test assemble-5.3 {unsupported substitution} { list [catch {x} result] $result $::errorCode } -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} + -cleanup {rename x {}} } test assemble-5.4 {backslash substitution} { -body { @@ -622,6 +624,7 @@ test assemble-7.24 {lsetList} { x } -result {{a b} {c d} {e i} {g h}} + -cleanup {rename x {}} } test assemble-7.25 {lshift} { -body { @@ -3093,6 +3096,7 @@ test assemble-41.1 {Inconsistent stack usage} {*}{ -match glob -result {inconsistent stack depths on two execution paths ("assemble" body, line 10)*} + -cleanup {rename x {}} } test assemble-41.2 {Inconsistent stack, jumptable and default} { -body { @@ -3111,6 +3115,7 @@ test assemble-41.2 {Inconsistent stack, jumptable and default} { -match glob -result {inconsistent stack depths on two execution paths ("assemble" body, line 6)*} + -cleanup {rename x {}} } test assemble-41.3 {Inconsistent stack, two legs of jumptable} { -body { @@ -3130,6 +3135,7 @@ test assemble-41.3 {Inconsistent stack, two legs of jumptable} { -match glob -result {inconsistent stack depths on two execution paths ("assemble" body, line 7)*} + -cleanup {rename x {}} } test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} { @@ -3182,6 +3188,7 @@ test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} { set result } -result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88} + -cleanup {rename ulam {}} } test assemble-51.1 {memory leak testing} memory { @@ -3337,6 +3344,10 @@ test assemble-52.1 {Bug 3154ea2759} { rename fillTables {} rename assemble {} +if {[testConstraint memory]} { + rename getbytes {} + rename leaktest {} +} ::tcltest::cleanupTests return diff --git a/tests/basic.test b/tests/basic.test index c90d80e..067f9b0 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -242,10 +242,10 @@ test basic-15.2 {Tcl_CreateObjCommand, Bug 0e4d88b650} -setup { } -test basic-16.1 {TclInvokeStringCommand} {emptyTest} { +test basic-16.1 {InvokeStringCommand} {emptyTest} { } {} -test basic-17.1 {TclInvokeObjCommand} {emptyTest} { +test basic-17.1 {InvokeObjCommand} {emptyTest} { } {} test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { diff --git a/tests/socket.test b/tests/socket.test index 82e908a..b628404 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -2581,6 +2581,14 @@ foreach {servip sc} $x { } } +test socket-bug-31fc36fe47 "Crash listening in multiple threads" \ + -constraints thread -body { + close [socket -server xxx 0] + set tid [thread::create] + thread::send $tid {close [socket -server accept 0]} + thread::release $tid + } -result 0 + ::tcltest::cleanupTests flush stdout return diff --git a/tests/unixInit.test b/tests/unixInit.test index 8e64c7a..3a9fa6d 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -86,251 +86,6 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} } } {OK} -# The unixInit-2.* tests were written to test the internal routine, -# TclpInitLibraryPath. That routine no longer does the things it used to do -# so those tests are obsolete. Skip them. - -skip [concat [skip] unixInit-2.*] - -test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} -constraints { - testgetencpath -} -body { - set origPath [testgetencpath] - testsetencpath slappy - set path [testgetencpath] - testsetencpath $origPath - set path -} -result {slappy} -test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup { - unset -nocomplain oldlibrary - if {[info exists env(TCL_LIBRARY)]} { - set oldlibrary $env(TCL_LIBRARY) - unset env(TCL_LIBRARY) - } -} -body { - set path [getlibpath] - set installLib lib/tcl[info tclversion] - set developLib tcl[info patchlevel]/library - set prefix [file dirname [file dirname [interpreter]]] - list [string equal [lindex $path 0] $prefix/$installLib] \ - [string equal [lindex $path 4] [file dirname $prefix]/$developLib] -} -cleanup { - if {[info exists oldlibrary]} { - set env(TCL_LIBRARY) $oldlibrary - unset oldlibrary - } -} -result {1 1} -test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup { - unset -nocomplain oldlibrary - if {[info exists env(TCL_LIBRARY)]} { - set oldlibrary $env(TCL_LIBRARY) - } -} -body { - # ((str != NULL) && (str[0] != '\x00')) - set env(TCL_LIBRARY) sparkly - lindex [getlibpath] 0 -} -cleanup { - unset -nocomplain env(TCL_LIBRARY) - if {[info exists oldlibrary]} { - set env(TCL_LIBRARY) $oldlibrary - unset oldlibrary - } -} -result "sparkly" -test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -setup { - unset -nocomplain oldlibrary - if {[info exists env(TCL_LIBRARY)]} { - set oldlibrary $env(TCL_LIBRARY) - } -} -body { - # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0)) - set env(TCL_LIBRARY) /a/b/tcl1.7 - lrange [getlibpath] 0 1 -} -cleanup { - unset -nocomplain env(TCL_LIBRARY) - if {[info exists oldlibrary]} { - set env(TCL_LIBRARY) $oldlibrary - unset oldlibrary - } -} -result [list /a/b/tcl1.7 /a/b/tcl[info tclversion]] -test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup { - if {[info exists env(TCL_LIBRARY)]} { - set oldlibrary $env(TCL_LIBRARY) - } -} -body { - # Child process translates env variable from native encoding. - set env(TCL_LIBRARY) "§" - lindex [getlibpath] 0 -} -cleanup { - unset -nocomplain env(TCL_LIBRARY) env(LANG) - if {[info exists oldlibrary]} { - set env(TCL_LIBRARY) $oldlibrary - unset oldlibrary - } -} -result "§" -test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} { - # cannot test -} {} -test unixInit-2.6 {TclpInitLibraryPath: executable relative} -setup { - unset -nocomplain oldlibrary - if {[info exists env(TCL_LIBRARY)]} { - set oldlibrary $env(TCL_LIBRARY) - } - set env(TCL_LIBRARY) [info library] - makeDirectory tmp - makeDirectory [file join tmp sparkly] - makeDirectory [file join tmp sparkly bin] - file copy [interpreter] [file join [temporaryDirectory] tmp sparkly \ - bin tcltest] - makeDirectory [file join tmp sparkly lib] - makeDirectory [file join tmp sparkly lib tcl[info tclversion]] - makeFile {} [file join tmp sparkly lib tcl[info tclversion] init.tcl] -} -body { - lrange [getlibpath [file join [temporaryDirectory] tmp sparkly \ - bin tcltest]] 1 2 -} -cleanup { - removeFile [file join tmp sparkly lib tcl[info tclversion] init.tcl] - removeDirectory [file join tmp sparkly lib tcl[info tclversion]] - removeDirectory [file join tmp sparkly lib] - removeDirectory [file join tmp sparkly bin] - removeDirectory [file join tmp sparkly] - removeDirectory tmp - unset env(TCL_LIBRARY) - if {[info exists oldlibrary]} { - set env(TCL_LIBRARY) $oldlibrary - unset oldlibrary - } -} -result [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]] -test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} { - # would need test command to get defaultLibDir and compare it to - # [lindex $auto_path end] -} {} -# -# The following two tests write to the directory /tmp/sparkly instead of to -# [temporaryDirectory]. This is because the failures tested by these tests -# need paths near the "root" of the file system to present themselves. -# -test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { - unset -nocomplain oldlibrary - if {[info exists env(TCL_LIBRARY)]} { - set oldlibrary $env(TCL_LIBRARY) - } - set env(TCL_LIBRARY) [info library] - # Checking for Bug 219416 - # When a program that embeds the Tcl library, like tcltest, is installed - # near the "root" of the file system, there was a problem constructing - # directories relative to the executable. When a relative ".." went past - # the root, relative path names were created rather than absolute - # pathnames. In some cases, accessing past the root caused memory access - # violations too. - # - # The bug is now fixed, but here we check for it by making sure that the - # directories constructed relative to the executable are all absolute - # pathnames, even when the executable is installed near the root of the - # filesystem. - # - # The only directory near the root we are likely to have write access to - # is /tmp. - file delete -force /tmp/sparkly - file delete -force /tmp/lib/tcl[info tclversion] - file mkdir /tmp/sparkly - file copy [interpreter] /tmp/sparkly/tcltest - # Keep any existing /tmp/lib directory - set deletelib 1 - if {[file exists /tmp/lib]} { - if {[file isdirectory /tmp/lib]} { - set deletelib 0 - } else { - file delete -force /tmp/lib - } - } - # For a successful Tcl_Init, we need a [source]-able init.tcl in - # ../lib/tcl$version relative to the executable. - file mkdir /tmp/lib/tcl[info tclversion] - close [open /tmp/lib/tcl[info tclversion]/init.tcl w] -} -body { - # Check that all directories in the library path are absolute pathnames - set allAbsolute 1 - foreach dir [getlibpath /tmp/sparkly/tcltest] { - set allAbsolute [expr {$allAbsolute \ - && [string equal absolute [file pathtype $dir]]}] - } - set allAbsolute -} -cleanup { - # Clean up temporary installation - file delete -force /tmp/sparkly - file delete -force /tmp/lib/tcl[info tclversion] - if {$deletelib} {file delete -force /tmp/lib} - unset env(TCL_LIBRARY) - if {[info exists oldlibrary]} { - set env(TCL_LIBRARY) $oldlibrary - unset oldlibrary - } -} -result 1 -test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} -setup { - # Checking for Bug 438014 - unset -nocomplain oldlibrary - if {[info exists env(TCL_LIBRARY)]} { - set oldlibrary $env(TCL_LIBRARY) - } - set env(TCL_LIBRARY) [info library] - file delete -force /tmp/sparkly - file delete -force /tmp/library - file mkdir /tmp/sparkly - file copy [interpreter] /tmp/sparkly/tcltest - file mkdir /tmp/library/ - close [open /tmp/library/init.tcl w] -} -body { - lrange [getlibpath /tmp/sparkly/tcltest] 1 5 -} -cleanup { - file delete -force /tmp/sparkly - file delete -force /tmp/library - unset env(TCL_LIBRARY) - if {[info exists oldlibrary]} { - set env(TCL_LIBRARY) $oldlibrary - unset oldlibrary - } -} -result [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \ - /tmp/library /library /tcl[info patchlevel]/library] -test unixInit-2.10 {TclpInitLibraryPath: executable relative} -setup { - unset -nocomplain oldlibrary - if {[info exists env(TCL_LIBRARY)]} { - set oldlibrary $env(TCL_LIBRARY) - } - set env(TCL_LIBRARY) [info library] - set tmpDir [makeDirectory tmp] - set sparklyDir [makeDirectory sparkly $tmpDir] - set execPath [file join [makeDirectory bin $sparklyDir] tcltest] - file copy [interpreter] $execPath - set libDir [makeDirectory lib $sparklyDir] - set scriptDir [makeDirectory tcl[info tclversion] $libDir] - makeFile {} init.tcl $scriptDir - set saveDir [pwd] - cd $libDir -} -body { - # Checking for Bug 832657 - set x [lrange [getlibpath [file join .. bin tcltest]] 3 4] - foreach p $x { - lappend y [file normalize $p] - } - set y -} -cleanup { - cd $saveDir - removeFile init.tcl $scriptDir - removeDirectory tcl[info tclversion] $libDir - file delete $execPath - removeDirectory bin $sparklyDir - removeDirectory lib $sparklyDir - removeDirectory sparkly $tmpDir - removeDirectory tmp - unset -nocomplain saveDir scriptDir libDir execPath sparklyDir tmpDir - unset -nocomplain x p y env(TCL_LIBRARY) - if {[info exists oldlibrary]} { - set env(TCL_LIBRARY) $oldlibrary - unset oldlibrary - } -} -result [list [file join [temporaryDirectory] tmp sparkly library] \ - [file join [temporaryDirectory] tmp library] ] - test unixInit-3.1 {TclpSetInitialEncodings} -constraints { unix stdio } -body { diff --git a/tests/zipfiles/test-paths.zip b/tests/zipfiles/test-paths.zip Binary files differnew file mode 100644 index 0000000..539013e --- /dev/null +++ b/tests/zipfiles/test-paths.zip diff --git a/tests/zipfs.test b/tests/zipfs.test index 0b3a886..d77369b 100644 --- a/tests/zipfs.test +++ b/tests/zipfs.test @@ -6,9 +6,11 @@ # # Copyright © 1996-1998 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2023 Ashok P. Nadkarni # # 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 @@ -17,7 +19,7 @@ if {"::tcltest" ni [namespace children]} { source [file join [file dirname [info script]] tcltests.tcl] testConstraint zipfs [expr {[llength [info commands zipfs]]}] -testConstraint zipfslib 1 +testConstraint thread [expr {0 == [catch {package require Thread 2.8-}]}] set ziproot [zipfs root] @@ -32,19 +34,11 @@ test zipfs-0.1 {zipfs basics} -constraints zipfs -body { expr {${ziproot} in [file volumes]} } -result 1 -if {![string match ${ziproot}* $tcl_library]} { - ### - # "make test" does not map tcl_library from the dynamic library on Unix - # - # Hack the environment to pretend we did pull tcl_library from a zip - # archive - ### - set tclzip [file join $CWD libtcl[info patchlevel].zip] - testConstraint zipfslib [file isfile $tclzip] - if {[testConstraint zipfslib]} { - zipfs mount $tclzip /lib/tcl - set ::tcl_library ${ziproot}lib/tcl/tcl_library - } +if {[string match ${ziproot}* $tcl_library]} { + testConstraint zipfslib 1 + set zipLibTop [file tail [file join {*}[lrange [file split $tcl_library] 0 1]]] +} else { + set zipLibTop "" } test zipfs-0.2 {zipfs basics} -constraints zipfslib -body { @@ -368,9 +362,6 @@ test zipfs-5.3 {zipfs mount_data: short data} -constraints zipfs -body { append data PK\x05\x06..................................... zipfs mount_data $data gorp } -returnCodes error -result {archive directory truncated} -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 ?data? ?mountpoint?"} test zipfs-6.1 {zipfs mkkey} -constraints zipfs -body { binary scan [zipfs mkkey gorp] cu* x @@ -385,7 +376,7 @@ namespace eval test_ns_zipfs { namespace import ::tcltest::test namespace path ::tcltests variable zipTestDir [file normalize [file join [file dirname [info script]] zipfiles]] - variable defaultMountPoint [file join [zipfs root] testmount] + variable defMountPt [file join [zipfs root] testmount] proc readbin {path} { set fd [open $path rb] @@ -396,8 +387,8 @@ namespace eval test_ns_zipfs { # Wrapper to ease transition if Tcl changes order of argument to zipfs mount # or the zipfs prefix - proc mount [list zippath [list mountpoint $defaultMountPoint]] { - zipfs mount $zippath $mountpoint + proc mount [list zippath [list mountpoint $defMountPt]] { + return [zipfs mount $zippath $mountpoint] } # Make full path to zip file @@ -410,9 +401,14 @@ namespace eval test_ns_zipfs { } } + # list of paths -> list of paths under mount point mt + proc zipfspathsmt {mt args} { + return [lsort [lmap path $args {file join $mt $path}]] + } + # list of paths -> list of paths under [zipfs root] proc zipfspaths {args} { - return [lmap path $args {file join [zipfs root] $path}] + return [zipfspathsmt [zipfs root] {*}$args] } proc cleanup {} { @@ -437,12 +433,12 @@ namespace eval test_ns_zipfs { # zipfs mount proc testbadmount {id zippath messagePattern args} { - variable defaultMountPoint + variable defMountPt set zippath [zippath $zippath] test zipfs-mount-$id $id -body { list [catch {mount $zippath} message] \ [string match $messagePattern $message] \ - [mounttarget $defaultMountPoint] + [mounttarget $defMountPt] } -cleanup { # In case mount succeeded when it should not cleanup @@ -453,9 +449,9 @@ namespace eval test_ns_zipfs { } set data [readbin $zippath] test zipfs-mount_data-$id $id -body { - list [catch {zipfs mount_data $data $defaultMountPoint} message] \ + list [catch {zipfs mount_data $data $defMountPt} message] \ [string match $messagePattern $message] \ - [mounttarget $defaultMountPoint] + [mounttarget $defMountPt] } -cleanup { # In case mount succeeded when it should not cleanup @@ -466,27 +462,26 @@ namespace eval test_ns_zipfs { proc testmount {id zippath checkPath mountpoint args} { set zippath [zippath $zippath] test zipfs-mount-$id "zipfs mount $id" -body { - mount $zippath $mountpoint - set canon [zipfs canonical $mountpoint] + set canon [mount $zippath $mountpoint] list [file exists [file join $canon $checkPath]] \ - [mounttarget $canon] + [zipfs mount $canon] [zipfs mount $mountpoint] } -cleanup { zipfs unmount $mountpoint - } -result [list 1 $zippath] {*}$args + } -result [list 1 $zippath $zippath] {*}$args # Mount memory buffer test zipfs-mount_data-$id "zipfs mount_data $id" -body { - zipfs mount_data [readbin $zippath] $mountpoint - set canon [zipfs canonical $mountpoint] + set canon [zipfs mount_data [readbin $zippath] $mountpoint] list [file exists [file join $canon $checkPath]] \ - [mounttarget $canon] + [zipfs mount $canon] [zipfs mount $mountpoint] } -cleanup { cleanup - } -result [list 1 {Memory Buffer}] {*}$args + } -result [list 1 {Memory Buffer} {Memory Buffer}] {*}$args } testnumargs "zipfs mount" "" "?zipfile? ?mountpoint? ?password?" + testnumargs "zipfs mount_data" "data mountpoint" "" # Not supported zip files testbadmount non-existent-file nosuchfile.zip "couldn't open*nosuchfile.zip*no such file or directory" @@ -500,15 +495,31 @@ namespace eval test_ns_zipfs { testbadmount bad-file-count-high incons-file-count-high.zip "truncated directory" testbadmount bad-file-count-low incons-file-count-low.zip "short file count" - testmount basic test.zip testdir/test2 $defaultMountPoint + test zipfs-mount-on-drive "Mount point include drive" -body { + zipfs mount [zippath test.zip] C:/foo + } -result {Invalid mount path "C:/foo"} -returnCodes error -constraints win + test zipfs-mount_data-on-drive "Mount point include drive" -body { + zipfs mount_data [readbin [zippath test.zip]] C:/foo + } -result {Invalid mount path "C:/foo"} -returnCodes error -constraints win + test zipfs-mount-on-unc "Mount point is unc" -body { + zipfs mount [zippath test.zip] //unc/share/foo + } -result {Invalid mount path "//unc/share/foo"} -returnCodes error + test zipfs-mount_data-on-unc "Mount point include unc" -body { + zipfs mount_data [readbin [zippath test.zip]] //unc/share/foo + } -result {Invalid mount path "//unc/share/foo"} -returnCodes error + + # Good mounts + testmount basic test.zip testdir/test2 $defMountPt testmount basic-on-default test.zip testdir/test2 "" testmount basic-on-root test.zip testdir/test2 [zipfs root] testmount basic-on-slash test.zip testdir/test2 / + testmount basic-on-bslash test.zip testdir/test2 \\ -constraints win testmount basic-on-relative test.zip testdir/test2 testmount testmount basic-on-absolute test.zip testdir/test2 /testmount - testmount zip-at-end junk-at-start.zip testdir/test2 $defaultMountPoint - testmount zip-at-start junk-at-end.zip testdir/test2 $defaultMountPoint - testmount zip-in-zip [file join [zipfs root] test2 test.zip] testdir/test2 $defaultMountPoint -setup { + testmount basic-on-absolute-bslash test.zip testdir/test2 \\testmount -constraints win + testmount zip-at-end junk-at-start.zip testdir/test2 $defMountPt + testmount zip-at-start junk-at-end.zip testdir/test2 $defMountPt + testmount zip-in-zip [file join [zipfs root] test2 test.zip] testdir/test2 $defMountPt -setup { mount [zippath test-zip-in-zip.zip] [file join [zipfs root] test2] } -cleanup { zipfs unmount $mountpoint @@ -521,8 +532,8 @@ namespace eval test_ns_zipfs { } -cleanup { cleanup } -body { - zipfs mount [zippath testfile-cp437.zip] $defaultMountPoint - } -result "[zippath test.zip] is already mounted on $defaultMountPoint" -returnCodes error + zipfs mount [zippath testfile-cp437.zip] $defMountPt + } -result "[zippath test.zip] is already mounted on $defMountPt" -returnCodes error test zipfs-mount-no-args-1 "mount - get mount list" -setup { mount [zippath test.zip] @@ -530,15 +541,15 @@ namespace eval test_ns_zipfs { cleanup } -body { set mounts [zipfs mount] - lsearch -inline -stride 2 $mounts $defaultMountPoint - } -result [list $defaultMountPoint [zippath test.zip]] + lsearch -inline -stride 2 $mounts $defMountPt + } -result [list $defMountPt [zippath test.zip]] test zipfs-mount-one-arg-1 "mount - get mount target - absolute path" -setup { mount [zippath test.zip] } -cleanup { cleanup } -body { - zipfs mount $defaultMountPoint + zipfs mount $defMountPt } -result [zippath test.zip] test zipfs-mount-one-arg-2 "mount - get mount target - relative path" -setup { @@ -548,21 +559,21 @@ namespace eval test_ns_zipfs { cleanup file delete ./test.zip } -body { - zipfs mount $defaultMountPoint + zipfs mount $defMountPt } -result [file normalize ./test.zip] test zipfs-mount-password-1 "mount - verify plaintext readable without password" -body { - zipfs mount [zippath test-password.zip] $defaultMountPoint - readbin [file join $defaultMountPoint plain.txt] + zipfs mount [zippath test-password.zip] $defMountPt + readbin [file join $defMountPt plain.txt] } -cleanup { cleanup } -result plaintext test zipfs-mount-password-2 "mount - verify uncompressed cipher unreadable without password" -body { - zipfs mount [zippath test-password.zip] $defaultMountPoint + zipfs mount [zippath test-password.zip] $defMountPt set chans [lsort [chan names]]; # Want to ensure open does not leave dangling channel set result [list ] - lappend result [catch {open [file join $defaultMountPoint cipher.bin]} message] + lappend result [catch {open [file join $defMountPt cipher.bin]} message] lappend result $message lappend result [string equal $chans [lsort [chan names]]] } -cleanup { @@ -570,10 +581,10 @@ namespace eval test_ns_zipfs { } -result {1 {decryption failed - no password provided} 1} test zipfs-mount-password-3 "mount - verify compressed cipher unreadable without password" -body { - zipfs mount [zippath test-password.zip] $defaultMountPoint + zipfs mount [zippath test-password.zip] $defMountPt set chans [lsort [chan names]]; # Want to ensure open does not leave dangling channel set result [list ] - lappend result [catch {open [file join $defaultMountPoint cipher-deflate.bin]} message] + lappend result [catch {open [file join $defMountPt cipher-deflate.bin]} message] lappend result $message lappend result [string equal $chans [lsort [chan names]]] } -cleanup { @@ -585,10 +596,10 @@ namespace eval test_ns_zipfs { } -cleanup { cleanup } -body { - set newmount [file join $defaultMountPoint newdir] + set newmount [file join $defMountPt newdir] mount [zippath test-overlay.zip] $newmount list \ - [lsort [glob -tails -dir $defaultMountPoint *]] \ + [lsort [glob -tails -dir $defMountPt *]] \ [lsort [glob -tails -dir $newmount *]] \ [readbin [file join $newmount test2]] } -result {{newdir test testdir} {test2 test3} test2-overlay} @@ -598,13 +609,13 @@ namespace eval test_ns_zipfs { } -cleanup { cleanup } -body { - set newmount [file join $defaultMountPoint testdir] + set newmount [file join $defMountPt testdir] mount [zippath test-overlay.zip] $newmount # Note - file from existing mount is preserved (testdir/test2) # Not clear this is desired but defined as such by the # current implementation list \ - [lsort [glob -tails -dir $defaultMountPoint *]] \ + [lsort [glob -tails -dir $defMountPt *]] \ [lsort [glob -tails -dir $newmount *]] \ [readbin [file join $newmount test2]] } -result [list {test testdir} {test2 test3} test\n] @@ -620,23 +631,27 @@ namespace eval test_ns_zipfs { test zipfs-unmount-2 "Unmount mount with open files" -setup { mount [zippath test.zip] - set fd [open [file join $defaultMountPoint test]] + set fd [open [file join $defMountPt test]] } -cleanup { close $fd cleanup } -body { - zipfs unmount $defaultMountPoint + zipfs unmount $defMountPt } -result {filesystem is busy} -returnCodes error test zipfs-unmount-3 "Unmount mount with current directory" -setup { + set cwd [pwd] mount [zippath test.zip] } -cleanup { + cd $cwd cleanup } -body { - set cwd [pwd] - cd [file join $defaultMountPoint testdir] - list [pwd] [zipfs unmount $defaultMountPoint] [string equal [pwd] $cwd] - } -result [list [file join $defaultMountPoint testdir] {} 1] + # Current directory does not change on unmount. + # This is the same behavior as when USB pen drive is unmounted + set cwd2 [file join $defMountPt testdir] + cd $cwd2 + list [pwd] [zipfs unmount $defMountPt] [string equal [pwd] $cwd2] + } -result [list [file join $defMountPt testdir] {} 1] test zipfs-unmount-nested-1 "unmount parent of nested mount on new directory should not affect nested mount" -setup { mount [zippath test.zip] @@ -645,9 +660,9 @@ namespace eval test_ns_zipfs { } -cleanup { cleanup } -body { - zipfs unmount $defaultMountPoint + zipfs unmount $defMountPt list \ - [zipfs mount $defaultMountPoint] \ + [zipfs mount $defMountPt] \ [lsort [glob -tails -dir $newmount *]] \ [readbin [file join $newmount test2]] } -result {{} {test2 test3} test2-overlay} @@ -662,14 +677,26 @@ namespace eval test_ns_zipfs { # KNOWN BUG. The test2 file is also present in parent mount. # After the unmount, the test2 in the nested mount is not # made available. - zipfs unmount $defaultMountPoint + zipfs unmount $defMountPt list \ - [zipfs mount $defaultMountPoint] \ + [zipfs mount $defMountPt] \ [lsort [glob -tails -dir $newmount *]] \ [readbin [file join $newmount test2]] } -result {{} {test2 test3} test2-overlay} # + # paths inside a zip + # TODO - paths encoded in utf-8 vs fallback encoding + test zipfs-content-paths-1 "Test absolute and full paths" -setup { + mount [zippath test-paths.zip] + } -cleanup { + cleanup + } -body { + # Primarily verifies that drive letters are stripped and paths maintained + lsort [zipfs find $defMountPt] + } -result {//zipfs:/testmount/filename.txt //zipfs:/testmount/src //zipfs:/testmount/src/tcltk //zipfs:/testmount/src/tcltk/wip //zipfs:/testmount/src/tcltk/wip/tcl //zipfs:/testmount/src/tcltk/wip/tcl/tests //zipfs:/testmount/src/tcltk/wip/tcl/tests/zipfiles //zipfs:/testmount/src/tcltk/wip/tcl/tests/zipfiles/abspath.txt //zipfs:/testmount/src/tcltk/wip/tcl/tests/zipfiles/fullpath.txt} + + # # zipfs list testnumargs "zipfs list" "" "?(-glob|-regexp)? ?pattern?" @@ -701,13 +728,13 @@ namespace eval test_ns_zipfs { } -result $resultpaths {*}$args } # Some tests have !zipfslib constraint because otherwise they dump the entire Tcl library which is mounted on root - testzipfslist no-mounts "" {} {} -constraints !zipfslib - testzipfslist no-pattern "" {test.zip testmountA} {testmountA testmountA/test testmountA/testdir testmountA/testdir/test2} -constraints !zipfslib + testzipfslist no-mounts "" {} {} -constraints !zipfslib + testzipfslist no-pattern "" {test.zip testmountA} {testmountA testmountA/test testmountA/testdir testmountA/testdir/test2} -constraints !zipfslib testzipfslist no-pattern-mount-on-empty "" {test.zip {}} {{} test testdir testdir/test2} -constraints !zipfslib - testzipfslist no-pattern-mount-on-root "" [list test.zip [zipfs root]] {{} test testdir testdir/test2} -constraints !zipfslib + testzipfslist no-pattern-mount-on-root "" [list test.zip [zipfs root]] {{} test testdir testdir/test2} -constraints !zipfslib testzipfslist no-pattern-mount-on-slash "" [list test.zip /] {{} test testdir testdir/test2} -constraints !zipfslib - testzipfslist no-pattern-mount-on-level3 "" [list test.zip testmt/a/b] {{} testmt testmt/a testmt/a/b testmt/a/b/test testmt/a/b/testdir testmt/a/b/testdir/test2} -constraints {knownBug !zipfslib} - testzipfslist no-pattern-multiple "" {test.zip testmountA test.zip testmountB/subdir} { + testzipfslist no-pattern-mount-on-mezzo "" [list test.zip testmt/a/b] {testmt/a/b testmt/a/b/test testmt/a/b/testdir testmt/a/b/testdir/test2} -constraints {!zipfslib} + testzipfslist no-pattern-multiple "" {test.zip testmountA test.zip testmountB/subdir} { testmountA testmountA/test testmountA/testdir testmountA/testdir/test2 testmountB/subdir testmountB/subdir/test testmountB/subdir/testdir testmountB/subdir/testdir/test2 } -constraints !zipfslib @@ -729,7 +756,7 @@ namespace eval test_ns_zipfs { testnumargs "zipfs exists" "filename" "" # Generates tests for zipfs exists - proc testzipfsexists [list id path result [list mountpoint $defaultMountPoint] args] { + proc testzipfsexists [list id path result [list mountpoint $defMountPt] args] { test zipfs-exists-$id "zipfs exists $id" -body { zipfs exists $path } -setup { @@ -739,14 +766,14 @@ namespace eval test_ns_zipfs { cleanup } -result $result {*}$args } - testzipfsexists native-file [info nameofexecutable] 0 - testzipfsexists enoent [file join $defaultMountPoint nosuchfile] 0 - testzipfsexists file [file join $defaultMountPoint test] 1 - testzipfsexists dir [file join $defaultMountPoint testdir] 1 - testzipfsexists mountpoint $defaultMountPoint 1 - testzipfsexists root [zipfs root] 1 $defaultMountPoint - testzipfsexists level3 [file join $defaultMountPoint a b] 1 [file join $defaultMountPoint a b c] - testzipfsexists level3-enoent [file join $defaultMountPoint a c] 0 [file join $defaultMountPoint a b c] + testzipfsexists native-file [info nameofexecutable] 0 + testzipfsexists enoent [file join $defMountPt nosuchfile] 0 + testzipfsexists file [file join $defMountPt test] 1 + testzipfsexists dir [file join $defMountPt testdir] 1 + testzipfsexists mountpoint $defMountPt 1 + testzipfsexists root [zipfs root] 1 $defMountPt + testzipfsexists mezzo [file join $defMountPt a b] 1 [file join $defMountPt a b c] + testzipfsexists mezzo-enoent [file join $defMountPt a c] 0 [file join $defMountPt a b c] # # zipfs find @@ -804,16 +831,15 @@ namespace eval test_ns_zipfs { # bug-6183f535c8 testzipfsfind root-path [zipfs root] { test.zip {} test.zip testmountB/subdir - } [zipfspaths test testdir testdir/test2] -constraints !zipfslib + } [zipfspaths test testdir testdir/test2 testmountB testmountB/subdir testmountB/subdir/test testmountB/subdir/testdir testmountB/subdir/testdir/test2] -constraints !zipfslib - testzipfsfind level3 [file join [zipfs root] testmt a] { + testzipfsfind mezzo [file join [zipfs root] testmt a] { test.zip testmt/a/b } [zipfspaths testmt/a/b testmt/a/b/test testmt/a/b/testdir testmt/a/b/testdir/test2] - testzipfsfind level3-root [zipfs root] { + testzipfsfind mezzo-root [zipfs root] { test.zip testmt/a/b - } [zipfspaths testmt testmt/a testmt/a/b testmt/a/b/test testmt/a/b/testdir testmt/a/b/testdir/test2] \ - -constraints bug-9e039ee0b9 + } [zipfspaths testmt testmt/a testmt/a/b testmt/a/b/test testmt/a/b/testdir testmt/a/b/testdir/test2] -constraints !zipfslib test zipfs-find-native-absolute "zipfs find on native file system" -setup { set dir [makeDirectory zipfs-native-absolute] @@ -860,15 +886,15 @@ namespace eval test_ns_zipfs { } -cleanup { cleanup } -body { - zipfs info [file join $defaultMountPoint nosuchfile] - } -result "path \"[file join $defaultMountPoint nosuchfile]\" not found in any zipfs volume" -returnCodes error + zipfs info [file join $defMountPt nosuchfile] + } -result "path \"[file join $defMountPt nosuchfile]\" not found in any zipfs volume" -returnCodes error test zipfs-info-file "zipfs info file within mounted archive" -setup { mount [zippath testdeflated2.zip] } -cleanup { cleanup } -body { - zipfs info [file join $defaultMountPoint abac-repeat.txt] + zipfs info [file join $defMountPt abac-repeat.txt] } -result [list [zippath testdeflated2.zip] 60 17 108] test zipfs-info-dir "zipfs info dir within mounted archive" -setup { @@ -876,7 +902,7 @@ namespace eval test_ns_zipfs { } -cleanup { cleanup } -body { - zipfs info [file join $defaultMountPoint testdir] + zipfs info [file join $defMountPt testdir] } -result [list [zippath test.zip] 0 0 119] test zipfs-info-mountpoint "zipfs info on mount point - verify correct offset of zip content" -setup { @@ -885,10 +911,10 @@ namespace eval test_ns_zipfs { } -cleanup { cleanup } -body { - zipfs info $defaultMountPoint + zipfs info $defMountPt } -result [list [zippath junk-at-start.zip] 0 0 4] - test zipfs-info-level3 "zipfs info on mount point - verify correct offset of zip content" -setup { + test zipfs-info-mezzo "zipfs info on mount point - verify correct offset of zip content" -setup { # zip starts at offset 4 mount [zippath junk-at-start.zip] /testmt/a/b } -cleanup { @@ -898,44 +924,50 @@ namespace eval test_ns_zipfs { } -result {path "//zipfs:/testmt/a" not found in any zipfs volume} -returnCodes error # - # zipfs canonical - - # TODO - semantics are very unclear. Can produce nonsensical paths like - # //zipfs:/n/zipfs:/m/test. Minimal sanity tests for now. + # zipfs canonical test zipfs-canonical-minargs {zipfs canonical min args} -body { zipfs canonical - } -returnCodes error -result {wrong # args: should be "zipfs canonical ?mountpoint? filename ?inZipfs?"} + } -returnCodes error -result {wrong # args: should be "zipfs canonical ?mountpoint? filename"} test zipfs-canonical-maxargs {zipfs canonical max args} -body { - zipfs canonical a b c d - } -returnCodes error -result {wrong # args: should be "zipfs canonical ?mountpoint? filename ?inZipfs?"} + zipfs canonical a b c + } -returnCodes error -result {wrong # args: should be "zipfs canonical ?mountpoint? filename"} proc testzipfscanonical {id cmdargs result args} { test zipfs-canonical-$id "zipfs canonical $id" \ -body [list zipfs canonical {*}$cmdargs] \ -result $result {*}$args } - testzipfscanonical basic-relative PATH [file join [zipfs root] PATH] - testzipfscanonical basic-absolute /PATH [file join [zipfs root] PATH] - testzipfscanonical mountpoint-relative {MT PATH} [file join [zipfs root] MT PATH] - testzipfscanonical mountpoint-absolute {MT /PATH} [file join [zipfs root] PATH] - testzipfscanonical mountpoint-trailslash-relative {MT/ PATH} [file join [zipfs root] MT PATH] - testzipfscanonical mountpoint-trailslash-absolute {MT/ /PATH} [file join [zipfs root] PATH] - testzipfscanonical mountpoint-root-relative [list [zipfs root] PATH] [file join [zipfs root] PATH] - testzipfscanonical mountpoint-root-absolute [list [zipfs root] /PATH] [file join [zipfs root] PATH] - testzipfscanonical mountpoint-empty-relative {{} PATH} [file join [zipfs root] PATH] - - testzipfscanonical driveletter X: [zipfs root] -constraints win - testzipfscanonical drivepath X:/foo/bar [file join [zipfs root] foo bar] -constraints win - # (backslashes need additional escaping passed to testzipfscanonical) - testzipfscanonical backslashes X:\\\\foo\\\\bar [file join [zipfs root] foo bar] -constraints win - testzipfscanonical backslashes-1 X:/foo\\\\bar [file join [zipfs root] foo bar] -constraints win + testzipfscanonical default-relative [list a] [file join [zipfs root] a] + testzipfscanonical default-absolute [list /a] [file join [zipfs root] a] + testzipfscanonical root-relative-1 [list [zipfs root] a] [file join [zipfs root] a] + testzipfscanonical root-relative-2 [list / a] [file join [zipfs root] a] + testzipfscanonical root-absolute-1 [list [zipfs root] /a] [file join [zipfs root] a] + testzipfscanonical root-absolute-2 [list / /a] [file join [zipfs root] a] + testzipfscanonical absolute-relative [list /MT a] [file join [zipfs root] MT a] + testzipfscanonical absolute-absolute [list /MT /a] [file join [zipfs root] MT a] + testzipfscanonical relative-relative [list MT a] [file join [zipfs root] MT a] + testzipfscanonical relative-absolute [list MT /a] [file join [zipfs root] MT a] + testzipfscanonical mountpoint-trailslash-relative [list MT/ a] [file join [zipfs root] MT a] + testzipfscanonical mountpoint-trailslash-absolute [list MT/ /a] [file join [zipfs root] MT a] + testzipfscanonical mountpoint-root-relative [list [zipfs root] a] [file join [zipfs root] a] + testzipfscanonical mountpoint-root-absolute [list [zipfs root] /a] [file join [zipfs root] a] + testzipfscanonical mountpoint-empty-relative [list {} a] [file join [zipfs root] a] + + testzipfscanonical driveletter [list X:] [zipfs root] -constraints win + testzipfscanonical drivepath [list X:/foo/bar] [file join [zipfs root] foo bar] -constraints win + testzipfscanonical drivepath-1 [list MT X:/foo/bar] [file join [zipfs root] MT foo bar] -constraints win + testzipfscanonical backslashes [list X:\\\\foo\\\\bar] [file join [zipfs root] foo bar] -constraints win + testzipfscanonical backslashes-1 [list X:/foo\\\\bar] [file join [zipfs root] foo bar] -constraints win + testzipfscanonical zipfspath [list //zipfs:/x/y] [file join [zipfs root] x y] + testzipfscanonical zipfspath-1 [list MT //zipfs:/x/y] [file join [zipfs root] x y] # # Read/uncompress proc testzipfsread {id zippath result {filename abac-repeat.txt} {openopts {}} args} { - variable defaultMountPoint + variable defMountPt set zippath [zippath $zippath] test zipfs-read-$id "zipfs read $id" -setup { unset -nocomplain fd - zipfs mount $zippath $defaultMountPoint + zipfs mount $zippath $defMountPt } -cleanup { # In case open succeeded when it should not if {[info exists fd]} { @@ -943,14 +975,14 @@ namespace eval test_ns_zipfs { } cleanup } -body { - set fd [open [file join $defaultMountPoint $filename] {*}$openopts] + set fd [open [file join $defMountPt $filename] {*}$openopts] gets $fd } -result $result {*}$args set data [readbin $zippath] test zipfs-read-memory-$id "zipfs read in-memory $id" -setup { unset -nocomplain fd - zipfs mount_data $data $defaultMountPoint + zipfs mount_data $data $defMountPt } -cleanup { # In case open succeeded when it should not if {[info exists fd]} { @@ -958,29 +990,29 @@ namespace eval test_ns_zipfs { } cleanup } -body { - set fd [open [file join $defaultMountPoint $filename] {*}$openopts] + set fd [open [file join $defMountPt $filename] {*}$openopts] gets $fd } -result $result {*}$args } - testzipfsread stored test.zip test test - testzipfsread stored teststored.zip aaaaaaaaaaaaaa - testzipfsread deflate testdeflated2.zip aaaaaaaaaaaaaa + testzipfsread stored test.zip test test + testzipfsread stored-1 teststored.zip aaaaaaaaaaaaaa + testzipfsread deflate testdeflated2.zip aaaaaaaaaaaaaa testzipfsread bug-23dd83ce7c empty.zip {} empty.txt # Test open modes - see bug [4645658689] - testzipfsread stored-rw teststored.zip aaaaaaaaaaaaaa abac-repeat.txt r+ - testzipfsread deflate-rw testdeflated2.zip aaaaaaaaaaaaaa abac-repeat.txt r+ - testzipfsread stored-wr teststored.zip {} abac-repeat.txt w+ -constraints bug-00018ec7a0 - testzipfsread deflate-wr testdeflated2.zip {} abac-repeat.txt w+ -constraints bug-00018ec7a0 - testzipfsread stored-ar teststored.zip {} abac-repeat.txt a+ - testzipfsread deflate-ar testdeflated2.zip {} abac-repeat.txt a+ - - testzipfsread nosuch test.zip "file not found \"//zipfs:/testmount/nosuchfile\": no such file or directory" nosuchfile {} -returnCodes error - testzipfsread deflate-error broken.zip {decompression error} deflatezliberror {} -returnCodes error + testzipfsread stored-r+ teststored.zip aaaaaaaaaaaaaa abac-repeat.txt r+ + testzipfsread deflate-r+ testdeflated2.zip aaaaaaaaaaaaaa abac-repeat.txt r+ + testzipfsread stored-w+ teststored.zip {} abac-repeat.txt w+ + testzipfsread deflate-w+ testdeflated2.zip {} abac-repeat.txt w+ + testzipfsread stored-a+ teststored.zip {} abac-repeat.txt a+ + testzipfsread deflate-a+ testdeflated2.zip {} abac-repeat.txt a+ + + testzipfsread enoent test.zip "file \"//zipfs:/testmount/nosuchfile\" not found: no such file or directory" nosuchfile {} -returnCodes error testzipfsread bzip2 testbzip2.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error testzipfsread lzma testfile-lzma.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error testzipfsread xz testfile-xz.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error testzipfsread zstd testfile-zstd.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error + testzipfsread deflate-error broken.zip {decompression error} deflatezliberror {} -returnCodes error test zipfs-read-unwritable "Writes not allowed on file opened for read" -setup { mount [zippath test.zip] @@ -988,20 +1020,22 @@ namespace eval test_ns_zipfs { close $fd cleanup } -body { - set fd [open [file join $defaultMountPoint test]] + set fd [open [file join $defMountPt test]] puts $fd blah } -result {channel "*" wasn't opened for writing} -match glob -returnCodes error # # Write proc testzipfswrite {id zippath result filename mode args} { - variable defaultMountPoint + variable defMountPt set zippath [zippath $zippath] - set path [file join $defaultMountPoint $filename] + set path [file join $defMountPt $filename] set body { set fd [open $path $mode] fconfigure $fd -translation binary - puts -nonewline $fd "xyz" + puts -nonewline $fd XYZ + seek $fd 0 + puts -nonewline $fd xyz close $fd set fd [open $path] fconfigure $fd -translation binary @@ -1009,7 +1043,7 @@ namespace eval test_ns_zipfs { } test zipfs-write-$id "zipfs write $id" -setup { unset -nocomplain fd - zipfs mount $zippath $defaultMountPoint + zipfs mount $zippath $defMountPt } -cleanup { # In case open succeeded when it should not if {[info exists fd]} { @@ -1021,7 +1055,7 @@ namespace eval test_ns_zipfs { set data [readbin $zippath] test zipfs-write-memory-$id "zipfs write in-memory $id" -setup { unset -nocomplain fd - zipfs mount_data $data $defaultMountPoint + zipfs mount_data $data $defMountPt } -cleanup { # In case open succeeded when it should not if {[info exists fd]} { @@ -1031,18 +1065,18 @@ namespace eval test_ns_zipfs { } -body $body -result $result {*}$args } - testzipfswrite create-w test.zip "file not found \"//zipfs:/testmount/newfile\": no such file or directory" newfile w -returnCodes error - testzipfswrite create-w+ test.zip "file not found \"//zipfs:/testmount/newfile\": no such file or directory" newfile w+ -returnCodes error - testzipfswrite create-a test.zip "append mode not supported: permission denied" newfile a -returnCodes error - testzipfswrite create-a+ test.zip "file not found \"//zipfs:/testmount/newfile\": no such file or directory" newfile a+ -returnCodes error - testzipfswrite store-w teststored.zip "xyz" abac-repeat.txt w - testzipfswrite deflate-w testdeflated2.zip "xyz" abac-repeat.txt w - testzipfswrite store-w+ teststored.zip "xyz" abac-repeat.txt w+ + testzipfswrite create-w test.zip "file \"//zipfs:/testmount/newfile\" not created: operation not supported" newfile w -returnCodes error + testzipfswrite create-w+ test.zip "file \"//zipfs:/testmount/newfile\" not created: operation not supported" newfile w+ -returnCodes error + testzipfswrite create-a test.zip "file \"$defMountPt/newfile\" not created: operation not supported" newfile a -returnCodes error + testzipfswrite create-a+ test.zip "file \"//zipfs:/testmount/newfile\" not created: operation not supported" newfile a+ -returnCodes error + testzipfswrite store-w teststored.zip "xyz" abac-repeat.txt w + testzipfswrite deflate-w testdeflated2.zip "xyz" abac-repeat.txt w + testzipfswrite store-w+ teststored.zip "xyz" abac-repeat.txt w+ testzipfswrite deflate-w+ testdeflated2.zip "xyz" abac-repeat.txt w+ - testzipfswrite stored-a teststored.zip "append mode not supported: permission denied" abac-repeat.txt a -returnCodes error - testzipfswrite deflate-a testdeflated2.zip "append mode not supported: permission denied" abac-repeat.txt a -returnCodes error - testzipfswrite store-a+ teststored.zip "aaaaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nxyz" abac-repeat.txt a+ - testzipfswrite deflate-a+ testdeflated2.zip "aaaaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nxyz" abac-repeat.txt a+ + testzipfswrite stored-a teststored.zip "aaaaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nXYZxyz" abac-repeat.txt a + testzipfswrite deflate-a testdeflated2.zip "aaaaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nXYZxyz" abac-repeat.txt a + testzipfswrite store-a+ teststored.zip "xyzaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nXYZ" abac-repeat.txt a+ + testzipfswrite deflate-a+ testdeflated2.zip "xyzaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nXYZ" abac-repeat.txt a+ testzipfswrite bug-23dd83ce7c-w empty.zip "xyz" empty.txt w test zipfs-write-unreadable "Reads not allowed on file opened for write" -setup { @@ -1051,7 +1085,7 @@ namespace eval test_ns_zipfs { close $fd cleanup } -body { - set fd [open [file join $defaultMountPoint test] w] + set fd [open [file join $defMountPt test] w] read $fd } -result {channel "*" wasn't opened for reading} -match glob -returnCodes error @@ -1060,14 +1094,14 @@ namespace eval test_ns_zipfs { } -cleanup { cleanup } -body { - set path [file join $defaultMountPoint test] + set path [file join $defMountPt test] set fd [open $path w] puts -nonewline $fd newtext close $fd set fd [open $path] set result [list [read $fd]] close $fd - zipfs unmount $defaultMountPoint + zipfs unmount $defMountPt mount [zippath test.zip] set fd [open $path] lappend result [read $fd] @@ -1084,7 +1118,7 @@ namespace eval test_ns_zipfs { cleanup } -body { set ::tcl::zipfs::wrmax 10 - set fd [open [file join $defaultMountPoint test] w] + set fd [open [file join $defMountPt test] w] puts $fd [string repeat x 11] flush $fd } -result {error flushing *: file too large} -match glob -returnCodes error @@ -1097,23 +1131,40 @@ namespace eval test_ns_zipfs { cleanup } -body { set ::tcl::zipfs::wrmax 10 - set fd [open [file join $defaultMountPoint test] w] + set fd [open [file join $defMountPt test] w] puts $fd [string repeat x 11] close $fd } -result {file too large} -match glob -returnCodes error test zipfs-write-size-limit-2 "Writes max size" -setup { + set origlimit $::tcl::zipfs::wrmax + set ::tcl::zipfs::wrmax 10000000 mount [zippath test.zip] } -cleanup { + set ::tcl::zipfs::wrmax $origlimit cleanup } -body { - set fd [open [file join $defaultMountPoint test] w] + set fd [open [file join $defMountPt test] w] puts -nonewline $fd [string repeat x $::tcl::zipfs::wrmax] close $fd - file size [file join $defaultMountPoint test] - } -result $::tcl::zipfs::wrmax + file size [file join $defMountPt test] + } -result 10000000 - test zipfs-write-size-limit-3 "Writes disallowed" -setup { + test zipfs-write-size-limit-3 "Writes incrementally - buffer growth" -setup { + mount [zippath test.zip] + } -cleanup { + cleanup + } -body { + set fd [open [file join $defMountPt test] w] + fconfigure $fd -buffering none + for {set i 0} {$i < 100000} {incr i} { + puts -nonewline $fd 0123456789 + } + close $fd + readbin [file join $defMountPt test] + } -result [string repeat 0123456789 100000] + + test zipfs-write-size-limit-4 "Writes disallowed" -setup { set origlimit $::tcl::zipfs::wrmax mount [zippath test.zip] } -cleanup { @@ -1121,15 +1172,15 @@ namespace eval test_ns_zipfs { cleanup } -body { set ::tcl::zipfs::wrmax -1 - open [file join $defaultMountPoint test] w - } -result {write access not supported: permission denied} -returnCodes error + open [file join $defMountPt test] w + } -result {writes not permitted: permission denied} -returnCodes error # # read/seek/write proc testzipfsrw {id zippath expected filename mode args} { - variable defaultMountPoint + variable defMountPt set zippath [zippath $zippath] - set path [file join $defaultMountPoint $filename] + set path [file join $defMountPt $filename] set body { set result "" set fd [open $path $mode] @@ -1150,7 +1201,7 @@ namespace eval test_ns_zipfs { } test zipfs-rw-$id "zipfs read/seek/write $id" -setup { unset -nocomplain fd - zipfs mount $zippath $defaultMountPoint + zipfs mount $zippath $defMountPt } -cleanup { # In case open succeeded when it should not if {[info exists fd]} { @@ -1162,7 +1213,7 @@ namespace eval test_ns_zipfs { set data [readbin $zippath] test zipfs-rw-memory-$id "zipfs read/seek/write in-memory $id" -setup { unset -nocomplain fd - zipfs mount_data $data $defaultMountPoint + zipfs mount_data $data $defMountPt } -cleanup { # In case open succeeded when it should not if {[info exists fd]} { @@ -1184,7 +1235,7 @@ namespace eval test_ns_zipfs { close $fd cleanup } -body { - set path [file join $defaultMountPoint test] + set path [file join $defMountPt test] set fd [open $path r+] puts -nonewline $fd X close $fd @@ -1195,14 +1246,14 @@ namespace eval test_ns_zipfs { # # Password protected proc testpasswordr {id zipfile filename password result args} { - variable defaultMountPoint + variable defMountPt set zippath [zippath $zipfile] test zipfs-password-read-$id "zipfs password read $id" -setup { unset -nocomplain fd if {$password ne ""} { - zipfs mount $zippath $defaultMountPoint $password + zipfs mount $zippath $defMountPt $password } else { - zipfs mount $zippath $defaultMountPoint + zipfs mount $zippath $defMountPt } } -cleanup { # In case open succeeded when it should not @@ -1211,32 +1262,32 @@ namespace eval test_ns_zipfs { } cleanup } -body { - set fd [open [file join $defaultMountPoint $filename]] + set fd [open [file join $defMountPt $filename]] gets $fd - } -result $result {*}$args + } -result $result {*}$args -constraints bbe7c6ff9e } # The bug bbe7c6ff9e only manifests on macos - testConstraint bug-bbe7c6ff9e [expr {$::tcl_platform(os) ne "Darwin"}] + testConstraint bbe7c6ff9e [expr {$::tcl_platform(os) ne "Darwin"}] # NOTE: test-password.zip is the DOS time based encryption header validity check (infozip style) # test-password2.zip is the CRC based encryption header validity check (pkware style) testpasswordr plain test-password.zip plain.txt password plaintext testpasswordr plain-nopass test-password.zip plain.txt "" plaintext testpasswordr plain-badpass test-password.zip plain.txt badpassword plaintext - testpasswordr cipher-1 test-password.zip cipher.bin password ciphertext -constraints bug-bbe7c6ff9e - testpasswordr cipher-2 test-password2.zip cipher.bin password ciphertext -constraints bug-bbe7c6ff9e + testpasswordr cipher-1 test-password.zip cipher.bin password ciphertext + testpasswordr cipher-2 test-password2.zip cipher.bin password ciphertext testpasswordr cipher-nopass-1 test-password.zip cipher.bin {} "decryption failed - no password provided" -returnCodes error testpasswordr cipher-nopass-2 test-password2.zip cipher.bin {} "decryption failed - no password provided" -returnCodes error testpasswordr cipher-badpass-1 test-password.zip cipher.bin badpassword "invalid password" -returnCodes error testpasswordr cipher-badpass-2 test-password2.zip cipher.bin badpassword "invalid password" -returnCodes error - testpasswordr cipher-deflate test-password.zip cipher-deflate.bin password [lseq 100] -constraints bug-bbe7c6ff9e + testpasswordr cipher-deflate test-password.zip cipher-deflate.bin password [lseq 100] testpasswordr cipher-deflate-nopass test-password.zip cipher-deflate.bin {} "decryption failed - no password provided" -returnCodes error testpasswordr cipher-deflate-badpass test-password.zip cipher-deflate.bin badpassword "invalid password" -returnCodes error proc testpasswordw {id zippath filename password mode result args} { - variable defaultMountPoint + variable defMountPt set zippath [zippath $zippath] - set path [file join $defaultMountPoint $filename] + set path [file join $defMountPt $filename] set body { set fd [open $path $mode] fconfigure $fd -translation binary @@ -1249,9 +1300,9 @@ namespace eval test_ns_zipfs { test zipfs-password-write-$id "zipfs write $id" -setup { unset -nocomplain fd if {$password ne ""} { - zipfs mount $zippath $defaultMountPoint $password + zipfs mount $zippath $defMountPt $password } else { - zipfs mount $zippath $defaultMountPoint + zipfs mount $zippath $defMountPt } } -cleanup { # In case open succeeded when it should not @@ -1259,7 +1310,7 @@ namespace eval test_ns_zipfs { close $fd } cleanup - } -body $body -result $result {*}$args + } -body $body -result $result {*}$args -constraints bbe7c6ff9e } # NOTE: test-password.zip is the DOS time based encryption header validity check (infozip style) # test-password2.zip is the CRC based encryption header validity check (pkware style) @@ -1283,11 +1334,11 @@ namespace eval test_ns_zipfs { # # CRC errors proc testcrc {id zippath filename result args} { - variable defaultMountPoint + variable defMountPt set zippath [zippath $zippath] test zipfs-crc-$id "zipfs crc $id" -setup { unset -nocomplain fd - zipfs mount $zippath $defaultMountPoint + zipfs mount $zippath $defMountPt } -cleanup { # In case mount succeeded when it should not if {[info exists fd]} { @@ -1295,16 +1346,16 @@ namespace eval test_ns_zipfs { } cleanup } -body { - set fd [open [file join $defaultMountPoint $filename]] + set fd [open [file join $defMountPt $filename]] } -result $result -returnCodes error {*}$args # Mount memory buffer test zipfs-crc-memory-$id "zipfs crc memory $id" -setup { - zipfs mount_data [readbin [zippath $zippath]] $defaultMountPoint + zipfs mount_data [readbin [zippath $zippath]] $defMountPt } -cleanup { cleanup } -body { - set fd [open [file join $defaultMountPoint $filename]] + set fd [open [file join $defMountPt $filename]] } -result $result -returnCodes error {*}$args } testcrc local incons-local-crc.zip a "invalid CRC" @@ -1324,14 +1375,19 @@ namespace eval test_ns_zipfs { } -result 1 # - # file stat + # file stat,lstat + proc fixuptime {t} { + # To compensate for the lack of timezone in zip, all dates + # expressed as strings and translated to local time + if {[regexp {^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d} $t]} { + return [clock scan $t -format "%Y-%m-%d %H:%M:%S"] + } + return $t + } proc fixupstat {stat} { foreach key {atime ctime mtime} { # ZIP files have no TZ info so zipfs uses mktime which is localtime - set time [dict get $stat $key] - if {$time ne "0"} { - dict set stat $key [clock scan [dict get $stat $key] -format "%Y-%m-%d %H:%M:%S"] - } + dict set stat $key [fixuptime [dict get $stat $key]] } if {$::tcl_platform(platform) ne "windows"} { dict set stat blksize 0 @@ -1339,101 +1395,115 @@ namespace eval test_ns_zipfs { } return [lsort -stride 2 $stat] } - test zipfs-file-stat-nosuchfile "Read stat of nonexistent file" -setup { - mount [zippath test.zip] - } -cleanup cleanup -body { - file stat [file join $defaultMountPoint nosuchfile] - } -result "could not read \"[file join $defaultMountPoint nosuchfile]\": *" -match glob -returnCodes error - - test zipfs-file-stat-nosuchmount "Read stat of nonexistent mount" -body { - file stat [file join $defaultMountPoint nosuchfile] - } -result "could not read \"[file join $defaultMountPoint nosuchfile]\": no such file or directory" -returnCodes error - - test zipfs-file-stat-file "Read stat of file" -setup { - mount [zippath test.zip] - } -cleanup cleanup -body { - lsort -stride 2 [file stat [file join $defaultMountPoint test]] - } -result [fixupstat {atime {2003-10-06 15:46:42} ctime {2003-10-06 15:46:42} dev 0 gid 0 ino 0 mode 33133 mtime {2003-10-06 15:46:42} nlink 0 size - 5 type file uid 0}] - - test zipfs-file-stat-dir "Read stat of dir" -setup { - mount [zippath test.zip] - } -cleanup cleanup -body { - lsort -stride 2 [file stat [file join $defaultMountPoint testdir]] - } -result [fixupstat {atime {2005-01-11 19:03:54} ctime {2005-01-11 19:03:54} dev 0 gid 0 ino 0 mode 16749 mtime {2005-01-11 19:03:54} nlink 0 size 0 type directory uid 0}] - - test zipfs-file-stat-mount "Read stat of mount point" -setup { - mount [zippath test.zip] - } -cleanup cleanup -body { - lsort -stride 2 [file stat $defaultMountPoint] - } -result [fixupstat {atime 0 ctime 0 dev 0 gid 0 ino 0 mode 16749 mtime 0 nlink 0 size 0 type directory uid 0}] - - test zipfs-file-stat-root-mount "Read stat of root" -setup { - mount [zippath test.zip] [zipfs root] - } -cleanup cleanup -body { - lsort -stride 2 [file stat [zipfs root]] - } -result [fixupstat {atime 0 ctime 0 dev 0 gid 0 ino 0 mode 16749 mtime 0 nlink 0 size 0 type directory uid 0}] - - test zipfs-file-stat-root-subdir-mount "Read stat of root when mount is subdir" -setup { - mount [zippath test.zip] - } -cleanup cleanup -body { - lsort -stride 2 [file stat [zipfs root]] - } -result [fixupstat {atime 0 ctime 0 dev 0 gid 0 ino 0 mode 16749 mtime 0 nlink 0 size 0 type directory uid 0}] + # Wraps stat and lstat + proc testzipfsstat {id mountpoint target result args} { + test zipfs-file-stat-$id "file stat $id" -setup { + zipfs mount [zippath test.zip] $mountpoint + } -cleanup cleanup -body { + lsort -stride 2 [file stat [file join $mountpoint $target]] + } -result $result {*}$args - test zipfs-file-stat-level3 "Stat on a directory that is intermediary in a mount point" -setup { - mount [zippath test.zip] [file join $defaultMountPoint mt2] - } -cleanup cleanup -body { - lsort -stride 2 [file stat $defaultMountPoint] - } -result [fixupstat {atime 0 ctime 0 dev 0 gid 0 ino 0 mode 16749 mtime 0 nlink 0 size 0 type directory uid 0}] + test zipfs-file-lstat-$id "file lstat $id" -setup { + mount [zippath test.zip] + } -cleanup cleanup -body { + lsort -stride 2 [file lstat [file join $mountpoint $target]] + } -result $result {*}$args + } + testzipfsstat enoent $defMountPt enoent "could not read \"[file join $defMountPt enoent]\": no such file or directory" -returnCodes error + testzipfsstat nosuchmount $defMountPt //zipfs:/notamount/test "could not read \"//zipfs:/notamount/test\": no such file or directory" -returnCodes error + testzipfsstat file $defMountPt test [fixupstat {atime {2003-10-06 15:46:42} ctime {2003-10-06 15:46:42} dev 0 gid 0 ino 0 mode 33133 mtime {2003-10-06 15:46:42} nlink 0 size 5 type file uid 0}] + testzipfsstat dir $defMountPt testdir [fixupstat {atime {2005-01-11 19:03:54} ctime {2005-01-11 19:03:54} dev 0 gid 0 ino 0 mode 16749 mtime {2005-01-11 19:03:54} nlink 0 size 0 type directory uid 0}] + testzipfsstat root-mount [zipfs root] [zipfs root] [fixupstat {atime .* ctime .* dev 0 gid 0 ino 0 mode 16749 mtime .* nlink 0 size 0 type directory uid 0}] -match regexp + testzipfsstat root-subdir-mount $defMountPt [zipfs root] [fixupstat {atime .* ctime .* dev 0 gid 0 ino 0 mode 16749 mtime .* nlink 0 size 0 type directory uid 0}] -match regexp + testzipfsstat mezzo [file join $defMountPt mt2] $defMountPt [fixupstat {atime .* ctime .* dev 0 gid 0 ino 0 mode 16749 mtime .* nlink 0 size 0 type directory uid 0}] -match regexp # # glob of zipfs file - proc testzipfsglob {id mountpoint pat result {globopt {}} args} { - test zipfs-glob-$id "zipfs glob $id" -setup { - mount [zippath test.zip] $mountpoint - } -cleanup { - cleanup - } -body { - lsort [glob {*}$globopt $pat] - } -result $result {*}$args + proc testzipfsglob {id mounts cmdopts result args} { + set setup { + foreach {zippath mountpoint} $mounts { + zipfs mount [zippath $zippath] [file join [zipfs root] $mountpoint] + } + } + if {[dict exists $args -setup]} { + append setup \n[dict get $args -setup] + dict unset args -setup + } + set cleanup cleanup + if {[dict exists $args -cleanup]} { + set cleanup "[dict get $args -cleanup]\n$cleanup" + dict unset args -cleanup + } + test zipfs-glob-$id "zipfs glob $id $cmdopts" -body { + lsort [glob {*}$cmdopts] + } -setup $setup -cleanup $cleanup -result $result {*}$args } - # Bug 14db54d81e - testzipfsglob root-dir [zipfs root] * {//zipfs:/test //zipfs:/testdir} [list -dir [zipfs root]] -constraints !zipfslib - testzipfsglob root [zipfs root] [file join [zipfs root] *] {//zipfs:/test //zipfs:/testdir} {} -constraints !zipfslib - testzipfsglob pattern $defaultMountPoint [file join $defaultMountPoint testdir t*] \ - [file join $defaultMountPoint testdir test2] - testzipfsglob files $defaultMountPoint [file join $defaultMountPoint t*] \ - [list [file join $defaultMountPoint test]] {-type f} - testzipfsglob dirs $defaultMountPoint [file join $defaultMountPoint t*] \ - [list [file join $defaultMountPoint testdir]] {-type d} - testzipfsglob no-match $defaultMountPoint [file join $defaultMountPoint testdir x*] {} {} - testzipfsglob no-match-nocomplain $defaultMountPoint [file join $defaultMountPoint testdir x*] {} {-nocomplain} - testzipfsglob mountpoint $defaultMountPoint [file join [zipfs root] *] \ - [list $defaultMountPoint] {} -constraints !zipfslib + + set basicMounts [list test.zip $defMountPt] + testzipfsglob basic $basicMounts [list $defMountPt/*] [zipfspathsmt $defMountPt test testdir] + testzipfsglob basic-pat $basicMounts [list $defMountPt/t*d*] [zipfspathsmt $defMountPt testdir] + testzipfsglob basic-deep $basicMounts [list $defMountPt/tes*/*] [zipfspathsmt $defMountPt testdir/test2] + testzipfsglob basic-dir $basicMounts [list -directory $defMountPt *] [zipfspathsmt $defMountPt test testdir] + testzipfsglob basic-dir-tails $basicMounts [list -tails -dir $defMountPt *] [list test testdir] + testzipfsglob basic-type-d $basicMounts [list -type d $defMountPt/*] [zipfspathsmt $defMountPt testdir] + testzipfsglob basic-type-f $basicMounts [list -type f $defMountPt/*] [zipfspathsmt $defMountPt test] + testzipfsglob basic-path $basicMounts [list -path $defMountPt/t *d*] [zipfspathsmt $defMountPt testdir] + testzipfsglob basic-enoent $basicMounts [list $defMountPt/x*] {} + testzipfsglob basic-enoent-ok $basicMounts [list -nocomplain $defMountPt/x*] {} + + # NOTE: test root mounts separately because some bugs only showed up on these + set rootMounts [list test.zip /] + testzipfsglob root-1 $rootMounts [list [zipfs root]*] [zipfspaths $::zipLibTop test testdir] -constraints zipfslib + testzipfsglob root-2 $rootMounts [list [zipfs root]*] [zipfspaths test testdir] -constraints !zipfslib + testzipfsglob root-pat $rootMounts [list [zipfs root]t*d*] [zipfspaths testdir] + testzipfsglob root-deep $rootMounts [list [zipfs root]tes*/*] [zipfspaths testdir/test2] + testzipfsglob root-dir-1 $rootMounts [list -directory [zipfs root] *] [zipfspaths $::zipLibTop test testdir] -constraints zipfslib + testzipfsglob root-dir-2 $rootMounts [list -directory [zipfs root] *] [zipfspaths test testdir] -constraints !zipfslib + testzipfsglob root-dir-tails-1 $rootMounts [list -tails -dir [zipfs root] *] [list $::zipLibTop test testdir] -constraints zipfslib + testzipfsglob root-dir-tails-2 $rootMounts [list -tails -dir [zipfs root] *] [list test testdir] -constraints !zipfslib + testzipfsglob root-type-d-1 $rootMounts [list -type d [zipfs root]*] [zipfspaths $::zipLibTop testdir] -constraints zipfslib + testzipfsglob root-type-d-2 $rootMounts [list -type d [zipfs root]*] [zipfspaths testdir] -constraints !zipfslib + testzipfsglob root-type-f $rootMounts [list -type f [zipfs root]*] [zipfspaths test] + testzipfsglob root-path $rootMounts [list -path [zipfs root]t *d*] [zipfspaths testdir] + testzipfsglob root-enoent $rootMounts [list [zipfs root]x*] {} + testzipfsglob root-enoent-ok $rootMounts [list -nocomplain [zipfs root]x*] {} + + # glob operations on intermediate directories (mezzo) in mount + # paths is another source of bugs + set mezzoMounts [list test.zip $defMountPt/a/b test-overlay.zip $defMountPt/a/c] + testzipfsglob mezzo-root-1 $mezzoMounts [list [zipfs root]*] [zipfspaths $::zipLibTop $defMountPt] -constraints zipfslib + testzipfsglob mezzo-root-2 $mezzoMounts [list [zipfs root]*] [list $defMountPt] -constraints !zipfslib + testzipfsglob mezzo-mountgrandparent $mezzoMounts [list $defMountPt/*] [list $defMountPt/a] + testzipfsglob mezzo-mountparent $mezzoMounts [list $defMountPt/a/*] [zipfspathsmt $defMountPt/a b c] + testzipfsglob mezzo-overlay [list test.zip $defMountPt/a/b test-overlay.zip $defMountPt/a] [list $defMountPt/a/*] [zipfspathsmt $defMountPt/a b test2 test3] # # file attributes - proc testzipfsfileattr [list id path result [list mountpoint $defaultMountPoint] args] { + proc testzipfsfileattr [list id path result [list mountpoint $defMountPt] args] { test zipfs-file-attrs-$id "zipfs file attrs $id" -setup { mount [zippath test.zip] $mountpoint } -cleanup cleanup -body { lsort -stride 2 [file attributes $path] } -result $result {*}$args } - testzipfsfileattr noent [file join $defaultMountPoint nosuchfile] \ - {file not found: no such file or directory} $defaultMountPoint -returnCodes error - testzipfsfileattr file [file join $defaultMountPoint test] \ - [list -archive [zippath test.zip] -compsize 5 -crc [expr 0x3BB935C6] -mount $defaultMountPoint -offset 55 -permissions 0o555 -uncompsize 5] - testzipfsfileattr dir [file join $defaultMountPoint testdir] \ - [list -archive [zippath test.zip] -compsize 0 -crc 0 -mount $defaultMountPoint -offset 119 -permissions 0o555 -uncompsize 0] - testzipfsfileattr root [zipfs root] {} {} -constraints bug-4af110a6a1 - testzipfsfileattr mountpoint $defaultMountPoint \ - [list -archive [zippath test.zip] -compsize 0 -crc 0 -mount $defaultMountPoint -offset 0 -permissions 0o555 -uncompsize 0] - testzipfsfileattr mezzo [file join $defaultMountPoint a b] {} [file join $defaultMountPoint a b c] -constraints bug-4af110a6a1 - - - # - # TODO - file copy, file rename etc. + testzipfsfileattr noent [file join $defMountPt nosuchfile] \ + {file not found: no such file or directory} $defMountPt -returnCodes error + testzipfsfileattr file [file join $defMountPt test] \ + [list -archive [zippath test.zip] -compsize 5 -crc [expr 0x3BB935C6] -mount $defMountPt -offset 55 -permissions 0o555 -uncompsize 5] + testzipfsfileattr dir [file join $defMountPt testdir] \ + [list -archive [zippath test.zip] -compsize 0 -crc 0 -mount $defMountPt -offset 119 -permissions 0o555 -uncompsize 0] + testzipfsfileattr root [zipfs root] {-archive {} -compsize 0 -crc 0 -mount {} -offset 0 -permissions 0o555 -uncompsize 0} + testzipfsfileattr mountpoint $defMountPt \ + [list -archive [zippath test.zip] -compsize 0 -crc 0 -mount $defMountPt -offset 0 -permissions 0o555 -uncompsize 0] + testzipfsfileattr mezzo [file join $defMountPt a b] {-archive {} -compsize 0 -crc 0 -mount {} -offset 0 -permissions 0o555 -uncompsize 0} [file join $defMountPt a b c] + + foreach attr {-uncompsize -compsize -offset -mount -archive -permissions -crc} { + test zipfs-file-attrs-set$attr "Set zipfs file attribute $attr" -setup { + mount [zippath test.zip] + } -cleanup cleanup \ + -body "file attributes [file join $defMountPt test] $attr {}" \ + -result "unsupported operation" -returnCodes error + } # # file normalize @@ -1489,6 +1559,331 @@ namespace eval test_ns_zipfs { testzipfsnormalize relative-13 dir/../../../a [file join [zipfs root] a] [zipfs root] testzipfsnormalize relative-14 a [file join [zipfs root] testdir a] [file join [zipfs root] testdir] + # + # file copy + test zipfs-file-copy-tozip-new {Copy native file to archive} -setup { + mount [zippath test.zip] + } -cleanup { + removeFile $_ + cleanup + } -body { + file copy [set _ [makeFile "" source.tmp]] [file join $defMountPt X] + } -result "error copying \"*source.tmp\" to \"[file join $defMountPt X]\": operation not supported" \ + -match glob -returnCodes error + test zipfs-file-copy-tozip-existing {Copy native file to archive} -setup { + mount [zippath test.zip] + } -cleanup { + removeFile $_ + cleanup + } -body { + file copy [set _ [makeFile "newtext" source.tmp]] [file join $defMountPt test] + } -result "error copying *: file exists" -match glob -returnCodes error + test zipfs-file-copy-tozip-existing-force {Copy native file to archive} -setup { + mount [zippath test.zip] + } -cleanup { + removeFile $_ + cleanup + } -body { + set to [file join $defMountPt test] + file copy -force [set _ [makeFile "newtext" source.tmp]] $to + readbin $to + } -result "newtext\n" + test zipfs-file-copy-tozipdir {Copy native file to archive directory} -setup { + mount [zippath test.zip] + } -cleanup { + removeFile $_ + cleanup + } -body { + file copy [set _ [makeFile "" source.tmp]] [file join $defMountPt testdir] + } -result "error copying \"*source.tmp\" to \"[file join $defMountPt testdir]/source.tmp\": operation not supported" \ + -match glob -returnCodes error + test zipfs-file-copydir-tozipdir {Copy native dir to archive directory} -setup { + mount [zippath test.zip] + } -cleanup { + cleanup + } -body { + file copy [temporaryDirectory] [file join $defMountPt testdir] + } -result "can't create directory *: operation not supported" \ + -match glob -returnCodes error + test zipfs-file-copy-fromzip-new {Copy archive file to native} -setup { + mount [zippath test.zip] + set dst [file join [temporaryDirectory] dst.tmp] + file delete $dst + } -cleanup { + file delete $dst + cleanup + } -body { + file copy [file join $defMountPt test] $dst + readbin $dst + } -result "test\n" + test zipfs-file-copydir-fromzip-1 {Copy archive dir to native} -setup { + mount [zippath test.zip] + set dst [file join [temporaryDirectory] dstdir.tmp] + file delete -force $dst + } -cleanup { + file delete -force $dst + cleanup + } -body { + file copy [file join $defMountPt testdir] $dst + zipfs find $dst + } -result [file join [temporaryDirectory] dstdir.tmp test2] + test zipfs-file-copymount-fromzip-new {Copy archive mount to native} -setup { + mount [zippath test.zip] + set dst [file join [temporaryDirectory] dstdir2.tmp] + file delete -force $dst + } -cleanup { + file delete -force $dst + cleanup + } -body { + file copy $defMountPt $dst + list [file isfile [file join $dst test]] \ + [file isdirectory [file join $dst testdir]] \ + [file isfile [file join $dst testdir test2]] + } -result {1 1 1} + + # + # file delete + test zipfs-file-delete "Delete file in zip archive" -setup { + mount [zippath test.zip] + } -cleanup { + cleanup + } -body { + set file [file join $defMountPt test] + list \ + [file exists $file] \ + [catch {file delete $file} msg] \ + $msg \ + [file exists $file] + } -result [list 1 1 {error deleting "//zipfs:/testmount/test": operation not supported} 1] + + test zipfs-file-delete-enoent "Delete nonexisting path in zip archive" -setup { + mount [zippath test.zip] + } -cleanup { + cleanup + } -body { + set file [file join $defMountPt enoent] + list \ + [file exists $file] \ + [catch {file delete $file} msg] \ + $msg \ + [file exists $file] + } -result [list 0 0 {} 0] + + test zipfs-file-delete-dir "Delete dir in zip archive" -setup { + mount [zippath test.zip] + } -cleanup { + cleanup + } -body { + set dir [file join $defMountPt testdir] + list \ + [file isdirectory $dir] \ + [catch {file delete -force $dir} msg] \ + $msg \ + [file isdirectory $dir] + } -result [list 1 1 {error deleting unknown file: operation not supported} 1] + + # + # file join + test zipfs-file-join-1 "Ensure file join recognizes zipfs path as absolute" -body { + file join /abc [zipfs root]a/b/c + } -result [zipfs root]a/b/c + + # + # file mkdir + test zipfs-file-mkdir {Make a directory in zip archive} -setup { + mount [zippath test.zip] + } -cleanup { + cleanup + } -body { + file mkdir [file join $defMountPt newdir] + } -result "can't create directory \"[file join $defMountPt newdir]\": operation not supported" -returnCodes error + test zipfs-file-mkdir-existing {Make a an existing directory in zip archive} -setup { + mount [zippath test.zip] + } -cleanup { + cleanup + } -body { + set dir [file join $defMountPt testdir] + file mkdir $dir + file isdirectory $dir + } -result 1 + + # Standard paths for file command tests. Because code paths are different, + # we need tests for... + set targetMountParent $defMountPt; # Parent of mount directory + set targetMount [file join $targetMountParent mt] ; # Mount directory + set targetFile [file join $targetMount test]; # Normal file + set targetDir [file join $targetMount testdir]; # Directory + set targetEnoent [file join $targetMount enoent]; # Non-existing path + + proc testzipfsfile {id cmdargs result args} { + variable targetMount + test zipfs-file-$id "file $id on zipfs" -setup { + zipfs mount [zippath test.zip] $targetMount + } -cleanup cleanup -body { + file {*}$cmdargs + } -result $result {*}$args + } + proc testzipfsenotsup {id cmdargs args} { + testzipfsfile $id $cmdargs "*: operation not supported" -match glob -returnCodes error + } + + # + # file atime + + testzipfsfile atime-get-file [list atime $targetFile] [fixuptime {2003-10-06 15:46:42}] + testzipfsfile atime-get-dir [list atime $targetDir] [fixuptime {2005-01-11 19:03:54}] + testzipfsfile atime-get-mount [list atime $targetMount] {\d+} -match regexp + testzipfsfile atime-get-mezzo [list atime $targetMountParent] {\d+} -match regexp + testzipfsfile atime-get-root [list atime [zipfs root]] {\d+} -match regexp + testzipfsfile atime-get-enoent [list atime $targetEnoent] \ + "could not read \"$targetEnoent\": no such file or directory" -returnCodes error + + set t [clock seconds] + testzipfsenotsup atime-set-file [list atime $targetFile $t] + testzipfsenotsup atime-set-dir [list atime $targetDir $t] + testzipfsenotsup atime-set-mount [list atime $targetMount $t] + testzipfsenotsup atime-set-mezzo [list atime $targetMountParent $t] + testzipfsenotsup atime-set-root [list atime [zipfs root] $t] + testzipfsfile atime-set-enoent [list atime $targetEnoent $t] \ + "could not read \"$targetEnoent\": no such file or directory" -returnCodes error + + # + # file dirname + testzipfsfile dirname-file [list dirname $targetFile] $targetMount + testzipfsfile dirname-dir [list dirname $targetDir] $targetMount + testzipfsfile dirname-mount [list dirname $targetMount] $targetMountParent + testzipfsfile dirname-mezzo [list dirname $targetMountParent] [zipfs root] + testzipfsfile dirname-root [list dirname [zipfs root]] [zipfs root] + testzipfsfile dirname-enoent [list dirname $targetEnoent] $targetMount + + # + # file executable + testzipfsfile executable-file [list executable $targetFile] 0 + testzipfsfile executable-dir [list executable $targetDir] 0 + testzipfsfile executable-mount [list executable $targetMount] 0 + testzipfsfile executable-mezzo [list executable $targetMountParent] 0 + testzipfsfile executable-root [list executable [zipfs root]] 0 + testzipfsfile executable-enoent [list executable $targetEnoent] 0 + + # + # file exists + testzipfsfile exists-file [list exists $targetFile] 1 + testzipfsfile exists-dir [list exists $targetDir] 1 + testzipfsfile exists-mount [list exists $targetMount] 1 + testzipfsfile exists-mezzo [list exists $targetMountParent] 1 + testzipfsfile exists-root [list exists [zipfs root]] 1 + testzipfsfile exists-enoent [list exists $targetEnoent] 0 + + # + # file isdirectory + testzipfsfile isdirectory-file [list isdirectory $targetFile] 0 + testzipfsfile isdirectory-dir [list isdirectory $targetDir] 1 + testzipfsfile isdirectory-mount [list isdirectory $targetMount] 1 + testzipfsfile isdirectory-mezzo [list isdirectory $targetMountParent] 1 + testzipfsfile isdirectory-root [list isdirectory [zipfs root]] 1 + testzipfsfile isdirectory-enoent [list isdirectory $targetEnoent] 0 + + # + # file isfile + testzipfsfile isfile-file [list isfile $targetFile] 1 + testzipfsfile isfile-dir [list isfile $targetDir] 0 + testzipfsfile isfile-mount [list isfile $targetMount] 0 + testzipfsfile isfile-mezzo [list isfile $targetMountParent] 0 + testzipfsfile isfile-root [list isfile [zipfs root]] 0 + testzipfsfile isfile-enoent [list isfile $targetEnoent] 0 + + # + # file link + testzipfsfile link-read-enoent [list link [file join $targetDir l]] {could not read link "//zipfs:/testmount/mt/testdir/l": operation not supported} -returnCodes error + testzipfsfile link-read-notalink [list link $targetFile] {could not read link "//zipfs:/testmount/mt/test": operation not supported} -returnCodes error + testzipfsfile link-write [list link [file join $targetDir l] $targetFile] {could not create new link "//zipfs:/testmount/mt/testdir/l" pointing to "//zipfs:/testmount/mt/test": operation not supported} -returnCodes error + + # + # file mtime + + testzipfsfile mtime-get-file [list mtime $targetFile] [fixuptime {2003-10-06 15:46:42}] + testzipfsfile mtime-get-dir [list mtime $targetDir] [fixuptime {2005-01-11 19:03:54}] + testzipfsfile mtime-get-mount [list mtime $targetMount] {\d+} -match regexp + testzipfsfile mtime-get-mezzo [list mtime $targetMountParent] {\d+} -match regexp + testzipfsfile mtime-get-root [list mtime [zipfs root]] {\d+} -match regexp + testzipfsfile mtime-set-enoent [list mtime $targetEnoent $t] \ + "could not read \"$targetEnoent\": no such file or directory" -returnCodes error + + set t [clock seconds] + testzipfsenotsup mtime-set-file [list mtime $targetFile $t] + testzipfsenotsup mtime-set-dir [list mtime $targetDir $t] + testzipfsenotsup mtime-set-mount [list mtime $targetMount $t] + testzipfsenotsup mtime-set-mezzo [list mtime $targetMountParent $t] + testzipfsenotsup mtime-set-root [list mtime [zipfs root] $t] + testzipfsfile mtime-set-enoent-1 [list mtime $targetEnoent $t] \ + "could not read \"$targetEnoent\": no such file or directory" -returnCodes error + + # + # file owned + testzipfsfile owned-file [list owned $targetFile] 1 + testzipfsfile owned-dir [list owned $targetDir] 1 + testzipfsfile owned-mount [list owned $targetMount] 1 + testzipfsfile owned-mezzo [list owned $targetMountParent] 1 + testzipfsfile owned-root [list owned [zipfs root]] 1 + testzipfsfile owned-enoent [list owned $targetEnoent] 0 + + # + # file pathtype + testzipfsfile pathtype [list pathtype $targetFile] absolute + + # + # file readable + testzipfsfile readable-file [list readable $targetFile] 1 + testzipfsfile readable-dir [list readable $targetDir] 1 + testzipfsfile readable-mount [list readable $targetMount] 1 + testzipfsfile readable-mezzo [list readable $targetMountParent] 1 + testzipfsfile readable-root [list readable [zipfs root]] 1 + testzipfsfile readable-enoent [list readable $targetEnoent] 0 + + # + # file separator + testzipfsfile separator [list separator $targetFile] / + + # + # file size + testzipfsfile size-file [list size $targetFile] 5 + testzipfsfile size-dir [list size $targetDir] 0 + testzipfsfile size-mount [list size $targetMount] 0 + testzipfsfile size-mezzo [list size $targetMountParent] 0 + testzipfsfile size-root [list size [zipfs root]] 0 + testzipfsfile size-enoent [list size $targetEnoent] \ + "could not read \"$targetEnoent\": no such file or directory" -returnCodes error + + # + # file split + testzipfsfile split-file [list split $targetFile] [list [zipfs root] testmount mt test] + testzipfsfile split-root [list split [zipfs root]] [list [zipfs root]] + testzipfsfile split-enoent [list split $targetEnoent] [list [zipfs root] testmount mt enoent] + + # + # file system + testzipfsfile system-file [list system $targetFile] {zipfs zip} + testzipfsfile system-root [list system [zipfs root]] {zipfs zip} + testzipfsfile system-enoent [list system $targetEnoent] {zipfs zip} + + # + # file type + testzipfsfile type-file [list type $targetFile] file + testzipfsfile type-dir [list type $targetDir] directory + testzipfsfile type-mount [list type $targetMount] directory + testzipfsfile type-mezzo [list type $targetMountParent] directory + testzipfsfile type-root [list type [zipfs root]] directory + testzipfsfile type-enoent [list type $targetEnoent] {could not read "//zipfs:/testmount/mt/enoent": no such file or directory} -returnCodes error + + # + # file writable + testzipfsfile writable-file [list writable $targetFile] 1 + testzipfsfile writable-dir [list writable $targetDir] 0 + testzipfsfile writable-mount [list writable $targetMount] 0 + testzipfsfile writable-mezzo [list writable $targetMountParent] 0 + testzipfsfile writable-root [list writable [zipfs root]] 0 + testzipfsfile writable-enoent [list writable $targetEnoent] 0 + # TODO - mkkey, mkimg, mkzip, lmkimg, lmkzip testnumargs "zipfs mkkey" "password" "" -constraints zipfs testnumargs "zipfs mkimg" "outfile indir" "?strip? ?password? ?infile?" @@ -1504,10 +1899,39 @@ namespace eval test_ns_zipfs { } -cleanup { cleanup } -body { - set fd [open [file join $defaultMountPoint -]] + set fd [open [file join $defMountPt -]] list [catch {read $fd} message] [close $fd] $message close $fd } -result {file size error (may be zip64)} -returnCodes error + + test bug-8259d74a64 "Crash exiting with open files" -setup { + set path [zippath test.zip] + set script "zipfs mount $path /\n" + append script {open [zipfs root]test} \n + append script "exit\n" + } -body { + set fd [open |[info nameofexecutable] r+] + puts $fd $script + flush $fd + read $fd + close $fd + } -result "" + + # Following will only show a leak with valgrind + test bug-9525f4c8bc "Memory leak with long mount paths" -body { + set mt //zipfs:[string repeat /x 240] + zipfs mount [zippath test.zip] $mt + zipfs unmount $mt + } -result "" + + test bug-33b2486199 "zipfs unmounted on thread exit" -constraints { + thread + } -body { + set before [lsort [zipfs mount]] + thread::release [thread::create] + after 100; # Needed to allow the spawned thread to exit to trigger bug + string equal $before [lsort [zipfs mount]] + } -result 1 } diff --git a/unix/Makefile.in b/unix/Makefile.in index 0601c4d..83728bd 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -235,7 +235,7 @@ PKGS_DIR = $(TOP_DIR)/pkgs # Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below. DLTEST_DIR = @TCL_SRC_DIR@/unix/dltest # Must be absolute to so the corresponding tcltest's tcl_library is absolute. -TCL_BUILDTIME_LIBRARY = @TCL_SRC_DIR@/library +TCL_BUILDTIME_LIBRARY = @TCL_BUILDTIME_LIBRARY@ ZLIB_DIR = ${COMPAT_DIR}/zlib ZLIB_INCLUDE = @ZLIB_INCLUDE@ @@ -888,13 +888,22 @@ SHELL_ENV = @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@} \ TCLLIBPATH="@abs_builddir@/pkgs" \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}" -${TCLTEST_EXE}: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${TCL_STUB_LIB_FILE} ${BUILD_DLTEST} +${TCLTEST_EXE}: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${TCL_STUB_LIB_FILE} ${BUILD_DLTEST} ${TCL_ZIP_FILE} $(MAKE) tcltest-real LIB_RUNTIME_DIR="`pwd`" tcltest-real: ${CC} ${CFLAGS} ${LDFLAGS} ${TCLTEST_OBJS} \ @TCL_BUILD_LIB_SPEC@ ${TCL_STUB_LIB_FILE} ${LIBS} @EXTRA_TCLSH_LIBS@ \ ${CC_SEARCH_FLAGS} -o ${TCLTEST_EXE} + @if test "${ZIPFS_BUILD}" = "2" ; then \ + if test "x$(MACHER)" = "x" ; then \ + cat ${TCL_ZIP_FILE} >> ${TCLTEST_EXE}; \ + else $(MACHER) append ${TCLTEST_EXE} ${TCL_ZIP_FILE} /tmp/macher_output; \ + mv /tmp/macher_output ${TCLTEST_EXE}; chmod u+x ${TCLTEST_EXE}; \ + fi; \ + ${NATIVE_ZIP} -A ${TCLTEST_EXE} \ + || echo 'ignore zip-error by adjust sfx process (not executable?)'; \ + fi # Note, in the targets below TCL_LIBRARY needs to be set or else "make test" # won't work in the case where the compilation directory isn't the same as the diff --git a/unix/configure b/unix/configure index a47e33d..87c7948 100755 --- a/unix/configure +++ b/unix/configure @@ -691,6 +691,7 @@ TCL_PATCH_LEVEL TCL_MINOR_VERSION TCL_MAJOR_VERSION TCL_VERSION +TCL_BUILDTIME_LIBRARY INSTALL_MSGS INSTALL_LIBRARIES TCL_ZIP_FILE @@ -10964,6 +10965,12 @@ INSTALL_LIBRARIES=install-libraries INSTALL_MSGS=install-msgs fi +# Point to tcl script library if we are not embedding it. +if test "${ZIPFS_BUILD}" = 0; then +TCL_BUILDTIME_LIBRARY=${TCL_SRC_DIR}/library +fi + + diff --git a/unix/configure.ac b/unix/configure.ac index 633b568..33e7a32 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -868,11 +868,17 @@ AC_MSG_RESULT([no]) INSTALL_LIBRARIES=install-libraries INSTALL_MSGS=install-msgs fi + +# Point to tcl script library if we are not embedding it. +if test "${ZIPFS_BUILD}" = 0; then +TCL_BUILDTIME_LIBRARY=${TCL_SRC_DIR}/library +fi + AC_SUBST(ZIPFS_BUILD) AC_SUBST(TCL_ZIP_FILE) AC_SUBST(INSTALL_LIBRARIES) AC_SUBST(INSTALL_MSGS) - +AC_SUBST(TCL_BUILDTIME_LIBRARY) #-------------------------------------------------------------------- # The statements below define the symbol TCL_PACKAGE_PATH, which diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index be4c680..ca64a11 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -52,7 +52,7 @@ Pkgb_SubObjCmd( || (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) { char buf[TCL_INTEGER_SPACE]; snprintf(buf, sizeof(buf), "%d", Tcl_GetErrorLine(interp)); - Tcl_AppendResult(interp, " in line: ", buf, NULL); + Tcl_AppendResult(interp, " in line: ", buf, (void *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second)); diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index e0aa45c..60e3864 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -108,18 +108,18 @@ Pkgooa_Init( } if (tclStubsPtr == NULL) { Tcl_AppendResult(interp, "Tcl stubs are not initialized, " - "did you compile using -DUSE_TCL_STUBS? ", NULL); + "did you compile using -DUSE_TCL_STUBS? ", (void *)NULL); return TCL_ERROR; } if (Tcl_OOInitStubs(interp) == NULL) { return TCL_ERROR; } if (tclOOStubsPtr == NULL) { - Tcl_AppendResult(interp, "TclOO stubs are not initialized", NULL); + Tcl_AppendResult(interp, "TclOO stubs are not initialized", (void *)NULL); return TCL_ERROR; } if (tclOOIntStubsPtr == NULL) { - Tcl_AppendResult(interp, "TclOO internal stubs are not initialized", NULL); + Tcl_AppendResult(interp, "TclOO internal stubs are not initialized", (void *)NULL); return TCL_ERROR; } diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index 743e94f..ee92318 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -232,7 +232,7 @@ FindSymbol( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot find symbol \"%s\": %s", symbol, errorStr)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, - NULL); + (void *)NULL); } } return proc; diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index 67e1682..7525abe 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -418,7 +418,7 @@ FindSymbol( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot find symbol \"%s\": %s", symbol, errMsg)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, - NULL); + (void *)NULL); } return (void *)proc; } diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c index 527e893..5acd397 100644 --- a/unix/tclLoadNext.c +++ b/unix/tclLoadNext.c @@ -153,7 +153,7 @@ FindSymbol( if (proc == NULL && interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot find symbol \"%s\"", symbol)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, (void *)NULL); } return proc; } diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index 79a869b..43f29c8 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -170,7 +170,7 @@ FindSymbol( if (proc == NULL && interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot find symbol \"%s\"", symbol)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, (void *)NULL); } return proc; } diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index eea1453..59e4f47 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -112,7 +112,7 @@ typedef struct { if (interp) { \ Tcl_SetObjResult(interp, Tcl_ObjPrintf( \ "%s not supported for this platform", (detail))); \ - Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \ + Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (void *)NULL); \ } /* @@ -278,7 +278,7 @@ FileInputProc( */ do { - bytesRead = read(fsPtr->fd, buf, (size_t)toRead); + bytesRead = read(fsPtr->fd, buf, toRead); } while ((bytesRead < 0) && (errno == EINTR)); if (bytesRead < 0) { @@ -327,7 +327,7 @@ FileOutputProc( return 0; } - written = write(fsPtr->fd, buf, (size_t)toWrite); + written = write(fsPtr->fd, buf, toWrite); if (written >= 0) { return written; } @@ -480,6 +480,20 @@ FileWideSeekProc( *---------------------------------------------------------------------- */ +/* + * Bug ad5a57f2f271: Tcl_NotifyChannel is not a Tcl_FileProc, + * so do not pass it to directly to Tcl_CreateFileHandler. + * Instead, pass a wrapper which is a Tcl_FileProc. + */ +static void +FileWatchNotifyChannelWrapper( + void *clientData, + int mask) +{ + Tcl_Channel channel = (Tcl_Channel)clientData; + Tcl_NotifyChannel(channel, mask); +} + static void FileWatchProc( void *instanceData, /* The file state. */ @@ -490,15 +504,13 @@ FileWatchProc( FileState *fsPtr = (FileState *)instanceData; /* - * Make sure we only register for events that are valid on this file. Note - * that we are passing Tcl_NotifyChannel directly to Tcl_CreateFileHandler - * with the channel pointer as the client data. + * Make sure we only register for events that are valid on this file. */ mask &= fsPtr->validMask; if (mask) { Tcl_CreateFileHandler(fsPtr->fd, mask, - (Tcl_FileProc *) Tcl_NotifyChannel, fsPtr->channel); + FileWatchNotifyChannelWrapper, fsPtr->channel); } else { Tcl_DeleteFileHandler(fsPtr->fd); } @@ -829,7 +841,7 @@ TtySetOptionProc( "bad value for -handshake: must be one of" " xonxoff, rtscts, dtrdsr or none", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", NULL); + "VALUE", (void *)NULL); } return TCL_ERROR; } @@ -850,7 +862,7 @@ TtySetOptionProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -xchar: should be a list of" " two elements with each a single 8-bit character", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", (void *)NULL); } Tcl_Free(argv); return TCL_ERROR; @@ -916,7 +928,7 @@ TtySetOptionProc( "bad value for -ttycontrol: should be a list of" " signal,value pairs", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", NULL); + "VALUE", (void *)NULL); } Tcl_Free(argv); return TCL_ERROR; @@ -958,7 +970,7 @@ TtySetOptionProc( "bad signal \"%s\" for -ttycontrol: must be" " DTR, RTS or BREAK", argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", NULL); + "VALUE", (void *)NULL); } Tcl_Free(argv); return TCL_ERROR; @@ -990,7 +1002,7 @@ TtySetOptionProc( "bad mode \"%s\" for -closemode: must be" " default, discard, or drain", value)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", NULL); + "VALUE", (void *)NULL); } return TCL_ERROR; } @@ -1048,7 +1060,7 @@ TtySetOptionProc( "bad mode \"%s\" for -inputmode: must be" " normal, password, raw, or reset", value)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", NULL); + "VALUE", (void *)NULL); } return TCL_ERROR; } @@ -1626,7 +1638,7 @@ TtyParseMode( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s: should be baud,parity,data,stop", bad)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (void *)NULL); } return TCL_ERROR; } @@ -1656,7 +1668,7 @@ TtyParseMode( "n, o, or e" #endif /* PAREXT */ )); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (void *)NULL); } return TCL_ERROR; } @@ -1665,7 +1677,7 @@ TtyParseMode( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s data: should be 5, 6, 7, or 8", bad)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (void *)NULL); } return TCL_ERROR; } @@ -1673,7 +1685,7 @@ TtyParseMode( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s stop: should be 1 or 2", bad)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (void *)NULL); } return TCL_ERROR; } @@ -1780,7 +1792,7 @@ TclpOpenFileChannel( if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), "\": filename is invalid on this platform", - NULL); + (void *)NULL); } return NULL; } @@ -2073,13 +2085,13 @@ Tcl_GetOpenFile( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" wasn't opened for writing", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_WRITABLE", - NULL); + (void *)NULL); return TCL_ERROR; } else if (!forWriting && !(chanMode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" wasn't opened for reading", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_READABLE", - NULL); + (void *)NULL); return TCL_ERROR; } @@ -2111,7 +2123,7 @@ Tcl_GetOpenFile( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot get a FILE * for \"%s\"", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", - "FILE_FAILURE", NULL); + "FILE_FAILURE", (void *)NULL); return TCL_ERROR; } *filePtr = f; @@ -2122,7 +2134,7 @@ Tcl_GetOpenFile( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" cannot be used to get a FILE *", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NO_DESCRIPTOR", - NULL); + (void *)NULL); return TCL_ERROR; } diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 3a6f13c..ec936e0 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -1533,7 +1533,7 @@ SetGroupAttribute( " group \"%s\" does not exist", TclGetString(fileName), string)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETGRP", - "NO_GROUP", NULL); + "NO_GROUP", (void *)NULL); } return TCL_ERROR; } @@ -1604,7 +1604,7 @@ SetOwnerAttribute( " user \"%s\" does not exist", TclGetString(fileName), string)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETOWN", - "NO_USER", NULL); + "NO_USER", (void *)NULL); } return TCL_ERROR; } @@ -1699,7 +1699,7 @@ SetPermissionsAttribute( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown permission string format \"%s\"", modeStringPtr)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", (void *)NULL); } return TCL_ERROR; } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 9c84657..982c36b 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -455,7 +455,7 @@ TclpInitPlatform(void) void TclpInitLibraryPath( char **valuePtr, - TCL_HASH_TYPE *lengthPtr, + size_t *lengthPtr, Tcl_Encoding *encodingPtr) { #define LIBRARY_SIZE 32 @@ -546,9 +546,9 @@ TclpInitLibraryPath( *encodingPtr = Tcl_GetEncoding(NULL, NULL); /* - * Note lengthPtr is (TCL_HASH_TYPE *) which is unsigned so cannot + * Note lengthPtr is (size_t *) which is unsigned so cannot * pass directly to Tcl_GetStringFromObj. - * TODO - why is the type TCL_HASH_TYPE anyways? + * TODO - why is the type size_t anyways? */ Tcl_Size length; str = Tcl_GetStringFromObj(pathPtr, &length); diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 8c0b378..08f60b2 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -1233,6 +1233,20 @@ PipeOutputProc( *---------------------------------------------------------------------- */ +/* + * Bug ad5a57f2f271: Tcl_NotifyChannel is not a Tcl_FileProc, + * so do not pass it to directly to Tcl_CreateFileHandler. + * Instead, pass a wrapper which is a Tcl_FileProc. + */ +static void +PipeWatchNotifyChannelWrapper( + void *clientData, + int mask) +{ + Tcl_Channel channel = (Tcl_Channel)clientData; + Tcl_NotifyChannel(channel, mask); +} + static void PipeWatchProc( void *instanceData, /* The pipe state. */ @@ -1247,7 +1261,7 @@ PipeWatchProc( newmask = mask & (TCL_READABLE | TCL_EXCEPTION); if (newmask) { Tcl_CreateFileHandler(GetFd(psPtr->inFile), newmask, - (Tcl_FileProc *) Tcl_NotifyChannel, psPtr->channel); + PipeWatchNotifyChannelWrapper, psPtr->channel); } else { Tcl_DeleteFileHandler(GetFd(psPtr->inFile)); } @@ -1256,7 +1270,7 @@ PipeWatchProc( newmask = mask & (TCL_WRITABLE | TCL_EXCEPTION); if (newmask) { Tcl_CreateFileHandler(GetFd(psPtr->outFile), newmask, - (Tcl_FileProc *) Tcl_NotifyChannel, psPtr->channel); + PipeWatchNotifyChannelWrapper, psPtr->channel); } else { Tcl_DeleteFileHandler(GetFd(psPtr->outFile)); } diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 1b2fd1b..36ed409 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -146,7 +146,7 @@ static int TcpSetOptionProc(void *instanceData, static void TcpThreadActionProc(void *instanceData, int action); static void TcpWatchProc(void *instanceData, int mask); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); -static void WrapNotify(void *clientData, int mask); +static Tcl_FileProc WrapNotify; /* * This structure describes the channel type structure for TCP socket @@ -1215,10 +1215,10 @@ TcpWatchProc( */ statePtr->interest = mask; - Tcl_CreateFileHandler(statePtr->fds.fd, mask|TCL_READABLE, - (Tcl_FileProc *) WrapNotify, statePtr); + Tcl_CreateFileHandler(statePtr->fds.fd, mask|TCL_READABLE, + WrapNotify, statePtr); } else { - Tcl_DeleteFileHandler(statePtr->fds.fd); + Tcl_DeleteFileHandler(statePtr->fds.fd); } } diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 0f73b57..2c20251 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -162,7 +162,7 @@ TestfilehandlerCmd( return TCL_ERROR; } if (i >= MAX_PIPES) { - Tcl_AppendResult(interp, "bad index ", objv[2], NULL); + Tcl_AppendResult(interp, "bad index ", objv[2], (void *)NULL); return TCL_ERROR; } pipePtr = &testPipes[i]; @@ -191,7 +191,7 @@ TestfilehandlerCmd( return TCL_ERROR; } snprintf(buf, sizeof(buf), "%d %d", pipePtr->readCount, pipePtr->writeCount); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); } else if (strcmp(Tcl_GetString(objv[1]), "create") == 0) { if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "index readMode writeMode"); @@ -200,7 +200,7 @@ TestfilehandlerCmd( if (pipePtr->readFile == NULL) { if (!TclpCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) { Tcl_AppendResult(interp, "couldn't open pipe: ", - Tcl_PosixError(interp), NULL); + Tcl_PosixError(interp), (void *)NULL); return TCL_ERROR; } #ifdef O_NONBLOCK @@ -208,7 +208,7 @@ TestfilehandlerCmd( fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK); #else Tcl_AppendResult(interp, "can't make pipes non-blocking", - NULL); + (void *)NULL); return TCL_ERROR; #endif } @@ -224,7 +224,7 @@ TestfilehandlerCmd( Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0, TestFileHandlerProc, pipePtr); } else { - Tcl_AppendResult(interp, "bad read mode \"", Tcl_GetString(objv[3]), "\"", NULL); + Tcl_AppendResult(interp, "bad read mode \"", Tcl_GetString(objv[3]), "\"", (void *)NULL); return TCL_ERROR; } if (strcmp(Tcl_GetString(objv[4]), "writable") == 0) { @@ -236,7 +236,7 @@ TestfilehandlerCmd( Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0, TestFileHandlerProc, pipePtr); } else { - Tcl_AppendResult(interp, "bad read mode \"", Tcl_GetString(objv[4]), "\"", NULL); + Tcl_AppendResult(interp, "bad read mode \"", Tcl_GetString(objv[4]), "\"", (void *)NULL); return TCL_ERROR; } } else if (strcmp(Tcl_GetString(objv[1]), "empty") == 0) { @@ -268,7 +268,7 @@ TestfilehandlerCmd( memset(buffer, 'b', 10); TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10)); - Tcl_AppendResult(interp, buf, NULL); + Tcl_AppendResult(interp, buf, (void *)NULL); } else if (strcmp(Tcl_GetString(objv[1]), "oneevent") == 0) { Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT); } else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) { @@ -277,7 +277,7 @@ TestfilehandlerCmd( return TCL_ERROR; } if (pipePtr->readFile == NULL) { - Tcl_AppendResult(interp, "pipe ", Tcl_GetString(objv[2]), " doesn't exist", NULL); + Tcl_AppendResult(interp, "pipe ", Tcl_GetString(objv[2]), " doesn't exist", (void *)NULL); return TCL_ERROR; } if (strcmp(Tcl_GetString(objv[3]), "readable") == 0) { @@ -302,7 +302,7 @@ TestfilehandlerCmd( } else { Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), "\": must be close, clear, counts, create, empty, fill, " - "fillpartial, oneevent, wait, or windowevent", NULL); + "fillpartial, oneevent, wait, or windowevent", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -369,13 +369,13 @@ TestfilewaitCmd( mask = TCL_WRITABLE|TCL_READABLE; } else { Tcl_AppendResult(interp, "bad argument \"", Tcl_GetString(objv[2]), - "\": must be readable, writable, or both", NULL); + "\": must be readable, writable, or both", (void *)NULL); return TCL_ERROR; } if (Tcl_GetChannelHandle(channel, (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE, (void **) &data) != TCL_OK) { - Tcl_AppendResult(interp, "couldn't get channel file", NULL); + Tcl_AppendResult(interp, "couldn't get channel file", (void *)NULL); return TCL_ERROR; } fd = PTR2INT(data); @@ -467,7 +467,7 @@ TestforkCmd( pid = fork(); if (pid == -1) { Tcl_AppendResult(interp, - "Cannot fork", NULL); + "Cannot fork", (void *)NULL); return TCL_ERROR; } /* Only needed when pthread_atfork is not present, @@ -522,7 +522,7 @@ TestalarmCmd( action.sa_flags = SA_RESTART; if (sigaction(SIGALRM, &action, NULL) < 0) { - Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL); + Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), (void *)NULL); return TCL_ERROR; } (void) alarm(sec); @@ -531,7 +531,7 @@ TestalarmCmd( Tcl_AppendResult(interp, "warning: sigaction SA_RESTART not support on this platform", - NULL); + (void *)NULL); return TCL_ERROR; #endif } @@ -582,7 +582,7 @@ TestgotsigCmd( TCL_UNUSED(int) /*objc*/, TCL_UNUSED(Tcl_Obj *const *)) { - Tcl_AppendResult(interp, gotsig, NULL); + Tcl_AppendResult(interp, gotsig, (void *)NULL); gotsig = "0"; return TCL_OK; } @@ -634,7 +634,7 @@ TestchmodCmd( } if (chmod(translated, mode) != 0) { Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp), - NULL); + (void *)NULL); return TCL_ERROR; } Tcl_DStringFree(&buffer); diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 5d357c9..71e451f 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -214,7 +214,7 @@ TclpThreadCreate( Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */ void *clientData, /* The one argument to Main() */ - TCL_HASH_TYPE stackSize, /* Size of stack for the new thread */ + size_t stackSize, /* Size of stack for the new thread */ int flags) /* Flags controlling behaviour of the new * thread. */ { @@ -228,7 +228,7 @@ TclpThreadCreate( #ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE if (stackSize != TCL_THREAD_STACK_DEFAULT) { - pthread_attr_setstacksize(&attr, (size_t)stackSize); + pthread_attr_setstacksize(&attr, stackSize); #ifdef TCL_THREAD_STACK_MIN } else { /* diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c index 09b16c5..09f454c 100644 --- a/unix/tclXtTest.c +++ b/unix/tclXtTest.c @@ -117,7 +117,7 @@ TesteventloopCmd( framePtr = oldFramePtr; } else { Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), - "\": must be done or wait", NULL); + "\": must be done or wait", (void *)NULL); return TCL_ERROR; } return TCL_OK; diff --git a/win/Makefile.in b/win/Makefile.in index b9a6d6f..877c4f3 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -126,10 +126,6 @@ ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)') MINIZIP_DIR_NATIVE = $(shell $(CYGPATH) '$(MINIZIP_DIR)') TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') -# Fully qualify library path so that `make test` -# does not depend on the current directory. -LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd -P) -LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)') DLLSUFFIX = @DLLSUFFIX@ LIBSUFFIX = @LIBSUFFIX@ EXESUFFIX = @EXESUFFIX@ @@ -234,6 +230,14 @@ SHARED_BUILD = @SHARED_BUILD@ INSTALL_MSGS = @INSTALL_MSGS@ INSTALL_LIBRARIES = @INSTALL_LIBRARIES@ +# Fully qualify library path so that `make test` +# does not depend on the current directory. +# Only define these if not embedding the library +ifeq ($(ZIPFS_BUILD), 0) +LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd -P) +LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)') +endif + # Minizip MINIZIP_OBJS = \ adler32.$(HOST_OBJEXT) \ diff --git a/win/makefile.vc b/win/makefile.vc index 9f49a82..3883999 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -20,10 +20,10 @@ # or examine Sections 6-8 in rules.vc.
#
# Possible values of TARGET are:
-# release -- Builds the core, the shell and the dlls. (default)
+# release -- Builds everything that ships with a release. (default)
+# core -- Builds the core [tclXX.(dll|lib)]
+# shell -- Builds tclsh and the core.
# dlls -- Just builds the windows extensions
-# shell -- Just builds the shell and the core.
-# core -- Only builds the core [tclXX.(dll|lib)].
# all -- Builds everything.
# test -- Builds and runs the test suite.
# tcltest -- Just builds the test shell.
@@ -141,6 +141,13 @@ RCFILE = tcl.rc # the build configuration, macros, output directories etc.
!include "rules.vc"
+#
+# The tclsh executable without the embedded libzip. We need this
+# separately from tclsh to have dependency and build order work right.
+# Ditto for the DLL and tcltest
+TCLSHRAW=$(TCLSH:.exe=-raw.exe)
+TCLLIBRAW=$(TCLLIB:.dll=-raw.dll)
+
# Tcl version info based on macros set up by rules.vc
DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
@@ -215,6 +222,7 @@ TCLDDELIBNAME = $(PROJECT)9dde$(DDEVERSION)$(SUFX:t=).$(EXT) TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME)
TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe
+TCLTESTRAW = $(TCLTEST:.exe=-raw.exe)
TCLSHOBJS = \
$(TMP_DIR)\tclAppInit.obj \
@@ -474,24 +482,57 @@ TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) #---------------------------------------------------------------------
# Project specific targets
+# There are 4 primary build configurations to consider from the combination
+# of static/shared and embed/noembed of the library zip. The targets are
+# done in the following order.
+# $(TCLLIB) - this is either the core static .lib or the .dll. The target
+# build does not embed the library zip in the DLL irrespective
+# of the noembed setting. A copy is made as $(TCLLIBRAW)
+# as the $(TCLLIB) binary is potentially modified later.
+# dlls - these are the registry and dde DLL's or static libraries
+# $(TCLSH) - the Tcl shell WITHOUT any embedded zip. This needs $(TCLLIB)
+# to be built first as it links against it. A copy is made
+# as $(TCLSHRAW) as $(TCLSH) binary may be modified later.
+# $(TCLSCRIPTZIP) - the zip file that is to be embedded. Note this also
+# ships separately and needs to be built irrespective of the
+# whether it is embedded or not. All above targets need to
+# be built prior as they are used to build the zip (unlike
+# Unix where the external zip program is used.)
+# core - this virtual target builds the final release ready Tcl
+# library. For shared, embedded builds it appends $(TCLSCRIPTZIP)
+# to the $(TCLLIB). For other build configurations, this
+# is a no-op.
+# shell - this virtual target builds the final release ready tclsh shell.
+# For static, embedded builds it appends $(TCLSCRIPTZIP)
+# to the $(TCLSH). For other build configurations, this
+# is a no-op.
+# release - Everything that builds as part of a release
#---------------------------------------------------------------------
-release: setup $(TCLSH) $(TCLSTUBLIB) dlls libtclzip embed pkgs
-core: setup $(TCLLIB) $(TCLSTUBLIB)
-shell: setup $(TCLSH)
-dlls: setup $(TCLREGLIB) $(TCLDDELIB) $(OUT_DIR)\zlib1.dll $(OUT_DIR)\libtommath.dll
-libtclzip: core dlls $(TCLSCRIPTZIP)
-all: setup $(TCLSH) $(TCLSTUBLIB) dlls libtclzip embed pkgs
-embed: setup $(TCLSH) $(TCLSTUBLIB) libtclzip
-!if $(TCL_EMBED_SCRIPTS)
-!if $(STATIC_BUILD)
- @copy /y /b "$(TCLSH)"+"$(TCLSCRIPTZIP)" "$(TCLSH)"
-!else
- @copy /y /b "$(TCLLIB)"+"$(TCLSCRIPTZIP)" "$(TCLLIB)"
+release: setup libtclzip core dlls shell pkgs
+all: setup libtclzip core dlls shell pkgs
+
+core: setup $(TCLLIB)
+!if $(TCL_EMBED_SCRIPTS) && !$(STATIC_BUILD)
+core: libtclzip
+ @$(COPY) /b "$(TCLLIBRAW)"+"$(TCLSCRIPTZIP)" "$(TCLLIB)"
!endif
+
+shell: setup core $(TCLSH)
+!if $(TCL_EMBED_SCRIPTS) && $(STATIC_BUILD)
+shell: libtclzip
+ @$(COPY) /b "$(TCLSHRAW)"+"$(TCLSCRIPTZIP)" "$(TCLSH)"
+!endif
+
+dlls: setup $(TCLREGLIB) $(TCLDDELIB) $(OUT_DIR)\zlib1.dll $(OUT_DIR)\libtommath.dll
+libtclzip: $(TCLSCRIPTZIP)
+
+tcltest: setup core $(TCLTEST) dlls
+!if $(TCL_EMBED_SCRIPTS) && $(STATIC_BUILD)
+tcltest: libtclzip
+ @$(COPY) /b "$(TCLTESTRAW)"+"$(TCLSCRIPTZIP)" "$(TCLTEST)"
!endif
-tcltest: setup $(TCLTEST) dlls
install: install-binaries install-libraries install-docs install-pkgs
!if $(SYMBOLS)
install: install-pdbs
@@ -499,7 +540,7 @@ install: install-pdbs setup: default-setup
test: test-core test-pkgs
-test-core: setup $(TCLTEST) dlls
+test-core: tcltest
set TCL_LIBRARY=$(TCL_TEST_LIBRARY)
$(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
package ifneeded dde 1.4.5 [list load "$(TCLDDELIB:\=/)"]
@@ -510,7 +551,7 @@ runtest: setup $(TCLTEST) dlls set TCL_LIBRARY=$(TCL_TEST_LIBRARY)
$(DEBUGGER) $(TCLTEST) $(SCRIPT)
-runshell: setup $(TCLSH) dlls
+runshell: setup core shell dlls
set TCL_LIBRARY=$(TCL_TEST_LIBRARY)
$(DEBUGGER) $(TCLSH) $(SCRIPT)
@@ -528,6 +569,9 @@ $(TCLLIB): $(TCLOBJS) $**
<<
$(_VC_MANIFEST_EMBED_DLL)
+!if $(TCL_EMBED_SCRIPTS) && !$(STATIC_BUILD)
+ $(COPY) $@ $(TCLLIBRAW)
+!endif
$(TCLIMPLIB): $(TCLLIB)
@@ -539,10 +583,17 @@ $(TCLSTUBLIB): $(TCLSTUBOBJS) $(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB)
$(CONEXECMD) -stack:2300000 $**
$(_VC_MANIFEST_EMBED_EXE)
+!if $(TCL_EMBED_SCRIPTS) && $(STATIC_BUILD)
+ $(COPY) $@ $(TCLSHRAW)
+!endif
+
$(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB)
$(CONEXECMD) -stack:2300000 $**
$(_VC_MANIFEST_EMBED_EXE)
+!if $(TCL_EMBED_SCRIPTS) && $(STATIC_BUILD)
+ $(COPY) $@ $(TCLTESTRAW)
+!endif
!if $(STATIC_BUILD)
$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj
@@ -591,8 +642,9 @@ $(OUT_DIR)\tommath.lib: $(TOMMATHDIR)\win64\tommath.lib $(COPY) $(TOMMATHDIR)\win64\tommath.lib $(OUT_DIR)\tommath.lib
!endif
-$(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB)
- @echo Building Tcl library zip file
+$(TCLSCRIPTZIP): $(TCLLIB) $(TCLSH) dlls
+ @echo Building Tcl library zip file $(TCLSCRIPTZIP)
+ @set TCL_LIBRARY=$(ROOT:\=/)/library
@if exist "$(LIBTCLVFS)" $(RMDIR) "$(LIBTCLVFS)"
@$(MKDIR) "$(LIBTCLVFS)"
@$(CPYDIR) $(LIBDIR) "$(LIBTCLVFS)\tcl_library"
@@ -611,7 +663,6 @@ $(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB) @echo zipfs mkzip {$@} {$(LIBTCLVFS)} {$(LIBTCLVFS)} >> "$(OUT_DIR)\zipper.tcl"
@cd "$(OUT_DIR)" && $(TCLSH_NATIVE) zipper.tcl
-
pkgs:
@for /d %d in ($(PKGSDIR)\*) do \
@if exist "%~fd\win\makefile.vc" ( \
@@ -980,9 +1031,11 @@ install-binaries: !endif
@$(CPY) "$(TCLIMPLIB)" "$(LIB_INSTALL_DIR)\"
@$(CPY) "$(OUT_DIR)\zlib1.dll" "$(BIN_INSTALL_DIR)\"
- @$(CPY) "$(OUT_DIR)\zdll.lib" "$(LIB_INSTALL_DIR)\"
@$(CPY) "$(OUT_DIR)\libtommath.dll" "$(BIN_INSTALL_DIR)\"
+!if !$(STATIC_BUILD)
+ @$(CPY) "$(OUT_DIR)\zdll.lib" "$(LIB_INSTALL_DIR)\"
@$(CPY) "$(OUT_DIR)\tommath.lib" "$(LIB_INSTALL_DIR)\"
+!endif
!if exist($(TCLSH))
@echo Installing $(TCLSHNAME)
@$(CPY) "$(TCLSH)" "$(BIN_INSTALL_DIR)\"
diff --git a/win/nmakehlp.c b/win/nmakehlp.c index c8b39a7..b0799f8 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -19,7 +19,6 @@ #pragma comment (lib, "kernel32.lib") #endif #include <stdio.h> -#include <math.h> /* * This library is required for x64 builds with _some_ versions of MSVC @@ -272,7 +271,7 @@ CheckForCompilerFeature( if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, - "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); + "Tried to launch: \"%s\", but got error [%lu]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars], @@ -406,7 +405,7 @@ CheckForLinkerFeature( if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, - "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); + "Tried to launch: \"%s\", but got error [%lu]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars], diff --git a/win/rules.vc b/win/rules.vc index 3a95aab..bca056c 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1530,6 +1530,10 @@ INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WIN_DIR)" -I"$(COMPATDIR)" # cflags contains generic flags used for building practically all object files
cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\ $(cdebug)
+!if $(TCL_MAJOR_VERSION) == 8 && $(TCL_MINOR_VERSION) < 7
+cflags = $(cflags) -DTcl_Size=int
+!endif
+
# appcflags contains $(cflags) and flags for building the application
# object files (e.g. tclsh, or wish) pkgcflags contains $(cflags) plus
# flags used for building shared object files The two differ in the
diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 9f541f0..7b4caf0 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -1167,7 +1167,7 @@ TclpOpenFileChannel( "couldn't open \"%s\": bad file type", TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE", - NULL); + (void *)NULL); break; } diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 6115739..62a2a36 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -2292,7 +2292,7 @@ ConsoleSetOptionProc( "bad mode \"%s\" for -inputmode: must be" " normal, password, raw, or reset", value)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", NULL); + "VALUE", (void *)NULL); } return TCL_ERROR; } diff --git a/win/tclWinDde.c b/win/tclWinDde.c index d01e7ae..7db5312 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -574,7 +574,7 @@ ExecuteRemoteObject( Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: " "a handler procedure must be defined for use in a safe " "interp", TCL_INDEX_NONE)); - Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL); + Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", (void *)NULL); result = TCL_ERROR; } @@ -1046,7 +1046,7 @@ MakeDdeConnection( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no registered server named \"%s\"", Tcl_DStringValue(&dString))); Tcl_DStringFree(&dString); - Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", (void *)NULL); } return TCL_ERROR; } @@ -1277,7 +1277,7 @@ SetDdeError( } Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, NULL); + Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, (void *)NULL); } /* @@ -1564,7 +1564,7 @@ DdeObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot execute null data", TCL_INDEX_NONE)); Tcl_DStringFree(&dsBuf); - Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", (void *)NULL); result = TCL_ERROR; break; } @@ -1614,7 +1614,7 @@ DdeObjCmd( if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot request value of null data", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", (void *)NULL); result = TCL_ERROR; goto cleanup; } @@ -1680,7 +1680,7 @@ DdeObjCmd( if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot have a null item", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", (void *)NULL); result = TCL_ERROR; goto cleanup; } @@ -1734,7 +1734,7 @@ DdeObjCmd( if (serviceName == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid service name \"\"", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", (void *)NULL); result = TCL_ERROR; goto cleanup; } @@ -1783,7 +1783,7 @@ DdeObjCmd( "permission denied: a handler procedure must be" " defined for use in a safe interp", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK", - NULL); + (void *)NULL); result = TCL_ERROR; } @@ -1848,7 +1848,7 @@ DdeObjCmd( invalidServerResponse: Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid data returned from server", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL); + Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", (void *)NULL); result = TCL_ERROR; goto cleanup; } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index cf71974..c0dd4fd 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -2457,7 +2457,7 @@ TclpFilesystemPathType( return NULL; } - firstSeparator = strchr(path, '/'); + firstSeparator = strchr((char *)path, '/'); if (firstSeparator == NULL) { found = GetVolumeInformationW((const WCHAR *)Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE); diff --git a/win/tclWinInit.c b/win/tclWinInit.c index d682006..b506111 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -124,7 +124,7 @@ TclpInitPlatform(void) void TclpInitLibraryPath( char **valuePtr, - TCL_HASH_TYPE *lengthPtr, + size_t *lengthPtr, Tcl_Encoding *encodingPtr) { #define LIBRARY_SIZE 64 diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 893313c..265c8e7 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -133,32 +133,32 @@ TclpDlopen( if (interp) { switch (lastError) { case ERROR_MOD_NOT_FOUND: - Tcl_SetErrorCode(interp, "WIN_LOAD", "MOD_NOT_FOUND", NULL); + Tcl_SetErrorCode(interp, "WIN_LOAD", "MOD_NOT_FOUND", (void *)NULL); goto notFoundMsg; case ERROR_DLL_NOT_FOUND: - Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL); + Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", (void *)NULL); notFoundMsg: Tcl_AppendToObj(errMsg, "this library or a dependent library" " could not be found in library path", TCL_INDEX_NONE); break; case ERROR_PROC_NOT_FOUND: - Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL); + Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", (void *)NULL); Tcl_AppendToObj(errMsg, "A function specified in the import" " table could not be resolved by the system. Windows" " is not telling which one, I'm sorry.", TCL_INDEX_NONE); break; case ERROR_INVALID_DLL: - Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL); + Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", (void *)NULL); Tcl_AppendToObj(errMsg, "this library or a dependent library" " is damaged", TCL_INDEX_NONE); break; case ERROR_DLL_INIT_FAILED: - Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL); + Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", (void *)NULL); Tcl_AppendToObj(errMsg, "the library initialization" " routine failed", TCL_INDEX_NONE); break; case ERROR_BAD_EXE_FORMAT: - Tcl_SetErrorCode(interp, "WIN_LOAD", "BAD_EXE_FORMAT", NULL); + Tcl_SetErrorCode(interp, "WIN_LOAD", "BAD_EXE_FORMAT", (void *)NULL); Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", TCL_INDEX_NONE); break; default: @@ -227,7 +227,7 @@ FindSymbol( if (proc == NULL && interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot find symbol \"%s\"", symbol)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, (void *)NULL); } return proc; } diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 1ccb105..4157380 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -462,7 +462,7 @@ DeleteKey( if (*keyName == '\0') { Tcl_SetObjResult(interp, Tcl_NewStringObj("bad key: cannot delete root keys", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL); + Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", (void *)NULL); Tcl_Free(buffer); return TCL_ERROR; } @@ -1143,7 +1143,7 @@ ParseKeyName( if (!rootName) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad key \"%s\": must start with a valid root", name)); - Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL); + Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", (void *)NULL); return TCL_ERROR; } @@ -1535,7 +1535,7 @@ AppendSystemError( } snprintf(id, sizeof(id), "%ld", error); - Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL); + Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (void *)NULL); Tcl_AppendToObj(resultPtr, msg, length); Tcl_SetObjResult(interp, resultPtr); diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 821fb96..650c767 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1656,7 +1656,7 @@ SerialSetOptionProc( "bad mode \"%s\" for -closemode: must be" " default, discard, or drain", value)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", NULL); + "VALUE", (void *)NULL); } return TCL_ERROR; } @@ -1681,7 +1681,7 @@ SerialSetOptionProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad value \"%s\" for -mode: should be baud,parity,data,stop", value)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (void *)NULL); } return TCL_ERROR; } @@ -1745,7 +1745,7 @@ SerialSetOptionProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad value \"%s\" for -handshake: must be one of" " xonxoff, rtscts, dtrdsr or none", value)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", (void *)NULL); } return TCL_ERROR; } @@ -1774,7 +1774,7 @@ SerialSetOptionProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -xchar: should be a list of" " two elements with each a single 8-bit character", TCL_INDEX_NONE)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", (void *)NULL); } Tcl_Free((void *)argv); return TCL_ERROR; @@ -1831,7 +1831,7 @@ SerialSetOptionProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad value \"%s\" for -ttycontrol: should be " "a list of signal,value pairs", value)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", (void *)NULL); } Tcl_Free((void *)argv); return TCL_ERROR; @@ -1849,7 +1849,7 @@ SerialSetOptionProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't set DTR signal", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", - "FCONFIGURE", "TTY_SIGNAL", NULL); + "FCONFIGURE", "TTY_SIGNAL", (void *)NULL); } res = TCL_ERROR; break; @@ -1861,7 +1861,7 @@ SerialSetOptionProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't set RTS signal", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", - "FCONFIGURE", "TTY_SIGNAL", NULL); + "FCONFIGURE", "TTY_SIGNAL", (void *)NULL); } res = TCL_ERROR; break; @@ -1873,7 +1873,7 @@ SerialSetOptionProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't set BREAK signal", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", - "FCONFIGURE", "TTY_SIGNAL", NULL); + "FCONFIGURE", "TTY_SIGNAL", (void *)NULL); } res = TCL_ERROR; break; @@ -1884,7 +1884,7 @@ SerialSetOptionProc( "bad signal name \"%s\" for -ttycontrol: must be" " DTR, RTS or BREAK", argv[i])); Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL", - NULL); + (void *)NULL); } res = TCL_ERROR; break; @@ -1924,7 +1924,7 @@ SerialSetOptionProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad value \"%s\" for -sysbuffer: should be " "a list of one or two integers > 0", value)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", (void *)NULL); } return TCL_ERROR; } diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 8de4b50..f54d8a1 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -229,7 +229,7 @@ static WNDCLASSW windowClass; static int TcpConnect(Tcl_Interp *interp, TcpState *state); -static void InitSockets(void); +static void InitSocketWindowClass(void); static TcpState * NewSocketInfo(SOCKET socket); static void SocketExitHandler(void *clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, @@ -345,7 +345,7 @@ printaddrinfolist( void InitializeHostName( char **valuePtr, - TCL_HASH_TYPE *lengthPtr, + size_t *lengthPtr, Tcl_Encoding *encodingPtr) { WCHAR wbuf[256]; @@ -415,11 +415,11 @@ Tcl_GetHostName(void) * * TclInitSockets -- * - * This function just calls InitSockets(), but is protected by a mutex. + * Initialization of sockets for the thread. Also creates message + * handling window class for the process if needed. * * Results: - * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an - * error in interp (if non-NULL). + * Nothing. Panics on failure. * * Side effects: * If not already prepared, initializes the TSD structure and socket @@ -432,13 +432,58 @@ Tcl_GetHostName(void) void TclInitSockets() { - if (!initialized) { - Tcl_MutexLock(&socketMutex); - if (!initialized) { - InitSockets(); - } - Tcl_MutexUnlock(&socketMutex); + /* Then Per thread initialization. */ + DWORD id; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + + if (tsdPtr != NULL) { + return; + } + + InitSocketWindowClass(); + + /* + * OK, this thread has never done anything with sockets before. Construct + * a worker thread to handle asynchronous events related to sockets + * assigned to _this_ thread. + */ + + tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr->pendingTcpState = NULL; + tsdPtr->socketList = NULL; + tsdPtr->hwnd = NULL; + tsdPtr->threadId = Tcl_GetCurrentThread(); + tsdPtr->readyEvent = CreateEventW(NULL, FALSE, FALSE, NULL); + if (tsdPtr->readyEvent == NULL) { + goto initFailure; + } + tsdPtr->socketListLock = CreateEventW(NULL, FALSE, TRUE, NULL); + if (tsdPtr->socketListLock == NULL) { + goto initFailure; } + tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0, + &id); + if (tsdPtr->socketThread == NULL) { + goto initFailure; + } + + SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); + + /* + * Wait for the thread to signal when the window has been created and if + * it is ready to go. + */ + + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + + if (tsdPtr->hwnd != NULL) { + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); + return; + } + + initFailure: + Tcl_Panic("InitSockets failed"); + return; } /* @@ -2322,28 +2367,27 @@ TcpAccept( /* *---------------------------------------------------------------------- * - * InitSockets -- + * InitSocketWindowClass -- * - * Registers the event window for the socket notifier code. - * - * Assumes socketMutex is held. + * Registers the event window class for the socket notifier code. + * Caller must not hold socket mutex lock. * * Results: * None. * * Side effects: - * Register a new window class and creates a - * window for use in asynchronous socket notification. + * Register a new window class. * *---------------------------------------------------------------------- */ static void -InitSockets(void) +InitSocketWindowClass(void) { - DWORD id; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - + if (initialized) { + return; + } + Tcl_MutexLock(&socketMutex); if (!initialized) { initialized = 1; TclCreateLateExitHandler(SocketExitHandler, NULL); @@ -2371,57 +2415,12 @@ InitSockets(void) goto initFailure; } } - - /* - * Check for per-thread initialization. - */ - - if (tsdPtr != NULL) { - return; - } - - /* - * OK, this thread has never done anything with sockets before. Construct - * a worker thread to handle asynchronous events related to sockets - * assigned to _this_ thread. - */ - - tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->pendingTcpState = NULL; - tsdPtr->socketList = NULL; - tsdPtr->hwnd = NULL; - tsdPtr->threadId = Tcl_GetCurrentThread(); - tsdPtr->readyEvent = CreateEventW(NULL, FALSE, FALSE, NULL); - if (tsdPtr->readyEvent == NULL) { - goto initFailure; - } - tsdPtr->socketListLock = CreateEventW(NULL, FALSE, TRUE, NULL); - if (tsdPtr->socketListLock == NULL) { - goto initFailure; - } - tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0, - &id); - if (tsdPtr->socketThread == NULL) { - goto initFailure; - } - - SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); - - /* - * Wait for the thread to signal when the window has been created and if - * it is ready to go. - */ - - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - - if (tsdPtr->hwnd != NULL) { - Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); - return; - } + Tcl_MutexUnlock(&socketMutex); + return; initFailure: + Tcl_MutexUnlock(&socketMutex); /* Probably pointless before panicing */ Tcl_Panic("InitSockets failed"); - return; } /* diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 29bdfe4..9a4c082 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -150,7 +150,7 @@ TesteventloopCmd( framePtr = oldFramePtr; } else { Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), - "\": must be done or wait", NULL); + "\": must be done or wait", (void *)NULL); return TCL_ERROR; } return TCL_OK; @@ -204,11 +204,11 @@ TestvolumetypeCmd( if (found == 0) { Tcl_AppendResult(interp, "could not get volume type for \"", - (path?path:""), "\"", NULL); + (path?path:""), "\"", (void *)NULL); Tcl_WinConvertError(GetLastError()); return TCL_ERROR; } - Tcl_AppendResult(interp, volType, NULL); + Tcl_AppendResult(interp, volType, (void *)NULL); return TCL_OK; #undef VOL_BUF_SIZE } @@ -663,7 +663,7 @@ TestchmodCmd( } if (TestplatformChmod(translated, mode) != 0) { Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp), - NULL); + (void *)NULL); return TCL_ERROR; } Tcl_DStringFree(&buffer); diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index c7f0ba7..37e0841 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -204,7 +204,7 @@ TclpThreadCreate( Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */ void *clientData, /* The one argument to Main(). */ - TCL_HASH_TYPE stackSize, /* Size of stack for the new thread. */ + size_t stackSize, /* Size of stack for the new thread. */ int flags) /* Flags controlling behaviour of the new * thread. */ { |