diff options
515 files changed, 22755 insertions, 24922 deletions
diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob index 306d5a5..656e184 100644 --- a/.fossil-settings/ignore-glob +++ b/.fossil-settings/ignore-glob @@ -48,9 +48,11 @@ libtommath/*.tex macosx/configure unix/autoMkindex.tcl unix/dltest.marker +unix/dltest/embtest unix/dltest/*.bundle unix/dltest/*.dll unix/dltest/*.dylib +unix/dltest/*.exe unix/dltest/*.o unix/dltest/*.sl unix/dltest/*.so diff --git a/.github/dependabot.yml b/.github/dependabot.yml new file mode 100644 index 0000000..203f3c8 --- /dev/null +++ b/.github/dependabot.yml @@ -0,0 +1,6 @@ +version: 2 +updates: +- package-ecosystem: "github-actions" + directory: "/" + schedule: + interval: "weekly" @@ -53,6 +53,7 @@ libtommath/*.tex macosx/configure unix/autoMkindex.tcl unix/dltest.marker +unix/dltest/embtest unix/tcl.pc unix/tclIndex unix/pkgs/* @@ -1,6 +1,6 @@ <?xml version="1.0" encoding="UTF-8"?> <projectDescription> - <name>tcl8</name> + <name>tcl9</name> <comment></comment> <projects> </projects> diff --git a/.travis.yml b/.travis.yml index b63be12..295ba77 100644 --- a/.travis.yml +++ b/.travis.yml @@ -76,13 +76,6 @@ jobs: compiler: clang env: - BUILD_DIR=unix - - name: "Linux/Clang/Shared:NO_DEPRECATED" - os: linux - dist: xenial - compiler: clang - env: - - BUILD_DIR=unix - - CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1" - name: "Linux/Clang/Static" os: linux dist: focal @@ -1,13 +1,24 @@ # README: Tcl -This is the **Tcl 8.7a6** source distribution. +This is the **Tcl 9.0b1** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). +8.6 (production release, daily build) +[](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Linux%22+branch%3Acore-8-6-branch) +[](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Windows%22+branch%3Acore-8-6-branch) +[](https://github.com/tcltk/tcl/actions?query=workflow%3A%22macOS%22+branch%3Acore-8-6-branch) +<br> +8.7 (in development, daily build)) [](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Linux%22+branch%3Acore-8-branch) [](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Windows%22+branch%3Acore-8-branch) [](https://github.com/tcltk/tcl/actions?query=workflow%3A%22macOS%22+branch%3Acore-8-branch) +<br> +9.0 (in development, daily build)) +[](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Linux%22+branch%3Amain) +[](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Windows%22+branch%3Amain) +[](https://github.com/tcltk/tcl/actions?query=workflow%3A%22macOS%22+branch%3Amain) ## Contents 1. [Introduction](#intro) @@ -45,7 +56,7 @@ and selling it either in whole or in part. See the file ## <a id="doc">2.</a> Documentation Extensive documentation is available on our website. The home page for this release, including new features, is -[here](https://www.tcl-lang.org/software/tcltk/8.7.html). +[here](https://www.tcl-lang.org/software/tcltk/9.0.html). Detailed release notes can be found at the [file distributions page](https://sourceforge.net/projects/tcl/files/Tcl/) by clicking on the relevant version. @@ -55,8 +66,8 @@ Xchange](https://www.tcl-lang.org/about/). There have been many Tcl books on the market. Many are mentioned in [the Wiki](https://wiki.tcl-lang.org/_/ref?N=25206). -The complete set of reference manual entries for Tcl 8.7 is [online, -here](https://www.tcl-lang.org/man/tcl8.7/). +The complete set of reference manual entries for Tcl 9.0 is [online, +here](https://www.tcl-lang.org/man/tcl9.0/). ### <a id="doc.unix">2a.</a> Unix Documentation The `doc` subdirectory in this release contains a complete set of @@ -4976,7 +4976,7 @@ msgcat package (duperval, krone, nelson) trace {add|remove|list} {variable|command} name ops command (darley, melski) -2000-09-06 (cross-platform feature) Set ^Z (\32) as default EOF char. (hobbs) +2000-09-06 (cross-platform feature) Set ^Z (\x1A) as default EOF char. (hobbs) 2000-09-07 partial fix for bug 2460 to prevent exec mem leak on Windows for the common case (gravereaux) @@ -9123,6 +9123,26 @@ in this changeset (new minor version) rather than bug fixes: - Released 8.7a3, Nov 21, 2019 --- https://core.tcl-lang.org/tcl/ for details - +Changes to 9.0a1 include all changes to the 8.7 line through 8.7a3, +plus the following, which focuses on the high-level feature changes +in this changeset (new minor version) rather than bug fixes: + +2017-11-03 [TIP 114] Leading zero integer no longer means octal + +2017-11-03 [TIP 278] Revise variable name resolution, solve "Creative Writing" + +2017-11-03 [TIPs 330,336] Encapsulate struct Tcl_Interp + +2017-11-17 [TIP 422] Remove all Tcl_*VA() routines + +2017-12-15 [TIP 488] Disable magic $::tcl_precision + +2018-10-08 [TIP 494] Increased support for size_t value ranges + +2019-05-31 [TIP 537] 64-bit indices in regexp matching + +- Released 9.0a1, Nov 25, 2019 --- https://core.tcl-lang.org/tcl/ for details - + 2019-12-03 (bug)[3cd9be] Corner case in surrogate handling (nijtmans) 2019-12-09 (new) Add tcltest::(Setup|Eval|Cleanup|)Test (coulter,sebres) @@ -9330,6 +9350,24 @@ in this changeset (new minor version) rather than bug fixes: - Released 8.7a5, Jun 18, 2021 --- https://core.tcl-lang.org/tcl/ for details - +Changes to 9.0a3 include all changes to the 8.7 line through 8.7a5, +plus the following, which focuses on the high-level feature changes +in this changeset (new major version) rather than bug fixes: + +Many of the TIPs in Tcl 8.7 mentioned above are extended further in 9.0 + +2020-02-28 [TIP 497] Full support for Unicode planes 1-16 + +2020-08-21 (bug)[43b434] improper calls to stat64() + +2021-04-08 [TIP 595] Unicode-aware loadable library handling. + +2021-04-30 [TIP 596] Stubs support for embedding Tcl in apps + +Many internal changes to broaden support for sizes beyond 32-bits. + +- Released 9.0a3, Jun 23, 2021 --- https://core.tcl-lang.org/tcl/ for details - + 2021-02-02 (new) support for MacOS Big Sur updates (nijtmans) => platform 1.0.17 diff --git a/compat/waitpid.c b/compat/waitpid.c index ec03cab..cd04d8b 100644 --- a/compat/waitpid.c +++ b/compat/waitpid.c @@ -100,7 +100,7 @@ waitpid( } else { prevPtr->nextPtr = waitPtr->nextPtr; } - ckfree(waitPtr); + Tcl_Free(waitPtr); return result; } @@ -156,7 +156,7 @@ waitpid( goto waitAgain; } } - waitPtr = (WaitInfo *) attemptckalloc(sizeof(WaitInfo)); + waitPtr = (WaitInfo *) Tcl_AttemptAlloc(sizeof(WaitInfo)); if (!waitPtr) { errno = ENOMEM; return -1; diff --git a/doc/Access.3 b/doc/Access.3 index 5a29ec2..5a32e08 100644 --- a/doc/Access.3 +++ b/doc/Access.3 @@ -18,6 +18,7 @@ int .sp int \fBTcl_Stat\fR(\fIpath\fR, \fIstatPtr\fR) +.fi .SH ARGUMENTS .AS "struct stat" *statPtr out .AP "const char" *path in diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3 index 357b3eb..05b20b8 100644 --- a/doc/AddErrInfo.3 +++ b/doc/AddErrInfo.3 @@ -9,11 +9,11 @@ .so man.macros .BS .SH NAME -Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_SetErrorLine, Tcl_GetErrorLine, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options +Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorLine, Tcl_GetErrorLine, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options .SH SYNOPSIS .nf \fB#include <tcl.h>\fR -.sp + Tcl_Obj * \fBTcl_GetReturnOptions\fR(\fIinterp, code\fR) .sp @@ -28,10 +28,9 @@ int .sp \fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR) .sp -\fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fB(char *)NULL\fR) -.sp -\fBTcl_SetErrorCodeVA\fR(\fIinterp, argList\fR) +\fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fBNULL\fR) .sp +int \fBTcl_GetErrorLine\fR(\fIinterp\fR) .sp \fBTcl_SetErrorLine\fR(\fIinterp, lineNum\fR) @@ -39,8 +38,8 @@ int const char * \fBTcl_PosixError\fR(\fIinterp\fR) .sp -void \fBTcl_LogCommandInfo\fR(\fIinterp, script, command, commandLength\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp commandLength .AP Tcl_Interp *interp in @@ -60,7 +59,7 @@ unless \fIlength\fR is negative. .AP Tcl_Obj *objPtr in A message to be appended to the \fB\-errorinfo\fR return option in the form of a Tcl_Obj value. -.AP int length in +.AP Tcl_Size length in The number of bytes to copy from \fImessage\fR when appending to the \fB\-errorinfo\fR return option. If negative, all bytes up to the first null byte are used. @@ -69,17 +68,17 @@ The \fB\-errorcode\fR return option will be set to this value. .AP "const char" *element in String to record as one element of the \fB\-errorcode\fR return option. Last \fIelement\fR argument must be NULL. -.AP va_list argList in -An argument list which must have been initialized using -\fBva_start\fR, and cleared using \fBva_end\fR. .AP int lineNum The line number of a script where an error occurred. .AP "const char" *script in -Pointer to first character in script containing command (must be <= command) +Pointer to first character in script containing command +(must be <= \fIcommand\fR). .AP "const char" *command in -Pointer to first character in command that generated the error -.AP int commandLength in -Number of bytes in command; -1 means use all bytes up to first null byte +Pointer to first character in the command that generated the error; must +point within the string given by \fIscript\fR. +.AP Tcl_Size commandLength in +Number of bytes in command; a negative value means use all bytes up to the +first null byte. .BE .SH DESCRIPTION .PP @@ -245,12 +244,6 @@ The procedure \fBTcl_SetErrorCode\fR is also used to set the record instead of a value. Otherwise, it is similar to \fBTcl_SetObjErrorCode\fR in behavior. .PP -\fBTcl_SetErrorCodeVA\fR is the same as \fBTcl_SetErrorCode\fR except that -instead of taking a variable number of arguments it takes an argument list. -Interfaces using argument lists have been found to be nonportable in practice. -This function is deprecated and will be removed in Tcl 9.0. - -.PP The procedure \fBTcl_GetErrorLine\fR is used to read the integer value of the \fB\-errorline\fR return option without the overhead of a full call to \fBTcl_GetReturnOptions\fR. Likewise, \fBTcl_SetErrorLine\fR diff --git a/doc/Alloc.3 b/doc/Alloc.3 index 70b0f7d..493eebc 100644 --- a/doc/Alloc.3 +++ b/doc/Alloc.3 @@ -4,11 +4,11 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures" +.TH Tcl_Alloc 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory +Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo \- allocate or free heap memory .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -16,38 +16,22 @@ Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetM char * \fBTcl_Alloc\fR(\fIsize\fR) .sp -void \fBTcl_Free\fR(\fIptr\fR) .sp -char * +void * \fBTcl_Realloc\fR(\fIptr, size\fR) .sp -char * +void * \fBTcl_AttemptAlloc\fR(\fIsize\fR) .sp -char * +void * \fBTcl_AttemptRealloc\fR(\fIptr, size\fR) .sp -void \fBTcl_GetMemoryInfo\fR(\fIdsPtr\fR) -.sp -char * -\fBckalloc\fR(\fIsize\fR) -.sp -void -\fBckfree\fR(\fIptr\fR) -.sp -char * -\fBckrealloc\fR(\fIptr, size\fR) -.sp -char * -\fBattemptckalloc\fR(\fIsize\fR) -.sp -char * -\fBattemptckrealloc\fR(\fIptr, size\fR) +.fi .SH ARGUMENTS .AS char *size -.AP "unsigned int" size in +.AP "size_t" size in Size in bytes of the memory block to allocate. .AP char *ptr in Pointer to memory block to free or realloc. @@ -84,18 +68,17 @@ allocation fails, these functions will return NULL. Note that on some platforms, but not all, attempting to allocate a zero-sized block of memory will also cause these functions to return NULL. .PP -The procedures \fBckalloc\fR, \fBckfree\fR, \fBckrealloc\fR, -\fBattemptckalloc\fR, and \fBattemptckrealloc\fR are implemented -as macros. Normally, they are synonyms for the corresponding -procedures documented on this page. When Tcl and all modules -calling Tcl are compiled with \fBTCL_MEM_DEBUG\fR defined, however, -these macros are redefined to be special debugging versions -of these procedures. To support Tcl's memory debugging within a -module, use the macros rather than direct calls to \fBTcl_Alloc\fR, etc. - +When a module or Tcl itself is compiled with \fBTCL_MEM_DEBUG\fR defined, +the procedures \fBTcl_Alloc\fR, \fBTcl_Free\fR, \fBTcl_Realloc\fR, +\fBTcl_AttemptAlloc\fR, and \fBTcl_AttempRealloc\fR are implemented +as macros, redefined to be special debugging versions of these procedures. +.PP \fBTcl_GetMemoryInfo\fR appends a list-of-lists of memory stats to the provided DString. This function cannot be used in stub-enabled extensions, -and it is only available if Tcl is compiled with the threaded memory allocator. +and it is only available if Tcl is compiled with the threaded memory allocator +When used in stub-enabled embedders, the stubs table must be first initialized +using one of \fBTcl_InitSubsystems\fR, \fBTcl_SetPanicProc\fR, +\fBTcl_FindExecutable\fR or \fBTclZipfs_AppHook\fR. .SH KEYWORDS alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG diff --git a/doc/AllowExc.3 b/doc/AllowExc.3 index 172bb30..a5e9aa2 100644 --- a/doc/AllowExc.3 +++ b/doc/AllowExc.3 @@ -15,6 +15,7 @@ Tcl_AllowExceptions \- allow all exceptions in next script evaluation \fB#include <tcl.h>\fR .sp \fBTcl_AllowExceptions\fR(\fIinterp\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in @@ -30,8 +31,7 @@ or \fBTCL_RETURN\fR, then Tcl normally converts this into a \fBTCL_ERROR\fR return with an appropriate message. The particular script evaluation procedures of Tcl that act in the manner are \fBTcl_EvalObjEx\fR, \fBTcl_EvalObjv\fR, \fBTcl_Eval\fR, \fBTcl_EvalEx\fR, -\fBTcl_GlobalEval\fR, \fBTcl_GlobalEvalObj\fR, \fBTcl_VarEval\fR and -\fBTcl_VarEvalVA\fR. +\fBTcl_GlobalEval\fR, \fBTcl_GlobalEvalObj\fR and \fBTcl_VarEval\fR. .PP However, if \fBTcl_AllowExceptions\fR is invoked immediately before calling one of those a procedures, then arbitrary completion diff --git a/doc/AppInit.3 b/doc/AppInit.3 index 44b2d6b..e61d188 100644 --- a/doc/AppInit.3 +++ b/doc/AppInit.3 @@ -16,6 +16,7 @@ Tcl_AppInit \- perform application-specific initialization .sp int \fBTcl_AppInit\fR(\fIinterp\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in diff --git a/doc/AssocData.3 b/doc/AssocData.3 index d4fa3d7..c1ca24c 100644 --- a/doc/AssocData.3 +++ b/doc/AssocData.3 @@ -13,12 +13,13 @@ Tcl_GetAssocData, Tcl_SetAssocData, Tcl_DeleteAssocData \- manage associations o .nf \fB#include <tcl.h>\fR .sp -ClientData +void * \fBTcl_GetAssocData\fR(\fIinterp, key, delProcPtr\fR) .sp \fBTcl_SetAssocData\fR(\fIinterp, key, delProc, clientData\fR) .sp \fBTcl_DeleteAssocData\fR(\fIinterp, key\fR) +.fi .SH ARGUMENTS .AS Tcl_InterpDeleteProc **delProcPtr .AP Tcl_Interp *interp in @@ -31,7 +32,7 @@ Procedure to call when \fIinterp\fR is deleted. .AP Tcl_InterpDeleteProc **delProcPtr in Pointer to location in which to store address of current deletion procedure for association. Ignored if NULL. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value associated with the given key in this interpreter. This data is owned by the caller. .BE @@ -64,7 +65,7 @@ the type \fBTcl_InterpDeleteProc\fR: .PP .CS typedef void \fBTcl_InterpDeleteProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR); .CE .PP diff --git a/doc/Async.3 b/doc/Async.3 index e6ec5f8..45ae587 100644 --- a/doc/Async.3 +++ b/doc/Async.3 @@ -17,7 +17,6 @@ Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncMarkFromSignal, Tcl_AsyncInvoke, Tcl_As Tcl_AsyncHandler \fBTcl_AsyncCreate\fR(\fIproc, clientData\fR) .sp -void \fBTcl_AsyncMark\fR(\fIasync\fR) .sp int @@ -26,16 +25,16 @@ int int \fBTcl_AsyncInvoke\fR(\fIinterp, code\fR) .sp -void \fBTcl_AsyncDelete\fR(\fIasync\fR) .sp int \fBTcl_AsyncReady\fR() +.fi .SH ARGUMENTS .AS Tcl_AsyncHandler clientData .AP Tcl_AsyncProc *proc in Procedure to invoke to handle an asynchronous event. -.AP ClientData clientData in +.AP void *clientData in One-word value to pass to \fIproc\fR. .AP Tcl_AsyncHandler async in Token for asynchronous event handler. @@ -95,7 +94,7 @@ type \fBTcl_AsyncProc\fR: .PP .CS typedef int \fBTcl_AsyncProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIcode\fR); .CE diff --git a/doc/BackgdErr.3 b/doc/BackgdErr.3 index adbe33c..4340e4d 100644 --- a/doc/BackgdErr.3 +++ b/doc/BackgdErr.3 @@ -17,6 +17,7 @@ Tcl_BackgroundException, Tcl_BackgroundError \- report Tcl exception that occurr \fBTcl_BackgroundException\fR(\fIinterp, code\fR) .sp \fBTcl_BackgroundError\fR(\fIinterp\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in diff --git a/doc/Backslash.3 b/doc/Backslash.3 deleted file mode 100644 index 1a807f6..0000000 --- a/doc/Backslash.3 +++ /dev/null @@ -1,47 +0,0 @@ -'\" -'\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_Backslash \- parse a backslash sequence -.SH SYNOPSIS -.nf -\fB#include <tcl.h>\fR -.sp -char -\fBTcl_Backslash\fR(\fIsrc, countPtr\fR) -.SH ARGUMENTS -.AS char *countPtr out -.AP "const char" *src in -Pointer to a string starting with a backslash. -.AP int *countPtr out -If \fIcountPtr\fR is not NULL, \fI*countPtr\fR gets filled -in with number of characters in the backslash sequence, including -the backslash character. -.BE - -.SH DESCRIPTION -.PP -The use of \fBTcl_Backslash\fR is deprecated in favor of -\fBTcl_UtfBackslash\fR. -.PP -This is a utility procedure provided for backwards compatibility with -non-internationalized Tcl extensions. It parses a backslash sequence and -returns the low byte of the Unicode character corresponding to the sequence. -\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of -characters in the backslash sequence. -.PP -See the Tcl manual entry for information on the valid backslash sequences. -All of the sequences described in the Tcl manual entry are supported by -\fBTcl_Backslash\fR. -.SH "SEE ALSO" -Tcl(n), Tcl_UtfBackslash(3) - -.SH KEYWORDS -backslash, parse diff --git a/doc/BoolObj.3 b/doc/BoolObj.3 index 71580af..de2a66b 100644 --- a/doc/BoolObj.3 +++ b/doc/BoolObj.3 @@ -24,6 +24,7 @@ int .sp int \fBTcl_GetBoolFromObj\fR(\fIinterp, objPtr, flags. charPtr\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp intValue in/out .AP int intValue in diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 8ddc28c..ae1a79c 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" +.TH Tcl_ByteArrayObj 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME @@ -16,7 +16,6 @@ Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetBytesFromObj, Tcl_GetByteArrayF Tcl_Obj * \fBTcl_NewByteArrayObj\fR(\fIbytes, numBytes\fR) .sp -void \fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, numBytes\fR) .sp .VS TIP568 @@ -29,13 +28,14 @@ unsigned char * .sp unsigned char * \fBTcl_SetByteArrayLength\fR(\fIobjPtr, numBytes\fR) +.fi .SH ARGUMENTS .AS "const unsigned char" *numBytesPtr in/out .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL even if \fInumBytes\fR is non-zero. -.AP int numBytes in -The number of bytes in the array. It must be >= 0. +.AP Tcl_Size numBytes in +The number of bytes in the array. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetByteArrayObj\fR, this points to an unshared value to be overwritten by a byte-array value. For \fBTcl_GetBytesFromObj\fR, @@ -43,11 +43,14 @@ overwritten by a byte-array value. For \fBTcl_GetBytesFromObj\fR, to the value from which to extract an array of bytes. .AP Tcl_Interp *interp in Interpreter to use for error reporting. -.AP int *numBytesPtr out +.AP "Tcl_Size \&| int" *numBytesPtr out Points to space where the number of bytes in the array may be written. -Caller may pass NULL when it does not need this information. +May be (Tcl_Size *)NULL when not used. If it points to a variable which +type is not \fBTcl_Size\fR, a compiler warning will be generated. +If your extensions is compiled with -DTCL_8_API, this function will return +NULL for byte arrays larger than INT_MAX (which should +trigger proper error-handling), otherwise expect it to crash. .BE - .SH DESCRIPTION .PP These routines are used to create, modify, store, transfer, and retrieve @@ -60,7 +63,7 @@ a finite byte sequence. A byte is an 8-bit quantity with no inherent meaning. When the 8 bits are interpreted as an integer value, the range of possible values is (0-255). The C type best suited to store a byte is the \fBunsigned char\fR. -An \fBunsigned char\fR array of size \fIN\fR stores an aribtrary binary +An \fBunsigned char\fR array of size \fIN\fR stores an arbitrary binary value of size \fIN\fR bytes. We call this representation a byte-array. Here we document the routines that allow us to operate on Tcl values as byte-arrays. @@ -92,11 +95,6 @@ returns a pointer to the created value with a reference count of zero. of the unshared \fIobjPtr\fR as appropriate, and keeps its reference count (0 or 1) unchanged. The value produced by these routines has no string representation. Any memory allocation failure may cause a panic. -Note that the type of the \fInumBytes\fR argument is \fBint\fR; consequently -the largest byte-array value that can be produced by these routines is one -holding \fBINT_MAX\fR bytes. Note also that the string representation of -any Tcl value is limited to \fBINT_MAX\fR bytes, so caution should be -taken with any byte-array of more than \fBINT_MAX / 2\fR bytes. .PP \fBTcl_GetBytesFromObj\fR performs the opposite function of \fBTcl_SetByteArrayObj\fR, providing access to read a byte-array from @@ -121,27 +119,12 @@ failure, nothing will be written to \fInumBytesPtr\fR, and if the \fIinterp\fR argument is non-NULL, then error messages and codes are left in it recording the error. .PP -\fBTcl_GetByteArrayFromObj\fR performs nearly the same function as -\fBTcl_GetBytesFromObj\fR. They differ only in the circumstance when -a byte-array internal value must be created by transformation of -a string representation, and that string representation contains a -character with codepoint greater than U+00FF. Instead of failing -the conversion, \fBTcl_GetByteArrayFromObj\fR will use the 8 least -significant bits of each codepoint to produce a valid byte value -from any character codepoint value. In any other circumstance, -\fBTcl_GetByteArrayFromObj\fR performs just as \fBTcl_GetBytesFromObj\fR -does. Since the conversion cannot fail, \fBTcl_GetByteArrayFromObj\fR -has no need for an \fIinterp\fR argument to record any errors and -the caller can assume \fBTcl_GetByteArrayFromObj\fR does not return NULL. -.PP -\fBTcl_GetByteArrayFromObj\fR must be used with caution. Because of the -truncation on conversion, the byte-array made available to the caller -cannot reliably complete a round-trip back to the original string -representation. This creates opportunities for bugs due to blindness -to differences in values. This routine exists in this form primarily -for compatibility with codebases written for earlier releases of Tcl. -It is expected this routine will incompatibly change in Tcl 9 so that -it also signals failed conversions with a NULL return. +\fBTcl_GetByteArrayFromObj\fR performs exactly the same function as +\fBTcl_GetBytesFromObj\fR does when called with the \fIinterp\fR +argument passed the value NULL. This is incompatible with the +way \fBTcl_GetByteArrayFromObj\fR functioned in Tcl 8. +\fBTcl_GetBytesFromObj\fR is the more capable interface and should +usually be favored for use over \fBTcl_GetByteArrayFromObj\fR. .PP On success, both \fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR return a pointer into the internal representation of a \fBTcl_Obj\fR. @@ -153,7 +136,15 @@ and any string representation is invalidated. .PP On success, both \fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR write the number of bytes in the byte-array value of \fIobjPtr\fR -to the space pointed to by \fInumBytesPtr\fR. +to the space pointed to by \fInumBytesPtr\fR. This space may be of type +\fBTcl_Size\fR or of type \fBint\fR. It is recommended that callers provide +a \fBTcl_Size\fR space for this purpose. If the caller provides only +an \fBint\fR space and the number of bytes in the byte-array value of +\fIobjPtr\fR is greater than \fBINT_MAX\fR, the routine will fail due +to being unable to correctly report the byte-array size to the caller. +The ability to provide an \fBint\fR space is best considered a migration +aid for codebases constrained to continue operating with Tcl releases +older than 8.7. .PP \fBTcl_SetByteArrayLength\fR enables a caller to change the size of a byte-array in the internal representation of an unshared \fIobjPtr\fR to @@ -166,8 +157,9 @@ changes the internal representation, \fBTcl_SetByteArrayLength\fR also invalidates any string representation in \fIobjPtr\fR. If resizing grows the byte-array, the new byte values are undefined. If \fIobjPtr\fR does not already possess an internal byte-array, one is produced in the -same way that \fBTcl_GetByteArrayFromObj\fR does, with all the cautions -that go along with that. +same way that \fBTcl_GetBytesFromObj\fR does, also returning NULL +when any characters of the value in \fIobjPtr\fR (up to +\fInumBytes\fR of them) are not valid bytes. .SH "REFERENCE COUNT MANAGEMENT" .PP \fBTcl_NewByteArrayObj\fR always returns a zero-reference object, much diff --git a/doc/CallDel.3 b/doc/CallDel.3 index 33b8afc..418998e 100644 --- a/doc/CallDel.3 +++ b/doc/CallDel.3 @@ -17,13 +17,14 @@ Tcl_CallWhenDeleted, Tcl_DontCallWhenDeleted \- Arrange for callback when interp \fBTcl_CallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR) .sp \fBTcl_DontCallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR) +.fi .SH ARGUMENTS .AS Tcl_InterpDeleteProc clientData .AP Tcl_Interp *interp in Interpreter with which to associated callback. .AP Tcl_InterpDeleteProc *proc in Procedure to call when \fIinterp\fR is deleted. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION @@ -38,7 +39,7 @@ type \fBTcl_InterpDeleteProc\fR: .PP .CS typedef void \fBTcl_InterpDeleteProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR); .CE .PP @@ -60,7 +61,8 @@ If there is no deletion callback that matches \fIinterp\fR, .PP Note that if the callback is being used to delete a resource that \fImust\fR be released on exit, \fBTcl_CreateExitHandler\fR should be used to ensure that -a callback is received even if the application terminates without deleting the interpreter. +a callback is received even if the application terminates without deleting the +interpreter. .SH "SEE ALSO" Tcl_CreateExitHandler(3), Tcl_CreateThreadExitHandler(3) .SH KEYWORDS diff --git a/doc/Cancel.3 b/doc/Cancel.3 index 027fb09..72dd939 100644 --- a/doc/Cancel.3 +++ b/doc/Cancel.3 @@ -17,6 +17,7 @@ int .sp int \fBTcl_Canceled\fR(\fIinterp, flags\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in @@ -30,7 +31,7 @@ OR'ed combination of flag bits that specify additional options. For \fBTcl_CancelEval\fR, only \fBTCL_CANCEL_UNWIND\fR is currently supported. For \fBTcl_Canceled\fR, only \fBTCL_LEAVE_ERR_MSG\fR and \fBTCL_CANCEL_UNWIND\fR are currently supported. -.AP ClientData clientData in +.AP void *clientData in Currently reserved for future use. It should be set to NULL. .BE diff --git a/doc/ChnlStack.3 b/doc/ChnlStack.3 index b046cd2..ba7bc48 100644 --- a/doc/ChnlStack.3 +++ b/doc/ChnlStack.3 @@ -11,7 +11,6 @@ Tcl_StackChannel, Tcl_UnstackChannel, Tcl_GetStackedChannel, Tcl_GetTopChannel \- manipulate stacked I/O channels .SH SYNOPSIS .nf -.nf \fB#include <tcl.h>\fR .sp Tcl_Channel @@ -25,14 +24,14 @@ Tcl_Channel .sp Tcl_Channel \fBTcl_GetTopChannel\fR(\fIchannel\fR) -.sp +.fi .SH ARGUMENTS .AS Tcl_ChannelType clientData .AP Tcl_Interp *interp in Interpreter for error reporting. .AP "const Tcl_ChannelType" *typePtr in The new channel I/O procedures to use for \fIchannel\fR. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to channel I/O procedures. .AP int mask in Conditions under which \fIchannel\fR will be used: OR-ed combination of @@ -49,11 +48,8 @@ I/O channels. Examples include compression and encryption modules. These functions transparently stack and unstack a new channel on top of an existing one. Any number of channels can be stacked together. .PP -The implementation of the Tcl channel code was rewritten in 8.3.2 to -correct some problems with the previous implementation with regard to -stacked channels. Anyone using stacked channels or creating stacked -channel drivers should update to the new \fBTCL_CHANNEL_VERSION_2\fR -\fBTcl_ChannelType\fR structure. See \fBTcl_CreateChannel\fR for details. +The \fBTcl_ChannelType\fR version currently supported is +\fBTCL_CHANNEL_VERSION_5\fR. See \fBTcl_CreateChannel\fR for details. .PP \fBTcl_StackChannel\fR stacks a new \fIchannel\fR on an existing channel with the same name that was registered for \fIchannel\fR by diff --git a/doc/Class.3 b/doc/Class.3 index c89c5f4..ed549c0 100644 --- a/doc/Class.3 +++ b/doc/Class.3 @@ -41,12 +41,12 @@ Tcl_Object int \fBTcl_ObjectDeleted\fR(\fIobject\fR) .sp -ClientData +void * \fBTcl_ObjectGetMetadata\fR(\fIobject, metaTypePtr\fR) .sp \fBTcl_ObjectSetMetadata\fR(\fIobject, metaTypePtr, metadata\fR) .sp -ClientData +void * \fBTcl_ClassGetMetadata\fR(\fIclass, metaTypePtr\fR) .sp \fBTcl_ClassSetMetadata\fR(\fIclass, metaTypePtr, metadata\fR) @@ -63,8 +63,9 @@ Tcl_Class Tcl_Obj * \fBTcl_GetObjectClassName\fR(\fIinterp\fR, \fIobject\fR) .VE "TIP 605" +.fi .SH ARGUMENTS -.AS ClientData metadata in/out +.AS void *metadata in/out .AP Tcl_Interp *interp in/out Interpreter providing the context for looking up or creating an object, and into whose result error messages will be written on failure. @@ -81,11 +82,11 @@ automatically selected. The name of the namespace to create for the object's private use, or NULL if a new unused name is to be automatically selected. The namespace must not already exist. -.AP int objc in +.AP Tcl_Size objc in The number of elements in the \fIobjv\fR array. .AP "Tcl_Obj *const" *objv in The arguments to the command to create the instance of the class. -.AP int skip in +.AP Tcl_Size skip in The number of arguments at the start of the argument array, \fIobjv\fR, that are not arguments to any constructors. This allows the generation of correct error messages even when complicated calling patterns are used (e.g., via the @@ -93,7 +94,7 @@ error messages even when complicated calling patterns are used (e.g., via the .AP Tcl_ObjectMetadataType *metaTypePtr in The type of \fImetadata\fR being set with \fBTcl_ClassSetMetadata\fR or retrieved with \fBTcl_ClassGetMetadata\fR. -.AP ClientData metadata in +.AP void *metadata in An item of metadata to attach to the class, or NULL to remove the metadata associated with a particular \fImetaTypePtr\fR. .AP "Tcl_ObjectMapMethodNameProc" "methodNameMapper" in @@ -200,7 +201,7 @@ a class or object. .PP .CS typedef void \fBTcl_ObjectMetadataDeleteProc\fR( - ClientData \fImetadata\fR); + void *\fImetadata\fR); .CE .PP The \fImetadata\fR argument gives the address of the metadata to be @@ -213,8 +214,8 @@ associated with a class or object. .CS typedef int \fBTcl_CloneProc\fR( Tcl_Interp *\fIinterp\fR, - ClientData \fIsrcMetadata\fR, - ClientData *\fIdstMetadataPtr\fR); + void *\fIsrcMetadata\fR, + void **\fIdstMetadataPtr\fR); .CE .PP The \fIinterp\fR argument gives a place to write an error message when the diff --git a/doc/CmdCmplt.3 b/doc/CmdCmplt.3 index bb7532c..2c18efe 100644 --- a/doc/CmdCmplt.3 +++ b/doc/CmdCmplt.3 @@ -16,6 +16,7 @@ Tcl_CommandComplete \- Check for unmatched braces in a Tcl command .sp int \fBTcl_CommandComplete\fR(\fIcmd\fR) +.fi .SH ARGUMENTS .AS "const char" *cmd .AP "const char" *cmd in diff --git a/doc/Concat.3 b/doc/Concat.3 index e853fc3..5357dae 100644 --- a/doc/Concat.3 +++ b/doc/Concat.3 @@ -16,9 +16,10 @@ Tcl_Concat \- concatenate a collection of strings .sp const char * \fBTcl_Concat\fR(\fIargc, argv\fR) +.fi .SH ARGUMENTS .AS "const char *const" argv[] -.AP int argc in +.AP Tcl_Size argc in Number of strings. .AP "const char *const" argv[] in Array of strings to concatenate. Must have \fIargc\fR entries. diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 index 77a3bc2..fba6253 100644 --- a/doc/CrtAlias.3 +++ b/doc/CrtAlias.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateChild, Tcl_CreateSlave, Tcl_GetChild, Tcl_GetSlave, Tcl_GetParent, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands +Tcl_IsSafe, Tcl_CreateChild, Tcl_GetChild, Tcl_GetParent, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -16,25 +16,13 @@ Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateChild, Tcl_CreateSlave, Tcl_GetChild, Tcl_Ge int \fBTcl_IsSafe\fR(\fIinterp\fR) .sp -int -\fBTcl_MakeSafe\fR(\fIinterp\fR) -.sp Tcl_Interp * \fBTcl_CreateChild\fR(\fIinterp, name, isSafe\fR) .sp Tcl_Interp * -\fBTcl_CreateSlave\fR(\fIinterp, name, isSafe\fR) -.sp -Tcl_Interp * -\fBTcl_GetSlave\fR(\fIinterp, name\fR) -.sp -Tcl_Interp * \fBTcl_GetChild\fR(\fIinterp, name\fR) .sp Tcl_Interp * -\fBTcl_GetMaster\fR(\fIinterp\fR) -.sp -Tcl_Interp * \fBTcl_GetParent\fR(\fIinterp\fR) .sp int @@ -61,6 +49,7 @@ int .sp int \fBTcl_HideCommand\fR(\fIinterp, cmdName, hiddenCmdName\fR) +.fi .SH ARGUMENTS .AS "const char *const" **targetInterpPtr out .AP Tcl_Interp *interp in @@ -81,12 +70,12 @@ Name of source command for alias. Interpreter that contains the target command for an alias. .AP "const char" *targetCmd in Name of target command for alias in \fItargetInterp\fR. -.AP int argc in +.AP Tcl_Size argc in Count of additional arguments to pass to the alias command. .AP "const char *const" *argv in Vector of strings, the additional arguments to pass to the alias command. This storage is owned by the caller. -.AP int objc in +.AP Tcl_Size objc in Count of additional value arguments to pass to the aliased command. .AP Tcl_Obj **objv in Vector of Tcl_Obj structures, the additional value arguments to pass to @@ -142,38 +131,19 @@ child in which Tcl code has access only to set of Tcl commands defined as see the manual entry for the Tcl \fBinterp\fR command for details. If the creation of the new child interpreter failed, \fBNULL\fR is returned. .PP -\fBTcl_CreateSlave\fR is a synonym for \fBTcl_CreateChild\fR. -.PP \fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is .QW safe (was created with the \fBTCL_SAFE_INTERPRETER\fR flag specified), \fB0\fR otherwise. .PP -\fBTcl_MakeSafe\fR marks \fIinterp\fR as -.QW safe , -so that future -calls to \fBTcl_IsSafe\fR will return 1. It also removes all known -potentially-unsafe core functionality (both commands and variables) -from \fIinterp\fR. However, it cannot know what parts of an extension -or application are safe and does not make any attempt to remove those -parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR. -Callers will want to take care with their use of \fBTcl_MakeSafe\fR -to avoid false claims of safety. For many situations, \fBTcl_CreateChild\fR -may be a better choice, since it creates interpreters in a known-safe state. -\fBTcl_MakeSafe\fR is deprecated and will be removed in Tcl 9.0. -.PP \fBTcl_GetChild\fR returns a pointer to a child interpreter of \fIinterp\fR. The child interpreter is identified by \fIname\fR. If no such child interpreter exists, \fBNULL\fR is returned. .PP -\fBTcl_GetSlave\fR is a synonym for \fBTcl_GetChild\fR. -.PP \fBTcl_GetParent\fR returns a pointer to the parent interpreter of \fIinterp\fR. If \fIinterp\fR has no parent (it is a top-level interpreter) then \fBNULL\fR is returned. .PP -\fBTcl_GetMaster\fR is a synonym for \fBTcl_GetParent\fR. -.PP \fBTcl_GetInterpPath\fR stores in the result of \fIinterp\fR the relative path between \fIinterp\fR and \fIchildInterp\fR; \fIchildInterp\fR must be a child of \fIinterp\fR. If the computation diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3 index 1496631..3c622f2 100644 --- a/doc/CrtChannel.3 +++ b/doc/CrtChannel.3 @@ -9,7 +9,7 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelTruncateProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_ChannelThreadActionProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels +Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelWideSeekProc, Tcl_ChannelTruncateProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_ChannelThreadActionProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -17,7 +17,7 @@ Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChanne Tcl_Channel \fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR) .sp -ClientData +void * \fBTcl_GetChannelInstanceData\fR(\fIchannel\fR) .sp const Tcl_ChannelType * @@ -59,13 +59,10 @@ int int \fBTcl_IsChannelExisting\fR(\fIchannelName\fR) .sp -void \fBTcl_CutChannel\fR(\fIchannel\fR) .sp -void \fBTcl_SpliceChannel\fR(\fIchannel\fR) .sp -void \fBTcl_ClearChannelHandlers\fR(\fIchannel\fR) .sp int @@ -80,9 +77,6 @@ Tcl_ChannelTypeVersion Tcl_DriverBlockModeProc * \fBTcl_ChannelBlockModeProc\fR(\fItypePtr\fR) .sp -Tcl_DriverCloseProc * -\fBTcl_ChannelCloseProc\fR(\fItypePtr\fR) -.sp Tcl_DriverClose2Proc * \fBTcl_ChannelClose2Proc\fR(\fItypePtr\fR) .sp @@ -92,9 +86,6 @@ Tcl_DriverInputProc * Tcl_DriverOutputProc * \fBTcl_ChannelOutputProc\fR(\fItypePtr\fR) .sp -Tcl_DriverSeekProc * -\fBTcl_ChannelSeekProc\fR(\fItypePtr\fR) -.sp Tcl_DriverWideSeekProc * \fBTcl_ChannelWideSeekProc\fR(\fItypePtr\fR) .sp @@ -121,7 +112,7 @@ Tcl_DriverFlushProc * .sp Tcl_DriverHandlerProc * \fBTcl_ChannelHandlerProc\fR(\fItypePtr\fR) -.sp +.fi .SH ARGUMENTS .AS "const Tcl_ChannelType" *channelName .AP "const Tcl_ChannelType" *typePtr in @@ -133,7 +124,7 @@ by any other channel. Can be NULL, in which case the channel is created without a name. If the created channel is assigned to one of the standard channels (\fBstdin\fR, \fBstdout\fR or \fBstderr\fR), the assigned channel name will be the name of the standard channel. -.AP ClientData instanceData in +.AP void *instanceData in Arbitrary one-word value to be associated with this channel. This value is passed to procedures in \fItypePtr\fR when they are invoked. .AP int mask in @@ -144,10 +135,10 @@ The channel to operate on. .AP int direction in \fBTCL_READABLE\fR means the input handle is wanted; \fBTCL_WRITABLE\fR means the output handle is wanted. -.AP ClientData *handlePtr out +.AP void **handlePtr out Points to the location where the desired OS-specific handle should be stored. -.AP int size in +.AP Tcl_Size size in The size, in bytes, of buffers to allocate in this channel. .AP int mask in An OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR @@ -302,16 +293,13 @@ name is registered in the (thread)-global list of all channels (result (thread)global list of all channels (of the current thread). Application to a channel still registered in some interpreter is not allowed. -Also notifies the driver if the \fBTcl_ChannelType\fR version is -\fBTCL_CHANNEL_VERSION_4\fR (or higher), and +Also notifies the driver if \fBTcl_DriverThreadActionProc\fR is defined for it. .PP \fBTcl_SpliceChannel\fR adds the specified \fIchannel\fR to the (thread)global list of all channels (of the current thread). Application to a channel registered in some interpreter is not allowed. -Also notifies the driver if the \fBTcl_ChannelType\fR version is -\fBTCL_CHANNEL_VERSION_4\fR (or higher), and -\fBTcl_DriverThreadActionProc\fR is defined for it. +Also notifies the driver if \fBTcl_DriverThreadActionProc\fR is defined for it. .PP \fBTcl_ClearChannelHandlers\fR removes all channel handlers and event scripts associated with the specified \fIchannel\fR, thus shutting @@ -328,13 +316,13 @@ details about the old structure. The \fBTcl_ChannelType\fR structure contains the following fields: .PP .CS -typedef struct Tcl_ChannelType { +typedef struct { const char *\fItypeName\fR; Tcl_ChannelTypeVersion \fIversion\fR; - Tcl_DriverCloseProc *\fIcloseProc\fR; + void *\fIcloseProc\fR; /* Not used any more*/ Tcl_DriverInputProc *\fIinputProc\fR; Tcl_DriverOutputProc *\fIoutputProc\fR; - Tcl_DriverSeekProc *\fIseekProc\fR; + void *\fIseekProc\fR; /* Not used any more */ Tcl_DriverSetOptionProc *\fIsetOptionProc\fR; Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; Tcl_DriverWatchProc *\fIwatchProc\fR; @@ -363,9 +351,8 @@ The user should only use the above structure for \fBTcl_ChannelType\fR instantiation. When referencing fields in a \fBTcl_ChannelType\fR structure, the following functions should be used to obtain the values: \fBTcl_ChannelName\fR, \fBTcl_ChannelVersion\fR, -\fBTcl_ChannelBlockModeProc\fR, \fBTcl_ChannelCloseProc\fR, -\fBTcl_ChannelClose2Proc\fR, \fBTcl_ChannelInputProc\fR, -\fBTcl_ChannelOutputProc\fR, \fBTcl_ChannelSeekProc\fR, +\fBTcl_ChannelBlockModeProc\fR, \fBTcl_ChannelClose2Proc\fR, +\fBTcl_ChannelInputProc\fR, \fBTcl_ChannelOutputProc\fR, \fBTcl_ChannelWideSeekProc\fR, \fBTcl_ChannelThreadActionProc\fR, \fBTcl_ChannelTruncateProc\fR, \fBTcl_ChannelSetOptionProc\fR, \fBTcl_ChannelGetOptionProc\fR, @@ -386,27 +373,10 @@ This value can be retrieved with \fBTcl_ChannelName\fR, which returns a pointer to the string. .SS VERSION .PP - The \fIversion\fR field should be set to the version of the structure -that you require. \fBTCL_CHANNEL_VERSION_2\fR is the minimum recommended. -\fBTCL_CHANNEL_VERSION_3\fR must be set to specify the \fIwideSeekProc\fR member. -\fBTCL_CHANNEL_VERSION_4\fR must be set to specify the \fIthreadActionProc\fR member -(includes \fIwideSeekProc\fR). -\fBTCL_CHANNEL_VERSION_5\fR must be set to specify the -\fItruncateProc\fR members (includes -\fIwideSeekProc\fR and \fIthreadActionProc\fR). -If it is not set to any of these, then this -\fBTcl_ChannelType\fR is assumed to have the original structure. See -\fBOLD CHANNEL TYPES\fR for more details. While Tcl will recognize -and function with either structures, stacked channels must be of at -least \fBTCL_CHANNEL_VERSION_2\fR to function correctly. -.PP -This value can be retrieved with \fBTcl_ChannelVersion\fR, which returns -one of -\fBTCL_CHANNEL_VERSION_5\fR, -\fBTCL_CHANNEL_VERSION_4\fR, -\fBTCL_CHANNEL_VERSION_3\fR, -\fBTCL_CHANNEL_VERSION_2\fR or \fBTCL_CHANNEL_VERSION_1\fR. +that you require. \fBTCL_CHANNEL_VERSION_5\fR is the minimum supported. +.PP +This value can be retrieved with \fBTcl_ChannelVersion\fR. .SS BLOCKMODEPROC .PP The \fIblockModeProc\fR field contains the address of a function called by @@ -415,7 +385,7 @@ the generic layer to set blocking and nonblocking mode on the device. .PP .CS typedef int \fBTcl_DriverBlockModeProc\fR( - ClientData \fIinstanceData\fR, + void *\fIinstanceData\fR, int \fImode\fR); .CE .PP @@ -442,22 +412,23 @@ blocking mode is acceptable to it, and should this also document for the user so that the blocking mode of the channel is not changed to an unacceptable value. Any confusion here may lead the interpreter into a (spurious and difficult to find) deadlock. -.SS "CLOSEPROC AND CLOSE2PROC" +.SS "CLOSE2PROC" .PP -The \fIcloseProc\fR field contains the address of a function called by the +The \fIclose2Proc\fR field contains the address of a function called by the generic layer to clean up driver-related information when the channel is -closed. \fICloseProc\fR must match the following prototype: +closed. \fIClose2Proc\fR must match the following prototype: .PP .CS -typedef int \fBTcl_DriverCloseProc\fR( - ClientData \fIinstanceData\fR, - Tcl_Interp *\fIinterp\fR); +typedef int \fBTcl_DriverClose2Proc\fR( + void *\fIinstanceData\fR, + Tcl_Interp *\fIinterp\fR, + int \fIflags\fR); .CE .PP -The \fIinstanceData\fR argument is the same as the value provided to -\fBTcl_CreateChannel\fR when the channel was created. The function should -release any storage maintained by the channel driver for this channel, and -close the input and output devices encapsulated by this channel. All queued +If \fIflags\fR is 0, the \fIinstanceData\fR argument is the same as the value +provided to \fBTcl_CreateChannel\fR when the channel was created. The function +should release any storage maintained by the channel driver for this channel, +and close the input and output devices encapsulated by this channel. All queued output will have been flushed to the device before this function is called, and no further driver operations will be invoked on this instance after calling the \fIcloseProc\fR. If the close operation is successful, the @@ -466,35 +437,20 @@ error code. In addition, if an error occurs and \fIinterp\fR is not NULL, the procedure should store an error message in the interpreter's result. .PP Alternatively, channels that support closing the read and write sides -independently may set \fIcloseProc\fR to \fBTCL_CLOSE2PROC\fR and set -\fIclose2Proc\fR to the address of a function that matches the -following prototype: -.PP -.CS -typedef int \fBTcl_DriverClose2Proc\fR( - ClientData \fIinstanceData\fR, - Tcl_Interp *\fIinterp\fR, - int \fIflags\fR); -.CE -.PP -The \fIclose2Proc\fR will be called with \fIflags\fR set to an OR'ed +independently may accept other flag values than 0. +Then \fIclose2Proc\fR will be called with \fIflags\fR set to an OR'ed combination of \fBTCL_CLOSE_READ\fR or \fBTCL_CLOSE_WRITE\fR to indicate that the driver should close the read and/or write side of the channel. The channel driver may be invoked to perform additional operations on the channel after \fIclose2Proc\fR is -called to close one or both sides of the channel. If \fIflags\fR is -\fB0\fR (zero), the driver should close the channel in the manner -described above for \fIcloseProc\fR. No further operations will be -invoked on this instance after \fIclose2Proc\fR is called with all -flags cleared. In all cases, the \fIclose2Proc\fR function should -return zero if the close operation was successful; otherwise it should -return a nonzero POSIX error code. In addition, if an error occurs and -\fIinterp\fR is not NULL, the procedure should store an error message -in the interpreter's result. -.PP -The \fIcloseProc\fR and \fIclose2Proc\fR values can be retrieved with -\fBTcl_ChannelCloseProc\fR or \fBTcl_ChannelClose2Proc\fR, which -return a pointer to the respective function. +called to close one or both sides of the channel. In all cases, the +\fIclose2Proc\fR function should return zero if the close operation was +successful; otherwise it should return a nonzero POSIX error code. +In addition, if an error occurs and \fIinterp\fR is not NULL, the procedure +should store an error message in the interpreter's result. +.PP +The \fIclose2Proc\fR value can be retrieved with \fBTcl_ChannelClose2Proc\fR, +which returns a pointer to the function. .SS INPUTPROC .PP The \fIinputProc\fR field contains the address of a function called by the @@ -503,7 +459,7 @@ internal buffer. \fIInputProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverInputProc\fR( - ClientData \fIinstanceData\fR, + void *\fIinstanceData\fR, char *\fIbuf\fR, int \fIbufSize\fR, int *\fIerrorCodePtr\fR); @@ -547,7 +503,7 @@ generic layer to transfer data from an internal buffer to the output device. .PP .CS typedef int \fBTcl_DriverOutputProc\fR( - ClientData \fIinstanceData\fR, + void *\fIinstanceData\fR, const char *\fIbuf\fR, int \fItoWrite\fR, int *\fIerrorCodePtr\fR); @@ -577,17 +533,17 @@ without writing any data. .PP This value can be retrieved with \fBTcl_ChannelOutputProc\fR, which returns a pointer to the function. -.SS "SEEKPROC AND WIDESEEKPROC" +.SS "WIDESEEKPROC" .PP -The \fIseekProc\fR field contains the address of a function called by the +The \fIwideSeekProc\fR field contains the address of a function called by the generic layer to move the access point at which subsequent input or output -operations will be applied. \fISeekProc\fR must match the following +operations will be applied. \fIWideSeekProc\fR must match the following prototype: .PP .CS -typedef int \fBTcl_DriverSeekProc\fR( - ClientData \fIinstanceData\fR, - long \fIoffset\fR, +typedef long long \fBTcl_DriverWideSeekProc\fR( + void *\fIinstanceData\fR, + long long \fIoffset\fR, int \fIseekMode\fR, int *\fIerrorCodePtr\fR); .CE @@ -606,30 +562,8 @@ does not implement seeking. The return value is the new access point or -1 in case of error. If an error occurred, the function should not move the access point. .PP -If there is a non-NULL \fIseekProc\fR field, the \fIwideSeekProc\fR -field may contain the address of an alternative function to use which -handles wide (i.e. larger than 32-bit) offsets, so allowing seeks -within files larger than 2GB. The \fIwideSeekProc\fR will be called -in preference to the \fIseekProc\fR, but both must be defined if the -\fIwideSeekProc\fR is defined. \fIWideSeekProc\fR must match the -following prototype: -.PP -.CS -typedef long long \fBTcl_DriverWideSeekProc\fR( - ClientData \fIinstanceData\fR, - long long \fIoffset\fR, - int \fIseekMode\fR, - int *\fIerrorCodePtr\fR); -.CE -.PP -The arguments and return values mean the same thing as with -\fIseekProc\fR above, except that the type of offsets and the return -type are different. -.PP -The \fIseekProc\fR value can be retrieved with -\fBTcl_ChannelSeekProc\fR, which returns a pointer to the function, -and similarly the \fIwideSeekProc\fR can be retrieved with -\fBTcl_ChannelWideSeekProc\fR. +The \fIwideSseekProc\fR value can be retrieved with +\fBTcl_ChannelWideSeekProc\fR, which returns a pointer to the function. .SS SETOPTIONPROC .PP The \fIsetOptionProc\fR field contains the address of a function called by @@ -638,7 +572,7 @@ the generic layer to set a channel type specific option on a channel. .PP .CS typedef int \fBTcl_DriverSetOptionProc\fR( - ClientData \fIinstanceData\fR, + void *\fIinstanceData\fR, Tcl_Interp *\fIinterp\fR, const char *\fIoptionName\fR, const char *\fInewValue\fR); @@ -679,7 +613,7 @@ channel. \fIgetOptionProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverGetOptionProc\fR( - ClientData \fIinstanceData\fR, + void *\fIinstanceData\fR, Tcl_Interp *\fIinterp\fR, const char *\fIoptionName\fR, Tcl_DString *\fIoptionValue\fR); @@ -717,7 +651,7 @@ notice events of interest on this channel. .PP .CS typedef void \fBTcl_DriverWatchProc\fR( - ClientData \fIinstanceData\fR, + void *\fIinstanceData\fR, int \fImask\fR); .CE .PP @@ -748,9 +682,9 @@ the generic layer to retrieve a device-specific handle from the channel. .PP .CS typedef int \fBTcl_DriverGetHandleProc\fR( - ClientData \fIinstanceData\fR, + void *\fIinstanceData\fR, int \fIdirection\fR, - ClientData *\fIhandlePtr\fR); + void **\fIhandlePtr\fR); .CE .PP \fIInstanceData\fR is the same as the value passed to @@ -777,7 +711,7 @@ It should be set to NULL. .PP .CS typedef int \fBTcl_DriverFlushProc\fR( - ClientData \fIinstanceData\fR); + void *\fIinstanceData\fR); .CE .PP This value can be retrieved with \fBTcl_ChannelFlushProc\fR, which returns @@ -792,7 +726,7 @@ that occur on the underlying (stacked) channel. .PP .CS typedef int \fBTcl_DriverHandlerProc\fR( - ClientData \fIinstanceData\fR, + void *\fIinstanceData\fR, int \fIinterestMask\fR); .CE .PP @@ -821,7 +755,7 @@ might be maintaining using the calling thread as the associate. See .PP .CS typedef void \fBTcl_DriverThreadActionProc\fR( - ClientData \fIinstanceData\fR, + void *\fIinstanceData\fR, int \fIaction\fR); .CE .PP @@ -838,7 +772,7 @@ length. It can be NULL. .PP .CS typedef int \fBTcl_DriverTruncateProc\fR( - ClientData \fIinstanceData\fR, + void *\fIinstanceData\fR, long long \fIlength\fR); .CE .PP @@ -886,58 +820,6 @@ The function takes good care of inserting minus signs before each option, commas after, and an .QW or before the last option. -.SH "OLD CHANNEL TYPES" -The original (8.3.1 and below) \fBTcl_ChannelType\fR structure contains -the following fields: -.PP -.CS -typedef struct Tcl_ChannelType { - const char *\fItypeName\fR; - Tcl_DriverBlockModeProc *\fIblockModeProc\fR; - Tcl_DriverCloseProc *\fIcloseProc\fR; - Tcl_DriverInputProc *\fIinputProc\fR; - Tcl_DriverOutputProc *\fIoutputProc\fR; - Tcl_DriverSeekProc *\fIseekProc\fR; - Tcl_DriverSetOptionProc *\fIsetOptionProc\fR; - Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; - Tcl_DriverWatchProc *\fIwatchProc\fR; - Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; - Tcl_DriverClose2Proc *\fIclose2Proc\fR; -} \fBTcl_ChannelType\fR; -.CE -.PP -It is still possible to create channel with the above structure. The -internal channel code will determine the version. It is imperative to use -the new \fBTcl_ChannelType\fR structure if you are creating a stacked -channel driver, due to problems with the earlier stacked channel -implementation (in 8.2.0 to 8.3.1). -.PP -Prior to 8.4.0 (i.e. during the later releases of 8.3 and early part -of the 8.4 development cycle) the \fBTcl_ChannelType\fR structure -contained the following fields: -.PP -.CS -typedef struct Tcl_ChannelType { - const char *\fItypeName\fR; - Tcl_ChannelTypeVersion \fIversion\fR; - Tcl_DriverCloseProc *\fIcloseProc\fR; - Tcl_DriverInputProc *\fIinputProc\fR; - Tcl_DriverOutputProc *\fIoutputProc\fR; - Tcl_DriverSeekProc *\fIseekProc\fR; - Tcl_DriverSetOptionProc *\fIsetOptionProc\fR; - Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; - Tcl_DriverWatchProc *\fIwatchProc\fR; - Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; - Tcl_DriverClose2Proc *\fIclose2Proc\fR; - Tcl_DriverBlockModeProc *\fIblockModeProc\fR; - Tcl_DriverFlushProc *\fIflushProc\fR; - Tcl_DriverHandlerProc *\fIhandlerProc\fR; - Tcl_DriverTruncateProc *\fItruncateProc\fR; -} \fBTcl_ChannelType\fR; -.CE -.PP -When the above structure is registered as a channel type, the -\fIversion\fR field should always be \fBTCL_CHANNEL_VERSION_2\fR. .SH "SEE ALSO" Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3), Tcl_QueueEvent(3), Tcl_StackChannel(3), Tcl_GetStdChannel(3) .SH KEYWORDS diff --git a/doc/CrtChnlHdlr.3 b/doc/CrtChnlHdlr.3 index 0ecd3c9..5b0e724 100644 --- a/doc/CrtChnlHdlr.3 +++ b/doc/CrtChnlHdlr.3 @@ -12,15 +12,12 @@ Tcl_CreateChannelHandler, Tcl_DeleteChannelHandler \- call a procedure when a channel becomes readable or writable .SH SYNOPSIS .nf -.nf \fB#include <tcl.h>\fR .sp -void \fBTcl_CreateChannelHandler\fR(\fIchannel, mask, proc, clientData\fR) .sp -void \fBTcl_DeleteChannelHandler\fR(\fIchannel, proc, clientData\fR) -.sp +.fi .SH ARGUMENTS .AS Tcl_ChannelProc clientData .AP Tcl_Channel channel in @@ -29,10 +26,10 @@ Tcl channel such as returned by \fBTcl_CreateChannel\fR. Conditions under which \fIproc\fR should be called: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. Specify a zero value to temporarily disable an existing handler. -.AP Tcl_FileProc *proc in +.AP Tcl_ChannelProc *proc in Procedure to invoke whenever the channel indicated by \fIchannel\fR meets the conditions specified by \fImask\fR. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION @@ -48,7 +45,7 @@ what it means for a channel to be readable or writable. .PP .CS typedef void \fBTcl_ChannelProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, int \fImask\fR); .CE .PP diff --git a/doc/CrtCloseHdlr.3 b/doc/CrtCloseHdlr.3 index bac2431..cd59e8a 100644 --- a/doc/CrtCloseHdlr.3 +++ b/doc/CrtCloseHdlr.3 @@ -14,19 +14,17 @@ Tcl_CreateCloseHandler, Tcl_DeleteCloseHandler \- arrange for callbacks when cha .nf \fB#include <tcl.h>\fR .sp -void \fBTcl_CreateCloseHandler\fR(\fIchannel, proc, clientData\fR) .sp -void \fBTcl_DeleteCloseHandler\fR(\fIchannel, proc, clientData\fR) -.sp +.fi .SH ARGUMENTS .AS Tcl_CloseProc clientData .AP Tcl_Channel channel in The channel for which to create or delete a close callback. .AP Tcl_CloseProc *proc in The procedure to call as the callback. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION @@ -38,7 +36,7 @@ Arbitrary one-word value to pass to \fIproc\fR. .PP .CS typedef void \fBTcl_CloseProc\fR( - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .PP The \fIclientData\fR is the same as the value provided in the call to diff --git a/doc/CrtCommand.3 b/doc/CrtCommand.3 index bf76d48..d15a920 100644 --- a/doc/CrtCommand.3 +++ b/doc/CrtCommand.3 @@ -16,6 +16,7 @@ Tcl_CreateCommand \- implement new commands in C .sp Tcl_Command \fBTcl_CreateCommand\fR(\fIinterp, cmdName, proc, clientData, deleteProc\fR) +.fi .SH ARGUMENTS .AS Tcl_CmdDeleteProc *deleteProc .AP Tcl_Interp *interp in @@ -25,7 +26,7 @@ Name of command. .AP Tcl_CmdProc *proc in Implementation of new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in Procedure to call before \fIcmdName\fR is deleted from the interpreter; @@ -75,7 +76,7 @@ and it returns NULL. .PP .CS typedef int \fBTcl_CmdProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIargc\fR, const char *\fIargv\fR[]); @@ -92,11 +93,11 @@ the command name) and \fIargv\fR giving the values of the arguments as strings. The \fIargv\fR array will contain \fIargc\fR+1 values; the first \fIargc\fR values point to the argument strings, and the last value is NULL. +.PP Note that the argument strings should not be modified as they may point to constant strings or may be shared with other parts of the interpreter. -.PP -Note that the argument strings are encoded in normalized UTF-8 since +Note also that the argument strings are encoded in normalized UTF-8 since version 8.1 of Tcl. .PP \fIProc\fR must return an integer code that is expected to be one of @@ -131,7 +132,7 @@ result that match the type \fBTcl_CmdDeleteProc\fR: .PP .CS typedef void \fBTcl_CmdDeleteProc\fR( - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .PP The \fIclientData\fR argument will be the same as the \fIclientData\fR diff --git a/doc/CrtFileHdlr.3 b/doc/CrtFileHdlr.3 index f1b8df7..65a6794 100644 --- a/doc/CrtFileHdlr.3 +++ b/doc/CrtFileHdlr.3 @@ -17,6 +17,7 @@ Tcl_CreateFileHandler, Tcl_DeleteFileHandler \- associate procedure callbacks wi \fBTcl_CreateFileHandler\fR(\fIfd, mask, proc, clientData\fR) .sp \fBTcl_DeleteFileHandler\fR(\fIfd\fR) +.fi .SH ARGUMENTS .AS Tcl_FileProc clientData .AP int fd in @@ -29,7 +30,7 @@ a handler. .AP Tcl_FileProc *proc in Procedure to invoke whenever the file or device indicated by \fIfile\fR meets the conditions specified by \fImask\fR. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION @@ -51,7 +52,7 @@ type \fBTcl_FileProc\fR: .PP .CS typedef void \fBTcl_FileProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, int \fImask\fR); .CE .PP diff --git a/doc/CrtInterp.3 b/doc/CrtInterp.3 index aacb868..159fb12 100644 --- a/doc/CrtInterp.3 +++ b/doc/CrtInterp.3 @@ -24,6 +24,7 @@ int .sp int \fBTcl_InterpActive\fR(\fIinterp\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in diff --git a/doc/CrtMathFnc.3 b/doc/CrtMathFnc.3 deleted file mode 100644 index bb96fc9..0000000 --- a/doc/CrtMathFnc.3 +++ /dev/null @@ -1,166 +0,0 @@ -'\" -'\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions -.SH "NOTICE OF EVENTUAL DEPRECATION" -.PP -The \fBTcl_CreateMathFunc\fR and \fBTcl_GetMathFuncInfo\fR functions -are rendered somewhat obsolete by the ability to create functions for -expressions by placing commands in the \fBtcl::mathfunc\fR namespace, -as described in the \fBmathfunc\fR manual page; the API described on -this page is not expected to be maintained indefinitely. -.SH SYNOPSIS -.nf -\fB#include <tcl.h>\fR -.sp -void -\fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) -.sp -int -\fBTcl_GetMathFuncInfo\fR(\fIinterp, name, numArgsPtr, argTypesPtr, procPtr, - clientDataPtr\fR) -.sp -Tcl_Obj * -\fBTcl_ListMathFuncs\fR(\fIinterp, pattern\fR) -.SH ARGUMENTS -.AS Tcl_ValueType *clientDataPtr out -.AP Tcl_Interp *interp in -Interpreter in which new function will be defined. -.AP "const char" *name in -Name for new function. -.AP int numArgs in -Number of arguments to new function; also gives size of \fIargTypes\fR array. -.AP Tcl_ValueType *argTypes in -Points to an array giving the permissible types for each argument to -function. -.AP Tcl_MathProc *proc in -Procedure that implements the function. -.AP ClientData clientData in -Arbitrary one-word value to pass to \fIproc\fR when it is invoked. -.AP int *numArgsPtr out -Points to a variable that will be set to contain the number of -arguments to the function. -.AP Tcl_ValueType **argTypesPtr out -Points to a variable that will be set to contain a pointer to an array -giving the permissible types for each argument to the function which -will need to be freed up using \fITcl_Free\fR. -.AP Tcl_MathProc **procPtr out -Points to a variable that will be set to contain a pointer to the -implementation code for the function (or NULL if the function is -implemented directly in bytecode). -.AP ClientData *clientDataPtr out -Points to a variable that will be set to contain the clientData -argument passed to \fITcl_CreateMathFunc\fR when the function was -created if the function is not implemented directly in bytecode. -.AP "const char" *pattern in -Pattern to match against function names so as to filter them (by -passing to \fITcl_StringMatch\fR), or NULL to not apply any filter. -.BE -.SH DESCRIPTION -.PP -Tcl allows a number of mathematical functions to be used in -expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR. -These functions are represented by commands in the namespace, -\fBtcl::mathfunc\fR. The \fBTcl_CreateMathFunc\fR function is -an obsolete way for applications to add additional functions -to those already provided by Tcl or to replace existing functions. -It should not be used by new applications, which should create -math functions using \fBTcl_CreateObjCommand\fR to create a command -in the \fBtcl::mathfunc\fR namespace. -.PP -In the \fBTcl_CreateMathFunc\fR interface, -\fIName\fR is the name of the function as it will appear in expressions. -If \fIname\fR does not already exist in the \fB::tcl::mathfunc\fR -namespace, then a new command is created in that namespace. -If \fIname\fR does exist, then the existing function is replaced. -\fINumArgs\fR and \fIargTypes\fR describe the arguments to the function. -Each entry in the \fIargTypes\fR array must be -one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR, \fBTCL_WIDE_INT\fR, -or \fBTCL_EITHER\fR to indicate whether the corresponding argument must be an -integer, a double-precision floating value, a wide (64-bit) integer, -or any, respectively. -.PP -Whenever the function is invoked in an expression Tcl will invoke -\fIproc\fR. \fIProc\fR should have arguments and result that match -the type \fBTcl_MathProc\fR: -.PP -.CS -typedef int \fBTcl_MathProc\fR( - ClientData \fIclientData\fR, - Tcl_Interp *\fIinterp\fR, - Tcl_Value *\fIargs\fR, - Tcl_Value *\fIresultPtr\fR); -.CE -.PP -When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR -arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR. -\fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures, -which describe the actual arguments to the function: -.PP -.CS -typedef struct Tcl_Value { - Tcl_ValueType \fItype\fR; - long \fIintValue\fR; - double \fIdoubleValue\fR; - Tcl_WideInt \fIwideValue\fR; -} \fBTcl_Value\fR; -.CE -.PP -The \fItype\fR field indicates the type of the argument and is -one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR. -It will match the \fIargTypes\fR value specified for the function unless -the \fIargTypes\fR value was \fBTCL_EITHER\fR. Tcl converts -the argument supplied in the expression to the type requested in -\fIargTypes\fR, if that is necessary. -Depending on the value of the \fItype\fR field, the \fIintValue\fR, -\fIdoubleValue\fR or \fIwideValue\fR -field will contain the actual value of the argument. -.PP -\fIProc\fR should compute its result and store it either as an integer -in \fIresultPtr->intValue\fR or as a floating value in -\fIresultPtr->doubleValue\fR. -It should set also \fIresultPtr->type\fR to one of -\fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR -to indicate which value was set. -Under normal circumstances \fIproc\fR should return \fBTCL_OK\fR. -If an error occurs while executing the function, \fIproc\fR should -return \fBTCL_ERROR\fR and leave an error message in the interpreter's result. -.PP -\fBTcl_GetMathFuncInfo\fR retrieves the values associated with -function \fIname\fR that were passed to a preceding -\fBTcl_CreateMathFunc\fR call. Normally, the return code is -\fBTCL_OK\fR but if the named function does not exist, \fBTCL_ERROR\fR -is returned and an error message is placed in the interpreter's -result. -.PP -If an error did not occur, the array reference placed in the variable -pointed to by \fIargTypesPtr\fR is newly allocated, and should be -released by passing it to \fBTcl_Free\fR. Some functions (the -standard set implemented in the core, and those defined by placing -commands in the \fBtcl::mathfunc\fR namespace) do not have -argument type information; attempting to retrieve values for -them causes a NULL to be stored in the variable pointed to by -\fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR -will not be modified. The variable pointed to by \fInumArgsPointer\fR -will contain -1, and no argument types will be stored in the variable -pointed to by \fIargTypesPointer\fR. -.PP -\fBTcl_ListMathFuncs\fR returns a Tcl value containing a list of all -the math functions defined in the interpreter whose name matches -\fIpattern\fR. The returned value has a reference count of zero. -.SH "REFERENCE COUNT MANAGEMENT" -.PP -\fBTcl_ListMathFuncs\fR always returns a zero-reference object, much -like \fBTcl_NewObj\fR. -.SH "SEE ALSO" -expr(n), info(n), Tcl_CreateObjCommand(3), Tcl_Free(3), Tcl_NewListObj(3) -.SH KEYWORDS -expression, mathematical function diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index bb63937..522f903 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -40,12 +40,11 @@ int const char * \fBTcl_GetCommandName\fR(\fIinterp, token\fR) .sp -void \fBTcl_GetCommandFullName\fR(\fIinterp, token, objPtr\fR) .sp Tcl_Command \fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR) -.sp +.fi .SH ARGUMENTS .AS Tcl_CmdDeleteProc *deleteProc in/out .AP Tcl_Interp *interp in @@ -58,7 +57,7 @@ Implementation of the new command: \fIproc\fR will be called whenever .AP Tcl_ObjCmdProc2 *proc2 in Implementation of the new command: \fIproc2\fR will be called whenever \fIcmdName\fR is invoked as a command. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in Procedure to call before \fIcmdName\fR is deleted from the interpreter; @@ -101,7 +100,7 @@ and it returns NULL. .PP .CS typedef int \fBTcl_ObjCmdProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIobjc\fR, Tcl_Obj *const \fIobjv\fR[]); @@ -174,7 +173,7 @@ result that match the type \fBTcl_CmdDeleteProc\fR: .PP .CS typedef void \fBTcl_CmdDeleteProc\fR( - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .PP The \fIclientData\fR argument will be the same as the \fIclientData\fR @@ -185,7 +184,7 @@ except its \fIproc2\fR argument is of type \fBTcl_ObjCmdProc2\fR. .PP .CS typedef int \fBTcl_ObjCmdProc2\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR, Tcl_Size \fIobjc\fR, Tcl_Obj *const \fIobjv\fR[]); @@ -224,24 +223,29 @@ pointed to by \fIinfoPtr\fR and returns 1. A \fBTcl_CmdInfo\fR structure has the following fields: .PP .CS -typedef struct Tcl_CmdInfo { +typedef struct { int \fIisNativeObjectProc\fR; Tcl_ObjCmdProc *\fIobjProc\fR; - ClientData \fIobjClientData\fR; + void *\fIobjClientData\fR; Tcl_CmdProc *\fIproc\fR; - ClientData \fIclientData\fR; + void *\fIclientData\fR; Tcl_CmdDeleteProc *\fIdeleteProc\fR; - ClientData \fIdeleteData\fR; + void *\fIdeleteData\fR; Tcl_Namespace *\fInamespacePtr\fR; + Tcl_ObjCmdProc2 *\fIobjProc2\fR; + void *\fIobjClientData2\fR; } \fBTcl_CmdInfo\fR; .CE .PP -The \fIisNativeObjectProc\fR field has the value 1 -if \fBTcl_CreateObjCommand\fR was called to register the command; -it is 0 if only \fBTcl_CreateCommand\fR was called. +The \fIisNativeObjectProc\fR field has the value 2 if +\fBTcl_CreateObjCommand2\fR was called to register the command; +it has the value 1 if \fBTcl_CreateObjCommand\fR was called to +register the command; it is 0 if only \fBTcl_CreateCommand\fR was called. It allows a program to determine whether it is faster to -call \fIobjProc\fR or \fIproc\fR: -\fIobjProc\fR is normally faster +call \fIobjProc2\fR, \fIobjProc\fR or \fIproc\fR: +\fIobjProc2\fR/\fIobjProc\fR is normally faster +if \fIisNativeObjectProc\fR has the value 2; +\fIobjProc\fR/\fIobjProc\fR is normally faster if \fIisNativeObjectProc\fR has the value 1. The fields \fIobjProc\fR and \fIobjClientData\fR have the same meaning as the \fIproc\fR and \fIclientData\fR @@ -257,7 +261,7 @@ otherwise, this is a compatibility procedure registered by \fBTcl_CreateObjCommand\fR that simply calls the command's value-based procedure after converting its string arguments to Tcl values. -The field \fIdeleteData\fR is the ClientData value +The field \fIdeleteData\fR is the clientData value to pass to \fIdeleteProc\fR; it is normally the same as \fIclientData\fR but may be set independently using the \fBTcl_SetCommandInfo\fR procedure. @@ -271,7 +275,7 @@ from \fBTcl_CreateObjCommand\fR in place of the command name. If the and fills in the structure designated by \fIinfoPtr\fR. .PP \fBTcl_SetCommandInfo\fR is used to modify the procedures and -ClientData values associated with a command. +clientData values associated with a command. Its \fIcmdName\fR argument is the name of a command in \fIinterp\fR. \fIcmdName\fR may include \fB::\fR namespace qualifiers to identify a command in a particular namespace. @@ -287,11 +291,10 @@ copies the information from \fI*infoPtr\fR to Tcl's internal structure for the command and returns 1. .PP Note that \fBTcl_SetCommandInfo\fR and -\fBTcl_SetCommandInfoFromToken\fR both allow the ClientData for a +\fBTcl_SetCommandInfoFromToken\fR both allow the clientData for a command's deletion procedure to be given a different value than the -ClientData for its command procedure. -.PP -Note that neither \fBTcl_SetCommandInfo\fR nor +clientData for its command procedure. +Note also that neither \fBTcl_SetCommandInfo\fR nor \fBTcl_SetCommandInfoFromToken\fR will change a command's namespace. Use \fBTcl_Eval\fR to call the \fBrename\fR command to do that. .PP diff --git a/doc/CrtTimerHdlr.3 b/doc/CrtTimerHdlr.3 index c229a23..eeeea77 100644 --- a/doc/CrtTimerHdlr.3 +++ b/doc/CrtTimerHdlr.3 @@ -18,13 +18,14 @@ Tcl_TimerToken \fBTcl_CreateTimerHandler\fR(\fImilliseconds, proc, clientData\fR) .sp \fBTcl_DeleteTimerHandler\fR(\fItoken\fR) +.fi .SH ARGUMENTS .AS Tcl_TimerToken milliseconds .AP int milliseconds in How many milliseconds to wait before invoking \fIproc\fR. .AP Tcl_TimerProc *proc in Procedure to invoke after \fImilliseconds\fR have elapsed. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .AP Tcl_TimerToken token in Token for previously created timer handler (the return value @@ -51,7 +52,7 @@ the type \fBTcl_TimerProc\fR: .PP .CS typedef void \fBTcl_TimerProc\fR( - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .PP The \fIclientData\fR parameter to \fIproc\fR is a diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index 519f348..8e4b92f 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -25,11 +25,12 @@ Tcl_Trace \fBTcl_CreateObjTrace2\fR(\fIinterp, level, flags, objProc2, clientData, deleteProc\fR) .sp \fBTcl_DeleteTrace\fR(\fIinterp, trace\fR) +.fi .SH ARGUMENTS .AS Tcl_CmdObjTraceDeleteProc *deleteProc .AP Tcl_Interp *interp in Interpreter containing command to be traced or untraced. -.AP int level in +.AP Tcl_Size level in Only commands at or below this nesting level will be traced unless 0 is specified. 1 means top-level commands only, 2 means top-level commands or those that are @@ -97,7 +98,7 @@ typedef int \fBTcl_CmdObjTraceProc2\fR( .PP The \fIclientData\fR and \fIinterp\fR parameters are copies of the corresponding arguments given to \fBTcl_CreateTrace\fR. -\fIClientData\fR typically points to an application-specific data +\fIclientData\fR typically points to an application-specific data structure that describes what to do when \fIobjProc\fR is invoked. The \fIlevel\fR parameter gives the nesting level of the command (1 for top-level commands passed to \fBTcl_Eval\fR by the application, 2 for diff --git a/doc/DString.3 b/doc/DString.3 index 33dd297..7265898 100644 --- a/doc/DString.3 +++ b/doc/DString.3 @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult, Tcl_DStringToObj \- manipulate dynamic strings +Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult, Tcl_DStringToObj \- manipulate dynamic strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -26,7 +26,7 @@ char * .sp \fBTcl_DStringEndSublist\fR(\fIdsPtr\fR) .sp -int +Tcl_Size \fBTcl_DStringLength\fR(\fIdsPtr\fR) .sp char * @@ -34,8 +34,6 @@ char * .sp \fBTcl_DStringSetLength\fR(\fIdsPtr, newLength\fR) .sp -\fBTcl_DStringTrunc\fR(\fIdsPtr, newLength\fR) -.sp \fBTcl_DStringFree\fR(\fIdsPtr\fR) .sp \fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) @@ -44,6 +42,7 @@ char * .sp Tcl_Obj * \fBTcl_DStringToObj\fR(\fIdsPtr\fR) +.fi .sp .SH ARGUMENTS .AS Tcl_DString newLength in/out @@ -53,10 +52,10 @@ Pointer to structure that is used to manage a dynamic string. Pointer to characters to append to dynamic string. .AP "const char" *element in Pointer to characters to append as list element to dynamic string. -.AP int length in -Number of bytes from \fIbytes\fR to add to dynamic string. If -1, +.AP Tcl_Size length in +Number of bytes from \fIbytes\fR to add to dynamic string. If negative, add all characters up to null terminating character. -.AP int newLength in +.AP Tcl_Size newLength in New length for dynamic string, not including null terminating character. .AP Tcl_Interp *interp in/out @@ -132,10 +131,6 @@ caller to fill in the new space. even if the string is truncated to zero length, so \fBTcl_DStringFree\fR will still need to be called. .PP -\fBTcl_DStringTrunc\fR changes the length of a dynamic string. -This procedure is now deprecated. \fBTcl_DStringSetLength\fR should -be used instead. -.PP \fBTcl_DStringFree\fR should be called when you are finished using the string. It frees up any memory that was allocated for the string and reinitializes the string's value to an empty string. @@ -148,7 +143,8 @@ This saves the cost of allocating new memory and copying the string. an empty string. Since the dynamic string is reinitialized, there is no need to further call \fBTcl_DStringFree\fR on it and it can be reused without -calling \fBTcl_DStringInit\fR. +calling \fBTcl_DStringInit\fR. The caller must ensure that the dynamic +string stored in \fIdsPtr\fR is encoded in Tcl's internal UTF-8 format. .PP \fBTcl_DStringGetResult\fR does the opposite of \fBTcl_DStringResult\fR. It sets the value of \fIdsPtr\fR to the result of \fIinterp\fR and @@ -156,15 +152,15 @@ it clears \fIinterp\fR's result. If possible it does this by moving a pointer rather than by copying the string. .PP -\fBTcl_DStringToObj\fR returns a \fBTcl_Obj\fR containing the value of -the dynamic string given by \fIdsPtr\fR. It does this by moving -a pointer from \fIdsPtr\fR to a newly allocated \fBTcl_Obj\fR -and reinitializing to dynamic string to an empty string. -This saves the cost of allocating new memory and copying the string. -Since the dynamic string is reinitialized, there is no need to -further call \fBTcl_DStringFree\fR on it and it can be reused without -calling \fBTcl_DStringInit\fR. -The returned \fBTcl_Obj\fR has a reference count of 0. +\fBTcl_DStringToObj\fR returns a \fBTcl_Obj\fR containing the value of the +dynamic string given by \fIdsPtr\fR. It does this by moving a pointer from +\fIdsPtr\fR to a newly allocated \fBTcl_Obj\fR and reinitializing to dynamic +string to an empty string. This saves the cost of allocating new memory and +copying the string. Since the dynamic string is reinitialized, there is no need +to further call \fBTcl_DStringFree\fR on it and it can be reused without calling +\fBTcl_DStringInit\fR. The returned \fBTcl_Obj\fR has a reference count of 0. +The caller must ensure that the dynamic string stored in \fIdsPtr\fR is encoded +in Tcl's internal UTF-8 format. .SH KEYWORDS append, dynamic string, free, result diff --git a/doc/DetachPids.3 b/doc/DetachPids.3 index 26075c3..4d87529 100644 --- a/doc/DetachPids.3 +++ b/doc/DetachPids.3 @@ -20,9 +20,10 @@ Tcl_DetachPids, Tcl_ReapDetachedProcs, Tcl_WaitPid \- manage child processes in .sp Tcl_Pid \fBTcl_WaitPid\fR(\fIpid, statusPtr, options\fR) +.fi .SH ARGUMENTS .AS Tcl_Pid *statusPtr out -.AP int numPids in +.AP Tcl_Size numPids in Number of process ids contained in the array pointed to by \fIpidPtr\fR. .AP int *pidPtr in Address of array containing \fInumPids\fR process ids. diff --git a/doc/DictObj.3 b/doc/DictObj.3 index 0b4c1ca..ec36d6a 100644 --- a/doc/DictObj.3 +++ b/doc/DictObj.3 @@ -33,10 +33,8 @@ int \fBTcl_DictObjFirst\fR(\fIinterp, dictPtr, searchPtr, keyPtrPtr, valuePtrPtr, donePtr\fR) .sp -void \fBTcl_DictObjNext\fR(\fIsearchPtr, keyPtrPtr, valuePtrPtr, donePtr\fR) .sp -void \fBTcl_DictObjDone\fR(\fIsearchPtr\fR) .sp int @@ -44,6 +42,7 @@ int .sp int \fBTcl_DictObjRemoveKeyList\fR(\fIinterp, dictPtr, keyc, keyv\fR) +.fi .SH ARGUMENTS .AS Tcl_DictSearch "**valuePtrPtr" in/out .AP Tcl_Interp *interp in @@ -70,9 +69,14 @@ Points to a variable that will have the value from a key/value pair placed within it. For \fBTcl_DictObjFirst\fR and \fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is not interested in the value. -.AP int *sizePtr out +.AP "Tcl_Size \&| int" *sizePtr out Points to a variable that will have the number of key/value pairs contained within the dictionary placed within it. +May be (Tcl_Size *)NULL when not used. If it points to a variable which +type is not \fBTcl_Size\fR, a compiler warning will be generated. +If your extensions is compiled with -DTCL_8_API, this function will return +NULL for dictionaries larger than INT_MAX (which should +trigger proper error-handling), otherwise expect it to crash. .AP Tcl_DictSearch *searchPtr in/out Pointer to record to use to keep track of progress in enumerating all key/value pairs in a dictionary. The contents of the record will be @@ -84,7 +88,7 @@ returned, the search record \fImust\fR be passed to Points to a variable that will have a non-zero value written into it when the enumeration of the key/value pairs in a dictionary has completed, and a zero otherwise. -.AP int keyc in +.AP Tcl_Size keyc in Indicates the number of keys that will be supplied in the \fIkeyv\fR array. .AP "Tcl_Obj *const" *keyv in @@ -138,7 +142,8 @@ converted to a dictionary. \fBTcl_DictObjSize\fR updates the given variable with the number of key/value pairs currently in the given dictionary. The result of this procedure is \fBTCL_OK\fR, or \fBTCL_ERROR\fR if the \fIdictPtr\fR cannot be -converted to a dictionary. +converted to a dictionary or if \fIsizePtr\fR points to a variable of type +\fBint\fR and the dict contains more than 2**31 key/value pairs. .PP \fBTcl_DictObjFirst\fR commences an iteration across all the key/value pairs in the given dictionary, placing the key and value in the diff --git a/doc/DoOneEvent.3 b/doc/DoOneEvent.3 index d48afd0..b14f2e1 100644 --- a/doc/DoOneEvent.3 +++ b/doc/DoOneEvent.3 @@ -16,6 +16,7 @@ Tcl_DoOneEvent \- wait for events and invoke event handlers .sp int \fBTcl_DoOneEvent\fR(\fIflags\fR) +.fi .SH ARGUMENTS .AS int flags .AP int flags in @@ -53,24 +54,18 @@ If the \fIflags\fR argument to \fBTcl_DoOneEvent\fR is non-zero, it restricts the kinds of events that will be processed by \fBTcl_DoOneEvent\fR. \fIFlags\fR may be an OR-ed combination of any of the following bits: -.TP 27 -\fBTCL_WINDOW_EVENTS\fR \- +.IP \fBTCL_WINDOW_EVENTS\fR Process window system events. -.TP 27 -\fBTCL_FILE_EVENTS\fR \- +.IP \fBTCL_FILE_EVENTS\fR Process file events. -.TP 27 -\fBTCL_TIMER_EVENTS\fR \- +.IP \fBTCL_TIMER_EVENTS\fR Process timer events. -.TP 27 -\fBTCL_IDLE_EVENTS\fR \- +.IP \fBTCL_IDLE_EVENTS\fR Process idle callbacks. -.TP 27 -\fBTCL_ALL_EVENTS\fR \- +.IP \fBTCL_ALL_EVENTS\fR Process all kinds of events: equivalent to OR-ing together all of the above flags or specifying none of them. -.TP 27 -\fBTCL_DONT_WAIT\fR \- +.IP \fBTCL_DONT_WAIT\fR Do not sleep: process only events that are ready at the time of the call. .LP diff --git a/doc/DoWhenIdle.3 b/doc/DoWhenIdle.3 index cfdbff9..f342820 100644 --- a/doc/DoWhenIdle.3 +++ b/doc/DoWhenIdle.3 @@ -17,11 +17,12 @@ Tcl_DoWhenIdle, Tcl_CancelIdleCall \- invoke a procedure when there are no pendi \fBTcl_DoWhenIdle\fR(\fIproc, clientData\fR) .sp \fBTcl_CancelIdleCall\fR(\fIproc, clientData\fR) +.fi .SH ARGUMENTS .AS Tcl_IdleProc clientData .AP Tcl_IdleProc *proc in Procedure to invoke. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION @@ -43,7 +44,7 @@ type \fBTcl_IdleProc\fR: .PP .CS typedef void \fBTcl_IdleProc\fR( - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .PP The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR diff --git a/doc/DoubleObj.3 b/doc/DoubleObj.3 index c70f5d1..4696cc3 100644 --- a/doc/DoubleObj.3 +++ b/doc/DoubleObj.3 @@ -20,6 +20,7 @@ Tcl_Obj * .sp int \fBTcl_GetDoubleFromObj\fR(\fIinterp, objPtr, doublePtr\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp doubleValue in/out .AP double doubleValue in @@ -73,4 +74,5 @@ is holding a reference to the object, it will be deleted. .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS -double, double value, double type, internal representation, value, value type, string representation +double, double value, double type, internal representation, value, value type, +string representation diff --git a/doc/DumpActiveMemory.3 b/doc/DumpActiveMemory.3 index 226209a..7c8dd7e 100644 --- a/doc/DumpActiveMemory.3 +++ b/doc/DumpActiveMemory.3 @@ -15,12 +15,10 @@ Tcl_DumpActiveMemory, Tcl_InitMemory, Tcl_ValidateAllMemory \- Validated memory int \fBTcl_DumpActiveMemory\fR(\fIfileName\fR) .sp -void \fBTcl_InitMemory\fR(\fIinterp\fR) .sp -void \fBTcl_ValidateAllMemory\fR(\fIfileName, line\fR) - +.fi .SH ARGUMENTS .AS Tcl_Interp *fileName .AP Tcl_Interp *interp in @@ -43,7 +41,7 @@ is not defined, these functions are all no-ops. \fBTcl_DumpActiveMemory\fR will output a list of all currently allocated memory to the specified file. The information output for each allocated block of memory is: starting and ending addresses -(excluding guard zone), size, source file where \fBckalloc\fR was +(excluding guard zone), size, source file where \fBTcl_Alloc\fR was called to allocate the block and line number in that file. It is especially useful to call \fBTcl_DumpActiveMemory\fR after the Tcl interpreter has been deleted. @@ -55,8 +53,8 @@ by \fBTcl_Main\fR. \fBTcl_ValidateAllMemory\fR forces a validation of the guard zones of all currently allocated blocks of memory. Normally validation of a block occurs when its freed, unless full validation is enabled, in -which case validation of all blocks occurs when \fBckalloc\fR and -\fBckfree\fR are called. This function forces the validation to occur +which case validation of all blocks occurs when \fBTcl_Alloc\fR and +\fBTcl_Free\fR are called. This function forces the validation to occur at any point. .SH "SEE ALSO" diff --git a/doc/Encoding.3 b/doc/Encoding.3 index c357ecd..9e5ae06 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtfDStringEx, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternalDStringEx, Tcl_UtfToExternal, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings +Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtfDStringEx, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternalDStringEx, Tcl_UtfToExternal, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath \- procedures for creating and using encodings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -16,7 +16,6 @@ Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDStr Tcl_Encoding \fBTcl_GetEncoding\fR(\fIinterp, name\fR) .sp -void \fBTcl_FreeEncoding\fR(\fIencoding\fR) .sp int @@ -42,16 +41,10 @@ int \fBTcl_UtfToExternal\fR(\fIinterp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR) .sp -char * -\fBTcl_WinTCharToUtf\fR(\fItsrc, srcLen, dstPtr\fR) -.sp -TCHAR * -\fBTcl_WinUtfToTChar\fR(\fIsrc, srcLen, dstPtr\fR) -.sp const char * \fBTcl_GetEncodingName\fR(\fIencoding\fR) .sp -int +Tcl_Size \fBTcl_GetEncodingNulLength\fR(\fIencoding\fR) .sp int @@ -60,7 +53,6 @@ int const char * \fBTcl_GetEncodingNameFromEnvironment\fR(\fIbufPtr\fR) .sp -void \fBTcl_GetEncodingNames\fR(\fIinterp\fR) .sp Tcl_Encoding @@ -71,12 +63,7 @@ Tcl_Obj * .sp int \fBTcl_SetEncodingSearchPath\fR(\fIsearchPath\fR) -.sp -const char * -\fBTcl_GetDefaultEncodingDir\fR(\fIvoid\fR) -.sp -void -\fBTcl_SetDefaultEncodingDir\fR(\fIpath\fR) +.fi .SH ARGUMENTS .AS "const Tcl_EncodingType" *dstWrotePtr in/out .AP Tcl_Interp *interp in @@ -94,11 +81,11 @@ Points to storage where encoding token is to be written. .AP "const char" *src in For the \fBTcl_ExternalToUtf\fR functions, an array of bytes in the specified encoding that are to be converted to UTF-8. For the -\fBTcl_UtfToExternal\fR and \fBTcl_WinUtfToTChar\fR functions, an array of +\fBTcl_UtfToExternal\fR function, an array of UTF-8 characters to be converted to the specified encoding. .AP "const TCHAR" *tsrc in An array of Windows TCHAR characters to convert to UTF-8. -.AP int srcLen in +.AP Tcl_Size srcLen in Length of \fIsrc\fR or \fItsrc\fR in bytes. If the length is negative, the encoding-specific length of the string is used. .AP Tcl_DString *dstPtr out @@ -117,9 +104,9 @@ byte is converted and then to reset to an initial state. The \fBTCL_PROFILE_*\fR bits defined in the \fBPROFILES\fR section below control the encoding profile to be used for dealing with invalid data or other errors in the encoding transform. -\fBTCL_ENCODING_STOPONERROR\fR is present for backward compatibility with -Tcl 8.6 and forces the encoding profile to \fBstrict\fR. - +The flag \fBTCL_ENCODING_STOPONERROR\fR has no effect, +it only has meaning in Tcl 8.x. +.PP Some flags bits may not be usable with some functions as noted in the function descriptions below. .AP Tcl_EncodingState *statePtr in/out @@ -147,7 +134,7 @@ buffer as a result of the conversion. May be NULL. .AP int *dstCharsPtr out Filled with the number of characters that correspond to the number of bytes stored in the output buffer. May be NULL. -.AP int *errorIdxPtr out +.AP Tcl_Size *errorIdxPtr out Filled with the index of the byte or character that caused the encoding transform to fail. May be NULL. .AP Tcl_DString *bufPtr out @@ -232,12 +219,12 @@ be used to specify the profile to be used for the transform. The ignored as the function assumes the entire source string to be decoded is passed into the function. On success, the function returns \fBTCL_OK\fR with the converted string stored in \fB*dstPtr\fR. For errors \fIother than conversion -errors\fR, such as invalid flags, the function returns \fBTCL_ERROR\fR with an error -message in \fBinterp\fR if it is not NULL. +errors\fR, such as invalid flags, the function returns \fBTCL_ERROR\fR with an +error message in \fBinterp\fR if it is not NULL. For conversion errors, \fBTcl_ExternalToUtfDStringEx\fR returns one of the \fBTCL_CONVERT_*\fR errors listed below for \fBTcl_ExternalToUtf\fR. -When one of these conversion errors is returned, an error message is -stored in \fBinterp\fR only if \fBerrorIdxPtr\fR is NULL. Otherwise, no error message +When one of these conversion errors is returned, an error message is stored +in \fBinterp\fR only if \fBerrorIdxPtr\fR is NULL. Otherwise, no error message is stored as the function expects the caller is interested the decoded data up to that point and not treating this as an immediate error condition. The index of the error location is stored in \fB*errorIdxPtr\fR. @@ -266,8 +253,8 @@ the unconverted bytes that remained in \fIsrc\fR plus some further bytes from the source stream to properly convert the formerly split-up multibyte sequence. .IP \fBTCL_CONVERT_SYNTAX\fR 29 -The source buffer contained an invalid byte or character sequence. This may occur -if the input stream has been damaged or if the input encoding method was +The source buffer contained an invalid byte or character sequence. This may +occur if the input stream has been damaged or if the input encoding method was misidentified. .IP \fBTCL_CONVERT_UNKNOWN\fR 29 The source buffer contained a character that could not be represented in @@ -284,11 +271,12 @@ encoding, a default fallback character will be used. The return value is a pointer to the value stored in the DString. .PP \fBTcl_UtfToExternalDStringEx\fR is an enhanced version of -\fBTcl_UtfToExternalDString\fR that transforms UTF-8 encoded source data to a specified -\fIencoding\fR. Except for the direction of the transform, the parameters and -return values are identical to those of \fBTcl_ExternalToUtfDStringEx\fR. See +\fBTcl_UtfToExternalDString\fR that transforms UTF-8 encoded source data to a +specified \fIencoding\fR. Except for the direction of the transform, the +parameters and return values are identical to those of +\fBTcl_ExternalToUtfDStringEx\fR. See that function above for details about the same. - +.PP Irrespective of the return code from the function, the caller must free resources associated with \fB*dstPtr\fR when the function returns. .PP @@ -301,18 +289,6 @@ is filled with the corresponding number of bytes that were stored in \fIdst\fR. The return values are the same as the return values for \fBTcl_ExternalToUtf\fR. .PP -\fBTcl_WinUtfToTChar\fR and \fBTcl_WinTCharToUtf\fR are Windows-only -convenience functions for converting between UTF-8 and Windows strings -based on the TCHAR type which is by convention a Unicode character on -Windows NT. Those functions are deprecated. You can use -\fBTcl_UtfToWCharDString\fR resp. \fBTcl_WCharToUtfDString\fR as replacement. -If you want compatibility with earlier Tcl releases than 8.7, use -\fBTcl_UtfToUniCharDString\fR resp. \fBTcl_UniCharToUtfDString\fR as -replacement, and make sure you compile your extension with -DTCL_UTF_MAX=3. -Beware: Those replacement functions don't initialize their Tcl_DString (you'll -have to do that yourself), and \fBTcl_UniCharToUtfDString\fR from Tcl 8.6 -doesn't accept -1 as length parameter. -.PP \fBTcl_GetEncodingName\fR is roughly the inverse of \fBTcl_GetEncoding\fR. Given an \fIencoding\fR, the return value is the \fIname\fR argument that was used to create the encoding. The string returned by @@ -342,7 +318,7 @@ the encoding name to it. The \fBTcl_DStringValue\fR is returned. \fBTcl_GetEncodingNames\fR sets the \fIinterp\fR result to a list consisting of the names of all the encodings that are currently defined or can be dynamically loaded, searching the encoding path specified by -\fBTcl_SetDefaultEncodingDir\fR. This procedure does not ensure that the +\fBTcl_SetEncodingSearchPath\fR. This procedure does not ensure that the dynamically-loadable encoding files contain valid data, but merely that they exist. .PP @@ -364,13 +340,13 @@ about the name of the encoding and the procedures that will be called to convert between this encoding and UTF-8. It is defined as follows: .PP .CS -typedef struct Tcl_EncodingType { +typedef struct { const char *\fIencodingName\fR; Tcl_EncodingConvertProc *\fItoUtfProc\fR; Tcl_EncodingConvertProc *\fIfromUtfProc\fR; Tcl_EncodingFreeProc *\fIfreeProc\fR; void *\fIclientData\fR; - int \fInullSize\fR; + Tcl_Size \fInullSize\fR; } \fBTcl_EncodingType\fR; .CE .PP @@ -457,15 +433,6 @@ are not verified as existing readable filesystem directories. When searching for encoding data files takes place, and non-existent or non-readable filesystem directories on the \fIsearchPath\fR are silently ignored. -.PP -\fBTcl_GetDefaultEncodingDir\fR and \fBTcl_SetDefaultEncodingDir\fR -are obsolete interfaces best replaced with calls to -\fBTcl_GetEncodingSearchPath\fR and \fBTcl_SetEncodingSearchPath\fR. -They are called to access and set the first element of the \fIsearchPath\fR -list. Since Tcl searches \fIsearchPath\fR for encoding data files in -list order, these routines establish the -.QW default -directory in which to find encoding data files. .SH "ENCODING FILES" Space would prohibit precompiling into Tcl every possible encoding algorithm, so many encodings are stored on disk as dynamically-loadable @@ -622,7 +589,7 @@ with at most one of \fBTCL_ENCODING_PROFILE_TCL8\fR, \fBTCL_ENCODING_PROFILE_STRICT\fR or \fBTCL_ENCODING_PROFILE_REPLACE\fR. These correspond to the \fBtcl8\fR, \fBstrict\fR and \fBreplace\fR profiles respectively. If none are specified, a version-dependent default profile is used. -For Tcl 8.7, the default profile is \fBtcl8\fR. +For Tcl 9.0, the default profile is \fBstrict\fR. .PP For details about profiles, see the \fBPROFILES\fR section in the documentation of the \fBencoding\fR command. diff --git a/doc/Ensemble.3 b/doc/Ensemble.3 index 71a53ac..0c2ea9d 100644 --- a/doc/Ensemble.3 +++ b/doc/Ensemble.3 @@ -56,6 +56,7 @@ int .sp int \fBTcl_GetEnsembleNamespace\fR(\fIinterp, token, namespacePtrPtr\fR) +.fi .SH ARGUMENTS .AS Tcl_Namespace **namespacePtrPtr in/out .AP Tcl_Interp *interp in/out @@ -161,6 +162,7 @@ All command names in prefixes set via \fBTcl_SetEnsembleMappingDict\fR must be fully qualified. .TP \fBformal pre-subcommand parameter list\fR (read-write) +. A list of formal parameter names (the names only being used when generating error messages) that come at invocation of the ensemble between the name of the ensemble and the subcommand argument. NULL (the default) is equivalent to diff --git a/doc/Environment.3 b/doc/Environment.3 index 7a5e396..da1d4f4 100644 --- a/doc/Environment.3 +++ b/doc/Environment.3 @@ -15,6 +15,7 @@ Tcl_PutEnv \- procedures to manipulate the environment .sp int \fBTcl_PutEnv\fR(\fIassignment\fR) +.fi .SH ARGUMENTS .AS "const char" *assignment .AP "const char" *assignment in @@ -10,7 +10,7 @@ .so man.macros .BS .SH NAME -Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts +Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval \- execute Tcl scripts .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -37,10 +37,8 @@ int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int -\fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *)NULL\fR) -.sp -int -\fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) +\fBTcl_VarEval\fR(\fIinterp, part, part, ... \fBNULL\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in @@ -53,7 +51,7 @@ OR'ed combination of flag bits that specify additional options. \fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported. .AP "const char" *fileName in Name of a file containing a Tcl script. -.AP int objc in +.AP Tcl_Size objc in The number of values in the array pointed to by \fIobjv\fR; this is also the number of words in the command. .AP Tcl_Obj **objv in @@ -67,9 +65,6 @@ first null byte are used. Points to first byte of script to execute (null-terminated and UTF-8). .AP "const char" *part in String forming part of a Tcl script. -.AP va_list argList in -An argument list which must have been initialized using -\fBva_start\fR, and cleared using \fBva_end\fR. .BE .SH DESCRIPTION @@ -126,16 +121,10 @@ might be a UTF-8 special code. The string is parsed and executed directly bytecodes. In situations where it is known that the script will never be executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion code and result just like -\fBTcl_EvalObjEx\fR. Note: for backward compatibility with versions before -Tcl 8.0, \fBTcl_Eval\fR copies the value result in \fIinterp\fR to -\fIinterp->result\fR (use is deprecated) where it can be accessed directly. - This makes \fBTcl_Eval\fR somewhat slower than \fBTcl_EvalEx\fR, which -does not do the copy. +\fBTcl_EvalObjEx\fR. .PP \fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes -additional arguments \fInumBytes\fR and \fIflags\fR. For the -efficiency reason given above, \fBTcl_EvalEx\fR is generally preferred -over \fBTcl_Eval\fR. +additional arguments \fInumBytes\fR and \fIflags\fR. .PP \fBTcl_GlobalEval\fR and \fBTcl_GlobalEvalObj\fR are older procedures that are now deprecated. They are similar to \fBTcl_EvalEx\fR and @@ -151,11 +140,6 @@ It returns the result of the command and also modifies the interpreter result in the same way as \fBTcl_Eval\fR. The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end of arguments. -.PP -\fBTcl_VarEvalVA\fR is the same as \fBTcl_VarEval\fR except that -instead of taking a variable number of arguments it takes an argument -list. Interfaces using argument lists have been found to be nonportable -in practice. This function is deprecated and will be removed in Tcl 9.0. .SH "FLAG BITS" .PP @@ -31,18 +31,19 @@ Tcl_Exit, Tcl_Finalize, Tcl_CreateExitHandler, Tcl_DeleteExitHandler, Tcl_ExitTh .sp Tcl_ExitProc * \fBTcl_SetExitProc\fR(\fIproc\fR) +.fi .SH ARGUMENTS .AS Tcl_ExitProc clientData .AP int status in Provides information about why the application or thread exited. -Exact meaning may -be platform-specific. 0 usually means a normal exit, any nonzero value +Exact meaning may be platform-specific. +0 usually means a normal exit, any nonzero value usually means that an error occurred. .AP Tcl_ExitProc *proc in Procedure to invoke before exiting application, or (for \fBTcl_SetExitProc\fR) NULL to uninstall the current application exit procedure. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE @@ -53,18 +54,18 @@ execution of a \fBTcl\fR application. Exit handlers are invoked to cleanup the application's state before ending the execution of \fBTcl\fR code. .PP Invoke \fBTcl_Exit\fR to end a \fBTcl\fR application and to exit from this -process. This procedure is invoked by the \fBexit\fR command, and can be +process. This procedure is invoked by the \fBexit\fR Tcl command, and can be invoked anyplace else to terminate the application. -No-one should ever invoke the \fBexit\fR system procedure directly; always +No-one should ever invoke the \fBexit()\fR system call directly; always invoke \fBTcl_Exit\fR instead, so that it can invoke exit handlers. -Note that if other code invokes \fBexit\fR system procedure directly, or +Note that if other code invokes \fBexit()\fR system call directly, or otherwise causes the application to terminate without calling \fBTcl_Exit\fR, the exit handlers will not be run. -\fBTcl_Exit\fR internally invokes the \fBexit\fR system call, thus it never +\fBTcl_Exit\fR internally invokes the \fBexit()\fR system call, thus it never returns control to its caller. If an application exit handler has been installed (see \fBTcl_SetExitProc\fR), that handler is invoked with an argument -consisting of the exit status (cast to ClientData); the application +consisting of the exit status (cast to void *); the application exit handler should not return control to Tcl. .PP \fBTcl_Finalize\fR is similar to \fBTcl_Exit\fR except that it does not @@ -93,7 +94,7 @@ and freeing global memory. .PP .CS typedef void \fBTcl_ExitProc\fR( - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .PP The \fIclientData\fR parameter to \fIproc\fR is a @@ -133,11 +134,11 @@ installed, that exit handler takes over complete responsibility for finalization of Tcl's subsystems via \fBTcl_Finalize\fR at an appropriate time. The argument passed to \fIproc\fR when it is invoked will be the exit status code (as passed to \fBTcl_Exit\fR) -cast to a ClientData value. +cast to a void *value. .PP -\fBTcl_SetExitProc\fR can not be used in stub-enabled extensions. Its symbol -entry in the stub table is deprecated and it will be removed in Tcl 9.0. +\fBTcl_SetExitProc\fR can not be used in stub-enabled extensions. .SH "SEE ALSO" exit(n) .SH KEYWORDS -abort, callback, cleanup, dynamic loading, end application, exit, unloading, thread +abort, callback, cleanup, dynamic loading, end application, exit, unloading, +thread diff --git a/doc/ExprLong.3 b/doc/ExprLong.3 index 0d369ce..8d5e06d 100644 --- a/doc/ExprLong.3 +++ b/doc/ExprLong.3 @@ -25,6 +25,7 @@ int .sp int \fBTcl_ExprString\fR(\fIinterp, expr\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *booleanPtr out .AP Tcl_Interp *interp in diff --git a/doc/ExprLongObj.3 b/doc/ExprLongObj.3 index 59413e1..09f83dd 100644 --- a/doc/ExprLongObj.3 +++ b/doc/ExprLongObj.3 @@ -24,6 +24,7 @@ int .sp int \fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index cc19ea8..b6c6d1e 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -20,10 +20,9 @@ int int \fBTcl_FSUnregister\fR(\fIfsPtr\fR) .sp -ClientData +void * \fBTcl_FSData\fR(\fIfsPtr\fR) .sp -void \fBTcl_FSMountsChanged\fR(\fIfsPtr\fR) .sp const Tcl_Filesystem * @@ -123,7 +122,7 @@ Tcl_Obj * int \fBTcl_FSConvertToPathType\fR(\fIinterp, pathPtr\fR) .sp -ClientData +void * \fBTcl_FSGetInternalRep\fR(\fIpathPtr, fsPtr\fR) .sp Tcl_Obj * @@ -182,6 +181,7 @@ unsigned long long .sp int \fBTcl_GetUserIdFromStat\fR(\fIstatPtr\fR) +.fi .SH ARGUMENTS .AS Tcl_GlobTypeData **srcPathPtr out .AP "const Tcl_Filesystem" *fsPtr in @@ -210,7 +210,7 @@ this structure will be returned. This parameter may be NULL. .AP Tcl_Interp *interp in Interpreter to use either for results, evaluation, or reporting error messages. -.AP ClientData clientData in +.AP void *clientData in The native description of the path value to create. .AP Tcl_Obj *firstPtr in The first of two path values to compare. The value may be converted @@ -220,8 +220,8 @@ The second of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *listObj in The list of path elements to operate on with a \fBjoin\fR operation. -.AP int elements in -If non-negative, the number of elements in the \fIlistObj\fR which should +.AP Tcl_Size elements in +The number of elements in the \fIlistObj\fR which should be joined together. If negative, then all elements are joined. .AP Tcl_Obj **errorPtr out In the case of an error, filled with a value containing the name of @@ -251,7 +251,7 @@ Name of a procedure to look up in the file's symbol table Filled with the init function for this code. .AP Tcl_LibraryInitProc **proc2Ptr out Filled with the safe-init function for this code. -.AP ClientData *clientDataPtr out +.AP void **clientDataPtr out Filled with the clientData value to pass to this code's unload function when it is called. .AP Tcl_LoadHandle *loadHandlePtr out @@ -269,11 +269,16 @@ allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. -.AP int *lenPtr out -If non-NULL, filled with the number of elements in the split path. +.AP "Tcl_Size \&| int" *lenPtr out +Filled with the number of elements in the split path. +May be (Tcl_Size *)NULL when not used. If it points to a variable which +type is not \fBTcl_Size\fR, a compiler warning will be generated. +If your extensions is compiled with -DTCL_8_API, this function will return +NULL for paths having more than INT_MAX elements (which should +trigger proper error-handling), otherwise expect it to crash. .AP Tcl_Obj *basePtr in The base path on to which to join the given elements. May be NULL. -.AP int objc in +.AP Tcl_Size objc in The number of elements in \fIobjv\fR. .AP "Tcl_Obj *const" objv[] in The elements to join to the given base path. @@ -372,7 +377,8 @@ variable to the POSIX error code (which signifies a .QW "cross-domain link" ). .PP -\fBTcl_FSCopyDirectory\fR attempts to copy the directory given by \fIsrcPathPtr\fR to the +\fBTcl_FSCopyDirectory\fR attempts to copy the directory given by +\fIsrcPathPtr\fR to the path name given by \fIdestPathPtr\fR. If the two paths given lie in the same filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that filesystem's @@ -482,8 +488,9 @@ is a Tcl_Obj specifying the contents of the symbolic link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned by the caller, which should call \fBTcl_DecrRefCount\fR when the result is no longer needed. If the \fItoPtr\fR is not NULL, Tcl should create a link -of one of the types passed in in the \fIlinkAction\fR flag. This flag is -an OR'ed combination of \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR. +of one of the types passed in in the \fIlinkAction\fR flag. +This flag is an OR'ed combination of \fBTCL_CREATE_SYMBOLIC_LINK\fR +and \fBTCL_CREATE_HARD_LINK\fR. Where a choice exists (i.e.\ more than one flag is passed in), the Tcl convention is to prefer symbolic links. When a link is successfully created, the return value should be \fItoPtr\fR (which is therefore @@ -678,11 +685,6 @@ of zero, they will be freed when this function returns. \fBTcl_FSConvertToPathType\fR tries to convert the given Tcl_Obj to a valid Tcl path type, taking account of the fact that the cwd may have changed even if this value is already supposedly of the correct type. -The filename may begin with -.QW ~ -(to indicate current user's home directory) or -.QW ~<user> -(to indicate any user's home directory). .PP If the conversion succeeds (i.e.\ the value is a valid path in one of the current filesystems), then \fBTCL_OK\fR is returned. Otherwise @@ -704,14 +706,7 @@ from the given Tcl_Obj. .PP If the translation succeeds (i.e.\ the value is a valid path), then it is returned. Otherwise NULL will be returned, and an error message may be -left in the interpreter. A -.QW translated -path is one which contains no -.QW ~ -or -.QW ~user -sequences (these have been expanded to their current -representation in the filesystem). The value returned is owned by the +left in the interpreter. The value returned is owned by the caller, which must store it or call \fBTcl_DecrRefCount\fR to ensure memory is freed. This function is of little practical use, and \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually @@ -720,7 +715,7 @@ better functions to use for most purposes. \fBTcl_FSGetTranslatedStringPath\fR does the same as \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL. The string returned is dynamically allocated and owned by the caller, -which must store it or call \fBckfree\fR to ensure it is freed. Again, +which must store it or call \fBTcl_Free\fR to ensure it is freed. Again, \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP @@ -787,7 +782,7 @@ It returns one of \fBTCL_PATH_ABSOLUTE\fR, \fBTCL_PATH_RELATIVE\fR, or .SS "PORTABLE STAT RESULT API" .PP \fBTcl_AllocStatBuf\fR allocates a \fITcl_StatBuf\fR on the system heap (which -may be deallocated by being passed to \fBckfree\fR). This allows extensions to +may be deallocated by being passed to \fBTcl_Free\fR). This allows extensions to invoke \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR without being dependent on the size of the buffer. That in turn depends on the flags used to build Tcl. .PP @@ -835,7 +830,7 @@ general that is not a good thing to do). \fBTCL_OK\fR will be returned. the list of known filesystems, if it is known, and returns \fBTCL_OK\fR. If the filesystem is not currently registered, \fBTCL_ERROR\fR is returned. .PP -\fBTcl_FSData\fR will return the ClientData associated with the given +\fBTcl_FSData\fR will return the clientData associated with the given filesystem, if that filesystem is registered. Otherwise it will return NULL. .PP @@ -848,9 +843,9 @@ longer be correct. The \fBTcl_Filesystem\fR structure contains the following fields: .PP .CS -typedef struct Tcl_Filesystem { +typedef struct { const char *\fItypeName\fR; - int \fIstructureLength\fR; + Tcl_Size \fIstructureLength\fR; Tcl_FSVersion \fIversion\fR; Tcl_FSPathInFilesystemProc *\fIpathInFilesystemProc\fR; Tcl_FSDupInternalRepProc *\fIdupInternalRepProc\fR; @@ -1012,7 +1007,7 @@ Tcl's internal list of known filesystems. .CS typedef int \fBTcl_FSPathInFilesystemProc\fR( Tcl_Obj *\fIpathPtr\fR, - ClientData *\fIclientDataPtr\fR); + void **\fIclientDataPtr\fR); .CE .SS DUPINTERNALREPPROC .PP @@ -1022,8 +1017,8 @@ simply not copy the internal representation, which may then need to be regenerated later. .PP .CS -typedef ClientData \fBTcl_FSDupInternalRepProc\fR( - ClientData \fIclientData\fR); +typedef void *\fBTcl_FSDupInternalRepProc\fR( + void *\fIclientData\fR); .CE .SS FREEINTERNALREPPROC Free the internal representation. This must be implemented if internal @@ -1032,7 +1027,7 @@ internal representation is generated), but may otherwise be NULL. .PP .CS typedef void \fBTcl_FSFreeInternalRepProc\fR( - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .SS INTERNALTONORMALIZEDPROC .PP @@ -1043,7 +1038,7 @@ representation is the normalized path. .PP .CS typedef Tcl_Obj *\fBTcl_FSInternalToNormalizedProc\fR( - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .SS CREATEINTERNALREPPROC .PP @@ -1054,7 +1049,7 @@ the \fITcl_FSPathInFilesystemProc\fR for this filesystem always immediately creates an internal representation for paths it accepts. .PP .CS -typedef ClientData \fBTcl_FSCreateInternalRepProc\fR( +typedef void *\fBTcl_FSCreateInternalRepProc\fR( Tcl_Obj *\fIpathPtr\fR); .CE .SS NORMALIZEPATHPROC @@ -1068,9 +1063,7 @@ must have a single unique string representation. Depending on the filesystem, there may be more than one unnormalized string representation which refers to that path (e.g.\ a relative path, a path with different -character case if the filesystem is case insensitive, a path contain a -reference to a home directory such as -.QW ~ , +character case if the filesystem is case insensitive, a path containing symbolic links, etc). If the very last component in the path is a symbolic link, it should not be converted into the value it points to (but @@ -1263,7 +1256,7 @@ The \fBTcl_GlobTypeData\fR structure passed in the \fItypes\fR parameter contains the following fields: .PP .CS -typedef struct Tcl_GlobTypeData { +typedef struct { /* Corresponds to bcdpfls as in 'find -t' */ int \fItype\fR; /* Corresponds to file permissions */ @@ -1391,10 +1384,10 @@ typedef int \fBTcl_FSFileAttrsGetProc\fR( .PP Returns a standard Tcl return code. The attribute value retrieved, which corresponds to the \fIindex\fR'th element in the list returned by -the \fBTcl_FSFileAttrStringsProc\fR, is a Tcl_Obj placed in \fIobjPtrRef\fR (if -\fBTCL_OK\fR was returned) and is likely to have a reference count of zero. Either -way we must either store it somewhere (e.g.\ the Tcl result), or -Incr/Decr its reference count to ensure it is properly freed. +the \fBTcl_FSFileAttrStringsProc\fR, is a Tcl_Obj placed in \fIobjPtrRef\fR +(if \fBTCL_OK\fR was returned) and is likely to have a reference count of +zero. Either way we must either store it somewhere (e.g.\ the Tcl result), +or Incr/Decr its reference count to ensure it is properly freed. .SS FILEATTRSSETPROC .PP Function to process a \fBTcl_FSFileAttrsSet\fR call, used by \fBfile diff --git a/doc/FindExec.3 b/doc/FindExec.3 index 6156382..756d8cb 100644 --- a/doc/FindExec.3 +++ b/doc/FindExec.3 @@ -18,6 +18,7 @@ const char * .sp const char * \fBTcl_GetNameOfExecutable\fR() +.fi .SH ARGUMENTS .AS char *argv0 .AP char *argv0 in @@ -35,8 +36,8 @@ Tcl. For example, it is needed on some platforms in the implementation of the \fBload\fR command. It is also returned by the \fBinfo nameofexecutable\fR command. .PP -The result of \fBTcl_FindExecutable\fR is the full Tcl version with build -information (e.g., \fB8.7.0+abcdef...abcdef.gcc-1002\fR). +The result of \fBTcl_FindExecutable\fR is the full Tcl version with +build information (e.g., \fB9.0.0+abcdef...abcdef.gcc-1002\fR). .PP On UNIX platforms this procedure is typically invoked as the very first thing in the application's main program; it must be passed @@ -62,7 +63,6 @@ equivalent to the \fBinfo nameofexecutable\fR command. NULL is returned if the internal full path name has not been computed or unknown. .PP -\fBTcl_FindExecutable\fR can not be used in stub-enabled extensions. Its symbol -entry in the stub table is deprecated and it will be removed in Tcl 9.0. +\fBTcl_FindExecutable\fR can not be used in stub-enabled extensions. .SH KEYWORDS binary, executable file diff --git a/doc/GetCwd.3 b/doc/GetCwd.3 index b19f587..b901098 100644 --- a/doc/GetCwd.3 +++ b/doc/GetCwd.3 @@ -18,6 +18,7 @@ char * .sp int \fBTcl_Chdir\fR(\fIdirName\fR) +.fi .SH ARGUMENTS .AS Tcl_DString *bufferPtr in/out .AP Tcl_Interp *interp in @@ -46,7 +47,7 @@ The format of the path is UTF\-8. .PP \fBTcl_Chdir\fR changes the applications current working directory to the value specified in \fIdirName\fR. The format of the passed in string -must be UTF\-8. The function returns -1 on error or 0 on success. +must be UTF\-8. The function returns \-1 on error or 0 on success. .SH KEYWORDS pwd diff --git a/doc/GetHostName.3 b/doc/GetHostName.3 index 8e43f8e..cdef270 100644 --- a/doc/GetHostName.3 +++ b/doc/GetHostName.3 @@ -13,6 +13,7 @@ Tcl_GetHostName \- get the name of the local host .sp const char * \fBTcl_GetHostName\fR() +.fi .BE .SH DESCRIPTION diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index 176b0b2..deb77fe 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -20,6 +20,7 @@ indexPtr\fR) int \fBTcl_GetIndexFromObjStruct\fR(\fIinterp, objPtr, structTablePtr, offset, msg, flags, indexPtr\fR) +.fi .SH ARGUMENTS .AS "const char" *structTablePtr in/out .AP Tcl_Interp *interp in @@ -89,7 +90,7 @@ the table and the index of the matching entry. If \fBTcl_GetIndexFromObj\fR is invoked again with the same \fIobjPtr\fR and \fItablePtr\fR arguments (e.g. during a reinvocation of a Tcl command), it returns the matching index immediately without having to redo the lookup -operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries +operation. Note that \fBTcl_GetIndexFromObj\fR assumes that the entries in \fItablePtr\fR are static: they must not change between invocations. This caching mechanism can be disallowed by specifying the \fBTCL_INDEX_TEMP_TABLE\fR flag. diff --git a/doc/GetInt.3 b/doc/GetInt.3 index f15c12d..a0c1d1b 100644 --- a/doc/GetInt.3 +++ b/doc/GetInt.3 @@ -25,6 +25,7 @@ int .sp int \fBTcl_GetBool\fR(\fIinterp, src, flags, charPtr\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *doublePtr out .AP Tcl_Interp *interp in @@ -71,12 +72,9 @@ if the first such characters are then \fIsrc\fR is expected to be in octal form; otherwise, if the first such characters are .QW \fB0b\fR -then \fIsrc\fR is expected to be in binary form; otherwise, -if the first such character is -.QW \fB0\fR then \fIsrc\fR -is expected to be in octal form; otherwise, \fIsrc\fR -is expected to be in decimal form. +is expected to be in binary form; otherwise, \fIsrc\fR is +expected to be in decimal form. .PP \fBTcl_GetDouble\fR expects \fIsrc\fR to consist of a floating-point number, which is: white space; a sign; a sequence of digits; a diff --git a/doc/GetOpnFl.3 b/doc/GetOpnFl.3 index a450b02..f3a3143 100644 --- a/doc/GetOpnFl.3 +++ b/doc/GetOpnFl.3 @@ -15,7 +15,7 @@ Tcl_GetOpenFile \- Return a FILE* for a channel registered in the given interpre .sp int \fBTcl_GetOpenFile\fR(\fIinterp, chanID, write, checkUsage, filePtr\fR) -.sp +.fi .SH ARGUMENTS .AS Tcl_Interp checkUsage out .AP Tcl_Interp *interp in @@ -28,7 +28,7 @@ be used for reading. .AP int checkUsage in If non-zero, then an error will be generated if the file was not opened for the access indicated by \fIwrite\fR. -.AP ClientData *filePtr out +.AP void **filePtr out Points to word in which to store pointer to FILE structure for the file given by \fIchanID\fR. .BE diff --git a/doc/GetStdChan.3 b/doc/GetStdChan.3 index 3472fee..91217e4 100644 --- a/doc/GetStdChan.3 +++ b/doc/GetStdChan.3 @@ -18,7 +18,7 @@ Tcl_Channel \fBTcl_GetStdChannel\fR(\fItype\fR) .sp \fBTcl_SetStdChannel\fR(\fIchannel, type\fR) -.sp +.fi .SH ARGUMENTS .AS Tcl_Channel channel .AP int type in diff --git a/doc/GetTime.3 b/doc/GetTime.3 index 9dc4056..ff302e5 100644 --- a/doc/GetTime.3 +++ b/doc/GetTime.3 @@ -18,6 +18,7 @@ Tcl_GetTime, Tcl_SetTimeProc, Tcl_QueryTimeProc \- get date and time \fBTcl_SetTimeProc\fR(\fIgetProc, scaleProc, clientData\fR) .sp \fBTcl_QueryTimeProc\fR(\fIgetProcPtr, scaleProcPtr, clientDataPtr\fR) +.fi .SH ARGUMENTS .AS Tcl_GetTimeProc *getProc in .AP Tcl_Time *timePtr out @@ -27,13 +28,13 @@ Pointer to handler function replacing \fBTcl_GetTime\fR's access to the OS. .AP Tcl_ScaleTimeProc scaleProc in Pointer to handler function for the conversion of time delays in the virtual domain to real-time. -.AP ClientData clientData in +.AP void *clientData in Value passed through to the two handler functions. .AP Tcl_GetTimeProc *getProcPtr out Pointer to place the currently registered get handler function into. .AP Tcl_ScaleTimeProc *scaleProcPtr out Pointer to place the currently registered scale handler function into. -.AP ClientData *clientDataPtr out +.AP void **clientDataPtr out Pointer to place the currently registered pass-through value into. .BE .SH DESCRIPTION @@ -43,8 +44,8 @@ The \fBTcl_GetTime\fR function retrieves the current time as a structure has the following definition: .PP .CS -typedef struct Tcl_Time { - long \fIsec\fR; +typedef struct { + long long \fIsec\fR; long \fIusec\fR; } \fBTcl_Time\fR; .CE @@ -52,7 +53,7 @@ typedef struct Tcl_Time { On return, the \fIsec\fR member of the structure is filled in with the number of seconds that have elapsed since the \fIepoch:\fR the epoch is the point in time of 00:00 UTC, 1 January 1970. This number does -\fInot\fR count leap seconds \- an interval of one day advances it by +\fInot\fR count leap seconds; an interval of one day advances it by 86400 seconds regardless of whether a leap second has been inserted. .PP The \fIusec\fR member of the structure is filled in with the number of @@ -83,10 +84,10 @@ The signatures of the handler functions are as follows: .CS typedef void \fBTcl_GetTimeProc\fR( Tcl_Time *\fItimebuf\fR, - ClientData \fIclientData\fR); + void *\fIclientData\fR); typedef void \fBTcl_ScaleTimeProc\fR( Tcl_Time *\fItimebuf\fR, - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .PP The \fItimebuf\fR fields contain the time to manipulate, and the diff --git a/doc/GetVersion.3 b/doc/GetVersion.3 index 3672382..5a85a2a 100644 --- a/doc/GetVersion.3 +++ b/doc/GetVersion.3 @@ -14,15 +14,15 @@ Tcl_GetVersion \- get the version of the library at runtime \fB#include <tcl.h>\fR .sp \fBTcl_GetVersion\fR(\fImajor, minor, patchLevel, type\fR) +.fi .SH ARGUMENTS -.AS Tcl_ReleaseType *patchLevel out .AP int *major out Major version number of the Tcl library. .AP int *minor out Minor version number of the Tcl library. .AP int *patchLevel out The patch level of the Tcl library (or alpha or beta number). -.AP Tcl_ReleaseType *type out +.AP int *type out The type of release, also indicates the type of patch level. Can be one of \fBTCL_ALPHA_RELEASE\fR, \fBTCL_BETA_RELEASE\fR, or \fBTCL_FINAL_RELEASE\fR. @@ -30,7 +30,7 @@ Tcl_HashEntry * Tcl_HashEntry * \fBTcl_FindHashEntry\fR(\fItablePtr, key\fR) .sp -ClientData +void * \fBTcl_GetHashValue\fR(\fIentryPtr\fR) .sp \fBTcl_SetHashValue\fR(\fIentryPtr, value\fR) @@ -46,6 +46,7 @@ Tcl_HashEntry * .sp char * \fBTcl_HashStats\fR(\fItablePtr\fR) +.fi .SH ARGUMENTS .AS "const Tcl_HashKeyType" *searchPtr out .AP Tcl_HashTable *tablePtr in @@ -66,9 +67,8 @@ The word at \fI*newPtr\fR is set to 1 if a new entry was created and 0 if there was already an entry for \fIkey\fR. .AP Tcl_HashEntry *entryPtr in Pointer to hash table entry. -.AP ClientData value in -New value to assign to hash table entry. Need not have type -ClientData, but must fit in same space as ClientData. +.AP void *value in +New value to assign to hash table entry. .AP Tcl_HashSearch *searchPtr in Pointer to record to use to keep track of progress in enumerating all the entries in a hash table. @@ -186,11 +186,6 @@ instead, it returns NULL as result. .PP \fBTcl_GetHashValue\fR and \fBTcl_SetHashValue\fR are used to read and write an entry's value, respectively. -Values are stored and retrieved as type -.QW ClientData , -which is -large enough to hold a pointer value. On almost all machines this is -large enough to hold an integer value too. .PP \fBTcl_GetHashKey\fR returns the key for a given hash table entry, either as a pointer to a string, a one-word @@ -229,7 +224,7 @@ overall information about a hash table, such as the number of entries it contains, the number of buckets in its hash array, and the utilization of the buckets. It is the caller's responsibility to free the result string -by passing it to \fBckfree\fR. +by passing it to \fBTcl_Free\fR. .PP The header file \fBtcl.h\fR defines the actual data structures used to implement hash tables. @@ -247,7 +242,7 @@ calling \fBTcl_InitCustomHashTable\fR. The \fBTcl_HashKeyType\fR structure is defined as follows: .PP .CS -typedef struct Tcl_HashKeyType { +typedef struct { int \fIversion\fR; int \fIflags\fR; Tcl_HashKeyProc *\fIhashKeyProc\fR; @@ -2,7 +2,7 @@ '\" Copyright (c) 1998-2000 Scriptics Corporation. '\" All rights reserved. '\" -.TH Tcl_Init 3 8.7 Tcl "Tcl Library Procedures" +.TH Tcl_Init 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME @@ -16,6 +16,7 @@ int .sp const char * \fBTcl_SetPreInitScript\fR(\fIscriptPtr\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in @@ -38,9 +39,12 @@ A value of \fINULL\fR may be passed to not register any script. The pre-initialization script is executed by \fBTcl_Init\fR before accessing the file system. The purpose is to typically prepare a custom file system (like an embedded zip-file) to be activated before the search. - +.PP +When used in stub-enabled embedders, the stubs table must be first initialized +using one of \fBTcl_InitSubsystems\fR, \fBTcl_SetPanicProc\fR, +\fBTcl_FindExecutable\fR +or \fBTclZipfs_AppHook\fR before \fBTcl_SetPreInitScript\fR may be called. .SH "SEE ALSO" Tcl_AppInit, Tcl_Main - .SH KEYWORDS application, initialization, interpreter diff --git a/doc/InitStubs.3 b/doc/InitStubs.3 index 4423666..80a21de 100644 --- a/doc/InitStubs.3 +++ b/doc/InitStubs.3 @@ -15,6 +15,7 @@ Tcl_InitStubs \- initialize the Tcl stubs mechanism .sp const char * \fBTcl_InitStubs\fR(\fIinterp, version, exact\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in @@ -63,9 +64,9 @@ Define the \fBUSE_TCL_STUBS\fR symbol. Typically, you would include the \fB\-DUSE_TCL_STUBS\fR flag when compiling the extension. .IP 3) 5 Link the extension with the Tcl stubs library instead of the standard -Tcl library. For example, to use the Tcl 8.6 ABI on Unix platforms, -the library name is \fIlibtclstub8.6.a\fR; on Windows platforms, the -library name is \fItclstub86.lib\fR. +Tcl library. For example, to use the Tcl 9.0 ABI on Unix platforms, +the library name is \fIlibtclstub.a\fR; on Windows platforms, the +library name is \fItclstub.lib\fR. .PP If the extension also requires the Tk API, it must also call \fBTk_InitStubs\fR to initialize the Tk stubs interface and link diff --git a/doc/InitSubSyst.3 b/doc/InitSubSyst.3 index 0d09a41..4647567 100644 --- a/doc/InitSubSyst.3 +++ b/doc/InitSubSyst.3 @@ -14,21 +14,23 @@ Tcl_InitSubsystems \- initialize the Tcl library. \fB#include <tcl.h>\fR .sp const char * -\fBTcl_InitSubsystems\fR(\fIvoid\fR) +\fBTcl_InitSubsystems\fR() +.fi +.BE .SH DESCRIPTION .PP The \fBTcl_InitSubsystems\fR procedure initializes the Tcl library. This procedure is typically invoked as the very first thing in the application's main program. .PP -The result of \fBTcl_InitSubsystems\fR is the full Tcl version with build -information (e.g., \fB8.7.0+abcdef...abcdef.gcc-1002\fR). +The result of \fBTcl_InitSubsystems\fR is the full Tcl version with +build information (e.g., \fB9.0.0+abcdef...abcdef.gcc-1002\fR). .PP \fBTcl_InitSubsystems\fR is very similar in use to \fBTcl_FindExecutable\fR. It can be used when Tcl is -used as utility library, no other encodings than utf8, +used as utility library, no other encodings than utf-8, iso8859-1 or utf-16 are used, and no interest exists in the value of \fBinfo nameofexecutable\fR. The system encoding will not -be extracted from the environment, but falls back to iso8859-1. +be extracted from the environment, but falls back to utf-8. .SH KEYWORDS binary, executable file diff --git a/doc/IntObj.3 b/doc/IntObj.3 index 18d867e..4cd13e6 100644 --- a/doc/IntObj.3 +++ b/doc/IntObj.3 @@ -32,7 +32,7 @@ int \fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR) .sp int -\fBTcl_GetIntForIndex\fR(\fIinterp, objPtr, endValue, intPtr\fR) +\fBTcl_GetIntForIndex\fR(\fIinterp, objPtr, endValue, indexPtr\fR) .sp int \fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR) @@ -43,6 +43,9 @@ int int \fBTcl_GetWideUIntFromObj\fR(\fIinterp, objPtr, uwidePtr\fR) .sp +int +\fBTcl_GetSizeIntFromObj\fR(\fIinterp, objPtr, sizePtr\fR) +.sp .sp \fB#include <tclTomMath.h>\fR .sp @@ -59,9 +62,10 @@ int .sp int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) +.fi .SH ARGUMENTS .AS Tcl_WideInt doubleValue in/out -.AP int endValue in +.AP Tcl_Size endValue in \fBTcl_GetIntForIndex\fR will return this when the input value is "end". .AP int intValue in Integer value used to initialize or set a Tcl value. @@ -83,10 +87,14 @@ retrieval fails. Points to place to store the integer value retrieved from \fIobjPtr\fR. .AP long *longPtr out Points to place to store the long integer value retrieved from \fIobjPtr\fR. +.AP Tcl_Size *indexPtr out +Points to place to store the Tcl_Size value retrieved from \fIobjPtr\fR. .AP Tcl_WideInt *widePtr out Points to place to store the wide integer value retrieved from \fIobjPtr\fR. .AP Tcl_WideUInt *uwidePtr out Points to place to store the unsigned wide integer value retrieved from \fIobjPtr\fR. +.AP Tcl_Size *sizePtr out +Points to place to store the \fBTcl_Size\fR integer value retrieved from \fIobjPtr\fR. .AP mp_int *bigValue in/out Points to a multi-precision integer structure declared by the LibTomMath library. @@ -136,7 +144,8 @@ of \fIobjPtr\fR may be changed to make subsequent calls to the same routine more efficient. .PP The \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, -\fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and +\fBTcl_GetWideIntFromObj\fR, \fBTcl_GetSizeIntFromObj\fR, +\fBTcl_GetBignumFromObj\fR, and \fBTcl_TakeBignumFromObj\fR routines attempt to retrieve an integral value of the appropriate type from the Tcl value \fIobjPtr\fR. If the attempt succeeds, then \fBTCL_OK\fR is returned, and the value is diff --git a/doc/Interp.3 b/doc/Interp.3 deleted file mode 100644 index c1b9803..0000000 --- a/doc/Interp.3 +++ /dev/null @@ -1,41 +0,0 @@ -'\" -'\" Copyright (c) 1989-1993 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_Interp 3 8.7 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_Interp \- client-visible fields of interpreter structures -.SH SYNOPSIS -.nf -\fB#include <tcl.h>\fR -.sp -typedef struct { - char *\fIresult\fR; /* NO LONGER AVAILABLE */ - Tcl_FreeProc *\fIfreeProc\fR; /* NO LONGER AVAILABLE */ - int \fIerrorLine\fR; /* NO LONGER AVAILABLE */ -} \fBTcl_Interp\fR; - -typedef void \fBTcl_FreeProc\fR( - char *\fIblockPtr\fR); -.BE -.SH DESCRIPTION -.PP -The \fBTcl_CreateInterp\fR procedure returns a pointer to a \fBTcl_Interp\fR -structure. Callers of \fBTcl_CreateInterp\fR should use this pointer -as an opaque token, suitable for nothing other than passing back to -other routines in the Tcl interface from the same thread that called -\fBTcl_CreateInterp\fR. The \fBTcl_Interp\fR struct no longer has any -supported client-visible fields. Supported public routines such as -\fBTcl_SetResult\fR, \fBTcl_GetResult\fR, \fBTcl_SetErrorLine\fR, -\fBTcl_GetErrorLine\fR must be used instead. -.PP -Any legacy programs and extensions trying to access the fields above -in their source code will need conversion to compile for Tcl 8.7 and later. - -.SH KEYWORDS -interpreter, result diff --git a/doc/Limit.3 b/doc/Limit.3 index 3d202fc..5eb3ac8 100644 --- a/doc/Limit.3 +++ b/doc/Limit.3 @@ -28,35 +28,28 @@ int int \fBTcl_LimitTypeEnabled\fR(\fIinterp, type\fR) .sp -void \fBTcl_LimitTypeSet\fR(\fIinterp, type\fR) .sp -void \fBTcl_LimitTypeReset\fR(\fIinterp, type\fR) .sp int \fBTcl_LimitGetCommands\fR(\fIinterp\fR) .sp -void \fBTcl_LimitSetCommands\fR(\fIinterp, commandLimit\fR) .sp -void \fBTcl_LimitGetTime\fR(\fIinterp, timeLimitPtr\fR) .sp -void \fBTcl_LimitSetTime\fR(\fIinterp, timeLimitPtr\fR) .sp int \fBTcl_LimitGetGranularity\fR(\fIinterp, type\fR) .sp -void \fBTcl_LimitSetGranularity\fR(\fIinterp, type, granularity\fR) .sp -void \fBTcl_LimitAddHandler\fR(\fIinterp, type, handlerProc, clientData, deleteProc\fR) .sp -void \fBTcl_LimitRemoveHandler\fR(\fIinterp, type, handlerProc, clientData\fR) +.fi .SH ARGUMENTS .AS Tcl_LimitHandlerDeleteProc commandLimit in/out .AP Tcl_Interp *interp in @@ -65,7 +58,7 @@ its limits checked. .AP int type in The type of limit that the operation refers to. This must be either \fBTCL_LIMIT_COMMANDS\fR or \fBTCL_LIMIT_TIME\fR. -.AP int commandLimit in +.AP Tcl_Size commandLimit in The maximum number of commands (as reported by \fBinfo cmdcount\fR) that may be executed in the interpreter. .AP Tcl_Time *timeLimitPtr in/out @@ -83,7 +76,7 @@ the handler returns. Many handlers may be attached to the same interpreter limit; their order of execution is not defined, and they must be identified by \fIhandlerProc\fR and \fIclientData\fR when they are deleted. -.AP ClientData clientData in +.AP void *clientData in Arbitrary pointer-sized word used to pass some context to the \fIhandlerProc\fR function. .AP Tcl_LimitHandlerDeleteProc *deleteProc in @@ -162,7 +155,7 @@ following prototype: .PP .CS typedef void \fBTcl_LimitHandlerProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR); .CE .PP @@ -179,7 +172,7 @@ following prototype: .PP .CS typedef void \fBTcl_LimitHandlerDeleteProc\fR( - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .PP A limit handler may be deleted using \fBTcl_LimitRemoveHandler\fR; the diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index f5e97b4..ffedb9d 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -25,6 +25,7 @@ int \fBTcl_UnlinkVar\fR(\fIinterp, varName\fR) .sp \fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp varName in .AP Tcl_Interp *interp in @@ -59,7 +60,7 @@ In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and All the above for both functions may be optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR to make the Tcl variable read-only. -.AP int size in +.AP Tcl_Size size in .VS "TIP 312" The number of elements in the C array. Must be greater than zero. .VE "TIP 312" @@ -263,7 +264,7 @@ Tcl errors. . The C variable is of type \fBchar *\fR. If its value is not NULL then it must be a pointer to a string -allocated with \fBTcl_Alloc\fR or \fBckalloc\fR. +allocated with \fBTcl_Alloc\fR. Whenever the Tcl variable is modified the current C string will be freed and new memory will be allocated to hold a copy of the variable's new value. diff --git a/doc/ListObj.3 b/doc/ListObj.3 index c5c1dc7..deae5a5 100644 --- a/doc/ListObj.3 +++ b/doc/ListObj.3 @@ -35,6 +35,7 @@ int .sp int \fBTcl_ListObjReplace\fR(\fIinterp, listPtr, first, count, objc, objv\fR) +.fi .SH ARGUMENTS .AS "Tcl_Obj *const" *elemListPtr in/out .AP Tcl_Interp *interp in @@ -59,13 +60,18 @@ points to the Tcl value that will be appended to \fIlistPtr\fR. For \fBTcl_SetListObj\fR, this points to the Tcl value that will be converted to a list value containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR. -.AP int *objcPtr in +.AP "Tcl_Size \&| int" *objcPtr in Points to location where \fBTcl_ListObjGetElements\fR stores the number of element values in \fIlistPtr\fR. +May be (Tcl_Size *)NULL when not used. If it points to a variable which +type is not \fBTcl_Size\fR, a compiler warning will be generated. +If your extensions is compiled with -DTCL_8_API, this function will return +NULL for lists with more than INT_MAX elements (which should +trigger proper error-handling), otherwise expect it to crash. .AP Tcl_Obj ***objvPtr out A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array of pointers to the element values of \fIlistPtr\fR. -.AP int objc in +.AP Tcl_Size objc in The number of Tcl values that \fBTcl_NewListObj\fR will insert into a new list value, and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR. @@ -76,21 +82,26 @@ An array of pointers to values. \fBTcl_NewListObj\fR will insert these values into a new list value and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR. Each value will become a separate list element. -.AP int *lengthPtr out +.AP "Tcl_Size \&| int" *lengthPtr out Points to location where \fBTcl_ListObjLength\fR stores the length of the list. -.AP int index in +May be (Tcl_Size *)NULL when not used. If it points to a variable which +type is not \fBTcl_Size\fR, a compiler warning will be generated. +If your extensions is compiled with -DTCL_8_API, this function will return +TCL_ERROR for lists with more than INT_MAX elements (which should +trigger proper error-handling), otherwise expect it to crash. +.AP Tcl_Size index in Index of the list element that \fBTcl_ListObjIndex\fR is to return. The first element has index 0. .AP Tcl_Obj **objPtrPtr out Points to place where \fBTcl_ListObjIndex\fR is to store a pointer to the resulting list element value. -.AP int first in +.AP Tcl_Size first in Index of the starting list element that \fBTcl_ListObjReplace\fR is to replace. The list's first element has index 0. -.AP int count in +.AP Tcl_Size count in The number of elements that \fBTcl_ListObjReplace\fR is to replace. .BE @@ -153,7 +164,9 @@ address \fIobjcPtr\fR. Similarly, it returns the array pointer by storing it in the address \fIobjvPtr\fR. The memory pointed to is managed by Tcl and should not be freed or written to by the caller. If the list is empty, 0 is stored at \fIobjcPtr\fR -and NULL at \fIobjvPtr\fR. +and NULL at \fIobjvPtr\fR. If \fIobjcPtr\fR points to a variable +of type \fBint\fR and the list contains more than 2**31 elements, the +function returns \fBTCL_ERROR\fR. If \fIlistPtr\fR is not already a list value, \fBTcl_ListObjGetElements\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result @@ -162,7 +175,6 @@ Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer. .PP \fBTcl_ListObjLength\fR returns the number of elements in the list value referenced by \fIlistPtr\fR. -It returns this count by storing an integer in the address \fIlengthPtr\fR. If the value is not already a list value, \fBTcl_ListObjLength\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR @@ -19,6 +19,7 @@ int .sp void * \fBTcl_FindSymbol\fR(\fIinterp, loadHandle, symbol\fR) +.fi .SH ARGUMENTS .AS Tcl_LoadHandle loadHandle in .AP Tcl_Interp *interp in diff --git a/doc/Method.3 b/doc/Method.3 index 577cd54..ed2211b 100644 --- a/doc/Method.3 +++ b/doc/Method.3 @@ -58,10 +58,11 @@ Tcl_Method Tcl_Object \fBTcl_ObjectContextObject\fR(\fIcontext\fR) .sp -int +Tcl_Size \fBTcl_ObjectContextSkippedArgs\fR(\fIcontext\fR) +.fi .SH ARGUMENTS -.AS ClientData clientData in +.AS void *clientData in .AP Tcl_Interp *interp in/out The interpreter holding the object or class to create or update a method in. .AP Tcl_Object object in @@ -83,10 +84,10 @@ and \fBTCL_OO_METHOD_PRIVATE\fR for a private method. .AP Tcl_MethodType *methodTypePtr in A description of the type of the method to create, or the type of method to compare against. -.AP ClientData clientData in +.AP void *clientData in A piece of data that is passed to the implementation of the method without interpretation. -.AP ClientData *clientDataPtr out +.AP void **clientDataPtr out A pointer to a variable in which to write the \fIclientData\fR value supplied when the method was created. If NULL, the \fIclientData\fR value will not be retrieved. @@ -95,11 +96,11 @@ A reference to a method to query. .AP Tcl_ObjectContext context in A reference to a method-call context. Note that client code \fImust not\fR retain a reference to a context. -.AP int objc in +.AP Tcl_Size objc in The number of arguments to pass to the method implementation. .AP "Tcl_Obj *const" *objv in An array of arguments to pass to the method implementation. -.AP int skip in +.AP Tcl_Size skip in The number of arguments passed to the method implementation that do not represent "real" arguments. .BE @@ -213,7 +214,7 @@ Functions matching this signature are called when the method is invoked. .PP .CS typedef int \fBTcl_MethodCallProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR, Tcl_ObjectContext \fIobjectContext\fR, int \fIobjc\fR, @@ -234,7 +235,7 @@ through a new method being created or because the object or class is deleted. .PP .CS typedef void \fBTcl_MethodDeleteProc\fR( - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .PP The \fIclientData\fR argument to a Tcl_MethodDeleteProc will be the same as @@ -248,8 +249,8 @@ class is copied using \fBTcl_CopyObjectInstance\fR (or \fBoo::copy\fR). .CS typedef int \fBTcl_CloneProc\fR( Tcl_Interp *\fIinterp\fR, - ClientData \fIoldClientData\fR, - ClientData *\fInewClientDataPtr\fR); + void *\fIoldClientData\fR, + void **\fInewClientDataPtr\fR); .CE .PP The \fIinterp\fR argument gives a place to write an error message when the @@ -40,7 +40,6 @@ int int \fBTcl_NRExprObj\fR(\fIinterp, objPtr, resultPtr\fR) .sp -void \fBTcl_NRAddCallback\fR(\fIinterp, postProcPtr, data0, data1, data2, data3\fR) .fi .SH ARGUMENTS @@ -63,13 +62,13 @@ in the same way as the \fIproc2\fR argument to \fBTcl_CreateObjCommand2\fR(3) Called instead of \fIproc\fR when a trampoline is already in use. .AP Tcl_ObjCmdProc2 *nreProc2 in Called instead of \fIproc2\fR when a trampoline is already in use. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR and \fIobjProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in/out Called before \fIcmdName\fR is deleted from the interpreter, allowing for command-specific cleanup. May be NULL. -.AP int objc in +.AP Tcl_Size objc in Number of items in \fIobjv\fR. .AP Tcl_Obj **objv in Words in the command. @@ -86,10 +85,10 @@ Pointer to an unshared Tcl_Obj where the result of the evaluation is stored if the return code is TCL_OK. .AP Tcl_NRPostProc *postProcPtr in A function to push. -.AP ClientData data0 in -.AP ClientData data1 in -.AP ClientData data2 in -.AP ClientData data3 in +.AP void *data0 in +.AP void *data1 in +.AP void *data2 in +.AP void *data3 in \fIdata0\fR through \fIdata3\fR are four one-word values that will be passed to the function designated by \fIpostProcPtr\fR when it is invoked. .BE @@ -147,7 +146,7 @@ a message as the interpreter's result. .CS typedef int \fBTcl_NRPostProc\fR( - \fBClientData\fR \fIdata\fR[], + \fBvoid *\fR \fIdata\fR[], \fBTcl_Interp\fR *\fIinterp\fR, int \fIresult\fR); .CE @@ -158,12 +157,12 @@ the routine. .SH EXAMPLE .PP The following command uses \fBTcl_EvalObjEx\fR, which consumes space on the C -stack, to evalute a script: +stack, to evaluate a script: .PP .CS int \fITheCmdOldObjProc\fR( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -194,7 +193,7 @@ call \fITheCmdNRObjProc\fR: .CS int \fITheCmdOldObjProc\fR( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -207,7 +206,7 @@ int .CS int \fITheCmdNRObjProc\fR - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -228,7 +227,7 @@ int .CS int \fITheCmdNRPostProc\fR( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { diff --git a/doc/Namespace.3 b/doc/Namespace.3 index a7e8502..399bd7d 100644 --- a/doc/Namespace.3 +++ b/doc/Namespace.3 @@ -50,6 +50,7 @@ Tcl_Obj * .sp int \fBTcl_SetNamespaceUnknownHandler\fR(\fIinterp, nsPtr, handlerPtr\fR) +.fi .SH ARGUMENTS .AS Tcl_NamespaceDeleteProc allowOverwrite in/out .AP Tcl_Interp *interp in/out @@ -57,7 +58,7 @@ The interpreter in which the namespace exists and where name lookups are performed. Also where error result messages are written. .AP "const char" *name in The name of the namespace or command to be created or accessed. -.AP ClientData clientData in +.AP void *clientData in A context pointer by the creator of the namespace. Not interpreted by Tcl at all. .AP Tcl_NamespaceDeleteProc *deleteProc in @@ -117,7 +118,7 @@ the global namespace.) .PP .CS typedef void \fBTcl_NamespaceDeleteProc\fR( - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .PP \fBTcl_DeleteNamespace\fR deletes a namespace, calling the diff --git a/doc/Notifier.3 b/doc/Notifier.3 index 7cb02f6..6aab2e2 100644 --- a/doc/Notifier.3 +++ b/doc/Notifier.3 @@ -14,43 +14,33 @@ Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEven .nf \fB#include <tcl.h>\fR .sp -void \fBTcl_CreateEventSource\fR(\fIsetupProc, checkProc, clientData\fR) .sp -void \fBTcl_DeleteEventSource\fR(\fIsetupProc, checkProc, clientData\fR) .sp -void \fBTcl_SetMaxBlockTime\fR(\fItimePtr\fR) .sp -void \fBTcl_QueueEvent\fR(\fIevPtr, position\fR) .sp -void \fBTcl_ThreadQueueEvent\fR(\fIthreadId, evPtr, position\fR) .sp -void \fBTcl_ThreadAlert\fR(\fIthreadId\fR) .sp Tcl_ThreadId \fBTcl_GetCurrentThread\fR() .sp -void \fBTcl_DeleteEvents\fR(\fIdeleteProc, clientData\fR) .sp -ClientData +void * \fBTcl_InitNotifier\fR() .sp -void \fBTcl_FinalizeNotifier\fR(\fIclientData\fR) .sp int \fBTcl_WaitForEvent\fR(\fItimePtr\fR) .sp -void \fBTcl_AlertNotifier\fR(\fIclientData\fR) .sp -void \fBTcl_SetTimer\fR(\fItimePtr\fR) .sp int @@ -65,11 +55,10 @@ int int \fBTcl_SetServiceMode\fR(\fImode\fR) .sp -void \fBTcl_ServiceModeHook\fR(\fImode\fR) .sp -void \fBTcl_SetNotifier\fR(\fInotifierProcPtr\fR) +.fi .SH ARGUMENTS .AS Tcl_EventDeleteProc *notifierProcPtr .AP Tcl_EventSetupProc *setupProc in @@ -78,7 +67,7 @@ Procedure to invoke to prepare for event wait in \fBTcl_DoOneEvent\fR. Procedure for \fBTcl_DoOneEvent\fR to invoke after waiting for events. Checks to see if any events have occurred and, if so, queues them. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIsetupProc\fR, \fIcheckProc\fR, or \fIdeleteProc\fR. .AP "const Tcl_Time" *timePtr in @@ -89,7 +78,7 @@ is NULL, it means there is no maximum wait time: wait forever if necessary. .AP Tcl_Event *evPtr in An event to add to the event queue. The storage for the event must -have been allocated by the caller using \fBTcl_Alloc\fR or \fBckalloc\fR. +have been allocated by the caller using \fBTcl_Alloc\fR. .AP int position in Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, \fBTCL_QUEUE_HEAD\fR, \fBTCL_QUEUE_MARK\fR, and whether to do @@ -226,7 +215,7 @@ the event source. .PP .CS typedef void \fBTcl_EventSetupProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, int \fIflags\fR); .CE .PP @@ -266,8 +255,8 @@ a structure that describes a time interval in seconds and microseconds: .PP .CS -typedef struct Tcl_Time { - long \fIsec\fR; +typedef struct { + long long \fIsec\fR; long \fIusec\fR; } \fBTcl_Time\fR; .CE @@ -304,7 +293,7 @@ following prototype: .PP .CS typedef void \fBTcl_EventCheckProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, int \fIflags\fR); .CE .PP @@ -328,7 +317,7 @@ structure is used when communicating between the event source and the rest of the notifier. A \fBTcl_Event\fR has the following definition: .PP .CS -typedef struct { +typedef struct Tcl_Event { Tcl_EventProc *\fIproc\fR; struct Tcl_Event *\fInextPtr\fR; } \fBTcl_Event\fR; @@ -399,7 +388,7 @@ of window events. When \fIproc\fR returns 1, \fBTcl_ServiceEvent\fR will remove the event from the event queue and free its storage. Note that the storage for an event must be allocated by -the event source (using \fBTcl_Alloc\fR or the Tcl macro \fBckalloc\fR) +the event source (using \fBTcl_Alloc\fR) before calling \fBTcl_QueueEvent\fR, but it will be freed by \fBTcl_ServiceEvent\fR, not by the event source. .PP @@ -424,7 +413,7 @@ queue. \fIProc\fR should match the following prototype: .CS typedef int \fBTcl_EventDeleteProc\fR( Tcl_Event *\fIevPtr\fR, - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .PP The \fIclientData\fR argument will be the same as the \fIclientData\fR @@ -544,7 +533,7 @@ passing a pointer to a \fBTcl_NotifierProcs\fR data structure. The structure has the following layout: .PP .CS -typedef struct Tcl_NotifierProcs { +typedef struct { Tcl_SetTimerProc *\fIsetTimerProc\fR; Tcl_WaitForEventProc *\fIwaitForEventProc\fR; Tcl_CreateFileHandlerProc *\fIcreateFileHandlerProc\fR; @@ -627,4 +616,5 @@ mode. Tcl_CreateFileHandler(3), Tcl_DeleteFileHandler(3), Tcl_Sleep(3), Tcl_DoOneEvent(3), Thread(3) .SH KEYWORDS -event, notifier, event queue, event sources, file events, timer, idle, service mode, threads +event, notifier, event queue, event sources, file events, timer, idle, +service mode, threads diff --git a/doc/Number.3 b/doc/Number.3 index 4642c10..99efab7 100644 --- a/doc/Number.3 +++ b/doc/Number.3 @@ -20,6 +20,7 @@ int .sp int \fBTcl_GetNumberFromObj\fR(\fIinterp, objPtr, clientDataPtr, typePtr\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp clientDataPtr out .AP Tcl_Interp *interp out @@ -27,9 +28,9 @@ When non-NULL, error information is recorded here when the value is not in any of the numeric formats recognized by Tcl. .AP "const char" *bytes in Points to first byte of the string value to be examined. -.AP int numBytes in +.AP Tcl_Size numBytes in The number of bytes, starting at \fIbytes\fR, that should be examined. -If the value \fBTCL_INDEX_NONE\fR is provided, then all bytes should +If \fBnumBytes\fR is negative, then all bytes should be examined until the first \fBNUL\fR byte terminates examination. .AP "void *" *clientDataPtr out Points to space where a pointer value may be written through which a numeric @@ -63,7 +64,7 @@ the same function. They differ only in how the arguments present the Tcl value to be examined. \fBTcl_GetNumber\fR accepts a counted string value in the arguments \fIbytes\fR and \fInumBytes\fR (or a \fBNUL\fR-terminated string value when \fInumBytes\fR is -\fBTCL_INDEX_NONE\fR). \fBTcl_GetNumberFromObj\fR accepts the Tcl value +negative). \fBTcl_GetNumberFromObj\fR accepts the Tcl value in \fIobjPtr\fR. .PP Both routines examine the Tcl value and determine whether Tcl recognizes diff --git a/doc/Object.3 b/doc/Object.3 index 2099552..0f52a51 100644 --- a/doc/Object.3 +++ b/doc/Object.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl values +Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_BounceRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl values .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -23,10 +23,13 @@ Tcl_Obj * .sp \fBTcl_DecrRefCount\fR(\fIobjPtr\fR) .sp +\fBTcl_BounceRefCount\fR(\fIobjPtr\fR) +.sp int \fBTcl_IsShared\fR(\fIobjPtr\fR) .sp -\fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR) +\fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR)3 +.fi .SH ARGUMENTS .AS Tcl_Obj *objPtr .AP Tcl_Obj *objPtr in @@ -110,10 +113,10 @@ Each Tcl value is represented by a \fBTcl_Obj\fR structure which is defined as follows. .PP .CS -typedef struct Tcl_Obj { - int \fIrefCount\fR; +typedef struct { + Tcl_Size \fIrefCount\fR; char *\fIbytes\fR; - int \fIlength\fR; + Tcl_Size \fIlength\fR; const Tcl_ObjType *\fItypePtr\fR; union { long \fIlongValue\fR; @@ -278,26 +281,28 @@ The string representation is now \fB124\fR and both representations are again valid. .SH "STORAGE MANAGEMENT OF VALUES" .PP -Tcl values are allocated on the heap and are shared as much as possible -to reduce storage requirements. -Reference counting is used to determine when a value is -no longer needed and can safely be freed. -A value just created by \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR -has \fIrefCount\fR 0, meaning that the object can often be given to a function -like \fBTcl_SetObjResult\fR, \fBTcl_ListObjAppendElement\fR, or -\fBTcl_DictObjPut\fR (as a value) without explicit reference management, all -of which are common use cases. (The latter two require that the the target -list or dictionary be well-formed, but that is often easy to arrange when the -value is being initially constructed.) -The macro \fBTcl_IncrRefCount\fR increments the reference count -when a new reference to the value is created. -The macro \fBTcl_DecrRefCount\fR decrements the count -when a reference is no longer needed and, -if the value's reference count drops to zero, frees its storage. +Tcl values are allocated on the heap and are shared as much as +possible to reduce storage requirements. Reference counting is used +to determine when a value is no longer needed and can safely be freed. +A value just created by \fBTcl_NewObj\fR, \fBTcl_NewStringObj\fR, or +any Abstract List command or function, has \fIrefCount\fR 0, meaning +that the object can often be given to a function like +\fBTcl_SetObjResult\fR, \fBTcl_ListObjAppendElement\fR, or +\fBTcl_DictObjPut\fR (as a value) without explicit reference +management, all of which are common use cases. (The latter two require +that the target list or dictionary be well-formed, but that is +often easy to arrange when the value is being initially constructed.) +The macro \fBTcl_IncrRefCount\fR increments the reference count when a +new reference to the value is created. +The macro \fBTcl_DecrRefCount\fR decrements the count when a reference +is no longer needed. If the value's reference count drops to zero, frees +its storage. +The macro \fBTcl_BounceRefCount\fR will check if the value has no +references (i.e. in a "new" state) and free the value. A value shared by different code or data structures has -\fIrefCount\fR greater than 1. -Incrementing a value's reference count ensures that -it will not be freed too early or have its value change accidentally. +\fIrefCount\fR greater than 1. Incrementing a value's reference count +ensures that it will not be freed too early or have its value change +accidentally. .PP As an example, the bytecode interpreter shares argument values between calling and called Tcl procedures to avoid having to copy values. @@ -311,12 +316,25 @@ the interpreter calls \fBTcl_DecrRefCount\fR to decrement each argument's reference count. When a value's reference count drops less than or equal to zero, \fBTcl_DecrRefCount\fR reclaims its storage. -Most command procedures do not have to be concerned about -reference counting since they use a value's value immediately -and do not retain a pointer to the value after they return. -However, if they do retain a pointer to a value in a data structure, -they must be careful to increment its reference count -since the retained pointer is a new reference. + +.PP +Most command procedures have not been concerned about reference +counting since they use a value immediately and do not retain +a pointer to the value after they return. However, there are some +procedures that may return a new value, with a refCount of 0. In this +situation, it is the caller's responsibility to free the value before +the procedure returns. One way to cover this is to always call +\fBTcl_IncrRefCount\fR before using the value, then call +\fBTcl_DecrRefCount\fR before returning. The other way is to use +\fBTcl_BounceRefCount\fR after the value is no longer needed or +referenced. This macro will free the value if there are no other +references to the value. When retaining a pointer to a value in a data +structure the procedure must be careful to increment its reference +count since the retained pointer is a new reference. Examples of +procedures that return new values are \fBTcl_NewIntObj\fR, and +commands like \fBlseq\fR, which creates an Abstract List, and an +lindex on this list may return a new Obj with a refCount of 0. + .PP Command procedures that directly modify values such as those for \fBlappend\fR and \fBlinsert\fR must be careful to @@ -350,6 +368,11 @@ must check whether the variable's value is shared before incrementing the integer in its internal representation. If it is shared, it needs to duplicate the value in order to avoid accidentally changing values in other data structures. +.PP +In cases where a value is obtained, used, and not retained, the value +can be freed using \fBTcl_BounceRefCount\fR. This +is functionally equivalent to calling \fBTcl_IncrRefCount\fR followed +\fBTcl_DecrRefCount\fR. .SH "SEE ALSO" Tcl_ConvertToType(3), Tcl_GetIntFromObj(3), Tcl_ListObjAppendElement(3), Tcl_ListObjIndex(3), Tcl_ListObjReplace(3), Tcl_RegisterObjType(3) .SH KEYWORDS diff --git a/doc/ObjectType.3 b/doc/ObjectType.3 index 7e3cc12..62104a8 100644 --- a/doc/ObjectType.3 +++ b/doc/ObjectType.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures" +.TH Tcl_ObjType 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME @@ -23,6 +23,7 @@ int .sp int \fBTcl_ConvertToType\fR(\fIinterp, objPtr, typePtr\fR) +.fi .SH ARGUMENTS .AS "const char" *typeName .AP "const Tcl_ObjType" *typePtr in @@ -93,22 +94,32 @@ free to set the internal representation for \fIobjPtr\fR to make use of another related Tcl_ObjType, if it sees fit. .SH "THE TCL_OBJTYPE STRUCTURE" .PP -Extension writers can define new value types by defining four -procedures and -initializing a Tcl_ObjType structure to describe the type. -Extension writers may also pass a pointer to their Tcl_ObjType -structure to \fBTcl_RegisterObjType\fR if they wish to permit -other extensions to look up their Tcl_ObjType by name with -the \fBTcl_GetObjType\fR routine. -The \fBTcl_ObjType\fR structure is defined as follows: +Extension writers can define new value types by defining four to eight +procedures and initializing a Tcl_ObjType structure to describe the +type. Extension writers may also pass a pointer to their Tcl_ObjType +structure to \fBTcl_RegisterObjType\fR if they wish to permit other +extensions to look up their Tcl_ObjType by name with the +\fBTcl_GetObjType\fR routine. The \fBTcl_ObjType\fR structure is +defined as follows: .PP .CS -typedef struct Tcl_ObjType { +typedef struct { const char *\fIname\fR; Tcl_FreeInternalRepProc *\fIfreeIntRepProc\fR; Tcl_DupInternalRepProc *\fIdupIntRepProc\fR; Tcl_UpdateStringProc *\fIupdateStringProc\fR; Tcl_SetFromAnyProc *\fIsetFromAnyProc\fR; + size_t \fIversion\fR; + /* List emulation functions - ObjType Version 1 & 2 */ + Tcl_ObjTypeLengthProc *lengthProc; + /* List emulation functions - ObjType Version 2 */ + Tcl_ObjTypeIndexProc *\fIindexProc\fR; + Tcl_ObjTypeSliceProc *\fIsliceProc\fR; + Tcl_ObjTypeReverseProc *\fIreverseProc\fR; + Tcl_ObjTypeGetElements *\fIgetElementsProc\fR; + Tcl_ObjTypeSetElement *\fIsetElementProc\fR; + Tcl_ObjTypeReplaceProc *\fIreplaceProc\fR; + Tcl_ObjTypeInOperatorProc *\fIinOperProc\fR; } \fBTcl_ObjType\fR; .CE .SS "THE NAME FIELD" @@ -184,8 +195,8 @@ to be treated as conventional null character-terminated C strings. These restrictions are easily met by using Tcl's internal UTF encoding for the string representation, same as one would do for other Tcl routines accepting string values as arguments. -Storage for the byte array must be allocated in the heap by \fBTcl_Alloc\fR -or \fBckalloc\fR. Note that \fIupdateStringProc\fRs must allocate +Storage for the byte array must be allocated in the heap by \fBTcl_Alloc\fR. +Note that \fIupdateStringProc\fRs must allocate enough storage for the string's bytes and the terminating null byte. .PP The \fIupdateStringProc\fR for Tcl's built-in double type, for example, @@ -253,6 +264,135 @@ Note that if a subsidiary value has its reference count reduced to zero during the running of a \fIfreeIntRepProc\fR, that value may be not freed immediately, in order to limit stack usage. However, the value will be freed before the outermost current \fBTcl_DecrRefCount\fR returns. +.SS "THE VERSION FIELD" +.PP +The \fIversion\fR member provides for future extensibility of the +structure and should be set to \fBTCL_OBJTYPE_V0\fR for compatibility +of ObjType definitions prior to version 9.0. Specifics about versions +will be described further in the sections below. +.SH "ABSTRACT LIST TYPES" +.PP +Additional fields in the Tcl_ObjType descriptor allow for control over +how custom data values can be manipulated using Tcl's List commands +without converting the value to a List type. This requires the custom +type to provide functions that will perform the given operation on the +custom data representation. Not all functions are required. In the +absence of a particular function (set to NULL), the fallback is to +allow the internal List operation to perform the operation, most +likely causing the value type to be converted to a traditional list. +.SS "SCALAR VALUE TYPES" +.PP +For a custom value type that is scalar or atomic in nature, i.e., not +a divisible collection, version \fBTCL_OBJTYPE_V1\fR is +recommended. In this case, List commands will treat the scalar value +as if it where a list of length 1, and not convert the value to a List +type. +.SS "VERSION 2: ABSTRACT LISTS" +.PP +Version 2, \fBTCL_OBJTYPE_V2\fR, allows full List support when the +functions described below are provided. This allows for script level +use of the List commands without causing the type of the Tcl_Obj value +to be converted to a list. +.SS "THE LENGTHPROC FIELD" +.PP +The \fBLengthProc\fR function correlates with the \fBTcl_ListObjLength\fR +C API. The function returns the number of elements in the list. It +is used in every List operation and is required for all Abstract List +implementations. +.CS +typedef Tcl_Size +(Tcl_ObjTypeLengthProc) (Tcl_Obj *listPtr); +.CE +.PP +.SS "THE INDEXPROC FIELD" +.PP +The \fBIndexProc\fR function correlates with with the +\fBTcl_ListObjIndex\fR C API. The function returns a Tcl_Obj value for +the element at the specified index. +.CS +typedef int (\fBTcl_ObjTypeIndexProc\fR) ( + Tcl_Interp *interp, + Tcl_Obj *listPtr, + Tcl_Size index, + Tcl_Obj** elemObj); +.CE +.SS "THE SLICEPROC FIELD" +.PP +The \fBSliceProc\fR correlates with the \fBlrange\fR command, +returning a new List or Abstract List for the portion of the original +list specified. +.CS +typedef int (\fBTcl_ObjTypeSliceProc\fR) ( + Tcl_Interp *interp, + Tcl_Obj *listPtr, + Tcl_Size fromIdx, + Tcl_Size toIdx, + Tcl_Obj **newObjPtr); +.CE +.SS "THE REVERSEPROC FIELD" +.PP +The \fBReverseProc\fR correlates with the \fBlreverse\fR command, +returning a List or Abstract List that has the same elements as the +input Abstract List, with the elements in the reverse order. +.CS +typedef int (\fBTcl_ObjTypeReverseProc\fR) ( + Tcl_Interp *interp, + Tcl_Obj *listPtr, + Tcl_Obj **newObjPtr); +.CE +.SS "THE GETELEMENTS FIELD" +.PP +The \fBGetElements\fR function returns a count and a pointer to an +array of Tcl_Obj values for the entire Abstract List. This +correlates to the \fBTcl_ListObjGetElements\fR C API call. +.CS +typedef int (\fBTcl_ObjTypeGetElements\fR) ( + Tcl_Interp *interp, + Tcl_Obj *listPtr, + Tcl_Size *objcptr, + Tcl_Obj ***objvptr); +.CE +.SS "THE SETELEMENT FIELD" +.PP +The \fBSetElement\fR function replaces the element within the +specified list at the give index. This function correlates to the +\fBlset\fR command. +.CS +typedef Tcl_Obj *(\fBTcl_ObjTypeSetElement\fR) ( + Tcl_Interp *interp, + Tcl_Obj *listPtr, + Tcl_Size indexCount, + Tcl_Obj *const indexArray[], + Tcl_Obj *valueObj); +.CE +.SS "REPLACEPROC FIELD" +.PP +The \fBReplaceProc\fR returns a new list after modifying the list +replacing the elements to be deleted, and adding the elements to be +inserted. This function correlates to the \fBTcl_ListObjReplace\fR C API. +.CS +typedef int (\fBTcl_ObjTypeReplaceProc\fR) ( + Tcl_Interp *interp, + Tcl_Obj *listObj, + Tcl_Size first, + Tcl_Size numToDelete, + Tcl_Size numToInsert, + Tcl_Obj *const insertObjs[]); +.CE +.SS "THE INOPERPROC FIELD" +.PP +The \fBInOperProc\fR function determines whether the value is present in the +given list, according to equivalent string comparison of elements. The +\fBboolResult\fR is set to 1 (true) if the value is present, and 0 +(false) if it is not present. This function implements the "in" and +"ni" math operators for an abstract list. +.CS +typedef int (\fBTcl_ObjTypeInOperatorProc\fR) ( + Tcl_Interp *interp, + Tcl_Obj *valueObj, + Tcl_Obj *listObj, + int *boolResult); +.CE .SH "REFERENCE COUNT MANAGEMENT" .PP The \fIobjPtr\fR argument to \fBTcl_AppendAllObjTypes\fR should be an unshared @@ -271,6 +411,7 @@ modify the reference count of their arguments, but if the values contain subsidiary values (e.g., the elements of a list or the keys of a dictionary) then those subsidiary values may have their reference counts modified. .SH "SEE ALSO" -Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3) +Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_BounceRefCount(3) .SH KEYWORDS -internal representation, value, value type, string representation, type conversion +internal representation, value, value type, string representation, +type conversion diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 index 85100fc..59364e0 100644 --- a/doc/OpenFileChnl.3 +++ b/doc/OpenFileChnl.3 @@ -32,7 +32,6 @@ int int \fBTcl_GetChannelNamesEx\fR(\fIinterp, pattern\fR) .sp -void \fBTcl_RegisterChannel\fR(\fIinterp, channel\fR) .sp int @@ -47,34 +46,34 @@ int int \fBTcl_Close\fR(\fIinterp, channel\fR) .sp -int +Tcl_Size \fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR) .sp -int +Tcl_Size \fBTcl_Read\fR(\fIchannel, readBuf, bytesToRead\fR) .sp -int +Tcl_Size \fBTcl_GetsObj\fR(\fIchannel, lineObjPtr\fR) .sp -int +Tcl_Size \fBTcl_Gets\fR(\fIchannel, lineRead\fR) .sp -int +Tcl_Size \fBTcl_Ungets\fR(\fIchannel, input, inputLen, addAtEnd\fR) .sp -int +Tcl_Size \fBTcl_WriteObj\fR(\fIchannel, writeObjPtr\fR) .sp -int +Tcl_Size \fBTcl_WriteChars\fR(\fIchannel, charBuf, bytesToWrite\fR) .sp -int +Tcl_Size \fBTcl_Write\fR(\fIchannel, byteBuf, bytesToWrite\fR) .sp -int +Tcl_Size \fBTcl_ReadRaw\fR(\fIchannel, readBuf, bytesToRead\fR) .sp -int +Tcl_Size \fBTcl_WriteRaw\fR(\fIchannel, byteBuf, bytesToWrite\fR) .sp int @@ -106,7 +105,7 @@ int .sp int \fBTcl_SetChannelOption\fR(\fIinterp, channel, optionName, newValue\fR) -.sp +.fi .SH ARGUMENTS .AS Tcl_DString *channelName in/out .AP Tcl_Interp *interp in @@ -119,7 +118,7 @@ allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. -.AP int argc in +.AP Tcl_Size argc in The number of elements in \fIargv\fR. .AP "const char" **argv in Arguments for constructing a command pipeline. These values have the same @@ -134,7 +133,7 @@ input of the invoking process; likewise for \fBTCL_STDOUT\fR and redirect stdio handles to override the stdio handles for which \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR have been set. If it is set, then such redirections cause an error. -.AP ClientData handle in +.AP void *handle in Operating system specific handle for I/O to a file. For Unix this is a file descriptor, for Windows it is a HANDLE. .AP int readOrWrite in @@ -154,7 +153,7 @@ from a procedure such as \fBTcl_OpenFileChannel\fR. .AP Tcl_Obj *readObjPtr in/out A pointer to a Tcl value in which to store the characters read from the channel. -.AP int charsToRead in +.AP Tcl_Size charsToRead in The number of characters to read from the channel. If the channel's encoding is \fBbinary\fR, this is equivalent to the number of bytes to read from the channel. @@ -163,7 +162,7 @@ If non-zero, data read from the channel will be appended to the value. Otherwise, the data will replace the existing contents of the value. .AP char *readBuf out A buffer in which to store the bytes read from the channel. -.AP int bytesToRead in +.AP Tcl_Size bytesToRead in The number of bytes to read from the channel. The buffer \fIreadBuf\fR must be large enough to hold this many bytes. .AP Tcl_Obj *lineObjPtr in/out @@ -176,7 +175,7 @@ channel. Must have been initialized by the caller. The line read will be appended to any data already in the dynamic string. .AP "const char" *input in The input to add to a channel buffer. -.AP int inputLen in +.AP Tcl_Size inputLen in Length of the input .AP int addAtEnd in Flag indicating whether the input should be added to the end or @@ -187,7 +186,7 @@ A pointer to a Tcl value whose contents will be output to the channel. A buffer containing the characters to output to the channel. .AP "const char" *byteBuf in A buffer containing the bytes to output to the channel. -.AP int bytesToWrite in +.AP Tcl_Size bytesToWrite in The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and output to the channel. .AP "long long" offset in @@ -391,7 +390,7 @@ If the channel is being closed synchronously and an error occurs during closing of the channel and \fIinterp\fR is not NULL, an error message is left in the interpreter's result. .PP -Note: it is not safe to call \fBTcl_Close\fR on a channel that has been +Note that it is not safe to call \fBTcl_Close\fR on a channel that has been registered using \fBTcl_RegisterChannel\fR; see the documentation for \fBTcl_RegisterChannel\fR, above, for details. If the channel has ever been given as the \fBchan\fR argument in a call to @@ -406,12 +405,12 @@ to UTF-8 based on the channel's encoding and storing the produced data in \fIreadObjPtr\fR's string representation. The return value of \fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR, that were stored in \fIreadObjPtr\fR. If an error occurs while reading, the -return value is TCL_INDEX_NONE and \fBTcl_ReadChars\fR records a POSIX error +return value is -1 and \fBTcl_ReadChars\fR records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. If an encoding error happens while the channel is in blocking mode with -profile strict, the characters retrieved until the encoding error happened will be stored in \fIreadObjPtr\fR. .PP -Setting \fIcharsToRead\fR to TCL_INDEX_NONE will cause the command to read +Setting \fIcharsToRead\fR to -1 will cause the command to read all characters currently available (non-blocking) or everything until eof (blocking mode). .PP @@ -473,14 +472,14 @@ character(s) are read and discarded. .PP If a line was successfully read, the return value is greater than or equal to zero and indicates the number of bytes stored in \fIlineObjPtr\fR. If an -error occurs, \fBTcl_GetsObj\fR returns TCL_INDEX_NONE and records a POSIX error code +error occurs, \fBTcl_GetsObj\fR returns -1 and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. \fBTcl_GetsObj\fR also -returns TCL_INDEX_NONE if the end of the file is reached; the \fBTcl_Eof\fR procedure +returns -1 if the end of the file is reached; the \fBTcl_Eof\fR procedure can be used to distinguish an error from an end-of-file condition. .PP -If the channel is in nonblocking mode, the return value can also be TCL_INDEX_NONE +If the channel is in nonblocking mode, the return value can also be -1 if no data was available or the data that was available did not contain an -end-of-line character. When TCL_INDEX_NONE is returned, the \fBTcl_InputBlocked\fR +end-of-line character. When -1 is returned, the \fBTcl_InputBlocked\fR procedure may be invoked to determine if the channel is blocked because of input unavailability. .PP @@ -498,7 +497,7 @@ head of the queue. If \fIchannel\fR has a .QW sticky EOF set, no data will be added to the input queue. \fBTcl_Ungets\fR returns \fIinputLen\fR or -TCL_INDEX_NONE if an error occurs. +-1 if an error occurs. .SH "TCL_WRITECHARS, TCL_WRITEOBJ, AND TCL_WRITE" .PP \fBTcl_WriteChars\fR accepts \fIbytesToWrite\fR bytes of character data at @@ -515,7 +514,7 @@ to appear as soon as a complete line is accepted for output, set the \fB\-buffering\fR option on the channel to \fBline\fR mode. .PP The return value of \fBTcl_WriteChars\fR is a count of how many bytes were -accepted for output to the channel. This is either TCL_INDEX_NONE to +accepted for output to the channel. This is either -1 to indicate that an error occurred or another number greater than zero to indicate success. If an error occurs, \fBTcl_WriteChars\fR records a POSIX error code that may be retrieved with \fBTcl_GetErrno\fR. diff --git a/doc/OpenTcp.3 b/doc/OpenTcp.3 index e72556a..709a8fc 100644 --- a/doc/OpenTcp.3 +++ b/doc/OpenTcp.3 @@ -25,7 +25,7 @@ Tcl_Channel .sp Tcl_Channel \fBTcl_OpenTcpServerEx\fR(\fIinterp, service, myaddr, flags, backlog, proc, clientData\fR) -.sp +.fi .SH ARGUMENTS .AS Tcl_TcpAcceptProc clientData .AP Tcl_Interp *interp in @@ -51,13 +51,13 @@ If nonzero, the client socket is connected asynchronously to the server. 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 -informations about the socket being created. -.AP ClientData sock in +information about the socket being created. +.AP void *sock in Platform-specific handle for client TCP socket. .AP Tcl_TcpAcceptProc *proc in Pointer to a procedure to invoke each time a new connection is accepted via the socket. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION @@ -129,7 +129,7 @@ the channel. \fIProc\fR must match the following prototype: .PP .CS typedef void \fBTcl_TcpAcceptProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Channel \fIchannel\fR, char *\fIhostName\fR, int \fIport\fR); diff --git a/doc/Panic.3 b/doc/Panic.3 index 5abe1dd..25e38c2 100644 --- a/doc/Panic.3 +++ b/doc/Panic.3 @@ -7,33 +7,24 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc, Tcl_ConsolePanic \- report fatal error and abort +Tcl_Panic, Tcl_SetPanicProc, Tcl_ConsolePanic \- report fatal error and abort .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp -void \fBTcl_Panic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR) .sp -void -\fBTcl_PanicVA\fR(\fIformat\fR, \fIargList\fR) -.sp const char * \fBTcl_SetPanicProc\fR(\fIpanicProc\fR) .sp -void \fBTcl_ConsolePanic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR) -.sp +.fi .SH ARGUMENTS .AS Tcl_PanicProc *panicProc .AP "const char*" format in A printf-style format string. .AP "" arg in Arguments matching the format string. -.AP va_list argList in -An argument list of arguments matching the format string. -Must have been initialized using \fBva_start\fR, -and cleared using \fBva_end\fR. .AP Tcl_PanicProc *panicProc in Procedure to report fatal error message and abort. .BE @@ -83,14 +74,13 @@ call the Tcl library, since the original call to \fBTcl_Panic\fR indicates the Tcl library is not in a state of reliable operation. .PP The result of \fBTcl_SetPanicProc\fR is the full Tcl version with build -information (e.g., \fB8.7.0+abcdef...abcdef.gcc-1002\fR). +information (e.g., \fB9.0.0+abcdef...abcdef.gcc-1002\fR). .PP The typical use of \fBTcl_SetPanicProc\fR arranges for the error message to be displayed or reported in a manner more suitable for the application or the platform. .PP -\fBTcl_SetPanicProc\fR can not be used in stub-enabled extensions. Its symbol -entry in the stub table is deprecated and it will be removed in Tcl 9.0. +\fBTcl_SetPanicProc\fR can not be used in stub-enabled extensions. .PP Although the primary callers of \fBTcl_Panic\fR are the procedures of the Tcl library, \fBTcl_Panic\fR is a public function and may be called @@ -98,10 +88,6 @@ by any extension or application that wishes to abort the process and have a panic message displayed the same way that panic messages from Tcl will be displayed. .PP -\fBTcl_PanicVA\fR is the same as \fBTcl_Panic\fR except that instead of -taking a variable number of arguments it takes an argument list. Interfaces -using argument lists have been found to be nonportable in practice. This -function is deprecated and will be removed in Tcl 9.0. .SH "SEE ALSO" abort(3), printf(3), exec(n), format(n) .SH KEYWORDS diff --git a/doc/ParseArgs.3 b/doc/ParseArgs.3 index f29f161..edc0bc0 100644 --- a/doc/ParseArgs.3 +++ b/doc/ParseArgs.3 @@ -15,23 +15,29 @@ Tcl_ParseArgsObjv \- parse arguments according to a tabular description .sp int \fBTcl_ParseArgsObjv\fR(\fIinterp, argTable, objcPtr, objv, remObjv\fR) +.fi .SH ARGUMENTS .AS "const Tcl_ArgvInfo" ***remObjv in/out .AP Tcl_Interp *interp out Where to store error messages. .AP "const Tcl_ArgvInfo" *argTable in Pointer to array of option descriptors. -.AP int *objcPtr in/out +.AP "Tcl_Size \&| int" *objcPtr in/out A pointer to variable holding number of arguments in \fIobjv\fR. Will be modified to hold number of arguments left in the unprocessed argument list stored in \fIremObjv\fR. +May be (Tcl_Size *)NULL when not used. If it points to a variable which +type is not \fBTcl_Size\fR, a compiler warning will be generated. +If your extensions is compiled with -DTCL_8_API, this function will return +NULL for argument lists with more than INT_MAX elements (which should +trigger proper error-handling), otherwise expect it to crash. .AP "Tcl_Obj *const" *objv in The array of arguments to be parsed. .AP Tcl_Obj ***remObjv out Pointer to a variable that will hold the array of unprocessed arguments. Should be NULL if no return of unprocessed arguments is required. If \fIobjcPtr\fR is updated to a non-zero value, the array returned through this -must be deallocated using \fBckfree\fR. +must be deallocated using \fBTcl_Free\fR. .BE .SH DESCRIPTION .PP @@ -57,20 +63,14 @@ The collection of arguments to be parsed is described by the \fIargTable\fR parameter. This points to a table of descriptor structures that is terminated by an entry with the \fItype\fR field set to TCL_ARGV_END. As convenience, the following prototypical entries are provided: -.TP -\fBTCL_ARGV_AUTO_HELP\fR -. +.IP \fBTCL_ARGV_AUTO_HELP\fR Enables the argument processor to provide help when passed the argument .QW \fB\-help\fR . -.TP -\fBTCL_ARGV_AUTO_REST\fR -. +.IP \fBTCL_ARGV_AUTO_REST\fR Instructs the argument processor that arguments after .QW \fB\-\-\fR are to be unprocessed. -.TP -\fBTCL_ARGV_TABLE_END\fR -. +.IP \fBTCL_ARGV_TABLE_END\fR Marks the end of the table of argument descriptors. .SS "ARGUMENT DESCRIPTOR ENTRIES" .PP @@ -84,7 +84,7 @@ typedef struct { void *\fIsrcPtr\fR; void *\fIdstPtr\fR; const char *\fIhelpStr\fR; - ClientData \fIclientData\fR; + void *\fIclientData\fR; } \fBTcl_ArgvInfo\fR; .CE .PP @@ -99,27 +99,19 @@ users when they request it. As noted above, the \fItype\fR field is used to describe the interpretation of the argument's value. The following values are acceptable values for \fItype\fR: -.TP -\fBTCL_ARGV_CONSTANT\fR -. +.IP \fBTCL_ARGV_CONSTANT\fR The argument does not take any following value argument. If this argument is present, the (integer) value of the \fIsrcPtr\fR field is copied to the variable pointed to by the \fIdstPtr\fR field. The \fIclientData\fR field is ignored. -.TP -\fBTCL_ARGV_END\fR -. +.IP \fBTCL_ARGV_END\fR This value marks the end of all option descriptors in the table. All other fields are ignored. -.TP -\fBTCL_ARGV_FLOAT\fR -. +.IP \fBTCL_ARGV_FLOAT\fR This argument takes a following floating point value argument. The value (once parsed by \fBTcl_GetDoubleFromObj\fR) will be stored as a double-precision value in the variable pointed to by the \fIdstPtr\fR field. The \fIsrcPtr\fR and \fIclientData\fR fields are ignored. -.TP -\fBTCL_ARGV_FUNC\fR -. +.IP \fBTCL_ARGV_FUNC\fR This argument optionally takes a following value argument; it is up to the handler callback function passed in \fIsrcPtr\fR to decide. That function will have the following signature: @@ -127,7 +119,7 @@ have the following signature: .PP .CS typedef int (\fBTcl_ArgvFuncProc\fR)( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Obj *\fIobjPtr\fR, void *\fIdstPtr\fR); .CE @@ -138,9 +130,7 @@ argument. The \fIclientData\fR is the value from the table entry, the there are no following arguments at all, and the \fIdstPtr\fR argument to the \fBTcl_ArgvFuncProc\fR is the location to write the parsed value to. .RE -.TP -\fBTCL_ARGV_GENFUNC\fR -. +.IP \fBTCL_ARGV_GENFUNC\fR This argument takes zero or more following arguments; the handler callback function passed in \fIsrcPtr\fR returns how many (or a negative number to signal an error, in which case it should also set the interpreter result). The @@ -149,7 +139,7 @@ function will have the following signature: .PP .CS typedef int (\fBTcl_ArgvGenFuncProc\fR)( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIobjc\fR, Tcl_Obj *const *\fIobjv\fR, @@ -162,28 +152,20 @@ argument, \fIobjc\fR and \fIobjv\fR describe an array of all the remaining arguments, and \fIdstPtr\fR argument to the \fBTcl_ArgvGenFuncProc\fR is the location to write the parsed value (or values) to. .RE -.TP -\fBTCL_ARGV_HELP\fR -. +.IP \fBTCL_ARGV_HELP\fR This special argument does not take any following value argument, but instead causes \fBTcl_ParseArgsObjv\fR to generate an error message describing the arguments supported. All other fields except the \fIhelpStr\fR field are ignored. -.TP -\fBTCL_ARGV_INT\fR -. +.IP \fBTCL_ARGV_INT\fR This argument takes a following integer value argument. The value (once parsed by \fBTcl_GetIntFromObj\fR) will be stored as an int in the variable pointed to by the \fIdstPtr\fR field. The \fIsrcPtr\fR field is ignored. -.TP -\fBTCL_ARGV_REST\fR -. +.IP \fBTCL_ARGV_REST\fR This special argument does not take any following value argument, but instead marks all following arguments to be left unprocessed. The \fIsrcPtr\fR, \fIdstPtr\fR and \fIclientData\fR fields are ignored. -.TP -\fBTCL_ARGV_STRING\fR -. +.IP \fBTCL_ARGV_STRING\fR This argument takes a following string value argument. A pointer to the string will be stored at \fIdstPtr\fR; the string inside will have a lifetime linked to the lifetime of the string representation of the argument value that it diff --git a/doc/ParseCmd.3 b/doc/ParseCmd.3 index 03b97f7..cdce96c 100644 --- a/doc/ParseCmd.3 +++ b/doc/ParseCmd.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions +Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -33,23 +33,20 @@ const char * .sp \fBTcl_FreeParse\fR(\fIusedParsePtr\fR) .sp -Tcl_Obj * -\fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR) -.sp int \fBTcl_EvalTokensStandard\fR(\fIinterp, tokenPtr, numTokens\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *usedParsePtr out .AP Tcl_Interp *interp out -For procedures other than \fBTcl_FreeParse\fR, \fBTcl_EvalTokens\fR -and \fBTcl_EvalTokensStandard\fR, used only for error reporting; +For procedures other than \fBTcl_FreeParse\fR and +\fBTcl_EvalTokensStandard\fR, used only for error reporting; if NULL, then no error messages are left after errors. -For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR, -determines the context for evaluating the -script and also is used for error reporting; must not be NULL. +For \fBTcl_EvalTokensStandard\fR, determines the context for evaluating +the script and also is used for error reporting; must not be NULL. .AP "const char" *start in Pointer to first character in string to parse. -.AP int numBytes in +.AP Tcl_Size numBytes in Number of bytes in string to parse, not including any terminating null character. If less than 0 then the script consists of all characters following \fIstart\fR up to the first null character. @@ -191,17 +188,6 @@ code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. -.SS "DEPRECATED FUNCTIONS" -.PP -\fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in -the return convention used: it returns the result in a new Tcl_Obj. -The reference count of the value returned as result has been -incremented, so the caller must -invoke \fBTcl_DecrRefCount\fR when it is finished with the value. -If an error or other exception occurs while evaluating the tokens -(such as a reference to a non-existent variable) then the return value -is NULL and an error message is left in \fIinterp\fR's result. The use -of \fBTcl_EvalTokens\fR is deprecated. .SH "TCL_PARSE STRUCTURE" .PP \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, @@ -209,22 +195,22 @@ of \fBTcl_EvalTokens\fR is deprecated. return parse information in two data structures, Tcl_Parse and Tcl_Token: .PP .CS -typedef struct Tcl_Parse { +typedef struct { const char *\fIcommentStart\fR; - int \fIcommentSize\fR; + Tcl_Size \fIcommentSize\fR; const char *\fIcommandStart\fR; - int \fIcommandSize\fR; - int \fInumWords\fR; + Tcl_Size \fIcommandSize\fR; + Tcl_Size \fInumWords\fR; Tcl_Token *\fItokenPtr\fR; - int \fInumTokens\fR; + Tcl_Size \fInumTokens\fR; ... } \fBTcl_Parse\fR; -typedef struct Tcl_Token { +typedef struct { int \fItype\fR; const char *\fIstart\fR; - int \fIsize\fR; - int \fInumComponents\fR; + Tcl_Size \fIsize\fR; + Tcl_Size \fInumComponents\fR; } \fBTcl_Token\fR; .CE .PP @@ -234,8 +220,7 @@ These fields are not used by the other parsing procedures. .PP \fBTcl_ParseCommand\fR fills in a Tcl_Parse structure with information that describes one Tcl command and any comments that -precede the command. -If there are comments, +precede the command. If there are comments, the \fIcommentStart\fR field points to the \fB#\fR character that begins the first comment and \fIcommentSize\fR indicates the number of bytes in all of the comments preceding the command, including the newline @@ -265,9 +250,7 @@ such as \fBTCL_TOKEN_WORD\fR and \fBTCL_TOKEN_VARIABLE\fR, consist of several component tokens, which immediately follow the parent token; the \fInumComponents\fR field describes how many of these there are. The \fItype\fR field has one of the following values: -.TP 20 -\fBTCL_TOKEN_WORD\fR -. +.IP \fBTCL_TOKEN_WORD\fR This token ordinarily describes one word of a command but it may also describe a quoted or braced string in an expression. The token describes a component of the script that is @@ -280,42 +263,30 @@ space, semicolon, close bracket, close quote, or close brace that terminates the component. The \fInumComponents\fR field counts the total number of sub-tokens that make up the word, including sub-tokens of \fBTCL_TOKEN_VARIABLE\fR and \fBTCL_TOKEN_BS\fR tokens. -.TP -\fBTCL_TOKEN_SIMPLE_WORD\fR -. +.IP \fBTCL_TOKEN_SIMPLE_WORD\fR This token has the same meaning as \fBTCL_TOKEN_WORD\fR, except that the word is guaranteed to consist of a single \fBTCL_TOKEN_TEXT\fR sub-token. The \fInumComponents\fR field is always 1. -.TP -\fBTCL_TOKEN_EXPAND_WORD\fR -. +.IP \fBTCL_TOKEN_EXPAND_WORD\fR This token has the same meaning as \fBTCL_TOKEN_WORD\fR, except that the command parser notes this word began with the expansion prefix \fB{*}\fR, indicating that after substitution, the list value of this word should be expanded to form multiple arguments in command evaluation. This token type can only be created by Tcl_ParseCommand. -.TP -\fBTCL_TOKEN_TEXT\fR -. +.IP \fBTCL_TOKEN_TEXT\fR The token describes a range of literal text that is part of a word. The \fInumComponents\fR field is always 0. -.TP -\fBTCL_TOKEN_BS\fR -. +.IP \fBTCL_TOKEN_BS\fR The token describes a backslash sequence such as \fB\en\fR or \fB\e0xA3\fR. The \fInumComponents\fR field is always 0. -.TP -\fBTCL_TOKEN_COMMAND\fR -. +.IP \fBTCL_TOKEN_COMMAND\fR The token describes a command whose result must be substituted into the word. The token includes the square brackets that surround the command. The \fInumComponents\fR field is always 0 (the nested command is not parsed; call \fBTcl_ParseCommand\fR recursively if you want to see its tokens). -.TP -\fBTCL_TOKEN_VARIABLE\fR -. +.IP \fBTCL_TOKEN_VARIABLE\fR The token describes a variable substitution, including the \fB$\fR, variable name, and array index (if there is one) up through the close parenthesis that terminates the index. This token is followed @@ -329,9 +300,7 @@ token giving the array name and the remaining sub-tokens are \fBTCL_TOKEN_VARIABLE\fR tokens that must be concatenated to produce the array index. The \fInumComponents\fR field includes nested sub-tokens that are part of \fBTCL_TOKEN_VARIABLE\fR tokens in the array index. -.TP -\fBTCL_TOKEN_SUB_EXPR\fR -. +.IP \fBTCL_TOKEN_SUB_EXPR\fR The token describes one subexpression of an expression (or an entire expression). A subexpression may consist of a value @@ -356,9 +325,7 @@ one of the token types \fBTCL_TOKEN_WORD\fR, \fBTCL_TOKEN_TEXT\fR, The \fInumComponents\fR field counts the total number of sub-tokens that make up the subexpression; this includes the sub-tokens for any nested \fBTCL_TOKEN_SUB_EXPR\fR tokens. -.TP -\fBTCL_TOKEN_OPERATOR\fR -. +.IP \fBTCL_TOKEN_OPERATOR\fR The token describes one operator of an expression such as \fB&&\fR or \fBhypot\fR. A \fBTCL_TOKEN_OPERATOR\fR token is always preceded by a @@ -464,12 +431,6 @@ There are additional fields in the Tcl_Parse structure after the \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR; they should not be referenced by code outside of these procedures. -.SH "REFERENCE COUNT MANAGEMENT" -.PP -The result of \fBTcl_EvalTokens\fR is an unshared value with a reference count -of 1; the caller of that function should call \fBTcl_DecrRefCount\fR on the -result value to dispose of it. (The equivalent with -\fBTcl_EvalTokenStandard\fR is just the interpreter result, which can be -retrieved with \fBTcl_GetObjResult\fR.) .SH KEYWORDS -backslash substitution, braces, command, expression, parse, token, variable substitution +backslash substitution, braces, command, expression, parse, token, +variable substitution diff --git a/doc/PkgRequire.3 b/doc/PkgRequire.3 index bdf6103..c19065b 100644 --- a/doc/PkgRequire.3 +++ b/doc/PkgRequire.3 @@ -33,6 +33,7 @@ int .sp int \fBTcl_PkgProvideEx\fR(\fIinterp, name, version, clientData\fR) +.fi .SH ARGUMENTS .AS void *clientDataPtr out .AP Tcl_Interp *interp in @@ -54,7 +55,7 @@ Pointer to place to store the value associated with the matching package. It is only changed if the pointer is not NULL and the function completed successfully. The storage can be any pointer type with the same size as a void pointer. -.AP int objc in +.AP Tcl_Size objc in Number of requirements. .AP Tcl_Obj* objv[] in Array of requirements. diff --git a/doc/Preserve.3 b/doc/Preserve.3 index c8f34a2..e01cf80 100644 --- a/doc/Preserve.3 +++ b/doc/Preserve.3 @@ -19,9 +19,10 @@ Tcl_Preserve, Tcl_Release, Tcl_EventuallyFree \- avoid freeing storage while it \fBTcl_Release\fR(\fIclientData\fR) .sp \fBTcl_EventuallyFree\fR(\fIclientData, freeProc\fR) +.fi .SH ARGUMENTS .AS Tcl_FreeProc clientData -.AP ClientData clientData in +.AP void *clientData in Token describing structure to be freed or reallocated. Usually a pointer to memory for structure. .AP Tcl_FreeProc *freeProc in @@ -91,7 +92,7 @@ reasons, but the value is the same. .PP When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR refers to storage allocated and returned by a prior call to -\fBTcl_Alloc\fR, \fBckalloc\fR, or another function of the Tcl library, +\fBTcl_Alloc\fR or another function of the Tcl library, then the \fIfreeProc\fR argument should be given the special value of \fBTCL_DYNAMIC\fR. .PP diff --git a/doc/PrintDbl.3 b/doc/PrintDbl.3 index 896b6eb..79398ab 100644 --- a/doc/PrintDbl.3 +++ b/doc/PrintDbl.3 @@ -15,13 +15,11 @@ Tcl_PrintDouble \- Convert floating value to string \fB#include <tcl.h>\fR .sp \fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *interp out .AP Tcl_Interp *interp in -Before Tcl 8.0, the \fBtcl_precision\fR variable in this interpreter -controlled the conversion. As of Tcl 8.0, this argument is ignored and -the conversion is controlled by the \fBtcl_precision\fR variable -that is now shared by all interpreters. +This argument is ignored. .AP double value in Floating-point value to be converted. .AP char *dst out @@ -41,9 +39,7 @@ so that it does not look like an integer. Where \fB%g\fR would generate an integer with no decimal point, \fBTcl_PrintDouble\fR adds .QW .0 . .PP -If the \fBtcl_precision\fR value is non-zero, the result will have -precisely that many digits of significance. If the value is zero -(the default), the result will have the fewest digits needed to +The result will have the fewest digits needed to represent the number in such a way that \fBTcl_NewDoubleObj\fR will generate the same number when presented with the given string. IEEE semantics of rounding to even apply to the conversion. diff --git a/doc/RecEvalObj.3 b/doc/RecEvalObj.3 index e68f4b5..7bfee95 100644 --- a/doc/RecEvalObj.3 +++ b/doc/RecEvalObj.3 @@ -15,6 +15,7 @@ Tcl_RecordAndEvalObj \- save command on history list before evaluating .sp int \fBTcl_RecordAndEvalObj\fR(\fIinterp, cmdPtr, flags\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in @@ -31,7 +32,7 @@ the command at global level instead of the current stack level. .SH DESCRIPTION .PP \fBTcl_RecordAndEvalObj\fR is invoked to record a command as an event -on the history list and then execute it using \fBTcl_EvalObjEx\fR +on the history list and then execute it using \fBTcl_EvalObjEx\fR. It returns a completion code such as \fBTCL_OK\fR just like \fBTcl_EvalObjEx\fR, as well as a result value containing additional information (a result value or error message) diff --git a/doc/RecordEval.3 b/doc/RecordEval.3 index 36ef6b9..a5887f0 100644 --- a/doc/RecordEval.3 +++ b/doc/RecordEval.3 @@ -16,6 +16,7 @@ Tcl_RecordAndEval \- save command on history list before evaluating .sp int \fBTcl_RecordAndEval\fR(\fIinterp, cmd, flags\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in diff --git a/doc/RegConfig.3 b/doc/RegConfig.3 index ef46ba5..f2bd2e3 100644 --- a/doc/RegConfig.3 +++ b/doc/RegConfig.3 @@ -14,9 +14,8 @@ Tcl_RegisterConfig \- procedures to register embedded configuration information .nf \fB#include <tcl.h>\fR .sp -void \fBTcl_RegisterConfig\fR(\fIinterp, pkgName, configuration, valEncoding\fR) -.sp +.fi .SH ARGUMENTS .AS Tcl_Interp *configuration .AP Tcl_Interp *interp in @@ -87,20 +86,23 @@ their associated values can be retrieved through calls to The command \fBpkgconfig\fR will provide two subcommands, \fBlist\fR and \fBget\fR: .RS +.\" METHOD: list .TP ::\fIpkgName\fR::\fBpkgconfig\fR list +. Returns a list containing the names of all defined keys. +.\" METHOD: get .TP ::\fIpkgName\fR::\fBpkgconfig\fR get \fIkey\fR -Returns the configuration value associated with the specified -\fIkey\fR. +. +Returns the configuration value associated with the specified \fIkey\fR. .RE .SH TCL_CONFIG .PP The \fBTcl_Config\fR structure contains the following fields: .PP .CS -typedef struct Tcl_Config { +typedef struct { const char *\fIkey\fR; const char *\fIvalue\fR; } \fBTcl_Config\fR; diff --git a/doc/RegExp.3 b/doc/RegExp.3 index 40429c9..114bbbb 100644 --- a/doc/RegExp.3 +++ b/doc/RegExp.3 @@ -27,7 +27,6 @@ Tcl_RegExp int \fBTcl_RegExpExec\fR(\fIinterp\fR, \fIregexp\fR, \fItext\fR, \fIstart\fR) .sp -void \fBTcl_RegExpRange\fR(\fIregexp\fR, \fIindex\fR, \fIstartPtr\fR, \fIendPtr\fR) .sp Tcl_RegExp @@ -36,7 +35,6 @@ Tcl_RegExp int \fBTcl_RegExpExecObj\fR(\fIinterp\fR, \fIregexp\fR, \fItextObj\fR, \fIoffset\fR, \fInmatches\fR, \fIeflags\fR) .sp -void \fBTcl_RegExpGetInfo\fR(\fIregexp\fR, \fIinfoPtr\fR) .fi .SH ARGUMENTS @@ -64,7 +62,7 @@ identifies the beginning of the larger string. If it is not the same as \fItext\fR, then no .QW \fB^\fR matches will be allowed. -.AP int index in +.AP Tcl_Size index in Specifies which range is desired: 0 means the range of the entire match, 1 or greater means the range that matched a parenthesized sub-expression. @@ -80,14 +78,14 @@ OR-ed combination of the compilation flags \fBTCL_REG_ADVANCED\fR, \fBTCL_REG_QUOTE\fR, \fBTCL_REG_NOCASE\fR, \fBTCL_REG_NEWLINE\fR, \fBTCL_REG_NLSTOP\fR, \fBTCL_REG_NLANCH\fR, \fBTCL_REG_NOSUB\fR, and \fBTCL_REG_CANMATCH\fR. See below for more information. -.AP int offset in +.AP Tcl_Size offset in The character offset into the text where matching should begin. The value of the offset has no impact on \fB^\fR matches. This behavior is controlled by \fIeflags\fR. -.AP int nmatches in +.AP Tcl_Size nmatches in The number of matching subexpressions that should be remembered for later use. If this value is 0, then no subexpression match -information will be computed. If the value is \-1, then +information will be computed. If the value is negative, then all of the matching subexpressions will be remembered. Any other value will be taken as the maximum number of subexpressions to remember. @@ -124,7 +122,7 @@ used in subsequent calls to \fBTcl_RegExpExec\fR or \fBTcl_RegExpRange\fR. If an error occurs while compiling the regular expression then \fBTcl_RegExpCompile\fR returns NULL and leaves an error message in the interpreter result. -Note: the return value from \fBTcl_RegExpCompile\fR is only valid +Note that the return value from \fBTcl_RegExpCompile\fR is only valid up to the next call to \fBTcl_RegExpCompile\fR; it is not safe to retain these values for long periods of time. .PP @@ -190,6 +188,7 @@ zero or more of the following flags that control the compilation of .RS 2 .TP \fBTCL_REG_ADVANCED\fR +. Compile advanced regular expressions .PQ ARE s . This mode corresponds to @@ -197,6 +196,7 @@ the normal regular expression syntax accepted by the Tcl \fBregexp\fR and \fBregsub\fR commands. .TP \fBTCL_REG_EXTENDED\fR +. Compile extended regular expressions .PQ ERE s . This mode corresponds @@ -204,6 +204,7 @@ to the regular expression syntax recognized by Tcl 8.0 and earlier versions. .TP \fBTCL_REG_BASIC\fR +. Compile basic regular expressions .PQ BRE s . This mode corresponds @@ -212,18 +213,22 @@ like \fBsed\fR and \fBgrep\fR. This is the default if no flags are specified. .TP \fBTCL_REG_EXPANDED\fR +. Compile the regular expression (basic, extended, or advanced) using an expanded syntax that allows comments and whitespace. This mode causes non-backslashed non-bracket-expression white space and #-to-end-of-line comments to be ignored. .TP \fBTCL_REG_QUOTE\fR +. Compile a literal string, with all characters treated as ordinary characters. .TP \fBTCL_REG_NOCASE\fR +. Compile for matching that ignores upper/lower case distinctions. .TP \fBTCL_REG_NEWLINE\fR +. Compile for newline-sensitive matching. By default, newline is a completely ordinary character with no special meaning in either regular expressions or strings. With this flag, @@ -241,6 +246,7 @@ an empty string before any newline in addition to its normal function. \fBREG_NLANCH\fR. .TP \fBTCL_REG_NLSTOP\fR +. Compile for partial newline-sensitive matching, with the behavior of .QW [^ @@ -257,6 +263,7 @@ bracket expressions and never match newline. .TP \fBTCL_REG_NLANCH\fR +. Compile for inverse partial newline-sensitive matching, with the behavior of .QW ^ @@ -277,12 +284,14 @@ matches an empty string before any newline in addition to its normal function. .TP \fBTCL_REG_NOSUB\fR +. Compile for matching that reports only success or failure, not what was matched. This reduces compile overhead and may improve performance. Subsequent calls to \fBTcl_RegExpGetInfo\fR or \fBTcl_RegExpRange\fR will not report any match information. .TP \fBTCL_REG_CANMATCH\fR +. Compile for matching that reports the potential to complete a partial match given more text (see below). .RE @@ -312,6 +321,7 @@ zero or more of the following flags: .RS 2 .TP \fBTCL_REG_NOTBOL\fR +. The starting character will not be treated as the beginning of a line or the beginning of the string, so .QW ^ @@ -321,6 +331,7 @@ Note that this flag has no effect on how matches. .TP \fBTCL_REG_NOTEOL\fR +. The last character in the string will not be treated as the end of a line or the end of the string, so .QW $ @@ -336,10 +347,10 @@ performed with a given regular expression \fIregexp\fR. The defined as follows: .PP .CS -typedef struct Tcl_RegExpInfo { - int \fInsubs\fR; +typedef struct { + Tcl_Size \fInsubs\fR; Tcl_RegExpIndices *\fImatches\fR; - long \fIextendStart\fR; + Tcl_Size \fIextendStart\fR; } \fBTcl_RegExpInfo\fR; .CE .PP @@ -354,9 +365,9 @@ appear in the pattern. Each element is a structure that is defined as follows: .PP .CS -typedef struct Tcl_RegExpIndices { - long \fIstart\fR; - long \fIend\fR; +typedef struct { + Tcl_Size \fIstart\fR; + Tcl_Size \fIend\fR; } \fBTcl_RegExpIndices\fR; .CE .PP @@ -396,4 +407,5 @@ additional reference being taken. .SH "SEE ALSO" re_syntax(n) .SH KEYWORDS -match, pattern, regular expression, string, subexpression, Tcl_RegExpIndices, Tcl_RegExpInfo +match, pattern, regular expression, string, subexpression, +Tcl_RegExpIndices, Tcl_RegExpInfo diff --git a/doc/SaveInterpState.3 b/doc/SaveInterpState.3 index 804f9ec..96fecdb 100644 --- a/doc/SaveInterpState.3 +++ b/doc/SaveInterpState.3 @@ -6,12 +6,11 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" +.TH Tcl_SaveInterpState 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, -Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- Save and restore the +Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState \- Save and restore the state of an an interpreter. .SH SYNOPSIS .nf @@ -24,12 +23,7 @@ int \fBTcl_RestoreInterpState\fR(\fIinterp, state\fR) .sp \fBTcl_DiscardInterpState\fR(\fIstate\fR) -.sp -\fBTcl_SaveResult\fR(\fIinterp, savedPtr\fR) -.sp -\fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR) -.sp -\fBTcl_DiscardResult\fR(\fIsavedPtr\fR) +.fi .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in @@ -38,8 +32,6 @@ The interpreter for the operation. The return code for the state. .AP Tcl_InterpState state in A token for saved state. -.AP Tcl_SavedResult *savedPtr in -A pointer to storage for saved state. .BE .SH DESCRIPTION .PP @@ -59,27 +51,5 @@ returns the \fIstatus\fR originally passed in the corresponding call to If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called to release it. A token used to discard or restore state must not be used again. -.PP -\fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR are -deprecated. Instead use \fBTcl_SaveInterpState\fR, -\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR, which are more -capable. -.PP -\fBTcl_SaveResult\fR moves the result of \fIinterp\fR to the location -\fIstatePtr\fR points to and returns the interpreter result to its initial -state. It does not save options such as \fB\-errorcode\fR or -\fB\-errorinfo\fR. -.PP -\fBTcl_RestoreResult\fR clears any existing result or error in \fIinterp\fR and -moves the result from \fIstatePtr\fR back to \fIinterp\fR. \fIstatePtr\fR is -then in an undefined state and must not be used until passed again to -\fBTcl_SaveResult\fR. -.PP -\fBTcl_DiscardResult\fR releases the state stored at \fBstatePtr\fR, which is -then in an undefined state and must not be used until passed again to -\fBTcl_SaveResult\fR. -.PP -If a saved result is not restored, \fBTcl_DiscardResult\fR must be called to -release it. .SH KEYWORDS result, state, interp diff --git a/doc/SetChanErr.3 b/doc/SetChanErr.3 index 473b61c..e7593b7 100644 --- a/doc/SetChanErr.3 +++ b/doc/SetChanErr.3 @@ -14,18 +14,14 @@ Tcl_SetChannelError, Tcl_SetChannelErrorInterp, Tcl_GetChannelError, Tcl_GetChan .nf \fB#include <tcl.h>\fR .sp -void \fBTcl_SetChannelError\fR(\fIchan, msg\fR) .sp -void \fBTcl_SetChannelErrorInterp\fR(\fIinterp, msg\fR) .sp -void \fBTcl_GetChannelError\fR(\fIchan, msgPtr\fR) .sp -void \fBTcl_GetChannelErrorInterp\fR(\fIinterp, msgPtr\fR) -.sp +.fi .SH ARGUMENTS .AS Tcl_Channel chan .AP Tcl_Channel chan in @@ -87,14 +83,10 @@ the value. Which functions of a channel driver are allowed to use which bypass function is listed below, as is which functions of the public channel API may leave a messages in the bypass areas. -.IP \fBTcl_DriverCloseProc\fR -May use \fBTcl_SetChannelErrorInterp\fR, and only this function. .IP \fBTcl_DriverInputProc\fR May use \fBTcl_SetChannelError\fR, and only this function. .IP \fBTcl_DriverOutputProc\fR May use \fBTcl_SetChannelError\fR, and only this function. -.IP \fBTcl_DriverSeekProc\fR -May use \fBTcl_SetChannelError\fR, and only this function. .IP \fBTcl_DriverWideSeekProc\fR May use \fBTcl_SetChannelError\fR, and only this function. .IP \fBTcl_DriverSetOptionProc\fR diff --git a/doc/SetErrno.3 b/doc/SetErrno.3 index c202e2e..abed74e 100644 --- a/doc/SetErrno.3 +++ b/doc/SetErrno.3 @@ -13,7 +13,6 @@ Tcl_SetErrno, Tcl_GetErrno, Tcl_ErrnoId, Tcl_ErrnoMsg \- manipulate errno to sto .nf \fB#include <tcl.h>\fR .sp -void \fBTcl_SetErrno\fR(\fIerrorCode\fR) .sp int @@ -24,7 +23,7 @@ const char * .sp const char * \fBTcl_ErrnoMsg\fR(\fIerrorCode\fR) -.sp +.fi .SH ARGUMENTS .AS int errorCode .AP int errorCode in diff --git a/doc/SetRecLmt.3 b/doc/SetRecLmt.3 index ec55794..b2d1705 100644 --- a/doc/SetRecLmt.3 +++ b/doc/SetRecLmt.3 @@ -14,14 +14,15 @@ Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter .nf \fB#include <tcl.h>\fR .sp -int +Tcl_Size \fBTcl_SetRecursionLimit\fR(\fIinterp, depth\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Interpreter whose recursion limit is to be set. Must be greater than zero. -.AP int depth in +.AP Tcl_Size depth in New limit for nested calls to \fBTcl_Eval\fR for \fIinterp\fR. .BE @@ -29,7 +30,7 @@ New limit for nested calls to \fBTcl_Eval\fR for \fIinterp\fR. .PP At any given time Tcl enforces a limit on the number of recursive calls that may be active for \fBTcl_Eval\fR and related procedures -such as \fBTcl_GlobalEval\fR. +such as \fBTcl_EvalEx\fR. Any call to \fBTcl_Eval\fR that exceeds this depth is aborted with an error. By default the recursion limit is 1000. diff --git a/doc/SetResult.3 b/doc/SetResult.3 index c9ff84c..4d0c9df 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_TransferResult, Tcl_FreeResult \- manipulate Tcl result +Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult, Tcl_TransferResult \- manipulate Tcl result .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -24,248 +24,116 @@ Tcl_Obj * const char * \fBTcl_GetStringResult\fR(\fIinterp\fR) .sp -\fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *)NULL\fR) -.sp -\fBTcl_AppendResultVA\fR(\fIinterp, argList\fR) +\fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fBNULL\fR) .sp \fBTcl_ResetResult\fR(\fIinterp\fR) .sp \fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR) .sp \fBTcl_AppendElement\fR(\fIinterp, element\fR) -.sp -\fBTcl_FreeResult\fR(\fIinterp\fR) +.fi .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out -Interpreter whose result is to be modified or read. +The interpreter get or set the result for. .AP Tcl_Obj *objPtr in -Tcl value to become result for \fIinterp\fR. +A value to set the result to. .AP char *result in -String value to become result for \fIinterp\fR or to be -appended to the existing result. +The string value set the result to, or to append to the existing result. .AP "const char" *element in -String value to append as a list element +The string value to append as a list element to the existing result of \fIinterp\fR. .AP Tcl_FreeProc *freeProc in -Address of procedure to call to release storage at -\fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or -\fBTCL_VOLATILE\fR. -.AP va_list argList in -An argument list which must have been initialized using -\fBva_start\fR, and cleared using \fBva_end\fR. +Pointer to a procedure to call to release storage at +\fIresult\fR. .AP Tcl_Interp *sourceInterp in -Interpreter that the result and return options should be transferred from. +The interpreter to transfer the result and return options from. .AP Tcl_Interp *targetInterp in -Interpreter that the result and return options should be transferred to. +The interpreter to transfer the result and return options to. .AP int code in Return code value that controls transfer of return options. .BE .SH DESCRIPTION .PP -The procedures described here are utilities for manipulating the -result value in a Tcl interpreter. -The interpreter result may be either a Tcl value or a string. -For example, \fBTcl_SetObjResult\fR and \fBTcl_SetResult\fR -set the interpreter result to, respectively, a value and a string. -Similarly, \fBTcl_GetObjResult\fR and \fBTcl_GetStringResult\fR -return the interpreter result as a value and as a string. -The procedures always keep the string and value forms -of the interpreter result consistent. -For example, if \fBTcl_SetObjResult\fR is called to set -the result to a value, -then \fBTcl_GetStringResult\fR is called, -it will return the value's string representation. +These procedures manipulate the result of an interpreter. Some procedures +provide a Tcl_Obj interface while others provide a string interface. For +example, \fBTcl_SetObjResult\fR accepts a Tcl_Obj and \fBTcl_SetResult\fR +accepts a char *. Similarly, \fBTcl_GetObjResult\fR produces a Tcl_Obj * and +\fBTcl_GetStringResult\fR produces a char *. The procedures can be mixed and +matched. For example, if \fBTcl_SetObjResult\fR is called to set the result to +a Tcl_Obj value, and then \fBTcl_GetStringResult\fR is called, it returns a +char * (but see caveats below). .PP -\fBTcl_SetObjResult\fR -arranges for \fIobjPtr\fR to be the result for \fIinterp\fR, +\fBTcl_SetObjResult\fR sets \fIobjPtr\fR as the result for \fIinterp\fR, replacing any existing result. -The result is left pointing to the value -referenced by \fIobjPtr\fR. -\fIobjPtr\fR's reference count is incremented -since there is now a new reference to it from \fIinterp\fR. -The reference count for any old result value -is decremented and the old result value is freed if no -references to it remain. -.PP -\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as a value. -The value's reference count is not incremented; -if the caller needs to retain a long-term pointer to the value -they should use \fBTcl_IncrRefCount\fR to increment its reference count -in order to keep it from being freed too early or accidentally changed. -.PP -\fBTcl_SetResult\fR -arranges for \fIresult\fR to be the result for the current Tcl -command in \fIinterp\fR, replacing any existing result. -The \fIfreeProc\fR argument specifies how to manage the storage -for the \fIresult\fR argument; -it is discussed in the section -\fBTHE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below. -If \fIresult\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored -and \fBTcl_SetResult\fR -re-initializes \fIinterp\fR's result to point to an empty string. -.PP -\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string. -If the result was set to a value by a \fBTcl_SetObjResult\fR call, -the value form will be converted to a string and returned. -If the value's string representation contains null bytes, -this conversion will lose information. -For this reason, programmers are encouraged to -write their code to use the new value API procedures -and to call \fBTcl_GetObjResult\fR instead. .PP -\fBTcl_ResetResult\fR clears the result for \fIinterp\fR -and leaves the result in its normal empty initialized state. -If the result is a value, -its reference count is decremented and the result is left -pointing to an unshared value representing an empty string. -If the result is a dynamically allocated string, its memory is free*d -and the result is left as a empty string. -\fBTcl_ResetResult\fR also clears the error state managed by -\fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR, -and \fBTcl_SetErrorCode\fR. -.PP -\fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces. -It takes each of its \fIresult\fR arguments and appends them in order -to the current result associated with \fIinterp\fR. -If the result is in its initialized empty state (e.g. a command procedure -was just invoked or \fBTcl_ResetResult\fR was just called), -then \fBTcl_AppendResult\fR sets the result to the concatenation of -its \fIresult\fR arguments. -\fBTcl_AppendResult\fR may be called repeatedly as additional pieces -of the result are produced. -\fBTcl_AppendResult\fR takes care of all the -storage management issues associated with managing \fIinterp\fR's -result, such as allocating a larger result area if necessary. -It also manages conversion to and from the \fIresult\fR field of the -\fIinterp\fR so as to handle backward-compatibility with old-style -extensions. -Any number of \fIresult\fR arguments may be passed in a single -call; the last argument in the list must be a NULL pointer. -.PP -\fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that -instead of taking a variable number of arguments it takes an argument list. -Interfaces using argument lists have been found to be nonportable in practice. -This function is deprecated and will be removed in Tcl 9.0. -.PP -\fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR -to \fItargetInterp\fR. The two interpreters must have been created in the -same thread. If \fIsourceInterp\fR and \fItargetInterp\fR are the same, -nothing is done. Otherwise, \fBTcl_TransferResult\fR moves the result -from \fIsourceInterp\fR to \fItargetInterp\fR, and resets the result -in \fIsourceInterp\fR. It also moves the return options dictionary as -controlled by the return code value \fIcode\fR in the same manner +\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR, without +incrementing its reference count. +.PP +\fBTcl_SetResult\fR sets \fIresult\fR as the result for \fIinterp\fR, replacing +any existing result, and calls \fIfreeProc\fR to free \fIresult\fR. See \fBTHE +TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below. If \fIresult\fR is +\fBNULL\fR, ignores \fIfreeProc\fR and sets the result for \fIinterp\fR to +point to the empty string. +.PP +\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string, i.e. +the bytes of the Tcl_Obj for the result, which can be decoded using +\fBTcl_UtfToExternal\fR. This value is freed when its corresponding Tcl_Obj is +freed.Programmers are encouraged to use the newer Tcl_Obj API procedures, e.g. +to call \fBTcl_GetObjResult\fR instead. +.PP +\fBTcl_ResetResult\fR sets the empty string as the result for \fIinterp\fR and +clears the error state managed by \fBTcl_AddErrorInfo\fR, +\fBTcl_AddObjErrorInfo\fR, and \fBTcl_SetErrorCode\fR. +.PP +\fBTcl_AppendResult\fR builds up a result from smaller pieces, appending each +\fIresult\fR in order to the current result for \fIinterp\fR. It may be called +repeatedly as additional pieces of the result are produced, and manages the +storage for the \fIinterp\fR's result, allocating a larger result area if +necessary. It also manages conversion to and from the \fIresult\fR field of +the \fIinterp\fR to handle backward-compatibility with old-style extensions. +Any number of \fIresult\fR arguments may be passed in a single call; the last +argument in the list must be a NULL pointer. +.PP +\fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR to +\fItargetInterp\fR, both of which must have been created in the same thread, +resets the result in \fIsourceInterp\fR, and moves the return options +dictionary as controlled by the return code value \fIcode\fR in the same manner as \fBTcl_GetReturnOptions\fR. +.PP +If \fIsourceInterp\fR and \fItargetInterp\fR are the same, nothing is done. .SH "DEPRECATED INTERFACES" .SS "OLD STRING PROCEDURES" .PP -Use of the following procedures is deprecated -since they manipulate the Tcl result as a string. -Procedures such as \fBTcl_SetObjResult\fR -that manipulate the result as a value -can be significantly more efficient. -.PP -\fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in -that it allows results to be built up in pieces. -However, \fBTcl_AppendElement\fR takes only a single \fIelement\fR -argument and it appends that argument to the current result -as a proper Tcl list element. -\fBTcl_AppendElement\fR adds backslashes or braces if necessary -to ensure that \fIinterp\fR's result can be parsed as a list and that -\fIelement\fR will be extracted as a single element. -Under normal conditions, \fBTcl_AppendElement\fR will add a space -character to \fIinterp\fR's result just before adding the new -list element, so that the list elements in the result are properly -separated. -However if the new list element is the first in a list or sub-list -(i.e. \fIinterp\fR's current result is empty, or consists of the -single character +The following procedures are deprecated since they manipulate the Tcl result as +a string. Procedures such as \fBTcl_SetObjResult\fR can be significantly more +efficient. +.PP +\fBTcl_AppendElement\fR is like \fBTcl_AppendResult\fR, but it appends only one +piece, and also appends that piece as a list item. +\fBTcl_AppendElement\fR adds backslashes or braces as necessary to ensure that +\fIelement\fR is properly formatted as a list item. Under normal conditions, +\fBTcl_AppendElement\fR adds a space character to \fIinterp\fR's result just +before adding the new list element, so that the list elements in the result are +properly separated. However if the new list element is the first item in the +list or sublist (i.e. \fIinterp\fR's current result is empty, or consists of +the single character .QW { , or ends in the characters .QW " {" ) then no space is added. -.PP -\fBTcl_FreeResult\fR performs part of the work -of \fBTcl_ResetResult\fR. -It frees up the memory associated with \fIinterp\fR's result. -It also sets \fIinterp->freeProc\fR to zero, but does not -change \fIinterp->result\fR or clear error state. -\fBTcl_FreeResult\fR is most commonly used when a procedure -is about to replace one result value with another. -.SS "DIRECT ACCESS TO INTERP->RESULT" -.PP -It used to be legal for programs to -directly read and write \fIinterp->result\fR -to manipulate the interpreter result. The Tcl headers no longer -permit this access. C code still doing this must -be updated to use supported routines \fBTcl_GetObjResult\fR, -\fBTcl_GetStringResult\fR, \fBTcl_SetObjResult\fR, and \fBTcl_SetResult\fR. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP -\fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how -the Tcl system is to manage the storage for the \fIresult\fR argument. -If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called -at a time when \fIinterp\fR holds a string result, -they do whatever is necessary to dispose of the old string result -(see the \fBTcl_Interp\fR manual entry for details on this). -.PP -If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIresult\fR -refers to an area of static storage that is guaranteed not to be -modified until at least the next call to \fBTcl_Eval\fR. -If \fIfreeProc\fR -is \fBTCL_DYNAMIC\fR it means that \fIresult\fR was allocated with a call -to \fBTcl_Alloc\fR and is now the property of the Tcl system. -\fBTcl_SetResult\fR will arrange for the string's storage to be -released by calling \fBTcl_Free\fR when it is no longer needed. -If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIresult\fR -points to an area of memory that is likely to be overwritten when -\fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame). -In this case \fBTcl_SetResult\fR will make a copy of the string in -dynamically allocated storage and arrange for the copy to be the -result for the current Tcl command. -.PP -If \fIfreeProc\fR is not one of the values \fBTCL_STATIC\fR, -\fBTCL_DYNAMIC\fR, and \fBTCL_VOLATILE\fR, then it is the address -of a procedure that Tcl should call to free the string. -This allows applications to use non-standard storage allocators. -When Tcl no longer needs the storage for the string, it will -call \fIfreeProc\fR. \fIFreeProc\fR should have arguments and -result that match the type \fBTcl_FreeProc\fR: +\fIFreeProc\fR has the following type: .PP .CS typedef void \fBTcl_FreeProc\fR( char *\fIblockPtr\fR); .CE .PP -When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to -the value of \fIresult\fR passed to \fBTcl_SetResult\fR. +When \fIfreeProc\fR is called, \fIblockPtr\fR is the \fIresult\fR value passed +to \fBTcl_SetResult\fR. -.SH "REFERENCE COUNT MANAGEMENT" -.PP -The interpreter result is one of the main places that owns references to -values, along with the bytecode execution stack, argument lists, variables, -and the list and dictionary collection values. -.PP -\fBTcl_SetObjResult\fR takes a value with an arbitrary reference count -\fI(specifically including zero)\fR and guarantees to increment the reference -count. If code wishes to continue using the value after setting it as the -result, it should add its own reference to it with \fBTcl_IncrRefCount\fR. -.PP -\fBTcl_GetObjResult\fR returns the current interpreter result value. This will -have a reference count of at least 1. If the caller wishes to keep the -interpreter result value, it should increment its reference count. -.PP -\fBTcl_GetStringResult\fR does not manipulate reference counts, but the string -it returns is owned by (and has a lifetime controlled by) the current -interpreter result value; it should be copied instead of being relied upon to -persist after the next Tcl API call, as most Tcl operations can modify the -interpreter result. -.PP -\fBTcl_SetResult\fR, \fBTcl_AppendResult\fR, \fBTcl_AppendResultVA\fR, -\fBTcl_AppendElement\fR, and \fBTcl_ResetResult\fR all modify the interpreter -result. They may cause the old interpreter result to have its reference count -decremented and a new interpreter result to be allocated. After they have been -called, the reference count of the interpreter result is guaranteed to be 1. .SH "SEE ALSO" Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp, Tcl_GetReturnOptions diff --git a/doc/SetVar.3 b/doc/SetVar.3 index 9d8e0b7..c34e55f 100644 --- a/doc/SetVar.3 +++ b/doc/SetVar.3 @@ -43,6 +43,7 @@ int .sp int \fBTcl_UnsetVar2\fR(\fIinterp, name1, name2, flags\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *newValuePtr .AP Tcl_Interp *interp in @@ -168,6 +169,7 @@ options to the procedures. It consists of an OR-ed combination of the following bits. .TP \fBTCL_GLOBAL_ONLY\fR +. Under normal circumstances the procedures look up variables as follows. If a procedure call is active in \fIinterp\fR, the variable is looked up at the current level of procedure call. @@ -180,12 +182,14 @@ If both \fBTCL_GLOBAL_ONLY\fR and \fBTCL_NAMESPACE_ONLY\fR are given, \fBTCL_GLOBAL_ONLY\fR is ignored. .TP \fBTCL_NAMESPACE_ONLY\fR +. If this bit is set in \fIflags\fR then the variable is looked up only in the current namespace; if a procedure is active its variables are ignored, and the global namespace is also ignored unless it is the current namespace. .TP \fBTCL_LEAVE_ERR_MSG\fR +. If an error is returned and this bit is set in \fIflags\fR, then an error message will be left in the interpreter's result, where it can be retrieved with \fBTcl_GetObjResult\fR @@ -194,12 +198,14 @@ If this flag bit is not set then no error message is left and the interpreter's result will not be modified. .TP \fBTCL_APPEND_VALUE\fR +. If this bit is set then \fInewValuePtr\fR or \fInewValue\fR is appended to the current value instead of replacing it. If the variable is currently undefined, then the bit is ignored. This bit is only used by the \fBTcl_Set*\fR procedures. .TP \fBTCL_LIST_ELEMENT\fR +. If this bit is set, then \fInewValue\fR is converted to a valid Tcl list element before setting (or appending to) the variable. A separator space is appended before the new list element unless diff --git a/doc/Signal.3 b/doc/Signal.3 index 0a280f9..a0d7417 100644 --- a/doc/Signal.3 +++ b/doc/Signal.3 @@ -18,7 +18,7 @@ const char * .sp const char * \fBTcl_SignalMsg\fR(\fIsig\fR) -.sp +.fi .SH ARGUMENTS .AS int sig .AP int sig in diff --git a/doc/Sleep.3 b/doc/Sleep.3 index 656d72a..082adb2 100644 --- a/doc/Sleep.3 +++ b/doc/Sleep.3 @@ -15,6 +15,7 @@ Tcl_Sleep \- delay execution for a given number of milliseconds \fB#include <tcl.h>\fR .sp \fBTcl_Sleep\fR(\fIms\fR) +.fi .SH ARGUMENTS .AS int ms .AP int ms in diff --git a/doc/SourceRCFile.3 b/doc/SourceRCFile.3 index bf8c527..3175cd1 100644 --- a/doc/SourceRCFile.3 +++ b/doc/SourceRCFile.3 @@ -11,8 +11,8 @@ Tcl_SourceRCFile \- source the Tcl rc file .nf \fB#include <tcl.h>\fR .sp -void \fBTcl_SourceRCFile\fR(\fIinterp\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in diff --git a/doc/SplitList.3 b/doc/SplitList.3 index 863e322..d036ace 100644 --- a/doc/SplitList.3 +++ b/doc/SplitList.3 @@ -20,17 +20,18 @@ int char * \fBTcl_Merge\fR(\fIargc, argv\fR) .sp -int +Tcl_Size \fBTcl_ScanElement\fR(\fIsrc, flagsPtr\fR) .sp -int +Tcl_Size \fBTcl_ScanCountedElement\fR(\fIsrc, length, flagsPtr\fR) .sp -int +Tcl_Size \fBTcl_ConvertElement\fR(\fIsrc, dst, flags\fR) .sp -int +Tcl_Size \fBTcl_ConvertCountedElement\fR(\fIsrc, length, dst, flags\fR) +.fi .SH ARGUMENTS .AS "const char *const" ***argvPtr out .AP Tcl_Interp *interp out @@ -38,14 +39,19 @@ Interpreter to use for error reporting. If NULL, then no error message is left. .AP "const char" *list in Pointer to a string with proper list structure. -.AP int *argcPtr out +.AP "Tcl_Size \&| int" *argcPtr out Filled in with number of elements in \fIlist\fR. +May be (Tcl_Size *)NULL when not used. If it points to a variable which +type is not \fBTcl_Size\fR, a compiler warning will be generated. +If your extensions is compiled with -DTCL_8_API, this function will return +TCL_ERROR for lists with more than INT_MAX elements (which should +trigger proper error-handling), otherwise expect it to crash. .AP "const char" ***argvPtr out \fI*argvPtr\fR will be filled in with the address of an array of pointers to the strings that are the extracted elements of \fIlist\fR. There will be \fI*argcPtr\fR valid entries in the array, followed by a NULL entry. -.AP int argc in +.AP Tcl_Size argc in Number of elements in \fIargv\fR. .AP "const char *const" *argv in Array of strings to merge together into a single list. @@ -55,7 +61,7 @@ String that is to become an element of a list. .AP int *flagsPtr in Pointer to word to fill in with information about \fIsrc\fR. The value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR. -.AP int length in +.AP Tcl_Size length in Number of bytes in string \fIsrc\fR. .AP char *dst in Place to copy converted list element. Must contain enough characters @@ -81,7 +87,8 @@ For example, suppose that you have called \fBTcl_SplitList\fR with the following code: .PP .CS -int argc, code; +Tcl_Size argc; +int code; char *string; char **argv; \&... @@ -92,12 +99,13 @@ Then you should eventually free the storage with a call like the following: .PP .CS -Tcl_Free((char *) argv); +Tcl_Free(argv); .CE .PP \fBTcl_SplitList\fR normally returns \fBTCL_OK\fR, which means the list was -successfully parsed. -If there was a syntax error in \fIlist\fR, then \fBTCL_ERROR\fR is returned +successfully parsed. If \fIsizePtr\fR points to a variable of type +\fBint\fR and the list contains more than 2**31 key/value pairs, or there was +a syntax error in \fIlist\fR, then \fBTCL_ERROR\fR is returned and the interpreter's result will point to an error message describing the problem (if \fIinterp\fR was not NULL). If \fBTCL_ERROR\fR is returned then no memory is allocated and \fI*argvPtr\fR diff --git a/doc/SplitPath.3 b/doc/SplitPath.3 index c011194..452baff 100644 --- a/doc/SplitPath.3 +++ b/doc/SplitPath.3 @@ -20,19 +20,25 @@ char * .sp Tcl_PathType \fBTcl_GetPathType\fR(\fIpath\fR) +.fi .SH ARGUMENTS .AS "const char *const" ***argvPtr in/out .AP "const char" *path in File path in a form appropriate for the current platform (see the \fBfilename\fR manual entry for acceptable forms for path names). -.AP int *argcPtr out +.AP "Tcl_Size \&| int" *argcPtr out Filled in with number of path elements in \fIpath\fR. +May be (Tcl_Size *)NULL when not used. If it points to a variable which +type is not \fBTcl_Size\fR, a compiler warning will be generated. +If your extensions is compiled with -DTCL_8_API, argcPtr will be filled +with -1 for paths with more than INT_MAX elements (which should +trigger proper error-handling), otherwise expect it to crash. .AP "const char" ***argvPtr out \fI*argvPtr\fR will be filled in with the address of an array of pointers to the strings that are the extracted elements of \fIpath\fR. There will be \fI*argcPtr\fR valid entries in the array, followed by a NULL entry. -.AP int argc in +.AP Tcl_Size argc in Number of elements in \fIargv\fR. .AP "const char *const" *argv in Array of path elements to merge together into a single path. @@ -61,7 +67,7 @@ For example, suppose that you have called \fBTcl_SplitPath\fR with the following code: .PP .CS -int argc; +Tcl_Size argc; char *path; char **argv; \&... @@ -72,7 +78,7 @@ Then you should eventually free the storage with a call like the following: .PP .CS -Tcl_Free((char *) argv); +Tcl_Free(argv); .CE .PP \fBTcl_JoinPath\fR is the inverse of \fBTcl_SplitPath\fR: it takes a diff --git a/doc/StaticLibrary.3 b/doc/StaticLibrary.3 index 9a77ab7..9cad43d 100644 --- a/doc/StaticLibrary.3 +++ b/doc/StaticLibrary.3 @@ -16,6 +16,7 @@ Tcl_StaticLibrary, Tcl_StaticPackage \- make a statically linked library availab \fBTcl_StaticLibrary\fR(\fIinterp, prefix, initProc, safeInitProc\fR) .sp \fBTcl_StaticPackage\fR(\fIinterp, prefix, initProc, safeInitProc\fR) +.fi .SH ARGUMENTS .AS Tcl_LibraryInitProc *safeInitProc .AP Tcl_Interp *interp in @@ -24,8 +25,8 @@ already been incorporated (i.e., the caller has already invoked the appropriate initialization procedure). NULL means the library has not yet been incorporated into any interpreter. .AP "const char" *prefix in -Prefix for library initialization function; should be properly -capitalized (first letter upper-case, all others lower-case). +Prefix for library initialization function. Normally in titlecase (first +letter upper-case, all others lower-case), but this is no longer required. .AP Tcl_LibraryInitProc *initProc in Procedure to invoke to incorporate this library into a trusted interpreter. @@ -70,8 +71,7 @@ initialization procedure to be invoked. \fBTcl_StaticLibrary\fR was named \fBTcl_StaticPackage\fR in Tcl 8.6 and earlier, but the old name is deprecated now. .PP -\fBTcl_StaticLibrary\fR can not be used in stub-enabled extensions. Its symbol -entry in the stub table is deprecated and it will be removed in Tcl 9.0. +\fBTcl_StaticLibrary\fR can not be used in stub-enabled extensions. .SH KEYWORDS initialization procedure, package, static linking .SH "SEE ALSO" diff --git a/doc/StdChannels.3 b/doc/StdChannels.3 index d3ecff2..e22e326 100644 --- a/doc/StdChannels.3 +++ b/doc/StdChannels.3 @@ -45,8 +45,7 @@ standard channels. (A channel is not if it could not be successfully opened; for example, in a Tcl application run as a Windows NT service.) -.TP -1) +.IP 1) A single standard channel is initialized when it is explicitly specified in a call to \fBTcl_SetStdChannel\fR. The states of the other standard channels are unaffected. @@ -55,17 +54,14 @@ other standard channels are unaffected. Missing platform-specific standard channels do not matter here. This approach is not available at the script level. .RE -.TP -2) +.IP 2) All uninitialized standard channels are initialized to platform-specific default values: .RS -.TP -(a) +.IP (a) when open channels are listed with \fBTcl_GetChannelNames\fR (or the \fBfile channels\fR script command), or -.TP -(b) +.IP (b) when information about any standard channel is requested with a call to \fBTcl_GetStdChannel\fR, or with a call to \fBTcl_GetChannel\fR which specifies one of the standard names (\fBstdin\fR, \fBstdout\fR @@ -76,8 +72,7 @@ standard channels are considered as initialized and then immediately closed. This means that the first three Tcl channels then opened by the application are designated as the Tcl standard channels. .RE -.TP -3) +.IP 3) All uninitialized standard channels are initialized to platform-specific default values when a user-requested channel is registered with \fBTcl_RegisterChannel\fR. diff --git a/doc/StrMatch.3 b/doc/StrMatch.3 index d664067..89b4ae0 100644 --- a/doc/StrMatch.3 +++ b/doc/StrMatch.3 @@ -19,6 +19,7 @@ int .sp int \fBTcl_StringCaseMatch\fR(\fIstr\fR, \fIpattern\fR, \fIflags\fR) +.fi .SH ARGUMENTS .AS "const char" *pattern .AP "const char" *str in diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 6f2abff..817ed34 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl values as strings +Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl values as strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -19,10 +19,8 @@ Tcl_Obj * Tcl_Obj * \fBTcl_NewUnicodeObj\fR(\fIunicode, numChars\fR) .sp -void \fBTcl_SetStringObj\fR(\fIobjPtr, bytes, length\fR) .sp -void \fBTcl_SetUnicodeObj\fR(\fIobjPtr, unicode, numChars\fR) .sp char * @@ -40,28 +38,20 @@ Tcl_UniChar * int \fBTcl_GetUniChar\fR(\fIobjPtr, index\fR) .sp -int +Tcl_Size \fBTcl_GetCharLength\fR(\fIobjPtr\fR) .sp Tcl_Obj * \fBTcl_GetRange\fR(\fIobjPtr, first, last\fR) .sp -void \fBTcl_AppendToObj\fR(\fIobjPtr, bytes, length\fR) .sp -void \fBTcl_AppendUnicodeToObj\fR(\fIobjPtr, unicode, numChars\fR) .sp -void \fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) .sp -void -\fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *)NULL\fR) -.sp -void -\fBTcl_AppendStringsToObjVA\fR(\fIobjPtr, argList\fR) +\fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fBNULL\fR) .sp -void \fBTcl_AppendLimitedToObj\fR(\fIobjPtr, bytes, length, limit, ellipsis\fR) .sp Tcl_Obj * @@ -73,10 +63,8 @@ int Tcl_Obj * \fBTcl_ObjPrintf\fR(\fIformat, ...\fR) .sp -void \fBTcl_AppendPrintfToObj\fR(\fIobjPtr, format, ...\fR) .sp -void \fBTcl_SetObjLength\fR(\fIobjPtr, newLength\fR) .sp int @@ -84,6 +72,7 @@ int .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) +.fi .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in @@ -94,7 +83,7 @@ unless \fInumChars\fR is negative. (Applications needing null bytes should represent them as the two-byte sequence \fI\e300\e200\fR, use \fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if the string is a collection of uninterpreted bytes.) -.AP int length in +.AP Tcl_Size length in The number of bytes to copy from \fIbytes\fR when initializing, setting, or appending to a string value. If negative, all bytes up to the first null are used. @@ -103,33 +92,35 @@ Points to the first byte of an array of Unicode characters used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is negative. -.AP int numChars in +.AP Tcl_Size numChars in The number of Unicode characters to copy from \fIunicode\fR when initializing, setting, or appending to a string value. If negative, all characters up to the first null character are used. -.AP int index in +.AP Tcl_Size index in The index of the Unicode character to return. -.AP int first in +.AP Tcl_Size first in The index of the first Unicode character in the Unicode range to be returned as a new value. If negative, behave the same as if the value was 0. -.AP int last in +.AP Tcl_Size last in The index of the last Unicode character in the Unicode range to be returned as a new value. If negative, take all characters up to the last one available. .AP Tcl_Obj *objPtr in/out -Points to a value to manipulate. +A pointer to a value to read, or to an unshared value to modify. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. -.AP int *lengthPtr out +.AP "Tcl_Size \&| int" *lengthPtr out The location where \fBTcl_GetStringFromObj\fR will store the length -of a value's string representation. May be (int *)NULL when not used. +of a value's string representation. +May be (Tcl_Size *)NULL when not used. If it points to a variable which +type is not \fBTcl_Size\fR, a compiler warning will be generated. +If your extensions is compiled with -DTCL_8_API, this function will +panic for strings with more than INT_MAX bytes/characters, otherwise +expect it to crash. .AP "const char" *string in Null-terminated string value to append to \fIobjPtr\fR. -.AP va_list argList in -An argument list which must have been initialized using -\fBva_start\fR, and cleared using \fBva_end\fR. -.AP int limit in +.AP Tcl_Size limit in Maximum number of bytes to be appended. .AP "const char" *ellipsis in Suffix to append when the limit leads to string truncation. @@ -138,11 +129,11 @@ If NULL is passed then the suffix is used. .AP "const char" *format in Format control string including % conversion specifiers. -.AP int objc in +.AP Tcl_Size objc in The number of elements to format or concatenate. .AP Tcl_Obj *objv[] in The array of values to format or concatenate. -.AP int newLength in +.AP Tcl_Size newLength in New length for the string value of \fIobjPtr\fR, not including the final null character. .BE @@ -206,15 +197,15 @@ where the caller does not need the length of the unicode string representation. .PP \fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the -value's Unicode representation. If the index is out of range or -it references a low surrogate preceded by a high surrogate, it returns -1; +value's Unicode representation. If the index is out of range +it returns -1; .PP \fBTcl_GetRange\fR returns a newly created value comprised of the -characters between \fIfirst\fR and \fIlast\fR (inclusive) in the -value's Unicode representation. If the value's Unicode -representation is invalid, the Unicode representation is regenerated -from the value's string representation. If \fIfirst\fR < 0, then -the returned string starts at the beginning of the value. If \fIlast\fR < 0, +characters between \fIfirst\fR and \fIlast\fR (inclusive) in the value's +Unicode representation. If the value's Unicode representation +is invalid, the Unicode representation is regenerated from the value's +string representation. If \fIfirst\fR is negative, then the returned +string starts at the beginning of the value. If \fIlast\fR negative, then the returned string ends at the end of the value. .PP \fBTcl_GetCharLength\fR returns the number of characters (as opposed @@ -253,12 +244,6 @@ values may contain internal null characters). Any number of \fIstring\fR arguments may be provided, but the last argument must be a NULL pointer to indicate the end of the list. .PP -\fBTcl_AppendStringsToObjVA\fR is the same as \fBTcl_AppendStringsToObj\fR -except that instead of taking a variable number of arguments it takes an -argument list. Interfaces using argument lists have been found to be -nonportable in practice. This function is deprecated and will be removed -in Tcl 9.0. -.PP \fBTcl_AppendLimitedToObj\fR is similar to \fBTcl_AppendToObj\fR except that it imposes a limit on how many bytes are appended. This can be handy when the string to be appended might be @@ -271,7 +256,7 @@ all \fIlength\fR bytes that are available from being appended, then the appending is done so that the last bytes appended are from the string \fIellipsis\fR. This allows for an indication of the truncation to be left in the string. -When \fIlength\fR is \fB-1\fR, all bytes up to the first zero byte are appended, +When \fIlength\fR is negative, all bytes up to the first zero byte are appended, subject to the limit. When \fIellipsis\fR is NULL, the default string \fB...\fR is used. When \fIellipsis\fR is non-NULL, it must point to a zero-byte-terminated string in Tcl's internal UTF encoding. diff --git a/doc/SubstObj.3 b/doc/SubstObj.3 index f10e01d..2867df8 100644 --- a/doc/SubstObj.3 +++ b/doc/SubstObj.3 @@ -15,6 +15,7 @@ Tcl_SubstObj \- perform substitutions on Tcl values .sp Tcl_Obj * \fBTcl_SubstObj\fR(\fIinterp, objPtr, flags\fR) +.fi .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in diff --git a/doc/TCL_MEM_DEBUG.3 b/doc/TCL_MEM_DEBUG.3 index 59af6ba..6bd03c9 100644 --- a/doc/TCL_MEM_DEBUG.3 +++ b/doc/TCL_MEM_DEBUG.3 @@ -34,7 +34,7 @@ and the Tcl \fBmemory\fR command can be used to validate and examine memory usage. .SH "GUARD ZONES" .PP -When memory debugging is enabled, whenever a call to \fBckalloc\fR is +When memory debugging is enabled, whenever a call to \fBTcl_Alloc\fR is made, slightly more memory than requested is allocated so the memory debugging code can keep track of the allocated memory, and eight-byte .QW "guard zones" @@ -44,7 +44,7 @@ C #define \fBLOW_GUARD_SIZE\fR and #define \fBHIGH_GUARD_SIZE\fR in the file \fIgeneric/tclCkalloc.c\fR \(em it can be extended if you suspect large overwrite problems, at some cost in performance.) A known pattern is written into the guard zones and, on -a call to \fBckfree\fR, the guard zones of the space being freed are +a call to \fBTcl_Free\fR, the guard zones of the space being freed are checked to see if either zone has been modified in any way. If one has been, the guard bytes and their new contents are identified, and a .QW "low guard failed" @@ -53,7 +53,7 @@ or message is issued. The .QW "guard failed" message includes the address of the memory packet and -the file name and line number of the code that called \fBckfree\fR. +the file name and line number of the code that called \fBTcl_Free\fR. This allows you to detect the common sorts of one-off problems, where not enough space was allocated to contain the data written, for example. @@ -66,15 +66,15 @@ suspect (or know) that corruption is occurring before the Tcl interpreter comes up far enough for you to issue commands, you can set \fBMEM_VALIDATE\fR define, recompile tclCkalloc.c and rebuild Tcl. This will enable memory validation from the first call to -\fBckalloc\fR, again, at a large performance impact. +\fBTcl_Alloc\fR, again, at a large performance impact. .PP If you are desperate and validating memory on every call to -\fBckalloc\fR and \fBckfree\fR is not enough, you can explicitly call +\fBTcl_Alloc\fR and \fBTcl_Free\fR is not enough, you can explicitly call \fBTcl_ValidateAllMemory\fR directly at any point. It takes a \fIchar *\fR and an \fIint\fR which are normally the filename and line number of the caller, but they can actually be anything you want. Remember to remove the calls after you find the problem. .SH "SEE ALSO" -ckalloc, memory, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory +Tcl_Alloc, memory, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory .SH KEYWORDS memory, debug @@ -108,13 +108,13 @@ variable within an array variable, and may be empty. \fB$\fIname\fR . \fIname\fR may not be empty. - .TP 15 \fB$\fIname\fB(\fIindex\fB)\fR . \fIname\fR may be empty. Substitutions are performed on \fIindex\fR. .TP 15 \fB${\fIname\fB}\fR +. \fIname\fR may be empty. .TP 15 \fB${\fIname(index)\fB}\fR @@ -136,24 +136,31 @@ are replaced as described: .RS .TP 7 \e\fBa\fR +. Audible alert (bell) (U+7). .TP 7 \e\fBb\fR +. Backspace (U+8). .TP 7 \e\fBf\fR +. Form feed (U+C). .TP 7 \e\fBn\fR +. Newline (U+A). .TP 7 \e\fBr\fR +. Carriage-return (U+D). .TP 7 \e\fBt\fR +. Tab (U+9). .TP 7 \e\fBv\fR +. Vertical tab (U+B). .TP 7 \e\fB<newline>\fIwhiteSpace\fR @@ -165,6 +172,7 @@ within braced words, and if the resulting space may subsequently be treated as a word delimiter. .TP 7 \e\e +. Backslash .PQ \e "" . .TP 7 diff --git a/doc/TclZlib.3 b/doc/TclZlib.3 index c2d7f6d..d14ba48 100644 --- a/doc/TclZlib.3 +++ b/doc/TclZlib.3 @@ -88,7 +88,7 @@ The initial value for the checksum algorithm. .AP "unsigned char" *bytes in An array of bytes to run the checksum algorithm over, or NULL to get the recommended initial value for the checksum algorithm. -.AP int length in +.AP Tcl_Size length in The number of bytes in the array. .AP int mode in What mode to operate the stream in. Should be either @@ -107,9 +107,9 @@ if the currently compressed data must be made available for access using into a state where the decompressor can recover from on corruption, or \fBTCL_ZLIB_FINALIZE\fR to ensure that the stream is finished and that any trailer demanded by the format is written. -.AP int count in -The maximum number of bytes to get from the stream, or -1 to get all remaining -bytes from the stream's buffers. +.AP Tcl_Size count in +The maximum number of bytes to get from the stream, or -1 to get +all remaining bytes from the stream's buffers. .AP Tcl_Obj *compDict in A byte array value that is the compression dictionary to use with the stream. Note that this is \fInot a Tcl dictionary\fR, and it is recommended that this @@ -219,47 +219,33 @@ an unshared dictionary value). .PP The following fields in the dictionary value are understood. All other fields are ignored. No field is required when creating a gzip-format stream. -.TP -\fBcomment\fR -. +.IP \fBcomment\fR This holds the comment field of the header, if present. If absent, no comment was supplied (on decompression) or will be created (on compression). -.TP -\fBcrc\fR -. +.IP \fBcrc\fR A boolean value describing whether a CRC of the header is computed. Note that the \fBgzip\fR program does \fInot\fR use or allow a CRC on the header. -.TP -\fBfilename\fR -. +.IP \fBfilename\fR The name of the file that held the uncompressed data. This should not contain any directory separators, and should be sanitized before use on decompression with \fBfile tail\fR. -.TP -\fBos\fR -. +.IP \fBos\fR The operating system type code field from the header (if not the .QW unknown value). See RFC 1952 for the meaning of these codes. On compression, if this is absent then the field will be set to the .QW unknown value. -.TP -\fBsize\fR -. +.IP \fBsize\fR The size of the uncompressed data. This is ignored on compression; the size of the data compressed depends on how much data is supplied to the compression engine. -.TP -\fBtime\fR -. +.IP \fBtime\fR The time field from the header if non-zero, expected to be the time that the file named by the \fBfilename\fR field was modified. Suitable for use with \fBclock format\fR. On creation, the right value to use is that from \fBclock seconds\fR or \fBfile mtime\fR. -.TP -\fBtype\fR -. +.IP \fBtype\fR The type of the uncompressed data (either \fBbinary\fR or \fBtext\fR) if known. .SH "REFERENCE COUNT MANAGEMENT" diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index 6a37cda..6410450 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -6,7 +6,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures" +.TH Tcl_Main 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME @@ -27,9 +27,10 @@ Tcl_Obj * \fBTcl_GetStartupScript\fR(\fIencodingPtr\fR) .sp \fBTcl_SetMainLoop\fR(\fImainLoopProc\fR) +.fi .SH ARGUMENTS .AS Tcl_MainLoopProc *mainLoopProc -.AP int argc in +.AP Tcl_Size argc in Number of elements in \fIargv\fR. .AP char *argv[] in Array of strings containing command-line arguments. On Windows, when @@ -203,6 +204,11 @@ procedure (if any) returns, \fBTcl_Main\fR will also evaluate the \fBexit\fR command. .PP \fBTcl_Main\fR can not be used in stub-enabled extensions. +.PP +The difference between Tcl_MainEx and Tcl_MainExW is that the arguments +are passed as characters or wide characters. When used in stub-enabled +embedders, the stubs table must be first initialized using one of +\fBTcl_InitSubsystems\fR, \fBTcl_SetPanicProc\fR, \fBTcl_FindExecutable\fR or \fBTclZipfs_AppHook\fR. .SH "REFERENCE COUNT MANAGEMENT" .PP \fBTcl_SetStartupScript\fR takes a value (or NULL) for its \fIpath\fR diff --git a/doc/Thread.3 b/doc/Thread.3 index ac60230..cb63570 100644 --- a/doc/Thread.3 +++ b/doc/Thread.3 @@ -14,25 +14,19 @@ Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData .nf \fB#include <tcl.h>\fR .sp -void \fBTcl_ConditionNotify\fR(\fIcondPtr\fR) .sp -void \fBTcl_ConditionWait\fR(\fIcondPtr, mutexPtr, timePtr\fR) .sp -void \fBTcl_ConditionFinalize\fR(\fIcondPtr\fR) .sp -Void * +void * \fBTcl_GetThreadData\fR(\fIkeyPtr, size\fR) .sp -void \fBTcl_MutexLock\fR(\fImutexPtr\fR) .sp -void \fBTcl_MutexUnlock\fR(\fImutexPtr\fR) .sp -void \fBTcl_MutexFinalize\fR(\fImutexPtr\fR) .sp int @@ -40,6 +34,7 @@ int .sp int \fBTcl_JoinThread\fR(\fIid, result\fR) +.fi .SH ARGUMENTS .AS Tcl_CreateThreadProc proc out .AP Tcl_Condition *condPtr in @@ -67,9 +62,9 @@ Id of the thread waited upon. .AP Tcl_ThreadCreateProc *proc in This procedure will act as the \fBmain()\fR of the newly created thread. The specified \fIclientData\fR will be its sole argument. -.AP ClientData clientData in +.AP void *clientData in Arbitrary information. Passed as sole argument to the \fIproc\fR. -.AP unsigned stackSize in +.AP size_t stackSize in The size of the stack given to the new thread. .AP int flags in Bitmask containing flags allowing the caller to modify behavior of @@ -208,7 +203,7 @@ value and then finishes. .CS static \fBTcl_ThreadCreateType\fR MyThreadImplFunc( - ClientData clientData) + void *clientData) { int i, limit = (int) clientData; for (i=0 ; i<limit ; i++) { @@ -223,7 +218,7 @@ would do this: .PP .CS int limit = 1000000000; -ClientData limitData = (void*)((intptr_t) limit); +void *limitData = (void*)((intptr_t) limit); Tcl_ThreadId id; \fI/* holds identity of thread created */\fR int result; diff --git a/doc/ToUpper.3 b/doc/ToUpper.3 index 37ebd2b..580a5b3 100644 --- a/doc/ToUpper.3 +++ b/doc/ToUpper.3 @@ -22,14 +22,15 @@ int int \fBTcl_UniCharToTitle\fR(\fIch\fR) .sp -int +Tcl_Size \fBTcl_UtfToUpper\fR(\fIstr\fR) .sp -int +Tcl_Size \fBTcl_UtfToLower\fR(\fIstr\fR) .sp -int +Tcl_Size \fBTcl_UtfToTitle\fR(\fIstr\fR) +.fi .SH ARGUMENTS .AS char *str in/out .AP int ch in diff --git a/doc/TraceCmd.3 b/doc/TraceCmd.3 index 99914a6..c1f2cbb 100644 --- a/doc/TraceCmd.3 +++ b/doc/TraceCmd.3 @@ -13,14 +13,14 @@ Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames an .nf \fB#include <tcl.h>\fR .sp -ClientData -\fBTcl_CommandTraceInfo(\fIinterp, cmdName, flags, proc, prevClientData\fB)\fR +void * +\fBTcl_CommandTraceInfo\fR(\fIinterp, cmdName, flags, proc, prevClientData\fR) .sp int -\fBTcl_TraceCommand(\fIinterp, cmdName, flags, proc, clientData\fB)\fR +\fBTcl_TraceCommand\fR(\fIinterp, cmdName, flags, proc, clientData\fR) .sp -void -\fBTcl_UntraceCommand(\fIinterp, cmdName, flags, proc, clientData\fB)\fR +\fBTcl_UntraceCommand\fR(\fIinterp, cmdName, flags, proc, clientData\fR) +.fi .SH ARGUMENTS .AS Tcl_CommandTraceProc prevClientData .AP Tcl_Interp *interp in @@ -32,9 +32,9 @@ OR'ed collection of the values \fBTCL_TRACE_RENAME\fR and \fBTCL_TRACE_DELETE\fR. .AP Tcl_CommandTraceProc *proc in Procedure to call when specified operations occur to \fIcmdName\fR. -.AP ClientData clientData in +.AP void *clientData in Arbitrary argument to pass to \fIproc\fR. -.AP ClientData prevClientData in +.AP void *prevClientData in If non-NULL, gives last value returned by \fBTcl_CommandTraceInfo\fR, so this call will return information about next trace. If NULL, this call will return information about first trace. @@ -54,9 +54,11 @@ trace procedure is to be invoked. It consists of an OR'ed combination of any of the following values: .TP \fBTCL_TRACE_RENAME\fR +. Invoke \fIproc\fR whenever the command is renamed. .TP \fBTCL_TRACE_DELETE\fR +. Invoke \fIproc\fR when the command is deleted. .PP Whenever one of the specified operations occurs to the command, @@ -65,7 +67,7 @@ match the type \fBTcl_CommandTraceProc\fR: .PP .CS typedef void \fBTcl_CommandTraceProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR, const char *\fIoldName\fR, const char *\fInewName\fR, @@ -74,7 +76,7 @@ typedef void \fBTcl_CommandTraceProc\fR( .PP The \fIclientData\fR and \fIinterp\fR parameters will have the same values as those passed to \fBTcl_TraceCommand\fR when the trace was -created. \fIClientData\fR typically points to an application-specific +created. \fIclientData\fR typically points to an application-specific data structure that describes what to do when \fIproc\fR is invoked. \fIOldName\fR gives the name of the command being renamed, and \fInewName\fR gives the name that the command is being renamed to (or diff --git a/doc/TraceVar.3 b/doc/TraceVar.3 index 5de6a44..3fb3ab6 100644 --- a/doc/TraceVar.3 +++ b/doc/TraceVar.3 @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_TraceVar 3 8.7 Tcl "Tcl Library Procedures" +.TH Tcl_TraceVar 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME @@ -15,22 +15,23 @@ Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, \fB#include <tcl.h>\fR .sp int -\fBTcl_TraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR +\fBTcl_TraceVar\fR(\fIinterp, varName, flags, proc, clientData\fR) .sp int -\fBTcl_TraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR +\fBTcl_TraceVar2\fR(\fIinterp, name1, name2, flags, proc, clientData\fR) .sp -\fBTcl_UntraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR +\fBTcl_UntraceVar\fR(\fIinterp, varName, flags, proc, clientData\fR) .sp -\fBTcl_UntraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR +\fBTcl_UntraceVar2\fR(\fIinterp, name1, name2, flags, proc, clientData\fR) .sp -ClientData -\fBTcl_VarTraceInfo(\fIinterp, varName, flags, proc, prevClientData\fB)\fR +void * +\fBTcl_VarTraceInfo\fR(\fIinterp, varName, flags, proc, prevClientData\fR) .sp -ClientData -\fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR +void * +\fBTcl_VarTraceInfo2\fR(\fIinterp, name1, name2, flags, proc, prevClientData\fR) +.fi .SH ARGUMENTS -.AS Tcl_VarTraceProc prevClientData +.AS void *prevClientData .AP Tcl_Interp *interp in Interpreter containing variable. .AP "const char" *varName in @@ -46,7 +47,7 @@ Not all flags are used by all procedures. See below for more information. .AP Tcl_VarTraceProc *proc in Procedure to invoke whenever one of the traced operations occurs. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIproc\fR. .AP "const char" *name1 in Name of scalar or array variable (without array index). @@ -54,7 +55,7 @@ Name of scalar or array variable (without array index). For a trace on an element of an array, gives the index of the element. For traces on scalar variables or on whole arrays, is NULL. -.AP ClientData prevClientData in +.AP void *prevClientData in If non-NULL, gives last value returned by \fBTcl_VarTraceInfo\fR or \fBTcl_VarTraceInfo2\fR, so this call will return information about next trace. If NULL, this call will return information about first @@ -76,22 +77,27 @@ for setting up the trace. It consists of an OR-ed combination of any of the following values: .TP \fBTCL_GLOBAL_ONLY\fR +. Normally, the variable will be looked up at the current level of procedure call; if this bit is set then the variable will be looked up at global level, ignoring any active procedures. .TP \fBTCL_NAMESPACE_ONLY\fR +. Normally, the variable will be looked up at the current level of procedure call; if this bit is set then the variable will be looked up in the current namespace, ignoring any active procedures. .TP \fBTCL_TRACE_READS\fR +. Invoke \fIproc\fR whenever an attempt is made to read the variable. .TP \fBTCL_TRACE_WRITES\fR +. Invoke \fIproc\fR whenever an attempt is made to modify the variable. .TP \fBTCL_TRACE_UNSETS\fR +. Invoke \fIproc\fR whenever the variable is unset. A variable may be unset either explicitly by an \fBunset\fR command, or implicitly when a procedure returns (its local variables are @@ -99,18 +105,21 @@ automatically unset) or when the interpreter or namespace is deleted (all variables are automatically unset). .TP \fBTCL_TRACE_ARRAY\fR +. Invoke \fIproc\fR whenever the array command is invoked. This gives the trace procedure a chance to update the array before array names or array get is called. Note that this is called before an array set, but that will trigger write traces. .TP \fBTCL_TRACE_RESULT_DYNAMIC\fR +. The result of invoking the \fIproc\fR is a dynamically allocated string that will be released by the Tcl library via a call to -\fBckfree\fR. Must not be specified at the same time as +\fBTcl_Free\fR. Must not be specified at the same time as \fBTCL_TRACE_RESULT_OBJECT\fR. .TP \fBTCL_TRACE_RESULT_OBJECT\fR +. The result of invoking the \fIproc\fR is a Tcl_Obj* (cast to a char*) with a reference count of at least one. The ownership of that reference will be transferred to the Tcl core for release (when the @@ -124,7 +133,7 @@ It should have arguments and result that match the type .PP .CS typedef char *\fBTcl_VarTraceProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR, const char *\fIname1\fR, const char *\fIname2\fR, @@ -134,12 +143,14 @@ typedef char *\fBTcl_VarTraceProc\fR( The \fIclientData\fR and \fIinterp\fR parameters will have the same values as those passed to \fBTcl_TraceVar\fR when the trace was created. -\fIClientData\fR typically points to an application-specific +\fIclientData\fR typically points to an application-specific data structure that describes what to do when \fIproc\fR is invoked. -\fIName1\fR and \fIname2\fR give the name of the traced variable -in the normal two-part form (see the description of \fBTcl_TraceVar2\fR -below for details). +\fIName1\fR and \fIname2\fR give the name of the variable that +triggered the callback in the normal two-part form (see the description +of \fBTcl_TraceVar2\fR below for details). In case \fIname1\fR is an +alias to an array element (created through facilities such as \fBupvar\fR), +\fIname2\fR holds the index of the array element, rather than NULL. \fIFlags\fR is an OR-ed combination of bits providing several pieces of information. One of the bits \fBTCL_TRACE_READS\fR, \fBTCL_TRACE_WRITES\fR, @@ -308,7 +319,7 @@ The return value must be a pointer to a static character string containing an error message, unless (\fIexactly\fR one of) the \fBTCL_TRACE_RESULT_DYNAMIC\fR and \fBTCL_TRACE_RESULT_OBJECT\fR flags is set, which specify that the result is -either a dynamic string (to be released with \fBckfree\fR) or a +either a dynamic string (to be released with \fBTcl_Free\fR) or a Tcl_Obj* (cast to char* and to be released with \fBTcl_DecrRefCount\fR) containing the error message. If a trace procedure returns an error, no further traces are @@ -333,7 +344,8 @@ The routine \fBTcl_InterpDeleted\fR is an important tool for this. When \fBTcl_InterpDeleted\fR returns 1, \fIproc\fR will not be able to invoke any scripts in \fIinterp\fR. You may encounter old code using a deprecated flag value \fBTCL_INTERP_DESTROYED\fR to signal this -condition, but any supported code should be converted to stop using it. +condition, but Tcl 9 no longer supports this. Any supported code +must be converted to stop using it. .PP A trace procedure can be called at any time, even when there are partially formed results stored in the interpreter. If diff --git a/doc/Translate.3 b/doc/Translate.3 index 38831d3..0b6db29 100644 --- a/doc/Translate.3 +++ b/doc/Translate.3 @@ -9,20 +9,20 @@ .so man.macros .BS .SH NAME -Tcl_TranslateFileName \- convert file name to native form and replace tilde with home directory +Tcl_TranslateFileName \- convert file name to native form .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp char * \fBTcl_TranslateFileName\fR(\fIinterp\fR, \fIname\fR, \fIbufferPtr\fR) +.fi .SH ARGUMENTS .AS Tcl_DString *bufferPtr in/out .AP Tcl_Interp *interp in Interpreter in which to report an error, if any. .AP "const char" *name in -File name, which may start with a -.QW ~ . +File name .AP Tcl_DString *bufferPtr in/out If needed, this dynamic string is used to store the new file name. At the time of the call it should be uninitialized or free. The @@ -34,7 +34,7 @@ anything stored here. This utility procedure translates a file name to a platform-specific form which, after being converted to the appropriate encoding, is suitable for passing to the local operating system. In particular, it converts -network names into native form and does tilde substitution. +network names into native form. .PP However, with the advent of the newer \fBTcl_FSGetNormalizedPath\fR and \fBTcl_FSGetNativePath\fR, there is no longer any need to use this @@ -45,7 +45,7 @@ Finally \fBTcl_FSGetNativePath\fR does not require you to free anything afterwards. .PP If -\fBTcl_TranslateFileName\fR has to do tilde substitution or translate +\fBTcl_TranslateFileName\fR has to translate the name then it uses the dynamic string at \fI*bufferPtr\fR to hold the new string it generates. @@ -68,4 +68,4 @@ has its default empty value when \fBTcl_TranslateFileName\fR is invoked. .SH "SEE ALSO" filename(n) .SH KEYWORDS -file name, home directory, tilde, translate, user +file name, home directory, translate, user diff --git a/doc/UniCharIsAlpha.3 b/doc/UniCharIsAlpha.3 index a07af9a..4ae4612 100644 --- a/doc/UniCharIsAlpha.3 +++ b/doc/UniCharIsAlpha.3 @@ -48,6 +48,7 @@ int .sp int \fBTcl_UniCharIsWordChar\fR(\fIch\fR) +.fi .SH ARGUMENTS .AS int ch .AP int ch in @@ -64,28 +65,34 @@ with the various routines. .SH "CHARACTER CLASSES" .PP -\fBTcl_UniCharIsAlnum\fR tests if the character is an alphanumeric Unicode character. +\fBTcl_UniCharIsAlnum\fR tests if the character is an alphanumeric Unicode +character. .PP -\fBTcl_UniCharIsAlpha\fR tests if the character is an alphabetic Unicode character. +\fBTcl_UniCharIsAlpha\fR tests if the character is an alphabetic Unicode +character. .PP \fBTcl_UniCharIsControl\fR tests if the character is a Unicode control character. .PP \fBTcl_UniCharIsDigit\fR tests if the character is a numeric Unicode character. .PP -\fBTcl_UniCharIsGraph\fR tests if the character is any Unicode print character except space. +\fBTcl_UniCharIsGraph\fR tests if the character is any Unicode print character +except space. .PP \fBTcl_UniCharIsLower\fR tests if the character is a lowercase Unicode character. .PP \fBTcl_UniCharIsPrint\fR tests if the character is a Unicode print character. .PP -\fBTcl_UniCharIsPunct\fR tests if the character is a Unicode punctuation character. +\fBTcl_UniCharIsPunct\fR tests if the character is a Unicode punctuation +character. .PP -\fBTcl_UniCharIsSpace\fR tests if the character is a whitespace Unicode character. +\fBTcl_UniCharIsSpace\fR tests if the character is a whitespace Unicode +character. .PP -\fBTcl_UniCharIsUpper\fR tests if the character is an uppercase Unicode character. +\fBTcl_UniCharIsUpper\fR tests if the character is an uppercase Unicode +character. .PP -\fBTcl_UniCharIsUnicode\fR tests if the character is a Unicode character, not being -a surrogate or noncharacter. +\fBTcl_UniCharIsUnicode\fR tests if the character is a Unicode character, +not being a surrogate or noncharacter. .PP \fBTcl_UniCharIsWordChar\fR tests if the character is alphanumeric or a connector punctuation mark. diff --git a/doc/UpVar.3 b/doc/UpVar.3 index 9e17ed5..d755b34 100644 --- a/doc/UpVar.3 +++ b/doc/UpVar.3 @@ -15,10 +15,11 @@ Tcl_UpVar, Tcl_UpVar2 \- link one variable to another \fB#include <tcl.h>\fR .sp int -\fBTcl_UpVar(\fIinterp, frameName, sourceName, destName, flags\fB)\fR +\fBTcl_UpVar\fR(\fIinterp, frameName, sourceName, destName, flags\fR) .sp int -\fBTcl_UpVar2(\fIinterp, frameName, name1, name2, destName, flags\fB)\fR +\fBTcl_UpVar2\fR(\fIinterp, frameName, name1, name2, destName, flags\fR) +.fi .SH ARGUMENTS .AS "const char" *sourceName .AP Tcl_Interp *interp in @@ -15,16 +15,16 @@ Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToChar16, Tcl_UtfToWChar .sp typedef ... \fBTcl_UniChar\fR; .sp -int +Tcl_Size \fBTcl_UniCharToUtf\fR(\fIch, buf\fR) .sp -int +Tcl_Size \fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR) .sp -int +Tcl_Size \fBTcl_UtfToChar16\fR(\fIsrc, uPtr\fR) .sp -int +Tcl_Size \fBTcl_UtfToWChar\fR(\fIsrc, wPtr\fR) .sp char * @@ -55,19 +55,19 @@ int \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int -\fBTcl_UniCharNcmp\fR(\fIucs, uct, numChars\fR) +\fBTcl_UniCharNcmp\fR(\fIucs, uct, uniLength\fR) .sp int -\fBTcl_UniCharNcasecmp\fR(\fIucs, uct, numChars\fR) +\fBTcl_UniCharNcasecmp\fR(\fIucs, uct, uniLength\fR) .sp int \fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR) .sp int -\fBTcl_UtfNcmp\fR(\fIcs, ct, numChars\fR) +\fBTcl_UtfNcmp\fR(\fIcs, ct, length\fR) .sp int -\fBTcl_UtfNcasecmp\fR(\fIcs, ct, numChars\fR) +\fBTcl_UtfNcasecmp\fR(\fIcs, ct, length\fR) .sp int \fBTcl_UtfCharComplete\fR(\fIsrc, numBytes\fR) @@ -93,8 +93,9 @@ int const char * \fBTcl_UtfAtIndex\fR(\fIsrc, index\fR) .sp -int +Tcl_Size \fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR) +.fi .SH ARGUMENTS .AS "const Tcl_UniChar" *uniPattern in/out .AP char *buf out @@ -143,11 +144,9 @@ The length of the input in wchar_t units. If negative, the length includes all bytes until the first null. .AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. -.AP "unsigned long" numChars in -The number of characters to compare. .AP "const char" *start in Pointer to the beginning of a UTF-8 string. -.AP int index in +.AP Tcl_Size index in The index of a character (not byte) in the UTF-8 string. .AP int *readPtr out If non-NULL, filled with the number of bytes in the backslash sequence, @@ -172,11 +171,12 @@ can consume in a single call. .PP \fBTcl_UniCharToUtf\fR stores the character \fIch\fR as a UTF-8 string in starting at \fIbuf\fR. The return value is the number of bytes stored -in \fIbuf\fR. If ch is a high surrogate (range U+D800 - U+DBFF), then -the return value will be 1 and a single byte in the range 0xF0 - 0xF4 -will be stored. If you still want to produce UTF-8 output for it (even -though knowing it's an illegal code-point on its own), just call -\fBTcl_UniCharToUtf\fR again specifying ch = -1. +in \fIbuf\fR. The character \fIch\fR can be or'ed with the value TCL_COMBINE +to enable special behavior, compatible with Tcl 8.x. Then, if ch is a high +surrogate (range U+D800 - U+DBFF), the return value will be 1 and a single +byte in the range 0xF0 - 0xF4 will be stored. If \fIch\fR is a low surrogate +(range U+DC00 - U+DFFF), an attempt is made to combine the result with +the earlier produced bytes, resulting in a 4-byte UTF-8 byte sequence. .PP \fBTcl_UtfToUniChar\fR reads one UTF-8 character starting at \fIsrc\fR and stores it as a Tcl_UniChar in \fI*chPtr\fR. The return value is the @@ -225,7 +225,7 @@ the number of Unicode characters (not bytes) in that string. \fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to \fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters. They accept two null-terminated Unicode strings and the number of characters -to compare. Both strings are assumed to be at least \fInumChars\fR characters +to compare. Both strings are assumed to be at least \fIuniLength\fR characters long. \fBTcl_UniCharNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal @@ -239,7 +239,7 @@ be case sensitive and returns whether the string matches the pattern. .PP \fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It accepts two null-terminated UTF-8 strings and the number of characters -to compare. (Both strings are assumed to be at least \fInumChars\fR +to compare. (Both strings are assumed to be at least \fIlength\fR characters long.) \fBTcl_UtfNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the @@ -306,17 +306,13 @@ byte \fIsrc[0]\fR nor the byte \fIstart[-1]\fR nor the byte Pascal Ord() function. It returns the Unicode character represented at the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR -characters. If a negative \fIindex\fR is given or \fIindex\fR points -to the second half of a surrogate pair, it returns -1. +characters. If \fIindex\fR is negative it returns -1. .PP \fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR characters. This is equivalent to calling -\fBTcl_UtfToUniChar\fR \fIindex\fR times, except if that would return -a pointer to the second byte of a valid 4-byte UTF-8 sequence, in which -case, \fBTcl_UtfToUniChar\fR will be called once more to find the end -of the sequence. If a negative \fIindex\fR is given, the returned pointer -points to the first character in the source string. +\fBTcl_UtfToUniChar\fR \fIindex\fR times. If \fIindex\fR is negative, +the return pointer points to the first character in the source string. .PP \fBTcl_UtfBackslash\fR is a utility procedure used by several of the Tcl commands. It parses a backslash sequence and stores the properly formed diff --git a/doc/WrongNumArgs.3 b/doc/WrongNumArgs.3 index 533cb4f..864d315 100644 --- a/doc/WrongNumArgs.3 +++ b/doc/WrongNumArgs.3 @@ -14,12 +14,13 @@ Tcl_WrongNumArgs \- generate standard error message for wrong number of argument \fB#include <tcl.h>\fR .sp \fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR) +.fi .SH ARGUMENTS .AS "Tcl_Obj *const" *message .AP Tcl_Interp interp in Interpreter in which error will be reported: error message gets stored in its result value. -.AP int objc in +.AP Tcl_Size objc in Number of leading arguments from \fIobjv\fR to include in error message. .AP "Tcl_Obj *const" objv[] in @@ -63,7 +64,7 @@ a subcommand. The command into an \fIindexObject\fR. If an error occurs in the parsing of the subcommand we would like to use the full subcommand name rather than the abbreviation. If the \fBTcl_WrongNumArgs\fR command finds any -\fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand +\fIindexObject\fRs in the \fIobjv\fR array, it will use the full subcommand name in the error message instead of the abbreviated name that was originally passed in. Using the above example, let us assume that \fIbar\fR is actually an abbreviation for \fIbarfly\fR and the value diff --git a/doc/after.n b/doc/after.n index 1a814e0..a619935 100644 --- a/doc/after.n +++ b/doc/after.n @@ -12,23 +12,21 @@ .SH NAME after \- Execute a command after a time delay .SH SYNOPSIS +.nf \fBafter \fIms\fR -.sp \fBafter \fIms \fR?\fIscript script script ...\fR? -.sp \fBafter cancel \fIid\fR -.sp \fBafter cancel \fIscript script script ...\fR -.sp \fBafter idle \fR?\fIscript script script ...\fR? -.sp \fBafter info \fR?\fIid\fR? +.fi .BE .SH DESCRIPTION .PP This command is used to delay execution of the program or to execute a command in background sometime in the future. It has several forms, depending on the first argument to the command: +.\" METHOD: <none> .TP \fBafter \fIms\fR . @@ -37,6 +35,7 @@ A negative number is treated as 0. The command sleeps for \fIms\fR milliseconds and then returns. While the command is sleeping the application does not respond to events. +.\" METHOD: <timedelay> .TP \fBafter \fIms \fR?\fIscript script script ...\fR? . @@ -54,8 +53,9 @@ registered with \fBinterp bgerror\fR. The \fBafter\fR command returns an identifier that can be used to cancel the delayed command using \fBafter cancel\fR. A \fIms\fR value of 0 (or negative) queues the event immediately with -priority over other event types (if not installed withn an event proc, +priority over other event types (if not installed with an event proc, which will wait for next round of events). +.\" METHOD: cancel .TP \fBafter cancel \fIid\fR . @@ -74,6 +74,7 @@ separators (just as in the \fBconcat\fR command). If there is a pending command that matches the string, it is canceled and will never be executed; if no such command is currently pending then the \fBafter cancel\fR command has no effect. +.\" METHOD: idle .TP \fBafter idle \fIscript \fR?\fIscript script ...\fR? . @@ -87,6 +88,7 @@ to cancel the delayed command using \fBafter cancel\fR. If an error occurs while executing the script then the background error will be reported by the command registered with \fBinterp bgerror\fR. +.\" METHOD: info .TP \fBafter info \fR?\fIid\fR? . diff --git a/doc/apply.n b/doc/apply.n index aeb2227..154ddff 100644 --- a/doc/apply.n +++ b/doc/apply.n @@ -44,18 +44,18 @@ interpreted relative to the global namespace even if its name does not start with .QW :: . .PP -The semantics of \fBapply\fR can also be described by: +The semantics of \fBapply\fR can also be described by approximately this: .PP .CS proc apply {fun args} { set len [llength $fun] if {($len < 2) || ($len > 3)} { - error "can't interpret \e"$fun\e" as anonymous function" + error "can't interpret \e"$fun\e" as anonymous function" } lassign $fun argList body ns set name ::$ns::[getGloballyUniqueName] set body0 { - rename [lindex [info level 0] 0] {} + rename [lindex [info level 0] 0] {} } proc $name $argList ${body0}$body set code [catch {uplevel 1 $name $args} res opt] diff --git a/doc/array.n b/doc/array.n index 268597d..6c63366 100644 --- a/doc/array.n +++ b/doc/array.n @@ -23,8 +23,10 @@ Unless otherwise specified for individual commands below, The \fIoption\fR argument determines what action is carried out by the command. The legal \fIoptions\fR (which may be abbreviated) are: +.\" METHOD: anymore .TP \fBarray anymore \fIarrayName searchId\fR +. Returns 1 if there are any more elements left to be processed in an array search, 0 if all elements have already been returned. @@ -35,6 +37,7 @@ This option is particularly useful if an array has an element with an empty name, since the return value from \fBarray nextelement\fR will not indicate whether the search has been completed. +.\" METHOD: default .TP \fBarray default \fIsubcommand arrayName args...\fR .VS TIP508 @@ -82,19 +85,25 @@ value. Raises an error if \fIarrayName\fR is an existing variable that is not an array. .VE TIP508 .RE +.\" METHOD: donesearch .TP \fBarray donesearch \fIarrayName searchId\fR +. This command terminates an array search and destroys all the state associated with that search. \fISearchId\fR indicates which search on \fIarrayName\fR to destroy, and must have been the return value from a previous invocation of \fBarray startsearch\fR. Returns an empty string. +.\" METHOD: exists .TP \fBarray exists \fIarrayName\fR +. Returns 1 if \fIarrayName\fR is an array variable, 0 if there is no variable by that name or if it is a scalar variable. +.\" METHOD: for .TP \fBarray for {\fIkeyVariable valueVariable\fB} \fIarrayName body\fP +. The first argument is a two element list of variable names for the key and value of each entry in the array. The second argument is the array name to iterate over. The third argument is the body to execute @@ -102,8 +111,10 @@ for each key and value returned. The ordering of the returned keys is undefined. If an array element is deleted or a new array element is inserted during the \fIarray for\fP process, the command will terminate with an error. +.\" METHOD: get .TP \fBarray get \fIarrayName\fR ?\fIpattern\fR? +. Returns a list containing pairs of elements. The first element in each pair is the name of an element in \fIarrayName\fR and the second element of each pair is the value of the @@ -118,8 +129,10 @@ the array contains no elements, then an empty list is returned. If traces on the array modify the list of elements, the elements returned are those that exist both before and after the call to \fBarray get\fR. +.\" METHOD: names .TP \fBarray names \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR? +. Returns a list containing the names of all of the elements in the array that match \fIpattern\fR. \fIMode\fR may be one of \fB\-exact\fR, \fB\-glob\fR, or \fB\-regexp\fR. If specified, \fImode\fR @@ -132,8 +145,10 @@ If \fIpattern\fR is omitted then the command returns all of the element names in the array. If there are no (matching) elements in the array, or if \fIarrayName\fR is not the name of an array variable, then an empty string is returned. +.\" METHOD: nextelement .TP \fBarray nextelement \fIarrayName searchId\fR +. Returns the name of the next element in \fIarrayName\fR, or an empty string if all elements of \fIarrayName\fR have already been returned in this search. The \fIsearchId\fR @@ -143,8 +158,10 @@ Warning: if elements are added to or deleted from the array, then all searches are automatically terminated just as if \fBarray donesearch\fR had been invoked; this will cause \fBarray nextelement\fR operations to fail for those searches. +.\" METHOD: set .TP \fBarray set \fIarrayName list\fR +. Sets the values of one or more elements in \fIarrayName\fR. \fIlist\fR must have a form like that returned by \fBarray get\fR, consisting of an even number of elements. @@ -154,13 +171,17 @@ is used as a new value for that array element. If the variable \fIarrayName\fR does not already exist and \fIlist\fR is empty, \fIarrayName\fR is created with an empty array value. +.\" METHOD: size .TP \fBarray size \fIarrayName\fR +. Returns a decimal string giving the number of elements in the array. If \fIarrayName\fR is not the name of an array then 0 is returned. +.\" METHOD: startsearch .TP \fBarray startsearch \fIarrayName\fR +. This command initializes an element-by-element search through the array given by \fIarrayName\fR, such that invocations of the \fBarray nextelement\fR command will return the names of the @@ -175,14 +196,18 @@ It is currently more efficient and easier to use either the \fBarray get\fR or \fBarray names\fR, together with \fBforeach\fR, to iterate over all but very large arrays. See the examples below for how to do this. +.\" METHOD: statistics .TP \fBarray statistics \fIarrayName\fR +. Returns statistics about the distribution of data within the hashtable that represents the array. This information includes the number of entries in the table, the number of buckets, and the utilization of the buckets. +.\" METHOD: unset .TP \fBarray unset \fIarrayName\fR ?\fIpattern\fR? +. Unsets all of the elements in the array that match \fIpattern\fR (using the matching rules of \fBstring match\fR). If \fIarrayName\fR is not the name of an array variable or there are no matching elements in the array, no diff --git a/doc/binary.n b/doc/binary.n index 7968d77..911e170 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -40,12 +40,15 @@ done by other Tcl commands (respectively \fBstring range\fR, binary string in Tcl is merely one where all the characters it contains are in the range \eu0000\-\eu00FF. .SH "BINARY ENCODE AND DECODE" +.\" METHOD: decode +.\" METHOD: encode .PP When encoding binary data as a readable string, the starting binary data is passed to the \fBbinary encode\fR command, together with the name of the encoding to use and any encoding-specific options desired. Data which has been -encoded can be converted back to binary form using \fBbinary decode\fR. The -following formats and options are supported. +encoded can be converted back to binary form using \fBbinary decode\fR. +The \fBbinary encode\fR command raises an error if the \fIdata\fR argument +is not binary data. The following formats and options are supported. .TP \fBbase64\fR . @@ -56,11 +59,13 @@ information. .RS .PP During encoding, the following options are supported: +.\" OPTION: -maxlen .TP \fB\-maxlen \fIlength\fR . Indicates that the output should be split into lines of no more than \fIlength\fR characters. By default, lines are not split. +.\" OPTION: -wrapchar .TP \fB\-wrapchar \fIcharacter\fR . @@ -70,6 +75,7 @@ newline character, .QW \en . .PP During decoding, the following options are supported: +.\" OPTION: -strict .TP \fB\-strict\fR . @@ -88,6 +94,7 @@ When decoding, upper and lower characters are accepted. .PP No options are supported during encoding. During decoding, the following options are supported: +.\" OPTION: -strict .TP \fB\-strict\fR . @@ -104,12 +111,14 @@ largely superseded by the \fBbase64\fR binary encoding. .PP During encoding, the following options are supported (though changing them may produce files that other implementations of decoders cannot process): +.\" OPTION: -maxlen .TP \fB\-maxlen \fIlength\fR . Indicates the maximum number of characters to produce for each encoded line. The valid range is 5 to 85. Line lengths outside that range cannot be accommodated by the encoding format. The default value is 61. +.\" OPTION: -wrapchar .TP \fB\-wrapchar \fIcharacter\fR . @@ -121,6 +130,7 @@ they would generate encoded text that could not be decoded. The default value is a single newline. .PP During decoding, the following options are supported: +.\" OPTION: -strict .TP \fB\-strict\fR . @@ -133,6 +143,7 @@ Note that neither the encoder nor the decoder handle the header and footer of the uuencode format. .RE .SH "BINARY FORMAT" +.\" METHOD: format .PP The \fBbinary format\fR command generates a binary string whose layout is specified by the \fIformatString\fR and whose contents come from @@ -606,12 +617,13 @@ will return .CE .RE .SH "BINARY SCAN" +.\" METHOD: scan .PP The \fBbinary scan\fR command parses fields from a binary string, returning the number of conversions performed. \fIString\fR gives the -input bytes to be parsed (one byte per character, and characters not -representable as a byte have their high bits chopped) -and \fIformatString\fR indicates how to parse it. +input bytes to be parsed and \fIformatString\fR indicates how to parse it. +An error is raised if \fIstring\fR is anything other than a valid binary +data value. Each \fIvarName\fR gives the name of a variable; when a field is scanned from \fIstring\fR the result is assigned to the corresponding variable. @@ -1096,7 +1108,7 @@ base64 and prints them: set f [open $filename rb] set data [read $f] close $f -puts [\fBbinary encode\fR base64 \-maxlen 64 $data] +puts [\fBbinary encode\fR base64 -maxlen 64 $data] .CE .SH "SEE ALSO" encoding(n), format(n), scan(n), string(n), tcl_platform(n) diff --git a/doc/callback.n b/doc/callback.n index 3ab81ac..c96b23b 100644 --- a/doc/callback.n +++ b/doc/callback.n @@ -14,8 +14,8 @@ callback, mymethod \- generate callbacks to methods .nf package require tcl::oo -\fBcallback\fR \fImethodName\fR ?\fIarg ...\fR? -\fBmymethod\fR \fImethodName\fR ?\fIarg ...\fR? +\fBcallback\fI methodName\fR ?\fIarg ...\fR? +\fBmymethod\fI methodName\fR ?\fIarg ...\fR? .fi .BE .SH DESCRIPTION @@ -20,6 +20,7 @@ Change the current working directory to \fIdirName\fR, or to the home directory (as specified in the HOME environment variable) if \fIdirName\fR is not given. Returns an empty string. +.PP Note that the current working directory is a per-process resource; the \fBcd\fR command changes the working directory for all interpreters and all threads. @@ -28,7 +29,7 @@ and all threads. Change to the home directory of the user \fBfred\fR: .PP .CS -\fBcd\fR ~fred +\fBcd\fR [file home fred] .CE .PP Change to the directory \fBlib\fR that is a sibling directory of the @@ -21,6 +21,7 @@ otherwise manipulating channels, e.g. those created by \fBopen\fR and which correspond respectively to the standard input, output, and error streams of the process. Any unique abbreviation for \fIoperation\fR is acceptable. Available operations are: +.\" METHOD: blocked .TP \fBchan blocked \fIchannelName\fR . @@ -28,6 +29,7 @@ Returns 1 when the channel is in non-blocking mode and the last input operation on the channel failed because it would have otherwise caused the process to block, and 0 otherwise. Each Tcl channel is in blocking mode unless configured otherwise. +.\" METHOD: close .TP \fBchan close \fIchannelName\fR ?\fIdirection\fR? . @@ -84,6 +86,7 @@ switch them back to blocking or (b) use the environment variable .QW \fB0\fR restores the previous behavior. .RE +.\" METHOD: configure .TP \fBchan configure \fIchannelName\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... . @@ -102,8 +105,9 @@ The options described below are supported for all channels. Each type of channel may provide additional options. Those options are described in the relevant documentation. For example, additional options are documented for \fBsocket\fR, and also for serial devices at \fBopen\fR. +.\" OPTION: -blocking .TP -\fB\-blocking\fR \fIboolean\fR +\fB\-blocking\fI boolean\fR . If \fB\-blocking\fR is set to \fBtrue\fR, which is the default, reading from or writing to the channel may cause the process to block indefinitely. Otherwise, @@ -112,8 +116,9 @@ flush\fR, and \fBchan close\fR take care not to block. Non-blocking mode in generally requires that the event loop is entered, e.g. by calling \fBTcl_DoOneEvent\fR or \fBvwait\fR or by using Tk, to give Tcl a chance to process events on the channel. +.\" OPTION: -buffering .TP -\fB\-buffering\fR \fInewValue\fR +\fB\-buffering\fI newValue\fR . If \fInewValue\fR is \fBfull\fR, which is the default, output is buffered until the internal buffer is full or until \fBchan flush\fR is called. If @@ -122,11 +127,13 @@ character is written. If \fInewValue\fR is \fBnone\fR, output is flushed after every output operation. For \fBstdin\fR, \fBstdout\fR, and channels that connect to terminal-like devices, the default value is \fBline\fR. For \fBstderr\fR the default value is \fBnone\fR. +.\" OPTION: -buffersize .TP -\fB\-buffersize\fR \fInewSize\fR +\fB\-buffersize\fI newSize\fR . \fInewSize\fR, an integer no greater than one million, is the size in bytes of any input or output buffers subsequently allocated for this channel. +.\" OPTION: -encoding .TP \fB\-encoding\fR ?\fIname\fR? . @@ -137,41 +144,29 @@ returned by \fBencoding names\fR, or from Unicode to the encoding. .RS .PP -\fBbinary\fR is an alias for \fBiso8859-1\fR: Each byte read from the -channel becomes the Unicode character having the same value as that byte, and -each character written to the channel becomes a single byte in the output, -allowing Tcl to work seamlessly with binary data as long as each "character" in -the data remains in the range of 0 to 255 so that there is no distinction between -binary data and text. For example, A JPEG image can be read from a -\fBbinary\fR channel, manipulated, and then written back to a \fBbinary\fR -channel. - -For working with binary data \fB\-translation binary\fR is usually used -instead, as it sets the encoding to \fBbinary\fR and also disables other -translations on the channel. +\fBbinary\fR is an alias for \fBiso8859-1\fR. This alone is not sufficient for +working with binary data. Use \fB\-translation binary\fR instead. .PP The encoding of a new channel is the value of \fBencoding system\fR, which returns the platform- and locale-dependent system encoding used to interface with the operating system, .RE +.\" OPTION: -eofchar .TP -\fB\-eofchar\fR \fIchar\fR -.TP -\fB\-eofchar\fR \fB{\fIchar outChar\fB}\fR +\fB\-eofchar\fI char\fR . \fIchar\fR signals the end of the data when it is encountered in the input. -For output, \fIoutChar\fR is added when the channel is closed. If \fIchar\fR -is the empty string, there is no special character that marks the end of the -data. For read-write channels, one end-of-file character for input and another -for output may be given. When only one end-of-file character is given it is -applied to input only. - -The default value is the empty string, except that under Windows the default -value for reading is Control-z (\ex1A). The acceptable range is \ex01 - +If \fIchar\fR is the empty string, there is no special character that marks +the end of the data. +.RS +.PP +The default value is the empty string. The acceptable range is \ex01 - \ex7F. A value outside this range results in an error. +.RE .VS "TCL8.7 TIP656" +.\" OPTION: -profile .TP -\fB\-profile\fR \fIprofile\fR +\fB\-profile\fI profile\fR . Specifies the encoding profile to be used on the channel. The encoding transforms in use for the channel's input and output will then be subject to the @@ -179,8 +174,9 @@ rules of that profile. Any failures will result in a channel error. See \fBPROFILES\fR in the \fBencoding(n)\fR documentation for details about encoding profiles. .VE "TCL8.7 TIP656" +.\" OPTION: -translation .TP -\fB\-translation\fR \fItranslation\fR +\fB\-translation\fI translation\fR .TP \fB\-translation\fR \fB{\fIinTranslation outTranslation\fB}\fR . @@ -192,9 +188,9 @@ carriage-return-linefeed sequence is normally used in network connections. Therefore, on input, e.g. with \fBchan gets\fR and \fBchan read\fR, each external end-of-line character is translated into a line feed. On output, e.g. with \fBchan puts\fR, each line feed is translated to the external -end-of-line character. The default translation, \fBauto\fR, handles all the common -cases, and \fB\-translation\fR provides explicit control over the end-of-line -character. +end-of-line character. The default translation, \fBauto\fR, handles all the +common cases, and \fB\-translation\fR provides explicit control over the +end-of-line character. .RS .PP Returns the input translation for a read-only channel, the output translation @@ -203,93 +199,81 @@ translation for a read-write channel. When two translations are given, they are the input and output translation, respectively. When only one translation is given for a read-write channel, it is the translation for both input and output. The following values are currently supported: -.TP -\fBauto\fR -. +.IP \fBauto\fR The default. For input each occurrence of a line feed (\fBlf\fR), carriage return (\fBcr\fR), or carriage return followed by a line feed (\fBcrlf\fR) is translated into a line feed. For output, each line feed is translated into a platform-specific representation: For all Unix variants it is \fBlf\fR, and for all Windows variants it is \fBcrlf\fR, except that for sockets on all platforms it is \fBcrlf\fR for both input and output. -.TP -\fBbinary\fR -. -Like \fBlf\fR, no end-of-line translation is performed, but in addition, -\fB\-eofchar\fR is set to the empty string to disable it, and \fB\-encoding\fR -is set to \fBbinary\fR. With this one setting, a channel is fully configured -for binary input and output. -.TP -\fBcr\fR -. +.IP \fBbinary\fR +Like \fBlf\fR, no end-of-line translation is performed, but in addition, sets +\fB\-eofchar\fR to the empty string to disable it, and sets \fB\-encoding\fR +to \fBiso8859-1\fR. With this one setting, a channel is fully configured +for binary input and output: Each byte read from the channel +becomes the Unicode character having the same value as that byte, and each +character written to the channel becomes a single byte in the output. This +makes it possible to work seamlessly with binary data as long as each character +in the data remains in the range of 0 to 255 so that there is no distinction +between binary data and text. For example, A JPEG image can be read from a +such a channel, manipulated, and then written back to such a channel. +.IP \fBcr\fR The end of a line is represented in the external data by a single carriage return character. For input, each carriage return is translated to a line feed, and for output each line feed character is translated to a carriage return. -.TP -\fBcrlf\fR -. +.IP \fBcrlf\fR The end of a line is represented in the external data by a carriage return character followed by a line feed. For input, each carriage-return-linefeed sequence is translated to a line feed. For output, each line feed is translated to a carriage-return-linefeed sequence. This translation is typically used for network connections, and also on Windows systems. -.TP -\fBlf\fR -. +.IP \fBlf\fR The end of a line in the external data is represented by a line feed so no translations occur during either input or output. This translation is typically used on UNIX platforms, .RE .RE +.\" METHOD: copy .TP \fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR? . -Copies data from \fIinputChan\fR to \fIoutputChan\fR, leveraging internal -buffers to avoid extra copies and to avoid buffering too much data in main -memory when copying large files to slow destinations like network sockets. +Reads characters from \fIinputChan\fR and writes them to \fIoutputChan\fR until +all characters are copied, blocking until the copy is complete and returning +the number of characters copied. Leverages internal buffers to avoid extra +copies and to avoid buffering too much data in main memory when copying large +files to slow destinations like network sockets. .RS .PP -If \fB\-size\fR is given, the size is in bytes if the two channels have the -same encoding and in characters otherwise, and only that amount is copied. -Otherwise, all data until the end of the file is copied. - -\fBchan copy\fR blocks until the copy is complete and returns the number of -bytes or characters written to \fIoutputChan\fR. -.PP -If \fB\-command\fR is given, \fBchan copy\fR returns immediately, the copy is -carried out in the background, and then \fIcallback\fR is called with the -number of bytes written to \fIoutputChan\fR as its first argument, and the -error message for any error that occurred as its second argument. -\fIinputChan\fR and \fIoutputChan\fR are automatically configured for -non-blocking mode if needed. Background copying only works correctly if the -event loop is active, e.g. via \fBvwait\fR or Tk. -.PP -During a background copy no other read or write operation may be performed on -\fIinputChan\fR or \fIoutputChan\fR. If either \fIinputChan\fR or -\fIoutputChan\fR is closed while the copy is in progress copying ceases and -\fBno\fR callback is made. If \fIinputChan\fR is closed all data already queued -is written to \fIoutputChan\fR. -.PP -The should be no event handler established for \fIinputChan\fR because it may -become readable during a background copy. An attempt to read or write -from within an event handler results result in the error, "channel busy". -.PP -Due to end-of-line translation the number of bytes read from \fIinputChan\fR -may be different than the number of bytes written to \fIoutputChan\fR. Only -the number of bytes written to \fIoutputChan\fR is reported. -.PP -\fBChan copy\fR reads the data according to the \fB\-encoding\fR, -\fB\-translation\fR, and \fB\-eofchar\fR of the source and writes to the -destination according to the configuration for that channel. If the encoding -and translation of both channels is \fBbinary\fR and the \fB\-eofchar\fR of -both channels is the empty string, an identical copy is made. If only the -encoding of the destination is \fBbinary\fR, Tcl's internal modified UTF-8 -representation of the characters read from the source is written to the -destination. If only the encoding of the source is \fBbinary\fR, each byte read -becomes one Unicode character in the range of 0 to 255, and that character is -subject to the encoding and translation of the destination as it is written. +\fB\-size\fR limits the number of characters copied. +.PP +If \fB\-command\fR is given, \fBchan copy\fR returns immediately, works in the +background, and calls \fIcallback\fR when the copy completes, providing as an +additional argument the number of characters written to \fIoutputChan\fR. If +an error occurs during the background copy, another argument provides message +for the error. \fIinputChan\fR and \fIoutputChan\fR are automatically +configured for non-blocking mode if needed. Background copying only works +correctly if events are being processed, e.g. via \fBvwait\fR or Tk. +.PP +During a background copy no other read operation may be performed on +\fIinputChan\fR, and no write operation may be performed on +\fIoutputChan\fR. However, write operations may by performed on +\fIinputChan\fR and read operations may be performed on \fIoutputChan\fR, as +exhibited by the bidirectional copy example below. +.PP +If either \fIinputChan\fR or \fIoutputChan\fR is closed while the copy is in +progress, copying ceases and \fBno\fR callback is made. If \fIinputChan\fR is +closed all data already queued is written to \fIoutputChan\fR. +.PP +There should be no event handler established for \fIinputChan\fR because it +may become readable during a background copy. An attempt to read or write from +within an event handler results result in the error, "channel busy". Any +wrong-sided I/O attempted (by a \fBchan event\fR handler or otherwise) results +in a +.QW "channel busy" +error. .RE +.\" METHOD: create .TP \fBchan create \fImode cmdPrefix\fR . @@ -329,11 +313,13 @@ is currently in or shared with. \fBchan create\fR is \fBsafe\fR and is accessible to safe interpreters. The handler is always called in the safe interpreter it was created in. .RE +.\" METHOD: eof .TP \fBchan eof \fIchannelName\fR . Returns 1 if the last read on the channel failed because the end of the data was already reached, and 0 otherwise. +.\" METHOD: event .TP \fBchan event \fIchannelName event\fR ?\fIscript\fR? . @@ -348,7 +334,6 @@ deleted when the channel is closed. If \fIscript\fR is omitted, either the existing script or the empty string is returned. The event loop must be entered, e.g. via \fBvwait\fR or \fBupdate\fR, or by using Tk, for handlers to be evaluated. - .RS .PP \fIscript\fR is evaluated at the global level in the interpreter it was @@ -356,7 +341,6 @@ established in. Any resulting error is handled in the background, i.e. via \fBinterp bgerror\fR. In order to prevent an endless loop due to a buggy handler, the handler is deleted if \fIscript\fR returns an error so that it is not evaluated again. - .PP Without an event handler, \fBchan gets\fR or \fBchan read\fR on a channel in blocking mode may block until data becomes available, become during which the @@ -391,12 +375,14 @@ thread can not do any other processing or service any other events. A channel in non-blocking mode allows a thread to carry on with other work and get back to the channel at the right time. .RE +.\" METHOD: flush .TP \fBchan flush \fIchannelName\fR . For a channel in blocking mode, flushes all buffered output to the destination, and then returns. For a channel in non-blocking mode, returns immediately while all buffered output is flushed in the background as soon as possible. +.\" METHOD: gets .TP \fBchan gets \fIchannelName\fR ?\fIvarName\fR? . @@ -418,11 +404,13 @@ indicate that the empty string means that the end of the data has been reached, and \fBchan blocked\fR may indicate that that the empty string means there isn't currently enough data do return the next line. .RE +.\" METHOD: names .TP \fBchan names\fR ?\fIpattern\fR? . Returns a list of all channel names, or if \fIpattern\fR is given, only those names that match according to the rules of \fBstring match\fR. +.\" METHOD: pending .TP \fBchan pending \fImode channelName\fR . @@ -436,8 +424,10 @@ event callback to impose limits on input line length to avoid a potential denial-of-service attack where an extremely long line exceeds the available memory to buffer it. Returns -1 if the channel was not opened for the mode in question. +.\" METHOD: pipe .TP \fBchan pipe\fR +. Creates a pipe, i.e. a readable channel and a writable channel, and returns the names of the readable channel and the writable channel. Data written to the writable channel can be read from the readable channel. Because the pipe is a @@ -467,12 +457,15 @@ issue, either put the channels into non-blocking mode and use event handlers, or place the read channel and the write channel in separate interpreters in separate threads. .RE +.\" METHOD: pop .TP \fBchan pop \fIchannelName\fR +. Removes the topmost transformation handler from the channel if there is one, and closes the channel otherwise. The result is normally the empty string, but may be an error in some situations, e.g. when closing the underlying resource results in an error. +.\" METHOD: postevent .TP \fBchan postevent \fIchannelName eventSpec\fR . @@ -498,13 +491,16 @@ It is an error to post an event that the channel has no interest in. See reflected channel would have been created, and will be evaluated in that interpreter as well. .RE +.\" METHOD: push .TP \fBchan push \fIchannelName cmdPrefix\fR +. Adds a new transformation handler on top of the channel and returns a handle for the transformation. \fIcmdPrefix\fR is the first words of a command that provides the interface documented for \fBtranschan\fR, and transforms data on the channel, It is an error if handler does not support the mode(s) the channel is in. +.\" METHOD: puts .TP \fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelName\fR? \fIstring\fR . @@ -534,6 +530,7 @@ non-blocking mode should normally be handled using \fBchan event\fR, where the application only invokes \fBchan puts\fR after being recently notified through a file event handler that the channel is ready for more output data. .RE +.\" METHOD: read .TP \fBchan read \fIchannelName\fR ?\fInumChars\fR? .TP @@ -564,6 +561,7 @@ possible to get a \fBreadable\fR event for each individual character. In blocking mode, \fBchan read\fR blocks forever when reading to the end of the data if there is no \fBchan configure -eofchar\fR configured for the channel. .RE +.\" METHOD: seek .TP \fBchan seek \fIchannelName offset\fR ?\fIorigin\fR? . @@ -572,18 +570,11 @@ bytes relative to \fIorigin\fR. A negative offset moves the current position backwards from the origin. \fIorigin\fR is one of the following: .RS -.PP -.TP 10 -\fBstart\fR -. +.IP \fBstart\fR The origin is the start of the data. This is the default. -.TP 10 -\fBcurrent\fR -. +.IP \fBcurrent\fR The origin is the current position. -.TP 10 -\fBend\fR -. +.IP \fBend\fR The origin is the end of the data. .PP \fBChan seek\fR flushes all buffered output even if the channel is in @@ -594,12 +585,14 @@ empty string or an error if the channel does not support seeking. read\fR, both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes, not characters, .RE +.\" METHOD: tell .TP \fBchan tell \fIchannelName\fR . Returns the offset in bytes of the current position in the underlying data, or --1 if the channel does not suport seeking. The value can be passed to \fBchan +-1 if the channel does not support seeking. The value can be passed to \fBchan seek\fR to set current position to that offset. +.\" METHOD: truncate .TP \fBchan truncate \fIchannelName\fR ?\fIlength\fR? . @@ -607,6 +600,7 @@ Flushes the channel and truncates the data in the channel to \fIlength\fR bytes, or to the current position in bytes if \fIlength\fR is omitted. . .SH EXAMPLES +.SS "SIMPLE CHANNEL OPERATION EXAMPLES" .PP In the following example a file is opened using the encoding CP1252, which is common on Windows, searches for a string, rewrites that part, and truncates the @@ -677,6 +671,90 @@ proc echoLine {chan clientName} { socket -server connect 12345 vwait forever .CE +.SS "CHANNEL COPY EXAMPLES" +.PP +The first example transfers the contents of one channel exactly to +another. Note that when copying one file to another, it is better to +use \fBfile copy\fR which also copies file metadata (e.g. the file +access permissions) where possible. +.PP +.CS +\fBchan configure\fR $in -translation binary +\fBchan configure\fR $out -translation binary +\fBchan copy\fR $in $out +.CE +.PP +This second example shows how the callback gets +passed the number of bytes transferred. +It also uses vwait to put the application into the event loop. +Of course, this simplified example could be done without the command +callback. +.PP +.CS +proc Cleanup {in out bytes {error {}}} { + global total + set total $bytes + \fBchan close\fR $in + \fBchan close\fR $out + if {$error ne ""} { + # error occurred during the copy + } +} + +set in [open $file1] +set out [socket $server $port] +\fBchan copy\fR $in $out -command [list Cleanup $in $out] +vwait total +.CE +.PP +The third example copies in chunks and tests for end of file +in the command callback. +.PP +.CS +proc CopyMore {in out chunk bytes {error {}}} { + global total done + incr total $bytes + if {($error ne "") || [\fBchan eof\fR $in]} { + set done $total + \fBchan close\fR $in + \fBchan close\fR $out + } else { + \fBchan copy\fR $in $out -size $chunk \e + -command [list CopyMore $in $out $chunk] + } +} + +set in [open $file1] +set out [socket $server $port] +set chunk 1024 +set total 0 +\fBchan copy\fR $in $out -size $chunk \e + -command [list CopyMore $in $out $chunk] +vwait done +.CE +.PP +The fourth example starts an asynchronous, bidirectional copy between +two sockets. Those could also be pipes from two bidirectional pipelines +(e.g., \fI[open "|hal 9000" r+]\fR); the conversation will remain +essentially secret to the script, since all four \fBchan event\fR slots +are busy, though any transforms that are \fBchan push\fRed on the +channels will be able to observe the passing traffic. +.PP +.CS +proc Done {dir args} { + global flows done + \fBchan puts\fR "$dir is over." + incr flows -1 + if {$flows <= 0} { + set done 1 + } +} + +set flows 2 +\fBchan copy\fR $sok1 $sok2 -command [list Done UP] +\fBchan copy\fR $sok2 $sok1 -command [list Done DOWN] +vwait done +.CE .SH "SEE ALSO" close(n), eof(n), fblocked(n), fconfigure(n), fcopy(n), file(n), fileevent(n), flush(n), gets(n), open(n), puts(n), read(n), seek(n), diff --git a/doc/class.n b/doc/class.n index c48f52d..1f4c774 100644 --- a/doc/class.n +++ b/doc/class.n @@ -48,6 +48,7 @@ The \fBoo::class\fR class does not define an explicit destructor. However, when a class is destroyed, all its subclasses and instances are also destroyed, along with all objects that it has been mixed into. .SS "EXPORTED METHODS" +.\" METHOD: create .TP \fIcls \fBcreate \fIname \fR?\fIarg ...\fR? . @@ -58,6 +59,7 @@ a successful result) returning the fully qualified name of the created object (the result of the constructor is ignored). If the constructor fails (i.e. returns a non-OK result) then the object is destroyed and the error message is the result of this method call. +.\" METHOD: new .TP \fIcls \fBnew \fR?\fIarg ...\fR? . @@ -75,6 +77,7 @@ classes should not be created using this method. .SS "NON-EXPORTED METHODS" .PP The \fBoo::class\fR class supports the following non-exported methods: +.\" METHOD: createWithNamespace .TP \fIcls \fBcreateWithNamespace\fI name nsName\fR ?\fIarg ...\fR? . diff --git a/doc/classvariable.n b/doc/classvariable.n index 70d9f13..198f09e 100644 --- a/doc/classvariable.n +++ b/doc/classvariable.n @@ -15,7 +15,7 @@ classvariable \- create link from local variable to variable in class .nf package require tcl::oo -\fBclassvariable\fR \fIvariableName\fR ?\fI...\fR? +\fBclassvariable\fI variableName\fR ?\fI...\fR? .fi .BE .SH DESCRIPTION @@ -26,8 +26,8 @@ elements. The originating scope for the variables is the namespace of the class that the method was defined by. In other words, the referenced variables are shared between all instances of that class. .PP -Note: This command is equivalent to the command \fBtypevariable\fR provided by -the snit package in tcllib for approximately the same purpose. If used in a +Note that this command is equivalent to the command \fBtypevariable\fR provided +by the snit package in tcllib for approximately the same purpose. If used in a method defined directly on a class instance (e.g., through the \fBoo::objdefine\fR \fBmethod\fR definition) this is very much like just using: diff --git a/doc/clock.n b/doc/clock.n index 5157ed1..871a942 100644 --- a/doc/clock.n +++ b/doc/clock.n @@ -8,38 +8,38 @@ .SH NAME clock \- Obtain and manipulate dates and times .SH "SYNOPSIS" +.nf package require \fBTcl 8.5-\fR -.sp -\fBclock add\fR \fItimeVal\fR ?\fIcount unit...\fR? ?\fI\-option value\fR? -.sp + +\fBclock add\fI timeVal\fR ?\fIcount unit...\fR? ?\fI\-option value\fR? \fBclock clicks\fR ?\fI\-option\fR? -.sp -\fBclock format\fR \fItimeVal\fR ?\fI\-option value\fR...? -.sp +\fBclock format\fI timeVal\fR ?\fI\-option value\fR...? \fBclock microseconds\fR -.sp \fBclock milliseconds\fR -.sp -\fBclock scan\fR \fIinputString\fR ?\fI\-option value\fR...? -.sp +\fBclock scan\fI inputString\fR ?\fI\-option value\fR...? \fBclock seconds\fR -.sp +.fi .BE .SH "DESCRIPTION" .PP The \fBclock\fR command performs several operations that obtain and manipulate values that represent times. The command supports several subcommands that determine what action is carried out by the command. +.\" METHOD: add .TP -\fBclock add\fR \fItimeVal\fR ?\fIcount unit...\fR? ?\fI\-option value\fR? +\fBclock add\fI timeVal\fR ?\fIcount unit...\fR? ?\fI\-option value\fR? +. Adds a (possibly negative) offset to a time that is expressed as an integer number of seconds. See \fBCLOCK ARITHMETIC\fR for a full description. +.\" METHOD: clicks .TP \fBclock clicks\fR ?\fI\-option\fR? +. If no \fI\-option\fR argument is supplied, returns a high-resolution time value as a system-dependent integer value. The unit of the value is system-dependent but should be the highest resolution clock available -on the system such as a CPU cycle counter. See \fBHIGH RESOLUTION TIMERS\fR for a full description. +on the system such as a CPU cycle counter. +See \fBHIGH RESOLUTION TIMERS\fR for a full description. .RS .PP If the \fI\-option\fR argument is \fB\-milliseconds\fR, then the command @@ -52,32 +52,46 @@ is synonymous with \fBclock microseconds\fR (see below). This usage is obsolete, and \fBclock microseconds\fR is to be considered the preferred way of obtaining a count of microseconds. .RE +.\" METHOD: format .TP -\fBclock format\fR \fItimeVal\fR ?\fI\-option value\fR...? +\fBclock format\fI timeVal\fR ?\fI\-option value\fR...? +. Formats a time that is expressed as an integer number of seconds into a format intended for consumption by users or external programs. See \fBFORMATTING TIMES\fR for a full description. +.\" METHOD: microseconds .TP \fBclock microseconds\fR -Returns the current time as an integer number of microseconds. See \fBHIGH RESOLUTION TIMERS\fR for a full description. +. +Returns the current time as an integer number of microseconds. +See \fBHIGH RESOLUTION TIMERS\fR for a full description. +.\" METHOD: milliseconds .TP \fBclock milliseconds\fR -Returns the current time as an integer number of milliseconds. See \fBHIGH RESOLUTION TIMERS\fR for a full description. +. +Returns the current time as an integer number of milliseconds. +See \fBHIGH RESOLUTION TIMERS\fR for a full description. +.\" METHOD: scan .TP -\fBclock scan\fR \fIinputString\fR ?\fI\-option value\fR...? +\fBclock scan\fI inputString\fR ?\fI\-option value\fR...? +. Scans a time that is expressed as a character string and produces an integer number of seconds. See \fBSCANNING TIMES\fR for a full description. +.\" METHOD: seconds .TP \fBclock seconds\fR +. Returns the current time as an integer number of seconds. .SS "PARAMETERS" .TP \fIcount\fR +. An integer representing a count of some unit of time. See \fBCLOCK ARITHMETIC\fR for the details. .TP \fItimeVal\fR +. An integer value passed to the \fBclock\fR command that represents an absolute time as a number of seconds from the \fIepoch time\fR of 1 January 1970, 00:00 UTC. Note that the count of seconds does not @@ -88,18 +102,23 @@ back in sync with UTC; its data model does not represent minutes that have 59 or 61 seconds. .TP \fIunit\fR +. One of the words, \fBseconds\fR, \fBminutes\fR, \fBhours\fR, \fBdays\fR, \fBweekdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR. Used in conjunction with \fIcount\fR to identify an interval of time, for example, \fI3 seconds\fR or \fI1 year\fR. .SS "OPTIONS" +.\" OPTION: -base .TP \fB\-base\fR time +. Specifies that any relative times present in a \fBclock scan\fR command are to be given relative to \fItime\fR. \fItime\fR must be expressed as a count of nominal seconds from the epoch time of 1 January 1970, 00:00 UTC. +.\" OPTION: -format .TP \fB\-format\fR format +. Specifies the desired output format for \fBclock format\fR or the expected input format for \fBclock scan\fR. The \fIformat\fR string consists of any number of characters other than the per-cent sign @@ -119,17 +138,21 @@ On \fBclock scan\fR, the lack of a \fB\-format\fR option indicates that a .QW "free format scan" is requested; see \fBFREE FORM SCAN\fR for a description of what happens. .RE +.\" OPTION: -gmt .TP \fB\-gmt\fR boolean +. If \fIboolean\fR is true, specifies that a time specified to \fBclock add\fR, \fBclock format\fR or \fBclock scan\fR should be processed in UTC. If \fIboolean\fR is false, the processing defaults to the local time zone. This usage is obsolete; the correct current usage is to specify the UTC time zone with -.QW "\fB\-timezone\fR \fI:UTC\fR" +.QW "\fB\-timezone\fI :UTC\fR" or any of the equivalent ways to specify it. +.\" OPTION: -locale .TP \fB\-locale\fR localeName +. Specifies that locale-dependent scanning and formatting (and date arithmetic for dates preceding the adoption of the Gregorian calendar) is to be done in the locale identified by \fIlocaleName\fR. The locale name may be any of @@ -143,8 +166,10 @@ descriptions of the individual format groups under \fBFORMAT GROUPS\fR. The effect of locale on clock arithmetic is discussed under \fBCLOCK ARITHMETIC\fR. .RE +.\" OPTION: -timezone .TP \fB\-timezone\fR zoneName +. Specifies that clock arithmetic, formatting, and scanning are to be done according to the rules for the time zone specified by \fIzoneName\fR. The permissible values, and their interpretation, are discussed under @@ -310,9 +335,9 @@ and their interpretation, are described under \fBFORMAT GROUPS\fR. If a \fB\-timezone\fR option is present, the following argument is a string that specifies the time zone in which the date and time are to be formatted. As an alternative to -.QW "\fB\-timezone\fR \fI:UTC\fR" , +.QW "\fB\-timezone\fI :UTC\fR" , the obsolete usage -.QW "\fB\-gmt\fR \fItrue\fR" +.QW "\fB\-gmt\fI true\fR" may be used. See \fBTIME ZONES\fR for the permissible variants for the time zone. .PP @@ -321,14 +346,14 @@ a string that specifies the locale in which the time is to be formatted, in the same format that is used for the \fBmsgcat\fR package. Note that the default, if \fB\-locale\fR is not specified, is the root locale \fB{}\fR rather than the current locale. The current locale may -be obtained by using \fB\-locale\fR \fBcurrent\fR. +be obtained by using \fB\-locale current\fR. In addition, some platforms support a \fBsystem\fR locale that reflects the user's current choices. For instance, on Windows, the format that the user has selected from dates and times in the Control Panel can be obtained by using the \fBsystem\fR locale. On platforms that do not define a user selection of date and time formats -separate from \fBLC_TIME\fR, \fB\-locale\fR \fBsystem\fR is -synonymous with \fB\-locale\fR \fBcurrent\fR. +separate from \fBLC_TIME\fR, \fB\-locale system\fR is +synonymous with \fB\-locale current\fR. .SH "SCANNING TIMES" .PP The \fBclock scan\fR command accepts times that are formatted as @@ -346,8 +371,8 @@ and their interpretation, are described under \fBFORMAT GROUPS\fR. .PP If a \fB\-timezone\fR option is present, the following argument is a string that specifies the time zone in which the date and time -are to be interpreted. As an alternative to \fB\-timezone\fR \fI:UTC\fR, -the obsolete usage \fB\-gmt\fR \fItrue\fR may be used. See +are to be interpreted. As an alternative to \fB\-timezone\fI :UTC\fR, +the obsolete usage \fB\-gmt\fI true\fR may be used. See \fBTIME ZONES\fR for the permissible variants for the time zone. .PP If a \fB\-locale\fR option is present, the following argument is @@ -355,14 +380,14 @@ a string that specifies the locale in which the time is to be interpreted, in the same format that is used for the \fBmsgcat\fR package. Note that the default, if \fB\-locale\fR is not specified, is the root locale \fB{}\fR rather than the current locale. The current locale may -be obtained by using \fB\-locale\fR \fBcurrent\fR. +be obtained by using \fB\-locale current\fR. In addition, some platforms support a \fBsystem\fR locale that reflects the user's current choices. For instance, on Windows, the format that the user has selected from dates and times in the Control Panel can be obtained by using the \fBsystem\fR locale. On platforms that do not define a user selection of date and time formats -separate from \fBLC_TIME\fR, \fB\-locale\fR \fBsystem\fR is -synonymous with \fB\-locale\fR \fBcurrent\fR. +separate from \fBLC_TIME\fR, \fB\-locale system\fR is +synonymous with \fB\-locale current\fR. .PP If a \fB\-base\fR option is present, the following argument is a time (expressed in seconds from the epoch time) that is used as @@ -469,69 +494,57 @@ if the clock had not changed. .PP The following format groups are recognized by the \fBclock scan\fR and \fBclock format\fR commands. -.TP -\fB%a\fR -On output, produces an abbreviation (\fIe.g.,\fR \fBMon\fR) for the day +.IP \fB%a\fR +On output, produces an abbreviation (\fIe.g., \fBMon\fR) for the day of the week in the given locale. On input, matches the name of the day of the week in the given locale (in either abbreviated or full form, or any unique prefix of either form). -.TP -\fB%A\fR -On output, produces the full name (\fIe.g.,\fR \fBMonday\fR) of the day +.IP \fB%A\fR +On output, produces the full name (\fIe.g., \fBMonday\fR) of the day of the week in the given locale. On input, matches the name of the day of the week in the given locale (in either abbreviated or full form, or any unique prefix of either form). -.TP -\fB%b\fR -On output, produces an abbreviation (\fIe.g.,\fR \fBJan\fR) for the name +.IP \fB%b\fR +On output, produces an abbreviation (\fIe.g., \fBJan\fR) for the name of the month in the given locale. On input, matches the name of the month in the given locale (in either abbreviated or full form, or any unique prefix of either form). -.TP -\fB%B\fR -On output, produces the full name (\fIe.g.,\fR \fBJanuary\fR) +.IP \fB%B\fR +On output, produces the full name (\fIe.g., \fBJanuary\fR) of the month in the given locale. On input, matches the name of the month in the given locale (in either abbreviated or full form, or any unique prefix of either form). -.TP -\fB%c\fR +.IP \fB%c\fR On output, produces a localized representation of date and time of day; the localized representation is expected to use the Gregorian calendar. On input, matches whatever \fB%c\fR produces. -.TP -\fB%C\fR +.IP \fB%C\fR On output, produces the number of the century in Indo-Arabic numerals. On input, matches one or two digits, possibly with leading whitespace, that are expected to be the number of the century. -.TP -\fB%d\fR +.IP \fB%d\fR On output, produces the number of the day of the month, as two decimal digits. On input, matches one or two digits, possibly with leading whitespace, that are expected to be the number of the day of the month. -.TP -\fB%D\fR +.IP \fB%D\fR This format group is synonymous with \fB%m/%d/%Y\fR. It should be used only in exchanging data within the \fBen_US\fR locale, since other locales typically do not use this order for the fields of the date. -.TP -\fB%e\fR +.IP \fB%e\fR On output, produces the number of the day of the month, as one or two decimal digits (with a leading blank for one-digit dates). On input, matches one or two digits, possibly with leading whitespace, that are expected to be the number of the day of the month. -.TP -\fB%Ec\fR +.IP \fB%Ec\fR On output, produces a locale-dependent representation of the date and time of day in the locale's alternative calendar. On input, matches whatever \fB%Ec\fR produces. The locale's alternative calendar need not be the Gregorian calendar. -.TP -\fB%EC\fR +.IP \fB%EC\fR On output, produces a locale-dependent name of an era in the locale's alternative calendar. On input, matches the name of the era or any unique prefix. -.TP -\fB%EE\fR +.IP \fB%EE\fR On output, produces the string \fBB.C.E.\fR or \fBC.E.\fR, or a string of the same meaning in the locale, to indicate whether \fB%Y\fR refers to years before or after Year 1 of the Common Era. On input, accepts @@ -539,204 +552,168 @@ the string \fBB.C.E.\fR, \fBB.C.\fR, \fBC.E.\fR, \fBA.D.\fR, or the abbreviation appropriate to the current locale, and uses it to fix whether \fB%Y\fR refers to years before or after Year 1 of the Common Era. -.TP -\fB%Ex\fR +.IP \fB%Ex\fR On output, produces a locale-dependent representation of the date in the locale's alternative calendar. On input, matches whatever \fB%Ex\fR produces. The locale's alternative calendar need not be the Gregorian calendar. -.TP -\fB%EX\fR +.IP \fB%EX\fR On output, produces a locale-dependent representation of the time of day in the locale's alternative numerals. On input, matches whatever \fB%EX\fR produces. -.TP -\fB%Ey\fR +.IP \fB%Ey\fR On output, produces a locale-dependent number of the year of the era in the locale's alternative calendar and numerals. On input, matches such a number. -.TP -\fB%EY\fR +.IP \fB%EY\fR On output, produces a representation of the year in the locale's alternative calendar and numerals. On input, matches what \fB%EY\fR produces. Often synonymous with \fB%EC%Ey\fR. -.TP -\fB%g\fR +.IP \fB%g\fR On output, produces a two-digit year number suitable for use with the week-based ISO8601 calendar; that is, the year number corresponds to the week number produced by \fB%V\fR. On input, accepts such a two-digit year number, possibly with leading whitespace. -.TP -\fB%G\fR +.IP \fB%G\fR On output, produces a four-digit year number suitable for use with the week-based ISO8601 calendar; that is, the year number corresponds to the week number produced by \fB%V\fR. On input, accepts such a four-digit year number, possibly with leading whitespace. -.TP -\fB%h\fR +.IP \fB%h\fR This format group is synonymous with \fB%b\fR. -.TP -\fB%H\fR +.IP \fB%H\fR On output, produces a two-digit number giving the hour of the day (00-23) on a 24-hour clock. On input, accepts such a number. -.TP -\fB%I\fR +.IP \fB%I\fR On output, produces a two-digit number giving the hour of the day (12-11) on a 12-hour clock. On input, accepts such a number. -.TP -\fB%j\fR +.IP \fB%j\fR On output, produces a three-digit number giving the day of the year (001-366). On input, accepts such a number. -.TP -\fB%J\fR +.IP \fB%J\fR On output, produces a string of digits giving the Julian Day Number. On input, accepts a string of digits and interprets it as a Julian Day Number. The Julian Day Number is a count of the number of calendar days that have elapsed since 1 January, 4713 BCE of the proleptic Julian calendar. The epoch time of 1 January 1970 corresponds to Julian Day Number 2440588. -.TP -\fB%k\fR +.IP \fB%k\fR On output, produces a one- or two-digit number giving the hour of the day (0-23) on a 24-hour clock. On input, accepts such a number. -.TP -\fB%l\fR +.IP \fB%l\fR On output, produces a one- or two-digit number giving the hour of the day (12-11) on a 12-hour clock. On input, accepts such a number. -.TP -\fB%m\fR +.IP \fB%m\fR On output, produces the number of the month (01-12) with exactly two digits. On input, accepts two digits and interprets them as the number of the month. -.TP -\fB%M\fR +.IP \fB%M\fR On output, produces the number of the minute of the hour (00-59) with exactly two digits. On input, accepts two digits and interprets them as the number of the minute of the hour. -.TP -\fB%N\fR +.IP \fB%N\fR On output, produces the number of the month (1-12) with one or two digits, and a leading blank for one-digit dates. On input, accepts one or two digits, possibly with leading whitespace, and interprets them as the number of the month. -.TP -\fB%Od\fR, \fB%Oe\fR, \fB%OH\fR, \fB%OI\fR, \fB%Ok\fR, \fB%Ol\fR, \fB%Om\fR, \fB%OM\fR, \fB%OS\fR, \fB%Ou\fR, \fB%Ow\fR, \fB%Oy\fR +.IP "\fB%Od\fR, \fB%Oe\fR, \fB%OH\fR, \fB%OI\fR, \fB%Ok\fR, \fB%Ol\fR, \fB%Om\fR, \fB%OM\fR, \fB%OS\fR, \fB%Ou\fR, \fB%Ow\fR, \fB%Oy\fR" All of these format groups are synonymous with their counterparts without the .QW \fBO\fR , except that the string is produced and parsed in the locale-dependent alternative numerals. -.TP -\fB%p\fR +.IP \fB%p\fR On output, produces an indicator for the part of the day, \fBAM\fR or \fBPM\fR, appropriate to the given locale. If the script of the given locale supports multiple letterforms, lowercase is preferred. On input, matches the representation \fBAM\fR or \fBPM\fR in the given locale, in either case. -.TP -\fB%P\fR +.IP \fB%P\fR On output, produces an indicator for the part of the day, \fBam\fR or \fBpm\fR, appropriate to the given locale. If the script of the given locale supports multiple letterforms, uppercase is preferred. On input, matches the representation \fBAM\fR or \fBPM\fR in the given locale, in either case. -.TP -\fB%Q\fR +.IP \fB%Q\fR This format group is reserved for internal use within the Tcl library. -.TP -\fB%r\fR +.\" It's the STARDATE! We're so Enterprise-ready... +.IP \fB%r\fR On output, produces a locale-dependent time of day representation on a 12-hour clock. On input, accepts whatever \fB%r\fR produces. -.TP -\fB%R\fR +.IP \fB%R\fR On output, the time in 24-hour notation (%H:%M). For a version including the seconds, see \fB%T\fR below. On input, accepts whatever \fB%R\fR produces. -.TP -\fB%s\fR +.IP \fB%s\fR On output, simply formats the \fItimeVal\fR argument as a decimal integer and inserts it into the output string. On input, accepts a decimal integer and uses is as the time value without any further processing. Since \fB%s\fR uniquely determines a point in time, it overrides all other input formats. -.TP -\fB%S\fR +.IP \fB%S\fR On output, produces a two-digit number of the second of the minute (00-59). On input, accepts two digits and uses them as the second of the minute. -.TP -\fB%t\fR +.IP \fB%t\fR On output, produces a TAB character. On input, matches a TAB character. -.TP -\fB%T\fR +.IP \fB%T\fR Synonymous with \fB%H:%M:%S\fR. -.TP -\fB%u\fR +.IP \fB%u\fR On output, produces the number of the day of the week (\fB1\fR\(->Monday, \fB7\fR\(->Sunday). On input, accepts a single digit and interprets it as the day of the week. Sunday may be either \fB0\fR or \fB7\fR. -.TP -\fB%U\fR +.IP \fB%U\fR On output, produces the ordinal number of the week of the year (00-53). The first Sunday of the year is the first day of week 01. On input accepts two digits which are otherwise ignored. This format group is never used in determining an input date. This interpretation of the week of the year was once common in US banking but is now largely obsolete. See \fB%V\fR for the ISO8601 week number. -.TP -\fB%V\fR +.IP \fB%V\fR On output, produces the number of the ISO8601 week as a two digit number (01-53). Week 01 is the week containing January 4; or the first week of the year containing at least 4 days; or the week containing the first Thursday of the year (the three statements are equivalent). Each week begins on a Monday. On input, accepts the ISO8601 week number. -.TP -\fB%w\fR +.IP \fB%w\fR On output, produces the ordinal number of the day of the week (Sunday==0; Saturday==6). On input, accepts a single digit and interprets it as the day of the week; Sunday may be represented as either 0 or 7. Note that \fB%w\fR is not the ISO8601 weekday number, which is produced and accepted by \fB%u\fR. -.TP -\fB%W\fR +.IP \fB%W\fR On output, produces a week number (00-53) within the year; week 01 begins on the first Monday of the year. On input, accepts two digits, which are otherwise ignored. This format group is never used in determining an input date. It is not the ISO8601 week number; that week is produced and accepted by \fB%V\fR. -.TP -\fB%x\fR +.IP \fB%x\fR On output, produces the date in a locale-dependent representation. On input, accepts whatever \fB%x\fR produces and is used to determine calendar date. -.TP -\fB%X\fR +.IP \fB%X\fR On output, produces the time of day in a locale-dependent representation. On input, accepts whatever \fB%X\fR produces and is used to determine time of day. -.TP -\fB%y\fR +.IP \fB%y\fR On output, produces the two-digit year of the century. On input, accepts two digits, and is used to determine calendar date. The date is presumed to lie between 1938 and 2037 inclusive. Note that \fB%y\fR does not yield a year appropriate for use with the ISO8601 week number \fB%V\fR; programs should use \fB%g\fR for that purpose. -.TP -\fB%Y\fR +.IP \fB%Y\fR On output, produces the four-digit calendar year. On input, accepts four digits and may be used to determine calendar date. Note that \fB%Y\fR does not yield a year appropriate for use with the ISO8601 week number \fB%V\fR; programs should use \fB%G\fR for that purpose. -.TP -\fB%z\fR +.IP \fB%z\fR On output, produces the current time zone, expressed in hours and minutes east (+hhmm) or west (\-hhmm) of Greenwich. On input, accepts a time zone specifier (see \fBTIME ZONES\fR below) that will be used to determine the time zone. -.TP -\fB%Z\fR +.IP \fB%Z\fR On output, produces the current time zone's name, possibly translated to the given locale. On input, accepts a time zone specifier (see \fBTIME ZONES\fR below) that will be used to determine the @@ -745,15 +722,13 @@ parsing RFC822 dates. Other uses are fraught with ambiguity; for instance, the string \fBBST\fR may represent British Summer Time or Brazilian Standard Time. It is recommended that date/time strings for use by computers use numeric time zones instead. -.TP -\fB%%\fR +.IP \fB%%\fR On output, produces a literal .QW \fB%\fR character. On input, matches a literal .QW \fB%\fR character. -.TP -\fB%+\fR +.IP \fB%+\fR Synonymous with .QW "\fB%a %b %e %H:%M:%S %Z %Y\fR" . .SH "TIME ZONES" @@ -766,7 +741,7 @@ A time zone specified inside a string being parsed and matched by a \fB%z\fR or \fB%Z\fR format group. .IP [2] A time zone specified with the \fB\-timezone\fR option to the \fBclock\fR -command (or, equivalently, by \fB\-gmt\fR \fB1\fR). +command (or, equivalently, by \fB\-gmt 1\fR). .IP [3] A time zone specified in an environment variable \fBTCL_TZ\fR. .IP [4] @@ -852,8 +827,9 @@ specification. .SH "FREE FORM SCAN" .PP If the \fBclock scan\fR command is invoked without a \fB\-format\fR -option, then it requests a \fIfree-form scan.\fR \fI -This form of scan is deprecated.\fR The reason for the deprecation +option, then it requests a \fIfree-form scan\fR. +\fIThis form of scan is deprecated.\fR +The reason for the deprecation is that there are too many ambiguities. (Does the string .QW 2000 represent a year, a time of day, or a quantity?) No set of rules @@ -904,7 +880,7 @@ acceptable formats are .QW "\fIdd monthname yy\fR" , .QW "?\fICC\fR?\fIyymmdd\fR" , and -.QW "\fIdd\fB-\fImonthname\fB-\fR?\fICC\fR?\fIyy\fR" . +.QW "\fIdd\fB\-\fImonthname\fB\-\fR?\fICC\fR?\fIyy\fR" . The default year is the current year. If the year is less than 100, we treat the years 00-68 as 2000-2068 and the years 69-99 as 1969-1999. Not all platforms can represent the years 38-70, so diff --git a/doc/concat.n b/doc/concat.n index d10f092..c83d2c4 100644 --- a/doc/concat.n +++ b/doc/concat.n @@ -28,7 +28,7 @@ Although \fBconcat\fR will concatenate lists, flattening them in the process (so giving the following interactive session): .PP .CS -\fI%\fR \fBconcat\fR a b {c d e} {f {g h}} +\fI% \fBconcat\fR a b {c d e} {f {g h}} \fIa b c d e f {g h}\fR .CE .PP @@ -36,7 +36,7 @@ it will also concatenate things that are not lists, as can be seen from this session: .PP .CS -\fI%\fR \fBconcat\fR " a b {c " d " e} f" +\fI% \fBconcat\fR " a b {c " d " e} f" \fIa b {c d e} f\fR .CE .PP @@ -44,14 +44,22 @@ Note also that the concatenation does not remove spaces from the middle of values, as can be seen here: .PP .CS -\fI%\fR \fBconcat\fR "a b c" { d e f } +\fI% \fBconcat\fR "a b c" { d e f } \fIa b c d e f\fR .CE .PP (i.e., there are three spaces between each of the \fBa\fR, the \fBb\fR and the \fBc\fR). +.PP +For \fItrue\fR list concatenation, the \fBlist\fR command should be used with +expansion of each input list: +.PP +.CS +\fI% \fRlist {*}"a b c" {*}{ d e f } +\fIa b c d e f\fR +.CE .SH "SEE ALSO" -append(n), eval(n), join(n) +append(n), eval(n), join(n), list(n) .SH KEYWORDS concatenate, join, list '\" Local Variables: diff --git a/doc/configurable.n b/doc/configurable.n index 0102f8c..7ab5b92 100644 --- a/doc/configurable.n +++ b/doc/configurable.n @@ -25,8 +25,8 @@ package require TclOO \fB}\fR \fIobjectName \fBconfigure\fR -\fIobjectName \fBconfigure\fR \fI\-prop\fR -\fIobjectName \fBconfigure\fR \fI\-prop value\fR ?\fI\-prop value\fR... +\fIobjectName \fBconfigure\fI \-prop\fR +\fIobjectName \fBconfigure\fI \-prop value\fR ?\fI\-prop value\fR... .fi .SH "CLASS HIERARCHY" .nf @@ -54,6 +54,7 @@ definition command available in definition scripts for the class and instances \fBoo::objdefine\fR) and making a \fBconfigure\fR method available within the instances. .SS "CONFIGURE METHOD" +.\" METHOD: configure .PP The behavior of the \fBconfigure\fR method is modelled after the \fBfconfigure\fR/\fBchan configure\fR command. @@ -74,6 +75,7 @@ method fails, the preceding pairs (if any) will continue to have been applied, and the succeeding pairs (if any) will be not applied. On success, the result of the \fBconfigure\fR method in this mode operation will be an empty string. .SS "PROPERTY DEFINITIONS" +.\" COMMAND: property .PP When a class has been manufactured by the \fBoo::configurable\fR metaclass (or one of its subclasses), it gains an extra definition, \fBproperty\fR. The @@ -84,6 +86,7 @@ The \fBproperty\fR command takes the name of a property to define first, \fIwithout a leading hyphen\fR, followed by a number of option-value pairs that modify the basic behavior of the property. This can then be followed by an arbitrary number of other property definitions. The supported options are: +.\" OPTION: -get .TP \fB\-get \fIgetterScript\fR . @@ -97,6 +100,7 @@ of the instance variable with the same name as the property (e.g., will result in a method .QW <ReadProp-xyz> being created). +.\" OPTION: -kind .TP \fB\-kind \fIpropertyKind\fR . @@ -112,6 +116,7 @@ Note that write-only properties are not particularly discoverable as they are never reported by the \fBconfigure\fR method other than by error messages when attempting to write to a property that does not exist. .RE +.\" OPTION: -set .TP \fB\-set \fIsetterScript\fR . @@ -143,11 +148,13 @@ The configurable class system is comprised of several pieces. The definition namespaces during object creation that provide the other bits and pieces of machinery. The key pieces of the implementation are enumerated here so that they can be used by other code: +.\" COMMAND: configurable .TP \fBoo::configuresupport::configurable\fR . This is a class that provides the implementation of the \fBconfigure\fR method (described above in \fBCONFIGURE METHOD\fR). +.\" NAMESPACE: configurableclass .TP \fBoo::configuresupport::configurableclass\fR . @@ -156,6 +163,7 @@ This is a namespace that contains the definition dialect that provides the class constructors under normal circumstances), as described above in \fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its \fBproperty\fR command so that it may be used easily in user definition dialects. +.\" NAMESPACE: configurableobject .TP \fBoo::configuresupport::configurableobject\fR . @@ -173,24 +181,28 @@ slots mean other than that they have unique names, no important order, can be inherited and discovered on classes and instances. .PP These slots, and their intended semantics, are: +.\" METHOD: readableproperties .TP \fBoo::configuresupport::readableproperties\fR . The set of properties of a class (not including those from its superclasses) that may be read from when configuring an instance of the class. This slot can also be read with the \fBinfo class properties\fR command. +.\" METHOD: writableproperties .TP \fBoo::configuresupport::writableproperties\fR . The set of properties of a class (not including those from its superclasses) that may be written to when configuring an instance of the class. This slot can also be read with the \fBinfo class properties\fR command. +.\" METHOD: objreadableproperties .TP \fBoo::configuresupport::objreadableproperties\fR . The set of properties of an object instance (not including those from its classes) that may be read from when configuring the object. This slot can also be read with the \fBinfo object properties\fR command. +.\" METHOD: objwritableproperties .TP \fBoo::configuresupport::objwritableproperties\fR . diff --git a/doc/const.n b/doc/const.n new file mode 100644 index 0000000..9bc77ba --- /dev/null +++ b/doc/const.n @@ -0,0 +1,85 @@ +'\" +'\" Copyright (c) 2023 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH const n 9.0 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +const \- create and initialize a constant +.SH SYNOPSIS +\fBconst \fIvarName value\fR +.BE +.SH DESCRIPTION +.PP +This command is normally used within a procedure body (or method body, +or lambda term) to create a constant within that procedure, or within a +\fBnamespace eval\fR body to create a constant within that namespace. +The constant is an unmodifiable variable, called \fIvarName\fR, that is +initialized with \fIvalue\fR. +The result of \fBconst\fR is always the empty string on success. +.PP +If a variable \fIvarName\fR does not exist, it is created with its value set +to \fIvalue\fR and marked as a constant; this means that no other command +(e.g., \fBset\fR, \fBappend\fR, \fBincr\fR, \fBunset\fR) +may modify or remove the variable; variables are checked for whether they +are constants before any traces are called. +If a variable \fIvarName\fR already exists, it is an error unless that +variable is marked as a constant (in which case \fBconst\fR is a no-op). +.PP +The \fIvarName\fR may not be a qualified name or reference an element of an +array by any means. If the variable exists and is an array, that is an error. +.PP +Constants are normally only removed by their containing procedure exiting or +their namespace being deleted. +.SH EXAMPLES +.PP +Create a constant in a procedure: +.PP +.CS +proc foo {a b} { + \fBconst\fR BAR 12345 + return [expr {$a + $b + $BAR}] +} +.CE +.PP +Create a constant in a namespace to factor out a regular expression: +.PP +.CS +namespace eval someNS { + \fBconst\fR FOO_MATCHER {(?i)}\emfoo\eM} + + proc findFoos str { + variable FOO_MATCHER + regexp -all $FOO_MATCHER $str + } + + proc findFooIndices str { + variable FOO_MATCHER + regexp -all -indices $FOO_MATCHER $str + } +} +.CE +.PP +Making a constant in a loop doesn't error: +.PP +.CS +proc foo {n} { + set result {} + for {set i 0} {$i < $n} {incr i} { + \fBconst\fR X 123 + lappend result [expr {$X + $i**2}] + } +} +.CE +.SH "SEE ALSO" +proc(n), namespace(n), set(n), unset(n) +.SH KEYWORDS +namespace, procedure, variable, constant +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/cookiejar.n b/doc/cookiejar.n index 7d2f46b..7d8e99e 100644 --- a/doc/cookiejar.n +++ b/doc/cookiejar.n @@ -15,13 +15,13 @@ cookiejar \- Implementation of the Tcl http package cookie jar protocol \fBpackage require\fR \fBcookiejar\fR ?\fB0.1\fR? \fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR? -\fB::http::cookiejar create\fR \fIname\fR ?\fIfilename\fR? +\fB::http::cookiejar create\fI name\fR ?\fIfilename\fR? \fB::http::cookiejar new\fR ?\fIfilename\fR? \fIcookiejar\fR \fBdestroy\fR \fIcookiejar\fR \fBforceLoadDomainData\fR -\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR -\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR +\fIcookiejar\fR \fBgetCookies\fI protocol host path\fR +\fIcookiejar\fR \fBstoreCookie\fI options\fR \fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR? .fi .SH DESCRIPTION @@ -33,6 +33,7 @@ create a cookie jar that manages a particular HTTP session. .PP The database management policy can be controlled at the package level by the \fBconfigure\fR method on the \fB::http::cookiejar\fR class object: +.\" METHOD: configure .TP \fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR? . @@ -44,6 +45,7 @@ to be the given value. .RS .PP Supported options are: +.\" OPTION: -domainfile .TP \fB\-domainfile \fIfilename\fR . @@ -53,6 +55,7 @@ list of top-level domains (e.g., \fB.com\fR or \fB.co.jp\fR). Such domains domains is both security-sensitive and \fInot\fR constant and should be periodically refetched. Cookie jars maintain their own cache of the domain list. +.\" OPTION: -domainlist .TP \fB\-domainlist \fIurl\fR . @@ -61,33 +64,39 @@ A URL to fetch the list of top-level domains (e.g., \fB.com\fR or them. Note that the list of such domains is both security-sensitive and \fInot\fR constant and should be periodically refetched. Cookie jars maintain their own cache of the domain list. +.\" OPTION: -domainrefresh .TP \fB\-domainrefresh \fIintervalMilliseconds\fR . -The number of milliseconds between checks of the \fI\-domainlist\fR for new +The number of milliseconds between checks of the \fB\-domainlist\fR for new domains. +.\" OPTION: -loglevel .TP \fB\-loglevel \fIlevel\fR . The logging level of this package. The logging level must be (in order of decreasing verbosity) one of \fBdebug\fR, \fBinfo\fR, \fBwarn\fR, or \fBerror\fR. +.\" OPTION: -offline .TP \fB\-offline \fIflag\fR . -Allows the cookie managment engine to be placed into offline mode. In offline +Allows the cookie management engine to be placed into offline mode. In offline mode, the list of domains is read immediately from the file configured in the \fB\-domainfile\fR option, and the \fB\-domainlist\fR option is not used; it also makes the \fB\-domainrefresh\fR option be effectively ignored. +.\" OPTION: -purgeold .TP \fB\-purgeold \fIintervalMilliseconds\fR . The number of milliseconds between checks of the database for expired cookies; expired cookies are deleted. +.\" OPTION: -retain .TP \fB\-retain \fIcookieCount\fR . The maximum number of cookies to retain in the database. +.\" OPTION: -vacuumtrigger .TP \fB\-vacuumtrigger \fIdeletionCount\fR . @@ -97,38 +106,43 @@ the database. .PP Cookie jar instances may be made with any of the standard TclOO instance creation methods (\fBcreate\fR or \fBnew\fR). +.\" METHOD: new .TP \fB::http::cookiejar new\fR ?\fIfilename\fR? . If a \fIfilename\fR argument is provided, it is the name of a file containing an SQLite database that will contain the persistent cookies maintained by the -cookie jar; the database will be created if the file does not already -exist. If \fIfilename\fR is not supplied, the database will be held entirely within +cookie jar; the database will be created if the file does not already exist. +If \fIfilename\fR is not supplied, the database will be held entirely within memory, which effectively forces all cookies within it to be session cookies. .SS "INSTANCE METHODS" .PP The following methods are supported on the instances: +.\" METHOD: destroy .TP -\fIcookiejar\fR \fBdestroy\fR +\fIcookiejar \fBdestroy\fR . This is the standard TclOO destruction method. It does \fInot\fR delete the SQLite database if it is written to disk. Callers are responsible for ensuring that the cookie jar is not in use by the http package at the time of destruction. +.\" METHOD: forceLoadDomainData .TP -\fIcookiejar\fR \fBforceLoadDomainData\fR +\fIcookiejar \fBforceLoadDomainData\fR . This method causes the cookie jar to immediately load (and cache) the domain list data. The domain list will be loaded from the \fB\-domainlist\fR configured a the package level if that is enabled, and otherwise will be obtained from the \fB\-domainfile\fR configured at the package level. +.\" METHOD: getCookies .TP -\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR +\fIcookiejar \fBgetCookies\fI protocol host path\fR . This method obtains the cookies for a particular HTTP request. \fIThis implements the http cookie jar protocol.\fR +.\" METHOD: policyAllow .TP -\fIcookiejar\fR \fBpolicyAllow\fR \fIoperation domain path\fR +\fIcookiejar \fBpolicyAllow\fI operation domain path\fR . This method is called by the \fBstoreCookie\fR method to get a decision on whether to allow \fIoperation\fR to be performed for the \fIdomain\fR and @@ -137,31 +151,27 @@ after the built-in security checks are done, and should return a boolean value; if the value is false, the operation is rejected and the database is not modified. The supported \fIoperation\fRs are: .RS -.TP -\fBdelete\fR -. +.IP \fBdelete\fR The \fIdomain\fR is seeking to delete a cookie. -.TP -\fBsession\fR -. +.IP \fBsession\fR The \fIdomain\fR is seeking to create or update a session cookie. -.TP -\fBset\fR -. +.IP \fBset\fR The \fIdomain\fR is seeking to create or update a persistent cookie (with a defined lifetime). .PP The default implementation of this method just returns true, but subclasses of this class may impose their own rules. .RE +.\" METHOD: storeCookie .TP -\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR +\fIcookiejar \fBstoreCookie\fI options\fR . This method stores a single cookie from a particular HTTP response. Cookies that fail security checks are ignored. \fIThis implements the http cookie jar protocol.\fR +.\" METHOD: lookup .TP -\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR? +\fIcookiejar \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR? . This method looks a cookie by exact host (or domain) matching. If neither \fIhost\fR nor \fIkey\fR are supplied, the list of hosts for which a cookie is @@ -178,7 +188,7 @@ the start of the application. package require http \fBpackage require cookiejar\fR -set cookiedb ~/.tclcookies.db +set cookiedb [file join [file home] cookiejar] http::configure -cookiejar [\fBhttp::cookiejar new\fR $cookiedb] # No further explicit steps are required to use cookies @@ -201,7 +211,7 @@ oo::class create MyCookieJar { } } -set cookiedb ~/.tclcookies.db +set cookiedb [file join [file home] cookiejar] http::configure -cookiejar [MyCookieJar new $cookiedb] # No further explicit steps are required to use cookies diff --git a/doc/coroutine.n b/doc/coroutine.n index 8110628..cb4d3dd 100644 --- a/doc/coroutine.n +++ b/doc/coroutine.n @@ -13,10 +13,11 @@ coroutine, yield, yieldto, coroinject, coroprobe \- Create and produce values fr .SH SYNOPSIS .nf \fBcoroutine \fIname command\fR ?\fIarg...\fR? + \fByield\fR ?\fIvalue\fR? -\fByieldto\fR \fIcommand\fR ?\fIarg...\fR? +\fByieldto\fI command\fR ?\fIarg...\fR? \fIname\fR ?\fIvalue...\fR? -.sp + .VS "8.7, TIP383" \fBcoroinject \fIcoroName command\fR ?\fIarg...\fR? \fBcoroprobe \fIcoroName command\fR ?\fIarg...\fR? @@ -198,7 +199,7 @@ proc juggler {name target {value ""}} { while {$value ne ""} { puts "$name : $value" set value [string range $value 0 end-1] - lassign [\fByieldto\fR \fI$target\fR $value] value + lassign [\fByieldto\fI $target\fR $value] value } } \fBcoroutine\fR j1 juggler Larry [ @@ -12,22 +12,17 @@ .SH NAME dde \- Execute a Dynamic Data Exchange command .SH SYNOPSIS -.sp +.nf \fBpackage require dde 1.4\fR -.sp + \fBdde servername\fR ?\fB\-force\fR? ?\fB\-handler \fIproc\fR? ?\fB\-\|\-\fR? ?\fItopic\fR? -.sp \fBdde execute\fR ?\fB\-async\fR? ?\fB\-binary\fR? \fIservice topic data\fR -.sp \fBdde poke\fR ?\fB\-binary\fR? \fIservice topic item data\fR -.sp \fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR -.sp \fBdde services \fIservice topic\fR -.sp \fBdde eval\fR ?\fB\-async\fR? \fItopic cmd \fR?\fIarg arg ...\fR? +.fi .BE - .SH DESCRIPTION .PP This command allows an application to send Dynamic Data Exchange (DDE) @@ -44,6 +39,7 @@ has the service name \fBExcel\fR. .PP The following commands are a subset of the full Dynamic Data Exchange set of commands. +.\" METHOD: servername .TP \fBdde servername \fR?\fB\-force\fR? ?\fB\-handler \fIproc\fR? ?\fB\-\|\-\fR? ?\fItopic\fR? . @@ -68,6 +64,7 @@ safe interpreter then a \fB\-handler\fR procedure must be defined. The procedure is called with all the arguments provided by the remote call. .RE +.\" METHOD: execute .TP \fBdde execute\fR ?\fB\-async\fR? ?\fB\-binary\fR? \fIservice topic data\fR . @@ -80,11 +77,15 @@ script is run in the application. The \fB\-async\fR option requests asynchronous invocation. The command returns an error message if the script did not run, unless the \fB\-async\fR flag was used, in which case the command returns immediately with no error. +.RS +.PP Without the \fB\-binary\fR option all data will be sent in unicode. For dde clients which don't implement the CF_UNICODE clipboard format, this will automatically be translated to the system encoding. You can use the \fB\-binary\fR option in combination with the result of \fBencoding convertto\fR to send data in any other encoding. +.RE +.\" METHOD: poke .TP \fBdde poke\fR ?\fB\-binary\fR? \fIservice topic item data\fR . @@ -95,11 +96,15 @@ specific but can be a command to the server or the name of a file to work on. The \fIitem\fR is also application specific and is often not used, but it must always be non-null. The \fIdata\fR field is given to the remote application. +.RS +.PP Without the \fB\-binary\fR option all data will be sent in unicode. For dde clients which don't implement the CF_UNICODE clipboard format, this will automatically be translated to the system encoding. You can use the \fB\-binary\fR option in combination with the result of \fBencoding convertto\fR to send data in any other encoding. +.RE +.\" METHOD: request .TP \fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR . @@ -111,6 +116,7 @@ application-specific. The command returns the value of \fIitem\fR as defined in the application. Normally this is interpreted to be a string with terminating null. If \fB\-binary\fR is specified, the result is returned as a byte array. +.\" METHOD: services .TP \fBdde services \fIservice topic\fR . @@ -123,6 +129,7 @@ returned. If \fIservice\fR is non-empty and \fItopic\fR is, all topics for a given service are returned. If both are non-empty, if that service-topic pair currently exists, it is returned; otherwise, an empty string is returned. +.\" METHOD: eval .TP \fBdde eval\fR ?\fB\-async\fR? \fItopic cmd \fR?\fIarg arg ...\fR? . diff --git a/doc/define.n b/doc/define.n index c1c3049..91d927c 100644 --- a/doc/define.n +++ b/doc/define.n @@ -20,7 +20,6 @@ package require tcl::oo \fBoo::objdefine\fI object subcommand arg\fR ?\fIarg ...\fR? .fi .BE - .SH DESCRIPTION The \fBoo::define\fR command is used to control the configuration of classes, and the \fBoo::objdefine\fR command is used to control the configuration of @@ -42,6 +41,7 @@ and define a class in one step. .PP The following commands are supported in the \fIdefScript\fR for \fBoo::define\fR, each of which may also be used in the \fIsubcommand\fR form: +.\" METHOD: classmethod .TP \fBclassmethod\fI name\fR ?\fIargList bodyScrip\fR? .VS TIP478 @@ -63,6 +63,7 @@ In a private definition context, the methods as invoked on classes are private. .RE .VE TIP478 +.\" METHOD: constructor .TP \fBconstructor\fI argList bodyScript\fR . @@ -79,6 +80,7 @@ string, the constructor will be deleted. Classes do not need to have a constructor defined. If none is specified, the superclass's constructor will be used instead. .RE +.\" METHOD: destructor .TP \fBdestructor\fI bodyScript\fR . @@ -95,6 +97,7 @@ Note that errors during the evaluation of a destructor \fIare not returned\fR to the code that causes the destruction of an object. Instead, they are passed to the currently-defined \fBbgerror\fR handler. .RE +.\" METHOD: export .TP \fBexport\fI name \fR?\fIname ...\fR? . @@ -103,6 +106,7 @@ This arranges for each of the named methods, \fIname\fR, to be exported class being defined. Note that the methods themselves may be actually defined by a superclass; subclass exports override superclass visibility, and may in turn be overridden by instances. +.\" METHOD: forward .TP \fBforward\fI name cmdName \fR?\fIarg ...\fR? . @@ -122,6 +126,7 @@ If in a private definition context (see the \fBprivate\fR definition command, below), this command creates private forwarded methods. .VE TIP500 .RE +.\" METHOD: initialise .TP \fBinitialise\fI script\fR .TP @@ -131,6 +136,7 @@ This evaluates \fIscript\fR in a context which supports local variables and where the current namespace is the instance namespace of the class object itself. This is useful for setting up, e.g., class-scoped variables. .VE TIP478 +.\" METHOD: method .TP \fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR . @@ -155,6 +161,7 @@ below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command creates private procedure-like methods. .VE TIP500 .RE +.\" METHOD: private .TP \fBprivate \fIcmd arg...\fR .TP @@ -174,6 +181,7 @@ commands have no difference in behavior when used in a private definition context. .RE .VE TIP500 +.\" METHOD: self .TP \fBself\fI subcommand arg ...\fR .TP @@ -201,6 +209,7 @@ below), the definitions on the class object will also be made in a private definition context. .VE TIP500 .RE +.\" METHOD: superclass .TP \fBsuperclass\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? . @@ -212,6 +221,7 @@ being non-classes or vice-versa, that an empty parent class is equivalent to \fBoo::object\fR, and that the parent classes of \fBoo::object\fR and \fBoo::class\fR may not be modified. By default, this slot works by replacement. +.\" METHOD: unexport .TP \fBunexport\fI name \fR?\fIname ...\fR? . @@ -221,6 +231,7 @@ but instead just through the \fBmy\fR command visible in each object's context) by the class being defined. Note that the methods themselves may be actually defined by a superclass; subclass unexports override superclass visibility, and may be overridden by instance unexports. +.\" METHOD: variable .TP \fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR? . @@ -252,6 +263,7 @@ extremely unlikely. .PP The following definitions are also supported, but are not required in simple programs: +.\" METHOD: definitionnamespace .TP \fBdefinitionnamespace\fR ?\fIkind\fR? \fInamespaceName\fR .VS TIP524 @@ -278,6 +290,7 @@ locked to \fB::oo::define\fR. A consequence of this is that effective use of this feature for classes requires the definition of a metaclass. .RE .VE TIP524 +.\" METHOD: deletemethod .TP \fBdeletemethod\fI name\fR ?\fIname ...\fR? . @@ -286,6 +299,7 @@ must have previously existed in that class. Does not affect the superclasses of the class, nor does it affect the subclasses or instances of the class (except when they have a call chain through the class being modified) or the class object itself. +.\" METHOD: filter .TP \fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? . @@ -296,6 +310,7 @@ results are. Each \fImethodName\fR names a single filtering method (which may be exposed or not exposed); it is not an error for a non-existent method to be named since they may be defined by subclasses. By default, this slot works by appending. +.\" METHOD: mixin .TP \fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? . @@ -304,6 +319,7 @@ sets or updates the list of additional classes that are to be mixed into all the instances of the class being defined. Each \fIclassName\fR argument names a single class that is to be mixed in. By default, this slot works by replacement. +.\" METHOD: renamemethod .TP \fBrenamemethod\fI fromName toName\fR . @@ -320,6 +336,7 @@ be afterwards. The following commands are supported in the \fIdefScript\fR for \fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR form: +.\" METHOD: export .TP \fBexport\fI name \fR?\fIname ...\fR? . @@ -327,6 +344,7 @@ This arranges for each of the named methods, \fIname\fR, to be exported (i.e. usable outside the object through the object's command) by the object being defined. Note that the methods themselves may be actually defined by a class or superclass; object exports override class visibility. +.\" METHOD: forward .TP \fBforward\fI name cmdName \fR?\fIarg ...\fR? . @@ -343,6 +361,7 @@ If in a private definition context (see the \fBprivate\fR definition command, below), this command creates private forwarded methods. .VE TIP500 .RE +.\" METHOD: method .TP \fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR . @@ -366,6 +385,7 @@ below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command creates private procedure-like methods. .VE TIP500 .RE +.\" METHOD: mixin .TP \fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? . @@ -374,6 +394,7 @@ sets or updates a per-object list of additional classes that are to be mixed into the object. Each argument, \fIclassName\fR, names a single class that is to be mixed in. By default, this slot works by replacement. +.\" METHOD: private .TP \fBprivate \fIcmd arg...\fR .TP @@ -391,6 +412,7 @@ just a private definition context. All other definition commands have no difference in behavior when used in a private definition context. .RE .VE TIP500 +.\" METHOD: unexport .TP \fBunexport\fI name \fR?\fIname ...\fR? . @@ -399,6 +421,7 @@ This arranges for each of the named methods, \fIname\fR, to be not exported just through the \fBmy\fR command visible in the object's context) by the object being defined. Note that the methods themselves may be actually defined by a class; instance unexports override class visibility. +.\" METHOD: variable .TP \fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR? . @@ -428,12 +451,14 @@ superclass methods extremely unlikely. .PP The following definitions are also supported, but are not required in simple programs: +.\" METHOD: class .TP \fBclass\fI className\fR . This allows the class of an object to be changed after creation. Note that the class's constructors are not called when this is done, and so the object may well be in an inconsistent state unless additional configuration work is done. +.\" METHOD: deletemethod .TP \fBdeletemethod\fI name\fR ?\fIname ...\fR . @@ -442,6 +467,7 @@ must have previously existed in that object (e.g., because it was created through \fBoo::objdefine method\fR). Does not affect the classes that the object is an instance of, or remove the exposure of those class-provided methods in the instance of that class. +.\" METHOD: filter .TP \fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? . @@ -453,6 +479,7 @@ not exposed); it is not an error for a non-existent method to be named. Note that the actual list of filters also depends on the filters set upon any classes that the object is an instance of. By default, this slot works by appending. +.\" METHOD: renamemethod .TP \fBrenamemethod\fI fromName toName\fR . @@ -463,6 +490,7 @@ that the object is an instance of and cannot rename in an instance object the methods provided by those classes (though a \fBoo::objdefine forward\fRed method may provide an equivalent capability). Does not change the export status of the method; if it was exported before, it will be afterwards. +.\" METHOD: self .TP \fBself \fR .VS TIP470 @@ -486,32 +514,38 @@ Some of the configurable definitions of a class or object are \fIslotted definitions\fR. This means that the configuration is implemented by a slot object, that is an instance of the class \fBoo::Slot\fR, which manages a list of values (class names, variable names, etc.) that comprises the contents of -the slot. The class defines five operations (as methods) that may be done on +the slot. The class defines six operations (as methods) that may be done on the slot: +.\" METHOD: -append .TP \fIslot\fR \fB\-append\fR ?\fImember ...\fR? . This appends the given \fImember\fR elements to the slot definition. +.\" METHOD: -appendifnew .TP \fIslot\fR \fB\-appendifnew\fR ?\fImember ...\fR? .VS TIP558 This appends the given \fImember\fR elements to the slot definition if they do not already exist. .VE TIP558 +.\" METHOD: -clear .TP \fIslot\fR \fB\-clear\fR . This sets the slot definition to the empty list. +.\" METHOD: -prepend .TP \fIslot\fR \fB\-prepend\fR ?\fImember ...\fR? .VS TIP516 This prepends the given \fImember\fR elements to the slot definition. .VE TIP516 +.\" METHOD: -remove .TP \fIslot\fR \fB\-remove\fR ?\fImember ...\fR? .VS TIP516 This removes the given \fImember\fR elements from the slot definition. .VE TIP516 +.\" METHOD: -set .TP \fIslot\fR \fB\-set\fR ?\fImember ...\fR? . @@ -521,12 +555,14 @@ A consequence of this is that any use of a slot's default operation where the first member argument begins with a hyphen will be an error. One of the above operations should be used explicitly in those circumstances. .SS "SLOT IMPLEMENTATION" +.\" METHOD: --default-operation Internally, slot objects also define a method \fB\-\-default\-operation\fR which is forwarded to the default operation of the slot (thus, for the class .QW \fBvariable\fR slot, this is forwarded to .QW "\fBmy \-append\fR" ), and these methods which provide the implementation interface: +.\" METHOD: Get .TP \fIslot\fR \fBGet\fR . @@ -542,8 +578,9 @@ The elements of the list should be fully resolved, if that is a meaningful concept to the slot. .VE TIP516 .RE +.\" METHOD: Resolve .TP -\fIslot\fR \fBResolve\fR \fIslotElement\fR +\fIslot\fR \fBResolve\fI slotElement\fR .VS TIP516 Returns \fIslotElement\fR with a resolution operation applied to it, but does not modify the slot. For slots of simple strings, this is an operation that @@ -560,6 +597,7 @@ Implementations \fIshould not\fR enforce uniqueness and ordering constraints in this method; that is the responsibility of the \fBSet\fR method. .RE .VE TIP516 +.\" METHOD: Set .TP \fIslot\fR \fBSet \fIelementList\fR . @@ -594,7 +632,7 @@ for reading from slots is via \fBinfo class\fR and \fBinfo object\fR). .SH EXAMPLES This example demonstrates how to use both forms of the \fBoo::define\fR and \fBoo::objdefine\fR commands (they work in the same way), as well as -illustrating four of the subcommands of them. +illustrating four of their subcommands. .PP .CS oo::class create c @@ -19,6 +19,7 @@ Performs one of several operations on dictionary values or variables containing dictionary values (see the \fBDICTIONARY VALUES\fR section below for a description), depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: +.\" METHOD: append .TP \fBdict append \fIdictionaryVariable key \fR?\fIstring ...\fR? . @@ -32,12 +33,14 @@ If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the appending operation. .VE TIP508 +.\" METHOD: create .TP \fBdict create \fR?\fIkey value ...\fR? . Return a new dictionary that contains each of the key/value mappings listed as arguments (keys and values alternating, with each key being followed by its associated value.) +.\" METHOD: exists .TP \fBdict exists \fIdictionaryValue key \fR?\fIkey ...\fR? . @@ -45,6 +48,7 @@ This returns a boolean value indicating whether the given key (or path of keys through a set of nested dictionaries) exists in the given dictionary value. This returns a true value exactly when \fBdict get\fR on that path will succeed. +.\" METHOD: filter .TP \fBdict filter \fIdictionaryValue filterType arg \fR?\fIarg ...\fR? . @@ -54,6 +58,7 @@ type (which may be abbreviated.) Supported filter types are: .RS .TP \fBdict filter \fIdictionaryValue \fBkey\fR ?\fIglobPattern ...\fR? +. The key rule only matches those key/value pairs whose keys match any of the given patterns (in the style of \fBstring match\fR.) .TP @@ -72,9 +77,11 @@ result. The key/value pairs are tested in the order in which the keys were inserted into the dictionary. .TP \fBdict filter \fIdictionaryValue \fBvalue \fR?\fIglobPattern ...\fR? +. The value rule only matches those key/value pairs whose values match any of the given patterns (in the style of \fBstring match\fR.) .RE +.\" METHOD: for .TP \fBdict for {\fIkeyVariable valueVariable\fB} \fIdictionaryValue body\fR . @@ -90,6 +97,7 @@ terminate successfully immediately. If any evaluation of the body generates a \fBTCL_CONTINUE\fR result, this shall be treated exactly like a normal \fBTCL_OK\fR result. The order of iteration is the order in which the keys were inserted into the dictionary. +.\" METHOD: get .TP \fBdict get \fIdictionaryValue \fR?\fIkey ...\fR? . @@ -115,6 +123,8 @@ the value for that key. It is an error to attempt to retrieve a value for a key that is not present in the dictionary. .RE +.\" METHOD: getdef +.\" METHOD: getwithdefault .TP \fBdict getdef \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR .TP @@ -131,6 +141,7 @@ Note that there must always be at least one \fIkey\fR provided, and that \fBdict getdef\fR and \fBdict getwithdefault\fR are aliases for each other. .RE .VE "8.7, TIP342" +.\" METHOD: incr .TP \fBdict incr \fIdictionaryVariable key \fR?\fIincrement\fR? . @@ -146,6 +157,7 @@ If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the incrementing operation. .VE TIP508 +.\" METHOD: info .TP \fBdict info \fIdictionaryValue\fR . @@ -154,6 +166,7 @@ given dictionary though the format of this data is dependent on the implementation of the dictionary. For dictionaries that are implemented by hash tables, it is expected that this will return the string produced by \fBTcl_HashStats\fR, similar to \fBarray statistics\fR. +.\" METHOD: keys .TP \fBdict keys \fIdictionaryValue \fR?\fIglobPattern\fR? . @@ -161,6 +174,7 @@ Return a list of all keys in the given dictionary value. If a pattern is supplied, only those keys that match it (according to the rules of \fBstring match\fR) will be returned. The returned keys will be in the order that they were inserted into the dictionary. +.\" METHOD: lappend .TP \fBdict lappend \fIdictionaryVariable key \fR?\fIvalue ...\fR? . @@ -176,6 +190,7 @@ If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the list-appending operation. .VE TIP508 +.\" METHOD: map .TP \fBdict map \fR{\fIkeyVariable valueVariable\fR} \fIdictionaryValue body\fR . @@ -201,6 +216,7 @@ of iteration is the natural order of the dictionary (typically the order in which the keys were added to the dictionary; the order is the same as that used in \fBdict for\fR). .RE +.\" METHOD: merge .TP \fBdict merge \fR?\fIdictionaryValue ...\fR? . @@ -209,6 +225,7 @@ Return a dictionary that contains the contents of each of the contain a mapping for the same key, the resulting dictionary maps that key to the value according to the last dictionary on the command line containing a mapping for that key. +.\" METHOD: remove .TP \fBdict remove \fIdictionaryValue \fR?\fIkey ...\fR? . @@ -217,6 +234,7 @@ first argument except without mappings for each of the keys listed. It is legal for there to be no keys to remove, and it also legal for any of the keys to be removed to not be present in the input dictionary in the first place. +.\" METHOD: replace .TP \fBdict replace \fIdictionaryValue \fR?\fIkey value ...\fR? . @@ -225,6 +243,7 @@ first argument except with some values different or some extra key/value pairs added. It is legal for this command to be called with no key/value pairs, but illegal for this command to be called with a key but no value. +.\" METHOD: set .TP \fBdict set \fIdictionaryVariable key \fR?\fIkey ...\fR? \fIvalue\fR . @@ -238,10 +257,12 @@ If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the value insert/update operation. .VE TIP508 +.\" METHOD: size .TP \fBdict size \fIdictionaryValue\fR . Return the number of key/value mappings in the given dictionary value. +.\" METHOD: unset .TP \fBdict unset \fIdictionaryVariable key \fR?\fIkey ...\fR? . @@ -258,6 +279,7 @@ If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the value remove operation. .VE TIP508 +.\" METHOD: update .TP \fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR . @@ -285,10 +307,12 @@ it is recommended that this command only be used in a local scope (\fBproc\fRedure, lambda term for \fBapply\fR, or method). Because of this, the variables set by \fBdict update\fR will continue to exist after the command finishes (unless explicitly \fBunset\fR). +.PP Note that the mapping of values to variables does not use traces; changes to the \fIdictionaryVariable\fR's contents only happen when \fIbody\fR terminates. .RE +.\" METHOD: values .TP \fBdict values \fIdictionaryValue \fR?\fIglobPattern\fR? . @@ -297,6 +321,7 @@ pattern is supplied, only those values that match it (according to the rules of \fBstring match\fR) will be returned. The returned values will be in the order of that the keys associated with those values were inserted into the dictionary. +.\" METHOD: with .TP \fBdict with \fIdictionaryVariable \fR?\fIkey ...\fR? \fIbody\fR . @@ -324,6 +349,7 @@ it is recommended that this command only be used in a local scope (\fBproc\fRedure, lambda term for \fBapply\fR, or method). Because of this, the variables set by \fBdict with\fR will continue to exist after the command finishes (unless explicitly \fBunset\fR). +.PP Note that the mapping of values to variables does not use traces; changes to the \fIdictionaryVariable\fR's contents only happen when \fIbody\fR terminates. diff --git a/doc/encoding.n b/doc/encoding.n index c881d26..d556839 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -1,5 +1,6 @@ '\" '\" Copyright (c) 1998 Scriptics Corporation. +'\" Copyright (c) 2023 Nathan Coulter '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -15,14 +16,15 @@ encoding \- Work with encodings .SH INTRODUCTION .PP In Tcl every string is composed of Unicode values. Text may be encoded into an -encoding such as cp1252, iso8859-1, Shitf\-JIS, utf-8, utf-16, etc. Not every -Unicode vealue is encodable in every encoding, and some encodings can encode +encoding such as cp1252, iso8859-1, Shift\-JIS, utf-8, utf-16, etc. Not every +Unicode value is encodable in every encoding, and some encodings can encode values that are not available in Unicode. .PP Even though Unicode is for encoding the written texts of human languages, any -sequence of bytes can be encoded as the first 255 Unicode values. iso8859-1 an -encoding for a subset of Unicode in which each byte is a Unicode value of 255 -or less. Thus, any sequence of bytes can be considered to be a Unicode string +sequence of bytes can be encoded as the first 255 Unicode values. In particular, +iso8859-1 is an encoding (a superset of classic ASCII) for a subset of Unicode +in which each byte is a Unicode value of 255 +or less; any sequence of bytes can be considered to be a Unicode string encoded in iso8859-1. To work with binary data in Tcl, decode it from iso8859-1 when reading it in, and encode it into iso8859-1 when writing it out, ensuring that each character in the string has a value of 255 or less. @@ -31,46 +33,49 @@ does nothing. .PP For example, the following is true: .CS + set text {In Tcl binary data is treated as Unicode text and it just works.} -set encoded [encoding convertto iso8859-1 $text] +set encoded [\fBencoding convertto\fR iso8859-1 $text] expr {$text eq $encoded}; #-> 1 .CE The following is also true: .CS -set decoded [encoding convertfrom iso8859-1 $text] +set decoded [\fBencoding convertfrom\fR iso8859-1 $text] expr {$text eq $decoded}; #-> 1 .CE .SH DESCRIPTION .PP Performs one of the following encoding \fIoperations\fR: +.\" METHOD: convertfrom .TP \fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR .TP -\fBencoding convertfrom\fR ?\fB-profile \fIprofile\fR? ?\fB-failindex var\fR? \fIencoding\fR \fIdata\fR +\fBencoding convertfrom\fR ?\fB\-profile \fIprofile\fR? ?\fB\-failindex var\fR? \fIencoding data\fR . Decodes \fIdata\fR encoded in \fIencoding\fR. If \fIencoding\fR is not specified the current system encoding is used. - .VS "TCL8.7 TIP607, TIP656" -\fB-profile\fR determines how invalid data for the encoding are handled. See +\fB\-profile\fR determines how invalid data for the encoding are handled. See the \fBPROFILES\fR section below for details. Returns an error if decoding -fails. However, if \fB-failindex\fR given, returns the result of the +fails. However, if \fB\-failindex\fR given, returns the result of the conversion up to the point of termination, and stores in \fBvar\fR the index of the character that could not be converted. If no errors are encountered the entire result of the conversion is returned and the value \fB-1\fR is stored in \fBvar\fR. .VE "TCL8.7 TIP607, TIP656" +.\" METHOD: convertto .TP \fBencoding convertto\fR ?\fIencoding\fR? \fIdata\fR .TP -\fBencoding convertto\fR ?\fB-profile \fIprofile\fR? ?\fB-failindex var\fR? \fIencoding\fR \fIdata\fR +\fBencoding convertto\fR ?\fB\-profile \fIprofile\fR? ?\fB\-failindex var\fR? \fIencoding data\fR . Converts \fIstring\fR to \fIencoding\fR. If \fIencoding\fR is not given, the current system encoding is used. - .VS "TCL8.7 TIP607, TIP656" -See \fBencoding convertfrom\fR for the meaning of \fB-profile\fR and \fB-failindex\fR. +See \fBencoding convertfrom\fR for the meaning of \fB\-profile\fR and +\fB\-failindex\fR. .VE "TCL8.7 TIP607, TIP656" +.\" METHOD: dirs .TP \fBencoding dirs\fR ?\fIdirectoryList\fR? . @@ -79,6 +84,7 @@ directories given by \fIdirectoryList\fR. If \fIdirectoryList\fR is not given, returns the current list of directories that make up the search path. It is not an error for an item in \fIdirectoryList\fR to not refer to a readable, searchable directory. +.\" METHOD: names .TP \fBencoding names\fR . @@ -88,12 +94,14 @@ The encodings and .QW iso8859-1 are guaranteed to be present in the list. -.VS "TCL8.7 TIP656" +.\" METHOD: profiles .TP \fBencoding profiles\fR +.VS "TCL8.7 TIP656" Returns a list of names of available encoding profiles. See \fBPROFILES\fR below. .VE "TCL8.7 TIP656" +.\" METHOD: system .TP \fBencoding system\fR ?\fIencoding\fR? . @@ -108,11 +116,17 @@ Each \fIprofile\fR is a distinct strategy for dealing with invalid data for an encoding. .PP The following profiles are currently implemented. +.VE "TCL8.7 TIP656" +.TP +\fBstrict\fR .VS "TCL8.7 TIP656" +The default profile. The operation fails when invalid data for the encoding +are encountered. +.VE "TCL8.7 TIP656" .TP \fBtcl8\fR -. -The default profile. Provides for behaviour identical to that of Tcl 8.6: When +.VS "TCL8.7 TIP656" +Provides for behaviour identical to that of Tcl 8.6: When decoding, for encodings \fBother than utf-8\fR, each invalid byte is interpreted as the Unicode value given by that one byte. For example, the byte 0x80, which is invalid in the ASCII encoding would be mapped to the Unicode value U+0080. @@ -122,22 +136,23 @@ not is treated as the Unicode value given by that one byte. For example, byte 0x80 is defined by CP1252 and is therefore mapped to its Unicode equivalent U+20AC while byte 0x81 which is not defined by CP1252 is mapped to U+0081. As an additional special case, the sequence 0xC0 0x80 is mapped to U+0000. - +.RS +.PP When encoding, each character that cannot be represented in the encoding is replaced by an encoding-dependent character, usually the question mark \fB?\fR. -.TP -\fBstrict\fR -. -The operation fails when invalid data for the encoding are encountered. +.RE +.VE "TCL8.7 TIP656" .TP \fBreplace\fR -. +.VS "TCL8.7 TIP 656" When decoding, invalid bytes are replaced by U+FFFD, the Unicode REPLACEMENT CHARACTER. - +.RS +.PP When encoding, Unicode values that cannot be represented in the target encoding are transformed to an encoding-specific fallback character, U+FFFD REPLACEMENT CHARACTER for UTF targets, and generally `?` for other encodings. +.RE .VE "TCL8.7 TIP656" .SH EXAMPLES .PP @@ -168,18 +183,18 @@ The letter \fBA\fR is Unicode character U+0041 and the byte "\ex80" is invalid in ASCII encoding. .PP .CS -% codepoints [encoding convertfrom -profile tcl8 ascii A\ex80] +% codepoints [\fBencoding convertfrom\fR -profile tcl8 ascii A\ex80] U+000041 U+000080 -% codepoints [encoding convertfrom -profile replace ascii A\ex80] +% codepoints [\fBencoding convertfrom\fR -profile replace ascii A\ex80] U+000041 U+00FFFD -% codepoints [encoding convertfrom -profile strict ascii A\ex80] +% codepoints [\fBencoding convertfrom\fR -profile strict ascii A\ex80] unexpected byte sequence starting at index 1: '\ex80' .CE .PP Example 3: Get partial data and the error location: .PP .CS -% codepoints [encoding convertfrom -profile strict -failindex idx ascii AB\ex80] +% codepoints [\fBencoding convertfrom\fR -failindex idx ascii AB\ex80] U+000041 U+000042 % set idx 2 @@ -188,11 +203,11 @@ U+000041 U+000042 Example 4: Encode a character that is not representable in ISO8859-1: .PP .CS -% encoding convertto iso8859-1 A\eu0141 +% \fBencoding convertto\fR iso8859-1 A\eu0141 A? -% encoding convertto -profile strict iso8859-1 A\eu0141 +% \fBencoding convertto\fR -profile strict iso8859-1 A\eu0141 unexpected character at index 1: 'U+000141' -% encoding convertto -profile strict -failindex idx iso8859-1 A\eu0141 +% \fBencoding convertto\fR -failindex idx iso8859-1 A\eu0141 A % set idx 1 diff --git a/doc/error.n b/doc/error.n index c05f8b9..9ff4298 100644 --- a/doc/error.n +++ b/doc/error.n @@ -14,7 +14,6 @@ error \- Generate an error .SH SYNOPSIS \fBerror \fImessage\fR ?\fIinfo\fR? ?\fIcode\fR? .BE - .SH DESCRIPTION .PP Returns a \fBTCL_ERROR\fR code, which causes command interpretation to be @@ -22,6 +22,7 @@ script containing one or more commands. fashion as the \fBconcat\fR command, passes the concatenated string to the Tcl interpreter recursively, and returns the result of that evaluation (or any error generated by it). +.PP Note that the \fBlist\fR command quotes sequences of words in such a way that they are not further expanded by the \fBeval\fR command; for \fIany\fR values, $a, $b, and $c, these two lines are effectively @@ -31,16 +31,19 @@ If the initial arguments to \fBexec\fR start with \fB\-\fR then they are treated as command-line switches and are not part of the pipeline specification. The following switches are currently supported: +.\" OPTION: -ignorestderr .TP 13 \fB\-ignorestderr\fR . Stops the \fBexec\fR command from treating the output of messages to the pipeline's standard error channel as an error case. +.\" OPTION: -keepnewline .TP 13 \fB\-keepnewline\fR . Retains a trailing newline in the pipeline's output. Normally a trailing newline will be deleted. +.\" OPTION: -- .TP 13 \fB\-\|\-\fR . @@ -52,7 +55,7 @@ described below then it is used by \fBexec\fR to control the flow of input and output among the subprocess(es). Such arguments will not be passed to the subprocess(es). In forms such as -.QW "\fB<\fR \fIfileName\fR" , +.QW "\fB<\fI fileName\fR" , \fIfileName\fR may either be in a separate argument from .QW \fB<\fR or in the same argument with no intervening space (i.e. @@ -198,7 +201,7 @@ the commands in the pipeline will go to the application's standard error file unless redirected. .PP The first word in each command is taken as the command name; -tilde-substitution is performed on it, and if the result contains +if the result contains no slashes then the directories in the PATH environment variable are searched for an executable by the given name. @@ -479,7 +482,7 @@ encrypted so that only the current user can access it requires use of the \fICIPHER\fR command, like this: .PP .CS -set secureDir "~/Desktop/Secure Directory" +set secureDir [file join [file home] Desktop/SecureDirectory] file mkdir $secureDir \fBexec\fR CIPHER /e /s:[file nativename $secureDir] .CE @@ -14,7 +14,6 @@ exit \- End the application .SH SYNOPSIS \fBexit \fR?\fIreturnCode\fR? .BE - .SH DESCRIPTION .PP Terminate the process, returning \fIreturnCode\fR to the @@ -54,17 +54,13 @@ ignored. Each operand is interpreted as a numeric value if at all possible. .PP Each operand has one of the following forms: .RS -.PP .TP A \fBnumeric value\fR .PP .RS -. Either integer or floating-point. The first two characters of an integer may also be \fB0d\fR for decimal, \fB0b\fR for binary, \fB0o\fR for octal or -\fB0x\fR for hexadicimal. For compatibility with older Tcl releases, an -operand that begins with \fB0\fR is interpreted as an octal integer even if the -second character is not \fBo\fR. +\fB0x\fR for hexadecimal. .PP A floating-point number may be take any of several common decimal formats, and may use the decimal point \fB.\fR, @@ -90,7 +86,6 @@ end of a numeric value. Here are some examples: \fBexpr\fR 3_141_592_653_589e-1_2 \fI3.141592653589\fR .CE .RE - .TP A \fBboolean value\fR . @@ -108,6 +103,7 @@ Backslash, variable, and command substitution are performed according to the rules for \fBTcl\fR. .TP A string enclosed in \fBbraces\fR. +. The operand is treated as a braced value according to the rule for braces in \fBTcl\fR. .TP @@ -116,8 +112,10 @@ A Tcl command enclosed in \fBbrackets\fR Command substitution is performed as according to the command substitution rule for \fBTcl\fR. .TP -A mathematical function such as \fBsin($x)\fR, whose arguments have any of the above -forms for operands. See \fBMATH FUNCTIONS\fR below for +A function call. +. +This is mathematical function such as \fBsin($x)\fR, whose arguments have any of +the above forms for operands. See \fBMATH FUNCTIONS\fR below for a discussion of how mathematical functions are handled. .RE .PP @@ -143,8 +141,8 @@ produces the value on the right side. For operators having both a numeric mode and a string mode, the numeric mode is chosen when all operands have a numeric interpretation. The integer interpretation of an operand is preferred over the floating-point -interpretation. To ensure string operations on arbitrary values it is generally a -good idea to use \fBeq\fR, \fBne\fR, or the \fBstring\fR command instead of +interpretation. To ensure string operations on arbitrary values it is generally +a good idea to use \fBeq\fR, \fBne\fR, or the \fBstring\fR command instead of more versatile operators such as \fB==\fR. .PP Unless otherwise specified, operators accept non-numeric operands. The value @@ -204,7 +202,7 @@ comparison operators below, which have the same precedence. Boolean string comparisons: less than, greater than, less than or equal, and greater than or equal. These always compare values using their UNICODE strings (also see \fBstring compare\fR), unlike with the numeric-preferring -comparisons abov, which have the same precedence. +comparisons above, which have the same precedence. .VE "8.7, TIP461" .TP 20 \fB==\0\0!=\fR @@ -292,8 +290,8 @@ For more details on the results produced by each operator, see the documentation for C. .SS "MATH FUNCTIONS" .PP -A mathematical function such as \fBsin($x)\fR is replaced with a call to an ordinary -Tcl command in the \fBtcl::mathfunc\fR namespace. The evaluation +A mathematical function such as \fBsin($x)\fR is replaced with a call to an +ordinary Tcl command in the \fBtcl::mathfunc\fR namespace. The evaluation of an expression such as .PP .CS @@ -313,12 +311,13 @@ tcl::mathfunc::sin [\fBexpr\fR {$x+$y}] .CE .PP \fBtcl::mathfunc::sin\fR is resolved as described in -\fBNAMESPACE RESOLUTION\fR in the \fBnamespace\fR(n) documentation. Given the +\fBNAMESPACE RESOLUTION\fR in the \fBnamespace\fR(n) documentation. Given the default value of \fBnamespace path\fR, \fB[namespace current]::tcl::mathfunc::sin\fR or \fB::tcl::mathfunc::sin\fR are the typical resolutions. .PP -As in C, a mathematical function may accept multiple arguments separated by commas. Thus, +As in C, a mathematical function may accept multiple arguments separated by +commas. Thus, .PP .CS \fBexpr\fR {hypot($x,$y)} @@ -389,13 +388,12 @@ the expression, resulting in better speed and smaller storage requirements. This also avoids issues that can arise if Tcl is allowed to perform substitution on the value before \fBexpr\fR is called. .PP -In the following example, the value of the expression is 11 because the Tcl parser first -substitutes \fB$b\fR and \fBexpr\fR then substitutes \fB$a\fR as part -of evaluating the expression +In the following example, the value of the expression is 11 because the Tcl +parser first substitutes \fB$b\fR and \fBexpr\fR then substitutes \fB$a\fR as +part of evaluating the expression .QW "$a + 2*4" . -Enclosing the -expression in braces would result in a syntax error as \fB$b\fR does -not evaluate to a numeric value. +Enclosing the expression in braces would result in a syntax error as \fB$b\fR +does not evaluate to a numeric value. .PP .CS set a 3 diff --git a/doc/fblocked.n b/doc/fblocked.n index 0a28dcf..44dfcd5 100644 --- a/doc/fblocked.n +++ b/doc/fblocked.n @@ -12,7 +12,6 @@ fblocked \- Test whether the last input operation exhausted all available input .SH SYNOPSIS \fBfblocked \fIchannelId\fR .BE - .SH DESCRIPTION .PP The \fBfblocked\fR command returns 1 if the most recent input operation diff --git a/doc/fconfigure.n b/doc/fconfigure.n index 3de22eb..468cd62 100644 --- a/doc/fconfigure.n +++ b/doc/fconfigure.n @@ -13,8 +13,8 @@ fconfigure \- Set and get options on a channel .SH SYNOPSIS .nf \fBfconfigure \fIchannelId\fR -\fBfconfigure \fIchannelId\fR \fIname\fR -\fBfconfigure \fIchannelId\fR \fIname value \fR?\fIname value ...\fR? +\fBfconfigure \fIchannelId name\fR +\fBfconfigure \fIchannelId name value \fR?\fIname value ...\fR? .fi .BE .SH DESCRIPTION @@ -41,8 +41,10 @@ entry for the command that creates each type of channels for the options that that specific type of channel supports. For example, see the manual entry for the \fBsocket\fR command for additional options for sockets, and the \fBopen\fR command for additional options for serial devices. +.\" OPTION: -blocking .TP -\fB\-blocking\fR \fIboolean\fR +\fB\-blocking\fI boolean\fR +. The \fB\-blocking\fR option determines whether I/O operations on the channel can cause the process to block indefinitely. The value of the option must be a proper boolean value. @@ -54,8 +56,9 @@ see the documentation for those commands for details. For nonblocking mode to work correctly, the application must be using the Tcl event loop (e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR command). +.\" OPTION: -buffering .TP -\fB\-buffering\fR \fInewValue\fR +\fB\-buffering\fI newValue\fR . If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output until its internal buffer is full or until the \fBflush\fR command is @@ -67,15 +70,17 @@ automatically after every output operation. The default is for connect to terminal-like devices; for these channels the initial setting is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR. +.\" OPTION: -buffersize .TP -\fB\-buffersize\fR \fInewSize\fR +\fB\-buffersize\fI newSize\fR . \fINewvalue\fR must be an integer; its value is used to set the size of buffers, in bytes, subsequently allocated for this channel to store input or output. \fINewvalue\fR must be between one and one million, allowing buffers of one to one million bytes in size. +.\" OPTION: -encoding .TP -\fB\-encoding\fR \fIname\fR +\fB\-encoding\fI name\fR . This option is used to specify the encoding of the channel, so that the data can be converted to and from Unicode for use in Tcl. For instance, in @@ -100,31 +105,23 @@ The default encoding for newly opened channels is the same platform- and locale-dependent system encoding used for interfacing with the operating system, as returned by \fBencoding system\fR. .RE +.\" OPTION: -eofchar .TP -\fB\-eofchar\fR \fIchar\fR -.TP -\fB\-eofchar\fR \fB{\fIchar outChar\fB}\fR +\fB\-eofchar\fI char\fR . This option supports DOS file systems that use Control-z (\ex1A) as an end of file marker. If \fIchar\fR is not an empty string, then this -character signals end-of-file when it is encountered during input. For -output, the end-of-file character is output when the channel is closed. +character signals end-of-file when it is encountered during input. If \fIchar\fR is the empty string, then there is no special end of file -character marker. For read-write channels, a two-element list specifies -the end of file marker for input and output, respectively. As a -convenience, when setting the end-of-file character for a read-write -channel you can specify a single value that will apply to reading -only. When querying the end-of-file character of a read-write -channel, a two-element list will always be returned. The default value -for \fB\-eofchar\fR is the empty string in all cases except for files -under Windows. In that case the \fB\-eofchar\fR is Control-z (\ex1A) for -reading and the empty string for writing. +character marker. The default value for \fB\-eofchar\fR is the empty +string. The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7F; attempting to set \fB\-eofchar\fR to a value outside of this range will generate an error. .VS "TCL8.7 TIP656" +.\" OPTION: -profile .TP -\fB\-profile\fR \fIprofile\fR +\fB\-profile\fI profile\fR . Specifies the encoding profile to be used on the channel. The encoding transforms in use for the channel's input and output will then be subject to the @@ -132,8 +129,9 @@ rules of that profile. Any failures will result in a channel error. See \fBPROFILES\fR in the \fBencoding(n)\fR documentation for details about encoding profiles. .VE "TCL8.7 TIP656" +.\" OPTION: -translation .TP -\fB\-translation\fR \fImode\fR +\fB\-translation\fI mode\fR .TP \fB\-translation\fR \fB{\fIinMode outMode\fB}\fR . @@ -160,9 +158,7 @@ you can specify a single value that will apply to both reading and writing. When querying the translation mode of a read-write channel, a two-element list will always be returned. The following values are currently supported: -.TP -\fBauto\fR -. +.IP \fBauto\fR As the input translation mode, \fBauto\fR treats any of newline (\fBlf\fR), carriage return (\fBcr\fR), or carriage return followed by a newline (\fBcrlf\fR) as the end of line representation. The end of line @@ -172,9 +168,7 @@ chooses a platform specific representation; for sockets on all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses \fBlf\fR, and for the various flavors of Windows it chooses \fBcrlf\fR. The default setting for \fB\-translation\fR is \fBauto\fR for both input and output. -.TP -\fBbinary\fR -. +.IP \fBbinary\fR No end-of-line translations are performed. This is nearly identical to \fBlf\fR mode, except that in addition \fBbinary\fR mode also sets the end-of-file character to the empty string (which disables it) and sets the @@ -187,17 +181,13 @@ translator this value \fBis\fR identical to \fBlf\fR and is therefore reported as such when queried. Even if \fBbinary\fR was used to set the translation. .RE -.TP -\fBcr\fR -. +.IP \fBcr\fR The end of a line in the underlying file or device is represented by a single carriage return character. As the input translation mode, \fBcr\fR mode converts carriage returns to newline characters. As the output translation mode, \fBcr\fR mode translates newline characters to carriage returns. -.TP -\fBcrlf\fR -. +.IP \fBcrlf\fR The end of a line in the underlying file or device is represented by a carriage return character followed by a linefeed character. As the input translation mode, \fBcrlf\fR mode converts carriage-return-linefeed @@ -205,9 +195,7 @@ sequences to newline characters. As the output translation mode, \fBcrlf\fR mode translates newline characters to carriage-return-linefeed sequences. This mode is typically used on Windows platforms and for network connections. -.TP -\fBlf\fR -. +.IP \fBlf\fR The end of a line in the underlying file or device is represented by a single newline (linefeed) character. In this mode no translations occur during either input or output. This mode is typically used on UNIX @@ -259,7 +247,7 @@ Read a PPM-format image from a file: .CS # Open the file and put it into Unix ASCII mode set f [open teapot.ppm] -\fBfconfigure\fR $f \-encoding ascii \-translation lf +\fBfconfigure\fR $f -encoding ascii -translation lf # Get the header if {[gets $f] ne "P6"} { @@ -281,7 +269,7 @@ lassign $words xSize ySize depth # Now switch to binary mode to pull in the data, # one byte per channel (red,green,blue) per pixel. -\fBfconfigure\fR $f \-translation binary +\fBfconfigure\fR $f -translation binary set numDataBytes [expr {3 * $xSize * $ySize}] set data [read $f $numDataBytes] @@ -291,9 +279,9 @@ close $f close(n), encoding(n), flush(n), gets(n), open(n), puts(n), read(n), socket(n), Tcl_StandardChannels(3) .SH KEYWORDS -blocking, buffering, carriage return, end of line, flushing, linemode, -newline, nonblocking, platform, profile, translation, encoding, filter, byte array, -binary +blocking, buffering, carriage return, end of line, encoding, flushing, linemode, +newline, nonblocking, platform, profile, translation, encoding, filter, +byte array, binary '\" Local Variables: '\" mode: nroff '\" End: diff --git a/doc/fcopy.n b/doc/fcopy.n index dc6d8ea..e044fb7 100644 --- a/doc/fcopy.n +++ b/doc/fcopy.n @@ -12,30 +12,28 @@ .SH NAME fcopy \- Copy data from one channel to another .SH SYNOPSIS -\fBfcopy \fIinputChan\fR \fIoutputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR? +\fBfcopy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR? .BE - .SH DESCRIPTION .PP -The \fBfcopy\fR command copies data from one I/O channel, \fIinchan\fR to another I/O channel, \fIoutchan\fR. +The \fBfcopy\fR command copies data from one I/O channel, \fIinchan\fR, to +another I/O channel, \fIoutchan\fR. The \fBfcopy\fR command leverages the buffering in the Tcl I/O system to avoid extra copies and to avoid buffering too much data in main memory when copying large files to destinations like network sockets. -. .SS "DATA QUANTITY" All data until \fIEOF\fR is copied. -In addition, the quantity of copied data may be specified by the option \fB-size\fR. -The given size is in bytes, if the input channel is in binary mode. -Otherwise, it is in characters. +In addition, the quantity of copied data may be specified by the option +\fB\-size\fR. The given size is in bytes, if the input channel is in binary +mode. Otherwise, it is in characters. .PP -The transfer is treated as a binary transfer, if the encoding -profile is set to +Depreciated feature: the transfer is treated as a binary transfer, if the +encoding profile is set to .QW tcl8 and the input encoding matches the output encoding. In this case, eventual encoding errors are not handled. An eventually given size is in bytes in this case. -This feature is depreciated in TCL 9. . .SS "BLOCKING OPERATION MODE" Without the \fB\-command\fR option, \fBfcopy\fR blocks until the copy is complete @@ -71,7 +69,8 @@ then all data already queued for \fIoutchan\fR is written out. Note that \fIinchan\fR can become readable during a background copy. You should turn off any \fBfileevent\fR handlers during a background copy so those handlers do not interfere with the copy. -Any wrong-sided I/O attempted (by a \fBfileevent\fR handler or otherwise) will get a +Any wrong-sided I/O attempted (by a \fBfileevent\fR handler or otherwise) will +get a .QW "channel busy" error. . @@ -111,15 +110,16 @@ channel is configured to the .QW strict encoding profile. .PP -If an encoding error arises on the input channel, any data before the error byte is -written to the output channel. The input file pointer is located just before the -values causing the encoding error. +If an encoding error arises on the input channel, any data before the error +byte is written to the output channel. The input file pointer is located just +before the values causing the encoding error. Error inspection or recovery is possible by changing the encoding parameters and invoking a file command (\fBread\fR, \fBfcopy\fR). .PP -If an encoding error arises on the output channel, the errorneous data is lost. -To make the difference between the input error case and the output error case, only the -error message may be inspected (read or write), as both throw the error code \fIEILSEQ\fR. +If an encoding error arises on the output channel, the erroneous data is lost. +To make the difference between the input error case and the output error case, +only the error message may be inspected (read or write), as both throw the +error code \fIEILSEQ\fR. .SH EXAMPLES .PP The first example transfers the contents of one channel exactly to @@ -12,16 +12,15 @@ .SH NAME file \- Manipulate file names and attributes .SH SYNOPSIS -\fBfile \fIoption\fR \fIname\fR ?\fIarg arg ...\fR? +\fBfile \fIoption name\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP -This command provides several operations on a file's name or attributes. -\fIName\fR is the name of a file; if it starts with a tilde, then tilde -substitution is done before executing the command (see the manual entry for -\fBfilename\fR for details). \fIOption\fR indicates what to do with the -file name. Any unique abbreviation for \fIoption\fR is acceptable. The -valid options are: +This command provides several operations on a file's name or attributes. The +\fIname\fR argument is the name of a file in most cases. The \fIoption\fR +argument indicates what to do with the file name. Any unique abbreviation for +\fIoption\fR is acceptable. The valid options are: +.\" METHOD: atime .TP \fBfile atime \fIname\fR ?\fItime\fR? . @@ -33,6 +32,7 @@ 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. +.\" METHOD: attributes .TP \fBfile attributes \fIname\fR .TP @@ -62,7 +62,7 @@ write permission for the file's group and other users. An \fBls\fR-style string of the form \fBrwxrwxrwx\fR is also accepted but must always be 9 characters long. E.g., \fBrwxr-xr-t\fR is equivalent to \fB01755\fR. On versions of Unix supporting file flags, -\fB-readonly\fR returns the value of, or sets, or clears the readonly +\fB\-readonly\fR returns the value of, or sets, or clears the readonly attribute of a file, i.e., the user immutable flag (\fBuchg\fR) to the \fBchflags\fR command. .PP @@ -86,17 +86,44 @@ 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. +.RS +.\" OPTION: -archive +.TP +\fB\-archive\fR +. +The path of the mounted ZIP archive containing the file. +.\" OPTION: -compsize +.TP +\fB\-compsize\fR +. +The compressed size of the file within the archive. This is \fB0\fR for directories. +.\" OPTION: -crc +.TP +\fB\-crc\fR +. +The CRC of the file if present, else \fB0\fR. +.\" OPTION: -mount +.TP +\fB\-mount\fR +. +The path where the containing archive is mounted. +.\" OPTION: -offset +.TP +\fB\-offset\fR +. +The offset of the file within the archive. +.\" OPTION: -uncompsize +.TP +\fB\-uncompsize\fR +. +The uncompressed size of the file. This is \fB0\fR for directories. +.RE +.PP Other attributes may be present in the returned list. These should be ignored. .RE +.\" METHOD: channels .TP \fBfile channels\fR ?\fIpattern\fR? . @@ -104,8 +131,9 @@ If \fIpattern\fR is not specified, returns a list of names of all registered open channels in this interpreter. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. +.\" METHOD: copy .TP -\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR +\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource target\fR .TP \fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR . @@ -126,6 +154,7 @@ or overwrite a file with a directory will all result in errors even if specified, halting at the first error, if any. A \fB\-\|\-\fR marks the end of switches; the argument following the \fB\-\|\-\fR will be treated as a \fIsource\fR even if it starts with a \fB\-\fR. +.\" METHOD: delete .TP \fBfile delete \fR?\fB\-force\fR? ?\fB\-\|\-\fR? ?\fIpathname\fR ... ? . @@ -145,8 +174,10 @@ the first error, if any. A \fB\-\|\-\fR marks the end of switches; the argument following the \fB\-\|\-\fR will be treated as a \fIpathname\fR even if it starts with a \fB\-\fR. +.\" METHOD: dirname .TP \fBfile dirname \fIname\fR +. Returns a name comprised of all of the path components in \fIname\fR excluding the last element. If \fIname\fR is a relative file name and only contains one path element, then returns @@ -160,22 +191,8 @@ returned. For example, .CE .PP returns \fBc:/\fR. -.PP -Note that tilde substitution will only be -performed if it is necessary to complete the command. For example, -.PP -.CS -\fBfile dirname\fR ~/src/foo.c -.CE -.PP -returns \fB~/src\fR, whereas -.PP -.CS -\fBfile dirname\fR ~ -.CE -.PP -returns \fB/home\fR (or something similar). .RE +.\" METHOD: executable .TP \fBfile executable \fIname\fR . @@ -183,17 +200,20 @@ Returns \fB1\fR if file \fIname\fR is executable by the current user, \fB0\fR otherwise. On Windows, which does not have an executable attribute, the command treats all directories and any files with extensions \fBexe\fR, \fBcom\fR, \fBcmd\fR or \fBbat\fR as executable. +.\" METHOD: exists .TP \fBfile exists \fIname\fR . Returns \fB1\fR if file \fIname\fR exists and the current user has search privileges for the directories leading to it, \fB0\fR otherwise. +.\" METHOD: extension .TP \fBfile extension \fIname\fR . Returns all of the characters in \fIname\fR after and including the last dot in the last element of \fIname\fR. If there is no dot in the last element of \fIname\fR then returns the empty string. +.\" METHOD: home .TP \fBfile home ?\fIusername\fR? .VS "8.7, TIP 602" @@ -212,14 +232,17 @@ raised if the \fIusername\fR does not correspond to a user account on the system. .RE .VE "8.7, TIP 602" +.\" METHOD: isdirectory .TP \fBfile isdirectory \fIname\fR . Returns \fB1\fR if file \fIname\fR is a directory, \fB0\fR otherwise. +.\" METHOD: isfile .TP \fBfile isfile \fIname\fR . Returns \fB1\fR if file \fIname\fR is a regular file, \fB0\fR otherwise. +.\" METHOD: join .TP \fBfile join \fIname\fR ?\fIname ...\fR? . @@ -240,6 +263,7 @@ Note that any of the names can contain separators, and that the result is always canonical for the current platform: \fB/\fR for Unix and Windows. .RE +.\" METHOD: link .TP \fBfile link\fR ?\fI\-linktype\fR? \fIlinkName\fR ?\fItarget\fR? . @@ -274,17 +298,15 @@ must be relative to the actual \fIlinkName\fR's location (not to the cwd), but on all other platforms where relative links are not supported, target paths will always be converted to absolute, normalized form before the link is created (and therefore relative paths are interpreted -as relative to the cwd). Furthermore, -.QW ~user -paths are always expanded -to absolute form. When creating links on filesystems that either do not +as relative to the cwd). When creating links on filesystems that either do not support any links, or do not support the specific type requested, an error message will be returned. Most Unix platforms support both symbolic and hard links (the latter for files only). Windows supports symbolic directory links and hard file links on NTFS drives. .RE +.\" METHOD: lstat .TP -\fBfile lstat \fIname ?varName?\fR +\fBfile lstat \fIname\fR ?\fIvarName\fR? . Same as \fBstat\fR option (see below) except uses the \fIlstat\fR kernel call instead of \fIstat\fR. This means that if \fIname\fR @@ -292,6 +314,7 @@ refers to a symbolic link the information returned is for the link rather than the file it refers to. On systems that do not support symbolic links this option behaves exactly the same as the \fBstat\fR option. +.\" METHOD: mkdir .TP \fBfile mkdir\fR ?\fIdir\fR ...? . @@ -301,6 +324,7 @@ well as \fIdir\fR itself. If an existing directory is specified, then no action is taken and no error is returned. Trying to overwrite an existing file with a directory will result in an error. Arguments are processed in the order specified, halting at the first error, if any. +.\" METHOD: mtime .TP \fBfile mtime \fIname\fR ?\fItime\fR? . @@ -311,12 +335,14 @@ 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. +.\" METHOD: nativename .TP \fBfile nativename \fIname\fR . Returns the platform-specific name of the file. This is useful if the filename is needed to pass to a platform-specific call, such as to a subprocess via \fBexec\fR under Windows (see \fBEXAMPLES\fR below). +.\" METHOD: normalize .TP \fBfile normalize \fIname\fR . @@ -338,11 +364,13 @@ last link in the path is necessary, because Tcl or the user may wish to operate on the actual symbolic link itself (for example \fBfile delete\fR, \fBfile rename\fR, \fBfile copy\fR are defined to operate on symbolic links, not on the things that they point to). +.\" METHOD: owned .TP \fBfile owned \fIname\fR . Returns \fB1\fR if file \fIname\fR is owned by the current user, \fB0\fR otherwise. +.\" METHOD: pathtype .TP \fBfile pathtype \fIname\fR . @@ -353,11 +381,13 @@ working directory, then the path type will be \fBrelative\fR. If \fIname\fR refers to a file relative to the current working directory on a specified volume, or to a specific file on the current working volume, then the path type is \fBvolumerelative\fR. +.\" METHOD: readable .TP \fBfile readable \fIname\fR . Returns \fB1\fR if file \fIname\fR is readable by the current user, \fB0\fR otherwise. +.\" METHOD: readlink .TP \fBfile readlink \fIname\fR . @@ -365,8 +395,9 @@ Returns the value of the symbolic link given by \fIname\fR (i.e. the name of the file it points to). If \fIname\fR is not a symbolic link or its value cannot be read, then an error is returned. On systems that do not support symbolic links this option is undefined. +.\" METHOD: rename .TP -\fBfile rename \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR +\fBfile rename \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource target\fR .TP \fBfile rename \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR . @@ -384,6 +415,7 @@ result in errors. Arguments are processed in the order specified, halting at the first error, if any. A \fB\-\|\-\fR marks the end of switches; the argument following the \fB\-\|\-\fR will be treated as a \fIsource\fR even if it starts with a \fB\-\fR. +.\" METHOD: rootname .TP \fBfile rootname \fIname\fR . @@ -392,6 +424,7 @@ last .QW . character in the last component of name. If the last component of \fIname\fR does not contain a dot, then returns \fIname\fR. +.\" METHOD: separator .TP \fBfile separator\fR ?\fIname\fR? . @@ -400,12 +433,14 @@ path segments for native files on this platform. If a path is given, the filesystem responsible for that path is asked to return its separator character. If no file system accepts \fIname\fR, an error is generated. +.\" METHOD: size .TP \fBfile size \fIname\fR . Returns a decimal string giving the size of file \fIname\fR in bytes. If the file does not exist or its size cannot be queried then an error is generated. +.\" METHOD: split .TP \fBfile split \fIname\fR . @@ -413,21 +448,9 @@ Returns a list whose elements are the path components in \fIname\fR. The first element of the list will have the same path type as \fIname\fR. All other elements will be relative. Path separators will be discarded unless they are needed to ensure that an element is unambiguously relative. -For example, under Unix -.RS -.PP -.CS -\fBfile split\fR /foo/~bar/baz -.CE -.PP -returns -.QW \fB/\0\0foo\0\0./~bar\0\0baz\fR -to ensure that later commands -that use the third component do not attempt to perform tilde -substitution. -.RE +.\" METHOD: stat .TP -\fBfile stat \fIname ?varName?\fR +\fBfile stat \fIname\fR ?\fIvarName\fR? . Invokes the \fBstat\fR kernel call on \fIname\fR, and returns a dictionary with the information returned from the kernel call. If @@ -441,6 +464,7 @@ field from the \fBstat\fR return structure; see the manual entry for \fBstat\fR for details on the meanings of the values. The \fBtype\fR element gives the type of the file in the same form returned by the command \fBfile type\fR. +.\" METHOD: system .TP \fBfile system \fIname\fR . @@ -462,6 +486,7 @@ to represent a file on a remote ftp site mounted as a virtual filesystem through an extension called .QW vfs . If the file does not belong to any filesystem, an error is generated. +.\" METHOD: tail .TP \fBfile tail \fIname\fR . @@ -470,6 +495,7 @@ Returns all of the characters in the last filesystem component of If \fIname\fR contains no separators then returns \fIname\fR. So, \fBfile tail a/b\fR, \fBfile tail a/b/\fR and \fBfile tail b\fR all return \fBb\fR. +.\" METHOD: tempdir .TP \fBfile tempdir\fR ?\fItemplate\fR? .VS "8.7, TIP 431" @@ -500,9 +526,10 @@ between platforms: .CE .RE .VE "8.7, TIP 431" +.\" METHOD: tempfile .TP \fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR? -'\" TIP #210 +.\" TIP #210 Creates a temporary file and returns a read-write channel opened on that file. If the \fInameVar\fR is given, it specifies a variable that the name of the temporary file will be written into; if absent, Tcl will attempt to arrange @@ -517,28 +544,31 @@ Note that temporary files are \fIonly\fR ever created on the native filesystem. As such, they can be relied upon to be used with operating-system native APIs and external programs that require a filename. .RE +.\" METHOD: tildeexpand .TP \fBfile tildeexpand \fIname\fR .VS "8.7, TIP 602" Returns the result of performing tilde substitution on \fIname\fR. If the name begins with a tilde, then the file name will be interpreted as if the first element is replaced with the location of the home directory for the given user. -If the tilde is followed immediately by a path separator, the \fBHOME\fR +If the tilde is followed immediately by a path separator, the \fB$HOME\fR environment variable is substituted. Otherwise the characters between the tilde and the next separator are taken as a user name, which is used to retrieve the user's home directory for substitution. An error is raised if the -\fBHOME\fR environment variable or user does not exist. +\fB$HOME\fR environment variable or user does not exist. .RS .PP If the file name does not begin with a tilde, it is returned unmodified. .RE .VE "8.7, TIP 602" +.\" METHOD: type .TP \fBfile type \fIname\fR . Returns a string giving the type of file \fIname\fR, which will be one of \fBfile\fR, \fBdirectory\fR, \fBcharacterSpecial\fR, \fBblockSpecial\fR, \fBfifo\fR, \fBlink\fR, or \fBsocket\fR. +.\" METHOD: volumes .TP \fBfile volumes\fR . @@ -552,6 +582,7 @@ On Windows, it will return a list of the available local drives .QW "a:/ c:/" ). If any virtual filesystem has mounted additional volumes, they will be in the returned list. +.\" METHOD: writable .TP \fBfile writable \fIname\fR . @@ -559,12 +590,12 @@ Returns \fB1\fR if file \fIname\fR is writable by the current user, \fB0\fR otherwise. .SH "PORTABILITY ISSUES" .TP -\fBUnix\fR\0\0\0\0\0\0\0 +\fBUnix\fR . These commands always operate using the real user and group identifiers, not the effective ones. .TP -\fBWindows\fR\0\0\0\0 +\fBWindows\fR . The \fBfile owned\fR subcommand uses the user identifier (SID) of the process token, not the thread token which may be impersonating @@ -586,7 +617,7 @@ proc findMatchingCFiles {dir} { set ext .o } } - foreach file [glob \-nocomplain \-directory $dir *.c] { + foreach file [glob -nocomplain -directory $dir *.c] { set objectFile [\fBfile tail\fR [\fBfile rootname\fR $file]]$ext if {[\fBfile exists\fR $objectFile]} { lappend files $file @@ -607,7 +638,7 @@ if {![\fBfile isdirectory\fR [\fBfile dirname\fR $newName]]} { \fBfile mkdir\fR [\fBfile dirname\fR $newName] } \fBfile rename\fR $oldName $newName -\fBfile link\fR \-symbolic $oldName $newName +\fBfile link\fR -symbolic $oldName $newName .CE .PP On Windows, a file can be @@ -617,7 +648,7 @@ interface) but the name passed to the operating system must be in native format: .PP .CS -exec {*}[auto_execok start] {} [\fBfile nativename\fR ~/example.txt] +exec {*}[auto_execok start] {} [\fBfile nativename\fR C:/Users/fred/example.txt] .CE .SH "SEE ALSO" filename(n), open(n), close(n), eof(n), gets(n), tell(n), seek(n), diff --git a/doc/fileevent.n b/doc/fileevent.n index bbba997..c302b39 100644 --- a/doc/fileevent.n +++ b/doc/fileevent.n @@ -17,7 +17,6 @@ fileevent \- Execute a script when a channel becomes readable or writable .sp \fBfileevent \fIchannelId \fBwritable \fR?\fIscript\fR? .BE - .SH DESCRIPTION .PP This command is used to create \fIfile event handlers\fR. A file event diff --git a/doc/filename.n b/doc/filename.n index d8a3364..373a8ee 100644 --- a/doc/filename.n +++ b/doc/filename.n @@ -41,6 +41,7 @@ The rules for native names depend on the value reported in the Tcl \fBplatform\fR element of the \fBtcl_platform\fR array: .TP 10 \fBUnix\fR +. On Unix and Apple MacOS X platforms, Tcl uses path names where the components are separated by slashes. Path names may be relative or absolute, and file names may contain any character other than slash. @@ -58,28 +59,35 @@ The following examples illustrate various forms of path names: .TP 15 \fB/\fR +. Absolute path to the root directory. .TP 15 \fB/etc/passwd\fR +. Absolute path to the file named \fBpasswd\fR in the directory \fBetc\fR in the root directory. .TP 15 \fB\&.\fR +. Relative path to the current directory. .TP 15 \fBfoo\fR +. Relative path to the file \fBfoo\fR in the current directory. .TP 15 \fBfoo/bar\fR +. Relative path to the file \fBbar\fR in the directory \fBfoo\fR in the current directory. .TP 15 \fB\&../foo\fR +. Relative path to the file \fBfoo\fR in the directory above the current directory. .RE .TP \fBWindows\fR +. On Microsoft Windows platforms, Tcl supports both drive-relative and UNC style names. Both \fB/\fR and \fB\e\fR may be used as directory separators in either type of name. Drive-relative names consist of an optional drive @@ -93,28 +101,34 @@ following examples illustrate various forms of path names: .RS .TP 15 \fB\&\e\eHost\eshare/file\fR +. Absolute UNC path to a file called \fBfile\fR in the root directory of the export point \fBshare\fR on the host \fBHost\fR. Note that repeated use of \fBfile dirname\fR on this path will give \fB//Host/share\fR, and will never give just \fB//Host\fR. .TP 15 \fBc:foo\fR +. Volume-relative path to a file \fBfoo\fR in the current directory on drive \fBc\fR. .TP 15 \fBc:/foo\fR +. Absolute path to a file \fBfoo\fR in the root directory of drive \fBc\fR. .TP 15 \fBfoo\ebar\fR +. Relative path to a file \fBbar\fR in the \fBfoo\fR directory in the current directory on the current volume. .TP 15 \fB\&\efoo\fR +. Volume-relative path to a file \fBfoo\fR in the root directory of the current volume. .TP 15 \fB\&\e\efoo\fR +. 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. @@ -128,24 +142,20 @@ Zipfs paths are case-sensitive on all platforms. .RE .SH "TILDE SUBSTITUTION" .PP -In addition to the file name rules described above, Tcl also supports -\fIcsh\fR-style tilde substitution. If a file name starts with a tilde, -then the file name will be interpreted as if the first element is -replaced with the location of the home directory for the given user. If -the tilde is followed immediately by a separator, then the \fB$HOME\fR -environment variable is substituted. Otherwise the characters between -the tilde and the next separator are taken as a user name, which is used -to retrieve the user's home directory for substitution. This works on -Unix, MacOS X and Windows (except very old releases). +Unlike earlier versions of Tcl, Tcl 9 does not do implicit tilde substitution +on file paths with the exception noted below. The commands \fBfile home\fR and +\fBfile tildeexpand\fR may be used to explicitly accomplish the same. .PP -Old Windows platforms do not support tilde substitution when a user name -follows the tilde. On these platforms, attempts to use a tilde followed -by a user name will generate an error that the user does not exist when -Tcl attempts to interpret that part of the path or otherwise access the -file. The behaviour of these paths when not trying to interpret them is -the same as on Unix. File names that have a tilde without a user name -will be correctly substituted using the \fB$HOME\fR environment -variable, just like for Unix. +The exception to the above is initialization of the \fBauto_path\fR variable +and the Tcl module search paths as documented in the manpages for +\fBtclvars\fR and \fBtm\fR. When any path in an environment variable used to +initialize these starts with a tilde, it will be interpreted as if the first +element is replaced with the location of the home directory for the given +user. If the tilde is followed immediately by a separator, the +\fB$HOME\fR environment variable is substituted. Otherwise the characters +between the tilde and the next separator are taken as a user name, which is +used to retrieve the user's home directory for substitution. This works on +POSIX, MacOS X and Windows platforms. .SH "PORTABILITY ISSUES" .PP Not all file systems are case sensitive, so scripts should avoid code @@ -14,7 +14,6 @@ for \- 'For' loop .SH SYNOPSIS \fBfor \fIstart test next body\fR .BE - .SH DESCRIPTION .PP \fBFor\fR is a looping command, similar in structure to the C @@ -38,7 +37,7 @@ The operation of \fBbreak\fR and \fBcontinue\fR are similar to the corresponding statements in C. \fBFor\fR returns an empty string. .PP -Note: \fItest\fR should almost always be enclosed in braces. If not, +Note that \fItest\fR should almost always be enclosed in braces. If not, variable substitutions will be made before the \fBfor\fR command starts executing, which means that variable changes made by the loop body will not be considered in the expression. diff --git a/doc/foreach.n b/doc/foreach.n index 43f961a..1f9f88e 100644 --- a/doc/foreach.n +++ b/doc/foreach.n @@ -16,7 +16,6 @@ foreach \- Iterate over all elements in one or more lists .br \fBforeach \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR .BE - .SH DESCRIPTION .PP The \fBforeach\fR command implements a loop where the loop @@ -96,10 +95,8 @@ set x {} # The value of x is "a d e b f g c {} {}" # There are 3 iterations of the loop. .CE - .SH "SEE ALSO" for(n), while(n), break(n), continue(n) - .SH KEYWORDS foreach, iteration, list, loop '\" Local Variables: diff --git a/doc/format.n b/doc/format.n index eb64491..79de204 100644 --- a/doc/format.n +++ b/doc/format.n @@ -14,7 +14,6 @@ format \- Format a string in the style of sprintf .SH SYNOPSIS \fBformat \fIformatString \fR?\fIarg arg ...\fR? .BE - .SH INTRODUCTION .PP This command generates a formatted string in a fashion similar to the @@ -64,25 +63,20 @@ then all of the specifiers must be positional. .PP The second portion of a conversion specifier may contain any of the following flag characters, in any order: -.TP 10 -\fB\-\fR +.IP \fB\-\fR 10 Specifies that the converted argument should be left-justified in its field (numbers are normally right-justified with leading spaces if needed). -.TP 10 -\fB+\fR +.IP \fB+\fR 10 Specifies that a number should always be printed with a sign, even if positive. -.TP 10 -\fIspace\fR +.IP \fIspace\fR 10 Specifies that a space should be added to the beginning of the number if the first character is not a sign. -.TP 10 -\fB0\fR +.IP \fB0\fR 10 Specifies that the number should be padded on the left with zeroes instead of spaces. -.TP 10 -\fB#\fR +.IP \fB#\fR 10 Requests an alternate output form. For \fBo\fR conversions, \fB0o\fR will be added to the beginning of the result unless it is zero. For \fBx\fR or \fBX\fR conversions, \fB0x\fR @@ -126,8 +120,8 @@ be omitted unless the \fB#\fR flag has been specified). For integer conversions, it specifies a minimum number of digits to print (leading zeroes will be added if necessary). For \fBs\fR conversions it specifies the maximum number of characters to be -printed; if the string is longer than this then the trailing characters will be dropped. -If the precision is specified with \fB*\fR rather than a number +printed; if the string is longer than this then the trailing characters will +be dropped. If the precision is specified with \fB*\fR rather than a number then the next argument to the \fBformat\fR command determines the precision; it must be a numeric string. .SS "OPTIONAL SIZE MODIFIER" @@ -153,67 +147,53 @@ determined by the value of the \fBwordSize\fR element of the The last thing in a conversion specifier is an alphabetic character that determines what kind of conversion to perform. The following conversion characters are currently supported: -.TP 10 -\fBd\fR +.IP \fBd\fR 10 Convert integer to signed decimal string. -.TP 10 -\fBu\fR +.IP \fBu\fR 10 Convert integer to unsigned decimal string. -.TP 10 -\fBi\fR +.IP \fBi\fR 10 Convert integer to signed decimal string (equivalent to \fBd\fR). -.TP 10 -\fBo\fR +.IP \fBo\fR 10 Convert integer to unsigned octal string. -.TP 10 -\fBx\fR or \fBX\fR +.IP "\fBx\fR or \fBX\fR" 10 Convert integer to unsigned hexadecimal string, using digits .QW 0123456789abcdef for \fBx\fR and .QW 0123456789ABCDEF for \fBX\fR). -.TP 10 -\fBb\fR +.IP \fBb\fR 10 Convert integer to unsigned binary string, using digits 0 and 1. -.TP 10 -\fBc\fR +.IP \fBc\fR 10 Convert integer to the Unicode character it represents. -.TP 10 -\fBs\fR +.IP \fBs\fR 10 No conversion; just insert string. -.TP 10 -\fBf\fR +.IP \fBf\fR 10 Convert number to signed decimal string of the form \fIxx.yyy\fR, where the number of \fIy\fR's is determined by the precision (default: 6). If the precision is 0 then no decimal point is output. -.TP 10 -\fBe\fR or \fBE\fR +.IP "\fBe\fR or \fBE\fR" 10 Convert number to scientific notation in the form \fIx.yyy\fBe\(+-\fIzz\fR, where the number of \fIy\fR's is determined by the precision (default: 6). If the precision is 0 then no decimal point is output. If the \fBE\fR form is used then \fBE\fR is printed instead of \fBe\fR. -.TP 10 -\fBg\fR or \fBG\fR +.IP "\fBg\fR or \fBG\fR" 10 If the exponent is less than \-4 or greater than or equal to the precision, then convert number as for \fB%e\fR or \fB%E\fR. Otherwise convert as for \fB%f\fR. Trailing zeroes and a trailing decimal point are omitted. -.TP 10 -\fBa\fR or \fBA\fR +.IP "\fBa\fR or \fBA\fR" 10 Convert double to hexadecimal notation in the form \fI0x1.yyy\fBp\(+-\fIzz\fR, where the number of \fIy\fR's is determined by the precision (default: 13). If the \fBA\fR form is used then the hex characters are printed in uppercase. -.TP 10 -\fB%\fR +.IP \fB%\fR 10 No conversion: just insert \fB%\fR. -.TP 10 -\fBp\fR +.IP \fBp\fR 10 Shorthand form for \fB0x%zx\fR, so it outputs the integer in hexadecimal form with \fB0x\fR prefix. .SH "DIFFERENCES FROM ANSI SPRINTF" diff --git a/doc/fpclassify.n b/doc/fpclassify.n index 22d365e..18722dc 100644 --- a/doc/fpclassify.n +++ b/doc/fpclassify.n @@ -19,26 +19,16 @@ package require \fBtcl 8.7\fR .SH DESCRIPTION The \fBfpclassify\fR command takes a floating point number, \fIvalue\fR, and returns one of the following strings that describe it: -.TP -\fBzero\fR -. +.IP \fBzero\fR \fIvalue\fR is a floating point zero. -.TP -\fBsubnormal\fR -. +.IP \fBsubnormal\fR \fIvalue\fR is the result of a gradual underflow. -.TP -\fBnormal\fR -. +.IP \fBnormal\fR \fIvalue\fR is an ordinary floating-point number (not zero, subnormal, infinite, nor NaN). -.TP -\fBinfinite\fR -. +.IP \fBinfinite\fR \fIvalue\fR is a floating-point infinity. -.TP -\fBnan\fR -. +.IP \fBnan\fR \fIvalue\fR is Not-a-Number. .PP The \fBfpclassify\fR command throws an error if value is not a floating-point @@ -76,7 +66,7 @@ This command depends on the \fBfpclassify\fR() C macro conforming to (i.e., to ISO/IEC 9899:1999). .SH COPYRIGHT .nf -Copyright \(co 2018 by Kevin B. Kenny <kennykb@acm.org>. All rights reserved +Copyright \(co 2018 Kevin B. Kenny <kennykb@acm.org>. All rights reserved .fi '\" Local Variables: '\" mode: nroff @@ -14,7 +14,6 @@ gets \- Read a line from a channel .SH SYNOPSIS \fBgets \fIchannelId\fR ?\fIvarName\fR? .BE - .SH DESCRIPTION .PP This command reads the next line from \fIchannelId\fR, returns everything @@ -96,10 +95,8 @@ while {[\fBgets\fR $chan line] >= 0} { } close $chan .CE - .SH "SEE ALSO" file(n), eof(n), fblocked(n), Tcl_StandardChannels(3) - .SH KEYWORDS blocking, channel, end of file, end of line, line, non-blocking, read '\" Local Variables: @@ -28,8 +28,9 @@ in the list, so if a sorted list is required the caller should use If the initial arguments to \fBglob\fR start with \fB\-\fR then they are treated as switches. The following switches are currently supported: +.\" OPTION: -directory .TP -\fB\-directory\fR \fIdirectory\fR +\fB\-directory\fI directory\fR . Search for files which match the given patterns starting in the given \fIdirectory\fR. This allows searching of directories whose name @@ -37,19 +38,22 @@ contains glob-sensitive characters without the need to quote such characters explicitly. This option may not be used in conjunction with \fB\-path\fR, which is used to allow searching for complete file paths whose names may contain glob-sensitive characters. +.\" OPTION: -join .TP \fB\-join\fR . The remaining pattern arguments, after option processing, are treated as a single pattern obtained by joining the arguments with directory separators. +.\" OPTION: -nocomplain .TP \fB\-nocomplain\fR . -Allows an empty list to be returned without error; without this -switch an error is returned if the result list would be empty. +Allows an empty list to be returned without error; This is the +default behavior in Tcl 9.0, so this switch has no effect any more. +.\" OPTION: -path .TP -\fB\-path\fR \fIpathPrefix\fR +\fB\-path\fI pathPrefix\fR . Search for files with the given \fIpathPrefix\fR where the rest of the name matches the given patterns. This allows searching for files with names @@ -61,6 +65,7 @@ as $path, but differing extensions, you should use .QW "\fBglob \-path [file rootname $path] .*\fR" which will work even if \fB$path\fR contains numerous glob-sensitive characters. +.\" OPTION: -tails .TP \fB\-tails\fR . @@ -72,10 +77,11 @@ is equivalent to .QW "\fBset pwd [pwd]; cd $dir; glob *; cd $pwd\fR" . For \fB\-path\fR specifications, the returned names will include the last path segment, so -.QW "\fBglob \-tails \-path [file rootname ~/foo.tex] .*\fR" +.QW "\fBglob \-tails \-path [file rootname /home/fred/foo.tex] .*\fR" will return paths like \fBfoo.aux foo.bib foo.tex\fR etc. +.\" OPTION: -types .TP -\fB\-types\fR \fItypeList\fR +\fB\-types\fI typeList\fR . Only list files or directories which match \fItypeList\fR, where the items in the list have two forms. The first form is like the \-type option of @@ -116,6 +122,7 @@ except that the first case doesn't return the trailing .QW / and is more platform independent. .RE +.\" OPTION: -- .TP \fB\-\|\-\fR . @@ -126,27 +133,17 @@ be treated as a \fIpattern\fR even if it starts with a \fB\-\fR. The \fIpattern\fR arguments may contain any of the following special characters, which are a superset of those supported by \fBstring match\fR: -.TP 10 -\fB?\fR -. +.IP \fB?\fR 10 Matches any single character. -.TP 10 -\fB*\fR -. +.IP \fB*\fR 10 Matches any sequence of zero or more characters. -.TP 10 -\fB[\fIchars\fB]\fR -. +.IP \fB[\fIchars\fB]\fR 10 Matches any single character in \fIchars\fR. If \fIchars\fR contains a sequence of the form \fIa\fB\-\fIb\fR then any character between \fIa\fR and \fIb\fR (inclusive) will match. -.TP 10 -\fB\e\fIx\fR -. +.IP \fB\e\fIx\fR 10 Matches the character \fIx\fR. -.TP 10 -\fB{\fIa\fB,\fIb\fB,\fI...\fR} -. +.IP \fB{\fIa\fB,\fIb\fB,\fI...\fB}\fR 10 Matches any of the sub-patterns \fIa\fR, \fIb\fR, etc. .PP On Unix, as with csh, a @@ -168,16 +165,6 @@ which must be matched explicitly (this is to avoid a recursive pattern like from recursing up the directory hierarchy as well as down). In addition, all .QW / characters must be matched explicitly. -.LP -If the first character in a \fIpattern\fR is -.QW ~ -then it refers to the home directory for the user whose name follows the -.QW ~ . -If the -.QW ~ -is followed immediately by -.QW / -then the value of the HOME environment variable is used. .PP The \fBglob\fR command differs from csh globbing in two ways. First, it does not sort its result list (use the \fBlsort\fR @@ -185,26 +172,10 @@ command if you want the list sorted). Second, \fBglob\fR only returns the names of files that actually exist; in csh no check for existence is made unless a pattern contains a ?, *, or [] construct. -.LP -When the \fBglob\fR command returns relative paths whose filenames -start with a tilde -.QW ~ -(for example through \fBglob *\fR or \fBglob \-tails\fR, the returned -list will not quote the tilde with -.QW ./ . -This means care must be taken if those names are later to -be used with \fBfile join\fR, to avoid them being interpreted as -absolute paths pointing to a given user's home directory. .SH "WINDOWS PORTABILITY ISSUES" .PP For Windows UNC names, the servername and sharename components of the path -may not contain ?, *, or [] constructs. On Windows NT, if \fIpattern\fR is -of the form -.QW \fB~\fIusername\fB@\fIdomain\fR , -it refers to the home -directory of the user whose account information resides on the specified NT -domain server. Otherwise, user account information is obtained from -the local computer. +may not contain ?, *, or [] constructs. .PP Since the backslash character has a special meaning to the glob command, glob patterns containing Windows style path separators need @@ -239,7 +210,7 @@ Find all the Tcl files in the user's home directory, irrespective of what the current directory is: .PP .CS -\fBglob\fR \-directory ~ *.tcl +\fBglob\fR \-directory [file home] *.tcl .CE .PP Find all subdirectories of the current directory: diff --git a/doc/history.n b/doc/history.n index 05d936e..1c2b581 100644 --- a/doc/history.n +++ b/doc/history.n @@ -37,16 +37,20 @@ matches the event in the sense of the \fBstring match\fR command. The \fBhistory\fR command can take any of the following forms: .TP \fBhistory\fR -Same -as \fBhistory info\fR, described below. +. +Same as \fBhistory info\fR, described below. +.\" METHOD: add .TP \fBhistory add\fI command \fR?\fBexec\fR? +. Adds the \fIcommand\fR argument to the history list as a new event. If \fBexec\fR is specified (or abbreviated) then the command is also executed and its result is returned. If \fBexec\fR is not specified then an empty string is returned as result. +.\" METHOD: change .TP \fBhistory change\fI newValue\fR ?\fIevent\fR? +. Replaces the value recorded for an event with \fInewValue\fR. \fIEvent\fR specifies the event to replace, and defaults to the \fIcurrent\fR event (not event \fB\-1\fR). This command @@ -54,32 +58,44 @@ is intended for use in commands that implement new forms of history substitution and wish to replace the current event (which invokes the substitution) with the command created through substitution. The return value is an empty string. +.\" METHOD: clear .TP \fBhistory clear\fR +. Erase the history list. The current keep limit is retained. The history event numbers are reset. +.\" METHOD: event .TP \fBhistory event\fR ?\fIevent\fR? +. Returns the value of the event given by \fIevent\fR. \fIEvent\fR defaults to \fB\-1\fR. +.\" METHOD: info .TP \fBhistory info \fR?\fIcount\fR? +. Returns a formatted string (intended for humans to read) giving the event number and contents for each of the events in the history list except the current event. If \fIcount\fR is specified then only the most recent \fIcount\fR events are returned. +.\" METHOD: keep .TP \fBhistory keep \fR?\fIcount\fR? +. This command may be used to change the size of the history list to \fIcount\fR events. Initially, 20 events are retained in the history list. If \fIcount\fR is not specified, the current keep limit is returned. +.\" METHOD: nextid .TP \fBhistory nextid\fR +. Returns the number of the next event to be recorded in the history list. It is useful for things like printing the event number in command-line prompts. +.\" METHOD: redo .TP \fBhistory redo \fR?\fIevent\fR? +. Re-executes the command indicated by \fIevent\fR and returns its result. \fIEvent\fR defaults to \fB\-1\fR. This command results in history revision: see below for details. @@ -93,8 +109,8 @@ history operations \fBsubstitute\fR and \fBwords\fR have been removed. The history option \fBredo\fR results in much simpler .QW "history revision" . When this option is invoked then the most recent event -is modified to eliminate the history command and replace it with -the result of the history command. +is modified to eliminate the \fBhistory\fR command and replace it with +the result of the \fBhistory\fR command. If you want to redo an event without modifying history, then use the \fBevent\fR operation to retrieve some event, and the \fBadd\fR operation to add it to history and execute it. @@ -13,66 +13,40 @@ .SH NAME http \- Client-side implementation of the HTTP/1.1 protocol .SH SYNOPSIS +.nf \fBpackage require http\fR ?\fB2.10\fR? .\" See Also -useragent option documentation in body! -.sp + \fB::http::config\fR ?\fI\-option value\fR ...? -.sp \fB::http::geturl \fIurl\fR ?\fI\-option value\fR ...? -.sp -\fB::http::formatQuery\fR \fIkey value\fR ?\fIkey value\fR ...? -.sp -\fB::http::quoteString\fR \fIvalue\fR -.sp -\fB::http::reset\fR \fItoken\fR ?\fIwhy\fR? -.sp +\fB::http::formatQuery\fI key value\fR ?\fIkey value\fR ...? +\fB::http::quoteString\fI value\fR +\fB::http::reset\fI token\fR ?\fIwhy\fR? \fB::http::wait \fItoken\fR -.sp \fB::http::status \fItoken\fR -.sp \fB::http::size \fItoken\fR -.sp \fB::http::error \fItoken\fR -.sp \fB::http::postError \fItoken\fR -.sp \fB::http::cleanup \fItoken\fR -.sp -\fB::http::requestLine\fR \fItoken\fR -.sp -\fB::http::requestHeaders\fR \fItoken\fR ?\fIheaderName\fR? -.sp -\fB::http::requestHeaderValue\fR \fItoken\fR \fIheaderName\fR -.sp -\fB::http::responseLine\fR \fItoken\fR -.sp -\fB::http::responseCode\fR \fItoken\fR -.sp -\fB::http::reasonPhrase\fR \fIcode\fR -.sp -\fB::http::responseHeaders\fR \fItoken\fR ?\fIheaderName\fR? -.sp -\fB::http::responseHeaderValue\fR \fItoken\fR \fIheaderName\fR -.sp -\fB::http::responseInfo\fR \fItoken\fR -.sp -\fB::http::responseBody\fR \fItoken\fR -.sp +\fB::http::requestLine\fI token\fR +\fB::http::requestHeaders\fI token\fR ?\fIheaderName\fR? +\fB::http::requestHeaderValue\fI token headerName\fR +\fB::http::responseLine\fI token\fR +\fB::http::responseCode\fI token\fR +\fB::http::reasonPhrase\fI code\fR +\fB::http::responseHeaders\fI token\fR ?\fIheaderName\fR? +\fB::http::responseHeaderValue\fI token headerName\fR +\fB::http::responseInfo\fI token\fR +\fB::http::responseBody\fI token\fR \fB::http::register \fIproto port command\fR ?\fIsocketCmdVarName\fR? ?\fIuseSockThread\fR? ?\fIendToEndProxy\fR? -.sp \fB::http::registerError \fIsock\fR ?\fImessage\fR? -.sp \fB::http::unregister \fIproto\fR -.sp \fB::http::code \fItoken\fR -.sp \fB::http::data \fItoken\fR -.sp \fB::http::meta \fItoken\fR ?\fIheaderName\fR? -.sp -\fB::http::metaValue\fR \fItoken\fR \fIheaderName\fR -.sp +\fB::http::metaValue\fI token headerName\fR \fB::http::ncode \fItoken\fR +.fi .SH "EXPORTED COMMANDS" .PP Namespace \fBhttp\fR exports the commands \fBconfig\fR, \fBformatQuery\fR, @@ -130,6 +104,7 @@ The response itself is returned by command \fB::http::responseBody\fR, unless it has been redirected to a file by the \fI\-channel\fR option of \fB::http::geturl\fR. .SH COMMANDS +.\" COMMAND: config .TP \fB::http::config\fR ?\fIoptions\fR? . @@ -141,16 +116,18 @@ of the flags described below. In this case the current value of that setting is returned. Otherwise, the options should be a set of flags and values that define the configuration: .RS +.\" OPTION: -accept .TP -\fB\-accept\fR \fImimetypes\fR +\fB\-accept\fI mimetypes\fR . The Accept header of the request. The default is */*, which means that all types of documents are accepted. Otherwise you can supply a comma-separated list of mime type patterns that you are willing to receive. For example, .QW "image/gif, image/jpeg, text/*" . +.\" OPTION: -cookiejar .TP -\fB\-cookiejar\fR \fIcommand\fR +\fB\-cookiejar\fI command\fR .VS TIP406 The cookie store for the package to use to manage HTTP cookies. \fIcommand\fR is a command prefix list; if the empty list (the @@ -158,21 +135,24 @@ default value) is used, no cookies will be sent by requests or stored from responses. The command indicated by \fIcommand\fR, if supplied, must obey the \fBCOOKIE JAR PROTOCOL\fR described below. .VE TIP406 +.\" OPTION: -pipeline .TP -\fB\-pipeline\fR \fIboolean\fR +\fB\-pipeline\fI boolean\fR . Specifies whether HTTP/1.1 transactions on a persistent socket will be pipelined. See the \fBPERSISTENT SOCKETS\fR section for details. The default is 1. +.\" OPTION: -postfresh .TP -\fB\-postfresh\fR \fIboolean\fR +\fB\-postfresh\fI boolean\fR . Specifies whether requests that use the \fBPOST\fR method will always use a fresh socket, overriding the \fB\-keepalive\fR option of command \fBhttp::geturl\fR. See the \fBPERSISTENT SOCKETS\fR section for details. The default is 0. +.\" OPTION: -proxyauth .TP -\fB\-proxyauth\fR \fIstring\fR +\fB\-proxyauth\fI string\fR . If non-empty, the string is supplied to the proxy server as the value of the request header Proxy-Authorization. This option can be used for HTTP Basic @@ -181,8 +161,9 @@ technique, e.g. Digest Authentication, the \fB\-proxyauth\fR option is not useful. In that case the caller must expect a 407 response from the proxy, compute the authentication value to be supplied, and use the \fB\-headers\fR option to supply it as the value of the Proxy-Authorization header. +.\" OPTION: -proxyfilter .TP -\fB\-proxyfilter\fR \fIcommand\fR +\fB\-proxyfilter\fI command\fR . The command is a callback that is made during \fB::http::geturl\fR @@ -208,14 +189,16 @@ a \fBcatch\fR command. Therefore an error in the callback command does not call the \fBbgerror\fR handler. See the \fBERRORS\fR section for details. .RE +.\" OPTION: -proxyhost .TP -\fB\-proxyhost\fR \fIhostname\fR +\fB\-proxyhost\fI hostname\fR . The host name or IP address of the proxy server, if any. If this value is the empty string, the URL host is contacted directly. See \fB\-proxyfilter\fR for how the value is used. +.\" OPTION: -proxynot .TP -\fB\-proxynot\fR \fIlist\fR +\fB\-proxynot\fI list\fR . A Tcl list of domain names and IP addresses that should be accessed directly, not through the proxy server. The target hostname is compared with each list @@ -223,13 +206,15 @@ element using a case-insensitive \fBstring match\fR. It is often convenient to use the wildcard "*" at the start of a domain name (e.g. *.example.com) or at the end of an IP address (e.g. 192.168.0.*). See \fB\-proxyfilter\fR for how the value is used. +.\" OPTION: -proxyport .TP -\fB\-proxyport\fR \fInumber\fR +\fB\-proxyport\fI number\fR . The port number of the proxy server. See \fB\-proxyfilter\fR for how the value is used. +.\" OPTION: -repost .TP -\fB\-repost\fR \fIboolean\fR +\fB\-repost\fI boolean\fR . Specifies what to do if a POST request over a persistent connection fails because the server has half-closed the connection. If boolean \fBtrue\fR, the @@ -240,32 +225,36 @@ that uses \fBhttp::geturl\fR is expected to seek user confirmation before retrying the POST. The value \fBtrue\fR should be used only under certain conditions. See the \fBPERSISTENT SOCKETS\fR section for details. The default is 0. +.\" OPTION: -threadlevel .TP -\fB\-threadlevel\fR \fIlevel\fR +\fB\-threadlevel\fI level\fR . Specifies whether and how to use the \fBThread\fR package. Possible values of \fIlevel\fR are 0, 1 or 2. .RS +.IP \fB0\fR +(the default) do not use Thread +.IP \fB1\fR +use Thread if it is available, do not use it if it is unavailable +.IP \fB2\fR +use Thread if it is available, raise an error if it is unavailable .PP -.DS -0 - (the default) do not use Thread -1 - use Thread if it is available, do not use it if it is unavailable -2 - use Thread if it is available, raise an error if it is unavailable -.DE The Tcl \fBsocket -async\fR command can block in adverse cases (e.g. a slow DNS lookup). Using the Thread package works around this problem, for both HTTP and HTTPS transactions. Values of \fIlevel\fR other than 0 are available only to the main interpreter in each thread. See section \fBTHREADS\fR for more information. .RE +.\" OPTION: -urlencoding .TP -\fB\-urlencoding\fR \fIencoding\fR +\fB\-urlencoding\fI encoding\fR . The \fIencoding\fR used for creating the x-url-encoded URLs with \fB::http::formatQuery\fR and \fB::http::quoteString\fR. The default is \fButf-8\fR, as specified by RFC 2718. +.\" OPTION: -useragent .TP -\fB\-useragent\fR \fIstring\fR +\fB\-useragent\fI string\fR . The value of the User-Agent header in the HTTP request. In an unsafe interpreter, the default value depends upon the operating system, and @@ -274,8 +263,9 @@ the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example) A safe interpreter cannot determine its operating system, and so the default in a safe interpreter is to use a Windows 10 value with the current version numbers of \fBhttp\fR and \fBTcl\fR. +.\" OPTION: -zip .TP -\fB\-zip\fR \fIboolean\fR +\fB\-zip\fI boolean\fR . If the value is boolean \fBtrue\fR, then by default requests will send a header .QW "\fBAccept-Encoding: gzip,deflate\fR" . @@ -285,8 +275,9 @@ In either case the default can be overridden for an individual request by supplying a custom \fBAccept-Encoding\fR header in the \fB\-headers\fR option of \fBhttp::geturl\fR. The default value is 1. .RE +.\" COMMAND: geturl .TP -\fB::http::geturl\fR \fIurl\fR ?\fIoptions\fR? +\fB::http::geturl\fI url\fR ?\fIoptions\fR? . The \fB::http::geturl\fR command is the main procedure in the package. The \fB\-query\fR or \fB\-querychannel\fR option causes a POST operation and @@ -300,26 +291,30 @@ completes, unless the \fB\-command\fR option specifies a callback that is invoked when the HTTP transaction completes. \fB::http::geturl\fR takes several options: .RS +.\" OPTION: -binary .TP -\fB\-binary\fR \fIboolean\fR +\fB\-binary\fI boolean\fR . Specifies whether to force interpreting the URL data as binary. Normally this is auto-detected (anything not beginning with a \fBtext\fR content type or whose content encoding is \fBgzip\fR or \fBdeflate\fR is considered binary data). +.\" OPTION: -blocksize .TP -\fB\-blocksize\fR \fIsize\fR +\fB\-blocksize\fI size\fR . The block size used when reading the URL. At most \fIsize\fR bytes are read at once. After each block, a call to the \fB\-progress\fR callback is made (if that option is specified). +.\" OPTION: -channel .TP -\fB\-channel\fR \fIname\fR +\fB\-channel\fI name\fR . Copy the URL contents to channel \fIname\fR instead of saving it in a Tcl variable for retrieval by \fB::http::responseBody\fR. +.\" OPTION: -command .TP -\fB\-command\fR \fIcallback\fR +\fB\-command\fI callback\fR . The presence of this option causes \fB::http::geturl\fR to return immediately. After the HTTP transaction completes, the value of \fIcallback\fR is expanded, @@ -344,8 +339,9 @@ a \fBcatch\fR command. Therefore an error in the callback command does not call the \fBbgerror\fR handler. See the \fBERRORS\fR section for details. .RE +.\" OPTION: -guesstype .TP -\fB\-guesstype\fR \fIboolean\fR +\fB\-guesstype\fI boolean\fR . Attempt to guess the \fBContent-Type\fR and character set when a misconfigured server provides no information. The default value is \fIfalse\fR (do @@ -357,9 +353,10 @@ detecting XML documents that begin with an XML declaration. In this case the \fBContent-Type\fR is changed to "application/xml", the binary flag state(binary) is changed to 0, and the character set is changed to the one specified by the "encoding" tag of the XML line, or to utf-8 if no -encoding is specified. Not used if a \fI\-channel\fR is specified. +encoding is specified. Not used if a \fB\-channel\fR is specified. +.\" OPTION: -handler .TP -\fB\-handler\fR \fIcallback\fR +\fB\-handler\fI callback\fR . If this option is absent, \fBhttp::geturl\fR processes incoming data itself, either appending it to the state(body) variable or writing it to the -channel. @@ -405,8 +402,9 @@ a \fBcatch\fR command. Therefore an error in the callback command does not call the \fBbgerror\fR handler. See the \fBERRORS\fR section for details. .RE +.\" OPTION: -headers .TP -\fB\-headers\fR \fIkeyvaluelist\fR +\fB\-headers\fI keyvaluelist\fR . This option is used to add headers not already specified by \fB::http::config\fR to the HTTP request. The @@ -422,13 +420,15 @@ HTTP request: Pragma: no-cache .CE .RE +.\" OPTION: -keepalive .TP -\fB\-keepalive\fR \fIboolean\fR +\fB\-keepalive\fI boolean\fR . If boolean \fBtrue\fR, attempt to keep the connection open for servicing multiple requests. Default is 0. +.\" OPTION: -method .TP -\fB\-method\fR \fItype\fR +\fB\-method\fI type\fR . Force the HTTP request method to \fItype\fR. \fB::http::geturl\fR will auto-select GET, POST or HEAD based on other options, but this option overrides @@ -437,20 +437,22 @@ that selection and enables choices like PUT and DELETE for WebDAV support. .PP It is the caller's responsibility to ensure that the headers and request body (if any) conform to the requirements of the request method. For example, if -using \fB\-method\fR \fIPOST\fR to send a POST with an empty request body, the +using \fB\-method\fI POST\fR to send a POST with an empty request body, the caller must also supply the option .PP .CS \-headers {Content-Length 0} .CE .RE +.\" OPTION: -myaddr .TP -\fB\-myaddr\fR \fIaddress\fR +\fB\-myaddr\fI address\fR . Pass an specific local address to the underlying \fBsocket\fR call in case multiple interfaces are available. +.\" OPTION: -progress .TP -\fB\-progress\fR \fIcallback\fR +\fB\-progress\fI callback\fR . If the \fB\-progress\fR option is present, then the \fIcallback\fR is made after each transfer of data from the URL. @@ -475,14 +477,16 @@ proc httpProgress {token total current} { } .CE .RE +.\" OPTION: -protocol .TP -\fB\-protocol\fR \fIversion\fR +\fB\-protocol\fI version\fR . Select the HTTP protocol version to use. This should be 1.0 or 1.1 (the default). Should only be necessary for servers that do not understand or otherwise complain about HTTP/1.1. +.\" OPTION: -query .TP -\fB\-query\fR \fIquery\fR +\fB\-query\fI query\fR . This flag (if the value is non-empty) causes \fB::http::geturl\fR to do a POST request that passes the string @@ -499,8 +503,9 @@ x-url-encoding formatted query-string (this \fB\-type\fR and query format are used in a POST submitted from an html form). The \fB::http::formatQuery\fR procedure can be used to do the formatting. .RE +.\" OPTION: -queryblocksize .TP -\fB\-queryblocksize\fR \fIsize\fR +\fB\-queryblocksize\fI size\fR . The block size used when posting query data to the URL. At most @@ -508,8 +513,9 @@ At most bytes are written at once. After each block, a call to the \fB\-queryprogress\fR callback is made (if that option is specified). +.\" OPTION: -querychannel .TP -\fB\-querychannel\fR \fIchannelID\fR +\fB\-querychannel\fI channelID\fR . This flag causes \fB::http::geturl\fR to do a POST request that passes the data contained in \fIchannelID\fR to the server. The data contained in @@ -519,22 +525,25 @@ If a \fBContent-Length\fR header is not specified via the \fB\-headers\fR options, \fB::http::geturl\fR attempts to determine the size of the post data in order to create that header. If it is unable to determine the size, it returns an error. +.\" OPTION: -queryprogress .TP -\fB\-queryprogress\fR \fIcallback\fR +\fB\-queryprogress\fI callback\fR . If the \fB\-queryprogress\fR option is present, then the \fIcallback\fR is made after each transfer of data to the URL in a POST request (i.e. a call to \fB::http::geturl\fR with option \fB\-query\fR or \fB\-querychannel\fR) and acts exactly like the \fB\-progress\fR option (the callback format is the same). +.\" OPTION: -strict .TP -\fB\-strict\fR \fIboolean\fR +\fB\-strict\fI boolean\fR . If true then the command will test that the URL complies with RFC 3986, i.e. that it has no characters that should be "x-url-encoded" (e.g. a space should be encoded to "%20"). Default value is 1. +.\" OPTION: -timeout .TP -\fB\-timeout\fR \fImilliseconds\fR +\fB\-timeout\fI milliseconds\fR . If \fImilliseconds\fR is non-zero, then \fB::http::geturl\fR sets up a timeout to occur after the specified number of milliseconds. @@ -543,14 +552,16 @@ the \fB\-command\fR callback, if specified. The return value of \fB::http::status\fR (and the value of the \fIstatus\fR key in the dictionary returned by \fB::http::responseInfo\fR) is \fBtimeout\fR after a timeout has occurred. +.\" OPTION: -type .TP -\fB\-type\fR \fImime-type\fR +\fB\-type\fI mime-type\fR . Use \fImime-type\fR as the \fBContent-Type\fR value, instead of the default value (\fBapplication/x-www-form-urlencoded\fR) during a POST operation. +.\" OPTION: -validate .TP -\fB\-validate\fR \fIboolean\fR +\fB\-validate\fI boolean\fR . If \fIboolean\fR is non-zero, then \fB::http::geturl\fR does an HTTP HEAD request. This server returns the same status line and response headers as it @@ -559,27 +570,31 @@ would for a HTTP GET request, but omits the response entity transaction using command \fB::http::responseHeaders\fR or, for selected information, \fB::http::responseInfo\fR. .RE +.\" COMMAND: formatQuery .TP -\fB::http::formatQuery\fR \fIkey value\fR ?\fIkey value\fR ...? +\fB::http::formatQuery\fI key value\fR ?\fIkey value\fR ...? . This procedure does x-url-encoding of query data. It takes an even number of arguments that are the keys and values of the query. It encodes the keys and values, and generates one string that has the proper & and = separators. The result is suitable for the \fB\-query\fR value passed to \fB::http::geturl\fR. +.\" COMMAND: quoteString .TP -\fB::http::quoteString\fR \fIvalue\fR +\fB::http::quoteString\fI value\fR . This procedure does x-url-encoding of string. It takes a single argument and encodes it. +.\" COMMAND: reset .TP -\fB::http::reset\fR \fItoken\fR ?\fIwhy\fR? +\fB::http::reset\fI token\fR ?\fIwhy\fR? . This command resets the HTTP transaction identified by \fItoken\fR, if any. This sets the \fBstate(status)\fR value to \fIwhy\fR, which defaults to \fBreset\fR, and then calls the registered \fB\-command\fR callback. +.\" COMMAND: wait .TP -\fB::http::wait\fR \fItoken\fR +\fB::http::wait\fI token\fR . This command blocks and waits for the transaction to complete. This only works in trusted code because it @@ -588,8 +603,9 @@ uses \fBvwait\fR. Also, it is not useful for the case where because in this case the \fB::http::geturl\fR call does not return until the HTTP transaction is complete, and thus there is nothing to wait for. +.\" COMMAND: status .TP -\fB::http::status\fR \fItoken\fR +\fB::http::status\fI token\fR . This command returns a description of the status of the HTTP transaction. The return value is the empty string until the HTTP transaction is @@ -601,19 +617,22 @@ section \fBERRORS\fR (below). The name "status" is not related to the terms "status line" and "status code" that are defined for a HTTP response. .RE +.\" COMMAND: size .TP -\fB::http::size\fR \fItoken\fR +\fB::http::size\fI token\fR . This command returns the number of bytes received so far from the URL in the \fB::http::geturl\fR call. +.\" COMMAND: error .TP -\fB::http::error\fR \fItoken\fR +\fB::http::error\fI token\fR . This command returns the error information if the HTTP transaction failed, or the empty string if there was no error. The information is a Tcl list of the error message, stack trace, and error code. +.\" COMMAND: postError .TP -\fB::http::postError\fR \fItoken\fR +\fB::http::postError\fI token\fR . A POST request is a call to \fB::http::geturl\fR with either the \fB\-query\fR or \fB\-querychannel\fR option. @@ -623,8 +642,9 @@ string if there was no error. The information is a Tcl list of the error message, stack trace, and error code. When this type of error occurs, the \fB::http::geturl\fR command continues the transaction and attempts to receive a response from the server. +.\" COMMAND: cleanup .TP -\fB::http::cleanup\fR \fItoken\fR +\fB::http::cleanup\fI token\fR . This procedure cleans up the state associated with the connection identified by \fItoken\fR. After this call, the procedures @@ -634,8 +654,9 @@ this function after you are done with a given HTTP request. Not doing so will result in memory not being freed, and if your app calls \fB::http::geturl\fR enough times, the memory leak could cause a performance hit...or worse. +.\" COMMAND: requestLine .TP -\fB::http::requestLine\fR \fItoken\fR +\fB::http::requestLine\fI token\fR . This command returns the "request line" sent to the server. The "request line" is the first line of a HTTP client request, and has three @@ -647,8 +668,9 @@ GET / HTTP/1.1 GET /introduction.html?subject=plumbing HTTP/1.1 POST /forms/order.html HTTP/1.1 .RE +.\" COMMAND: requestHeaders .TP -\fB::http::requestHeaders\fR \fItoken\fR ?\fIheaderName\fR? +\fB::http::requestHeaders\fI token\fR ?\fIheaderName\fR? . This command returns the HTTP request header names and values, in the order that they were sent to the server, as a Tcl list of the form @@ -659,8 +681,9 @@ are returned. If two arguments are supplied, the second provides the value of a header name. Only headers with the requested name (converted to lower case) are returned. If no such headers are found, an empty list is returned. +.\" COMMAND: requestHeaderValue .TP -\fB::http::requestHeaderValue\fR \fItoken\fR \fIheaderName\fR +\fB::http::requestHeaderValue\fI token headerName\fR . This command returns the value of the HTTP request header named \fIheaderName\fR. Header names are case-insensitive and are converted to @@ -668,8 +691,9 @@ lower case. If no such header exists, the return value is the empty string. If there are multiple headers named \fIheaderName\fR, the result is obtained by joining the individual values with the string ", " (comma and space), preserving their order. +.\" COMMAND: responseLine .TP -\fB::http::responseLine\fR \fItoken\fR +\fB::http::responseLine\fI token\fR . This command returns the first line of the server response: the HTTP "status line". The "status line" has three @@ -695,15 +719,17 @@ and can be changed without affecting the HTTP protocol. The recommended values (RFC 7231 and IANA assignments) for each code are provided by the command \fB::http::reasonPhrase\fR. .RE +.\" COMMAND: responseCode .TP -\fB::http::responseCode\fR \fItoken\fR +\fB::http::responseCode\fI token\fR . This command returns the "status code" (200, 404, etc.) of the server "status line". If a three-digit code cannot be found, the full status line is returned. See command \fB::http::responseLine\fR for more information on the "status line". +.\" COMMAND: reasonPhrase .TP -\fB::http::reasonPhrase\fR \fIcode\fR +\fB::http::reasonPhrase\fI code\fR . This command returns the IANA recommended "reason phrase" for a particular "status code" returned by a HTTP server. The argument \fIcode\fR is a valid @@ -724,8 +750,9 @@ the "reason phrase" stored in key \fIreasonPhrase\fR). A registry of valid status codes is maintained at https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml .RE +.\" COMMAND: responseHeaders .TP -\fB::http::responseHeaders\fR \fItoken\fR ?\fIheaderName\fR? +\fB::http::responseHeaders\fI token\fR ?\fIheaderName\fR? . The response from a HTTP server includes metadata headers that describe the response body and the transaction itself. @@ -739,8 +766,9 @@ supplied, it provides the value of a header name. Only headers with the requested name (converted to lower case) are returned. If no such headers are found, an empty list is returned. See section \fBMETADATA\fR for more information. +.\" COMMAND: responseHeaderValue .TP -\fB::http::responseHeaderValue\fR \fItoken\fR \fIheaderName\fR +\fB::http::responseHeaderValue\fI token headerName\fR . This command returns the value of the HTTP response header named \fIheaderName\fR. Header names are case-insensitive and are converted to @@ -751,9 +779,10 @@ preserving their order. Multiple headers with the same name may be processed in this manner, except \fBSet-Cookie\fR which does not conform to the comma-separated-list syntax and cannot be combined into a single value. Each \fBSet-Cookie\fR header must be treated individually, e.g. by processing -the return value of \fB::http::responseHeaders\fR \fItoken\fR \fBSet-Cookie\fR. +the return value of \fB::http::responseHeaders\fI token\fR \fBSet-Cookie\fR. +.\" COMMAND: responseInfo .TP -\fB::http::responseInfo\fR \fItoken\fR +\fB::http::responseInfo\fI token\fR . This command returns a \fBdict\fR of selected response metadata that are essential for identifying a successful transaction and making use of the @@ -775,8 +804,9 @@ text resource as a binary, or vice versa. After a POST transaction, check the value of \fIpostError\fR to verify that the request body was uploaded without error. .RE +.\" COMMAND: responseBody .TP -\fB::http::responseBody\fR \fItoken\fR +\fB::http::responseBody\fI token\fR . This command returns the entity sent by the HTTP server (unless \fI-channel\fR was used, in which case the entity was delivered to the @@ -788,8 +818,9 @@ Other terms for "resource", "response body after decoding", "payload", "message body after decoding", "content(s)", and "file". .RE +.\" COMMAND: register .TP -\fB::http::register\fR \fIproto port command\fR ?\fIsocketCmdVarName\fR? ?\fIuseSockThread\fR? ?\fIendToEndProxy\fR? +\fB::http::register\fI proto port command\fR ?\fIsocketCmdVarName\fR? ?\fIuseSockThread\fR? ?\fIendToEndProxy\fR? . This procedure allows one to provide custom HTTP transport types such as HTTPS, by registering a prefix, the default port, and the @@ -809,7 +840,7 @@ arguments \fIuseSockThread\fR, \fIendToEndProxy\fR, which take boolean values with default value \fIfalse\fR. .PP Iff argument \fIuseSockThread\fR is supplied and is boolean \fItrue\fR, -then iff permitted by the value [\fBhttp::config\fR \fI-threadlevel\fR] +then iff permitted by the value [\fBhttp::config\fI \-threadlevel\fR] and by the availability of package \fBThread\fR, sockets created for the transport will be opened in a different thread so that a slow DNS lookup will not cause the script to block. @@ -825,7 +856,6 @@ For example, .PP .CS package require http - package require tls ::http::register https 443 ::tls::socket ::tls::socketCmd 1 1 @@ -834,8 +864,9 @@ set token [::http::geturl https://my.secure.site/] .CE .RE .RE +.\" COMMAND: registerError .TP -\fB::http::registerError\fR \fIsock\fR ?\fImessage\fR? +\fB::http::registerError\fI sock\fR ?\fImessage\fR? . This procedure allows a registered protocol handler to deliver an error message for use by \fBhttp\fR. Calling this command does not raise an @@ -845,27 +876,32 @@ propagate to \fBhttp\fR. The command allows \fBhttp\fR to provide a precise error message rather than a general one. The command returns the value provided by the last call with argument \fImessage\fR, or the empty string if no such call has been made. +.\" COMMAND: unregister .TP -\fB::http::unregister\fR \fIproto\fR +\fB::http::unregister\fI proto\fR . This procedure unregisters a protocol handler that was previously registered via \fB::http::register\fR, returning a six-item list of the values that were previously supplied to \fB::http::register\fR if there was such a handler, and an error if there was no such handler. +.\" COMMAND: code .TP -\fB::http::code\fR \fItoken\fR +\fB::http::code\fI token\fR . An alternative name for the command \fB::http::responseLine\fR +.\" COMMAND: data .TP -\fB::http::data\fR \fItoken\fR +\fB::http::data\fI token\fR . An alternative name for the command \fB::http::responseBody\fR. +.\" COMMAND: meta .TP -\fB::http::meta\fR \fItoken\fR ?\fIheaderName\fR? +\fB::http::meta\fI token\fR ?\fIheaderName\fR? . An alternative name for the command \fB::http::responseHeaders\fR +.\" COMMAND: ncode .TP -\fB::http::ncode\fR \fItoken\fR +\fB::http::ncode\fI token\fR . An alternative name for the command \fB::http::responseCode\fR .SH ERRORS @@ -914,41 +950,29 @@ determined by examining the status from \fB::http::status\fR (or the value of the \fIstatus\fR key in the dictionary returned by \fB::http::responseInfo\fR). These are described below. -.TP -\fBok\fR -. +.IP \fBok\fR If the HTTP transaction completes entirely, then status will be \fBok\fR. However, you should still check the \fB::http::responseLine\fR value to get the HTTP status. The \fB::http::responseCode\fR procedure provides just the numeric error (e.g., 200, 404 or 500) while the \fB::http::responseLine\fR procedure returns a value like .QW "HTTP 404 File not found" . -.TP -\fBeof\fR -. +.IP \fBeof\fR If the server closes the socket without replying, then no error is raised, but the status of the transaction will be \fBeof\fR. -.TP -\fBerror\fR -. +.IP \fBerror\fR The error message, stack trace, and error code are accessible via \fB::http::error\fR. The error message is also provided by the value of the \fIerror\fR key in the dictionary returned by \fB::http::responseInfo\fR. -.TP -\fBtimeout\fR -. +.IP \fBtimeout\fR A timeout occurred before the transaction could complete. -.TP -\fBreset\fR -. +.IP \fBreset\fR The user has called \fB::http::reset\fR. -.TP -\fB""\fR -. +.IP \fB""\fR (empty string) The transaction has not yet finished. .PP Another error possibility is that \fB::http::geturl\fR failed to -write the whole of the POST request body (\fB-query\fR or \fB-querychannel\fR +write the whole of the POST request body (\fB\-query\fR or \fB\-querychannel\fR data) to the server. \fB::http::geturl\fR stores the error message for later retrieval by the \fB::http::postError\fR or \fB::http::responseInfo\fR commands, and then attempts to complete the transaction. @@ -974,46 +998,35 @@ the \fBdict\fR are: .PP .RS .RS +.\" TODO: Find a better way to mark this up! \fB===== Essential Values =====\fR .RE .RE -.TP -\fBstage\fR -. +.IP \fBstage\fR This value, set by \fB::http::geturl\fR, describes the stage that the transaction has reached. Values, in order of the transaction lifecycle, are: "created", "connecting", "header", "body", and "complete". The other \fBdict\fR keys will not be available until the value of \fBstage\fR is "body" or "complete". The key \fBcurrentSize\fR has its final value only when \fBstage\fR is "complete". -.TP -\fBstatus\fR -. +.IP \fBstatus\fR This value, set by \fB::http::geturl\fR, is "ok" for a successful transaction; "eof", "error", "timeout", or "reset" for an unsuccessful transaction; or "" if the transaction is still in progress. The value is the same as that returned by command \fB::http::status\fR. The meaning of these values is described in the section \fBERRORS\fR (above). -.TP -\fBresponseCode\fR -. +.IP \fBresponseCode\fR The "HTTP status code" sent by the server in the first line (the "status line") of the response. If the value cannot be extracted from the status line, the full status line is returned. -.TP -\fBreasonPhrase\fR -. +.IP \fBreasonPhrase\fR The "reason phrase" sent by the server as a description of the HTTP status code. If the value cannot be extracted from the status line, the full status line is returned. -.TP -\fBcontentType\fR -. +.IP \fBcontentType\fR The value of the \fBContent-Type\fR response header or, if the header was not supplied, the default value "application/octet-stream". -.TP -\fBbinary\fR -. +.IP \fBbinary\fR This boolean value, set by \fB::http::geturl\fR, describes how the command has interpreted the entity returned by the server (after decoding any compression specified by the \fBContent-Encoding\fR response header). @@ -1025,7 +1038,7 @@ The value is \fBtrue\fR if http has interpreted the decoded entity as binary. The value returned by \fB::http::responseBody\fR is a Tcl binary string. This is a suitable format for image data, zip files, etc. \fB::http::geturl\fR chooses this value if the user has requested a binary -interpretation by passing the option \fI\-binary\fR to the command, or if the +interpretation by passing the option \fB\-binary\fR to the command, or if the server has supplied a binary content type in a \fBContent-Type\fR response header, or if the server has not supplied any \fBContent-Type\fR header. .PP @@ -1038,15 +1051,11 @@ It is always worth checking the value of "binary" after a HTTP transaction, to determine whether a misconfigured server has caused http to interpret a text resource as a binary, or vice versa. .RE -.TP -\fBredirection\fR -. +.IP \fBredirection\fR The URL that is the redirection target. The value is that of the \fBLocation\fR response header. This header is sent when a response has status code 3XX (redirection). -.TP -\fBupgrade\fR -. +.IP \fBupgrade\fR If not empty, the value indicates the protocol(s) to which the server will switch after completion of this transaction, while continuing to use the same connection. When the server intends to switch protocols, it will also @@ -1054,14 +1063,10 @@ send the value "101" as the status code (the \fBresponseCode\fR key), and the word "upgrade" as an element of the \fBConnection\fR response header (the \fBconnectionResponse\fR key), and it will not send a response body. See the section \fBPROTOCOL UPGRADES\fR for more information. -.TP -\fBerror\fR -. +.IP \fBerror\fR The error message, if there is one. Further information, including a stack trace and error code, are available from command \fB::http::error\fR. -.TP -\fBpostError\fR -. +.IP \fBpostError\fR The error message (if any) generated when a HTTP POST request sends its request-body to the server. Further information, including a stack trace and error code, are available from command \fB::http::postError\fR. A POST @@ -1075,13 +1080,9 @@ the request-body. \fB===== Informational Values =====\fR .RE .RE -.TP -\fBmethod\fR -. +.IP \fBmethod\fR The HTTP method used in the request. -.TP -\fBcharset\fR -. +.IP \fBcharset\fR The value of the charset attribute of the \fBContent-Type\fR response header. The charset value is used only for a text resource. If the server did not specify a charset, the value defaults to that of the @@ -1089,72 +1090,48 @@ variable \fB::http::defaultCharset\fR, which unless it has been deliberately modified by the caller is \fBiso8859-1\fR. Incoming text data is automatically converted from the character set defined by \fBcharset\fR to Tcl's internal Unicode representation, i.e. to a Tcl string. -.TP -\fBcompression\fR -. +.IP \fBcompression\fR A copy of the \fBContent-Encoding\fR response-header value. -.TP -\fBhttpRequest\fR -. +.IP \fBhttpRequest\fR The version of HTTP specified in the request (i.e. sent in the request line). The value is that of the option \fB\-protocol\fR supplied to \fB::http::geturl\fR (default value "1.1"), unless the command reduced the value to "1.0" because it was passed the \fB\-handler\fR option. -.TP -\fBhttpResponse\fR -. +.IP \fBhttpResponse\fR The version of HTTP used by the server (obtained from the response "status line"). The server uses this version of HTTP in its response, but ensures that this response is compatible with the HTTP version specified in the client's request. If the value cannot be extracted from the status line, the full status line is returned. -.TP -\fBurl\fR -. +.IP \fBurl\fR The requested URL, typically the URL supplied as an argument to \fB::http::geturl\fR but without its "fragment" (the final part of the URL beginning with "#"). -.TP -\fBconnectionRequest\fR -. +.IP \fBconnectionRequest\fR The value, if any, sent to the server in \fBConnection\fR request header(s). -.TP -\fBconnectionResponse\fR -. +.IP \fBconnectionResponse\fR The value, if any, received from the server in \fBConnection\fR response header(s). -.TP -\fBconnectionActual\fR -. +.IP \fBconnectionActual\fR This value, set by \fB::http::geturl\fR, reports whether the connection was closed after the transaction (value "close"), or left open (value "keep-alive"). -.TP -\fBtransferEncoding\fR -. +.IP \fBtransferEncoding\fR The value of the Transfer-Encoding response header, if it is present. The value is either "chunked" (indicating HTTP/1.1 "chunked encoding") or the empty string. -.TP -\fBtotalPost\fR -. +.IP \fBtotalPost\fR The total length of the request body in a POST request. -.TP -\fBcurrentPost\fR -. +.IP \fBcurrentPost\fR The number of bytes of the POST request body sent to the server so far. The value is the same as that returned by command \fB::http::size\fR. -.TP -\fBtotalSize\fR -. +.IP \fBtotalSize\fR A copy of the \fBContent-Length\fR response-header value. The number of bytes specified in a \fBContent-Length\fR header, if one was sent. If none was sent, the value is 0. A correctly configured server omits this header if the transfer-encoding is "chunked", or (for older servers) if the server closes the connection when it reaches the end of the resource. -.TP -\fBcurrentSize\fR -. +.IP \fBcurrentSize\fR The number of bytes fetched from the server so far. .PP .SS "MORE METADATA" @@ -1179,63 +1156,49 @@ Some of the header names (metadata keys) are listed below, but the HTTP standard defines several more, and servers are free to add their own. When a dictionary key is mentioned below, this refers to the \fBdict\fR value returned by command \fB::http::responseInfo\fR. -.TP -\fBContent-Type\fR -. +.IP \fBContent-Type\fR The content type of the URL contents. Examples include \fBtext/html\fR, \fBimage/gif,\fR \fBapplication/postscript\fR and \fBapplication/x-tcl\fR. Text values typically specify a character set, e.g. \fBtext/html; charset=UTF-8\fR. Dictionary key \fIcontentType\fR. -.TP -\fBContent-Length\fR -. +.IP \fBContent-Length\fR The advertised size in bytes of the contents, available as dictionary key \fItotalSize\fR. The actual number of bytes read by \fB::http::geturl\fR so far is available as dictionary key \fBcurrentSize\fR. -.TP -\fBContent-Encoding\fR -. +.IP \fBContent-Encoding\fR The compression algorithm used for the contents. Examples include \fBgzip\fR, \fBdeflate\fR. Dictionary key \fIcontent\fR. -.TP -\fBLocation\fR -. +.IP \fBLocation\fR This header is sent when a response has status code 3XX (redirection). It provides the URL that is the redirection target. Dictionary key \fIredirection\fR. -.TP -\fBSet-Cookie\fR -. +.IP \fBSet-Cookie\fR This header is sent to offer a cookie to the client. Cookie management is -done by the \fB::http::config\fR option \fI\-cookiejar\fR, and so +done by the \fB::http::config\fR option \fB\-cookiejar\fR, and so the \fBSet-Cookie\fR headers need not be parsed by user scripts. See section \fBCOOKIE JAR PROTOCOL\fR. -.TP -\fBConnection\fR -. +.IP \fBConnection\fR The value can be supplied as a comma-separated list, or by multiple headers. The list often has only one element, either "close" or "keep-alive". The value "upgrade" indicates a successful upgrade request and is typically combined with the status code 101, an \fBUpgrade\fR response header, and no response body. Dictionary key \fIconnectionResponse\fR. -.TP -\fBUpgrade\fR -. +.IP \fBUpgrade\fR The value indicates the protocol(s) to which the server will switch immediately after the empty line that terminates the 101 response headers. Dictionary key \fIupgrade\fR. .RE .PP .SS "EVEN MORE METADATA" -.PP -1. Details of the HTTP request. The request is determined by the options +.IP 1. +Details of the HTTP request. The request is determined by the options supplied to \fB::http::geturl\fR and \fB::http::config\fR. However, it is sometimes helpful to examine what \fB::http::geturl\fR actually sent to the server, and this information is available through commands \fB::http::requestHeaders\fR and \fB::http::requestLine\fR. -.PP -2. The state array: the internal variables of \fB::http::geturl\fR. +.IP 2. +The state array: the internal variables of \fB::http::geturl\fR. It may sometimes be helpful to examine this array. Details are given in the next section. .SH "STATE ARRAY" @@ -1263,114 +1226,60 @@ values returned by commands as described below. When a dictionary key is mentioned below, this refers to the \fBdict\fR value returned by command \fB::http::responseInfo\fR. .RS -.TP -\fBbinary\fR -. +.IP \fBbinary\fR For dictionary key \fIbinary\fR. -.TP -\fBbody\fR -. +.IP \fBbody\fR For command \fB::http::responseBody\fR. -.TP -\fBcharset\fR -. +.IP \fBcharset\fR For dictionary key \fIcharset\fR. -.TP -\fBcoding\fR -. +.IP \fBcoding\fR For dictionary key \fIcompression\fR. -.TP -\fBconnection\fR -. +.IP \fBconnection\fR For dictionary key \fIconnectionActual\fR. -.TP -\fBcurrentsize\fR -. +.IP \fBcurrentsize\fR For command \fB::http::size\fR; and for dictionary key \fIcurrentSize\fR. -.TP -\fBerror\fR -. +.IP \fBerror\fR For command \fB::http::error\fR; part is used in dictionary key \fIerror\fR. -.TP -\fBhttp\fR -. +.IP \fBhttp\fR For command \fB::http::responseLine\fR. -.TP -\fBhttpResponse\fR -. +.IP \fBhttpResponse\fR For dictionary key \fIhttpResponse\fR. -.TP -\fBmeta\fR -. +.IP \fBmeta\fR For command \fB::http::responseHeaders\fR. Further discussion above in the section \fBMORE METADATA\fR. -.TP -\fBmethod\fR -. +.IP \fBmethod\fR For dictionary key \fImethod\fR. -.TP -\fBposterror\fR -. +.IP \fBposterror\fR For dictionary key \fIpostError\fR. -.TP -\fBpostErrorFull\fR -. +.IP \fBpostErrorFull\fR For command \fB::http::postError\fR. -.TP -\fB\-protocol\fR -. +.IP \fB\-protocol\fR For dictionary key \fIhttpRequest\fR. -.TP -\fBquerylength\fR -. +.IP \fBquerylength\fR For dictionary key \fItotalPost\fR. -.TP -\fBqueryoffset\fR -. +.IP \fBqueryoffset\fR For dictionary key \fIcurrentPost\fR. -.TP -\fBreasonPhrase\fR -. +.IP \fBreasonPhrase\fR For dictionary key \fIreasonPhrase\fR. -.TP -\fBrequestHeaders\fR -. +.IP \fBrequestHeaders\fR For command \fB::http::requestHeaders\fR. -.TP -\fBrequestLine\fR -. +.IP \fBrequestLine\fR For command \fB::http::requestLine\fR. -.TP -\fBresponseCode\fR -. +.IP \fBresponseCode\fR For dictionary key \fIresponseCode\fR. -.TP -\fBstate\fR -. +.IP \fBstate\fR For dictionary key \fIstage\fR. -.TP -\fBstatus\fR -. +.IP \fBstatus\fR For command \fB::http::status\fR; and for dictionary key \fIstatus\fR. -.TP -\fBtotalsize\fR -. +.IP \fBtotalsize\fR For dictionary key \fItotalSize\fR. -.TP -\fBtransfer\fR -. +.IP \fBtransfer\fR For dictionary key \fItransferEncoding\fR. -.TP -\fBtype\fR -. +.IP \fBtype\fR For dictionary key \fIcontentType\fR. -.TP -\fBupgrade\fR -. +.IP \fBupgrade\fR For dictionary key \fIupgrade\fR. -.TP -\fBurl\fR -. +.IP \fBurl\fR For dictionary key \fIurl\fR. .RE .SH "PERSISTENT CONNECTIONS" @@ -1481,7 +1390,7 @@ Cookies are short key-value pairs used to implement sessions within the otherwise-stateless HTTP protocol. (See RFC 6265 for details; Tcl does not implement the Cookie2 protocol as that is rarely seen in the wild.) .PP -Cookie storage managment commands \(em +Cookie storage management commands \(em .QW "cookie jars" \(em must support these subcommands which form the HTTP cookie storage management protocol. Note that \fIcookieJar\fR below does not have to be a @@ -1493,6 +1402,7 @@ values of \fIcookieJar\fR will correspond to sessions; it is up to the caller of \fB::http::config\fR to decide what session applies and to manage the deletion of said sessions when they are no longer desired (which should be when they not configured as the current cookie jar). +.\" METHOD: getCookies .TP \fIcookieJar \fBgetCookies \fIprotocol host requestPath\fR . @@ -1509,6 +1419,7 @@ request (typically the one with the most specific \fIhost\fR/domain match and most specific \fIrequestPath\fR/path match), but there may be many cookies with different names in any request. .RE +.\" METHOD: storeCookie .TP \fIcookieJar \fBstoreCookie \fIcookieDictionary\fR . @@ -1517,58 +1428,40 @@ returned by a request; the result of this command is ignored. The cookie (which will have been parsed by the http package) is described by a dictionary, \fIcookieDictionary\fR, that may have the following keys: .RS -.TP -\fBdomain\fR -. +.IP \fBdomain\fR This is always present. Its value describes the domain hostname \fIor prefix\fR that the cookie should be returned for. The checking of the domain against the origin (below) should be careful since sites that issue cookies should only do so for domains related to themselves. Cookies that do not obey a relevant origin matching rule should be ignored. -.TP -\fBexpires\fR -. +.IP \fBexpires\fR This is optional. If present, the cookie is intended to be a persistent cookie and the value of the option is the Tcl timestamp (in seconds from the same base as \fBclock seconds\fR) of when the cookie expires (which may be in the past, which should result in the cookie being deleted immediately). If absent, the cookie is intended to be a session cookie that should be not persisted beyond the lifetime of the cookie jar. -.TP -\fBhostonly\fR -. +.IP \fBhostonly\fR This is always present. Its value is a boolean that describes whether the cookie is a single host cookie (true) or a domain-level cookie (false). -.TP -\fBhttponly\fR -. +.IP \fBhttponly\fR This is always present. Its value is a boolean that is true when the site wishes the cookie to only ever be used with HTTP (or HTTPS) traffic. -.TP -\fBkey\fR -. +.IP \fBkey\fR This is always present. Its value is the \fIkey\fR of the cookie, which is part of the information that must be return when sending this cookie back in a future request. -.TP -\fBorigin\fR -. +.IP \fBorigin\fR This is always present. Its value describes where the http package believes it received the cookie from, which may be useful for checking whether the cookie's domain is valid. -.TP -\fBpath\fR -. +.IP \fBpath\fR This is always present. Its value describes the path prefix of requests to the cookie domain where the cookie should be returned. -.TP -\fBsecure\fR -. +.IP \fBsecure\fR This is always present. Its value is a boolean that is true when the cookie should only used on requests sent over secure channels (typically HTTPS). -.TP -\fBvalue\fR -. +.IP \fBvalue\fR This is always present. Its value is the value of the cookie, which is part of the information that must be return when sending this cookie back in a future request. @@ -1618,19 +1511,19 @@ See https://w3c.github.io/webappsec-upgrade-insecure-requests/ .SS "PURPOSE" .PP Command \fB::http::geturl\fR uses the Tcl \fB::socket\fR command with -the \fI\-async\fR option to connect to a remote server, but the return from +the \fB\-async\fR option to connect to a remote server, but the return from this command can be delayed in adverse cases (e.g. a slow DNS lookup), preventing the event loop from processing other events. This delay is avoided if the \fB::socket\fR command is evaluated in another thread. The Thread package is not part of Tcl but is provided in "Batteries Included" distributions. Instead of the \fB::socket\fR command, the http package uses \fB::http::socket\fR which makes connections in the -manner specified by the value of \fI\-threadlevel\fR and the availability +manner specified by the value of \fB\-threadlevel\fR and the availability of package Thread. .PP .SS "WITH TLS (HTTPS)" .PP -The same \fI\-threadlevel\fR configuration applies to both HTTP and HTTPS +The same \fB\-threadlevel\fR configuration applies to both HTTP and HTTPS connections. HTTPS is enabled by using the \fBhttp::register\fR command, typically by specifying the \fB::tls::socket\fR command of the tls package to handle TLS @@ -1648,10 +1541,10 @@ for integrating \fB::http::socket\fR into its own replacement command. .PP The peer thread can transfer the socket only to the main interpreter of the script's thread. Therefore the thread-based \fB::http::socket\fR works with -non-zero \fI\-threadlevel\fR values only if the script runs in the main -interpreter. A child interpreter must use \fI\-threadlevel 0\fR unless the +non-zero \fB\-threadlevel\fR values only if the script runs in the main +interpreter. A child interpreter must use \fB\-threadlevel 0\fR unless the parent interpreter has provided alternative facilities. The main parent -interpreter may grant full \fI\-threadlevel\fR facilities to a child +interpreter may grant full \fB\-threadlevel\fR facilities to a child interpreter, for example by aliasing, to \fB::http::socket\fR in the child, a command that runs \fBhttp::socket\fR in the parent, and then transfers the socket to the child. @@ -1691,7 +1584,7 @@ proc httpcopy { url file {chunk 4096} } { return $token } proc httpCopyProgress {args} { - puts \-nonewline stderr . + puts -nonewline stderr . flush stderr } .CE @@ -14,38 +14,42 @@ tcl::idna \- Support for normalization of Internationalized Domain Names .nf package require tcl::idna 1.0 -\fBtcl::idna decode\fR \fIhostname\fR -\fBtcl::idna encode\fR \fIhostname\fR -\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR? -\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR? +\fBtcl::idna decode\fI hostname\fR +\fBtcl::idna encode\fI hostname\fR +\fBtcl::idna puny decode\fI string\fR ?\fIcase\fR? +\fBtcl::idna puny encode\fI string\fR ?\fIcase\fR? \fBtcl::idna version\fR .fi +.BE .SH DESCRIPTION This package provides an implementation of the punycode scheme used in Internationalised Domain Names, and some access commands. (See RFC 3492 for a description of punycode.) +.\" METHOD: decode .TP -\fBtcl::idna decode\fR \fIhostname\fR +\fBtcl::idna decode\fI hostname\fR . This command takes the name of a host that potentially contains punycode-encoded character sequences, \fIhostname\fR, and returns the hostname as might be displayed to the user. Note that there are often UNICODE characters that have extremely similar glyphs, so care should be taken with displaying hostnames to users. +.\" METHOD: encode .TP -\fBtcl::idna encode\fR \fIhostname\fR +\fBtcl::idna encode\fI hostname\fR . This command takes the name of a host as might be displayed to the user, \fIhostname\fR, and returns the version of the hostname with characters not permitted in basic hostnames encoded with punycode. +.\" METHOD: puny .TP -\fBtcl::idna puny\fR \fIsubcommand ...\fR +\fBtcl::idna puny\fI subcommand ...\fR . This command provides direct access to the basic punycode encoder and decoder. It supports two \fIsubcommand\fRs: .RS .TP -\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR? +\fBtcl::idna puny decode\fI string\fR ?\fIcase\fR? . This command decodes the punycode-encoded string, \fIstring\fR, and returns the result. If \fIcase\fR is provided, it is a boolean to make the case be @@ -53,7 +57,7 @@ folded to upper case (if \fIcase\fR is true) or lower case (if \fIcase\fR is false) during the decoding process; if omitted, no case transformation is applied. .TP -\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR? +\fBtcl::idna puny encode\fI string\fR ?\fIcase\fR? . This command encodes the string, \fIstring\fR, and returns the punycode-encoded version of the string. If \fIcase\fR is provided, it is a @@ -61,6 +65,7 @@ boolean to make the case be folded to upper case (if \fIcase\fR is true) or lower case (if \fIcase\fR is false) during the encoding process; if omitted, no case transformation is applied. .RE +.\" METHOD: version .TP \fBtcl::idna version\fR . @@ -14,7 +14,6 @@ if \- Execute scripts conditionally .SH SYNOPSIS \fBif \fIexpr1 \fR?\fBthen\fR? \fIbody1 \fBelseif \fIexpr2 \fR?\fBthen\fR? \fIbody2\fR \fBelseif\fR ... ?\fBelse\fR? ?\fIbodyN\fR? .BE - .SH DESCRIPTION .PP The \fIif\fR command evaluates \fIexpr1\fR as an expression (in the @@ -20,23 +20,28 @@ info \- Information about the state of the Tcl interpreter .SH DESCRIPTION .PP Available commands: +.\" METHOD: args .TP \fBinfo args \fIprocname\fR . Returns the names of the parameters to the procedure named \fIprocname\fR. +.\" METHOD: body .TP \fBinfo body \fIprocname\fR . Returns the body of the procedure named \fIprocname\fR. +.\" METHOD: class .TP \fBinfo class\fI subcommand class\fR ?\fIarg ...\fR . Returns information about the class named \fIclass\fR. See \fBCLASS INTROSPECTION\fR below. +.\" METHOD: cmdcount .TP \fBinfo cmdcount\fR . Returns the total number of commands evaluated in this interpreter. +.\" METHOD: cmdtype .TP \fBinfo cmdtype \fIcommandName\fR .VS TIP426 @@ -70,6 +75,7 @@ that represents an instance of \fBoo::object\fR or one of its subclasses. \fIcommandName\fR was created by \fBzlib stream\fR. .RE .VE TIP426 +.\" METHOD: commands .TP \fBinfo commands \fR?\fIpattern\fR? . @@ -78,24 +84,43 @@ Returns the names of all commands visible in the current namespace. If \fBstring match\fR. Only the last component of \fIpattern\fR is a pattern. Other components identify a namespace. See \fBNAMESPACE RESOLUTION\fR in the \fBnamespace\fR(n) documentation. +.\" METHOD: complete .TP \fBinfo complete \fIcommand\fR . Returns 1 if \fIcommand\fR is a complete command, and \fB0\fR otherwise. Typically used in line-oriented input environments to allow users to type in commands that span multiple lines. +.\" METHOD: constant +.TP +\fBinfo constant \fIvarName\fR +.VS "TIP 677" +Returns 1 if \fIvarName\fR is a constant variable (see \fBconst\fR) and 0 +otherwise. +.VE "TIP 677" +.\" METHOD: consts +.TP +\fBinfo consts\fR ?\fIpattern\fR? +.VS "TIP 677" +Returns the list of constant variables (see \fBconst\fR) in the current scope, +or the list of constant variables matching \fIpattern\fR (if that is provided) +in a manner similar to \fBinfo vars\fR. +.VE "TIP 677" +.\" METHOD: coroutine .TP \fBinfo coroutine\fR . Returns the name of the current \fBcoroutine\fR, or the empty string if there is no current coroutine or the current coroutine has been deleted. +.\" METHOD: default .TP \fBinfo default \fIprocname parameter varname\fR . If the parameter \fIparameter\fR for the procedure named \fIprocname\fR has a default value, stores that value in \fIvarname\fR and returns \fB1\fR. Otherwise, returns \fB0\fR. +.\" METHOD: errorstack .TP \fBinfo errorstack \fR?\fIinterp\fR? . @@ -123,11 +148,13 @@ options dictionary returned by 3-argument \fBcatch\fR; \fBinfo errorstack\fR is a convenient way of retrieving it for uncaught errors at top-level in an interactive \fBinterpreter\fR. .RE +.\" METHOD: exists .TP \fBinfo exists \fIvarName\fR . Returns \fB1\fR if a variable named \fIvarName\fR is visible and has been defined, and \fB0\fR otherwise. +.\" METHOD: frame .TP \fBinfo frame\fR ?\fIdepth\fR? . @@ -149,60 +176,37 @@ is seen by \fBinfo frame\fR invoked within .QW x . .PP The dictionary may contain the following keys: -.TP -\fBtype\fR -. +.IP \fBtype\fR Always present. Possible values are \fBsource\fR, \fBproc\fR, \fBeval\fR, and \fBprecompiled\fR. .RS -.TP -\fBsource\fR\0\0\0\0\0\0\0\0 -. -A script loaded via the \fBsource\fR -command. -.TP -\fBproc\fR\0\0\0\0\0\0\0\0 -. +.IP \fBsource\fR +A script loaded via the \fBsource\fR command. +.IP \fBproc\fR The body of a procedure that could not be traced back to a line in a particular script. -.TP -\fBeval\fR\0\0\0\0\0\0\0\0 -. +.IP \fBeval\fR The body of a script provided to \fBeval\fR or \fBuplevel\fR. -.TP -\fBprecompiled\fR\0\0\0\0\0\0\0\0 -. +.IP \fBprecompiled\fR A precompiled script (loadable by the package \fBtbcload\fR), and no further information is available. .RE -.TP -\fBline\fR -. +.IP \fBline\fR The line number of of the command inside its script. Not available for \fBprecompiled\fR commands. When the type is \fBsource\fR, the line number is relative to the beginning of the file, whereas for the last two types it is relative to the start of the script. -.TP -\fBfile\fR -. +.IP \fBfile\fR For type \fBsource\fR, provides the normalized path of the file that contains the command. -.TP -\fBcmd\fR -. +.IP \fBcmd\fR The command before substitutions were performed. -.TP -\fBproc\fR -. +.IP \fBproc\fR For type \fBprod\fR, the name of the procedure containing the command. -.TP -\fBlambda\fR -. +.IP \fBlambda\fR For a command in a script evaluated as the body of an unnamed routine via the \fBapply\fR command, the definition of that routine. -.TP -\fBlevel\fR -. +.IP \fBlevel\fR For a frame that corresponds to a level, (to be determined). .PP When a command can be traced to its literal definition in some script, e.g. @@ -229,6 +233,7 @@ is given a literal list argument the system tracks the line number within the list words as well, and otherwise all line numbers are counted relative to the start of each word (smallest scope) .RE +.\" METHOD: functions .TP \fBinfo functions \fR?\fIpattern\fR? . @@ -236,6 +241,7 @@ If \fIpattern\fR is not given, returns a list of all the math functions currently defined. If \fIpattern\fR is given, returns only those names that match \fIpattern\fR according to \fBstring match\fR. +.\" METHOD: globals .TP \fBinfo globals \fR?\fIpattern\fR? . @@ -245,16 +251,20 @@ Global variables are variables in the global namespace. If \fIpattern\fR is given, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. +.\" METHOD: hostname .TP \fBinfo hostname\fR . Returns the name of the current host. - +.RS +.PP This name is not guaranteed to be the fully-qualified domain name of the host. Where machines have several different names, as is common on systems with both TCP/IP (DNS) and NetBIOS-based networking installed, it is the name that is suitable for TCP/IP networking that is returned. +.RE +.\" METHOD: level .TP \fBinfo level\fR ?\fIlevel\fR? . @@ -262,13 +272,15 @@ If \fInumber\fR is not given, the level this routine was called from. Otherwise returns the complete command active at the given level. If \fInumber\fR is greater than \fB0\fR, it is the desired level. Otherwise, it is \fInumber\fR levels up from the current level. A complete command is the -words in the command, with all subsitutions performed, meaning that it is a +words in the command, with all substitutions performed, meaning that it is a list. See \fBuplevel\fR for more information on levels. +.\" METHOD: library .TP \fBinfo library\fR . Returns the value of \fBtcl_library\fR, which is the name of the library directory in which the scripts distributed with Tcl scripts are stored. +.\" METHOD: loaded .TP \fBinfo loaded \fR?\fIinterp\fR? ?\fIpackage\fR? . @@ -277,6 +289,7 @@ Returns the name of each file loaded in \fIinterp\fR va \fBload\fR as part of is the name of the loaded file and the name of the package for which the file was loaded. For a statically-loaded package the name of the file is the empty string. For \fIinterp\fR, the empty string is the current interpreter. +.\" METHOD: locals .TP \fBinfo locals \fR?\fIpattern\fR? . @@ -284,22 +297,25 @@ If \fIpattern\fR is given, returns the name of each local variable matching \fIpattern\fR according to \fBstring match\fR. Otherwise, returns the name of each local variable. A variables defined with the \fBglobal\fR, \fBupvar\fR or \fBvariable\fR is not local. - +.\" METHOD: nameofexecutable .TP \fBinfo nameofexecutable\fR . Returns the absolute pathname of the program for the current interpreter. If such a file can not be identified an empty string is returned. +.\" METHOD: object .TP \fBinfo object\fI subcommand object\fR ?\fIarg ...\fR . Returns information about the object named \fIobject\fR. \fIsubcommand\fR is described \fBOBJECT INTROSPECTION\fR below. +.\" METHOD: patchlevel .TP \fBinfo patchlevel\fR . Returns the value of the global variable \fBtcl_patchLevel\fR, in which the exact version of the Tcl library initially stored. +.\" METHOD: procs .TP \fBinfo procs \fR?\fIpattern\fR? . @@ -308,6 +324,7 @@ only those names that match according to \fBstring match\fR. Only the final component in \fIpattern\fR is actually considered a pattern. Any qualifying components simply select a namespace. See \fBNAMESPACE RESOLUTION\fR in the \fBnamespace\fR(n) documentation. +.\" METHOD: script .TP \fBinfo script\fR ?\fIfilename\fR? . @@ -316,17 +333,20 @@ empty string if no pathname can be determined. If \fIfilename\fR is given, sets the return value of any future calls to \fBinfo script\fR for the duration of the innermost active script. This is useful in virtual file system applications. +.\" METHOD: sharedlibextension .TP \fBinfo sharedlibextension\fR . Returns the extension used on this platform for names of shared libraries, e.g. \fB.so\fR under Solaris. Returns the empty string if shared libraries are not supported on this platform. +.\" METHOD: tclversion .TP \fBinfo tclversion\fR . Returns the value of the global variable \fBtcl_version\fR, in which the major and minor version of the Tcl library are stored. +.\" METHOD: vars .TP \fBinfo vars\fR ?\fIpattern\fR? . @@ -336,11 +356,15 @@ If \fIpattern\fR is not given, returns the names of all visible variables. If Other components identify a namespace. See \fBNAMESPACE RESOLUTION\fR in the \fBnamespace\fR(n) documentation. When \fIpattern\fR is a qualified name, results are fully qualified. - -A variable that has declared but not yet defined is included in the results. +.RS +.PP +A variable that has been declared but not yet given a value will be included in +the results. +.RE .SS "CLASS INTROSPECTION" .PP The following \fIsubcommand\fR values are supported by \fBinfo class\fR: +.\" METHOD: call .TP \fBinfo class call\fI class method\fR . @@ -371,6 +395,7 @@ and the call chains that this command files do not actually contain private methods. .VE TIP500 .RE +.\" METHOD: constructor .TP \fBinfo class constructor\fI class\fR . @@ -380,6 +405,7 @@ element is the list of arguments to the constructor in a form suitable for passing to another call to \fBproc\fR or a method definition, and the second element is the body of the constructor. If no constructor is present, this returns the empty list. +.\" METHOD: definition .TP \fBinfo class definition\fI class method\fR . @@ -388,6 +414,7 @@ This subcommand returns a description of the definition of the method named list; the first element is the list of arguments to the method in a form suitable for passing to another call to \fBproc\fR or a method definition, and the second element is the body of the method. +.\" METHOD: definitionnamespace .TP \fBinfo class definitionnamespace\fI class\fR ?\fIkind\fR? .VS TIP524 @@ -406,26 +433,31 @@ this command returns the empty string. In those circumstances, the namespace to use using the class inheritance hierarchy. .RE .VE TIP524 +.\" METHOD: destructor .TP \fBinfo class destructor\fI class\fR . This subcommand returns the body of the destructor of class \fIclass\fR. If no destructor is present, this returns the empty string. +.\" METHOD: filters .TP \fBinfo class filters\fI class\fR . This subcommand returns the list of filter methods set on the class. +.\" METHOD: forward .TP \fBinfo class forward\fI class method\fR . This subcommand returns the argument list for the method forwarding called \fImethod\fR that is set on the class called \fIclass\fR. +.\" METHOD: instances .TP \fBinfo class instances\fI class\fR ?\fIpattern\fR? . This subcommand returns a list of instances of class \fIclass\fR. If the optional \fIpattern\fR argument is present, it constrains the list of returned instances to those that match it according to the rules of \fBstring match\fR. +.\" METHOD: methods .TP \fBinfo class methods\fI class\fR ?\fIoptions...\fR? . @@ -433,6 +465,7 @@ This subcommand returns a list of all public (i.e. exported) methods of the class called \fIclass\fR. Any of the following \fIoption\fRs may be given, controlling exactly which method names are returned: .RS +.\" OPTION: -all .TP \fB\-all\fR . @@ -443,6 +476,7 @@ and the \fB\-scope\fR flag is not given, the list of methods will include those methods defined not just by the class, but also by the class's superclasses and mixins. +.\" OPTION: -private .TP \fB\-private\fR . @@ -457,6 +491,7 @@ mixins, if \fB\-all\fR is also given). Note that this naming is an unfortunate clash with true private methods; this option name is retained for backward compatibility. .VE TIP500 +.\" OPTION: -scope .TP \fB\-scope\fI scope\fR .VS TIP500 @@ -465,17 +500,18 @@ Returns a list of all methods on \fIclass\fR that have the given visibility \fB\-private\fR options are ignored. The valid values for \fIscope\fR are: .RS .IP \fBpublic\fR 3 -Only methods with \fIpublic\fR scope (i.e., callable from anywhere by any instance -of this class) are to be returned. +Only methods with \fIpublic\fR scope (i.e., callable from anywhere by any +instance of this class) are to be returned. .IP \fBunexported\fR 3 -Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to -be returned. +Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) +are to be returned. .IP \fBprivate\fR 3 -Only methods with \fIprivate\fR scope (i.e., only callable from within this class's -methods) are to be returned. +Only methods with \fIprivate\fR scope (i.e., only callable from within this +class's methods) are to be returned. .RE .VE TIP500 .RE +.\" METHOD: methodtype .TP \fBinfo class methodtype\fI class method\fR . @@ -484,27 +520,32 @@ the method named \fImethod\fR of class \fIclass\fR. When the result is \fBmethod\fR, further information can be discovered with \fBinfo class definition\fR, and when the result is \fBforward\fR, further information can be discovered with \fBinfo class forward\fR. +.\" METHOD: mixins .TP \fBinfo class mixins\fI class\fR . This subcommand returns a list of all classes that have been mixed into the class named \fIclass\fR. +.\" METHOD: properties .TP \fBinfo class properties\fI class\fR ?\fIoptions...\fR .VS "TIP 558" This subcommand returns a sorted list of properties defined on the class named \fIclass\fR. The \fIoptions\fR define exactly which properties are returned: .RS +.\" OPTION: -all .TP \fB\-all\fR . With this option, the properties from the superclasses and mixins of the class are also returned. +.\" OPTION: -readable .TP \fB\-readable\fR . This option (the default behavior) asks for the readable properties to be returned. Only readable or writable properties are returned, not both. +.\" OPTION: -writable .TP \fB\-writable\fR . @@ -512,6 +553,7 @@ This option asks for the writable properties to be returned. Only readable or writable properties are returned, not both. .RE .VE "TIP 558" +.\" METHOD: subclasses .TP \fBinfo class subclasses\fI class\fR ?\fIpattern\fR? . @@ -519,11 +561,13 @@ This subcommand returns a list of direct subclasses of class \fIclass\fR. If the optional \fIpattern\fR argument is present, it constrains the list of returned classes to those that match it according to the rules of \fBstring match\fR. +.\" METHOD: superclasses .TP \fBinfo class superclasses\fI class\fR . This subcommand returns a list of direct superclasses of class \fIclass\fR in inheritance precedence order. +.\" METHOD: variables .TP \fBinfo class variables\fI class\fR ?\fB\-private\fR? . @@ -537,6 +581,7 @@ declared instead. .SS "OBJECT INTROSPECTION" .PP The following \fIsubcommand\fR values are supported by \fBinfo object\fR: +.\" METHOD: call .TP \fBinfo object call\fI object method\fR . @@ -566,12 +611,14 @@ and the call chains that this command files do not actually contain private methods. .VE TIP500 .RE +.\" METHOD: class .TP \fBinfo object class\fI object\fR ?\fIclassName\fR? . If \fIclassName\fR is not given, this subcommand returns class of the \fIobject\fR object. If \fIclassName\fR is present, this subcommand returns a boolean value indicating whether the \fIobject\fR is of that class. +.\" METHOD: creationid .TP \fBinfo object creationid\fI object\fR .VS TIP500 @@ -584,6 +631,7 @@ cannot be controlled at object creation time or altered afterwards. identifiers associated with the object, especially for private variables. .RE .VE TIP500 +.\" METHOD: definition .TP \fBinfo object definition\fI object method\fR . @@ -592,15 +640,18 @@ This subcommand returns a description of the definition of the method named element list; the first element is the list of arguments to the method in a form suitable for passing to another call to \fBproc\fR or a method definition, and the second element is the body of the method. +.\" METHOD: filters .TP \fBinfo object filters\fI object\fR . This subcommand returns the list of filter methods set on the object. +.\" METHOD: forward .TP \fBinfo object forward\fI object method\fR . This subcommand returns the argument list for the method forwarding called \fImethod\fR that is set on the object called \fIobject\fR. +.\" METHOD: isa .TP \fBinfo object isa\fI category object\fR ?\fIarg\fR? . @@ -633,6 +684,7 @@ This returns whether \fIclass\fR is the type of \fIobject\fR (i.e. whether \fIobject\fR is an instance of \fIclass\fR or one of its subclasses, whether direct or indirect). .RE +.\" METHOD: methods .TP \fBinfo object methods\fI object\fR ?\fIoption...\fR? . @@ -640,6 +692,7 @@ This subcommand returns a list of all public (i.e. exported) methods of the object called \fIobject\fR. Any of the following \fIoption\fRs may be given, controlling exactly which method names are returned: .RS +.\" OPTION: -all .TP \fB\-all\fR . @@ -650,6 +703,7 @@ and the \fB\-scope\fR flag is not given, the list of methods will include those methods defined not just by the object, but also by the object's class and mixins, plus the superclasses of those classes. +.\" OPTION: -private .TP \fB\-private\fR . @@ -664,6 +718,7 @@ the non-exported methods of the object (and classes, if Note that this naming is an unfortunate clash with true private methods; this option name is retained for backward compatibility. .VE TIP500 +.\" OPTION: -scope .TP \fB\-scope\fI scope\fR .VS TIP500 @@ -675,14 +730,15 @@ Returns a list of all methods on \fIobject\fR that have the given visibility Only methods with \fIpublic\fR scope (i.e., callable from anywhere) are to be returned. .IP \fBunexported\fR 3 -Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to -be returned. +Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) +are to be returned. .IP \fBprivate\fR 3 -Only methods with \fIprivate\fR scope (i.e., only callable from within this object's -instance methods) are to be returned. +Only methods with \fIprivate\fR scope (i.e., only callable from within this +object's instance methods) are to be returned. .RE .VE TIP500 .RE +.\" METHOD: methodtype .TP \fBinfo object methodtype\fI object method\fR . @@ -691,16 +747,19 @@ the method named \fImethod\fR of object \fIobject\fR. When the result is \fBmethod\fR, further information can be discovered with \fBinfo object definition\fR, and when the result is \fBforward\fR, further information can be discovered with \fBinfo object forward\fR. +.\" METHOD: mixins .TP \fBinfo object mixins\fI object\fR . This subcommand returns a list of all classes that have been mixed into the object named \fIobject\fR. +.\" METHOD: namespace .TP \fBinfo object namespace\fI object\fR . This subcommand returns the name of the internal namespace of the object named \fIobject\fR. +.\" METHOD: properties .TP \fBinfo object properties\fI object\fR ?\fIoptions...\fR .VS "TIP 558" @@ -708,16 +767,19 @@ This subcommand returns a sorted list of properties defined on the object named \fIobject\fR. The \fIoptions\fR define exactly which properties are returned: .RS +.\" OPTION: -all .TP \fB\-all\fR . With this option, the properties from the class, superclasses and mixins of the object are also returned. +.\" OPTION: -readable .TP \fB\-readable\fR . This option (the default behavior) asks for the readable properties to be returned. Only readable or writable properties are returned, not both. +.\" OPTION: -writable .TP \fB\-writable\fR . @@ -725,8 +787,9 @@ This option asks for the writable properties to be returned. Only readable or writable properties are returned, not both. .RE .VE "TIP 558" +.\" METHOD: variables .TP -\fBinfo object variables\fI object\fRR ?\fB\-private\fR? +\fBinfo object variables\fI object\fR ?\fB\-private\fR? . This subcommand returns a list of all variables that have been declared for the object named \fIobject\fR (i.e. that are automatically present in the @@ -735,6 +798,7 @@ object's methods). If the \fB\-private\fR option is given, this lists the private variables declared instead. .VE TIP500 +.\" METHOD: vars .TP \fBinfo object vars\fI object\fR ?\fIpattern\fR? . diff --git a/doc/interp.n b/doc/interp.n index 08bed1c..2c08533 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -87,8 +87,9 @@ The \fBinterp\fR command is used to create, delete, and manipulate child interpreters, and to share or transfer channels between interpreters. It can have any of several forms, depending on the \fIsubcommand\fR argument: +.\" METHOD: alias .TP -\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR +\fBinterp alias\fI srcPath srcToken\fR . Returns a Tcl list whose elements are the \fItargetCmd\fR and \fIarg\fRs associated with the alias represented by \fIsrcToken\fR @@ -96,7 +97,7 @@ Returns a Tcl list whose elements are the \fItargetCmd\fR and created; it is possible that the name of the source command in the child is different from \fIsrcToken\fR). .TP -\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR \fB{}\fR +\fBinterp alias\fI srcPath srcToken\fR \fB{}\fR . Deletes the alias for \fIsrcToken\fR in the child interpreter identified by \fIsrcPath\fR. @@ -104,7 +105,7 @@ Deletes the alias for \fIsrcToken\fR in the child interpreter identified by was created; if the source command has been renamed, the renamed command will be deleted. .TP -\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcCmd\fR \fItargetPath\fR \fItargetCmd \fR?\fIarg arg ...\fR? +\fBinterp alias\fI srcPath srcCmd targetPath targetCmd \fR?\fIarg arg ...\fR? . This command creates an alias between one child and another (see the \fBalias\fR child command below for creating aliases between a child @@ -135,14 +136,16 @@ more details. The command returns a token that uniquely identifies the command created \fIsrcCmd\fR, even if the command is renamed afterwards. The token may but does not have to be equal to \fIsrcCmd\fR. +.\" METHOD: aliases .TP -\fBinterp\fR \fBaliases \fR?\fIpath\fR? +\fBinterp aliases \fR?\fIpath\fR? . This command returns a Tcl list of the tokens of all the source commands for aliases defined in the interpreter identified by \fIpath\fR. The tokens correspond to the values returned when the aliases were created (which may not be the same as the current names of the commands). +.\" METHOD: bgerror .TP \fBinterp bgerror \fIpath\fR ?\fIcmdPrefix\fR? . @@ -152,8 +155,10 @@ absent, the current background exception handler is returned, and if it is present, it is a list of words (of minimum length one) that describes what to set the interpreter's background exception handler to. See the \fBBACKGROUND EXCEPTION HANDLING\fR section for more details. +.\" METHOD: cancel .TP -\fBinterp\fR \fBcancel \fR?\fB\-unwind\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? ?\fIresult\fR? +\fBinterp cancel \fR?\fB\-unwind\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? ?\fIresult\fR? +. Cancels the script being evaluated in the interpreter identified by \fIpath\fR. Without the \fB\-unwind\fR switch the evaluation stack for the interpreter is unwound until an enclosing catch command is found or @@ -166,8 +171,16 @@ switches; it may be needed if \fIpath\fR is an unusual value such as \fB\-safe\fR. If \fIresult\fR is present, it will be used as the error message string; otherwise, a default error message string will be used. +.\" METHOD: children +.TP +\fBinterp children\fR ?\fIpath\fR? +. +Returns a Tcl list of the names of all the child interpreters associated +with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted, +the invoking interpreter is used. +.\" METHOD: create .TP -\fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? +\fBinterp create \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? . Creates a child interpreter identified by \fIpath\fR and a new command, called a \fIchild command\fR. The name of the child command is the last @@ -191,8 +204,9 @@ the children for its parent; an error occurs if a child interpreter by the given name already exists in this parent. The initial recursion limit of the child interpreter is set to the current recursion limit of its parent interpreter. +.\" METHOD: debug .TP -\fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR?? +\fBinterp debug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR?? . Controls whether frame-level stack information is captured in the child interpreter identified by \fIpath\fR. If no arguments are @@ -233,16 +247,18 @@ Note that once it is on, this flag cannot be switched back off: such attempts are silently ignored. This is needed to maintain the consistency of the underlying interpreter's state. .RE +.\" METHOD: delete .TP -\fBinterp\fR \fBdelete \fR?\fIpath ...\fR? +\fBinterp delete \fR?\fIpath ...\fR? . Deletes zero or more interpreters given by the optional \fIpath\fR arguments, and for each interpreter, it also deletes its children. The command also deletes the child command for each interpreter deleted. For each \fIpath\fR argument, if no interpreter by that name exists, the command raises an error. +.\" METHOD: eval .TP -\fBinterp\fR \fBeval\fR \fIpath arg \fR?\fIarg ...\fR? +\fBinterp eval\fI path arg \fR?\fIarg ...\fR? . This command concatenates all of the \fIarg\fR arguments in the same fashion as the \fBconcat\fR command, then evaluates the resulting string as @@ -250,19 +266,24 @@ a Tcl script in the child interpreter identified by \fIpath\fR. The result of this evaluation (including all \fBreturn\fR options, such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an error occurs) is returned to the invoking interpreter. +.RS +.PP Note that the script will be executed in the current context stack frame of the \fIpath\fR interpreter; this is so that the implementations (in a parent interpreter) of aliases in a child interpreter can execute scripts in the child that find out information about the child's current state and stack frame. +.RE +.\" METHOD: exists .TP \fBinterp exists \fIpath\fR . Returns \fB1\fR if a child interpreter by the specified \fIpath\fR exists in this parent, \fB0\fR otherwise. If \fIpath\fR is omitted, the invoking interpreter is used. +.\" METHOD: expose .TP -\fBinterp expose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR? +\fBinterp expose \fIpath hiddenName\fR ?\fIexposedCmdName\fR? . Makes the hidden command \fIhiddenName\fR exposed, eventually bringing it back under a new \fIexposedCmdName\fR name (this name is currently @@ -272,8 +293,9 @@ denoted by \fIpath\fR. If an exposed command with the targeted name already exists, this command fails. Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. +.\" METHOD: hide .TP -\fBinterp\fR \fBhide\fR \fIpath\fR \fIexposedCmdName\fR ?\fIhiddenCmdName\fR? +\fBinterp hide\fI path exposedCmdName\fR ?\fIhiddenCmdName\fR? . Makes the exposed command \fIexposedCmdName\fR hidden, renaming it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if @@ -288,13 +310,15 @@ namespace even if the current namespace is not the global one. This prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. +.\" METHOD: hidden .TP -\fBinterp\fR \fBhidden\fR \fIpath\fR +\fBinterp hidden\fI path\fR . Returns a list of the names of all hidden commands in the interpreter identified by \fIpath\fR. +.\" METHOD: invokehidden .TP -\fBinterp\fR \fBinvokehidden\fR \fIpath\fR ?\fI\-option ...\fR? \fIhiddenCmdName\fR ?\fIarg ...\fR? +\fBinterp invokehidden\fI path\fR ?\fI\-option ...\fR? \fIhiddenCmdName\fR ?\fIarg ...\fR? . Invokes the hidden command \fIhiddenCmdName\fR with the arguments supplied in the interpreter denoted by \fIpath\fR. No substitutions or evaluation @@ -312,16 +336,22 @@ The \fB\-\|\-\fR flag allows the \fIhiddenCmdName\fR argument to start with a character, and is otherwise unnecessary. If both the \fB\-namespace\fR and \fB\-global\fR flags are present, the \fB\-namespace\fR flag is ignored. +.RS +.PP Note that the hidden command will be executed (by default) in the current context stack frame of the \fIpath\fR interpreter. +.PP Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. +.RE +.\" METHOD: issafe .TP \fBinterp issafe\fR ?\fIpath\fR? . Returns \fB1\fR if the interpreter identified by the specified \fIpath\fR is safe, \fB0\fR otherwise. +.\" METHOD: limit .TP -\fBinterp\fR \fBlimit\fR \fIpath\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR? +\fBinterp limit\fI path limitType\fR ?\fI\-option\fR? ?\fIvalue ...\fR? . Sets up, manipulates and queries the configuration of the resource limit \fIlimitType\fR for the interpreter denoted by \fIpath\fR. If @@ -330,16 +360,18 @@ limit. If \fI\-option\fR is the sole argument, return the value of that option. Otherwise, a list of \fI\-option\fR/\fIvalue\fR argument pairs must supplied. See \fBRESOURCE LIMITS\fR below for a more detailed explanation of what limits and options are supported. +.\" METHOD: marktrusted .TP -\fBinterp marktrusted\fR \fIpath\fR +\fBinterp marktrusted\fI path\fR . Marks the interpreter identified by \fIpath\fR as trusted. Does not expose the hidden commands. This command can only be invoked from a trusted interpreter. The command has no effect if the interpreter identified by \fIpath\fR is already trusted. +.\" METHOD: recursionlimit .TP -\fBinterp\fR \fBrecursionlimit\fR \fIpath\fR ?\fInewlimit\fR? +\fBinterp recursionlimit\fI path\fR ?\fInewlimit\fR? . Returns the maximum allowable nesting depth for the interpreter specified by \fIpath\fR. If \fInewlimit\fR is specified, @@ -358,8 +390,9 @@ may get stack overflows before reaching the limit set by the command. If this happens, see if there is a mechanism in your system for increasing the maximum size of the C stack. .RE +.\" METHOD: share .TP -\fBinterp\fR \fBshare\fR \fIsrcPath channelId destPath\fR +\fBinterp share\fI srcPath channelId destPath\fR . Causes the IO channel identified by \fIchannelId\fR to become shared between the interpreter identified by \fIsrcPath\fR and the interpreter @@ -368,18 +401,9 @@ on the IO channel. Both interpreters must close it to close the underlying IO channel; IO channels accessible in an interpreter are automatically closed when an interpreter is destroyed. +.\" METHOD: target .TP -\fBinterp\fR \fBchildren\fR ?\fIpath\fR? -. -Returns a Tcl list of the names of all the child interpreters associated -with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted, -the invoking interpreter is used. -.TP -\fBinterp\fR \fBslaves\fR ?\fIpath\fR? -. -Synonym for . \fBinterp\fR \fBchildren\fR ?\fIpath\fR? -.TP -\fBinterp\fR \fBtarget\fR \fIpath alias\fR +\fBinterp target\fI path alias\fR . Returns a Tcl list describing the target interpreter for an alias. The alias is specified with an interpreter path and source command name, just @@ -389,8 +413,9 @@ If the target interpreter for the alias is the invoking interpreter then an empty list is returned. If the target interpreter for the alias is not the invoking interpreter or one of its descendants then an error is generated. The target command does not have to be defined at the time of this invocation. +.\" METHOD: transfer .TP -\fBinterp\fR \fBtransfer\fR \fIsrcPath channelId destPath\fR +\fBinterp transfer\fI srcPath channelId destPath\fR . Causes the IO channel identified by \fIchannelId\fR to become available in the interpreter identified by \fIdestPath\fR and unavailable in the @@ -410,6 +435,7 @@ general form: \fIChild\fR is the name of the interpreter, and \fIcommand\fR and the \fIarg\fRs determine the exact behavior of the command. The valid forms of this command are: +.\" METHOD: aliases .TP \fIchild \fBaliases\fR . @@ -417,6 +443,7 @@ Returns a Tcl list whose elements are the tokens of all the aliases in \fIchild\fR. The tokens correspond to the values returned when the aliases were created (which may not be the same as the current names of the commands). +.\" METHOD: alias .TP \fIchild \fBalias \fIsrcToken\fR . @@ -444,6 +471,7 @@ See \fBALIAS INVOCATION\fR below for details. The command returns a token that uniquely identifies the command created \fIsrcCmd\fR, even if the command is renamed afterwards. The token may but does not have to be equal to \fIsrcCmd\fR. +.\" METHOD: bgerror .TP \fIchild \fBbgerror\fR ?\fIcmdPrefix\fR? . @@ -453,6 +481,7 @@ absent, the current background exception handler is returned, and if it is present, it is a list of words (of minimum length one) that describes what to set the interpreter's background exception handler to. See the \fBBACKGROUND EXCEPTION HANDLING\fR section for more details. +.\" METHOD: eval .TP \fIchild \fBeval \fIarg \fR?\fIarg ..\fR? . @@ -462,11 +491,15 @@ the resulting string as a Tcl script in \fIchild\fR. The result of this evaluation (including all \fBreturn\fR options, such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an error occurs) is returned to the invoking interpreter. +.RS +.PP Note that the script will be executed in the current context stack frame of \fIchild\fR; this is so that the implementations (in a parent interpreter) of aliases in a child interpreter can execute scripts in the child that find out information about the child's current state and stack frame. +.RE +.\" METHOD: expose .TP \fIchild \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR? . @@ -477,6 +510,7 @@ in \fIchild\fR. If an exposed command with the targeted name already exists, this command fails. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. +.\" METHOD: hide .TP \fIchild \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR? . @@ -492,10 +526,12 @@ namespace even if the current namespace is not the global one. This prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. +.\" METHOD: hidden .TP \fIchild \fBhidden\fR . Returns a list of the names of all hidden commands in \fIchild\fR. +.\" METHOD: invokehidden .TP \fIchild \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR? . @@ -514,16 +550,21 @@ The \fB\-\|\-\fR flag allows the \fIhiddenCmdName\fR argument to start with a character, and is otherwise unnecessary. If both the \fB\-namespace\fR and \fB\-global\fR flags are given, the \fB\-namespace\fR flag is ignored. +.RS +.PP Note that the hidden command will be executed (by default) in the current context stack frame of \fIchild\fR. -For more details on hidden commands, -see \fBHIDDEN COMMANDS\fR, below. +.PP +For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. +.RE +.\" METHOD: issafe .TP \fIchild \fBissafe\fR . -Returns \fB1\fR if the child interpreter is safe, \fB0\fR otherwise. +Returns \fB1\fR if the child interpreter is safe, \fB0\fR otherwise. +.\" METHOD: limit .TP -\fIchild \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR? +\fIchild \fBlimit\fI limitType\fR ?\fI\-option\fR? ?\fIvalue ...\fR? . Sets up, manipulates and queries the configuration of the resource limit \fIlimitType\fR for the child interpreter. If no \fI\-option\fR @@ -532,6 +573,7 @@ is specified, return the current configuration of the limit. If Otherwise, a list of \fI\-option\fR/\fIvalue\fR argument pairs must supplied. See \fBRESOURCE LIMITS\fR below for a more detailed explanation of what limits and options are supported. +.\" METHOD: marktrusted .TP \fIchild \fBmarktrusted\fR . @@ -539,8 +581,9 @@ Marks the child interpreter as trusted. Can only be invoked by a trusted interpreter. This command does not expose any hidden commands in the child interpreter. The command has no effect if the child is already trusted. +.\" METHOD: recursionlimit .TP -\fIchild\fR \fBrecursionlimit\fR ?\fInewlimit\fR? +\fIchild \fBrecursionlimit\fR ?\fInewlimit\fR? . Returns the maximum allowable nesting depth for the \fIchild\fR interpreter. If \fInewlimit\fR is specified, the recursion limit in \fIchild\fR will be @@ -793,6 +836,7 @@ catch and handle. Every limit has a number of options associated with it, some of which are common across all kinds of limits, and others of which are particular to the kind of limit. +.\" OPTION: -command .TP \fB\-command\fR . @@ -803,9 +847,13 @@ The callback may modify the limit on the interpreter if it wishes the limited interpreter to continue executing. If the callback generates an exception, it is reported through the background exception mechanism (see \fBBACKGROUND EXCEPTION HANDLING\fR). +.RS +.PP Note that the callbacks defined by one interpreter are completely isolated from the callbacks defined by another, and that the order in which those callbacks are called is undefined. +.RE +.\" OPTION: -granularity .TP \fB\-granularity\fR . @@ -814,6 +862,7 @@ points when the Tcl interpreter is in a consistent state where limit checking is possible) that the limit is actually checked. This allows the tuning of how frequently a limit is checked, and hence how often the limit-checking overhead (which may be substantial in the case of time limits) is incurred. +.\" OPTION: -milliseconds .TP \fB\-milliseconds\fR . @@ -821,6 +870,7 @@ This option specifies the number of milliseconds after the moment defined in the \fB\-seconds\fR option that the time limit will fire. It should only ever be specified in conjunction with the \fB\-seconds\fR option (whether it was set previously or is being set this invocation.) +.\" OPTION: -seconds .TP \fB\-seconds\fR . @@ -830,6 +880,7 @@ limit will be triggered at the start of the second unless specified at a sub-second level using the \fB\-milliseconds\fR option. This option may be the empty string, which indicates that a time limit is not set for the interpreter. +.\" OPTION: -value .TP \fB\-value\fR . @@ -849,14 +900,15 @@ necessary. .PP When an exception happens in a situation where it cannot be reported directly up the stack (e.g. when processing events in an \fBupdate\fR or \fBvwait\fR call) -the exception is instead reported through the background exception handling mechanism. -Every interpreter has a background exception handler registered; the default exception +the exception is instead reported through the background exception handling +mechanism. Every interpreter has a background exception handler registered; +the default exception handler arranges for the \fBbgerror\fR command in the interpreter's global namespace to be called, but other exception handlers may be installed and process background exceptions in substantially different ways. .PP -A background exception handler consists of a non-empty list of words to which will -be appended two further words at invocation time. The first word will be the +A background exception handler consists of a non-empty list of words to which +will be appended two further words at invocation time. The first word will be the interpreter result at time of the exception, typically an error message, and the second will be the dictionary of return options at the time of the exception. These are the same values that \fBcatch\fR can capture @@ -904,7 +956,8 @@ set i [\fBinterp create\fR] } .CE .SH "SEE ALSO" -bgerror(n), load(n), safe(n), Tcl_CreateChild(3), Tcl_Eval(3), Tcl_BackgroundException(3) +bgerror(n), load(n), safe(n), +Tcl_CreateChild(3), Tcl_Eval(3), Tcl_BackgroundException(3) .SH KEYWORDS alias, parent interpreter, safe interpreter, child interpreter '\"Local Variables: diff --git a/doc/ledit.n b/doc/ledit.n index 48bc608..b956cc1 100644 --- a/doc/ledit.n +++ b/doc/ledit.n @@ -26,6 +26,8 @@ the same as index values for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the end of the list. The index \fB0\fR refers to the first element of the list, and \fBend\fR refers to the last element of the list. +(Unlike with \fBlpop\fR, \fBlset\fR, and \fBlindex\fR, indices into sublists +are not supported.) .PP If either \fIfirst\fR or \fIlast\fR is less than zero, it is considered to refer to the position before the first element of the list. This allows @@ -42,7 +44,7 @@ with no elements being deleted. The \fIvalue\fR arguments specify zero or more new elements to be added to the list in place of those that were deleted. Each \fIvalue\fR argument will become a separate element of -the list. If no \fIvalue\fR arguments are specified, then the elements +the list. If no \fIvalue\fR arguments are specified, the elements between \fIfirst\fR and \fIlast\fR are simply deleted. .SH EXAMPLES .PP diff --git a/doc/library.n b/doc/library.n index 0342cbe..bb3db05 100644 --- a/doc/library.n +++ b/doc/library.n @@ -30,6 +30,7 @@ auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, tcl \fBreadFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fBwriteFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fIcontents\fR .VE "Tcl 8.7, TIP 670" +.fi .BE .SH INTRODUCTION .PP @@ -61,6 +62,7 @@ the auto-load mechanism defined below. .SH "COMMAND PROCEDURES" .PP The following procedures are provided in the Tcl library: +.\" COMMAND: auto_execok .TP \fBauto_execok \fIcmd\fR . @@ -97,6 +99,7 @@ you would do: set mayFrob [expr {[llength [\fBauto_execok\fR frobnicate]] > 0}] .CE .RE +.\" COMMAND: auto_import .TP \fBauto_import \fIpattern\fR . @@ -111,6 +114,7 @@ matching rules of \fBnamespace import\fR. .PP It is not normally necessary to call this command directly. .RE +.\" COMMAND: auto_load .TP \fBauto_load \fIcmd\fR . @@ -142,6 +146,7 @@ reload the index database from disk. It is not normally necessary to call this command directly; the default \fBunknown\fR handler will do so. .RE +.\" COMMAND: auto_mkindex .TP \fBauto_mkindex \fIdir pattern pattern ...\fR . @@ -184,6 +189,7 @@ code, such as global initialization code or procedure names with special characters like \fB$\fR, \fB*\fR, \fB[\fR or \fB]\fR, you are safer using \fBauto_mkindex_old\fR. .RE +.\" COMMAND: auto_reset .TP \fBauto_reset\fR . @@ -192,6 +198,7 @@ Destroys all the information cached by \fBauto_execok\fR and time it is needed. \fBAuto_reset\fR also deletes any procedures listed in the auto-load index, so that fresh copies of them will be loaded the next time that they are used. +.\" COMMAND: auto_qualify .TP \fBauto_qualify \fIcommand namespace\fR . @@ -212,6 +219,7 @@ if it were a command in the global namespace. for producing auto-loading indexes such as \fIpkgIndex.tcl\fR, and for performing the actual auto-loading of functions at runtime. .RE +.\" COMMAND: auto_findLibrary .TP \fBtcl_findLibrary \fIbasename version patch initScript enVarName varName\fR . @@ -235,6 +243,7 @@ relative to the executable file in the standard installation bin or bin/\fIarch\fR directory; relative to the executable file in the current build tree; relative to the executable file in a parallel build tree. +.\" COMMAND: parray .TP \fBparray \fIarrayName\fR ?\fIpattern\fR? . @@ -256,6 +265,7 @@ For example, to print the contents of the \fBtcl_platform\fR array, do: .SS "WORD BOUNDARY HELPERS" .PP These procedures are mainly used internally by Tk. +.\" COMMAND: tcl_endOfWord .TP \fBtcl_endOfWord \fIstr start\fR . @@ -267,6 +277,7 @@ are no more end-of-word locations after the starting point. See the description of \fBtcl_wordchars\fR and \fBtcl_nonwordchars\fR below for more details on how Tcl determines which characters are word characters. +.\" COMMAND: tcl_startOfNextWord .TP \fBtcl_startOfNextWord \fIstr start\fR . @@ -288,6 +299,7 @@ for {set idx 0} {$idx >= 0} { } .CE .RE +.\" COMMAND: tcl_startOfPreviousWord .TP \fBtcl_startOfPreviousWord \fIstr start\fR . @@ -295,6 +307,7 @@ Returns the index of the first start-of-word location that occurs before a starting index \fIstart\fR in the string \fIstr\fR. Returns \-1 if there are no more start-of-word locations before the starting point. +.\" COMMAND: tcl_wordBreakAfter .TP \fBtcl_wordBreakAfter \fIstr start\fR . @@ -303,6 +316,7 @@ Returns the index of the first word boundary after the starting index boundaries after the starting point in the given string. The index returned refers to the second character of the pair that comprises a boundary. +.\" COMMAND: tcl_wordBreakBefore .TP \fBtcl_wordBreakBefore \fIstr start\fR . @@ -311,6 +325,8 @@ Returns the index of the first word boundary before the starting index boundaries before the starting point in the given string. The index returned refers to the second character of the pair that comprises a boundary. +.SS "FILE ACCESS HELPERS" +.\" COMMAND: foreachLine .TP \fBforeachLine \fIvarName filename body\fR .VS "Tcl 8.7, TIP 670" @@ -325,6 +341,7 @@ The overall result of \fBforeachLine\fR is the empty string (assuming no errors from I/O or from evaluating the body of the loop); the file will be closed prior to the procedure returning. .VE "Tcl 8.7, TIP 670" +.\" COMMAND: readFile .TP \fBreadFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? .VS "Tcl 8.7, TIP 670" @@ -335,6 +352,7 @@ The second argument says how to read in the file, either as \fBtext\fR will include any trailing newline. The file will be closed prior to the procedure returning. .VE "Tcl 8.7, TIP 670" +.\" COMMAND: writeFile .TP \fBwriteFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fIcontents\fR .VS "Tcl 8.7, TIP 670" @@ -352,6 +370,7 @@ The following global variables are defined or used by the procedures in the Tcl library. They fall into two broad classes, handling unknown commands and packages, and determining what are words. .SS "AUTOLOADING AND PACKAGE MANAGEMENT VARIABLES" +.\" VARIABLE: auto_execs .TP \fBauto_execs\fR . @@ -361,6 +380,7 @@ particular commands exist as executable files. .PP Not normally usefully accessed directly by user code. .RE +.\" VARIABLE: auto_index .TP \fBauto_index\fR . @@ -370,16 +390,19 @@ disk. .PP Not normally usefully accessed directly by user code. .RE +.\" VARIABLE: auto_noexec .TP \fBauto_noexec\fR . If set to any value, then \fBunknown\fR will not attempt to auto-exec any commands. +.\" VARIABLE: auto_noload .TP \fBauto_noload\fR . If set to any value, then \fBunknown\fR will not attempt to auto-load any commands. +.\" VARIABLE: auto_path .TP \fBauto_path\fR . @@ -405,6 +428,7 @@ lappend \fBauto_path\fR [file dirname [info script]]/lib Note that if the script uses \fBcd\fR, it is advisable to ensure that entries on the \fBauto_path\fR are \fBfile normalize\fRd. .RE +.\" VARIABLE: env(TCL_LIBRARY) .TP \fBenv(TCL_LIBRARY)\fR . @@ -419,6 +443,7 @@ Use of this environment variable is not recommended outside of testing. Tcl installations should already know where to find their own script files, as the value is baked in during the build or installation. .RE +.\" VARIABLE: env(TCLLIBPATH) .TP \fBenv(TCLLIBPATH)\fR . @@ -441,6 +466,7 @@ as their own threads or subprocesses). These variables are only used in the \fBtcl_endOfWord\fR, \fBtcl_startOfNextWord\fR, \fBtcl_startOfPreviousWord\fR, \fBtcl_wordBreakAfter\fR, and \fBtcl_wordBreakBefore\fR commands. +.\" VARIABLE: tcl_nonwordchars .TP \fBtcl_nonwordchars\fR . @@ -449,6 +475,7 @@ like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is considered to be a non-word character. The default value is .QW "\\W" . +.\" VARIABLE: tcl_wordchars .TP \fBtcl_wordchars\fR . @@ -15,7 +15,7 @@ link \- create link from command to method of object .nf package require tcl::oo -\fBlink\fR \fImethodName\fR ?\fI...\fR? +\fBlink\fI methodName\fR ?\fI...\fR? \fBlink\fR \fB{\fIcommandName methodName\fB}\fR ?\fI...\fR? .fi .BE @@ -38,17 +38,14 @@ Tcl interpreter. The name of the initialization procedure is determined by \fIprefix\fR and whether or not the target interpreter is a safe one. For normal interpreters the name of the initialization -procedure will have the form \fIpfx\fB_Init\fR, where \fIpfx\fR -is the same as \fIprefix\fR except that the first letter is -converted to upper case and all other letters -are converted to lower case. For example, if \fIprefix\fR is -\fBfoo\fR or \fBFOo\fR, the initialization procedure's name will +procedure will have the form \fIprefix\fB_Init\fR. For example, if +\fIprefix\fR is \fBFoo\fR, the initialization procedure's name will be \fBFoo_Init\fR. .PP If the target interpreter is a safe interpreter, then the name -of the initialization procedure will be \fIpfx\fB_SafeInit\fR -instead of \fIpfx\fB_Init\fR. -The \fIpfx\fB_SafeInit\fR function should be written carefully, so that it +of the initialization procedure will be \fIprefix\fB_SafeInit\fR +instead of \fIprefix\fB_Init\fR. +The \fIprefix\fB_SafeInit\fR function should be written carefully, so that it initializes the safe interpreter only with partial functionality provided by the library that is safe for use by untrusted code. For more information on Safe\-Tcl, see the \fBsafe\fR manual entry. @@ -84,13 +81,11 @@ If \fIfileName\fR is an empty string, then \fIprefix\fR must be specified. .PP If \fIprefix\fR is omitted or specified as an empty string, -Tcl tries to guess the prefix. This may be done differently on -different platforms. The default guess, which is used on most -UNIX platforms, is to take the last element of +Tcl tries to guess the prefix by taking the last element of \fIfileName\fR, strip off the first three characters if they -are \fBlib\fR, then strip off the next three characters if they -are \fBtcl\fR, and use any following alphabetic and -underline characters, converted to titlecase as the prefix. +are \fBlib\fR, then strip off the next three characters if +they are \fBtcl9\fR, and use any following wordchars but not digits, +converted to titlecase as the prefix. For example, the command \fBload libxyz4.2.so\fR uses the prefix \fBXyz\fR and the command \fBload bin/last.so {}\fR uses the prefix \fBLast\fR. @@ -122,7 +117,7 @@ use this when you know what you are doing, you will not get a nice error message when something is wrong with the loaded library. .SH "PORTABILITY ISSUES" .TP -\fBWindows\fR\0\0\0\0\0 +\fBWindows\fR . When a load fails with .QW "library not found" @@ -18,14 +18,15 @@ lpop \- Get and remove an element in a list The \fBlpop\fR command accepts a parameter, \fIvarName\fR, which it interprets as the name of a variable containing a Tcl list. It also accepts one or more \fIindices\fR into -the list. If no indices are presented, it defaults to "end". +the list. If no indices are presented, it defaults to "\fBend\fR". .PP When presented with a single index, the \fBlpop\fR command addresses the \fIindex\fR'th element in it, removes if from the list and returns the element. .PP If \fIindex\fR is negative or greater or equal than the number -of elements in \fI$varName\fR, then an error occurs. +of elements in the list in the variable called \fIvarName\fR, an +error occurs. .PP The interpretation of each simple \fIindex\fR value is the same as for the command \fBstring index\fR, supporting simple index @@ -34,7 +35,8 @@ arithmetic and indices relative to the end of the list. If additional \fIindex\fR arguments are supplied, then each argument is used in turn to address an element within a sublist designated by the previous indexing operation, -allowing the script to remove elements in sublists. +allowing the script to remove elements in sublists, similar to +\fBlindex\fR and \fBlset\fR. The command, .PP .CS diff --git a/doc/lrange.n b/doc/lrange.n index 38c4abf..8dac91f 100644 --- a/doc/lrange.n +++ b/doc/lrange.n @@ -29,7 +29,8 @@ If \fIlast\fR is greater than or equal to the number of elements in the list, then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty string is returned. -Note: +.PP +Note that .QW "\fBlrange \fIlist first first\fR" does not always produce the same result as .QW "\fBlindex \fIlist first\fR" diff --git a/doc/lrepeat.n b/doc/lrepeat.n index cd672db..8e4cc41 100644 --- a/doc/lrepeat.n +++ b/doc/lrepeat.n @@ -18,7 +18,9 @@ lrepeat \- Build a list by repeating elements The \fBlrepeat\fR command creates a list of size \fIcount * number of elements\fR by repeating \fIcount\fR times the sequence of elements \fIelement ...\fR. \fIcount\fR must be a non-negative integer, -\fIelement\fR can be any Tcl value. Note that \fBlrepeat 1 element ...\fR +\fIelement\fR can be any Tcl value. +.PP +Note that \fBlrepeat 1 element ...\fR is identical to \fBlist element ...\fR. .SH EXAMPLES .CS diff --git a/doc/lsearch.n b/doc/lsearch.n index dc6d1f7..cc5d795 100644 --- a/doc/lsearch.n +++ b/doc/lsearch.n @@ -31,22 +31,26 @@ indicates how the elements of the list are to be matched against If all matching style options are omitted, the default matching style is \fB\-glob\fR. If more than one matching style is specified, the last matching style given takes precedence. +.\" OPTION: -exact .TP \fB\-exact\fR . \fIPattern\fR is a literal string that is compared for exact equality against each list element. +.\" OPTION: -glob .TP \fB\-glob\fR . \fIPattern\fR is a glob-style pattern which is matched against each list element using the same rules as the \fBstring match\fR command. +.\" OPTION: -regexp .TP \fB\-regexp\fR . \fIPattern\fR is treated as a regular expression and matched against each list element using the rules described in the \fBre_syntax\fR reference page. +.\" OPTION: -sorted .TP \fB\-sorted\fR . @@ -60,24 +64,28 @@ is treated exactly like \fB\-exact\fR when either \fB\-all\fR or .SS "GENERAL MODIFIER OPTIONS" .PP These options may be given with all matching styles. +.\" OPTION: -all .TP \fB\-all\fR . Changes the result to be the list of all matching indices (or all matching values if \fB\-inline\fR is specified as well.) If indices are returned, the -indices will be in numeric order. If values are returned, the order of the -values will be the order of those values within the input \fIlist\fR. +indices will be in ascending numeric order. If values are returned, the order +of the values will be the order of those values within the input \fIlist\fR. +.\" OPTION: -inline .TP \fB\-inline\fR . The matching value is returned instead of its index (or an empty string if no value matches.) If \fB\-all\fR is also specified, then the result of the command is the list of all values that matched. +.\" OPTION: -not .TP \fB\-not\fR . This negates the sense of the match, returning the index of the first non-matching value in the list. +.\" OPTION: -start .TP \fB\-start\fR\0\fIindex\fR . @@ -91,11 +99,13 @@ These options describe how to interpret the items in the list being searched. They are only meaningful when used with the \fB\-exact\fR and \fB\-sorted\fR options. If more than one is specified, the last one takes precedence. The default is \fB\-ascii\fR. +.\" OPTION: -ascii .TP \fB\-ascii\fR . The list elements are to be examined as Unicode strings (the name is for backward-compatibility reasons.) +.\" OPTION: -dictionary .TP \fB\-dictionary\fR . @@ -104,16 +114,19 @@ comparisons (see \fBlsort\fR for a fuller description). Note that this only makes a meaningful difference from the \fB\-ascii\fR option when the \fB\-sorted\fR option is given, because values are only dictionary-equal when exactly equal. +.\" OPTION: -integer .TP \fB\-integer\fR . The list elements are to be compared as integers. +.\" OPTION: -nocase .TP \fB\-nocase\fR . Causes comparisons to be handled in a case-insensitive manner. Has no effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or \fB\-real\fR options. +.\" OPTION: -real .TP \fB\-real\fR . @@ -123,18 +136,22 @@ The list elements are to be compared as floating-point values. These options (only meaningful with the \fB\-sorted\fR option) specify how the list is sorted. If more than one is given, the last one takes precedence. The default option is \fB\-increasing\fR. +.\" OPTION: -decreasing .TP \fB\-decreasing\fR . The list elements are sorted in decreasing order. This option is only meaningful when used with \fB\-sorted\fR. +.\" OPTION: -increasing .TP \fB\-increasing\fR . The list elements are sorted in increasing order. This option is only meaningful when used with \fB\-sorted\fR. +.\" OPTION: -bisect .TP \fB\-bisect\fR +. Inexact search when the list elements are in sorted order. For an increasing list the last index where the element is less than or equal to the pattern is returned. For a decreasing list the last index where the element is greater @@ -146,6 +163,7 @@ or \fB\-not\fR. .PP These options are used to search lists of lists. They may be used with any other options. +.\" OPTION: -stride .TP \fB\-stride\0\fIstrideLength\fR . @@ -159,6 +177,7 @@ index always points to the first element in a group. The list length must be an integer multiple of \fIstrideLength\fR, which in turn must be at least 1. A \fIstrideLength\fR of 1 is the default and indicates no grouping. +.\" OPTION: -index .TP \fB\-index\fR\0\fIindexList\fR . @@ -166,6 +185,7 @@ This option is designed for use when searching within nested lists. The \fIindexList\fR argument gives a path of indices (much as might be used with the \fBlindex\fR or \fBlset\fR commands) within each element to allow the location of the term being matched against. +.\" OPTION: -subindices .TP \fB\-subindices\fR . @@ -11,85 +11,115 @@ .SH NAME lseq \- Build a numeric sequence returned as a list .SH SYNOPSIS +.nf \fBlseq \fIstart \fR?(\fB..\fR|\fBto\fR)? \fIend\fR ??\fBby\fR? \fIstep\fR? - -\fBlseq \fIstart \fBcount\fR \fIcount\fR ??\fBby\fR? \fIstep\fR? - +\fBlseq \fIstart \fBcount\fI count\fR ??\fBby\fR? \fIstep\fR? \fBlseq \fIcount\fR ?\fBby \fIstep\fR? +.fi .BE .SH DESCRIPTION .PP The \fBlseq\fR command creates a sequence of numeric values using the given -parameters \fIstart\fR, \fIend\fR, and \fIstep\fR. -The \fIoperation\fR argument -.QW \fB..\fR -or -.QW \fBto\fR -defines an inclusive range; if it is omitted, the range is exclusive. -The \fBcount\fR option is used to define a count of the number of elements in -the list. -The \fIstep\fR (which may be preceded by \fBby\fR) is 1 if not provided. -The short form with a -single \fIcount\fR value will create a range from 0 to \fIcount\fR-1 (i.e., -\fIcount\fR values). +parameters \fIstart\fR, \fIend\fR, and \fIstep\fR. The \fIoperation\fR +argument "\fB..\fR" or "\fBto\fR" defines the range. The "\fBcount\fR" option +is used to define a count of the number of elements in the list. A short form +use of the command, with a single count value, will create a range from 0 to +\fIcount\fR-1. +.PP +The \fBlseq\fR command can produce both increasing and decreasing +sequences. When both \fIstart\fR and \fIend\fR are provided without a +\fIstep\fR value, then if \fIstart\fR <= \fIend\fR, the sequence will be +increasing and if \fIstart\fR > \fIend\fR it will be decreasing. If a +\fIstep\fR vale is included, it's sign should agree with the direction of the +sequence (descending \(-> negative and ascending \(-> positive), otherwise an +empty list is returned. For example: +.RS +.PP +.CS \" +% \fBlseq\fR 1 to 5 ;# increasing +\fI\(-> 1 2 3 4 5 + +% \fBlseq\fR 5 to 1 ;# decreasing +\fI\(-> 5 4 3 2 1 + +% \fBlseq\fR 6 to 1 by 2 ;# decreasing, step wrong sign, empty list + +% \fBlseq\fR 1 to 5 by 0 ;# all step sizes of 0 produce an empty list +.\" +.CE +.RE +.PP +The numeric arguments, \fIstart\fR, \fIend\fR, \fIstep\fR, and \fIcount\fR, +may also be a valid expression. The expression will be evaluated and the +numeric result will be used. An expression that does not evaluate to a number +will produce an invalid argument error. +.PP +\fIStart\fR defines the initial value and \fIend\fR defines the limit, not +necessarily the last value. \fBlseq\fR produces a list with \fIcount\fR +elements, and if \fIcount\fR is not supplied, it is computed as: +.RS +.PP +.CS +\fIcount\fR = int( (\fIend\fR - \fIstart\fR + \fIstep\fR) / \fIstep\fR ) +.CE +.RE .PP The numeric arguments, \fIstart\fR, \fIend\fR, \fIstep\fR, and \fIcount\fR, can also be a valid expression. the \fBlseq\fR command will evaluate the expression (as if with \fBexpr\fR) and use the numeric result, or return an error as with any invalid argument value; a non-numeric expression result will result in an error. - .SH EXAMPLES .CS .\" \fBlseq\fR 3 - \fI\(-> 0 1 2\fR +\fI\(-> 0 1 2\fR \fBlseq\fR 3 0 - \fI\(-> 3 2 1 0\fR +\fI\(-> 3 2 1 0\fR \fBlseq\fR 10 .. 1 by -2 - \fI\(-> 10 8 6 4 2\fR +\fI\(-> 10 8 6 4 2\fR set l [\fBlseq\fR 0 -5] - \fI\(-> 0 -1 -2 -3 -4 -5\fR +\fI\(-> 0 -1 -2 -3 -4 -5\fR foreach i [\fBlseq\fR [llength $l]] { puts l($i)=[lindex $l $i] } - \fI\(-> l(0)=0\fR - \fI\(-> l(1)=-1\fR - \fI\(-> l(2)=-2\fR - \fI\(-> l(3)=-3\fR - \fI\(-> l(4)=-4\fR - \fI\(-> l(5)=-5\fR +\fI\(-> l(0)=0\fR +\fI\(-> l(1)=-1\fR +\fI\(-> l(2)=-2\fR +\fI\(-> l(3)=-3\fR +\fI\(-> l(4)=-4\fR +\fI\(-> l(5)=-5\fR foreach i [\fBlseq\fR {[llength $l]-1} 0] { puts l($i)=[lindex $l $i] } - \fI\(-> l(5)=-5\fR - \fI\(-> l(4)=-4\fR - \fI\(-> l(3)=-3\fR - \fI\(-> l(2)=-2\fR - \fI\(-> l(1)=-1\fR - \fI\(-> l(0)=0\fR +\fI\(-> l(5)=-5\fR +\fI\(-> l(4)=-4\fR +\fI\(-> l(3)=-3\fR +\fI\(-> l(2)=-2\fR +\fI\(-> l(1)=-1\fR +\fI\(-> l(0)=0\fR set i 17 \fI\(-> 17\fR -if {$i in [\fBlseq\fR 0 50]} { # equivalent to: (0 <= $i && $i < 50) +if {$i in [\fBlseq\fR 0 50]} { # equivalent to: (0 <= $i && $i <= 50) puts "Ok" } else { puts "outside :(" } - \fI\(-> Ok\fR +\fI\(-> Ok\fR set sqrs [lmap i [\fBlseq\fR 1 10] { expr {$i*$i} }] - \fI\(-> 1 4 9 16 25 36 49 64 81 100\fR +\fI\(-> 1 4 9 16 25 36 49 64 81 100\fR .\" .CE .SH "SEE ALSO" -foreach(n), list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), -llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n), +foreach(n), list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n), lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, index, list @@ -116,6 +116,8 @@ The indicated return value also becomes the new value of \fIx\fR \fBlset\fR x {2 1} j \fI\(-> {a b c} {d e f} {g j i}\fR \fBlset\fR x {2 3} j + \fI\(-> {a b c} {d e f} {g h i j}\fR +\fBlset\fR x {2 4} j \fI\(-> list index out of range\fR .CE .PP diff --git a/doc/lsort.n b/doc/lsort.n index 1695ea8..4e4f720 100644 --- a/doc/lsort.n +++ b/doc/lsort.n @@ -20,18 +20,20 @@ lsort \- Sort the elements of a list .PP This command sorts the elements of \fIlist\fR, returning a new list in sorted order. The implementation of the \fBlsort\fR command -uses the merge\-sort algorithm which is a stable sort that has O(n log +uses the merge-sort algorithm which is a stable sort that has O(n log n) performance characteristics. .PP By default ASCII sorting is used with the result returned in increasing order. However, any of the following options may be specified before \fIlist\fR to control the sorting process (unique abbreviations are accepted): +.\" OPTION: -ascii .TP \fB\-ascii\fR . Use string comparison with Unicode code-point collation order (the name is for backward-compatibility reasons.) This is the default. +.\" OPTION: -dictionary .TP \fB\-dictionary\fR . @@ -42,14 +44,17 @@ not characters. For example, in \fB\-dictionary\fR mode, \fBbigBoy\fR sorts between \fBbigbang\fR and \fBbigboy\fR, and \fBx10y\fR sorts between \fBx9y\fR and \fBx11y\fR. Overrides the \fB\-nocase\fR option. +.\" OPTION: -integer .TP \fB\-integer\fR . Convert list elements to integers and use integer comparison. +.\" OPTION: -real .TP \fB\-real\fR . Convert list elements to floating-point values and use floating comparison. +.\" OPTION: -command .TP \fB\-command\0\fIcommand\fR . @@ -60,22 +65,26 @@ arguments. The script should return an integer less than, equal to, or greater than zero if the first element is to be considered less than, equal to, or greater than the second, respectively. +.\" OPTION: -increasing .TP \fB\-increasing\fR . Sort the list in increasing order .PQ smallest "items first" . This is the default. +.\" OPTION: -decreasing .TP \fB\-decreasing\fR . Sort the list in decreasing order .PQ largest "items first" . +.\" OPTION: -indices .TP \fB\-indices\fR . Return a list of indices into \fIlist\fR in sorted order instead of the values themselves. +.\" OPTION: -index .TP \fB\-index\0\fIindexList\fR . @@ -119,6 +128,7 @@ returns \fB{{d e m o} 34512} {{b i g} 12345} {{c o d e} 54321}\fR This option is much more efficient than using \fB\-command\fR to achieve the same effect. .RE +.\" OPTION: -stride .TP \fB\-stride\0\fIstrideLength\fR . @@ -136,7 +146,7 @@ in turn must be at least 2. For example, .PP .CS -\fBlsort\fR \-stride 2 {carrot 10 apple 50 banana 25} +\fBlsort\fR -stride 2 {carrot 10 apple 50 banana 25} .CE .PP returns @@ -144,18 +154,20 @@ returns and .PP .CS -\fBlsort\fR \-stride 2 \-index 1 \-integer {carrot 10 apple 50 banana 25} +\fBlsort\fR -stride 2 -index 1 -integer {carrot 10 apple 50 banana 25} .CE .PP returns .QW "carrot 10 banana 25 apple 50" . .RE +.\" OPTION: -nocase .TP \fB\-nocase\fR . Causes comparisons to be handled in a case-insensitive manner. Has no effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or \fB\-real\fR options. +.\" OPTION: -unique .TP \fB\-unique\fR . @@ -234,7 +246,7 @@ Sorting using striding and multiple indices: .PP .CS \fI%\fR # Note the first index value is relative to the group -\fI%\fR \fBlsort\fR \-stride 3 \-index {0 1} \e +\fI%\fR \fBlsort\fR -stride 3 -index {0 1} \e {{Bob Smith} 25 Audi {Jane Doe} 40 Ford} {{Jane Doe} 40 Ford {Bob Smith} 25 Audi} .CE diff --git a/doc/mathfunc.n b/doc/mathfunc.n index 004b7e3..c84dbf7 100644 --- a/doc/mathfunc.n +++ b/doc/mathfunc.n @@ -13,86 +13,51 @@ .SH NAME mathfunc \- Mathematical functions for Tcl expressions .SH SYNOPSIS +.nf package require \fBTcl 8.5-\fR -.sp -\fB::tcl::mathfunc::abs\fR \fIarg\fR -.br -\fB::tcl::mathfunc::acos\fR \fIarg\fR -.br -\fB::tcl::mathfunc::asin\fR \fIarg\fR -.br -\fB::tcl::mathfunc::atan\fR \fIarg\fR -.br -\fB::tcl::mathfunc::atan2\fR \fIy\fR \fIx\fR -.br -\fB::tcl::mathfunc::bool\fR \fIarg\fR -.br -\fB::tcl::mathfunc::ceil\fR \fIarg\fR -.br -\fB::tcl::mathfunc::cos\fR \fIarg\fR -.br -\fB::tcl::mathfunc::cosh\fR \fIarg\fR -.br -\fB::tcl::mathfunc::double\fR \fIarg\fR -.br -\fB::tcl::mathfunc::entier\fR \fIarg\fR -.br -\fB::tcl::mathfunc::exp\fR \fIarg\fR -.br -\fB::tcl::mathfunc::floor\fR \fIarg\fR -.br -\fB::tcl::mathfunc::fmod\fR \fIx\fR \fIy\fR -.br -\fB::tcl::mathfunc::hypot\fR \fIx\fR \fIy\fR -.br -\fB::tcl::mathfunc::int\fR \fIarg\fR -.br + +\fB::tcl::mathfunc::abs\fI arg\fR +\fB::tcl::mathfunc::acos\fI arg\fR +\fB::tcl::mathfunc::asin\fI arg\fR +\fB::tcl::mathfunc::atan\fI arg\fR +\fB::tcl::mathfunc::atan2\fI y x\fR +\fB::tcl::mathfunc::bool\fI arg\fR +\fB::tcl::mathfunc::ceil\fI arg\fR +\fB::tcl::mathfunc::cos\fI arg\fR +\fB::tcl::mathfunc::cosh\fI arg\fR +\fB::tcl::mathfunc::double\fI arg\fR +\fB::tcl::mathfunc::entier\fI arg\fR +\fB::tcl::mathfunc::exp\fI arg\fR +\fB::tcl::mathfunc::floor\fI arg\fR +\fB::tcl::mathfunc::fmod\fI x y\fR +\fB::tcl::mathfunc::hypot\fI x y\fR +\fB::tcl::mathfunc::int\fI arg\fR .VS "8.7, TIP 521" -\fB::tcl::mathfunc::isfinite\fR \fIarg\fR -.br -\fB::tcl::mathfunc::isinf\fR \fIarg\fR -.br -\fB::tcl::mathfunc::isnan\fR \fIarg\fR -.br -\fB::tcl::mathfunc::isnormal\fR \fIarg\fR +\fB::tcl::mathfunc::isfinite\fI arg\fR +\fB::tcl::mathfunc::isinf\fI arg\fR +\fB::tcl::mathfunc::isnan\fI arg\fR +\fB::tcl::mathfunc::isnormal\fI arg\fR .VE "8.7, TIP 521" -.br -\fB::tcl::mathfunc::isqrt\fR \fIarg\fR -.br +\fB::tcl::mathfunc::isqrt\fI arg\fR .VS "8.7, TIP 521" -\fB::tcl::mathfunc::issubnormal\fR \fIarg\fR -.br -\fB::tcl::mathfunc::isunordered\fR \fIx y\fR +\fB::tcl::mathfunc::issubnormal\fI arg\fR +\fB::tcl::mathfunc::isunordered\fI x y\fR .VE "8.7, TIP 521" -.br -\fB::tcl::mathfunc::log\fR \fIarg\fR -.br -\fB::tcl::mathfunc::log10\fR \fIarg\fR -.br -\fB::tcl::mathfunc::max\fR \fIarg\fR ?\fIarg\fR ...? -.br -\fB::tcl::mathfunc::min\fR \fIarg\fR ?\fIarg\fR ...? -.br -\fB::tcl::mathfunc::pow\fR \fIx\fR \fIy\fR -.br +\fB::tcl::mathfunc::log\fI arg\fR +\fB::tcl::mathfunc::log10\fI arg\fR +\fB::tcl::mathfunc::max\fI arg\fR ?\fIarg\fR ...? +\fB::tcl::mathfunc::min\fI arg\fR ?\fIarg\fR ...? +\fB::tcl::mathfunc::pow\fI x y\fR \fB::tcl::mathfunc::rand\fR -.br -\fB::tcl::mathfunc::round\fR \fIarg\fR -.br -\fB::tcl::mathfunc::sin\fR \fIarg\fR -.br -\fB::tcl::mathfunc::sinh\fR \fIarg\fR -.br -\fB::tcl::mathfunc::sqrt\fR \fIarg\fR -.br -\fB::tcl::mathfunc::srand\fR \fIarg\fR -.br -\fB::tcl::mathfunc::tan\fR \fIarg\fR -.br -\fB::tcl::mathfunc::tanh\fR \fIarg\fR -.br -\fB::tcl::mathfunc::wide\fR \fIarg\fR -.sp +\fB::tcl::mathfunc::round\fI arg\fR +\fB::tcl::mathfunc::sin\fI arg\fR +\fB::tcl::mathfunc::sinh\fI arg\fR +\fB::tcl::mathfunc::sqrt\fI arg\fR +\fB::tcl::mathfunc::srand\fI arg\fR +\fB::tcl::mathfunc::tan\fI arg\fR +\fB::tcl::mathfunc::tanh\fI arg\fR +\fB::tcl::mathfunc::wide\fI arg\fR +.fi .BE .SH "DESCRIPTION" .PP @@ -124,31 +89,33 @@ of which work solely with floating-point numbers unless otherwise noted: In addition to these predefined functions, applications may define additional functions by using \fBproc\fR (or any other method, such as \fBinterp alias\fR or \fBTcl_CreateObjCommand\fR) to define -new commands in the \fBtcl::mathfunc\fR namespace. In addition, an -obsolete interface named \fBTcl_CreateMathFunc\fR() is available to -extensions that are written in C. The latter interface is not recommended -for new implementations. +new commands in the \fBtcl::mathfunc\fR namespace. .SS "DETAILED DEFINITIONS" +.\" COMMAND: abs .TP \fBabs \fIarg\fR . Returns the absolute value of \fIarg\fR. \fIArg\fR may be either integer or floating-point, and the result is returned in the same form. +.\" COMMAND: acos .TP \fBacos \fIarg\fR . Returns the arc cosine of \fIarg\fR, in the range [\fI0\fR,\fIpi\fR] radians. \fIArg\fR should be in the range [\fI\-1\fR,\fI1\fR]. +.\" COMMAND: asin .TP \fBasin \fIarg\fR . Returns the arc sine of \fIarg\fR, in the range [\fI\-pi/2\fR,\fIpi/2\fR] radians. \fIArg\fR should be in the range [\fI\-1\fR,\fI1\fR]. +.\" COMMAND: atan .TP \fBatan \fIarg\fR . Returns the arc tangent of \fIarg\fR, in the range [\fI\-pi/2\fR,\fIpi/2\fR] radians. +.\" COMMAND: atan2 .TP \fBatan2 \fIy x\fR . @@ -156,6 +123,7 @@ Returns the arc tangent of \fIy\fR/\fIx\fR, in the range [\fI\-pi\fR,\fIpi\fR] radians. \fIx\fR and \fIy\fR cannot both be 0. If \fIx\fR is greater than \fI0\fR, this is equivalent to .QW "\fBatan \fR[\fBexpr\fR {\fIy\fB/\fIx\fR}]" . +.\" COMMAND: bool .TP \fBbool \fIarg\fR . @@ -164,21 +132,25 @@ Accepts any numeric value, or any string acceptable to boolean value \fB0\fR or \fB1\fR. Non-zero numbers are true. Other numbers are false. Non-numeric strings produce boolean value in agreement with \fBstring is true\fR and \fBstring is false\fR. +.\" COMMAND: ceil .TP \fBceil \fIarg\fR . Returns the smallest integral floating-point value (i.e. with a zero fractional part) not less than \fIarg\fR. The argument may be any numeric value. +.\" COMMAND: cos .TP \fBcos \fIarg\fR . Returns the cosine of \fIarg\fR, measured in radians. +.\" COMMAND: cosh .TP \fBcosh \fIarg\fR . Returns the hyperbolic cosine of \fIarg\fR. If the result would cause an overflow, an error is returned. +.\" COMMAND: double .TP \fBdouble \fIarg\fR . @@ -187,6 +159,7 @@ If \fIarg\fR is a floating-point value, returns \fIarg\fR, otherwise converts \fIarg\fR to floating-point and returns the converted value. May return \fBInf\fR or \fB\-Inf\fR when the argument is a numeric value that exceeds the floating-point range. +.\" COMMAND: entier .TP \fBentier \fIarg\fR . @@ -194,22 +167,26 @@ The argument may be any numeric value. The integer part of \fIarg\fR is determined and returned. The integer range returned by this function is unlimited, unlike \fBint\fR and \fBwide\fR which truncate their range to fit in particular storage widths. +.\" COMMAND: exp .TP \fBexp \fIarg\fR . Returns the exponential of \fIarg\fR, defined as \fIe\fR**\fIarg\fR. If the result would cause an overflow, an error is returned. +.\" COMMAND: floor .TP \fBfloor \fIarg\fR . Returns the largest integral floating-point value (i.e. with a zero fractional part) not greater than \fIarg\fR. The argument may be any numeric value. +.\" COMMAND: fmod .TP \fBfmod \fIx y\fR . Returns the floating-point remainder of the division of \fIx\fR by \fIy\fR. If \fIy\fR is 0, an error is returned. +.\" COMMAND: hypot .TP \fBhypot \fIx y\fR . @@ -218,6 +195,7 @@ approximately .QW "\fBsqrt\fR [\fBexpr\fR {\fIx\fB*\fIx\fB+\fIy\fB*\fIy\fR}]" except for being more numerically stable when the two arguments have substantially different magnitudes. +.\" COMMAND: int .TP \fBint \fIarg\fR . @@ -226,6 +204,7 @@ is determined, and then the low order bits of that integer value up to the machine word size are returned as an integer value. For reference, the number of bytes in the machine word are stored in the \fBwordSize\fR element of the \fBtcl_platform\fR array. +.\" COMMAND: isfinite .TP \fBisfinite \fIarg\fR .VS "8.7, TIP 521" @@ -233,6 +212,7 @@ Returns 1 if the floating-point number \fIarg\fR is finite. That is, if it is zero, subnormal, or normal. Returns 0 if the number is infinite or NaN. Throws an error if \fIarg\fR cannot be promoted to a floating-point value. .VE "8.7, TIP 521" +.\" COMMAND: isinf .TP \fBisinf \fIarg\fR .VS "8.7, TIP 521" @@ -240,6 +220,7 @@ Returns 1 if the floating-point number \fIarg\fR is infinite. Returns 0 if the number is finite or NaN. Throws an error if \fIarg\fR cannot be promoted to a floating-point value. .VE "8.7, TIP 521" +.\" COMMAND: isnan .TP \fBisnan \fIarg\fR .VS "8.7, TIP 521" @@ -247,6 +228,7 @@ Returns 1 if the floating-point number \fIarg\fR is Not-a-Number. Returns 0 if the number is finite or infinite. Throws an error if \fIarg\fR cannot be promoted to a floating-point value. .VE "8.7, TIP 521" +.\" COMMAND: isnormal .TP \fBisnormal \fIarg\fR .VS "8.7, TIP 521" @@ -254,6 +236,7 @@ Returns 1 if the floating-point number \fIarg\fR is normal. Returns 0 if the number is zero, subnormal, infinite or NaN. Throws an error if \fIarg\fR cannot be promoted to a floating-point value. .VE "8.7, TIP 521" +.\" COMMAND: isqrt .TP \fBisqrt \fIarg\fR . @@ -261,6 +244,7 @@ Computes the integer part of the square root of \fIarg\fR. \fIArg\fR must be a positive value, either an integer or a floating point number. Unlike \fBsqrt\fR, which is limited to the precision of a floating point number, \fIisqrt\fR will return a result of arbitrary precision. +.\" COMMAND: issubnormal .TP \fBissubnormal \fIarg\fR .VS "8.7, TIP 521" @@ -269,6 +253,7 @@ result of gradual underflow. Returns 0 if the number is zero, normal, infinite or NaN. Throws an error if \fIarg\fR cannot be promoted to a floating-point value. .VE "8.7, TIP 521" +.\" COMMAND: isunordered .TP \fBisunordered \fIx y\fR .VS "8.7, TIP 521" @@ -278,31 +263,37 @@ are both chosen from among the set of zero, subnormal, normal and infinite values. Throws an error if either \fIx\fR or \fIy\fR cannot be promoted to a floating-point value. .VE "8.7, TIP 521" +.\" COMMAND: log .TP \fBlog \fIarg\fR . Returns the natural logarithm of \fIarg\fR. \fIArg\fR must be a positive value. +.\" COMMAND: log10 .TP \fBlog10 \fIarg\fR . Returns the base 10 logarithm of \fIarg\fR. \fIArg\fR must be a positive value. +.\" COMMAND: max .TP \fBmax \fIarg\fB \fI...\fR . Accepts one or more numeric arguments. Returns the one argument with the greatest value. +.\" COMMAND: min .TP \fBmin \fIarg\fB \fI...\fR . Accepts one or more numeric arguments. Returns the one argument with the least value. +.\" COMMAND: pow .TP \fBpow \fIx y\fR . Computes the value of \fIx\fR raised to the power \fIy\fR. If \fIx\fR is negative, \fIy\fR must be an integer value. +.\" COMMAND: rand .TP \fBrand\fR . @@ -313,20 +304,24 @@ determines all future results from subsequent calls to \fBrand\fR, so \fBrand\fR should not be used to generate a sequence of secrets, such as one-time passwords. The seed of the generator is initialized from the internal clock of the machine or may be set with the \fBsrand\fR function. +.\" COMMAND: round .TP \fBround \fIarg\fR . If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts \fIarg\fR to integer by rounding and returns the converted value. +.\" COMMAND: sin .TP \fBsin \fIarg\fR . Returns the sine of \fIarg\fR, measured in radians. +.\" COMMAND: sinh .TP \fBsinh \fIarg\fR . Returns the hyperbolic sine of \fIarg\fR. If the result would cause an overflow, an error is returned. +.\" COMMAND: sqrt .TP \fBsqrt \fIarg\fR . @@ -334,20 +329,24 @@ The argument may be any non-negative numeric value. Returns a floating-point value that is the square root of \fIarg\fR. May return \fBInf\fR when the argument is a numeric value that exceeds the square of the maximum value of the floating-point range. +.\" COMMAND: srand .TP \fBsrand \fIarg\fR . The \fIarg\fR, which must be an integer, is used to reset the seed for the random number generator of \fBrand\fR. Returns the first random number (see \fBrand\fR) from that seed. Each interpreter has its own seed. +.\" COMMAND: tan .TP \fBtan \fIarg\fR . Returns the tangent of \fIarg\fR, measured in radians. +.\" COMMAND: tanh .TP \fBtanh \fIarg\fR . Returns the hyperbolic tangent of \fIarg\fR. +.\" COMMAND: wide .TP \fBwide \fIarg\fR . diff --git a/doc/mathop.n b/doc/mathop.n index 3a13456..95a5d0e 100644 --- a/doc/mathop.n +++ b/doc/mathop.n @@ -11,64 +11,39 @@ .SH NAME mathop \- Mathematical operators as Tcl commands .SH SYNOPSIS +.nf package require \fBTcl 8.5-\fR -.sp -\fB::tcl::mathop::!\fR \fInumber\fR -.br -\fB::tcl::mathop::~\fR \fInumber\fR -.br + +\fB::tcl::mathop::!\fI number\fR +\fB::tcl::mathop::~\fI number\fR \fB::tcl::mathop::+\fR ?\fInumber\fR ...? -.br -\fB::tcl::mathop::\-\fR \fInumber\fR ?\fInumber\fR ...? -.br +\fB::tcl::mathop::\-\fI number\fR ?\fInumber\fR ...? \fB::tcl::mathop::*\fR ?\fInumber\fR ...? -.br -\fB::tcl::mathop::/\fR \fInumber\fR ?\fInumber\fR ...? -.br -\fB::tcl::mathop::%\fR \fInumber number\fR -.br +\fB::tcl::mathop::/\fI number\fR ?\fInumber\fR ...? +\fB::tcl::mathop::%\fI number number\fR \fB::tcl::mathop::**\fR ?\fInumber\fR ...? -.br \fB::tcl::mathop::&\fR ?\fInumber\fR ...? -.br \fB::tcl::mathop::|\fR ?\fInumber\fR ...? -.br \fB::tcl::mathop::^\fR ?\fInumber\fR ...? -.br -\fB::tcl::mathop::<<\fR \fInumber number\fR -.br -\fB::tcl::mathop::>>\fR \fInumber number\fR -.br +\fB::tcl::mathop::<<\fI number number\fR +\fB::tcl::mathop::>>\fI number number\fR \fB::tcl::mathop::==\fR ?\fIarg\fR ...? -.br -\fB::tcl::mathop::!=\fR \fIarg arg\fR -.br +\fB::tcl::mathop::!=\fI arg arg\fR \fB::tcl::mathop::<\fR ?\fIarg\fR ...? -.br \fB::tcl::mathop::<=\fR ?\fIarg\fR ...? -.br \fB::tcl::mathop::>=\fR ?\fIarg\fR ...? -.br \fB::tcl::mathop::>\fR ?\fIarg\fR ...? -.br \fB::tcl::mathop::eq\fR ?\fIarg\fR ...? -.br -\fB::tcl::mathop::ne\fR \fIarg arg\fR -.br +\fB::tcl::mathop::ne\fI arg arg\fR .VS "8.7, TIP461" \fB::tcl::mathop::lt\fR ?\fIarg\fR ...? -.br \fB::tcl::mathop::le\fR ?\fIarg\fR ...? -.br \fB::tcl::mathop::gt\fR ?\fIarg\fR ...? -.br \fB::tcl::mathop::ge\fR ?\fIarg\fR ...? .VE "8.7, TIP461" -.br -\fB::tcl::mathop::in\fR \fIarg list\fR -.br -\fB::tcl::mathop::ni\fR \fIarg list\fR -.sp +\fB::tcl::mathop::in\fI arg list\fR +\fB::tcl::mathop::ni\fI arg list\fR +.fi .BE .SH DESCRIPTION .PP @@ -92,34 +67,39 @@ The following operator commands are supported: .SS "MATHEMATICAL OPERATORS" .PP The behaviors of the mathematical operator commands are as follows: +.\" COMMAND: ! .TP -\fB!\fR \fIboolean\fR +\fB!\fI boolean\fR . Returns the boolean negation of \fIboolean\fR, where \fIboolean\fR may be any numeric value or any other form of boolean value (i.e. it returns truth if the argument is falsity or zero, and falsity if the argument is truth or non-zero). +.\" COMMAND: + .TP \fB+\fR ?\fInumber\fR ...? . Returns the sum of arbitrarily many arguments. Each \fInumber\fR argument may be any numeric value. If no arguments are given, the result will be zero (the summation identity). +.\" COMMAND: - .TP -\fB\-\fR \fInumber\fR ?\fInumber\fR ...? +\fB\-\fI number\fR ?\fInumber\fR ...? . If only a single \fInumber\fR argument is given, returns the negation of that numeric value. Otherwise returns the number that results when all subsequent numeric values are subtracted from the first one. All \fInumber\fR arguments must be numeric values. At least one argument must be given. +.\" COMMAND: * .TP \fB*\fR ?\fInumber\fR ...? . Returns the product of arbitrarily many arguments. Each \fInumber\fR may be any numeric value. If no arguments are given, the result will be one (the multiplicative identity). +.\" COMMAND: / .TP -\fB/\fR \fInumber\fR ?\fInumber\fR ...? +\fB/\fI number\fR ?\fInumber\fR ...? . If only a single \fInumber\fR argument is given, returns the reciprocal of that numeric value (i.e. the value obtained by dividing 1.0 by that value). @@ -134,8 +114,9 @@ results will be as if the functions \fIfloor\fR and \fIint\fR are applied to them, in that order). If all values in the operation are integers, the result will be an integer. .RE +.\" COMMAND: % .TP -\fB%\fR \fInumber number\fR +\fB%\fI number number\fR . Returns the integral modulus (i.e., remainder) of the first argument with respect to the second. @@ -152,6 +133,7 @@ clarity): \fB==\fR [\fB*\fR [\fB/\fI x y\fR] \fIy\fR] [\fB\-\fI x\fR [\fB%\fI x y\fR]] .CE .RE +.\" COMMAND: ** .TP \fB**\fR ?\fInumber\fR ...? . @@ -171,6 +153,7 @@ arguments are integral values. .PP The behaviors of the comparison operator commands (most of which operate preferentially on numeric arguments) are as follows: +.\" COMMAND: == .TP \fB==\fR ?\fIarg\fR ...? . @@ -178,23 +161,27 @@ Returns whether each argument is equal to the arguments on each side of it in the sense of the \fBexpr\fR == operator (\fIi.e.\fR, numeric comparison if possible, exact string comparison otherwise). If fewer than two arguments are given, this operation always returns a true value. +.\" COMMAND: eq .TP \fBeq\fR ?\fIarg\fR ...? . Returns whether each argument is equal to the arguments on each side of it using exact string comparison. If fewer than two arguments are given, this operation always returns a true value. +.\" COMMAND: != .TP -\fB!=\fR \fIarg arg\fR +\fB!=\fI arg arg\fR . Returns whether the two arguments are not equal to each other, in the sense of the \fBexpr\fR != operator (\fIi.e.\fR, numeric comparison if possible, exact string comparison otherwise). +.\" COMMAND: ne .TP -\fBne\fR \fIarg arg\fR +\fBne\fI arg arg\fR . Returns whether the two arguments are not equal to each other using exact string comparison. +.\" COMMAND: < .TP \fB<\fR ?\fIarg\fR ...? . @@ -205,6 +192,7 @@ otherwise performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. When the arguments are numeric but should be compared as strings, the \fBlt\fR operator or the \fBstring compare\fR command should be used instead. +.\" COMMAND: <= .TP \fB<=\fR ?\fIarg\fR ...? . @@ -215,6 +203,7 @@ otherwise performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. When the arguments are numeric but should be compared as strings, the \fBle\fR operator or the \fBstring compare\fR command should be used instead. +.\" COMMAND: > .TP \fB>\fR ?\fIarg\fR ...? . @@ -225,6 +214,7 @@ otherwise performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. When the arguments are numeric but should be compared as strings, the \fBgt\fR operator or the \fBstring compare\fR command should be used instead. +.\" COMMAND: >= .TP \fB>=\fR ?\fIarg\fR ...? . @@ -235,6 +225,7 @@ otherwise performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. When the arguments are numeric but should be compared as strings, the \fBge\fR operator or the \fBstring compare\fR command should be used instead. +.\" COMMAND: lt .TP \fBlt\fR ?\fIarg\fR ...? .VS "8.7, TIP461" @@ -243,6 +234,7 @@ after the first having to be strictly more than the one preceding it. Comparisons are performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. .VE "8.7, TIP461" +.\" COMMAND: le .TP \fBle\fR ?\fIarg\fR ...? .VS "8.7, TIP461" @@ -251,6 +243,7 @@ after the first having to be equal to or strictly more than the one preceding it Comparisons are performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. .VE "8.7, TIP461" +.\" COMMAND: gt .TP \fBgt\fR ?\fIarg\fR ...? .VS "8.7, TIP461" @@ -259,6 +252,7 @@ after the first having to be strictly less than the one preceding it. Comparisons are performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. .VE "8.7, TIP461" +.\" COMMAND: ge .TP \fBge\fR ?\fIarg\fR ...? .VS "8.7, TIP461" @@ -271,38 +265,44 @@ arguments are present, this operation always returns a true value. .PP The behaviors of the bit-wise operator commands (all of which only operate on integral arguments) are as follows: +.\" COMMAND: ~ .TP -\fB~\fR \fInumber\fR +\fB~\fI number\fR . Returns the bit-wise negation of \fInumber\fR. \fINumber\fR may be an integer of any size. Note that the result of this operation will always have the opposite sign to the input \fInumber\fR. +.\" COMMAND: & .TP \fB&\fR ?\fInumber\fR ...? . Returns the bit-wise AND of each of the arbitrarily many arguments. Each \fInumber\fR must have an integral value. If no arguments are given, the result will be minus one. +.\" COMMAND: | .TP \fB|\fR ?\fInumber\fR ...? . Returns the bit-wise OR of each of the arbitrarily many arguments. Each \fInumber\fR must have an integral value. If no arguments are given, the result will be zero. +.\" COMMAND: ^ .TP \fB^\fR ?\fInumber\fR ...? . Returns the bit-wise XOR of each of the arbitrarily many arguments. Each \fInumber\fR must have an integral value. If no arguments are given, the result will be zero. +.\" COMMAND: << .TP -\fB<<\fR \fInumber number\fR +\fB<<\fI number number\fR . Returns the result of bit-wise shifting the first argument left by the number of bits specified in the second argument. Each \fInumber\fR must have an integral value. +.\" COMMAND: >> .TP -\fB>>\fR \fInumber number\fR +\fB>>\fI number number\fR . Returns the result of bit-wise shifting the first argument right by the number of bits specified in the second argument. Each \fInumber\fR @@ -310,13 +310,15 @@ must have an integral value. .SS "LIST OPERATORS" .PP The behaviors of the list-oriented operator commands are as follows: +.\" COMMAND: in .TP -\fBin\fR \fIarg list\fR +\fBin\fI arg list\fR . Returns whether the value \fIarg\fR is present in the list \fIlist\fR (according to exact string comparison of elements). +.\" COMMAND: ni .TP -\fBni\fR \fIarg list\fR +\fBni\fI arg list\fR . Returns whether the value \fIarg\fR is not present in the list \fIlist\fR (according to exact string comparison of elements). diff --git a/doc/memory.n b/doc/memory.n index fc3ff99..8fe6a9b 100644 --- a/doc/memory.n +++ b/doc/memory.n @@ -18,96 +18,106 @@ debugging capabilities. The memory command has several suboptions, which are described below. It is only available when Tcl has been compiled with memory debugging enabled (when \fBTCL_MEM_DEBUG\fR is defined at compile time), and after \fBTcl_InitMemory\fR has been called. +.\" METHOD: active .TP -\fBmemory active\fR \fIfile\fR +\fBmemory active\fI file\fR . Write a list of all currently allocated memory to the specified \fIfile\fR. +.\" METHOD: break_on_malloc .TP -\fBmemory break_on_malloc\fR \fIcount\fR +\fBmemory break_on_malloc\fI count\fR . -After the \fIcount\fR allocations have been performed, \fBckalloc\fR +After the \fIcount\fR allocations have been performed, \fBTcl_Alloc\fR outputs a message to this effect and that it is now attempting to enter the C debugger. Tcl will then issue a \fISIGINT\fR signal against itself. If you are running Tcl under a C debugger, it should then enter the debugger command mode. +.\" METHOD: info .TP \fBmemory info\fR . Returns a report containing the total allocations and frees since Tcl began, the current packets allocated (the current -number of calls to \fBckalloc\fR not met by a corresponding call -to \fBckfree\fR), the current bytes allocated, and the maximum number +number of calls to \fBTcl_Alloc\fR not met by a corresponding call +to \fBTcl_Free\fR), the current bytes allocated, and the maximum number of packets and bytes allocated. +.\" METHOD: init .TP \fBmemory init \fR[\fBon\fR|\fBoff\fR] . Turn on or off the preinitialization of all allocated memory with bogus bytes. Useful for detecting the use of uninitialized values. +.\" METHOD: objs .TP \fBmemory objs \fIfile\fR . Causes a list of all allocated Tcl_Obj values to be written to the specified \fIfile\fR immediately, together with where they were allocated. Useful for checking for leaks of values. +.\" METHOD: onexit .TP -\fBmemory onexit\fR \fIfile\fR +\fBmemory onexit\fI file\fR . Causes a list of all allocated memory to be written to the specified \fIfile\fR during the finalization of Tcl's memory subsystem. Useful for checking that memory is properly cleaned up during process exit. +.\" METHOD: tag .TP -\fBmemory tag\fR \fIstring\fR +\fBmemory tag\fI string\fR . -Each packet of memory allocated by \fBckalloc\fR can have associated +Each packet of memory allocated by \fBTcl_Alloc\fR can have associated with it a string-valued tag. In the lists of allocated memory generated by \fBmemory active\fR and \fBmemory onexit\fR, the tag for each packet is printed along with other information about the packet. The \fBmemory tag\fR command sets the tag value for subsequent calls -to \fBckalloc\fR to be \fIstring\fR. +to \fBTcl_Alloc\fR to be \fIstring\fR. +.\" METHOD: trace .TP \fBmemory trace \fR[\fBon\fR|\fBoff\fR] . Turns memory tracing on or off. When memory tracing is on, every call -to \fBckalloc\fR causes a line of trace information to be written to -\fIstderr\fR, consisting of the word \fIckalloc\fR, followed by the +to \fBTcl_Alloc\fR causes a line of trace information to be written to +\fIstderr\fR, consisting of the word \fITcl_Alloc\fR, followed by the address returned, the amount of memory allocated, and the C filename and line number of the code performing the allocation. For example: .RS .PP .CS -ckalloc 40e478 98 tclProc.c 1406 +Tcl_Alloc 40e478 98 tclProc.c 1406 .CE .PP -Calls to \fBckfree\fR are traced in the same manner. +Calls to \fBTcl_Free\fR are traced in the same manner. .RE +.\" METHOD: trace_on_at_malloc .TP -\fBmemory trace_on_at_malloc\fR \fIcount\fR +\fBmemory trace_on_at_malloc\fI count\fR . -Enable memory tracing after \fIcount\fR \fBckalloc\fRs have been performed. +Enable memory tracing after \fIcount\fR \fBTcl_Alloc\fRs have been performed. For example, if you enter \fBmemory trace_on_at_malloc 100\fR, -after the 100th call to \fBckalloc\fR, memory trace information will begin +after the 100th call to \fBTcl_Alloc\fR, memory trace information will begin being displayed for all allocations and frees. Since there can be a lot of memory activity before a problem occurs, judicious use of this option can reduce the slowdown caused by tracing (and the amount of trace information produced), if you can identify a number of allocations that occur before the problem sets in. The current number of memory allocations that have occurred since Tcl started is printed on a guard zone failure. +.\" METHOD: validate .TP \fBmemory validate \fR[\fBon\fR|\fBoff\fR] . Turns memory validation on or off. When memory validation is enabled, -on every call to \fBckalloc\fR or \fBckfree\fR, the guard zones are +on every call to \fBTcl_Alloc\fR or \fBTcl_Free\fR, the guard zones are checked for every piece of memory currently in existence that was -allocated by \fBckalloc\fR. This has a large performance impact and +allocated by \fBTcl_Alloc\fR. This has a large performance impact and should only be used when overwrite problems are strongly suspected. The advantage of enabling memory validation is that a guard zone -overwrite can be detected on the first call to \fBckalloc\fR or -\fBckfree\fR after the overwrite occurred, rather than when the +overwrite can be detected on the first call to \fBTcl_Alloc\fR or +\fBTcl_Free\fR after the overwrite occurred, rather than when the specific memory with the overwritten guard zone(s) is freed, which may occur long after the overwrite occurred. .SH "SEE ALSO" -ckalloc, ckfree, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory, TCL_MEM_DEBUG +Tcl_Alloc, Tcl_Free, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory, TCL_MEM_DEBUG .SH KEYWORDS memory, debug '\"Local Variables: diff --git a/doc/msgcat.n b/doc/msgcat.n index c39dc87..21b6aa1 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -11,55 +11,40 @@ .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS +.nf \fBpackage require tcl 8.7\fR -.sp \fBpackage require msgcat 1.7\fR -.sp + \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? -.sp \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? -.sp .VS "TIP 412" -\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR +\fB::msgcat::mcexists\fR ?\fB\-exactnamespace\fR? ?\fB\-exactlocale\fR? \fIsrc-string\fR .VE "TIP 412" -.sp .VS "TIP 490" \fB::msgcat::mcpackagenamespaceget\fR .VE "TIP 490" -.sp \fB::msgcat::mclocale \fR?\fInewLocale\fR? -.sp .VS "TIP 499" \fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... .VE "TIP 499" -.sp .VS "TIP 412" \fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR? .VE "TIP 412" -.sp \fB::msgcat::mcload \fIdirname\fR -.sp \fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? -.sp \fB::msgcat::mcmset \fIlocale src-trans-list\fR -.sp \fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? -.sp \fB::msgcat::mcflmset \fIsrc-trans-list\fR -.sp \fB::msgcat::mcunknown \fIlocale src-string\fR ?\fIarg arg ...\fR? -.sp .VS "TIP 412" \fB::msgcat::mcpackagelocale subcommand\fR ?\fIlocale\fR? -.sp -\fB::msgcat::mcpackageconfig subcommand\fR \fIoption\fR ?\fIvalue\fR? -.sp +\fB::msgcat::mcpackageconfig subcommand\fI option\fR ?\fIvalue\fR? \fB::msgcat::mcforgetpackage\fR .VE "TIP 412" -.sp .VS "TIP 499" \fB::msgcat::mcutil subcommand\fR ?\fIlocale\fR? .VS "TIP 499" +.fi .BE .SH DESCRIPTION .PP @@ -73,20 +58,23 @@ the application source code. New languages or locales may be provided by adding a new file to the message catalog. .PP -\fBmsgcat\fR distinguishes packages by its namespace. -Each package has its own message catalog and configuration settings in \fBmsgcat\fR. +\fBmsgcat\fR distinguishes packages by its namespace. Each package has +its own message catalog and configuration settings in \fBmsgcat\fR. .PP -A \fIlocale\fR is a specification string describing a user language like \fBde_ch\fR for Swiss German. -In \fBmsgcat\fR, there is a global locale initialized by the system locale of the current system. -Each package may decide to use the global locale or to use a package specific locale. +A \fIlocale\fR is a specification string describing a user language like +\fBde_ch\fR for Swiss German. In \fBmsgcat\fR, there is a global locale +initialized by the system locale of the current system. Each package may +decide to use the global locale or to use a package specific locale. .PP -The global locale may be changed on demand, for example by a user initiated language change or within a multi user application like a web server. +The global locale may be changed on demand, for example by a user initiated +language change or within a multi user application like a web server. .PP .VS tip490 Object oriented programming is supported by the use of a package namespace. .VE tip490 .PP .SH COMMANDS +.\" COMMAND: mc .TP \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? . @@ -110,17 +98,20 @@ use the result. If an application is written for a single language in this fashion, then it is easy to add support for additional languages later simply by defining new message catalog entries. .RE -.VS "TIP 490" +.\" COMMAND: mcc .TP -\fB::msgcat::mcn \fInamespace\fR \fIsrc-string\fR ?\fIarg arg ...\fR? -. -Like \fB::msgcat::mc\fR, but with the message namespace specified as first argument. +\fB::msgcat::mcn \fInamespace src-string\fR ?\fIarg arg ...\fR? +.VS "TIP 490" +Like \fB::msgcat::mc\fR, but with the message namespace specified as first +argument. .PP .RS -\fBmcn\fR may be used for cases where the package namespace is not the namespace of the caller. -An example is shown within the description of the command \fB::msgcat::mcpackagenamespaceget\fR below. +\fBmcn\fR may be used for cases where the package namespace is not the +namespace of the caller. An example is shown within the description of the +command \fB::msgcat::mcpackagenamespaceget\fR below. .RE -.PP +.VE +.\" COMMAND: mcmax .TP \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? . @@ -128,33 +119,37 @@ Given several source strings, \fB::msgcat::mcmax\fR returns the length of the longest translated string. This is useful when designing localized GUIs, which may require that all buttons, for example, be a fixed width (which will be the width of the widest button). -.VS "TIP 412" +.\" COMMAND: mcexists .TP -\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? ?\fB-namespace\fR \fInamespace\fR? \fIsrc-string\fR -. +\fB::msgcat::mcexists\fR ?\fB\-exactnamespace\fR? ?\fB\-exactlocale\fR? ?\fB\-namespace\fI namespace\fR? \fIsrc-string\fR +.VS "TIP 412" Return true, if there is a translation for the given \fIsrc-string\fR. .PP .RS -The search may be limited by the option \fB\-exactnamespace\fR to only check the current namespace and not any parent namespaces. +The search may be limited by the option \fB\-exactnamespace\fR to only check +the current namespace and not any parent namespaces. .PP -It may also be limited by the option \fB\-exactlocale\fR to only check the first prefered locale (e.g. first element returned by \fB::msgcat::mcpreferences\fR if global locale is used). +It may also be limited by the option \fB\-exactlocale\fR to only check the +first prefered locale (e.g. first element returned by +\fB::msgcat::mcpreferences\fR if global locale is used). .PP .VE "TIP 412" .VS "TIP 490" -An explicit package namespace may be specified by the option \fB-namespace\fR. +An explicit package namespace may be specified by the option \fB\-namespace\fR. The namespace of the caller is used if not explicitly specified. .RE .PP .VE "TIP 490" -.VS "TIP 490" +.\" COMMAND: mcpackagenamespaceget .TP \fB::msgcat::mcpackagenamespaceget\fR -. -Return the package namespace of the caller. -This command handles all cases described in section \fBOBJECT ORIENTED PROGRAMMING\fR. +.VS "TIP 490" +Return the package namespace of the caller. This command handles all cases +described in section \fBOBJECT ORIENTED PROGRAMMING\fR. .PP .RS -Example usage is a tooltip package, which saves the caller package namespace to update the translation each time the tooltip is shown: +Example usage is a tooltip package, which saves the caller package namespace +to update the translation each time the tooltip is shown: .CS proc ::tooltip::tooltip {widget message} { ... @@ -172,19 +167,24 @@ proc ::tooltip::show {widget messagenamespace message} { .RE .PP .VE "TIP 490" +.\" COMMAND: mclocale .TP \fB::msgcat::mclocale \fR?\fInewLocale\fR? . -If \fInewLocale\fR is omitted, the current locale is returned, otherwise the current locale -is set to \fInewLocale\fR. +If \fInewLocale\fR is omitted, the current locale is returned, otherwise the +current locale is set to \fInewLocale\fR. .PP .RS -If the new locale is set to \fInewLocale\fR, the corresponding preferences are calculated and set. -For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR returns \fB{en_us_funky en_us en {}}\fR. +If the new locale is set to \fInewLocale\fR, the corresponding preferences +are calculated and set. +For example, if the current locale is en_US_funky, then +\fB::msgcat::mcpreferences\fR returns \fB{en_us_funky en_us en {}}\fR. .PP -The same result may be acheved by \fB::msgcat::mcpreferences\fR {*}[\fB::msgcat::mcutil getpreferences\fR \fInewLocale\fR]. +The same result may be achieved by \fB::msgcat::mcpreferences\fR +{*}[\fB::msgcat::mcutil getpreferences\fI newLocale\fR]. .PP -The current locale is always the first element of the list returned by \fBmcpreferences\fR. +The current locale is always the first element of the list returned by +\fBmcpreferences\fR. .PP msgcat stores and compares the locale in a case-insensitive manner, and returns locales in lowercase. @@ -197,6 +197,7 @@ If the locale is set, the preference list of locales is evaluated. Locales in this list are loaded now, if not jet loaded. .VE "TIP 412" .RE +.\" COMMAND: mcpreferences .TP \fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... . @@ -207,34 +208,40 @@ The list is ordered from most specific to least preference. .VS "TIP 499" .RS A set of locale preferences may be given to set the list of locale preferences. -The current locale is also set, which is the first element of the locale preferences list. +The current locale is also set, which is the first element of the locale +preferences list. .PP Locale preferences are loaded now, if not jet loaded. .PP -As an example, the user may prefer French or English text. This may be configured by: +As an example, the user may prefer French or English text. This may be +configured by: .CS ::msgcat::mcpreferences fr en {} .CE .RE .PP -.VS "TIP 499" +.\" COMMAND: mcloadedlocales .TP \fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR? -. -This group of commands manage the list of loaded locales for packages not setting a package locale. +.VS "TIP 499" +This group of commands manage the list of loaded locales for packages not +setting a package locale. .PP .RS The subcommand \fBloaded\fR returns the list of currently loaded locales. .PP -The subcommand \fBclear\fR removes all locales and their data, which are not in the current preference list. +The subcommand \fBclear\fR removes all locales and their data, which are not in +the current preference list. .RE +.VE +.\" COMMAND: mcload .TP \fB::msgcat::mcload \fIdirname\fR -. .VS "TIP 412" Searches the specified directory for files that match the language specifications returned by \fB::msgcat::mcloadedlocales loaded\fR -(or \fBmsgcat::mcpackagelocale preferences\fR if a package locale is set) (note that these are all lowercase), extended by the file extension +(or \fBmsgcat::mcpackagelocale preferences\fR if a package locale is set) +(note that these are all lowercase), extended by the file extension .QW .msg . Each matching file is read in order, assuming a UTF-8 encoding. The file contents are @@ -245,9 +252,12 @@ evaluation. The number of message files which matched the specification and were loaded is returned. .RS .PP -In addition, the given folder is stored in the \fBmsgcat\fR package configuration option \fImcfolder\fR to eventually load message catalog files required by a locale change. +In addition, the given folder is stored in the \fBmsgcat\fR package +configuration option \fImcfolder\fR to eventually load message catalog +files required by a locale change. .VE "TIP 412" .RE +.\" COMMAND: mcset .TP \fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? . @@ -255,6 +265,7 @@ Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the specified \fIlocale\fR and the current namespace. If \fItranslate-string\fR is not specified, \fIsrc-string\fR is used for both. The function returns \fItranslate-string\fR. +.\" COMMAND: mcmset .TP \fB::msgcat::mcmset \fIlocale src-trans-list\fR . @@ -266,15 +277,19 @@ the form {\fIsrc-string translate-string\fR ?\fIsrc-string translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly faster than multiple invocations of \fB::msgcat::mcset\fR. The function returns the number of translations set. +.\" COMMAND: mcflset .TP \fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? +. Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the current namespace for the locale implied by the name of the message catalog being loaded via \fB::msgcat::mcload\fR. If \fItranslate-string\fR is not specified, \fIsrc-string\fR is used for both. The function returns \fItranslate-string\fR. +.\" COMMAND: mcflmset .TP \fB::msgcat::mcflmset \fIsrc-trans-list\fR +. Sets the translation for multiple source strings in \fIsrc-trans-list\fR in the current namespace for the locale implied by the name of the message catalog being loaded via \fB::msgcat::mcload\fR. \fIsrc-trans-list\fR must @@ -282,6 +297,7 @@ have an even number of elements and is in the form {\fIsrc-string translate-string\fR ?\fIsrc-string translate-string ...\fR?} \fB::msgcat::mcflmset\fR can be significantly faster than multiple invocations of \fB::msgcat::mcflset\fR. The function returns the number of translations set. +.\" COMMAND: mcunknown .TP \fB::msgcat::mcunknown \fIlocale src-string\fR ?\fIarg arg ...\fR? . @@ -298,28 +314,37 @@ to \fB::msgcat::mc\fR. .VS "TIP 412" .RS .PP -Note that this routine is only called if the concerned package did not set a package locale unknown command name. +Note that this routine is only called if the concerned package did not set a +package locale unknown command name. .RE +.\" COMMAND: mcforgetpackage .TP \fB::msgcat::mcforgetpackage\fR . -The calling package clears all its state within the \fBmsgcat\fR package including all settings and translations. +The calling package clears all its state within the \fBmsgcat\fR package +including all settings and translations. .VE "TIP 412" .PP +.\" COMMAND: mcutil +.\" METHOD: getpreferences .VS "TIP 499" .TP -\fB::msgcat::mcutil getpreferences\fR \fIlocale\fR +\fB::msgcat::mcutil getpreferences\fI locale\fR . -Return the preferences list of the given locale as described in section \fBLOCALE SPECIFICATION\fR. -An example is the composition of a preference list for the bilingual region "Biel/Bienne" as a concatenation of swiss german and swiss french: +Return the preferences list of the given locale as described in the section +\fBLOCALE SPECIFICATION\fR. +An example is the composition of a preference list for the bilingual region +"Biel/Bienne" as a concatenation of swiss german and swiss french: .CS % concat [lrange [msgcat::mcutil getpreferences fr_CH] 0 end-1] [msgcat::mcutil getpreferences de_CH] fr_ch fr de_ch de {} .CE +.\" METHOD: getsystemlocale .TP \fB::msgcat::mcutil getsystemlocale\fR . -The system locale is returned as described by the section \fBLOCALE SPECIFICATION\fR. +The system locale is returned as described by the section +\fBLOCALE SPECIFICATION\fR. .VE "TIP 499" .PP .SH "LOCALE SPECIFICATION" @@ -360,7 +385,7 @@ msgcat will attempt to extract locale information from the registry. From Windows Vista on, the RFC4747 locale name "lang-script-country-options" is transformed to the locale as "lang_country_script" (Example: sr-Latn-CS -> sr_cs_latin). For Windows XP, the language id is -transformed analoguously (Example: 0c1a -> sr_yu_cyrillic). +transformed analogously (Example: 0c1a -> sr_yu_cyrillic). If all these attempts to discover an initial locale from the user's environment fail, msgcat defaults to an initial locale of .QW C . @@ -533,58 +558,73 @@ A package using \fBmsgcat\fR may choose to use its own package private locale and its own set of loaded locales, independent to the global locale set by \fB::msgcat::mclocale\fR. .PP -This allows a package to change its locale without causing any locales load or removal in other packages and not to invoke the global locale change callback (see below). +This allows a package to change its locale without causing any locales load or +removal in other packages and not to invoke the global locale change callback +(see below). .PP This action is controled by the following ensemble: +.\" COMMAND: mcpackagelocale +.\" METHOD: set .TP \fB::msgcat::mcpackagelocale set\fR ?\fIlocale\fR? . Set or change a package private locale. -The package private locale is set to the given \fIlocale\fR if the \fIlocale\fR is given. -If the option \fIlocale\fR is not given, the package is set to package private locale mode, but no locale is changed (e.g. if the global locale was valid for the package before, it is copied to the package private locale). +The package private locale is set to the given \fIlocale\fR if the \fIlocale\fR +is given. If the option \fIlocale\fR is not given, the package is set to package +private locale mode, but no locale is changed (e.g. if the global locale was +valid for the package before, it is copied to the package private locale). .PP .RS This command may cause the load of locales. .RE +.\" METHOD: get .TP \fB::msgcat::mcpackagelocale get\fR . -Return the package private locale or the global locale, if no package private locale is set. +Return the package private locale or the global locale, if no package private +locale is set. +.\" METHOD: preferences .TP \fB::msgcat::mcpackagelocale preferences\fR ?\fIlocale preference\fR? ... . -With no parameters, return the package private preferences or the global preferences, -if no package private locale is set. -The package locale state (set or not) is not changed (in contrast to the command \fB::msgcat::mcpackagelocale set\fR). +With no parameters, return the package private preferences or the global +preferences, if no package private locale is set. +The package locale state (set or not) is not changed (in contrast to the +command \fB::msgcat::mcpackagelocale set\fR). .PP .RS .VS "TIP 499" -If a set of locale preferences is given, it is set as package locale preference list. -The package locale is set to the first element of the preference list. +If a set of locale preferences is given, it is set as package locale preference +list. The package locale is set to the first element of the preference list. A package locale is activated, if it was not set so far. .PP Locale preferences are loaded now for the package, if not jet loaded. .VE "TIP 499" .RE .PP +.\" METHOD: loaded .TP \fB::msgcat::mcpackagelocale loaded\fR . Return the list of locales loaded for this package. +.\" METHOD: isset .TP \fB::msgcat::mcpackagelocale isset\fR . Returns true, if a package private locale is set. +.\" METHOD: unset .TP \fB::msgcat::mcpackagelocale unset\fR . -Unset the package private locale and use the globale locale. +Unset the package private locale and use the global locale. Load and remove locales to adjust the list of loaded locales for the package to the global loaded locales list. +.\" METHOD: present .TP -\fB::msgcat::mcpackagelocale present\fR \fIlocale\fR +\fB::msgcat::mcpackagelocale present\fI locale\fR . Returns true, if the given locale is loaded for the package. +.\" METHOD: clear .TP \fB::msgcat::mcpackagelocale clear\fR . @@ -594,24 +634,31 @@ Clear any loaded locales of the package not present in the package preferences. .PP Each package using msgcat has a set of options within \fBmsgcat\fR. The package options are described in the next sectionPackage options. -Each package option may be set or unset individually using the following ensemble: +Each package option may be set or unset individually using the following +ensemble: +.\" COMMAND: mcpackageconfig +.\" METHOD: get .TP -\fB::msgcat::mcpackageconfig get\fR \fIoption\fR +\fB::msgcat::mcpackageconfig get\fI option\fR . Return the current value of the given \fIoption\fR. This call returns an error if the option is not set for the package. +.\" METHOD: isset .TP -\fB::msgcat::mcpackageconfig isset\fR \fIoption\fR +\fB::msgcat::mcpackageconfig isset\fI option\fR . Returns 1, if the given \fIoption\fR is set for the package, 0 otherwise. +.\" METHOD: set .TP -\fB::msgcat::mcpackageconfig set\fR \fIoption\fR \fIvalue\fR +\fB::msgcat::mcpackageconfig set\fI option value\fR . Set the given \fIoption\fR to the given \fIvalue\fR. This may invoke additional actions in dependency of the \fIoption\fR. -The return value is 0 or the number of loaded packages for the option \fBmcfolder\fR. +The return value is 0 or the number of loaded packages for the option +\fBmcfolder\fR. +.\" METHOD: unset .TP -\fB::msgcat::mcpackageconfig unset\fR \fIoption\fR +\fB::msgcat::mcpackageconfig unset\fI option\fR . Unsets the given \fIoption\fR for the package. No action is taken if the \fIoption\fR is not set for the package. @@ -622,30 +669,40 @@ The following package options are available for each package: .TP \fBmcfolder\fR . -This is the message folder of the package. This option is set by mcload and by the subcommand set. Both are identical and both return the number of loaded message catalog files. +This is the message folder of the package. This option is set by mcload and by +the subcommand set. Both are identical and both return the number of loaded +message catalog files. .RS .PP -Setting or changing this value will load all locales contained in the preferences valid for the package. This implies also to invoke any set loadcmd (see below). +Setting or changing this value will load all locales contained in the +preferences valid for the package. This implies also to invoke any set +loadcmd (see below). .PP Unsetting this value will disable message file load for the package. .RE .TP \fBloadcmd\fR . -This callback is invoked before a set of message catalog files are loaded for the package which has this property set. +This callback is invoked before a set of message catalog files are loaded for +the package which has this property set. .PP .RS -This callback may be used to do any preparation work for message file load or to get the message data from another source like a data base. In this case, no message files are used (mcfolder is unset). +This callback may be used to do any preparation work for message file load or +to get the message data from another source like a data base. In this case, no +message files are used (mcfolder is unset). .PP See section \fBcallback invocation\fR below. The parameter list appended to this callback is the list of locales to load. .PP -If this callback is changed, it is called with the preferences valid for the package. +If this callback is changed, it is called with the preferences valid for the +package. .RE .TP \fBchangecmd\fR . -This callback is invoked when a default local change was performed. Its purpose is to allow a package to update any dependency on the default locale like showing the GUI in another language. +This callback is invoked when a default local change was performed. Its +purpose is to allow a package to update any dependency on the default locale +like showing the GUI in another language. .PP .RS See the callback invocation section below. @@ -655,15 +712,19 @@ The registered callbacks are invoked in no particular order. .TP \fBunknowncmd\fR . -Use a package locale mcunknown procedure instead of the standard version supplied by the msgcat package (msgcat::mcunknown). +Use a package locale mcunknown procedure instead of the standard version +supplied by the msgcat package (\fBmsgcat::mcunknown\fR). .PP .RS -The called procedure must return the formatted message which will finally be returned by msgcat::mc. +The called procedure must return the formatted message which will finally be +returned by \fBmsgcat::mc\fR. .PP -A generic unknown handler is used if set to the empty string. This consists in returning the key if no arguments are given. With given arguments, format is used to process the arguments. +A generic unknown handler is used if set to the empty string. This consists of +returning the key if no arguments are given. With given arguments, the +\fBformat\fR command is used to process the arguments. .PP See section \fBcallback invocation\fR below. -The appended arguments are identical to \fB::msgcat::mcunknown\fR. +The appended arguments are identical to \fBmsgcat::mcunknown\fR. .RE .SH "Callback invocation" A package may decide to register one or multiple callbacks, as described above. @@ -676,15 +737,20 @@ Callbacks are invoked, if: .PP 3. the registering namespace exists. .PP -If a called routine fails with an error, the \fBbgerror\fR routine for the interpreter is invoked after command completion. -Only exception is the callback \fBunknowncmd\fR, where an error causes the invoking \fBmc\fR-command to fail with that error. +If a called routine fails with an error, the \fBbgerror\fR routine for the +interpreter is invoked after command completion. +Only exception is the callback \fBunknowncmd\fR, where an error causes the +invoking \fBmc\fR-command to fail with that error. .PP .VS tip490 .SH "OBJECT ORIENTED PROGRAMMING" \fBmsgcat\fR supports packages implemented by object oriented programming. Objects and classes should be defined within a package namespace. .PP -There are 3 supported cases where package namespace sensitive commands of msgcat (\fBmc\fR, \fBmcexists\fR, \fBmcpackagelocale\fR, \fBmcforgetpackage\fR, \fBmcpackagenamespaceget\fR, \fBmcpackageconfig\fR, \fBmcset\fR and \fBmcmset\fR) may be called: +There are 3 supported cases where package namespace sensitive commands of msgcat +(\fBmc\fR, \fBmcexists\fR, \fBmcpackagelocale\fR, \fBmcforgetpackage\fR, +\fBmcpackagenamespaceget\fR, \fBmcpackageconfig\fR, \fBmcset\fR and \fBmcmset\fR) +may be called: .PP .TP \fB1) In class definition script\fR @@ -700,7 +766,8 @@ namespace eval ::N2 { .TP \fB2) method defined in a class\fR . -\fBmsgcat\fR command is called from a method in an object and the method is defined in a class. +\fBmsgcat\fR command is called from a method in an object and the method is +defined in a class. .CS namespace eval ::N3Class { mcload $dir/msgs @@ -727,8 +794,8 @@ namespace eval ::N4 { .PP .VE tip490 .SH EXAMPLES -Packages which display a GUI may update their widgets when the global locale changes. -To register to a callback, use: +Packages which display a GUI may update their widgets when the global locale +changes. To register to a callback, use: .CS namespace eval gui { msgcat::mcpackageconfig changecmd updateGUI @@ -742,7 +809,8 @@ fr % New locale is 'fr'. .CE .PP -If locales (or additional locales) are contained in another source like a data base, a package may use the load callback and not mcload: +If locales (or additional locales) are contained in another source like a +database, a package may use the load callback and not \fBmcload\fR: .CS namespace eval db { msgcat::mcpackageconfig loadcmd loadMessages @@ -757,10 +825,12 @@ namespace eval db { } .CE .PP -The \fBclock\fR command implementation uses \fBmsgcat\fR with a package locale to implement the command line parameter \fB-locale\fR. +The \fBclock\fR command implementation uses \fBmsgcat\fR with a package +locale to implement the command line parameter \fB\-locale\fR. Here are some sketches of the implementation: .PP -First, a package locale is initialized and the generic unknown function is desactivated: +First, a package locale is initialized and the generic unknown function is +deactivated: .CS msgcat::mcpackagelocale set msgcat::mcpackageconfig unknowncmd "" @@ -769,13 +839,15 @@ As an example, the user requires the week day in a certain locale as follows: .CS clock format [clock seconds] -format %A -locale fr .CE -\fBclock\fR sets the package locale to \fBfr\fR and looks for the day name as follows: +\fBclock\fR sets the package locale to \fBfr\fR and looks for the day name as +follows: .CS msgcat::mcpackagelocale set $locale return [lindex [msgcat::mc DAYS_OF_WEEK_FULL] $day] ### Returns "mercredi" .CE -Within \fBclock\fR, some message-catalog items are heavy in computation and thus are dynamically cached using: +Within \fBclock\fR, some message-catalog items are heavy in computation and +thus are dynamically cached using: .CS proc ::tcl::clock::LocalizeFormat { locale format } { set key FORMAT_$format @@ -794,7 +866,8 @@ The message catalog code was developed by Mark Harrison. .SH "SEE ALSO" format(n), scan(n), namespace(n), package(n), oo::class(n), oo::object .SH KEYWORDS -internationalization, i18n, localization, l10n, message, text, translation, class, object +internationalization, i18n, localization, l10n, message, text, translation, +class, object .\" Local Variables: .\" mode: nroff .\" End: @@ -35,9 +35,9 @@ defined by that object or class. .VE TIP500 .PP The object upon which the method is invoked via \fBmy\fR is the one that owns -the namespace that the \fBmy\fR command is contained in initially (\fBNB:\fR the link -remains if the command is renamed), which is the currently invoked object by -default. +the namespace that the \fBmy\fR command is contained in initially (\fBNB:\fR the +link remains if the command is renamed), which is the currently invoked object +by default. .VS TIP478 Similarly, the object on which the method is invoked via \fBmyclass\fR is the object that is the current class of the object that owns the namespace that diff --git a/doc/namespace.n b/doc/namespace.n index 4be0a3a..5f02082 100644 --- a/doc/namespace.n +++ b/doc/namespace.n @@ -24,6 +24,7 @@ See the section \fBWHAT IS A NAMESPACE?\fR below for a brief overview of namespaces. The legal values of \fIsubcommand\fR are listed below. Note that you can abbreviate the \fIsubcommand\fRs. +.\" METHOD: children .TP \fBnamespace children \fR?\fInamespace\fR? ?\fIpattern\fR? . @@ -40,6 +41,7 @@ a pattern that starts with double colon (\fB::\fR) is used directly, otherwise the namespace \fInamespace\fR (or the fully-qualified name of the current namespace) is prepended onto the pattern. +.\" METHOD: code .TP \fBnamespace code \fIscript\fR . @@ -68,6 +70,7 @@ A scoped command captures a command together with its namespace context in a way that allows it to be executed properly later. See the section \fBSCOPED SCRIPTS\fR for some examples of how this is used to create callback scripts. +.\" METHOD: current .TP \fBnamespace current\fR . @@ -77,6 +80,7 @@ The actual name of the global namespace is (i.e., an empty string), but this command returns \fB::\fR for the global namespace as a convenience to programmers. +.\" METHOD: delete .TP \fBnamespace delete \fR?\fInamespace namespace ...\fR? . @@ -89,14 +93,16 @@ however, the namespace is marked to prevent other code from looking it up by name. If a namespace does not exist, this command returns an error. If no namespace names are given, this command does nothing. +.\" METHOD: ensemble .TP -\fBnamespace ensemble\fR \fIsubcommand\fR ?\fIarg ...\fR? +\fBnamespace ensemble \fIsubcommand\fR ?\fIarg ...\fR? . Creates and manipulates a command that is formed out of an ensemble of subcommands. See the section \fBENSEMBLES\fR below for further details. +.\" METHOD: eval .TP -\fBnamespace eval\fR \fInamespace arg\fR ?\fIarg ...\fR? +\fBnamespace eval \fInamespace arg\fR ?\fIarg ...\fR? . Activates a namespace called \fInamespace\fR and evaluates some code in that context. @@ -111,11 +117,13 @@ If \fInamespace\fR has leading namespace qualifiers and any leading namespaces do not exist, they are automatically created. .RE +.\" METHOD: exists .TP -\fBnamespace exists\fR \fInamespace\fR +\fBnamespace exists \fInamespace\fR . Returns \fB1\fR if \fInamespace\fR is a valid namespace in the current context, returns \fB0\fR otherwise. +.\" METHOD: export .TP \fBnamespace export \fR?\fB\-clear\fR? ?\fIpattern pattern ...\fR? . @@ -137,6 +145,7 @@ the namespace's export pattern list is reset to empty before any \fIpattern\fR arguments are appended. If no \fIpattern\fRs are given and the \fB\-clear\fR flag is not given, this command returns the namespace's current export list. +.\" METHOD: forget .TP \fBnamespace forget \fR?\fIpattern pattern ...\fR? . @@ -162,8 +171,9 @@ It then checks whether any of those commands were previously imported by the current namespace. If so, this command deletes the corresponding imported commands. In effect, this undoes the action of a \fBnamespace import\fR command. +.\" METHOD: import .TP -\fBnamespace import \fR?\fB\-force\fR? ?\fIpattern\fR \fIpattern ...\fR? +\fBnamespace import \fR?\fB\-force\fR? ?\fIpattern pattern ...\fR? . Imports commands into a namespace, or queries the set of imported commands in a namespace. When no arguments are present, @@ -205,8 +215,9 @@ at the time when the \fBnamespace import\fR command is executed. If another command is defined and exported in this namespace later on, it will not be imported. .RE +.\" METHOD: inscope .TP -\fBnamespace inscope\fR \fInamespace\fR \fIscript\fR ?\fIarg ...\fR? +\fBnamespace inscope \fInamespace script\fR ?\fIarg ...\fR? . Executes a script in the context of the specified \fInamespace\fR. This command is not expected to be used directly by programmers; @@ -232,6 +243,7 @@ is equivalent to thus additional arguments will not undergo a second round of substitution, as is the case with \fBnamespace eval\fR. .RE +.\" METHOD: origin .TP \fBnamespace origin \fIcommand\fR . @@ -247,6 +259,7 @@ this command returns the fully-qualified name of the original command in the first namespace, \fIa\fR. If \fIcommand\fR does not refer to an imported command, the command's own fully-qualified name is returned. +.\" METHOD: parent .TP \fBnamespace parent\fR ?\fInamespace\fR? . @@ -254,6 +267,7 @@ Returns the fully-qualified name of the parent namespace for namespace \fInamespace\fR. If \fInamespace\fR is not specified, the fully-qualified name of the current namespace's parent is returned. +.\" METHOD: path .TP \fBnamespace path\fR ?\fInamespaceList\fR? . @@ -263,8 +277,9 @@ current namespace's command resolution path is set to those namespaces and returns the empty list. The default command resolution path is always empty. See the section \fBNAME RESOLUTION\fR below for an explanation of the rules regarding name resolution. +.\" METHOD: qualifiers .TP -\fBnamespace qualifiers\fR \fIstring\fR +\fBnamespace qualifiers\fI string\fR . Returns any leading namespace qualifiers for \fIstring\fR. Qualifiers are namespace names separated by double colons (\fB::\fR). @@ -272,11 +287,11 @@ For the \fIstring\fR \fB::foo::bar::x\fR, this command returns \fB::foo::bar\fR, and for \fB::\fR it returns an empty string. This command is the complement of the \fBnamespace tail\fR command. -Note that it does not check whether the -namespace names are, in fact, +It does not check whether the namespace names are, in fact, the names of currently defined namespaces. +.\" METHOD: tail .TP -\fBnamespace tail\fR \fIstring\fR +\fBnamespace tail\fI string\fR . Returns the simple name at the end of a qualified string. Qualifiers are namespace names separated by double colons (\fB::\fR). @@ -286,8 +301,9 @@ and for \fB::\fR it returns an empty string. This command is the complement of the \fBnamespace qualifiers\fR command. It does not check whether the namespace names are, in fact, the names of currently defined namespaces. +.\" METHOD: upvar .TP -\fBnamespace upvar\fR \fInamespace\fR ?\fIotherVar myVar \fR...? +\fBnamespace upvar\fI namespace\fR ?\fIotherVar myVar \fR...? . This command arranges for zero or more local variables in the current procedure to refer to variables in \fInamespace\fR. The namespace name is @@ -297,6 +313,7 @@ The command \fBupvar 0 ${ns}::a b\fR, with the sole exception of the resolution rules used for qualified namespace or variable names. \fBnamespace upvar\fR returns an empty string. +.\" METHOD: unknown .TP \fBnamespace unknown\fR ?\fIscript\fR? . @@ -310,6 +327,7 @@ the handler is invoked, the full invocation line will be appended to the script and the result evaluated in the context of the namespace. The default handler for all namespaces is \fB::unknown\fR. If no argument is given, it returns the handler for the current namespace. +.\" METHOD: which .TP \fBnamespace which\fR ?\fB\-command\fR? ?\fB\-variable\fR? \fIname\fR . @@ -527,14 +545,14 @@ about name resolution. For example, the command: .PP .CS -\fBnamespace eval\fR Foo::Debug {\fBnamespace which\fR \-variable traceLevel} +\fBnamespace eval\fR Foo::Debug {\fBnamespace which\fR -variable traceLevel} .CE .PP returns \fB::traceLevel\fR. On the other hand, the command, .PP .CS -\fBnamespace eval\fR Foo {\fBnamespace which\fR \-variable traceLevel} +\fBnamespace eval\fR Foo {\fBnamespace which\fR -variable traceLevel} .CE .PP returns \fB::Foo::traceLevel\fR. @@ -576,7 +594,7 @@ like BLT are contained in a namespace called \fBBlt\fR. Then you might access these commands like this: .PP .CS -Blt::graph .g \-background red +Blt::graph .g -background red Blt::table . .g 0,0 .CE .PP @@ -593,7 +611,7 @@ This adds all exported commands from the \fBBlt\fR namespace into the current namespace context, so you can write code like this: .PP .CS -graph .g \-background red +graph .g -background red table . .g 0,0 .CE .PP @@ -622,7 +640,7 @@ that have appeared in a namespace. In that case, you can use the \fB\-force\fR option, and existing commands will be silently overwritten: .PP .CS -\fBnamespace import\fR \-force Blt::graph Blt::table +\fBnamespace import\fR -force Blt::graph Blt::table .CE .PP If for some reason, you want to stop using the imported commands, @@ -730,6 +748,7 @@ namespace is deleted. The link between an ensemble command and its namespace is maintained however the ensemble is renamed. .PP Three subcommands of the \fBnamespace ensemble\fR command are defined: +.\" METHOD: create .TP \fBnamespace ensemble create\fR ?\fIoption value ...\fR? . @@ -741,6 +760,7 @@ command. If not overridden with the \fB\-command\fR option, this command creates an ensemble with exactly the same name as the linked namespace. See the section \fBENSEMBLE OPTIONS\fR below for a full list of options supported and their effects. +.\" METHOD: configure .TP \fBnamespace ensemble configure \fIcommand\fR ?\fIoption\fR? ?\fIvalue ...\fR? . @@ -748,8 +768,9 @@ Retrieves the value of an option associated with the ensemble command named \fIcommand\fR, or updates some options associated with that ensemble command. See the section \fBENSEMBLE OPTIONS\fR below for a full list of options supported and their effects. +.\" METHOD: exists .TP -\fBnamespace ensemble exists\fR \fIcommand\fR +\fBnamespace ensemble exists\fI command\fR . Returns a boolean value that describes whether the command \fIcommand\fR exists and is an ensemble command. This command only @@ -771,6 +792,7 @@ the \fBuplevel\fR or \fBinfo level\fR commands. The following options, supported by the \fBnamespace ensemble create\fR and \fBnamespace ensemble configure\fR commands, control how an ensemble command behaves: +.\" OPTION: -map .TP \fB\-map\fR . @@ -786,12 +808,15 @@ will be from the local name of the subcommand to its fully-qualified name. Note that when this option is non-empty and the \fB\-subcommands\fR option is empty, the ensemble subcommand names will be exactly those words that have mappings in the dictionary. +.\" OPTION: -parameters .TP \fB\-parameters\fR +. This option gives a list of named arguments (the names being used during generation of error messages) that are passed by the caller of the ensemble between the name of the ensemble and the subcommand argument. By default, it is the empty list. +.\" OPTION: -prefixes .TP \fB\-prefixes\fR . @@ -799,6 +824,7 @@ This option (which is enabled by default) controls whether the ensemble command recognizes unambiguous prefixes of its subcommands. When turned off, the ensemble command requires exact matching of subcommand names. +.\" OPTION: -subcommands .TP \fB\-subcommands\fR . @@ -810,6 +836,7 @@ empty, the subcommands of the namespace will either be the keys of the dictionary listed in the \fB\-map\fR option or the exported commands of the linked namespace at the time of the invocation of the ensemble command. +.\" OPTION: -unknown .TP \fB\-unknown\fR . @@ -824,6 +851,7 @@ unable to determine how to implement a particular subcommand. See .PP The following extra option is allowed by \fBnamespace ensemble create\fR: +.\" OPTION: -command .TP \fB\-command\fR . @@ -835,6 +863,7 @@ command is invoked. .PP The following extra option is allowed by \fBnamespace ensemble configure\fR: +.\" OPTION: -namespace .TP \fB\-namespace\fR . @@ -34,10 +34,10 @@ chain. .PP The \fBnextto\fR command is the same as the \fBnext\fR command, except that it takes an additional \fIclass\fR argument that identifies a class whose -implementation of the current method chain (see \fBinfo object\fR \fBcall\fR) should -be used; the method implementation selected will be the one provided by the -given class, and it must refer to an existing non-filter invocation that lies -further along the chain than the current implementation. +implementation of the current method chain (see \fBinfo object\fR \fBcall\fR) +should be used; the method implementation selected will be the one provided by +the given class, and it must refer to an existing non-filter invocation that +lies further along the chain than the current implementation. .SH "THE METHOD CHAIN" .PP When a method of an object is invoked, things happen in several stages: diff --git a/doc/object.n b/doc/object.n index 98679d1..2bed231 100644 --- a/doc/object.n +++ b/doc/object.n @@ -48,6 +48,7 @@ The \fBoo::object\fR class does not define an explicit constructor. The \fBoo::object\fR class does not define an explicit destructor. .SS "EXPORTED METHODS" The \fBoo::object\fR class supports the following exported methods: +.\" METHOD: destroy .TP \fIobj \fBdestroy\fR . @@ -58,12 +59,14 @@ always the empty string. .SS "NON-EXPORTED METHODS" .PP The \fBoo::object\fR class supports the following non-exported methods: +.\" METHOD: eval .TP \fIobj \fBeval\fR ?\fIarg ...\fR? . This method concatenates the arguments, \fIarg\fR, as if with \fBconcat\fR, and then evaluates the resulting script in the namespace that is uniquely associated with \fIobj\fR, returning the result of the evaluation. +.\" METHOD: unknown .TP \fIobj \fBunknown ?\fImethodName\fR? ?\fIarg ...\fR? . @@ -78,6 +81,7 @@ The default implementation (i.e., the one defined by the \fBoo::object\fR class) generates a suitable error, detailing what methods the object supports given whether the object was invoked by its public name or through the \fBmy\fR command. +.\" METHOD: variable .TP \fIobj \fBvariable \fR?\fIvarName ...\fR? . @@ -86,11 +90,13 @@ the object \fIobj\fR's unique namespace into the caller's context. Thus, if it is invoked from inside a procedure then the namespace variable in the object is linked to the local variable in the procedure. Each \fIvarName\fR argument must not have any namespace separators in it. The result is the empty string. +.\" METHOD: varname .TP \fIobj \fBvarname \fIvarName\fR . This method returns the globally qualified name of the variable \fIvarName\fR in the unique namespace for the object \fIobj\fR. +.\" METHOD: <cloned> .TP \fIobj \fB<cloned> \fIsourceObjectName\fR .VS @@ -12,12 +12,11 @@ .SH NAME open \- Open a file-based or command pipeline channel .SH SYNOPSIS -.sp +.nf \fBopen \fIfileName\fR -.br \fBopen \fIfileName access\fR -.br \fBopen \fIfileName access permissions\fR +.fi .BE .SH DESCRIPTION .PP @@ -32,35 +31,23 @@ conventions described in the \fBfilename\fR manual entry. The \fIaccess\fR argument, if present, indicates the way in which the file (or command pipeline) is to be accessed. In the first form \fIaccess\fR may have any of the following values: -.TP 15 -\fBr\fR -. +.IP \fBr\fR Open the file for reading only; the file must already exist. This is the default value if \fIaccess\fR is not specified. -.TP 15 -\fBr+\fR -. +.IP \fBr+\fR Open the file for both reading and writing; the file must already exist. -.TP 15 -\fBw\fR -. +.IP \fBw\fR Open the file for writing only. Truncate it if it exists. If it does not exist, create a new file. -.TP 15 -\fBw+\fR -. +.IP \fBw+\fR Open the file for reading and writing. Truncate it if it exists. If it does not exist, create a new file. -.TP 15 -\fBa\fR -. +.IP \fBa\fR Open the file for writing only. If the file does not exist, create a new empty file. Set the file pointer to the end of the file prior to each write. -.TP 15 -\fBa+\fR -. +.IP \fBa+\fR Open the file for reading and writing. If the file does not exist, create a new empty file. Set the initial access position to the end of the file. @@ -74,44 +61,26 @@ reading or writing of binary data. In the second form, \fIaccess\fR consists of a list of any of the following flags, most of which have the standard POSIX meanings. One of the flags must be either \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR. -.TP 15 -\fBRDONLY\fR -. +.IP \fBRDONLY\fR Open the file for reading only. -.TP 15 -\fBWRONLY\fR -. +.IP \fBWRONLY\fR Open the file for writing only. -.TP 15 -\fBRDWR\fR -. +.IP \fBRDWR\fR Open the file for both reading and writing. -.TP 15 -\fBAPPEND\fR -. +.IP \fBAPPEND\fR Set the file pointer to the end of the file prior to each write. -.TP 15 -\fBBINARY\fR -. +.IP \fBBINARY\fR Configure the opened channel with the \fB\-translation binary\fR option. -.TP 15 -\fBCREAT\fR -. +.IP \fBCREAT\fR Create the file if it does not already exist (without this flag it is an error for the file not to exist). -.TP 15 -\fBEXCL\fR -. +.IP \fBEXCL\fR If \fBCREAT\fR is also specified, an error is returned if the file already exists. -.TP 15 -\fBNOCTTY\fR -. +.IP \fBNOCTTY\fR If the file is a terminal device, this flag prevents the file from becoming the controlling terminal of the process. -.TP 15 -\fBNONBLOCK\fR -. +.IP \fBNONBLOCK\fR Prevents the process from blocking while opening the file, and possibly in subsequent I/O operations. The exact behavior of this flag is system- and device-dependent; its use is discouraged @@ -119,9 +88,7 @@ this flag is system- and device-dependent; its use is discouraged in nonblocking mode). For details refer to your system documentation on the \fBopen\fR system call's \fBO_NONBLOCK\fR flag. -.TP 15 -\fBTRUNC\fR -. +.IP \fBTRUNC\fR If the file exists it is truncated to zero length. .PP If a new file is created as part of opening it, \fIpermissions\fR @@ -133,6 +100,7 @@ conjunction with the process's file mode creation mask. When the file opened is an ordinary disk file, the \fBchan configure\fR and \fBfconfigure\fR commands can be used to query this additional configuration option: +.\" OPTION: -stat .TP \fB\-stat\fR . @@ -191,8 +159,9 @@ the PORTABILITY ISSUES section. The \fBchan configure\fR and \fBfconfigure\fR commands can be used to query and set additional configuration options specific to serial ports (where supported): +.\" OPTION: -mode .TP -\fB\-mode\fR \fIbaud\fB,\fIparity\fB,\fIdata\fB,\fIstop\fR +\fB\-mode\fI baud\fB,\fIparity\fB,\fIdata\fB,\fIstop\fR . This option is a set of 4 comma-separated values: the baud rate, parity, number of data bits, and number of stop bits for this serial port. The @@ -208,8 +177,9 @@ or \fIData\fR is the number of data bits and should be an integer from 5 to 8, while \fIstop\fR is the number of stop bits and should be the integer 1 or 2. +.\" OPTION: -handshake .TP -\fB\-handshake\fR \fItype\fR +\fB\-handshake\fI type\fR . (Windows and Unix). This option is used to setup automatic handshake control. Note that not all handshake types maybe supported by your operating @@ -226,14 +196,16 @@ There is no default handshake configuration, the initial value depends on your operating system settings. The \fB\-handshake\fR option cannot be queried. .RE +.\" OPTION: -queue .TP \fB\-queue\fR . (Windows and Unix). The \fB\-queue\fR option can only be queried. It returns a list of two integers representing the current number of bytes in the input and output queue respectively. +.\" OPTION: -timeout .TP -\fB\-timeout\fR \fImsec\fR +\fB\-timeout\fI msec\fR . (Windows and Unix). This option is used to set the timeout for blocking read operations. It specifies the maximum interval between the @@ -242,8 +214,9 @@ For Unix systems the granularity is 100 milliseconds. The \fB\-timeout\fR option does not affect write operations or nonblocking reads. This option cannot be queried. +.\" OPTION: -ttycontrol .TP -\fB\-ttycontrol\fR \fI{signal boolean signal boolean ...}\fR +\fB\-ttycontrol\fI {signal boolean signal boolean ...}\fR . (Windows and Unix). This option is used to setup the handshake output lines (see below) permanently or to send a BREAK over the serial line. @@ -255,6 +228,7 @@ It is not a good idea to change the \fBRTS\fR (or \fBDTR\fR) signal with active hardware handshake \fBrtscts\fR (or \fBdtrdsr\fR). The result is unpredictable. The \fB\-ttycontrol\fR option cannot be queried. +.\" OPTION: -ttystatus .TP \fB\-ttystatus\fR . @@ -264,41 +238,38 @@ queried. It returns the current modem status and handshake input signals The result is a list of signal,value pairs with a fixed order, e.g. \fB{CTS 1 DSR 0 RING 1 DCD 0}\fR. The \fIsignal\fR names are returned upper case. +.\" OPTION: -xchar .TP -\fB\-xchar\fR \fI{xonChar xoffChar}\fR +\fB\-xchar\fI {xonChar xoffChar}\fR . (Windows and Unix). This option is used to query or change the software handshake characters. Normally the operating system default should be DC1 (0x11) and DC3 (0x13) representing the ASCII standard XON and XOFF characters. +.\" OPTION: -closemode .TP -\fB\-closemode\fR \fIcloseMode\fR +\fB\-closemode\fI closeMode\fR .VS "8.7, TIP 160" (Windows and Unix). This option is used to query or change the close mode of the serial channel, which defines how pending output in operating system buffers is handled when the channel is closed. The following values for \fIcloseMode\fR are supported: .RS -.TP -\fBdefault\fR -. +.IP \fBdefault\fR indicates that a system default operation should be used; all serial channels default to this. -.TP -\fBdiscard\fR -. +.IP \fBdiscard\fR indicates that the contents of the OS buffers should be discarded. Note that this is \fInot recommended\fR when writing to a POSIX terminal, as it can interact unexpectedly with handling of \fBstderr\fR. -.TP -\fBdrain\fR -. +.IP \fBdrain\fR indicates that Tcl should wait when closing the channel until all output has been consumed. This may slow down \fBclose\fR noticeably. .RE .VE "8.7, TIP 160" +.\" OPTION: -inputmode .TP -\fB\-inputmode\fR \fIinputMode\fR +\fB\-inputmode\fI inputMode\fR .VS "8.7, TIP 160" (Unix only; Windows has the equivalent option on console channels). This option is used to query or change the input mode of the serial channel under @@ -306,26 +277,18 @@ the assumption that it is talking to a terminal, which controls how interactive input from users is handled. The following values for \fIinputMode\fR are supported: .RS -.TP -\fBnormal\fR -. +.IP \fBnormal\fR indicates that normal line-oriented input should be used, with standard terminal editing capabilities enabled. -.TP -\fBpassword\fR -. +.IP \fBpassword\fR indicates that non-echoing input should be used, with standard terminal editing capabilities enabled but no writing of typed characters to the terminal (except for newlines). Some terminals may indicate this specially. -.TP -\fBraw\fR -. +.IP \fBraw\fR indicates that all keyboard input should be given directly to Tcl with the terminal doing no processing at all. It does not echo the keys, leaving it up to the Tcl script to interpret what to do. -.TP -\fBreset\fR (set only) -. +.IP "\fBreset\fR (set only)" indicates that the terminal should be reset to what state it was in when the terminal was opened. .PP @@ -333,6 +296,7 @@ Note that setting this option (technically, anything that changes the terminal state from its initial value \fIvia this option\fR) will cause the channel to turn on an automatic reset of the terminal when the channel is closed. .RE +.\" OPTION: -winsize .TP \fB\-winsize\fR . @@ -340,8 +304,9 @@ turn on an automatic reset of the terminal when the channel is closed. option is query only. It retrieves a two-element list with the the current width and height of the terminal. .VE "8.7, TIP 160" +.\" OPTION: -pollinterval .TP -\fB\-pollinterval\fR \fImsec\fR +\fB\-pollinterval\fI msec\fR . (Windows only). This option is used to set the maximum time between polling for fileevents. @@ -349,16 +314,18 @@ This affects the time interval between checking for events throughout the Tcl interpreter (the smallest value always wins). Use this option only if you want to poll the serial port more or less often than 10 msec (the default). +.\" OPTION: -sysbuffer .TP -\fB\-sysbuffer\fR \fIinSize\fR +\fB\-sysbuffer\fI inSize\fR .TP -\fB\-sysbuffer\fR \fI{inSize outSize}\fR +\fB\-sysbuffer\fI {inSize outSize}\fR . (Windows only). This option is used to change the size of Windows system buffers for a serial channel. Especially at higher communication rates the default input buffer size of 4096 bytes can overrun for latent systems. The first form specifies the input buffer size, in the second form both input and output buffers are defined. +.\" OPTION: -lasterror .TP \fB\-lasterror\fR . @@ -377,29 +344,29 @@ lines and handshaking. Here we are using the terms \fIworkstation\fR for your computer and \fImodem\fR for the external device, because some signal names (DCD, RI) come from modems. Of course your external device may use these signal lines for other purposes. -.IP \fBTXD\fR(output) +.IP "\fBTXD\fR (output)" \fBTransmitted Data:\fR Outgoing serial data. -.IP \fBRXD\fR(input) +.IP "\fBRXD\fR (input)" \fBReceived Data:\fRIncoming serial data. -.IP \fBRTS\fR(output) +.IP "\fBRTS\fR (output)" \fBRequest To Send:\fR This hardware handshake line informs the modem that your workstation is ready to receive data. Your workstation may automatically reset this signal to indicate that the input buffer is full. -.IP \fBCTS\fR(input) +.IP "\fBCTS\fR (input)" \fBClear To Send:\fR The complement to RTS. Indicates that the modem is ready to receive data. -.IP \fBDTR\fR(output) +.IP "\fBDTR\fR (output)" \fBData Terminal Ready:\fR This signal tells the modem that the workstation is ready to establish a link. DTR is often enabled automatically whenever a serial port is opened. -.IP \fBDSR\fR(input) +.IP "\fBDSR\fR (input)" \fBData Set Ready:\fR The complement to DTR. Tells the workstation that the modem is ready to establish a link. -.IP \fBDCD\fR(input) +.IP "\fBDCD\fR (input)" \fBData Carrier Detect:\fR This line becomes active when a modem detects a .QW Carrier signal. -.IP \fBRI\fR(input) +.IP "\fBRI\fR (input)" \fBRing Indicator:\fR Goes active when the modem detects an incoming call. .IP \fBBREAK\fR A BREAK condition is not a hardware signal line, but a logical zero on the @@ -417,39 +384,27 @@ settings may be wrong. That is why a reliable software should always \fBcatch\fR serial read operations. In cases of an error Tcl returns a general file I/O error. Then \fBfconfigure\fR \fB\-lasterror\fR may help to locate the problem. The following error codes may be returned. -.TP 10 -\fBRXOVER\fR -. +.IP \fBRXOVER\fR Windows input buffer overrun. The data comes faster than your scripts reads -it or your system is overloaded. Use \fBfconfigure\fR \fB\-sysbuffer\fR to avoid a -temporary bottleneck and/or make your script faster. -.TP 10 -\fBTXFULL\fR -. +it or your system is overloaded. Use \fBfconfigure\fR \fB\-sysbuffer\fR to +avoid a temporary bottleneck and/or make your script faster. +.IP \fBTXFULL\fR Windows output buffer overrun. Complement to RXOVER. This error should practically not happen, because Tcl cares about the output buffer status. -.TP 10 -\fBOVERRUN\fR -. +.IP \fBOVERRUN\fR UART buffer overrun (hardware) with data lost. The data comes faster than the system driver receives it. Check your advanced serial port settings to enable the FIFO (16550) buffer and/or setup a lower(1) interrupt threshold value. -.TP 10 -\fBRXPARITY\fR -. +.IP \fBRXPARITY\fR A parity error has been detected by your UART. -Wrong parity settings with \fBfconfigure\fR \fB\-mode\fR or a noisy data line (RXD) -may cause this error. -.TP 10 -\fBFRAME\fR -. +Wrong parity settings with \fBfconfigure\fR \fB\-mode\fR or a noisy data line +(RXD) may cause this error. +.IP \fBFRAME\fR A stop-bit error has been detected by your UART. -Wrong mode settings with \fBfconfigure\fR \fB\-mode\fR or a noisy data line (RXD) -may cause this error. -.TP 10 -\fBBREAK\fR -. +Wrong mode settings with \fBfconfigure\fR \fB\-mode\fR or a noisy data line +(RXD) may cause this error. +.IP \fBBREAK\fR A BREAK condition has been detected by your UART (see above). .SS "PORTABILITY ISSUES" .TP @@ -483,7 +438,7 @@ before each write, which is not an atomic operation and does not carry the guarantee of strict appending that is present on POSIX platforms. .RE .TP -\fBUnix\fR\0\0\0\0\0\0\0 +\fBUnix \fR . Valid values for \fIfileName\fR to open a serial port are generally of the form \fB/dev/tty\fIX\fR, where \fIX\fR is \fBa\fR or \fBb\fR, but the name @@ -510,27 +465,22 @@ applications on the various platforms .VS "8.7, TIP 160" On Windows only, console channels (usually \fBstdin\fR or \fBstdout\fR) support the following options: +.\" OPTION: -inputmode .TP -\fB\-inputmode\fR \fIinputMode\fR +\fB\-inputmode\fI inputMode\fR . This option is used to query or change the input mode of the console channel, which controls how interactive input from users is handled. The following values for \fIinputMode\fR are supported: .RS -.TP -\fBnormal\fR -. +.IP \fBnormal\fR indicates that normal line-oriented input should be used, with standard console editing capabilities enabled. -.TP -\fBpassword\fR -. +.IP \fBpassword\fR indicates that non-echoing input should be used, with standard console -editing capabilitied enabled but no writing of typed characters to the +editing capabilities enabled but no writing of typed characters to the terminal (except for newlines). -.TP -\fBraw\fR -. +.IP \fBraw\fR indicates that all keyboard input should be given directly to Tcl with the console doing no processing at all. It does not echo the keys, leaving it up to the Tcl script to interpret what to do. @@ -544,11 +494,12 @@ Note that setting this option (technically, anything that changes the console state from its default \fIvia this option\fR) will cause the channel to turn on an automatic reset of the console when the channel is closed. .RE +.\" OPTION: -winsize .TP \fB\-winsize\fR . This option is query only. -It retrieves a two-element list with the the current width and height of the +It retrieves a two-element list with the current width and height of the console that this channel is talking to. .PP Note that the equivalent options exist on Unix, but are on the serial channel diff --git a/doc/package.n b/doc/package.n index 5687480..d27a44a 100644 --- a/doc/package.n +++ b/doc/package.n @@ -12,7 +12,7 @@ package \- Facilities for package loading and version control .SH SYNOPSIS .nf -\fBpackage files\fR \fIpackage\fR +\fBpackage files\fI package\fR \fBpackage forget\fR ?\fIpackage package ...\fR? \fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR? \fBpackage names\fR @@ -43,19 +43,22 @@ primarily by system scripts that maintain the package database. .PP The behavior of the \fBpackage\fR command is determined by its first argument. The following forms are permitted: +.\" METHOD: files .TP -\fBpackage files\fR \fIpackage\fR +\fBpackage files \fIpackage\fR . Lists all files forming part of \fIpackage\fR. Auto-loaded files are not included in this list, only files which were directly sourced during package initialization. The list order corresponds with the order in which the files were sourced. +.\" METHOD: forget .TP \fBpackage forget\fR ?\fIpackage package ...\fR? . Removes all information about each specified package from this interpreter, including information provided by both \fBpackage ifneeded\fR and \fBpackage provide\fR. +.\" METHOD: ifneeded .TP \fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR? . @@ -78,6 +81,7 @@ If the \fIscript\fR argument is omitted, the current script for version \fIversion\fR of package \fIpackage\fR is returned, or an empty string if no \fBpackage ifneeded\fR command has been invoked for this \fIpackage\fR and \fIversion\fR. +.\" METHOD: names .TP \fBpackage names\fR . @@ -86,11 +90,13 @@ interpreter for which a version has been provided (via \fBpackage provide\fR) or for which a \fBpackage ifneeded\fR script is available. The order of elements in the list is arbitrary. +.\" METHOD: present .TP \fBpackage present\fR ?\fB\-exact\fR? \fIpackage\fR ?\fIrequirement...\fR? . This command is equivalent to \fBpackage require\fR except that it does not try and load the package if it is not already loaded. +.\" METHOD: provide .TP \fBpackage provide \fIpackage \fR?\fIversion\fR? . @@ -104,6 +110,7 @@ If the \fIversion\fR argument is omitted, then the command returns the version number that is currently provided, or an empty string if no \fBpackage provide\fR command has been invoked for \fIpackage\fR in this interpreter. +.\" METHOD: require .TP \fBpackage require \fR\fIpackage \fR?\fIrequirement...\fR? . @@ -156,6 +163,7 @@ package, then the command returns an error. This form of the command is used when only the given \fIversion\fR of \fIpackage\fR is acceptable to the caller. This command is equivalent to \fBpackage require \fIpackage version\fR-\fIversion\fR. +.\" METHOD: unknown .TP \fBpackage unknown \fR?\fIcommand\fR? . @@ -178,18 +186,21 @@ argument, then the current \fBpackage unknown\fR script is returned, or an empty string if there is none. If \fIcommand\fR is specified as an empty string, then the current \fBpackage unknown\fR script is removed, if there is one. +.\" METHOD: vcompare .TP \fBpackage vcompare \fIversion1 version2\fR . Compares the two version numbers given by \fIversion1\fR and \fIversion2\fR. Returns -1 if \fIversion1\fR is an earlier version than \fIversion2\fR, 0 if they are equal, and 1 if \fIversion1\fR is later than \fIversion2\fR. +.\" METHOD: versions .TP \fBpackage versions \fIpackage\fR . Returns a list of all the version numbers of \fIpackage\fR for which information has been provided by \fBpackage ifneeded\fR commands. +.\" METHOD: vsatisfies .TP \fBpackage vsatisfies \fIversion requirement...\fR . @@ -197,33 +208,23 @@ Returns 1 if the \fIversion\fR satisfies at least one of the given requirements, and 0 otherwise. Each \fIrequirement\fR is allowed to have any of the forms: .RS -.TP -min -. +.IP \fImin\fR This form is called .QW min-bounded . -.TP -min- -. +.IP \fImin\fB\-\fR This form is called .QW min-unbound . -.TP -min-max -. +.IP \fImin\fB\-\fImax\fR This form is called .QW bounded . -.RE -.RS .PP where -.QW min +.QW \fImin\fR and -.QW max +.QW \fImax\fR are valid version numbers. The legacy syntax is a special case of the extended syntax, keeping backward compatibility. Regarding satisfaction the rules are: -.RE -.RS .IP [1] The \fIversion\fR has to pass at least one of the listed \fIrequirement\fRs to be satisfactory. @@ -260,8 +261,10 @@ requirement if, and only if it is greater than or equal to the .QW a0 . There is no constraint to a maximum. .RE +.\" METHOD: prefer .TP \fBpackage prefer \fR?\fBlatest\fR|\fBstable\fR? +. With no arguments, the commands returns either .QW latest or diff --git a/doc/packagens.n b/doc/packagens.n index d55151f..42a0686 100644 --- a/doc/packagens.n +++ b/doc/packagens.n @@ -11,24 +11,28 @@ pkg::create \- Construct an appropriate 'package ifneeded' command for a given p .SH SYNOPSIS \fB::pkg::create\fR \fB\-name \fIpackageName \fB\-version \fIpackageVersion\fR ?\fB\-load \fIfilespec\fR? ... ?\fB\-source \fIfilespec\fR? ... .BE - .SH DESCRIPTION .PP \fB::pkg::create\fR is a utility procedure that is part of the standard Tcl library. It is used to create an appropriate \fBpackage ifneeded\fR command for a given package specification. It can be used to construct a \fBpkgIndex.tcl\fR file for use with the \fBpackage\fR mechanism. - .SH OPTIONS The parameters supported are: +.\" OPTION: -name .TP \fB\-name \fIpackageName\fR +. This parameter specifies the name of the package. It is required. +.\" OPTION: -version .TP \fB\-version \fIpackageVersion\fR +. This parameter specifies the version of the package. It is required. +.\" OPTION: -load .TP \fB\-load \fIfilespec\fR +. This parameter specifies a library that must be loaded with the \fBload\fR command. \fIfilespec\fR is a list with two elements. The first element is the name of the file to load. The second, optional @@ -36,8 +40,10 @@ element is a list of commands supplied by loading that file. If the list of procedures is empty or omitted, \fB::pkg::create\fR will set up the library for direct loading (see \fBpkg_mkIndex\fR). Any number of \fB\-load\fR parameters may be specified. +.\" OPTION: -source .TP \fB\-source \fIfilespec\fR +. This parameter is similar to the \fB\-load\fR parameter, except that it specifies a Tcl library that must be loaded with the \fBsource\fR command. Any number of \fB\-source\fR parameters may be @@ -14,7 +14,6 @@ pid \- Retrieve process identifiers .SH SYNOPSIS \fBpid \fR?\fIfileId\fR? .BE - .SH DESCRIPTION .PP If the \fIfileId\fR argument is given then it should normally @@ -40,7 +39,6 @@ puts [string repeat - 70] puts [read $pipeline] close $pipeline .CE - .SH "SEE ALSO" exec(n), open(n) .SH KEYWORDS diff --git a/doc/pkgMkIndex.n b/doc/pkgMkIndex.n index f98cbcd..3d10360 100644 --- a/doc/pkgMkIndex.n +++ b/doc/pkgMkIndex.n @@ -96,29 +96,39 @@ Different versions of a package may be loaded in different interpreters. .SH OPTIONS The optional switches are: +.\" OPTION: -direct .TP 15 \fB\-direct\fR +. The generated index will implement direct loading of the package upon \fBpackage require\fR. This is the default. +.\" OPTION: -lazy .TP 15 \fB\-lazy\fR +. The generated index will manage to delay loading the package until the use of one of the commands provided by the package, instead of loading it immediately upon \fBpackage require\fR. This is not compatible with the use of \fIauto_reset\fR, and therefore its use is discouraged. +.\" OPTION: -load .TP 15 \fB\-load \fIpkgPat\fR +. The index process will preload any packages that exist in the current interpreter and match \fIpkgPat\fR into the child interpreter used to generate the index. The pattern match uses string match rules, but without making case distinctions. See \fBCOMPLEX CASES\fR below. +.\" OPTION: -verbose .TP 15 \fB\-verbose\fR +. Generate output during the indexing process. Output is via the \fBtclLog\fR procedure, which by default prints to stderr. +.\" OPTION: -- .TP 15 \fB\-\-\fR +. End of the flags, in case \fIdir\fR begins with a dash. .SH "PACKAGES AND THE AUTO-LOADER" .PP diff --git a/doc/platform.n b/doc/platform.n index 7cb685d..3ff0568 100644 --- a/doc/platform.n +++ b/doc/platform.n @@ -13,7 +13,7 @@ platform \- System identification support code and utilities .SH SYNOPSIS .nf \fBpackage require platform\fR ?\fB1.0.10\fR? -.sp + \fBplatform::generic\fR \fBplatform::identify\fR \fBplatform::patterns \fIidentifier\fR @@ -43,6 +43,7 @@ establishes a standard naming convention for architectures running Tcl and makes it more convenient for developers to identify the current architecture a Tcl program is running on. .SH COMMANDS +.\" COMMAND: identify .TP \fBplatform::identify\fR . @@ -52,6 +53,7 @@ core is running on. The returned identifier has the general format details like kernel version, libc version, etc., and this information may contain dashes as well. The \fICPU\fR part will not contain dashes, making the preceding dash the last dash in the result. +.\" COMMAND: generic .TP \fBplatform::generic\fR . @@ -59,6 +61,7 @@ This command returns a simplified identifier describing the platform the Tcl core is running on. In contrast to \fBplatform::identify\fR it leaves out details like kernel version, libc version, etc. The returned identifier has the general format \fIOS\fR-\fICPU\fR. +.\" COMMAND: patterns .TP \fBplatform::patterns \fIidentifier\fR . diff --git a/doc/platform_shell.n b/doc/platform_shell.n index a9e14d0..22c2ca4 100644 --- a/doc/platform_shell.n +++ b/doc/platform_shell.n @@ -13,7 +13,7 @@ platform::shell \- System identification support code and utilities .SH SYNOPSIS .nf \fBpackage require platform::shell\fR ?\fB1.1.4\fR? -.sp + \fBplatform::shell::generic \fIshell\fR \fBplatform::shell::identify \fIshell\fR \fBplatform::shell::platform \fIshell\fR @@ -41,16 +41,22 @@ the architecture of the shell which will actually run the installed packages, versus the architecture of the shell running the repository software. .SH COMMANDS +.\" COMMAND: identify .TP \fBplatform::shell::identify \fIshell\fR +. This command does the same identification as \fBplatform::identify\fR, for the specified Tcl shell, in contrast to the running shell. +.\" COMMAND: generic .TP \fBplatform::shell::generic \fIshell\fR +. This command does the same identification as \fBplatform::generic\fR, for the specified Tcl shell, in contrast to the running shell. +.\" COMMAND: platform .TP \fBplatform::shell::platform \fIshell\fR +. This command returns the contents of \fBtcl_platform(platform)\fR for the specified Tcl shell. .SH KEYWORDS diff --git a/doc/prefix.n b/doc/prefix.n index d327a78..a2180e5 100644 --- a/doc/prefix.n +++ b/doc/prefix.n @@ -12,8 +12,8 @@ tcl::prefix \- facilities for prefix matching .SH SYNOPSIS .nf -\fB::tcl::prefix all\fR \fItable string\fR -\fB::tcl::prefix longest\fR \fItable string\fR +\fB::tcl::prefix all\fI table string\fR +\fB::tcl::prefix longest\fI table string\fR \fB::tcl::prefix match\fR ?\fIoption ...\fR? \fItable string\fR .fi .BE @@ -21,16 +21,19 @@ tcl::prefix \- facilities for prefix matching .PP This document describes commands looking up a prefix in a list of strings. The following commands are supported: +.\" METHOD: all .TP -\fB::tcl::prefix all\fR \fItable string\fR +\fB::tcl::prefix all\fI table string\fR . Returns a list of all elements in \fItable\fR that begin with the prefix \fIstring\fR. +.\" METHOD: longest .TP -\fB::tcl::prefix longest\fR \fItable string\fR +\fB::tcl::prefix longest\fI table string\fR . Returns the longest common prefix of all elements in \fItable\fR that begin with the prefix \fIstring\fR. +.\" METHOD: match .TP \fB::tcl::prefix match\fR ?\fIoptions\fR? \fItable string\fR . @@ -41,15 +44,18 @@ before use with this subcommand, so that the list of matches presented in the error message also becomes sorted, though this is not strictly necessary for the operation of this subcommand itself.) .RS +.\" OPTION: -exact .TP -\fB\-exact\fR\0 +\fB\-exact\fR . Accept only exact matches. +.\" OPTION: -message .TP \fB\-message\0\fIstring\fR . Use \fIstring\fR in the error message at a mismatch. Default is .QW option . +.\" OPTION: -error .TP \fB\-error\0\fIoptions\fR . @@ -64,7 +70,7 @@ is used, an error would be generated as: .RS .PP .CS -return \-errorcode MyError \-level 1 \-code error \e +return -errorcode MyError -level 1 -code error \e "ambiguous option ..." .CE .RE @@ -79,9 +85,9 @@ namespace import ::tcl::prefix \fI\(-> apa\fR \fBprefix match\fR {apa bepa cepa} a \fI\(-> apa\fR -\fBprefix match\fR \-exact {apa bepa cepa} a +\fBprefix match\fR -exact {apa bepa cepa} a \fI\(-> bad option "a": must be apa, bepa, or cepa\fR -\fBprefix match\fR \-message "switch" {apa ada bepa cepa} a +\fBprefix match\fR -message "switch" {apa ada bepa cepa} a \fI\(-> ambiguous switch "a": must be apa, ada, bepa, or cepa\fR \fBprefix longest\fR {fblocked fconfigure fcopy file fileevent flush} fc \fI\(-> fco\fR @@ -92,9 +98,9 @@ namespace import ::tcl::prefix Simplifying option matching: .PP .CS -array set opts {\-apa 1 \-bepa "" \-cepa 0} +array set opts {-apa 1 -bepa "" -cepa 0} foreach {arg val} $args { - set opts([\fBprefix match\fR {\-apa \-bepa \-cepa} $arg]) $val + set opts([\fBprefix match\fR {-apa -bepa -cepa} $arg]) $val } .CE .PP @@ -57,10 +57,10 @@ There is one special case to permit procedures with variable numbers of arguments. If the last formal argument has the name .QW \fBargs\fR , then a call to the procedure may contain more actual arguments -than the procedure has formal arguments. In this case, all of the actual arguments -starting at the one that would be assigned to \fBargs\fR are combined into -a list (as if the \fBlist\fR command had been used); this combined value -is assigned to the local variable \fBargs\fR. +than the procedure has formal arguments. In this case, all of the actual +arguments starting at the one that would be assigned to \fBargs\fR are +combined into a list (as if the \fBlist\fR command had been used); this +combined value is assigned to the local variable \fBargs\fR. .PP When \fIbody\fR is being executed, variable names normally refer to local variables, which are created automatically when referenced and diff --git a/doc/process.n b/doc/process.n index 165e413..78c05ad 100644 --- a/doc/process.n +++ b/doc/process.n @@ -18,6 +18,7 @@ tcl::process \- Subprocess management This command provides a way to manage subprocesses created by the \fBopen\fR and \fBexec\fR commands, as identified by the process identifiers (PIDs) of those subprocesses. The legal \fIoptions\fR (which may be abbreviated) are: +.\" METHOD: autopurge .TP \fB::tcl::process autopurge\fR ?\fIflag\fR? . @@ -28,12 +29,14 @@ status as a boolean value. When autopurge is active, executed or a pipe channel created by \fBopen\fR is closed. When autopurge is inactive, \fB::tcl::process\fR purge must be called explicitly. By default autopurge is active. +.\" METHOD: list .TP \fB::tcl::process list\fR . Returns the list of subprocess PIDs. This includes all currently executing subprocesses and all terminated subprocesses that have not yet had their corresponding process table entries purged. +.\" METHOD: purge .TP \fB::tcl::process purge\fR ?\fIpids\fR? . @@ -41,6 +44,7 @@ Cleans up all data associated with terminated subprocesses. If \fIpids\fR is specified as a list of PIDs then the command only cleanup data for the matching subprocesses if they exist, and raises an error otherwise. If a process listed is still active, this command does nothing to that process. +.\" METHOD: status .TP \fB::tcl::process status\fR ?\fIswitches\fR? ?\fIpids\fR? . @@ -53,16 +57,16 @@ processes, the status is a list with the following format: where: .RS .TP -\fIcode\fR\0 +\fIcode\fR . is a standard Tcl return code, i.e., \fB0\fR for TCL_OK and \fB1\fR for TCL_ERROR, .TP -\fImsg\fR\0 +\fImsg\fR . is the human-readable error message, .TP -\fIerrorCode\fR\0 +\fIerrorCode\fR . uses the same format as the \fBerrorCode\fR global variable .PP @@ -72,14 +76,16 @@ hood this command calls \fBTcl_WaitPid\fR with the \fBWNOHANG\fR flag set for non-blocking behavior, unless the \fB\-wait\fR switch is set (see below). .PP Additionally, \fB::tcl::process status\fR accepts the following switches: +.\" OPTION: -wait .TP -\fB\-wait\fR\0 +\fB\-wait\fR . By default the command returns immediately (the underlying \fBTcl_WaitPid\fR is called with the \fBWNOHANG\fR flag set) unless this switch is set. If \fIpids\fR is specified as a list of PIDs then the command waits until the status of the matching subprocesses are available. If \fIpids\fR was not specified, this command will wait for all known subprocesses. +.\" OPTION: -- .TP \fB\-\|\-\fR . @@ -67,7 +67,6 @@ via a file event that the channel is ready for more output data). Encoding errors may exist, if the encoding profile \fBstrict\fR is used. \fBputs\fR writes out data until an encoding error occurs and fails with POSIX error code \fBEILSEQ\fR. - .SH EXAMPLES .PP Write a short message to the console (or wherever \fBstdout\fR is diff --git a/doc/re_syntax.n b/doc/re_syntax.n index ef8c570..1ece560 100644 --- a/doc/re_syntax.n +++ b/doc/re_syntax.n @@ -57,29 +57,17 @@ Without a quantifier, it matches a single match for the atom. The quantifiers, and what a so-quantified atom matches, are: .RS 2 -.TP 6 -\fB*\fR -. +.IP \fB*\fR 6 a sequence of 0 or more matches of the atom -.TP -\fB+\fR -. +.IP \fB+\fR 6 a sequence of 1 or more matches of the atom -.TP -\fB?\fR -. +.IP \fB?\fR 6 a sequence of 0 or 1 matches of the atom -.TP -\fB{\fIm\fB}\fR -. +.IP \fB{\fIm\fB}\fR 6 a sequence of exactly \fIm\fR matches of the atom -.TP -\fB{\fIm\fB,}\fR -. +.IP \fB{\fIm\fB,}\fR 6 a sequence of \fIm\fR or more matches of the atom -.TP -\fB{\fIm\fB,\fIn\fB}\fR -. +.IP \fB{\fIm\fB,\fIn\fB}\fR 6 a sequence of \fIm\fR through \fIn\fR (inclusive) matches of the atom; \fIm\fR may not exceed \fIn\fR .TP @@ -99,32 +87,32 @@ An atom is one of: .IP \fB(\fIre\fB)\fR 6 matches a match for \fIre\fR (\fIre\fR is any regular expression) with the match noted for possible reporting -.IP \fB(?:\fIre\fB)\fR +.IP \fB(?:\fIre\fB)\fR 6 as previous, but does no reporting (a .QW non-capturing set of parentheses) -.IP \fB()\fR +.IP \fB()\fR 6 matches an empty string, noted for possible reporting -.IP \fB(?:)\fR +.IP \fB(?:)\fR 6 matches an empty string, without reporting -.IP \fB[\fIchars\fB]\fR +.IP \fB[\fIchars\fB]\fR 6 a \fIbracket expression\fR, matching any one of the \fIchars\fR (see \fBBRACKET EXPRESSIONS\fR for more detail) -.IP \fB.\fR +.IP \fB.\fR 6 matches any single character -.IP \fB\e\fIk\fR +.IP \fB\e\fIk\fR 6 matches the non-alphanumeric character \fIk\fR taken as an ordinary character, e.g. \fB\e\e\fR matches a backslash character -.IP \fB\e\fIc\fR +.IP \fB\e\fIc\fR 6 where \fIc\fR is alphanumeric (possibly followed by other characters), an \fIescape\fR (AREs only), see \fBESCAPES\fR below -.IP \fB{\fR +.IP \fB{\fR 6 when followed by a character other than a digit, matches the left-brace character .QW \fB{\fR ; when followed by a digit, it is the beginning of a \fIbound\fR (see above) -.IP \fIx\fR +.IP \fIx\fR 6 where \fIx\fR is a single character with no other significance, matches that character. .RE @@ -334,82 +322,50 @@ is the one actual incompatibility between EREs and AREs.) Character-entry escapes (AREs only) exist to make it easier to specify non-printing and otherwise inconvenient characters in REs: .RS 2 -.TP 5 -\fB\ea\fR -. +.IP \fB\ea\fR 5 alert (bell) character, as in C -.TP -\fB\eb\fR -. +.IP \fB\eb\fR 5 backspace, as in C -.TP -\fB\eB\fR -. +.IP \fB\eB\fR 5 synonym for \fB\e\fR to help reduce backslash doubling in some applications where there are multiple levels of backslash processing -.TP -\fB\ec\fIX\fR -. +.IP \fB\ec\fIX\fR 5 (where \fIX\fR is any character) the character whose low-order 5 bits are the same as those of \fIX\fR, and whose other bits are all zero -.TP -\fB\ee\fR -. +.IP \fB\ee\fR 5 the character whose collating-sequence name is .QW \fBESC\fR , or failing that, the character with octal value 033 -.TP -\fB\ef\fR -. +.IP \fB\ef\fR 5 formfeed, as in C -.TP -\fB\en\fR -. +.IP \fB\en\fR 5 newline, as in C -.TP -\fB\er\fR -. +.IP \fB\er\fR 5 carriage return, as in C -.TP -\fB\et\fR -. +.IP \fB\et\fR 5 horizontal tab, as in C -.TP -\fB\eu\fIwxyz\fR -. +.IP \fB\eu\fIwxyz\fR 5 (where \fIwxyz\fR is one up to four hexadecimal digits) the Unicode character \fBU+\fIwxyz\fR in the local byte ordering -.TP -\fB\eU\fIstuvwxyz\fR -. +.IP \fB\eU\fIstuvwxyz\fR 5 (where \fIstuvwxyz\fR is one up to eight hexadecimal digits) reserved for a Unicode extension up to 21 bits. The digits are parsed until the -first non-hexadecimal character is encountered, the maximun of eight +first non-hexadecimal character is encountered, the maximum of eight hexadecimal digits are reached, or an overflow would occur in the maximum value of \fBU+\fI10ffff\fR. -.TP -\fB\ev\fR -. -vertical tab, as in C are all available. -.TP -\fB\ex\fIhh\fR -. +.IP \fB\ev\fR 5 +vertical tab, as in C +.IP \fB\ex\fIhh\fR 5 (where \fIhh\fR is one or two hexadecimal digits) the character whose hexadecimal value is \fB0x\fIhh\fR. -.TP -\fB\e0\fR -. +.IP \fB\e0\fR 5 the character whose value is \fB0\fR -.TP -\fB\e\fIxyz\fR -. +.IP \fB\e\fIxyz\fR 5 (where \fIxyz\fR is exactly three octal digits, and is not a \fIback reference\fR (see below)) the character whose octal value is \fB0\fIxyz\fR. The first digit must be in the range 0-3, otherwise the two-digit form is assumed. -.TP -\fB\e\fIxy\fR -. +.IP \fB\e\fIxy\fR 5 (where \fIxy\fR is exactly two octal digits, and is not a \fIback reference\fR (see below)) the character whose octal value is \fB0\fIxy\fR @@ -446,7 +402,8 @@ commonly-used character classes: .TP \fB\ew\fR . -\fB[[:alnum:]_\eu203F\eu2040\eu2054\euFE33\euFE34\euFE4D\euFE4E\euFE4F\euFF3F]\fR (including punctuation connector characters) +\fB[[:alnum:]_\eu203F\eu2040\eu2054\euFE33\euFE34\euFE4D\euFE4E\euFE4F\euFF3F]\fR +(including punctuation connector characters) .TP \fB\eD\fR . @@ -458,7 +415,8 @@ commonly-used character classes: .TP \fB\eW\fR . -\fB[^[:alnum:]_\eu203F\eu2040\eu2054\euFE33\euFE34\euFE4D\euFE4E\euFE4F\euFF3F]\fR (including punctuation connector characters) +\fB[^[:alnum:]_\eu203F\eu2040\eu2054\euFE33\euFE34\euFE4D\euFE4E\euFE4F\euFF3F]\fR +(including punctuation connector characters) .RE .PP Within bracket expressions, @@ -484,41 +442,25 @@ is illegal.) A constraint escape (AREs only) is a constraint, matching the empty string if specific conditions are met, written as an escape: .RS 2 -.TP 6 -\fB\eA\fR -. +.IP \fB\eA\fR 6 matches only at the beginning of the string (see \fBMATCHING\fR, below, for how this differs from .QW \fB^\fR ) -.TP -\fB\em\fR -. +.IP \fB\em\fR 6 matches only at the beginning of a word -.TP -\fB\eM\fR -. +.IP \fB\eM\fR 6 matches only at the end of a word -.TP -\fB\ey\fR -. +.IP \fB\ey\fR 6 matches only at the beginning or end of a word -.TP -\fB\eY\fR -. +.IP \fB\eY\fR 6 matches only at a point that is not the beginning or end of a word -.TP -\fB\eZ\fR -. +.IP \fB\eZ\fR 6 matches only at the end of the string (see \fBMATCHING\fR, below, for how this differs from .QW \fB$\fR ) -.TP -\fB\e\fIm\fR -. +.IP \fB\e\fIm\fR 6 (where \fIm\fR is a nonzero digit) a \fIback reference\fR, see below -.TP -\fB\e\fImnn\fR -. +.IP \fB\e\fImnn\fR 6 (where \fIm\fR is a nonzero digit, and \fInn\fR is some more digits, and the decimal value \fImnn\fR is not greater than the number of closing capturing parentheses seen so far) a \fIback reference\fR, see @@ -62,14 +62,14 @@ In blocking mode, the error is directly thrown, even, if there is a leading decodable data portion. The file pointer is advanced just before the encoding error. An eventual well decoded data chunk before the encoding error is returned -in the error option dictionary key \fB-data\fR. +in the error option dictionary key \fB\-data\fR. The value of the key contains the empty string, if the error arises at the first data position. .PP In non blocking mode, first, any data without encoding error is returned (without error state). In the next call, no data is returned and the \fBEILSEQ\fR error state is set. -The key \fB-data\fR is not present. +The key \fB\-data\fR is not present. .PP Here is an example with an encoding error in UTF-8 encoding, which is then introspected by a switch to the binary encoding. The test file contains a not @@ -101,7 +101,7 @@ file35a65a0 % close $f .CE The already decoded data "A" is returned in the error options dictionary key -\fB-data\fR. +\fB\-data\fR. The file position is advanced on the encoding error position 1. The data at the error position is thus recovered by the next \fBread\fR command. .PP @@ -156,7 +156,8 @@ set lines [split $data \en] .SH "SEE ALSO" file(n), eof(n), fblocked(n), fconfigure(n), Tcl_StandardChannels(3) .SH KEYWORDS -blocking, channel, end of line, end of file, nonblocking, read, translation, encoding +blocking, channel, end of line, end of file, nonblocking, read, translation, +encoding '\"Local Variables: '\"mode: nroff '\"End: diff --git a/doc/refchan.n b/doc/refchan.n index 94823c5..b997ddb 100644 --- a/doc/refchan.n +++ b/doc/refchan.n @@ -14,16 +14,16 @@ refchan \- command handler API of reflected channels .nf \fBchan create \fImode cmdPrefix\fR -\fIcmdPrefix \fBblocking\fR \fIchannelId mode\fR -\fIcmdPrefix \fBcget\fR \fIchannelId option\fR -\fIcmdPrefix \fBcgetall\fR \fIchannelId\fR -\fIcmdPrefix \fBconfigure\fR \fIchannelId option value\fR -\fIcmdPrefix \fBfinalize\fR \fIchannelId\fR -\fIcmdPrefix \fBinitialize\fR \fIchannelId mode\fR -\fIcmdPrefix \fBread\fR \fIchannelId count\fR -\fIcmdPrefix \fBseek\fR \fIchannelId offset base\fR -\fIcmdPrefix \fBwatch\fR \fIchannelId eventspec\fR -\fIcmdPrefix \fBwrite\fR \fIchannelId data\fR +\fIcmdPrefix \fBblocking\fI channelId mode\fR +\fIcmdPrefix \fBcget\fI channelId option\fR +\fIcmdPrefix \fBcgetall\fI channelId\fR +\fIcmdPrefix \fBconfigure\fI channelId option value\fR +\fIcmdPrefix \fBfinalize\fI channelId\fR +\fIcmdPrefix \fBinitialize\fI channelId mode\fR +\fIcmdPrefix \fBread\fI channelId count\fR +\fIcmdPrefix \fBseek\fI channelId offset base\fR +\fIcmdPrefix \fBwatch\fI channelId eventspec\fR +\fIcmdPrefix \fBwrite\fI channelId data\fR .fi .BE .SH DESCRIPTION @@ -42,6 +42,7 @@ Of all the possible subcommands, the handler \fImust\fR support \fBinitialize\fR, \fBfinalize\fR, and \fBwatch\fR. Support for the other subcommands is optional. .SS "MANDATORY SUBCOMMANDS" +.\" METHOD: initialize .TP \fIcmdPrefix \fBinitialize \fIchannelId mode\fR . @@ -72,6 +73,7 @@ will usually contain at least one element. The subcommand must throw an error if the chosen mode is not supported by the \fIcmdPrefix\fR. .RE +.\" METHOD: finalize .TP \fIcmdPrefix \fBfinalize \fIchannelId\fR . @@ -94,6 +96,7 @@ treated as (and converted to) an error. This subcommand is not invoked if the creation of the channel was aborted during \fBinitialize\fR (See above). .RE +.\" METHOD: watch .TP \fIcmdPrefix \fBwatch \fIchannelId eventspec\fR . @@ -114,6 +117,7 @@ event which was not listed in the last call to \fBwatch\fR will cause \fBchan postevent\fR to throw an error. .RE .SS "OPTIONAL SUBCOMMANDS" +.\" METHOD: read .TP \fIcmdPrefix \fBread \fIchannelId count\fR . @@ -170,6 +174,7 @@ invocation (usually \fBgets\fR, or \fBread\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR, (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE +.\" METHOD: write .TP \fIcmdPrefix \fBwrite \fIchannelId data\fR . @@ -227,6 +232,7 @@ invocation (usually \fBputs\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE +.\" METHOD: seek .TP \fIcmdPrefix \fBseek \fIchannelId offset base\fR . @@ -238,17 +244,11 @@ the channel. .PP The \fIbase\fR argument is the same as the equivalent argument of the builtin \fBchan seek\fR, namely: -.TP 10 -\fBstart\fR -. +.IP \fBstart\fR 10 Seeking is relative to the beginning of the channel. -.TP 10 -\fBcurrent\fR -. +.IP \fBcurrent\fR 10 Seeking is relative to the current seek position. -.TP 10 -\fBend\fR -. +.IP \fBend\fR 10 Seeking is relative to the end of the channel. .PP The \fIoffset\fR is an integer number specifying the amount of @@ -269,6 +269,7 @@ The offset/base combination of 0/\fBcurrent\fR signals a \fBchan tell\fR request, i.e.,\ seek nothing relative to the current location, making the new location identical to the current one, which is then returned. .RE +.\" METHOD: configure .TP \fIcmdPrefix \fBconfigure \fIchannelId option value\fR . @@ -288,6 +289,7 @@ If the subcommand throws an error the command which performed the beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE +.\" METHOD: cget .TP \fIcmdPrefix \fBcget \fIchannelId option\fR . @@ -303,6 +305,7 @@ If the subcommand throws an error, the command which performed the will appear to have thrown this error. Any exception beyond \fIerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE +.\" METHOD: cgetall .TP \fIcmdPrefix \fBcgetall \fIchannelId\fR . @@ -319,6 +322,7 @@ If the subcommand throws an error the command which performed the will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE +.\" METHOD: blocking .TP \fIcmdPrefix \fBblocking \fIchannelId mode\fR . @@ -335,8 +339,9 @@ invocation (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. .RE +.\" METHOD: truncate .TP -\fIcmdPrefix \fBtruncate\fR \fIchannelId length\fR +\fIcmdPrefix \fBtruncate\fI channelId length\fR . This \fIoptional\fR subcommand handles changing the length of the underlying data stream for the channel \fIchannelId\fR. Its length diff --git a/doc/regexp.n b/doc/regexp.n index 6f303a4..f37ccbe 100644 --- a/doc/regexp.n +++ b/doc/regexp.n @@ -34,6 +34,7 @@ subexpression to the right in \fIexp\fR, and so on. If the initial arguments to \fBregexp\fR start with \fB\-\fR then they are treated as switches. The following switches are currently supported: +.\" OPTION: -about .TP 15 \fB\-about\fR . @@ -42,12 +43,14 @@ containing information about the regular expression. The first element of the list is a subexpression count. The second element is a list of property names that describe various attributes of the regular expression. This switch is primarily intended for debugging purposes. +.\" OPTION: -expanded .TP 15 \fB\-expanded\fR . Enables use of the expanded regular expression syntax where whitespace and comments are ignored. This is the same as specifying the \fB(?x)\fR embedded option (see the \fBre_syntax\fR manual page). +.\" OPTION: -indices .TP 15 \fB\-indices\fR . @@ -57,6 +60,7 @@ each variable will contain a list of two decimal strings giving the indices in \fIstring\fR of the first and last characters in the matching range of characters. +.\" OPTION: -line .TP 15 \fB\-line\fR . @@ -75,6 +79,7 @@ matches an empty string before any newline in addition to its normal function. This flag is equivalent to specifying both \fB\-linestop\fR and \fB\-lineanchor\fR, or the \fB(?n)\fR embedded option (see the \fBre_syntax\fR manual page). +.\" OPTION: -linestop .TP 15 \fB\-linestop\fR . @@ -85,6 +90,7 @@ bracket expressions and so that they stop at newlines. This is the same as specifying the \fB(?p)\fR embedded option (see the \fBre_syntax\fR manual page). +.\" OPTION: -lineanchor .TP 15 \fB\-lineanchor\fR . @@ -98,11 +104,13 @@ so they match the beginning and end of a line respectively. This is the same as specifying the \fB(?w)\fR embedded option (see the \fBre_syntax\fR manual page). +.\" OPTION: -nocase .TP 15 \fB\-nocase\fR . Causes upper-case characters in \fIstring\fR to be treated as lower case during the matching process. +.\" OPTION: -all .TP 15 \fB\-all\fR . @@ -110,6 +118,7 @@ Causes the regular expression to be matched as many times as possible in the string, returning the total number of matches found. If this is specified with match variables, they will contain information for the last match only. +.\" OPTION: -inline .TP 15 \fB\-inline\fR . @@ -129,8 +138,9 @@ regular expression. Examples are: \fI\(-> in n li i ne e\fR .CE .RE +.\" OPTION: -start .TP 15 -\fB\-start\fR \fIindex\fR +\fB\-start\fI index\fR . Specifies a character index offset into the string to start matching the regular expression at. @@ -143,6 +153,7 @@ match the start of the string at \fIindex\fR. If \fB\-indices\fR is specified, the indices will be indexed starting from the absolute beginning of the input string. \fIindex\fR will be constrained to the bounds of the input string. +.\" OPTION: -- .TP 15 \fB\-\|\-\fR . @@ -175,7 +186,7 @@ Find the index of the word \fBbadger\fR (in any case) within a string and store that in the variable \fBlocation\fR: .PP .CS -\fBregexp\fR \-indices {(?i)\embadger\eM} $string location +\fBregexp\fR -indices {(?i)\embadger\eM} $string location .CE .PP This could also be written as a \fIbasic\fR regular expression (as opposed @@ -183,13 +194,13 @@ to using the default syntax of \fIadvanced\fR regular expressions) match by prefixing the expression with a suitable flag: .PP .CS -\fBregexp\fR \-indices {(?ib)\e<badger\e>} $string location +\fBregexp\fR -indices {(?ib)\e<badger\e>} $string location .CE .PP This counts the number of octal digits in a string: .PP .CS -\fBregexp\fR \-all {[0\-7]} $string +\fBregexp\fR -all {[0-7]} $string .CE .PP This lists all words (consisting of all sequences of non-whitespace @@ -197,7 +208,7 @@ characters) in a string, and is useful as a more powerful version of the \fBsplit\fR command: .PP .CS -\fBregexp\fR \-all \-inline {\eS+} $string +\fBregexp\fR -all -inline {\eS+} $string .CE .SH "SEE ALSO" re_syntax(n), regsub(n), string(n) diff --git a/doc/registry.n b/doc/registry.n index 66b2dd9..4defbad 100644 --- a/doc/registry.n +++ b/doc/registry.n @@ -12,10 +12,11 @@ .SH NAME registry \- Manipulate the Windows registry .SH SYNOPSIS -.sp +.nf \fBpackage require registry 1.3\fR -.sp -\fBregistry \fR?\fI\-mode\fR? \fIoption\fR \fIkeyName\fR ?\fIarg arg ...\fR? + +\fBregistry \fR?\fI\-mode\fR? \fIoption keyName\fR ?\fIarg arg ...\fR? +.fi .BE .SH DESCRIPTION .PP @@ -53,6 +54,7 @@ of the requested operation. \fIOption\fR indicates what to do with the registry key name. Any unique abbreviation for \fIoption\fR is acceptable. The valid options are: +.\" METHOD: broadcast .TP \fBregistry broadcast \fIkeyName\fR ?\fB\-timeout \fImilliseconds\fR? . @@ -79,6 +81,7 @@ set curPath [\fBregistry get\fR $regPath "Path"] \fBregistry broadcast\fR "Environment" .CE .RE +.\" METHOD: delete .TP \fBregistry delete \fIkeyName\fR ?\fIvalueName\fR? . @@ -88,6 +91,7 @@ optional \fIvalueName\fR is omitted, the specified key and any subkeys or values beneath it in the registry hierarchy will be deleted. If the key could not be deleted then an error is generated. If the key did not exist, the command has no effect. +.\" METHOD: get .TP \fBregistry get \fIkeyName valueName\fR . @@ -95,6 +99,7 @@ Returns the data associated with the value \fIvalueName\fR under the key \fIkeyName\fR. If either the key or the value does not exist, then an error is generated. For more details on the format of the returned data, see \fBSUPPORTED TYPES\fR, below. +.\" METHOD: keys .TP \fBregistry keys \fIkeyName\fR ?\fIpattern\fR? . @@ -103,6 +108,7 @@ subkeys of \fIkeyName\fR. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. If the specified \fIkeyName\fR does not exist, then an error is generated. +.\" METHOD: set .TP \fBregistry set \fIkeyName\fR ?\fIvalueName data \fR?\fItype\fR?? . @@ -113,12 +119,14 @@ contents of \fIvalueName\fR are set to \fIdata\fR with the type indicated by \fItype\fR. If \fItype\fR is not specified, the type \fBsz\fR is assumed. For more details on the data and type arguments, see \fBSUPPORTED TYPES\fR below. +.\" METHOD: type .TP \fBregistry type \fIkeyName valueName\fR . Returns the type of the value \fIvalueName\fR in the key \fIkeyName\fR. For more information on the possible types, see \fBSUPPORTED TYPES\fR, below. +.\" METHOD: values .TP \fBregistry values \fIkeyName\fR ?\fIpattern\fR? . @@ -136,53 +144,35 @@ data, but does not actually change the representation. For some types, the \fBregistry\fR command returns the data in a different form to make it easier to manipulate. The following types are recognized by the registry command: -.TP 17 -\fBbinary\fR -. +.IP \fBbinary\fR The registry value contains arbitrary binary data. The data is represented exactly in Tcl, including any embedded nulls. -.TP -\fBnone\fR -. +.IP \fBnone\fR The registry value contains arbitrary binary data with no defined type. The data is represented exactly in Tcl, including any embedded nulls. -.TP -\fBsz\fR -. +.IP \fBsz\fR The registry value contains a null-terminated string. The data is represented in Tcl as a string. -.TP -\fBexpand_sz\fR -. +.IP \fBexpand_sz\fR The registry value contains a null-terminated string that contains unexpanded references to environment variables in the normal Windows style (for example, .QW %PATH% ). The data is represented in Tcl as a string. -.TP -\fBdword\fR -. +.IP \fBdword\fR The registry value contains a little-endian 32-bit number. The data is represented in Tcl as a decimal string. -.TP -\fBdword_big_endian\fR -. +.IP \fBdword_big_endian\fR The registry value contains a big-endian 32-bit number. The data is represented in Tcl as a decimal string. -.TP -\fBlink\fR -. +.IP \fBlink\fR The registry value contains a symbolic link. The data is represented exactly in Tcl, including any embedded nulls. -.TP -\fBmulti_sz\fR -. +.IP \fBmulti_sz\fR The registry value contains an array of null-terminated strings. The data is represented in Tcl as a list of strings. -.TP -\fBresource_list\fR -. +.IP \fBresource_list\fR The registry value contains a device-driver resource list. The data is represented exactly in Tcl, including any embedded nulls. .PP diff --git a/doc/regsub.n b/doc/regsub.n index 29c118a..f7931af 100644 --- a/doc/regsub.n +++ b/doc/regsub.n @@ -54,6 +54,7 @@ backslashes. If the initial arguments to \fBregsub\fR start with \fB\-\fR then they are treated as switches. The following switches are currently supported: +.\" OPTION: -all .TP \fB\-all\fR . @@ -67,6 +68,7 @@ and .QW \e\fIn\fR sequences are handled for each substitution using the information from the corresponding match. +.\" OPTION: -command .TP \fB\-command\fR .VS 8.7 @@ -80,7 +82,7 @@ command prefix, that is, a non-empty list. The substring of \fIstring\fR that matches \fIexp\fR, and then each substring that matches each capturing sub-RE within \fIexp\fR are appended as additional elements to that list. (The items appended to the list are much like what -\fBregexp\fR \fB-inline\fR would return). The completed list is then +\fBregexp\fR \fB\-inline\fR would return). The completed list is then evaluated as a Tcl command, and the result of that command is the substitution string. Any error or exception from command evaluation becomes an error or exception from the \fBregsub\fR command. @@ -94,12 +96,14 @@ The exact location indices that matched are not made available to the script. See \fBEXAMPLES\fR below for illustrative cases. .RE .VE 8.7 +.\" OPTION: -expanded .TP \fB\-expanded\fR . Enables use of the expanded regular expression syntax where whitespace and comments are ignored. This is the same as specifying the \fB(?x)\fR embedded option (see the \fBre_syntax\fR manual page). +.\" OPTION: -line .TP \fB\-line\fR . @@ -117,6 +121,7 @@ matches an empty string before any newline in addition to its normal function. This flag is equivalent to specifying both \fB\-linestop\fR and \fB\-lineanchor\fR, or the \fB(?n)\fR embedded option (see the \fBre_syntax\fR manual page). +.\" OPTION: -linestop .TP \fB\-linestop\fR . @@ -127,6 +132,7 @@ bracket expressions and so that they stop at newlines. This is the same as specifying the \fB(?p)\fR embedded option (see the \fBre_syntax\fR manual page). +.\" OPTION: -lineanchor .TP \fB\-lineanchor\fR . @@ -140,14 +146,16 @@ so they match the beginning and end of a line respectively. This is the same as specifying the \fB(?w)\fR embedded option (see the \fBre_syntax\fR manual page). +.\" OPTION: -nocase .TP \fB\-nocase\fR . Upper-case characters in \fIstring\fR will be converted to lower-case before matching against \fIexp\fR; however, substitutions specified by \fIsubSpec\fR use the original unconverted form of \fIstring\fR. +.\" OPTION: -start .TP -\fB\-start\fR \fIindex\fR +\fB\-start\fI index\fR . Specifies a character index offset into the string to start matching the regular expression at. @@ -158,6 +166,7 @@ When using this switch, will not match the beginning of the line, and \eA will still match the start of the string at \fIindex\fR. \fIindex\fR will be constrained to the bounds of the input string. +.\" OPTION: -- .TP \fB\-\|\-\fR . @@ -256,6 +265,15 @@ set decoded [\fBregsub\fR -all -command $RE $string {apply {{- p h} { format %c $charNumber }}}] .CE +.PP +The \fB\-command\fR option can also be useful for restricting the range of +commands such as \fBstring totitle\fR: +.PP +.CE +set message "the quIck broWn fOX JUmped oVer the laZy dogS..." +puts [\fBregsub\fR -all -command {\ew+} $message {string totitle}] +# \(-> \fIThe Quick Brown Fox Jumped Over The Lazy Dogs..\fR +.CE .VE 8.7 .SH "SEE ALSO" regexp(n), re_syntax(n), subst(n), string(n) diff --git a/doc/return.n b/doc/return.n index e3d7c06..9bf1ae2 100644 --- a/doc/return.n +++ b/doc/return.n @@ -13,11 +13,11 @@ .SH NAME return \- Return from a procedure, or set return code of a script .SH SYNOPSIS +.nf \fBreturn \fR?\fIresult\fR? -.sp \fBreturn \fR?\fB\-code \fIcode\fR? ?\fIresult\fR? -.sp \fBreturn \fR?\fIoption value \fR...? ?\fIresult\fR? +.fi .BE .SH DESCRIPTION .PP @@ -54,7 +54,7 @@ of the procedure is 0 (\fBTCL_OK\fR). . Error return: the return code of the procedure is 1 (\fBTCL_ERROR\fR). The procedure command behaves in its calling context as if it -were the command \fBerror\fR \fIresult\fR. See below for additional +were the command \fBerror\fI result\fR. See below for additional options. .TP 13 \fBreturn\fR (or \fB2\fR) @@ -105,6 +105,7 @@ script. As documented above, the \fB\-code\fR entry in the return options dictionary receives special treatment by Tcl. There are other return options also recognized and treated specially by Tcl. They are: +.\" OPTION: -errorcode .TP \fB\-errorcode \fIlist\fR . @@ -117,6 +118,7 @@ the \fB\-code error\fR option is provided, Tcl will set the value of the \fB\-errorcode\fR entry in the return options dictionary to the default value of \fBNONE\fR. The \fB\-errorcode\fR return option will also be stored in the global variable \fBerrorCode\fR. +.\" OPTION: -errorinfo .TP \fB\-errorinfo \fIinfo\fR . @@ -135,11 +137,14 @@ the procedure. Typically the \fIinfo\fR value is supplied from the value of \fB\-errorinfo\fR in a return options dictionary captured by the \fBcatch\fR command (or from the copy of that information stored in the global variable \fBerrorInfo\fR). +.\" OPTION: -errorstack .TP \fB\-errorstack \fIlist\fR +. The \fB\-errorstack\fR option receives special treatment only when the value of the \fB\-code\fR option is \fBTCL_ERROR\fR. Then \fIlist\fR is the initial -error stack, recording actual argument values passed to each proc level. The error stack will +error stack, recording actual argument values passed to each proc level. +The error stack will also be reachable through \fBinfo errorstack\fR. If no \fB\-errorstack\fR option is provided to \fBreturn\fR when the \fB\-code error\fR option is provided, Tcl will provide its own @@ -151,6 +156,7 @@ the procedure. Typically the \fIlist\fR value is supplied from the value of \fB\-errorstack\fR in a return options dictionary captured by the \fBcatch\fR command (or from the copy of that information from \fBinfo errorstack\fR). +.\" OPTION: -level .TP \fB\-level \fIlevel\fR . @@ -163,6 +169,7 @@ be \fIcode\fR. If no \fB\-level\fR option is provided, the default value of \fIlevel\fR is 1, so that \fBreturn\fR sets the return code that the current procedure returns to its caller, 1 level up the call stack. The mechanism by which these options work is described in more detail below. +.\" OPTION: -options .TP \fB\-options \fIoptions\fR . @@ -11,28 +11,26 @@ .SH NAME safe \- Creating and manipulating safe interpreters .SH SYNOPSIS +.nf \fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR? -.sp -\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR? -.sp -\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR? -.sp -\fB::safe::interpDelete\fR \fIchild\fR -.sp -\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR -.sp -\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR -.sp +\fB::safe::interpInit\fI child\fR ?\fIoptions...\fR? +\fB::safe::interpConfigure\fI child\fR ?\fIoptions...\fR? +\fB::safe::interpDelete\fI child\fR +\fB::safe::interpAddToAccessPath\fI child directory\fR +\fB::safe::interpFindInAccessPath\fI child directory\fR \fB::safe::setSyncMode\fR ?\fInewValue\fR? -.sp \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? +.fi .SS OPTIONS -.PP -?\fB\-accessPath\fR \fIpathList\fR? -?\fB\-autoPath\fR \fIpathList\fR? -?\fB\-statics\fR \fIboolean\fR? ?\fB\-noStatics\fR? -?\fB\-nested\fR \fIboolean\fR? ?\fB\-nestedLoadOk\fR? -?\fB\-deleteHook\fR \fIscript\fR? +.nf +?\fB\-accessPath\fI pathList\fR? +?\fB\-autoPath\fI pathList\fR? +?\fB\-statics\fI boolean\fR? +?\fB\-noStatics\fR? +?\fB\-nested\fI boolean\fR? +?\fB\-nestedLoadOk\fR? +?\fB\-deleteHook\fI script\fR? +.fi .BE .SH DESCRIPTION Safe Tcl is a mechanism for executing untrusted Tcl scripts @@ -66,8 +64,10 @@ All commands provided in the parent interpreter by Safe Tcl reside in the \fBsafe\fR namespace. .SH COMMANDS The following commands are provided in the parent interpreter: +.\" COMMAND: interpCreate .TP \fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR? +. Creates a safe interpreter, installs the aliases described in the section \fBALIASES\fR and initializes the auto-loading and package mechanism as specified by the supplied \fIoptions\fR. @@ -75,21 +75,27 @@ See the \fBOPTIONS\fR section below for a description of the optional arguments. If the \fIchild\fR argument is omitted, a name will be generated. \fB::safe::interpCreate\fR always returns the interpreter name. -.sp +.RS +.PP The interpreter name \fIchild\fR may include namespace separators, but may not have leading or trailing namespace separators, or excess colon characters in namespace separators. The interpreter name is qualified relative to the global namespace ::, not the namespace in which the \fB::safe::interpCreate\fR command is evaluated. +.RE +.\" COMMAND: interpInit .TP -\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR? +\fB::safe::interpInit\fI child\fR ?\fIoptions...\fR? +. This command is similar to \fBinterpCreate\fR except it that does not create the safe interpreter. \fIchild\fR must have been created by some other means, like \fBinterp create\fR \fB\-safe\fR. The interpreter name \fIchild\fR may include namespace separators, subject to the same restrictions as for \fBinterpCreate\fR. +.\" COMMAND: interpConfigure .TP -\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR? +\fB::safe::interpConfigure\fI child\fR ?\fIoptions...\fR? +. If no \fIoptions\fR are given, returns the settings for all options for the named safe interpreter as a list of options and their current values for that \fIchild\fR. @@ -108,22 +114,26 @@ Example of use: set i1 [safe::interpCreate {*}[safe::interpConfigure $i0]] # Get the current deleteHook -set dh [safe::interpConfigure $i0 \-del] +set dh [safe::interpConfigure $i0 -del] # Change (only) the statics loading ok attribute of an # interp and its deleteHook (leaving the rest unchanged): -safe::interpConfigure $i0 \-delete {foo bar} \-statics 0 +safe::interpConfigure $i0 -delete {foo bar} -statics 0 .CE .RE +.\" COMMAND: interpDelete .TP -\fB::safe::interpDelete\fR \fIchild\fR +\fB::safe::interpDelete\fI child\fR +. Deletes the safe interpreter and cleans up the corresponding parent interpreter data structures. If a \fIdeleteHook\fR script was specified for this interpreter it is evaluated before the interpreter is deleted, with the name of the interpreter as an additional argument. +.\" COMMAND: interpFindInAccessPath .TP -\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR +\fB::safe::interpFindInAccessPath\fI child directory\fR +. This command finds and returns the token for the real directory \fIdirectory\fR in the safe interpreter's current virtual access path. It generates an error if the directory is not found. @@ -135,8 +145,10 @@ $child eval [list set tk_library \e [::safe::interpFindInAccessPath $name $tk_library]] .CE .RE +.\" COMMAND: interpAddToAccessPath .TP -\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR +\fB::safe::interpAddToAccessPath\fI child directory\fR +. This command adds \fIdirectory\fR to the virtual path maintained for the safe interpreter in the parent, and returns the token that can be used in the safe interpreter to obtain access to files in that directory. @@ -150,8 +162,10 @@ $child eval [list set tk_library \e [::safe::interpAddToAccessPath $name $tk_library]] .CE .RE +.\" COMMAND: setSyncMode .TP \fB::safe::setSyncMode\fR ?\fInewValue\fR? +. This command is used to get or set the "Sync Mode" of the Safe Base. When an argument is supplied, the command returns an error if the argument is not a boolean value, or if any Safe Base interpreters exist. Typically @@ -159,8 +173,10 @@ the value will be set as part of initialization - boolean true for "Sync Mode" on (the default), false for "Sync Mode" off. With "Sync Mode" on, the Safe Base keeps each child interpreter's ::auto_path synchronized with its access path. See the section \fBSYNC MODE\fR below for details. +.\" COMMAND: setLogCmd .TP \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? +. This command installs a script that will be called when interesting life cycle events occur for a safe interpreter. When called with no arguments, it returns the currently installed script. @@ -201,8 +217,10 @@ and \fB::safe::interpConfigure\fR. Any option name can be abbreviated to its minimal non-ambiguous name. Option names are not case sensitive. +.\" OPTION: -accessPath .TP -\fB\-accessPath\fR \fIdirectoryList\fR +\fB\-accessPath\fI directoryList\fR +. This option sets the list of directories from which the safe interpreter can \fBsource\fR and \fBload\fR files. If this option is not specified, or if it is given as the @@ -210,38 +228,50 @@ empty list, the safe interpreter will use the same directories as its parent for auto-loading. See the section \fBSECURITY\fR below for more detail about virtual paths, tokens and access control. +.\" OPTION: -autoPath .TP -\fB\-autoPath\fR \fIdirectoryList\fR +\fB\-autoPath\fI directoryList\fR +. This option sets the list of directories in the safe interpreter's ::auto_path. The option is undefined if the Safe Base has "Sync Mode" on - in that case the safe interpreter's ::auto_path is managed by the Safe Base and is a tokenized form of its access path. See the section \fBSYNC MODE\fR below for details. +.\" OPTION: -statics .TP -\fB\-statics\fR \fIboolean\fR +\fB\-statics\fI boolean\fR +. This option specifies if the safe interpreter will be allowed to load statically linked packages (like \fBload {} Tk\fR). The default value is \fBtrue\fR : safe interpreters are allowed to load statically linked packages. +.\" OPTION: -noStatics .TP \fB\-noStatics\fR +. This option is a convenience shortcut for \fB\-statics false\fR and thus specifies that the safe interpreter will not be allowed to load statically linked packages. +.\" OPTION: -nested .TP -\fB\-nested\fR \fIboolean\fR +\fB\-nested\fI boolean\fR +. This option specifies if the safe interpreter will be allowed to load packages into its own sub-interpreters. The default value is \fBfalse\fR : safe interpreters are not allowed to load packages into their own sub-interpreters. +.\" OPTION: -nestedLoadOk .TP \fB\-nestedLoadOk\fR +. This option is a convenience shortcut for \fB\-nested true\fR and thus specifies the safe interpreter will be allowed to load packages into its own sub-interpreters. +.\" OPTION: -deleteHook .TP -\fB\-deleteHook\fR \fIscript\fR +\fB\-deleteHook\fI script\fR +. When this option is given a non-empty \fIscript\fR, it will be evaluated in the parent with the name of the safe interpreter as an additional argument @@ -252,7 +282,8 @@ The default value (\fB{}\fR) is not to have any deletion call back. .SH ALIASES The following aliases are provided in a safe interpreter: .TP -\fBsource\fR \fIfileName\fR +\fBsource\fI fileName\fR +. The requested file, a Tcl source file, is sourced into the safe interpreter if it is found. The \fBsource\fR alias can only source files from directories in @@ -263,7 +294,8 @@ which the file to be sourced can be found. See the section on \fBSECURITY\fR for more discussion of restrictions on valid filenames. .TP -\fBload\fR \fIfileName\fR +\fBload\fI fileName\fR +. The requested file, a shared object file, is dynamically loaded into the safe interpreter if it is found. The filename must contain a token name mentioned in the virtual path for @@ -271,20 +303,23 @@ the safe interpreter for it to be found successfully. Additionally, the shared object file must contain a safe entry point; see the manual page for the \fBload\fR command for more details. .TP -\fBfile\fR ?\fIsubCmd args...\fR? +\fBfile\fR ?\fIsubcommand args...\fR? +. The \fBfile\fR alias provides access to a safe subset of the subcommands of the \fBfile\fR command; it allows only \fBdirname\fR, \fBjoin\fR, \fBextension\fR, \fBroot\fR, \fBtail\fR, \fBpathname\fR and \fBsplit\fR subcommands. For more details on what these subcommands do see the manual page for the \fBfile\fR command. .TP -\fBencoding\fR ?\fIsubCmd args...\fR? +\fBencoding\fR ?\fIsubcommand args...\fR? +. The \fBencoding\fR alias provides access to a safe subset of the subcommands of the \fBencoding\fR command; it disallows setting of the system encoding, but allows all other subcommands including \fBsystem\fR to check the current encoding. .TP \fBexit\fR +. The calling interpreter is deleted and its computation is stopped, but the Tcl process in which this interpreter exists is not terminated. .SH SECURITY @@ -435,9 +470,9 @@ parent interpreter to packages, modules, and autoloader files. With parent's ::auto_path, and will set the child's ::auto_path to a tokenized form of the parent's ::auto_path. .PP -With "Sync Mode" off, if a value is specified for \fB\-autoPath\fR, even the empty -list, in a call to \fB::safe::interpCreate\fR, \fB::safe::interpInit\fR, or -\fB::safe::interpConfigure\fR, it will be tokenized and used as the safe +With "Sync Mode" off, if a value is specified for \fB\-autoPath\fR, even the +empty list, in a call to \fB::safe::interpCreate\fR, \fB::safe::interpInit\fR, +or \fB::safe::interpConfigure\fR, it will be tokenized and used as the safe interpreter's ::auto_path. Any directories that do not also belong to the access path cannot be tokenized and will be silently ignored. However, the value of \fB\-autoPath\fR will remain as specified, and will be used to @@ -446,26 +481,26 @@ to change the value of \fB\-accessPath\fR. .PP With "Sync Mode" off, if the access path is reset to the values in the parent interpreter by calling \fB::safe::interpConfigure\fR with arguments -\fB\-accessPath\fR {}, then the ::auto_path will also be reset unless the argument -\fB\-autoPath\fR is supplied to specify a different value. +\fB\-accessPath\fR {}, then the ::auto_path will also be reset unless the +argument \fB\-autoPath\fR is supplied to specify a different value. .PP With "Sync Mode" off, if a non-empty value of \fB\-accessPath\fR is supplied, the safe interpreter's ::auto_path will be set to {} (by \fB::safe::interpCreate\fR, \fB::safe::interpInit\fR) or left unchanged (by \fB::safe::interpConfigure\fR). If the same command specifies a new -value for \fB\-autoPath\fR, it will be applied after the \fB\-accessPath\fR argument has -been processed. - +value for \fB\-autoPath\fR, it will be applied after the \fB\-accessPath\fR +argument has been processed. +.PP Examples of use with "Sync Mode" off: any of these commands will set the ::auto_path to a tokenized form of its value in the parent interpreter: .RS .PP .CS - safe::interpCreate foo - safe::interpCreate foo -accessPath {} - safe::interpInit bar - safe::interpInit bar -accessPath {} - safe::interpConfigure foo -accessPath {} +safe::interpCreate foo +safe::interpCreate foo -accessPath {} +safe::interpInit bar +safe::interpInit bar -accessPath {} +safe::interpConfigure foo -accessPath {} .CE .RE .PP @@ -475,35 +510,35 @@ own value is also specified: .RS .PP .CS - safe::interpCreate foo -accessPath { - /usr/local/TclHome/lib/tcl8.6 - /usr/local/TclHome/lib/tcl8.6/http1.0 - /usr/local/TclHome/lib/tcl8.6/opt0.4 - /usr/local/TclHome/lib/tcl8.6/msgs - /usr/local/TclHome/lib/tcl8.6/encoding - /usr/local/TclHome/lib - } +safe::interpCreate foo -accessPath { + /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib/tcl8.6/http1.0 + /usr/local/TclHome/lib/tcl8.6/opt0.4 + /usr/local/TclHome/lib/tcl8.6/msgs + /usr/local/TclHome/lib/tcl8.6/encoding + /usr/local/TclHome/lib +} - # The child's ::auto_path must be given a suitable value: +# The child's ::auto_path must be given a suitable value: - safe::interpConfigure foo -autoPath { - /usr/local/TclHome/lib/tcl8.6 - /usr/local/TclHome/lib - } +safe::interpConfigure foo -autoPath { + /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib +} - # The two commands can be combined: +# The two commands can be combined: - safe::interpCreate foo -accessPath { - /usr/local/TclHome/lib/tcl8.6 - /usr/local/TclHome/lib/tcl8.6/http1.0 - /usr/local/TclHome/lib/tcl8.6/opt0.4 - /usr/local/TclHome/lib/tcl8.6/msgs - /usr/local/TclHome/lib/tcl8.6/encoding - /usr/local/TclHome/lib - } -autoPath { - /usr/local/TclHome/lib/tcl8.6 - /usr/local/TclHome/lib - } +safe::interpCreate foo -accessPath { + /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib/tcl8.6/http1.0 + /usr/local/TclHome/lib/tcl8.6/opt0.4 + /usr/local/TclHome/lib/tcl8.6/msgs + /usr/local/TclHome/lib/tcl8.6/encoding + /usr/local/TclHome/lib +} -autoPath { + /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib +} .CE .RE .PP @@ -513,18 +548,18 @@ Example of use with "Sync Mode" off: the command .RS .PP .CS - safe::interpAddToAccessPath foo /usr/local/TclHome/lib/extras/Img1.4.11 +safe::interpAddToAccessPath foo /usr/local/TclHome/lib/extras/Img1.4.11 - lassign [safe::interpConfigure foo -autoPath] DUM childAutoPath - lappend childAutoPath /usr/local/TclHome/lib/extras/Img1.4.11 - safe::interpConfigure foo -autoPath $childAutoPath +lassign [safe::interpConfigure foo -autoPath] DUM childAutoPath +lappend childAutoPath /usr/local/TclHome/lib/extras/Img1.4.11 +safe::interpConfigure foo -autoPath $childAutoPath .CE .RE .SH "SEE ALSO" interp(n), library(n), load(n), package(n), pkg_mkIndex(n), source(n), tm(n), unknown(n) .SH KEYWORDS -alias, auto\-loading, auto_mkindex, load, parent interpreter, safe +alias, auto-loading, auto_mkindex, load, parent interpreter, safe interpreter, child interpreter, source '\" Local Variables: '\" mode: nroff @@ -86,33 +86,23 @@ the integer range to be stored is unlimited. .SS "MANDATORY CONVERSION CHARACTER" .PP The following conversion characters are supported: -.TP -\fBd\fR -. +.IP \fBd\fR The input substring must be a decimal integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. -.TP -\fBo\fR -. +.IP \fBo\fR The input substring must be an octal integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. -.TP -\fBx\fR or \fBX\fR -. +.IP "\fBx\fR or \fBX\fR" The input substring must be a hexadecimal integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. -.TP -\fBb\fR -. +.IP \fBb\fR The input substring must be a binary integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. -.TP -\fBu\fR -. +.IP \fBu\fR The input substring must be a decimal integer. The integer value is truncated as required by the size modifier value, and the corresponding unsigned value for that truncated @@ -120,35 +110,28 @@ range is computed and stored in the variable as a decimal string. The conversion makes no sense without reference to a truncation range, so the size modifier \fBll\fR is not permitted in combination with conversion character \fBu\fR. -.TP -\fBi\fR -. -The input substring must be an integer. The base (i.e. decimal, octal, or hexadecimal) is determined by the C convention (leading 0 for octal; prefix 0x for hexadecimal). The integer value is stored in the variable, -truncated as required by the size modifier value. -.TP -\fBc\fR -. +.IP \fBi\fR +The input substring must be an integer. The base (i.e. decimal, +octal, or hexadecimal) is determined by the C convention (leading +0 for octal; prefix 0x for hexadecimal). The integer value is +stored in the variable, truncated as required by the size modifier +value. +.IP \fBc\fR A single character is read in and its Unicode value is stored in the variable as an integer value. Initial white space is not skipped in this case, so the input substring may be a white-space character. -.TP -\fBs\fR -. +.IP \fBs\fR The input substring consists of all the characters up to the next white-space character; the characters are copied to the variable. -.TP -\fBe\fR or \fBf\fR or \fBg\fR or \fBE\fR or \fBG\fR -. +.IP "\fBe\fR or \fBf\fR or \fBg\fR or \fBE\fR or \fBG\fR" The input substring must be a floating-point number consisting of an optional sign, a string of decimal digits possibly containing a decimal point, and an optional exponent consisting of an \fBe\fR or \fBE\fR followed by an optional sign and a string of decimal digits. It is read in and stored in the variable as a floating-point value. -.TP -\fB[\fIchars\fB]\fR -. +.IP \fB[\fIchars\fB]\fR The input substring consists of one or more characters in \fIchars\fR. The matching string is stored in the variable. If the first character between the brackets is a \fB]\fR then @@ -159,9 +142,7 @@ contains a sequence of the form \fIa\fB\-\fIb\fR then any character between \fIa\fR and \fIb\fR (inclusive) will match. If the first or last character between the brackets is a \fB\-\fR, then it is treated as part of \fIchars\fR rather than indicating a range. -.TP -\fB[^\fIchars\fB]\fR -. +.IP \fB[^\fIchars\fB]\fR The input substring consists of one or more characters not in \fIchars\fR. The matching string is stored in the variable. If the character immediately following the \fB^\fR is a \fB]\fR then it is @@ -173,9 +154,7 @@ character between \fIa\fR and \fIb\fR (inclusive) will be excluded from the set. If the first or last character between the brackets is a \fB\-\fR, then it is treated as part of \fIchars\fR rather than indicating a range value. -.TP -\fBn\fR -. +.IP \fBn\fR No input is consumed from the input string. Instead, the total number of characters scanned from the input string so far is stored in the variable. .PP @@ -224,12 +203,10 @@ set string "#08D03F" \fBscan\fR $string "#%2x%2x%2x" r g b .CE .PP -Parse a \fIHH:MM\fR time string, noting that this avoids problems with -octal numbers by forcing interpretation as decimals (if we did not -care, we would use the \fB%i\fR conversion instead): +Parse a \fIHH:MM\fR time string: .PP .CS -set string "08:08" ;# *Not* octal! +set string "08:08" if {[\fBscan\fR $string "%d:%d" hours minutes] != 2} { error "not a valid time string" } @@ -27,20 +27,14 @@ The \fIoffset\fR and \fIorigin\fR arguments specify the position at which the next read or write will occur for \fIchannelId\fR. \fIOffset\fR must be an integer (which may be negative) and \fIorigin\fR must be one of the following: -.TP 10 -\fBstart\fR -. +.IP \fBstart\fR 10 The new access position will be \fIoffset\fR bytes from the start of the underlying file or device. -.TP 10 -\fBcurrent\fR -. +.IP \fBcurrent\fR 10 The new access position will be \fIoffset\fR bytes from the current access position; a negative \fIoffset\fR moves the access position backwards in the underlying file or device. -.TP 10 -\fBend\fR -. +.IP \fBend\fR 10 The new access position will be \fIoffset\fR bytes from the end of the file or device. A negative \fIoffset\fR places the access position before the end of file, and a positive \fIoffset\fR places the access @@ -24,6 +24,7 @@ used to allow the method to discover information about how it was called. It takes an argument, \fIsubcommand\fR, that tells it what sort of information is actually desired; if omitted the result will be the same as if \fBself object\fR was invoked. The supported subcommands are: +.\" METHOD: call .TP \fBself call\fR . @@ -40,6 +41,7 @@ being a \fBmethod\fR), and the second element is an index into the first element's list that indicates which actual implementation is currently executing (the first implementation to execute is always at index 0). +.\" METHOD: caller .TP \fBself caller\fR . @@ -50,6 +52,7 @@ second element is the name of the object on which the containing method was invoked, and the third element is the name of the method (with the strings \fB<constructor>\fR and \fB<destructor>\fR indicating constructors and destructors respectively). +.\" METHOD: class .TP \fBself class\fR . @@ -66,6 +69,7 @@ construct: info object class [\fBself object\fR] .CE .RE +.\" METHOD: filter .TP \fBself filter\fR . @@ -75,17 +79,20 @@ that declared the filter (note that this may be different from the object or class that provided the implementation of the filter), the second element is either \fBobject\fR or \fBclass\fR depending on whether the declaring entity was an object or class, and the third element is the name of the filter. +.\" METHOD: method .TP \fBself method\fR . This returns the name of the current method (with the strings \fB<constructor>\fR and \fB<destructor>\fR indicating constructors and destructors respectively). +.\" METHOD: namespace .TP \fBself namespace\fR . This returns the name of the unique namespace of the object that the method was invoked upon. +.\" METHOD: next .TP \fBself next\fR . @@ -98,10 +105,12 @@ of the method (with the strings \fB<constructor>\fR and \fB<destructor>\fR indicating constructors and destructors respectively). If invoked from a method that is at the end of a call chain, this subcommand returns the empty string. +.\" METHOD: object .TP \fBself object\fR . This returns the name of the object that the method was invoked upon. +.\" METHOD: target .TP \fBself target\fR . @@ -70,7 +70,8 @@ practice instead of doing double-dereferencing): \fBset\fR out [\fBset\fR $vbl] .CE .SH "SEE ALSO" -expr(n), global(n), namespace(n), proc(n), trace(n), unset(n), upvar(n), variable(n) +expr(n), global(n), namespace(n), proc(n), trace(n), unset(n), upvar(n), +variable(n) .SH KEYWORDS read, write, variable '\" Local Variables: diff --git a/doc/singleton.n b/doc/singleton.n index 3ccbdd3..ce35593 100644 --- a/doc/singleton.n +++ b/doc/singleton.n @@ -47,6 +47,7 @@ The \fBoo::singleton\fR class does not define an explicit destructor; destroying an instance of it is just like destroying an ordinary class (and will destroy the singleton object). .SS "EXPORTED METHODS" +.\" METHOD: new .TP \fIcls \fBnew \fR?\fIarg ...\fR? . @@ -63,7 +64,8 @@ identical call signature to the superclass's implementation. .SS "NON-EXPORTED METHODS" The \fBoo::singleton\fR class explicitly states that \fBcreate\fR and \fBcreateWithNamespace\fR are unexported; callers should not assume that they -have control over either the name or the namespace name of the singleton instance. +have control over either the name or the namespace name of the singleton +instance. .SH EXAMPLE .PP This example demonstrates that there is only one instance even though the diff --git a/doc/socket.n b/doc/socket.n index b7b3228..06d3b5b 100644 --- a/doc/socket.n +++ b/doc/socket.n @@ -12,10 +12,10 @@ .SH NAME socket \- Open a TCP network connection .SH SYNOPSIS -.sp +.nf \fBsocket \fR?\fIoptions\fR? \fIhost port\fR -.sp \fBsocket\fR \fB\-server \fIcommand\fR ?\fIoptions\fR? \fIport\fR +.fi .BE .SH DESCRIPTION .PP @@ -49,6 +49,7 @@ Use \fIlocalhost\fR to refer to the host on which the command is invoked. .PP The following options may also be present before \fIhost\fR to specify additional information about the connection: +.\" OPTION: -myaddr .TP \fB\-myaddr\fI addr\fR . @@ -57,6 +58,7 @@ the client-side network interface to use for the connection. This option may be useful if the client machine has multiple network interfaces. If the option is omitted then the client-side interface will be chosen by the system software. +.\" OPTION: -myport .TP \fB\-myport\fI port\fR . @@ -65,6 +67,7 @@ supported and understood by the host operating system) to use for the client's side of the connection. If this option is omitted, the client's port number will be chosen at random by the system software. +.\" OPTION: -async .TP \fB\-async\fR . @@ -98,9 +101,12 @@ asynchronous connection has succeeded or failed. See the \fBvwait\fR and the \fBchan\fR commands for more details on the event loop and channel events. .PP -The \fBchan configure\fR option \fB-connecting\fR may be used to check if the connect is still running. To verify a successful connect, the option \fB-error\fR may be checked when \fB-connecting\fR returned 0. +The \fBchan configure\fR option \fB\-connecting\fR may be used to check +if the connect is still running. To verify a successful connect, the +option \fB\-error\fR may be checked when \fB\-connecting\fR returned 0. .PP -Operation without the event queue requires at the moment calls to \fBchan configure\fR to advance the internal state machine. +Operation without the event queue requires at the moment calls to +\fBchan configure\fR to advance the internal state machine. .RE .SH "SERVER SOCKETS" .PP @@ -120,6 +126,7 @@ network address notation, of the client's host, and the client's port number. .PP The following additional option may also be specified before \fIport\fR: +.\" OPTION: -myaddr .TP \fB\-myaddr\fI addr\fR . @@ -131,11 +138,13 @@ wildcard address so that it can accept connections from any interface. If \fIaddr\fR is a domain name that resolves to multiple IP addresses that are available on the local machine, the socket will listen on all of them. +.\" OPTION: -reuseaddr .TP \fB\-reuseaddr\fI boolean\fR . Tells the kernel whether to reuse the local address if there is no socket actively listening on it. This is the default on Windows. +.\" OPTION: -reuseport .TP \fB\-reuseport\fI boolean\fR . @@ -164,6 +173,7 @@ described below. The \fBchan configure\fR command can be used to query several readonly configuration options for socket channels or in some cases to set alternative properties on socket channels: +.\" OPTION: -error .TP \fB\-error\fR . @@ -176,6 +186,7 @@ returned. If there was no error, an empty string is returned. Note that the error status is reset by the read operation; this mimics the underlying getsockopt(SO_ERROR) call. .RE +.\" OPTION: -sockname .TP \fB\-sockname\fR . @@ -193,6 +204,7 @@ was created without \fB\-myaddr\fR or with the argument to \fB\-myaddr\fR being a domain name that resolves multiple IP addresses that are local to the invoking host. .RE +.\" OPTION: -peername .TP \fB\-peername\fR . @@ -201,15 +213,19 @@ sockets, this option returns a list of three elements; these are the address, the host name and the port to which the peer socket is connected or bound. If the host name cannot be computed, the second element of the list is identical to the address, its first element. +.\" OPTION: -connecting .TP \fB\-connecting\fR . -This option is not supported by server sockets. For client sockets, this option returns 1 if an asyncroneous connect is still in progress, 0 otherwise. +This option is not supported by server sockets. For client sockets, this +option returns 1 if an asynchronous connect is still in progress, 0 otherwise. +.\" OPTION: -keepalive .TP \fB\-keepalive\fR . This option sets or queries the TCP keepalive option on the socket as 1 if keepalive is turned on, 0 otherwise. +.\" OPTION: -nodelay .TP \fB\-nodelay\fR . @@ -250,7 +266,8 @@ Support for IPv6 was added in Tcl 8.6. .SH "SEE ALSO" chan(n), flush(n), open(n), read(n) .SH KEYWORDS -asynchronous I/O, bind, channel, connection, domain name, host, network address, socket, tcp +asynchronous I/O, bind, channel, connection, domain name, host, +network address, socket, tcp '\" Local Variables: '\" mode: nroff '\" End: diff --git a/doc/source.n b/doc/source.n index cee1312..d4d8332 100644 --- a/doc/source.n +++ b/doc/source.n @@ -41,7 +41,8 @@ in code for string comparison, you can use which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP -A leading BOM (Byte order mark) contained in the file is ignored for unicode encodings (utf-8, utf-16, ucs-2). +A leading BOM (Byte order mark) contained in the file is ignored for +unicode encodings (utf-8, utf-16, ucs-2). .PP The \fB\-encoding\fR option is used to specify the encoding of the data stored in \fIfileName\fR. When the \fB\-encoding\fR option diff --git a/doc/string.n b/doc/string.n index 6a9a8e1..3b9af03 100644 --- a/doc/string.n +++ b/doc/string.n @@ -18,6 +18,7 @@ string \- Manipulate strings .PP Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: +.\" METHOD: cat .TP \fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR? . @@ -32,6 +33,7 @@ of a concatenation without resorting to \fBreturn\fR \fB\-level 0\fR, and is more efficient than building a list of arguments and using \fBjoin\fR with an empty join string. .RE +.\" METHOD: compare .TP \fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR . @@ -42,6 +44,7 @@ than \fIstring2\fR. If \fB\-length\fR is specified, then only the first \fIlength\fR characters are used in the comparison. If \fB\-length\fR is negative, it is ignored. If \fB\-nocase\fR is specified, then the strings are compared in a case-insensitive manner. +.\" METHOD: equal .TP \fBstring equal\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR . @@ -51,6 +54,7 @@ identical, or 0 when not. If \fB\-length\fR is specified, then only the first \fIlength\fR characters are used in the comparison. If \fB\-length\fR is negative, it is ignored. If \fB\-nocase\fR is specified, then the strings are compared in a case-insensitive manner. +.\" METHOD: first .TP \fBstring first \fIneedleString haystackString\fR ?\fIstartIndex\fR? . @@ -75,6 +79,7 @@ will return \fB10\fR, but .PP will return \fB\-1\fR. .RE +.\" METHOD: index .TP \fBstring index \fIstring charIndex\fR . @@ -87,6 +92,7 @@ string. \fIcharIndex\fR may be specified as described in the If \fIcharIndex\fR is less than 0 or greater than or equal to the length of the string then this command returns an empty string. .RE +.\" METHOD: insert .TP \fBstring insert \fIstring index insertString\fR .VS "TIP 504" @@ -105,6 +111,7 @@ or after the end of \fIstring\fR (e.g., \fIindex\fR is \fBend\fR), \fIinsertString\fR is appended to \fIstring\fR. .RE .VE "TIP 504" +.\" METHOD: is .TP \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR . @@ -175,7 +182,12 @@ zero width no-break space (U+feff) (=BOM). Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is true. .IP \fBunicode\fR 12 -Any Unicode character, except surrogates and noncharacters +Any Unicode character, except surrogates and noncharacters. +.RS +.PP +\fIWarning: this option is under discussion and may be renamed or replaced +by another solution within the Tcl 9.0 series.\fR +.RE .IP \fBupper\fR 12 Any upper case alphabet character in the Unicode character set. .IP \fBwideinteger\fR 12 @@ -192,6 +204,7 @@ In the case of \fBboolean\fR, \fBtrue\fR and \fBfalse\fR, if the function will return 0, then the \fIvarname\fR will always be set to 0, due to the varied nature of a valid boolean value. .RE +.\" METHOD: last .TP \fBstring last \fIneedleString haystackString\fR ?\fIlastIndex\fR? . @@ -216,6 +229,7 @@ will return \fB10\fR, but .PP will return \fB1\fR. .RE +.\" METHOD: length .TP \fBstring length \fIstring\fR . @@ -224,6 +238,7 @@ Returns a decimal string giving the number of characters in number of bytes used to store the string. If the value is a byte array value (such as those returned from reading a binary encoded channel), then this will return the actual byte length of the value. +.\" METHOD: map .TP \fBstring map\fR ?\fB\-nocase\fR? \fImapping string\fR . @@ -255,8 +270,9 @@ reordered like this, .PP it will return the string \fB02c322c222c\fR. .RE +.\" METHOD: match .TP -\fBstring match\fR ?\fB\-nocase\fR? \fIpattern\fR \fIstring\fR +\fBstring match\fR ?\fB\-nocase\fR? \fIpattern string\fR . See if \fIpattern\fR matches \fIstring\fR; return 1 if it does, 0 if it does not. If \fB\-nocase\fR is specified, then the pattern attempts @@ -289,6 +305,7 @@ Matches the single character \fIx\fR. This provides a way of avoiding the special interpretation of the characters \fB*?[]\e\fR in \fIpattern\fR. .RE +.\" METHOD: range .TP \fBstring range \fIstring first last\fR . @@ -303,12 +320,14 @@ it is treated as if it were zero, and if \fIlast\fR is greater than or equal to the length of the string then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty string is returned. +.\" METHOD: repeat .TP \fBstring repeat \fIstring count\fR . Returns a string consisting of \fIstring\fR concatenated with itself \fIcount\fR times. If \fIcount\fR is 0, the empty string will be returned. +.\" METHOD: replace .TP \fBstring replace \fIstring first last\fR ?\fInewstring\fR? . @@ -325,11 +344,13 @@ then it is treated as if it were \fBend\fR. The initial string is returned untouched, if \fIfirst\fR is greater than \fIlast\fR, or if \fIfirst\fR is equal to or greater than the length of the initial string, or \fIlast\fR is less than 0. +.\" METHOD: reverse .TP \fBstring reverse \fIstring\fR . Returns a string that is the same length as \fIstring\fR but with its characters in the reverse order. +.\" METHOD: tolower .TP \fBstring tolower \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR? . @@ -339,6 +360,7 @@ specified, it refers to the first char index in the string to start modifying. If \fIlast\fR is specified, it refers to the char index in the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified using the forms described in \fBSTRING INDICES\fR. +.\" METHOD: totitle .TP \fBstring totitle \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR? . @@ -350,6 +372,7 @@ refers to the first char index in the string to start modifying. If \fIlast\fR is specified, it refers to the char index in the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified using the forms described in \fBSTRING INDICES\fR. +.\" METHOD: toupper .TP \fBstring toupper \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR? . @@ -359,6 +382,7 @@ specified, it refers to the first char index in the string to start modifying. If \fIlast\fR is specified, it refers to the char index in the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified using the forms described in \fBSTRING INDICES\fR. +.\" METHOD: trim .TP \fBstring trim \fIstring\fR ?\fIchars\fR? . @@ -366,6 +390,7 @@ Returns a value equal to \fIstring\fR except that any leading or trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\e0"). +.\" METHOD: trimleft .TP \fBstring trimleft \fIstring\fR ?\fIchars\fR? . @@ -373,6 +398,7 @@ Returns a value equal to \fIstring\fR except that any leading characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\e0"). +.\" METHOD: trimright .TP \fBstring trimright \fIstring\fR ?\fIchars\fR? . @@ -385,46 +411,7 @@ for which \fBstring is space\fR returns 1, and "\e0"). These subcommands are currently supported, but are likely to go away in a future release as their functionality is either virtually never used or highly misleading. -.TP -\fBstring bytelength \fIstring\fR -. -Returns a decimal string giving the number of bytes used to represent -\fIstring\fR in memory when encoded as Tcl's internal modified UTF\-8; -Tcl may use other encodings for \fIstring\fR as well, and does not -guarantee to only use a single encoding for a particular \fIstring\fR. -Because UTF\-8 uses a variable number of bytes to represent Unicode -characters, the byte length will not be the same as the character -length in general. The cases where a script cares about the byte -length are rare. -.RS -.PP -In almost all cases, you should use the -\fBstring length\fR operation (including determining the length of a -Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual -entry for more details on the UTF\-8 representation. -.PP -Formally, the \fBstring bytelength\fR operation returns the content of -the \fIlength\fR field of the \fBTcl_Obj\fR structure, after calling -\fBTcl_GetString\fR to ensure that the \fIbytes\fR field is populated. -This is highly unlikely to be useful to Tcl scripts, as Tcl's internal -encoding is not strict UTF\-8, but rather a modified WTF\-8 with a -denormalized NUL (identical to that used in a number of places by -Java's serialization mechanism) to enable basic processing with -non-Unicode-aware C functions. As this representation should only -ever be used by Tcl's implementation, the number of bytes used to -store the representation is of very low value (except to C extension -code, which has direct access for the purpose of memory management, -etc.) -.PP -\fICompatibility note:\fR This subcommand is deprecated and will -be removed in Tcl 9.0. It is better to use the \fBencoding convertto\fR -command to convert a string to a known encoding (e.g. "utf-8" or "cesu-8") -and then apply \fBstring length\fR to that. -.PP -.CS -\fBstring length\fR [encoding convertto utf-8 $theString] -.CE -.RE +.\" METHOD: wordend .TP \fBstring wordend \fIstring charIndex\fR . @@ -434,6 +421,7 @@ may be specified using the forms in \fBSTRING INDICES\fR. A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) or underscore (Unicode connector punctuation) characters, or any single character other than these. +.\" METHOD: wordstart .TP \fBstring wordstart \fIstring charIndex\fR . @@ -502,14 +490,14 @@ set length [\fBstring length\fR $string] if {$length == 0} { set isPrefix 0 } else { - set isPrefix [\fBstring equal\fR \-length $length $string "foobar"] + set isPrefix [\fBstring equal\fR -length $length $string "foobar"] } .CE .SH "SEE ALSO" expr(n), list(n) .SH KEYWORDS -case conversion, compare, index, integer value, match, pattern, string, word, equal, -ctype, character, reverse +case conversion, compare, index, integer value, match, pattern, string, +word, equal, ctype, character, reverse .\" Local Variables: .\" mode: nroff .\" End: diff --git a/doc/subst.n b/doc/subst.n index 4518140..4c9a519 100644 --- a/doc/subst.n +++ b/doc/subst.n @@ -158,7 +158,8 @@ not .SH "SEE ALSO" Tcl(n), eval(n), break(n), continue(n) .SH KEYWORDS -backslash substitution, command substitution, quoting, substitution, variable substitution +backslash substitution, command substitution, quoting, substitution, +variable substitution .\" Local Variables: .\" mode: nroff .\" End: diff --git a/doc/switch.n b/doc/switch.n index 70eeb09..61449a9 100644 --- a/doc/switch.n +++ b/doc/switch.n @@ -35,28 +35,33 @@ unless there are exactly two arguments to \fBswitch\fR (in which case the first must the \fIstring\fR and the second must be the \fIpattern\fR/\fIbody\fR list). The following options are currently supported: +.\" OPTION: -exact .TP 10 \fB\-exact\fR . Use exact matching when comparing \fIstring\fR to a pattern. This is the default. +.\" OPTION: -glob .TP 10 \fB\-glob\fR . When matching \fIstring\fR to the patterns, use glob-style matching (i.e. the same as implemented by the \fBstring match\fR command). +.\" OPTION: -regexp .TP 10 \fB\-regexp\fR . When matching \fIstring\fR to the patterns, use regular expression matching (as described in the \fBre_syntax\fR reference page). +.\" OPTION: -nocase .TP 10 \fB\-nocase\fR . Causes comparisons to be handled in a case-insensitive manner. +.\" OPTION: -matchvar .TP 10 -\fB\-matchvar\fR \fIvarName\fR +\fB\-matchvar\fI varName\fR . This option (only legal when \fB\-regexp\fR is also specified) specifies the name of a variable into which the list of matches @@ -68,8 +73,9 @@ capturing parenthesis in the regular expression that matched, and so on. When a \fBdefault\fR branch is taken, the variable will have the empty list written to it. This option may be specified at the same time as the \fB\-indexvar\fR option. +.\" OPTION: -indexvar .TP 10 -\fB\-indexvar\fR \fIvarName\fR +\fB\-indexvar\fI varName\fR . This option (only legal when \fB\-regexp\fR is also specified) specifies the name of a variable into which the list of indices @@ -85,6 +91,7 @@ capturing parenthesis in the regular expression that matched, and so on. When a \fBdefault\fR branch is taken, the variable will have the empty list written to it. This option may be specified at the same time as the \fB\-matchvar\fR option. +.\" OPTION: -- .TP 10 \fB\-\|\-\fR . @@ -128,7 +135,7 @@ literals, as shown here (the result is \fI2\fR): .PP .CS set foo "abc" -\fBswitch\fR abc a \- b {expr {1}} $foo {expr {2}} default {expr {3}} +\fBswitch\fR abc a - b {expr {1}} $foo {expr {2}} default {expr {3}} .CE .PP Using glob matching and the fall-through body is an alternative to @@ -136,8 +143,8 @@ writing regular expressions with alternations, as can be seen here (this returns \fI1\fR): .PP .CS -\fBswitch\fR \-glob aaab { - a*b \- +\fBswitch\fR -glob aaab { + a*b - b {expr {1}} a* {expr {2}} default {expr {3}} @@ -149,7 +156,7 @@ last) is taken. This example has a result of \fI3\fR: .PP .CS \fBswitch\fR xyz { - a \- + a - b { # Correct Comment Placement expr {1} @@ -167,7 +174,7 @@ When matching against regular expressions, information about what exactly matched is easily obtained using the \fB\-matchvar\fR option: .PP .CS -\fBswitch\fR \-regexp \-matchvar foo \-\- $bar { +\fBswitch\fR -regexp -matchvar foo -- $bar { a(b*)c { puts "Found [string length [lindex $foo 1]] 'b's" } diff --git a/doc/tclsh.1 b/doc/tclsh.1 index 3a78737..91df79d 100644 --- a/doc/tclsh.1 +++ b/doc/tclsh.1 @@ -96,26 +96,41 @@ its version number as part of the name. This has the advantage of allowing multiple versions of Tcl to exist on the same system at once, but also the disadvantage of making it harder to write scripts that start up uniformly across different versions of Tcl. +.PP +Alternatively, you can use /usr/bin/env to locate tclsh on the path, +like this: +.PP +.CS +\fB#!/usr/bin/env tclsh\fR +.CE +.PP +That has the advantages of being succinct and simple, but the +disadvantage of not being flexible in the face of varying names for +the binary. .SH "VARIABLES" .PP \fBTclsh\fR sets the following global Tcl variables in addition to those created by the Tcl library itself (such as \fBenv\fR, which maps environment variables such as \fBPATH\fR into Tcl): +.\" VARIABLE: argc .TP 15 \fBargc\fR . Contains a count of the number of \fIarg\fR arguments (0 if none), not including the name of the script file. +.\" VARIABLE: argv .TP 15 \fBargv\fR . Contains a Tcl list whose elements are the \fIarg\fR arguments, in order, or an empty string if there are no \fIarg\fR arguments. +.\" VARIABLE: argv0 .TP 15 \fBargv0\fR . Contains \fIfileName\fR if it was specified. Otherwise, contains the name by which \fBtclsh\fR was invoked. +.\" VARIABLE: tcl_interactive .TP 15 \fBtcl_interactive\fR . @@ -123,6 +138,8 @@ Contains 1 if \fBtclsh\fR is running interactively (no \fIfileName\fR was specified and standard input is a terminal-like device), 0 otherwise. .SH PROMPTS +.\" VARIABLE: tcl_prompt1 +.\" VARIABLE: tcl_prompt2 .PP When \fBtclsh\fR is invoked interactively it normally prompts for each command with diff --git a/doc/tcltest.n b/doc/tcltest.n index 965ed64..f78f7a2 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -89,8 +89,9 @@ See \fBCREATING TEST SUITES WITH TCLTEST\fR below for an extended example of how to use the commands of \fBtcltest\fR to produce test suites for your Tcl-enabled code. .SH COMMANDS +.\" COMMAND: test .TP -\fBtest\fR \fIname description\fR ?\fI\-option value ...\fR? +\fBtest\fI name description\fR ?\fI\-option value ...\fR? . Defines and possibly runs a test with the name \fIname\fR and description \fIdescription\fR. The name and description of a test @@ -104,17 +105,18 @@ See \fBTESTS\fR below for a complete description of the valid options and how they define a test. The \fBtest\fR command returns an empty string. .TP -\fBtest\fR \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR +\fBtest\fI name description\fR ?\fIconstraints\fR? \fIbody result\fR . This form of \fBtest\fR is provided to support test suites written for version 1 of the \fBtcltest\fR package, and also a simpler interface for a common usage. It is the same as -.QW "\fBtest\fR \fIname description\fB \-constraints \fIconstraints\fB \-body \fIbody\fB \-result \fIresult\fR" . +.QW "\fBtest\fI name description\fB \-constraints \fIconstraints\fB \-body \fIbody\fB \-result \fIresult\fR" . All other options to \fBtest\fR take their default values. When \fIconstraints\fR is omitted, this form of \fBtest\fR can be distinguished from the first because all \fIoption\fRs begin with .QW \- . +.\" COMMAND: loadTestedCommands .TP \fBloadTestedCommands\fR . @@ -124,8 +126,9 @@ Returns the result of that script evaluation, including any error raised by the script. Use this command and the related configuration options to provide the commands to be tested to the interpreter running the test suite. +.\" COMMAND: makeFile .TP -\fBmakeFile\fR \fIcontents name\fR ?\fIdirectory\fR? +\fBmakeFile\fI contents name\fR ?\fIdirectory\fR? . Creates a file named \fIname\fR relative to directory \fIdirectory\fR and write \fIcontents\fR @@ -140,16 +143,18 @@ of \fBcleanupTests\fR, unless it is removed by \fIdirectory\fR is the directory \fBconfigure \-tmpdir\fR. Returns the full path of the file created. Use this command to create any text file required by a test with contents as needed. +.\" COMMAND: removeFile .TP -\fBremoveFile\fR \fIname\fR ?\fIdirectory\fR? +\fBremoveFile\fI name\fR ?\fIdirectory\fR? . Forces the file referenced by \fIname\fR to be removed. This file name should be relative to \fIdirectory\fR. The default value of \fIdirectory\fR is the directory \fBconfigure \-tmpdir\fR. Returns an empty string. Use this command to delete files created by \fBmakeFile\fR. +.\" COMMAND: makeDirectory .TP -\fBmakeDirectory\fR \fIname\fR ?\fIdirectory\fR? +\fBmakeDirectory\fI name\fR ?\fIdirectory\fR? . Creates a directory named \fIname\fR relative to directory \fIdirectory\fR. The directory will be removed by the next evaluation of \fBcleanupTests\fR, @@ -158,8 +163,9 @@ The default value of \fIdirectory\fR is the directory \fBconfigure \-tmpdir\fR. Returns the full path of the directory created. Use this command to create any directories that are required to exist by a test. +.\" COMMAND: removeDirectory .TP -\fBremoveDirectory\fR \fIname\fR ?\fIdirectory\fR? +\fBremoveDirectory\fI name\fR ?\fIdirectory\fR? . Forces the directory referenced by \fIname\fR to be removed. This directory should be relative to \fIdirectory\fR. @@ -167,8 +173,9 @@ The default value of \fIdirectory\fR is the directory \fBconfigure \-tmpdir\fR. Returns an empty string. Use this command to delete any directories created by \fBmakeDirectory\fR. +.\" COMMAND: viewFile .TP -\fBviewFile\fR \fIfile\fR ?\fIdirectory\fR? +\fBviewFile\fI file\fR ?\fIdirectory\fR? . Returns the contents of \fIfile\fR, except for any final newline, just as \fBread \-nonewline\fR would return. @@ -180,6 +187,7 @@ by a test into the result of that test for matching against an expected result. The contents of the file are read using the system encoding, so its usefulness is limited to text files. +.\" COMMAND: cleanupTests .TP \fBcleanupTests\fR . @@ -200,6 +208,7 @@ to \fBoutputChannel\fR. This command also restores the original shell environment, as described by the global \fBenv\fR array. Returns an empty string. .RE +.\" COMMAND: runAllTests .TP \fBrunAllTests\fR . @@ -209,6 +218,7 @@ the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR below for a complete description of the many variations possible with \fBrunAllTests\fR. .SS "CONFIGURATION COMMANDS" +.\" COMMAND: configure .TP \fBconfigure\fR . @@ -238,6 +248,7 @@ then its value is taken as a list of arguments to pass to \fBconfigure\fR. This allows the default values of the configuration options to be set by the environment. .RE +.\" COMMAND: customMatch .TP \fBcustomMatch \fImode script\fR . @@ -252,11 +263,13 @@ is evaluated in the global namespace. The completed script is expected to return a boolean value indicating whether or not the results match. The built-in matching modes of \fBtest\fR are \fBexact\fR, \fBglob\fR, and \fBregexp\fR. +.\" COMMAND: testConstraint .TP \fBtestConstraint \fIconstraint\fR ?\fIboolean\fR? . Sets or returns the boolean value associated with the named \fIconstraint\fR. See \fBTEST CONSTRAINTS\fR below for more information. +.\" COMMAND: interpreter .TP \fBinterpreter\fR ?\fIexecutableName\fR? . @@ -265,6 +278,7 @@ Sets or returns the name of the executable to be \fBexec\fRed by \fBconfigure \-singleproc\fR is false. The default value for \fBinterpreter\fR is the name of the currently running program as returned by \fBinfo nameofexecutable\fR. +.\" COMMAND: outputChannel .TP \fBoutputChannel\fR ?\fIchannelID\fR? . @@ -272,6 +286,7 @@ Sets or returns the output channel ID. This defaults to \fBstdout\fR. Any test that prints test related output should send that output to \fBoutputChannel\fR rather than letting that output default to \fBstdout\fR. +.\" COMMAND: errorChannel .TP \fBerrorChannel\fR ?\fIchannelID\fR? . @@ -280,6 +295,7 @@ Any test that prints error messages should send that output to \fBerrorChannel\fR rather than printing directly to \fBstderr\fR. .SS "SHORTCUT CONFIGURATION COMMANDS" +.\" COMMAND: debug .TP \fBdebug\fR ?\fIlevel\fR? . @@ -290,76 +306,91 @@ Same as . Same as .QW "\fBconfigure \-errfile\fR ?\fIfilename\fR?" . +.\" COMMAND: limitConstraints .TP \fBlimitConstraints\fR ?\fIboolean\fR? . Same as .QW "\fBconfigure \-limitconstraints\fR ?\fIboolean\fR?" . +.\" COMMAND: loadFile .TP \fBloadFile\fR ?\fIfilename\fR? . Same as .QW "\fBconfigure \-loadfile\fR ?\fIfilename\fR?" . +.\" COMMAND: loadScript .TP \fBloadScript\fR ?\fIscript\fR? . Same as .QW "\fBconfigure \-load\fR ?\fIscript\fR?" . +.\" COMMAND: match .TP \fBmatch\fR ?\fIpatternList\fR? . Same as .QW "\fBconfigure \-match\fR ?\fIpatternList\fR?" . +.\" COMMAND: matchDirectories .TP \fBmatchDirectories\fR ?\fIpatternList\fR? . Same as .QW "\fBconfigure \-relateddir\fR ?\fIpatternList\fR?" . +.\" COMMAND: matchFiles .TP \fBmatchFiles\fR ?\fIpatternList\fR? . Same as .QW "\fBconfigure \-file\fR ?\fIpatternList\fR?" . +.\" COMMAND: outputFile .TP \fBoutputFile\fR ?\fIfilename\fR? . Same as .QW "\fBconfigure \-outfile\fR ?\fIfilename\fR?" . +.\" COMMAND: preserveCore .TP \fBpreserveCore\fR ?\fIlevel\fR? . Same as .QW "\fBconfigure \-preservecore\fR ?\fIlevel\fR?" . +.\" COMMAND: singleProcess .TP \fBsingleProcess\fR ?\fIboolean\fR? . Same as .QW "\fBconfigure \-singleproc\fR ?\fIboolean\fR?" . +.\" COMMAND: skip .TP \fBskip\fR ?\fIpatternList\fR? . Same as .QW "\fBconfigure \-skip\fR ?\fIpatternList\fR?" . +.\" COMMAND: skipDirectories .TP \fBskipDirectories\fR ?\fIpatternList\fR? . Same as .QW "\fBconfigure \-asidefromdir\fR ?\fIpatternList\fR?" . +.\" COMMAND: skipFiles .TP \fBskipFiles\fR ?\fIpatternList\fR? . Same as .QW "\fBconfigure \-notfile\fR ?\fIpatternList\fR?" . +.\" COMMAND: temporaryDirectory .TP \fBtemporaryDirectory\fR ?\fIdirectory\fR? . Same as .QW "\fBconfigure \-tmpdir\fR ?\fIdirectory\fR?" . +.\" COMMAND: testsDirectory .TP \fBtestsDirectory\fR ?\fIdirectory\fR? . Same as .QW "\fBconfigure \-testdir\fR ?\fIdirectory\fR?" . +.\" COMMAND: verbose .TP \fBverbose\fR ?\fIlevel\fR? . @@ -372,7 +403,7 @@ alternatives provided by \fBtcltest\fR or \fBTcl\fR itself. They are retained to support existing test suites, but should be avoided in new code. .TP -\fBtest\fR \fIname description optionList\fR +\fBtest\fI name description optionList\fR . This form of \fBtest\fR was provided to enable passing many options spanning several lines to \fBtest\fR as a single @@ -396,6 +427,7 @@ If you insist on using this form, examine the source code of \fBtcltest\fR if you want to know the substitution details, or just enclose the third through last argument to \fBtest\fR in braces and hope for the best. +.\" COMMAND: workingDirectory .TP \fBworkingDirectory\fR ?\fIdirectoryName\fR? . @@ -403,6 +435,7 @@ Sets or returns the current working directory when the test suite is running. The default value for workingDirectory is the directory in which the test suite was launched. The Tcl commands \fBcd\fR and \fBpwd\fR are sufficient replacements. +.\" COMMAND: normalizeMsg .TP \fBnormalizeMsg \fImsg\fR . @@ -414,6 +447,7 @@ is rather imprecise. Tcl offers plenty of string processing commands to modify strings as you wish, and \fBcustomMatch\fR allows flexible matching of actual and expected results. +.\" COMMAND: normalizePath .TP \fBnormalizePath \fIpathVar\fR . @@ -421,6 +455,7 @@ Resolves symlinks in a path, thus creating a path without internal redirection. It is assumed that \fIpathVar\fR is absolute. \fIpathVar\fR is modified in place. The Tcl command \fBfile normalize\fR is a sufficient replacement. +.\" COMMAND: bytestring .TP \fBbytestring \fIstring\fR . @@ -445,7 +480,7 @@ also influence how \fBtest\fR operates. The valid options for \fBtest\fR are summarized: .PP .CS -\fBtest\fR \fIname\fR \fIdescription\fR +\fBtest\fI name description\fR ?\fB\-constraints \fIkeywordList|expression\fR? ?\fB\-setup \fIsetupScript\fR? ?\fB\-body \fItestScript\fR? @@ -490,6 +525,7 @@ description for regression tests. If the test case exists to reproduce a bug, include the bug ID in the description. .PP Valid attributes and associated values are: +.\" OPTION: -constraints .TP \fB\-constraints \fIkeywordList\fR|\fIexpression\fR . @@ -500,9 +536,12 @@ defined by a call to \fBtestConstraint\fR. If any of the listed constraints is false or does not exist, the test is skipped. If the \fB\-constraints\fR value is an expression, that expression is evaluated. If the expression evaluates to true, then the test is run. +.RS +.PP Note that the expression form of \fB\-constraints\fR may interfere with the operation of \fBconfigure \-constraints\fR and \fBconfigure \-limitconstraints\fR, and is not recommended. +.PP Appropriate constraints should be added to any tests that should not always be run. That is, conditional evaluation of a test should be accomplished by the \fB\-constraints\fR option, not by @@ -512,6 +551,8 @@ the number skipped may change based on the testing environment. The default value is an empty list. See \fBTEST CONSTRAINTS\fR below for a list of built-in constraints and information on how to add your own constraints. +.RE +.\" OPTION: -setup .TP \fB\-setup \fIscript\fR . @@ -519,6 +560,7 @@ The optional \fB\-setup\fR attribute indicates a \fIscript\fR that will be run before the script indicated by the \fB\-body\fR attribute. If evaluation of \fIscript\fR raises an error, the test will fail. The default value is an empty script. +.\" OPTION: -body .TP \fB\-body \fIscript\fR . @@ -528,6 +570,7 @@ If evaluation of \fIscript\fR raises an error, the test will fail (unless the \fB\-returnCodes\fR option is used to state that an error is expected). The default value is an empty script. +.\" OPTION: -cleanup .TP \fB\-cleanup \fIscript\fR . @@ -535,6 +578,7 @@ The optional \fB\-cleanup\fR attribute indicates a \fIscript\fR that will be run after the script indicated by the \fB\-body\fR attribute. If evaluation of \fIscript\fR raises an error, the test will fail. The default value is an empty script. +.\" OPTION: -match .TP \fB\-match \fImode\fR . @@ -543,12 +587,14 @@ The \fB\-match\fR attribute determines how expected answers supplied by values for \fImode\fR are \fBregexp\fR, \fBglob\fR, \fBexact\fR, and any value registered by a prior call to \fBcustomMatch\fR. The default value is \fBexact\fR. +.\" OPTION: -result .TP \fB\-result \fIexpectedValue\fR . The \fB\-result\fR attribute supplies the \fIexpectedValue\fR against which the return value from script will be compared. The default value is an empty string. +.\" OPTION: -output .TP \fB\-output \fIexpectedValue\fR . @@ -558,6 +604,7 @@ of the script(s) will be compared. Note that only output printed using the global \fBputs\fR command is used for comparison. If \fB\-output\fR is not specified, output sent to \fBstdout\fR and \fBoutputChannel\fR is not processed for comparison. +.\" OPTION: -errorOutput .TP \fB\-errorOutput \fIexpectedValue\fR . @@ -567,6 +614,7 @@ evaluation of the script(s) will be compared. Note that only output printed using the global \fBputs\fR command is used for comparison. If \fB\-errorOutput\fR is not specified, output sent to \fBstderr\fR and \fBerrorChannel\fR is not processed for comparison. +.\" OPTION: -returnCodes .TP \fB\-returnCodes \fIexpectedCodeList\fR . @@ -578,6 +626,7 @@ return codes known to \fBreturn\fR, in both numeric and symbolic form, including extended return codes, are acceptable elements in the \fIexpectedCodeList\fR. Default value is .QW "\fBok return\fR" . +.\" OPTION: -errorCode .TP \fB\-errorCode \fIexpectedErrorCode\fR . @@ -634,134 +683,82 @@ options. .PP The following is a list of constraints predefined by the \fBtcltest\fR package itself: -.TP -\fIsingleTestInterp\fR -. +.IP \fIsingleTestInterp\fR This test can only be run if all test files are sourced into a single interpreter. -.TP -\fIunix\fR -. +.IP \fIunix\fR This test can only be run on any Unix platform. -.TP -\fIwin\fR -. +.IP \fIwin\fR This test can only be run on any Windows platform. -.TP -\fInt\fR -. +.IP \fInt\fR This test can only be run on any Windows NT platform. -.TP -\fImac\fR -. +.IP \fImac\fR This test can only be run on any Mac platform. -.TP -\fIunixOrWin\fR -. +.IP \fIunixOrWin\fR This test can only be run on a Unix or Windows platform. -.TP -\fImacOrWin\fR -. +.IP \fImacOrWin\fR This test can only be run on a Mac or Windows platform. -.TP -\fImacOrUnix\fR -. +.IP \fImacOrUnix\fR This test can only be run on a Mac or Unix platform. -.TP -\fItempNotWin\fR -. +.IP \fItempNotWin\fR This test can not be run on Windows. This flag is used to temporarily disable a test. -.TP -\fItempNotMac\fR -. +.IP \fItempNotMac\fR This test can not be run on a Mac. This flag is used to temporarily disable a test. -.TP -\fIunixCrash\fR -. +.IP \fIunixCrash\fR This test crashes if it is run on Unix. This flag is used to temporarily disable a test. -.TP -\fIwinCrash\fR -. +.IP \fIwinCrash\fR This test crashes if it is run on Windows. This flag is used to temporarily disable a test. -.TP -\fImacCrash\fR -. +.IP \fImacCrash\fR This test crashes if it is run on a Mac. This flag is used to temporarily disable a test. -.TP -\fIemptyTest\fR -. +.IP \fIemptyTest\fR This test is empty, and so not worth running, but it remains as a place-holder for a test to be written in the future. This constraint has value false to cause tests to be skipped unless the user specifies otherwise. -.TP -\fIknownBug\fR -. +.IP \fIknownBug\fR This test is known to fail and the bug is not yet fixed. This constraint has value false to cause tests to be skipped unless the user specifies otherwise. -.TP -\fInonPortable\fR -. +.IP \fInonPortable\fR This test can only be run in some known development environment. Some tests are inherently non-portable because they depend on things like word length, file system configuration, window manager, etc. This constraint has value false to cause tests to be skipped unless the user specifies otherwise. -.TP -\fIuserInteraction\fR -. +.IP \fIuserInteraction\fR This test requires interaction from the user. This constraint has value false to causes tests to be skipped unless the user specifies otherwise. -.TP -\fIinteractive\fR -. +.IP \fIinteractive\fR This test can only be run in if the interpreter is in interactive mode -(when the global tcl_interactive variable is set to 1). -.TP -\fInonBlockFiles\fR -. +(when the global \fB::tcl_interactive\fR variable is set to 1). +.IP \fInonBlockFiles\fR This test can only be run if platform supports setting files into nonblocking mode. -.TP -\fIasyncPipeClose\fR -. +.IP \fIasyncPipeClose\fR This test can only be run if platform supports async flush and async close on a pipe. -.TP -\fIunixExecs\fR -. +.IP \fIunixExecs\fR This test can only be run if this machine has Unix-style commands \fBcat\fR, \fBecho\fR, \fBsh\fR, \fBwc\fR, \fBrm\fR, \fBsleep\fR, \fBfgrep\fR, \fBps\fR, \fBchmod\fR, and \fBmkdir\fR available. -.TP -\fIhasIsoLocale\fR -. +.IP \fIhasIsoLocale\fR This test can only be run if can switch to an ISO locale. -.TP -\fIroot\fR -. +.IP \fIroot\fR This test can only run if Unix user is root. -.TP -\fInotRoot\fR -. +.IP \fInotRoot\fR This test can only run if Unix user is not root. -.TP -\fIeformat\fR -. +.IP \fIeformat\fR This test can only run if app has a working version of sprintf with respect to the .QW e format of floating-point numbers. -.TP -\fIstdio\fR -. +.IP \fIstdio\fR This test can only be run if \fBinterpreter\fR can be \fBopen\fRed as a pipe. .PP @@ -846,12 +843,14 @@ command. .SH "CONFIGURABLE OPTIONS" The \fBconfigure\fR command is used to set and query the configurable options of \fBtcltest\fR. The valid options are: +.\" OPTION: -singleproc .TP \fB\-singleproc \fIboolean\fR . Controls whether or not \fBrunAllTests\fR spawns a child process for each test file. No spawning when \fIboolean\fR is true. Default value is false. +.\" OPTION: -debug .TP \fB\-debug \fIlevel\fR . @@ -877,6 +876,7 @@ that exist in the current namespace as they are used. Display information regarding what individual procs in the test harness are doing. .RE +.\" OPTION: -verbose .TP \fB\-verbose \fIlevel\fR . @@ -906,7 +906,7 @@ Print each test's execution time in milliseconds Print each test's execution time in microseconds .PP Note that the \fBmsec\fR and \fBusec\fR verbosity levels are provided as -indicative measures only. They do not tackle the problem of repeatibility which +indicative measures only. They do not tackle the problem of repeatability which should be considered in performance tests or benchmarks. To use these verbosity levels to thoroughly track performance degradations, consider wrapping your test bodies with \fBtime\fR commands. @@ -917,6 +917,7 @@ so that is the same as .QW "\fBconfigure \-verbose {pass start}\fR" . .RE +.\" OPTION: -preservecore .TP \fB\-preservecore \fIlevel\fR . @@ -934,11 +935,13 @@ Also check for core files at the end of each \fBtest\fR command. Check for core files at all times described above, and save a copy of each core file produced in \fBconfigure \-tmpdir\fR. .RE +.\" OPTION: -limitconstraints .TP \fB\-limitconstraints \fIboolean\fR . Sets the mode by which \fBtest\fR honors constraints as described in \fBTESTS\fR above. Default value is false. +.\" OPTION: -constraints .TP \fB\-constraints \fIlist\fR . @@ -946,6 +949,7 @@ Sets all the constraints in \fIlist\fR to true. Also used in combination with \fBconfigure \-limitconstraints true\fR to control an alternative constraint mode as described in \fBTESTS\fR above. Default value is an empty list. +.\" OPTION: -tmpdir .TP \fB\-tmpdir \fIdirectory\fR . @@ -954,17 +958,20 @@ Sets the temporary directory to be used by \fBmakeFile\fR, and \fBremoveDirectory\fR as the default directory where temporary files and directories created by test files should be created. Default value is \fBworkingDirectory\fR. +.\" OPTION: -testdir .TP \fB\-testdir \fIdirectory\fR . Sets the directory searched by \fBrunAllTests\fR for test files and subdirectories. Default value is \fBworkingDirectory\fR. +.\" OPTION: -file .TP \fB\-file \fIpatternList\fR . Sets the list of patterns used by \fBrunAllTests\fR to determine what test files to evaluate. Default value is .QW \fB*.test\fR . +.\" OPTION: -notfile .TP \fB\-notfile \fIpatternList\fR . @@ -972,6 +979,7 @@ Sets the list of patterns used by \fBrunAllTests\fR to determine what test files to skip. Default value is .QW \fBl.*.test\fR , so that any SCCS lock files are skipped. +.\" OPTION: -relateddir .TP \fB\-relateddir \fIpatternList\fR . @@ -979,40 +987,47 @@ Sets the list of patterns used by \fBrunAllTests\fR to determine what subdirectories to search for an \fBall.tcl\fR file. Default value is .QW \fB*\fR . +.\" OPTION: -asidefromdir .TP \fB\-asidefromdir \fIpatternList\fR . Sets the list of patterns used by \fBrunAllTests\fR to determine what subdirectories to skip when searching for an \fBall.tcl\fR file. Default value is an empty list. +.\" OPTION: -match .TP \fB\-match \fIpatternList\fR . Set the list of patterns used by \fBtest\fR to determine whether a test should be run. Default value is .QW \fB*\fR . +.\" OPTION: -skip .TP \fB\-skip \fIpatternList\fR . Set the list of patterns used by \fBtest\fR to determine whether a test should be skipped. Default value is an empty list. +.\" OPTION: -load .TP \fB\-load \fIscript\fR . Sets a script to be evaluated by \fBloadTestedCommands\fR. Default value is an empty script. +.\" OPTION: -loadfile .TP \fB\-loadfile \fIfilename\fR . Sets the filename from which to read a script to be evaluated by \fBloadTestedCommands\fR. This is an alternative to \fB\-load\fR. They cannot be used together. +.\" OPTION: -outfile .TP \fB\-outfile \fIfilename\fR . Sets the file to which all output produced by tcltest should be written. A file named \fIfilename\fR will be \fBopen\fRed for writing, and the resulting channel will be set as the value of \fBoutputChannel\fR. +.\" OPTION: -errfile .TP \fB\-errfile \fIfilename\fR . diff --git a/doc/tclvars.n b/doc/tclvars.n index 4d1413c..04cbc6c 100644 --- a/doc/tclvars.n +++ b/doc/tclvars.n @@ -10,13 +10,14 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl +argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl .BE .SH DESCRIPTION .PP The following global variables are created and managed automatically by the Tcl library. Except where noted below, these variables should normally be treated as read-only by application-specific code and by users. +.\" VARIABLE: auto_path .TP \fBauto_path\fR . @@ -30,12 +31,17 @@ the parent directory of \fBtcl_library\fR, the directories listed in the \fBtcl_pkgPath\fR variable. Additional locations to look for files and package indices should normally be added to this variable using \fBlappend\fR. +Initialization of auto_path from the TCLLIBPATH environment +variable undergoes tilde substitution (see \fBfilename\fR) on each +path. Any tilde substitution that fails because the user is unknown +will be omitted from auto_path. .RS .PP Additional variables relating to package management exist. More details are listed in the \fBVARIABLES\fR section of the \fBlibrary\fR manual page. .RE +.\" VARIABLE: env .TP \fBenv\fR . @@ -73,11 +79,11 @@ The following elements of \fBenv\fR are special to Tcl: \fBenv(HOME)\fR . This environment variable, if set, gives the location of the directory -considered to be the current user's home directory, and to which a -call of \fBcd\fR without arguments or with just -.QW ~ -as an argument will change into. Most platforms set this correctly by -default; it does not normally need to be set by user code. +considered to be the current user's home directory. The value of this variable +is returned by the \fBfile home\fR command. Most platforms set this correctly by +default; it does not normally need to be set by user code. On Windows, if not +already set, it is set to the value of the \fBUSERPROFILE\fR environment +variable. .TP \fBenv(TCL_LIBRARY)\fR . @@ -117,6 +123,7 @@ If existing, it has the same effect as running \fBinterp debug\fR \fB{} -frame 1\fR as the very first command of each new Tcl interpreter. .RE +.\" VARIABLE: errorCode .TP \fBerrorCode\fR . @@ -213,6 +220,7 @@ If none of these methods for setting the error code has been used, the Tcl interpreter will reset the variable to \fBNONE\fR after the next error. .RE +.\" VARIABLE: errorInfo .TP \fBerrorInfo\fR . @@ -223,6 +231,7 @@ identifying the Tcl commands and procedures that were being executed when the most recent error occurred. Its contents take the form of a stack trace showing the various nested Tcl commands that had been invoked at the time of the error. +.\" VARIABLE: tcl_library .TP \fBtcl_library\fR . @@ -245,6 +254,7 @@ If \fBTCL_LIBRARY\fR is not set or doesn't refer to an appropriate directory, then Tcl checks several other directories based on a compiled-in default location, the location of the binary containing the application, and the current working directory. +.\" VARIABLE: tcl_patchLevel .TP \fBtcl_patchLevel\fR . @@ -254,6 +264,7 @@ hold a string giving the current patch level for Tcl, such as \fB8.5b3\fR for the third beta release of Tcl 8.5. The value of this variable is returned by the \fBinfo patchlevel\fR command. +.\" VARIABLE: tcl_pkgPath .TP \fBtcl_pkgPath\fR . @@ -273,6 +284,7 @@ value is added to \fBauto_path\fR at startup; changes to \fBtcl_pkgPath\fR are not reflected in \fBauto_path\fR. If you want Tcl to search additional directories for packages you should add the names of those directories to \fBauto_path\fR, not \fBtcl_pkgPath\fR. +.\" VARIABLE: tcl_platform .TP \fBtcl_platform\fR . @@ -285,138 +297,52 @@ retrieve any relevant information. In addition, extensions and applications may add additional values to the array. The predefined elements are: .RS -.TP -\fBbyteOrder\fR -. +.IP \fBbyteOrder\fR The native byte order of this machine: either \fBlittleEndian\fR or \fBbigEndian\fR. -.TP -\fBdebug\fR -. +.IP \fBdebug\fR If this variable exists, then the interpreter was compiled with and linked to a debug-enabled C run-time. This variable will only exist on Windows, so extension writers can specify which package to load depending on the C run-time library that is in use. This is not an indication that this core contains symbols. -.TP -\fBengine\fR -. +.IP \fBengine\fR The name of the Tcl language implementation. When the interpreter is first created, this is always set to the string \fBTcl\fR. -.TP -\fBmachine\fR -. +.IP \fBmachine\fR The instruction set executed by this machine, such as \fBintel\fR, \fBPPC\fR, \fB68k\fR, or \fBsun4m\fR. On UNIX machines, this is the value returned by \fBuname -m\fR. -.TP -\fBos\fR -. +.IP \fBos\fR The name of the operating system running on this machine, such as \fBWindows NT\fR or \fBSunOS\fR. On UNIX machines, this is the value returned by \fBuname -s\fR. -.TP -\fBosVersion\fR -. +.IP \fBosVersion\fR The version number for the operating system running on this machine. On UNIX machines, this is the value returned by \fBuname -r\fR. -.TP -\fBpathSeparator\fR +.IP \fBpathSeparator\fR '\" Defined by TIP #315 The character that should be used to \fBsplit\fR PATH-like environment variables into their corresponding list of directory names. -.TP -\fBplatform\fR -. +.IP \fBplatform\fR Either \fBwindows\fR, or \fBunix\fR. This identifies the general operating environment of the machine. -.TP -\fBpointerSize\fR -. +.IP \fBpointerSize\fR This gives the size of the native-machine pointer in bytes (strictly, it is same as the result of evaluating \fIsizeof(void*)\fR in C.) -.TP -\fBthreaded\fR -. +.IP \fBthreaded\fR If this variable exists, then the interpreter was compiled with threads enabled. -.TP -\fBuser\fR -. +.IP \fBuser\fR This identifies the current user based on the login information available on the platform. This value comes from the getuid() and getpwuid() system calls on Unix, and the value from the GetUserName() system call on Windows. -.TP -\fBwordSize\fR -. +.IP \fBwordSize\fR This gives the size of the native-machine word in bytes (strictly, it is same as the result of evaluating \fIsizeof(long)\fR in C.) .RE -.TP -\fBtcl_precision\fR -. -This variable controls the number of digits to generate -when converting floating-point values to strings. It defaults -to 0. \fIApplications should not change this value;\fR it is -provided for compatibility with legacy code. -.PP -.RS -The default value of 0 is special, meaning that Tcl should -convert numbers using as few digits as possible while still -distinguishing any floating point number from its nearest -neighbours. It differs from using an arbitrarily high value -for \fItcl_precision\fR in that an inexact number like \fI1.4\fR -will convert as \fI1.4\fR rather than \fI1.3999999999999999\fR -even though the latter is nearer to the exact value of the -binary number. -.RE -.PP -.RS -If \fBtcl_precision\fR is not zero, then when Tcl converts a floating -point number, it creates a decimal representation of at most -\fBtcl_precision\fR significant digits; the result may be shorter if -the shorter result represents the original number exactly. If no -result of at most \fBtcl_precision\fR digits is an exact representation -of the original number, the one that is closest to the original -number is chosen. -If the original number lies precisely between two equally accurate -decimal representations, then the one with an even value for the least -significant digit is chosen; for instance, if \fBtcl_precision\fR is 3, then -0.3125 will convert to 0.312, not 0.313, while 0.6875 will convert to -0.688, not 0.687. Any string of trailing zeroes that remains is trimmed. -.RE -.PP -.RS -a \fBtcl_precision\fR value of 17 digits is -.QW perfect -for IEEE floating-point in that it allows -double-precision values to be converted to strings and back to -binary with no loss of information. For this reason, you will often -see it as a value in legacy code that must run on Tcl versions before -8.5. It is no longer recommended; as noted above, a zero value is the -preferred method. -.RE -.PP -.RS -All interpreters in a thread share a single \fBtcl_precision\fR value: -changing it in one interpreter will affect all other interpreters as -well. Safe interpreters are not allowed to modify the -variable. -.RE -.PP -.RS -Valid values for \fBtcl_precision\fR range from 0 to 17. -.RE -.TP -\fBtcl_rcFileName\fR -. -This variable is used during initialization to indicate the name of a -user-specific startup file. If it is set by application-specific -initialization, then the Tcl startup code will check for the existence -of this file and \fBsource\fR it if it exists. For example, for \fBwish\fR -the variable is set to \fB~/.wishrc\fR for Unix and \fB~/wishrc.tcl\fR -for Windows. +.\" VARIABLE: tcl_traceCompile .TP \fBtcl_traceCompile\fR . @@ -434,7 +360,9 @@ tracking down suspected problems with the Tcl compiler. .RS This variable and functionality only exist if \fBTCL_COMPILE_DEBUG\fR was defined during Tcl's compilation. +.\" tcl::unsupported::disassemble always works, but we don't document it .RE +.\" VARIABLE: tcl_traceExec .TP \fBtcl_traceExec\fR . @@ -461,6 +389,7 @@ and interpreter. This variable and functionality only exist if \fBTCL_COMPILE_DEBUG\fR was defined during Tcl's compilation. .RE +.\" VARIABLE: tcl_wordchars .TP \fBtcl_wordchars\fR . @@ -472,6 +401,7 @@ selecting a word by double-clicking in text in Tk. It is platform dependent. On Windows, it defaults to \fB\eS\fR, meaning anything but a Unicode space character. Otherwise it defaults to \fB\ew\fR, which is any Unicode word character (number, letter, or underscore). +.\" VARIABLE: tcl_nonwordchars .TP \fBtcl_nonwordchars\fR . @@ -483,6 +413,7 @@ selecting a word by double-clicking in text in Tk. It is platform dependent. On Windows, it defaults to \fB\es\fR, meaning any Unicode space character. Otherwise it defaults to \fB\eW\fR, which is anything but a Unicode word character (number, letter, or underscore). +.\" VARIABLE: tcl_version .TP \fBtcl_version\fR . @@ -498,20 +429,24 @@ command. The following variables are only guaranteed to exist in \fBtclsh\fR and \fBwish\fR executables; the Tcl library does not define them itself but many Tcl environments do. +.\" VARIABLE: argc .TP 6 \fBargc\fR . The number of arguments to \fBtclsh\fR or \fBwish\fR. +.\" VARIABLE: argv .TP 6 \fBargv\fR . Tcl list of arguments to \fBtclsh\fR or \fBwish\fR. +.\" VARIABLE: argv0 .TP 6 \fBargv0\fR . The script that \fBtclsh\fR or \fBwish\fR started executing (if it was specified) or otherwise the name by which \fBtclsh\fR or \fBwish\fR was invoked. +.\" VARIABLE: tcl_interactive .TP 6 \fBtcl_interactive\fR . diff --git a/doc/timerate.n b/doc/timerate.n index 5d49c86..0207fd8 100644 --- a/doc/timerate.n +++ b/doc/timerate.n @@ -11,11 +11,11 @@ .SH NAME timerate \- Calibrated performance measurements of script execution time .SH SYNOPSIS +.nf \fBtimerate \fIscript\fR ?\fItime\fR? ?\fImax-count\fR? -.sp -\fBtimerate \fR?\fB\-direct\fR? ?\fB\-overhead\fI double\fR? \fIscript\fR ?\fItime\fR? ?\fImax-count\fR? -.sp +\fBtimerate \fR?\fB\-direct\fR? ?\fB\-overhead\fI estimate\fR? \fIscript\fR ?\fItime\fR? ?\fImax-count\fR? \fBtimerate \fR?\fB\-calibrate\fR? ?\fB\-direct\fR? \fIscript\fR ?\fItime\fR? ?\fImax-count\fR? +.fi .BE .SH DESCRIPTION .PP @@ -32,12 +32,12 @@ application performance. The first and second form will evaluate \fIscript\fR until the interval \fItime\fR given in milliseconds elapses, or for 1000 milliseconds (1 second) if \fItime\fR is not specified. -.sp +.PP The parameter \fImax-count\fR could additionally impose a further restriction by the maximal number of iterations to evaluate the script. If \fImax-count\fR is specified, the evaluation will stop either this count of iterations is reached or the time is exceeded. -.sp +.PP It will then return a canonical Tcl-list of the form: .PP .CS @@ -46,15 +46,18 @@ It will then return a canonical Tcl-list of the form: .PP which indicates: .IP \(bu 3 -the average amount of time required per iteration, in microseconds ([\fBlindex\fR $result 0]) +the average amount of time required per iteration, in microseconds +([\fBlindex\fR $result 0]) .IP \(bu 3 the count how many times it was executed ([\fBlindex\fR $result 2]) .IP \(bu 3 the estimated rate per second ([\fBlindex\fR $result 4]) .IP \(bu 3 -the estimated real execution time without measurement overhead ([\fBlindex\fR $result 6]) +the estimated real execution time without measurement overhead +([\fBlindex\fR $result 6]) .PP The following options may be supplied to the \fBtimerate\fR command: +.\" OPTION: -calibrate .TP \fB\-calibrate\fR . @@ -66,31 +69,36 @@ for future invocations of the \fBtimerate\fR command. If the \fItime\fR parameter is not specified, the calibrate procedure runs for up to 10 seconds. .RS .PP -Note that calibration is not thread safe in the current implementation. +Note that the calibration process is not thread safe in the current +implementation. .RE +.\" OPTION: -overhead .TP -\fB\-overhead \fIdouble\fR +\fB\-overhead \fIestimate\fR . -The \fB\-overhead\fR parameter supplies an estimate (in microseconds) of the +The \fB\-overhead\fR parameter supplies an estimate (in microseconds, which may +be a floating point number) of the measurement overhead of each iteration of the tested script. This quantity will be subtracted from the measured time prior to reporting results. This can be useful for removing the cost of interpreter state reset commands from the script being measured. +.\" OPTION: -direct .TP \fB\-direct\fR . -The \fB-direct\fR option causes direct execution of the supplied script, +The \fB\-direct\fR option causes direct execution of the supplied script, without compilation, in a manner similar to the \fBtime\fR command. It can be used to measure the cost of \fBTcl_EvalObjEx\fR, of the invocation of canonical lists, and of the uncompiled versions of bytecoded commands. .PP -As opposed to the \fBtime\fR commmand, which runs the tested script for a fixed +As opposed to the \fBtime\fR command, which runs the tested script for a fixed number of iterations, the \fBtimerate\fR command runs it for a fixed time. Additionally, the compiled variant of the script will be used during the entire -measurement, as if the script were part of a compiled procedure, if the \fB\-direct\fR -option is not specified. The fixed time period and possibility of compilation allow -for more precise results and prevent very long execution times by slow scripts, making -it practical for measuring scripts with highly uncertain execution times. +measurement, as if the script were part of a compiled procedure, +if the \fB\-direct\fR option is not specified. The fixed time period and +possibility of compilation allow for more precise results and prevent very long +execution times by slow scripts, making it practical for measuring scripts with +highly uncertain execution times. .SH EXAMPLES Estimate how fast it takes for a simple Tcl \fBfor\fR loop (including operations on variable \fIi\fR) to count to ten: @@ -116,9 +124,9 @@ set i 0; \fBtimerate\fR -calibrate {expr {$i<10}; incr i} 1000 } 5000 .CE .PP -Estimate the speed of calculating the hour of the day using \fBclock format\fR only, -ignoring overhead of the portion of the script that prepares the time for it to -calculate: +Estimate the speed of calculating the hour of the day using \fBclock format\fR +only, ignoring overhead of the portion of the script that prepares the time for +it to calculate: .PP .CS \fI# calibrate\fR @@ -23,6 +23,8 @@ tm \- Facilities for locating and loading of Tcl Modules This document describes the facilities for locating and loading Tcl Modules (see \fBMODULE DEFINITION\fR for the definition of a Tcl Module). The following commands are supported: +.\" COMMAND: path +.\" METHOD: add .TP \fB::tcl::tm::path add \fR?\fIpath\fR...? . @@ -45,16 +47,19 @@ list. As they are added to the front of the list they are searched in reverse order of addition. In other words, the paths added last are looked at first. .RE +.\" METHOD: remove .TP \fB::tcl::tm::path remove \fR?\fIpath\fR...? . Removes the paths from the list of module paths. The command silently ignores all paths which are not on the list. +.\" METHOD: list .TP \fB::tcl::tm::path list\fR . Returns a list containing all registered module paths, in the order that they are searched for modules. +.\" COMMAND: roots .TP \fB::tcl::tm::roots \fR?\fIpath\fR...? . @@ -295,6 +300,10 @@ environment variables: \fB$::env(TCL8.1_TM_PATH)\fR \fB$::env(TCL8_1_TM_PATH)\fR \fB$::env(TCL8.0_TM_PATH)\fR \fB$::env(TCL8_0_TM_PATH)\fR .CE +.PP +Paths initialized from the environment variables undergo tilde +substitution (see \fBfilename\fR). Any path whose tilde substitution +fails because the user is unknown will be omitted from search paths. .SH "SEE ALSO" package(n), Tcl Improvement Proposal #189 .QW "\fITcl Modules\fR" diff --git a/doc/trace.n b/doc/trace.n index 9b8fd57..6eba974 100644 --- a/doc/trace.n +++ b/doc/trace.n @@ -19,13 +19,14 @@ trace \- Monitor variable accesses, command usages and command executions .PP This command causes Tcl commands to be executed whenever certain operations are invoked. The legal \fIoption\fRs (which may be abbreviated) are: +.\" METHOD: add .TP \fBtrace add \fItype name ops\fR ?\fIargs\fR? . Where \fItype\fR is \fBcommand\fR, \fBexecution\fR, or \fBvariable\fR. .RS .TP -\fBtrace add command\fR \fIname ops commandPrefix\fR +\fBtrace add command\fI name ops commandPrefix\fR . Arrange for \fIcommandPrefix\fR to be executed (with additional arguments) whenever command \fIname\fR is modified in one of the ways given by the list @@ -76,7 +77,7 @@ Both \fIoldName\fR and \fInewName\fR are fully qualified with any namespace(s) in which they appear. .RE .TP -\fBtrace add execution\fR \fIname ops commandPrefix\fR +\fBtrace add execution\fI name ops commandPrefix\fR . Arrange for \fIcommandPrefix\fR to be executed (with additional arguments) whenever command \fIname\fR is executed, with traces occurring at the points @@ -89,10 +90,12 @@ an error will be thrown. one or more of the following items: .TP \fBenter\fR +. Invoke \fIcommandPrefix\fR whenever the command \fIname\fR is executed, just before the actual execution takes place. .TP \fBleave\fR +. Invoke \fIcommandPrefix\fR whenever the command \fIname\fR is executed, just after the actual execution takes place. .TP @@ -156,6 +159,7 @@ the result string. \fIOp\fR indicates what operation is being performed on the command execution, and is one of \fBleave\fR or \fBleavestep\fR as defined above. +.PP Note that the creation of many \fBenterstep\fR or \fBleavestep\fR traces can lead to unintuitive results, since the invoked commands from one trace can themselves lead to further @@ -187,6 +191,7 @@ The behavior of execution traces is currently undefined for a command .RE .TP \fBtrace add variable\fI name ops commandPrefix\fR +. Arrange for \fIcommandPrefix\fR to be executed whenever variable \fIname\fR is accessed in one of the ways given by the list \fIops\fR. \fIName\fR may refer to a normal variable, an element of an array, or to an array @@ -202,6 +207,7 @@ queries, but not to \fBinfo exists\fR queries. one or more of the following items: .TP \fBarray\fR +. Invoke \fIcommandPrefix\fR whenever the variable is accessed or modified via the \fBarray\fR command, provided that \fIname\fR is not a scalar variable at the time that the \fBarray\fR command is invoked. If @@ -209,12 +215,15 @@ variable at the time that the \fBarray\fR command is invoked. If command will not trigger the trace. .TP \fBread\fR +. Invoke \fIcommandPrefix\fR whenever the variable is read. .TP \fBwrite\fR +. Invoke \fIcommandPrefix\fR whenever the variable is written. .TP \fBunset\fR +. Invoke \fIcommandPrefix\fR whenever the variable is unset. Variables can be unset explicitly with the \fBunset\fR command, or implicitly when procedures return (all of their local variables @@ -229,18 +238,18 @@ When the trace triggers, three arguments are appended to \fIcommandPrefix name1 name2 op\fR .CE .PP -\fIName1\fR and \fIname2\fR give the name(s) for the variable -being accessed: if the variable is a scalar then \fIname1\fR -gives the variable's name and \fIname2\fR is an empty string; -if the variable is an array element then \fIname1\fR gives the -name of the array and name2 gives the index into the array; -if an entire array is being deleted and the trace was registered +\fIName1\fR gives the name for the variable being accessed. +This is not necessarily the same as the name used in the +\fBtrace add variable\fR command: the \fBupvar\fR command allows a +procedure to reference a variable under a different name. +If the trace was originally set on an array or array element, +\fIname2\fR provides which index into the array was affected. +This information is present even when \fIname1\fR refers to a +scalar, which may happen if the \fBupvar\fR command was used to +create a reference to a single array element. +If an entire array is being deleted and the trace was registered on the overall array, rather than a single element, then \fIname1\fR gives the array name and \fIname2\fR is an empty string. -\fIName1\fR and \fIname2\fR are not necessarily the same as the -name used in the \fBtrace add variable\fR command: the \fBupvar\fR -command allows a procedure to reference a variable under a -different name. \fIOp\fR indicates what operation is being performed on the variable, and is one of \fBread\fR, \fBwrite\fR, or \fBunset\fR as defined above. @@ -302,12 +311,15 @@ but will not remove traces on the overall array. This command returns an empty string. .RE .RE +.\" METHOD: remove .TP \fBtrace remove \fItype name opList commandPrefix\fR +. Where \fItype\fR is either \fBcommand\fR, \fBexecution\fR or \fBvariable\fR. .RS .TP \fBtrace remove command\fI name opList commandPrefix\fR +. If there is a trace set on command \fIname\fR with the operations and command given by \fIopList\fR and \fIcommandPrefix\fR, then the trace is removed, so that \fIcommandPrefix\fR will never again be invoked. Returns @@ -315,6 +327,7 @@ an empty string. If \fIname\fR does not exist, the command will throw an error. .TP \fBtrace remove execution\fI name opList commandPrefix\fR +. If there is a trace set on command \fIname\fR with the operations and command given by \fIopList\fR and \fIcommandPrefix\fR, then the trace is removed, so that \fIcommandPrefix\fR will never again be invoked. Returns @@ -322,17 +335,21 @@ an empty string. If \fIname\fR does not exist, the command will throw an error. .TP \fBtrace remove variable\fI name opList commandPrefix\fR +. If there is a trace set on variable \fIname\fR with the operations and command given by \fIopList\fR and \fIcommandPrefix\fR, then the trace is removed, so that \fIcommandPrefix\fR will never again be invoked. Returns an empty string. .RE +.\" METHOD: info .TP \fBtrace info \fItype name\fR +. Where \fItype\fR is either \fBcommand\fR, \fBexecution\fR or \fBvariable\fR. .RS .TP \fBtrace info command\fI name\fR +. Returns a list containing one element for each trace currently set on command \fIname\fR. Each element of the list is itself a list containing two elements, which are the \fIopList\fR and \fIcommandPrefix\fR @@ -341,6 +358,7 @@ then the result of the command will be an empty string. If \fIname\fR does not exist, the command will throw an error. .TP \fBtrace info execution\fI name\fR +. Returns a list containing one element for each trace currently set on command \fIname\fR. Each element of the list is itself a list containing two elements, which are the \fIopList\fR and \fIcommandPrefix\fR @@ -349,6 +367,7 @@ then the result of the command will be an empty string. If \fIname\fR does not exist, the command will throw an error. .TP \fBtrace info variable\fI name\fR +. Returns a list containing one element for each trace currently set on variable \fIname\fR. Each element of the list is itself a list containing two elements, which are the \fIopList\fR and \fIcommandPrefix\fR @@ -356,26 +375,6 @@ associated with the trace. If \fIname\fR does not exist or does not have any traces set, then the result of the command will be an empty string. .RE -.PP -For backwards compatibility, three other subcommands are available: -.RS -.TP -\fBtrace variable \fIname ops command\fR -This is equivalent to \fBtrace add variable \fIname ops command\fR. -.TP -\fBtrace vdelete \fIname ops command\fR -This is equivalent to \fBtrace remove variable \fIname ops command\fR -.TP -\fBtrace vinfo \fIname\fR -This is equivalent to \fBtrace info variable \fIname\fR -.RE -.PP -These subcommands are deprecated and will likely be removed in a -future version of Tcl. They use an older syntax in which \fBarray\fR, -\fBread\fR, \fBwrite\fR, \fBunset\fR are replaced by \fBa\fR, \fBr\fR, -\fBw\fR and \fBu\fR respectively, and the \fIops\fR argument is not a -list, but simply a string concatenation of the operations, such as -\fBrwua\fR. .SH EXAMPLES .PP Print a message whenever either of the global variables \fBfoo\fR and diff --git a/doc/transchan.n b/doc/transchan.n index b9a0f21..a511c75 100644 --- a/doc/transchan.n +++ b/doc/transchan.n @@ -44,6 +44,7 @@ create the transformation. .SS "GENERIC SUBCOMMANDS" .PP The following subcommands are relevant to all types of channel. +.\" METHOD: clear .TP \fIcmdPrefix \fBclear \fIhandle\fR . @@ -51,6 +52,7 @@ This optional subcommand is called to signify to the transformation that any data stored in internal buffers (either incoming or outgoing) must be cleared. It is called when a \fBchan seek\fR is performed on the channel being transformed. +.\" METHOD: finalize .TP \fIcmdPrefix \fBfinalize \fIhandle\fR . @@ -59,6 +61,7 @@ never again, and it exists to allow for cleaning up any Tcl-level data structures associated with the transformation. \fIWarning!\fR Any errors thrown by this subcommand will be ignored. It is not guaranteed to be called if the interpreter is deleted. +.\" METHOD: initialize .TP \fIcmdPrefix \fBinitialize \fIhandle mode\fR . @@ -67,13 +70,9 @@ This mandatory subcommand is called first, and then never again (for the given transformation at the Tcl level. The \fImode\fR is a list containing any of \fBread \fRand \fBwrite\fR. .RS -.TP -\fBwrite\fR -. +.IP \fBwrite\fR implies that the channel is writable. -.TP -\fBread\fR -. +.IP \fBread\fR implies that the channel is readable. .PP The return value of the subcommand should be a list containing the names of @@ -86,6 +85,7 @@ as error thrown by \fBchan push\fR. These subcommands are used for handling transformations applied to readable channels; though strictly \fBread \fRis optional, it must be supported if any of the others is or the channel will be made non-readable. +.\" METHOD: drain .TP \fIcmdPrefix \fBdrain \fIhandle\fR . @@ -100,6 +100,7 @@ In other words, when this method is called the transformation cannot defer the actual transformation operation anymore and has to transform all data waiting in its internal read buffers and return the result of that action. .RE +.\" METHOD: limit? .TP \fIcmdPrefix \fBlimit? \fIhandle\fR . @@ -108,6 +109,7 @@ how far ahead it should read. If present, it should return an integer number greater than zero which indicates how many bytes ahead should be read, or an integer less than zero to indicate that the I/O engine may read as far ahead as it likes. +.\" METHOD: read .TP \fIcmdPrefix \fBread \fIhandle buffer\fR . @@ -131,6 +133,7 @@ defer the actual transformation until it has more data. These subcommands are used for handling transformations applied to writable channels; though strictly \fBwrite\fR is optional, it must be supported if any of the others is or the channel will be made non-writable. +.\" METHOD: flush .TP \fIcmdPrefix \fBflush \fIhandle\fR . @@ -145,6 +148,7 @@ In other words, when this subcommand is called the transformation cannot defer the actual transformation operation anymore and has to transform all data waiting in its internal write buffers and return the result of that action. .RE +.\" METHOD: write .TP \fIcmdPrefix \fBwrite \fIhandle buffer\fR . diff --git a/doc/unload.n b/doc/unload.n index 00b709b..fdc3555 100644 --- a/doc/unload.n +++ b/doc/unload.n @@ -36,16 +36,19 @@ interpreter in which the \fBunload\fR command was invoked. If the initial arguments to \fBunload\fR start with \fB\-\fR then they are treated as switches. The following switches are currently supported: +.\" OPTION: -nocomplain .TP \fB\-nocomplain\fR . Suppresses all error messages. If this switch is given, \fBunload\fR will never report an error. +.\" OPTION: -keeplibrary .TP \fB\-keeplibrary\fR . This switch will prevent \fBunload\fR from issuing the operating system call that will unload the library from the process. +.\" OPTION: -- .TP \fB\-\|\-\fR . @@ -81,10 +84,10 @@ instead of \fIpkg\fB_Unload\fR. If \fBunload\fR determines that a library is not unloadable (or unload functionality has been disabled during compilation), an error will be returned. If the library is unloadable, then \fBunload\fR will call the unload -procedure. If the unload procedure returns \fBTCL_OK\fR, \fBunload\fR will proceed -and decrease the proper reference count (depending on the target interpreter -type). When both reference counts have reached 0, the library will be -detached from the process. +procedure. If the unload procedure returns \fBTCL_OK\fR, \fBunload\fR will +proceed and decrease the proper reference count (depending on the target +interpreter type). When both reference counts have reached 0, the library will +be detached from the process. .SS "UNLOAD HOOK PROTOTYPE" .PP The unload procedure must match the following prototype: @@ -123,14 +126,14 @@ different platforms. The default guess, which is used on most UNIX platforms, is to take the last element of \fIfileName\fR, strip off the first three characters if they are \fBlib\fR, then strip off the next three characters if they -are \fBtcl\fR, and use any following alphabetic and -underline characters, converted to titlecase as the prefix. +are \fBtcl9\fR, and use any following wordchars but not digits, +converted to titlecase as the prefix. For example, the command \fBunload libxyz4.2.so\fR uses the prefix \fBXyz\fR and the command \fBunload bin/last.so {}\fR uses the prefix \fBLast\fR. .SH "PORTABILITY ISSUES" .TP -\fBUnix\fR\0\0\0\0\0 +\fBUnix\fR . Not all unix operating systems support library unloading. Under such an operating system \fBunload\fR returns an error (unless \fB\-nocomplain\fR diff --git a/doc/uplevel.n b/doc/uplevel.n index cda1652..8687416 100644 --- a/doc/uplevel.n +++ b/doc/uplevel.n @@ -26,7 +26,8 @@ it gives a distance (up the procedure calling stack) to move before executing the command. If \fIlevel\fR consists of \fB#\fR followed by a integer then the level gives an absolute level. If \fIlevel\fR is omitted then it defaults to \fB1\fR. \fILevel\fR cannot be -defaulted if the first \fIcommand\fR argument is an integer or starts with \fB#\fR. +defaulted if the first \fIcommand\fR argument is an integer or starts +with \fB#\fR. .PP For example, suppose that procedure \fBa\fR was invoked from top-level, and that it called \fBb\fR, and that \fBb\fR called \fBc\fR. diff --git a/doc/upvar.n b/doc/upvar.n index 5d697dd..6543be8 100644 --- a/doc/upvar.n +++ b/doc/upvar.n @@ -14,7 +14,6 @@ upvar \- Create link to variable in a different stack frame .SH SYNOPSIS \fBupvar \fR?\fIlevel\fR? \fIotherVar myVar \fR?\fIotherVar myVar \fR...? .BE - .SH DESCRIPTION .PP This command arranges for one or more local variables in the current @@ -98,11 +97,9 @@ trace add variable originalVar write \fItraceproc\fR \fIsetByUpvar\fR originalVar 2 .CE .PP -If \fIotherVar\fR refers to an element of an array, then variable -traces set for the entire array will not be invoked when \fImyVar\fR -is accessed (but traces on the particular element will still be -invoked). In particular, if the array is \fBenv\fR, then changes -made to \fImyVar\fR will not be passed to subprocesses correctly. +If \fIotherVar\fR refers to an element of an array, then the element +name is passed as the second argument to the trace procedure. This +may be important information in case of traces set on an entire array. .SH EXAMPLE A \fBdecr\fR command that works like \fBincr\fR except it subtracts the value from the variable instead of adding it: diff --git a/doc/vwait.n b/doc/vwait.n index e595a74..1ff6caa 100644 --- a/doc/vwait.n +++ b/doc/vwait.n @@ -11,7 +11,7 @@ .SH NAME vwait \- Process events until a variable is written .SH SYNOPSIS -\fBvwait\fR \fIvarName\fR +\fBvwait\fI varName\fR .sp \fBvwait\fR ?\fIoptions\fR? ?\fIvarName ...\fR? .BE @@ -28,64 +28,75 @@ namespace's variables if the fully-qualified name is given. .PP In the second more complex command form \fIoptions\fR allow for finer control of the wait operation and to deal with multiple event sources. -\fIOptions\fR can be made up of +\fIOptions\fR can be made up of: +.\" OPTION: -- .TP \fB\-\-\fR . Marks the end of options. All following arguments are handled as variable names. +.\" OPTION: -all .TP \fB\-all\fR . All conditions for the wait operation must be met to complete the wait operation. Otherwise (the default) the first event completes the wait. +.\" OPTION: -extended .TP \fB\-extended\fR . An extended result in list form is returned, see below for explanation. +.\" OPTION: -nofileevents .TP \fB\-nofileevents\fR . File events are not handled in the wait operation. +.\" OPTION: -noidleevents .TP \fB\-noidleevents\fR . Idle handlers are not invoked during the wait operation. +.\" OPTION: -notimerevents .TP \fB\-notimerevents\fR . Timer handlers are not serviced during the wait operation. +.\" OPTION: -nowindowevents .TP \fB\-nowindowevents\fR . Events of the windowing system are not handled during the wait operation. +.\" OPTION: -readable .TP -\fB\-readable\fR \fIchannel\fR +\fB\-readable\fI channel\fR . \fIChannel\fR must name a Tcl channel open for reading. If \fIchannel\fR is or becomes readable the wait operation completes. +.\" OPTION: -timeout .TP -\fB\-timeout\fR \fImilliseconds\fR +\fB\-timeout\fI milliseconds\fR . The wait operation is constrained to \fImilliseconds\fR. +.\" OPTION: -variable .TP -\fB\-variable\fR \fIvarName\fR +\fB\-variable\fI varName\fR . \fIVarName\fR must be the name of a global variable. Writing or unsetting this variable completes the wait operation. +.\" OPTION: -writable .TP -\fB\-writable\fR \fIchannel\fR +\fB\-writable\fI channel\fR . \fIChannel\fR must name a Tcl channel open for writing. If \fIchannel\fR is or becomes writable the wait operation completes. .PP The result returned by \fBvwait\fR is for the simple form an empty -string. If the \fI\-timeout\fR option is specified, the result is the +string. If the \fB\-timeout\fR option is specified, the result is the number of milliseconds remaining when the wait condition has been met, or -1 if the wait operation timed out. .PP -If the \fI\-extended\fR option is specified, the result is made up +If the \fB\-extended\fR option is specified, the result is made up of a Tcl list with an even number of elements. Odd elements take the values \fBreadable\fR, \fBtimeleft\fR, \fBvariable\fR, and \fBwritable\fR. Even elements are the corresponding variable diff --git a/doc/while.n b/doc/while.n index 6acc909..bacc782 100644 --- a/doc/while.n +++ b/doc/while.n @@ -30,7 +30,7 @@ commands may be executed inside \fIbody\fR to cause immediate termination of the \fBwhile\fR command. The \fBwhile\fR command always returns an empty string. .PP -Note: \fItest\fR should almost always be enclosed in braces. If not, +Note that \fItest\fR should almost always be enclosed in braces. If not, variable substitutions will be made before the \fBwhile\fR command starts executing, which means that variable changes made by the loop body will not be considered in the expression. diff --git a/doc/zipfs.3 b/doc/zipfs.3 index 571647f..c15ba02 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -14,7 +14,7 @@ TclZipfs_AppHook, TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount \- hand .SH SYNOPSIS .nf const char * -\fBTclZipfs_AppHook(\fIargcPtr, argvPtr\fR) +\fBTclZipfs_AppHook\fR(\fIargcPtr, argvPtr\fR) .sp int \fBTclZipfs_Mount\fR(\fIinterp, zipname, mountpoint, password\fR) @@ -83,10 +83,10 @@ example, the Tcl 8.7.2 release would be searched for in a file On Windows, \fBTclZipfs_AppHook\fR has a slightly different signature, since it uses WCHAR instead of char. As a result, it requires your application to be compiled with the UNICODE preprocessor symbol defined (e.g., via the -\fB-DUNICODE\fR compiler flag). +\fB\-DUNICODE\fR compiler flag). .PP The result of \fBTclZipfs_AppHook\fR is the full Tcl version with build -information (e.g., \fB8.7.0+abcdef...abcdef.gcc-1002\fR). +information (e.g., \fB9.0.0+abcdef...abcdef.gcc-1002\fR). The function \fImay\fR modify the variables pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the current implementation does not do so, but callers \fIshould not\fR assume that this will be true in the future. diff --git a/doc/zipfs.n b/doc/zipfs.n index 0a05078..d4f97a8 100644 --- a/doc/zipfs.n +++ b/doc/zipfs.n @@ -15,20 +15,20 @@ zipfs \- Mount and work with ZIP files within Tcl .SH SYNOPSIS .nf \fBpackage require tcl::zipfs \fR?\fB1.0\fR? -.sp -\fBzipfs canonical\fR ?\fImntpnt\fR? \fIfilename\fR ?\fIZIPFS\fR? -\fBzipfs exists\fR \fIfilename\fR -\fBzipfs find\fR \fIdirectoryName\fR -\fBzipfs info\fR \fIfilename\fR + +\fBzipfs canonical\fR ?\fImountpoint\fR? \fIfilename\fR ?\fIZIPFS\fR? +\fBzipfs exists\fI filename\fR +\fBzipfs find\fI directoryName\fR +\fBzipfs info\fI filename\fR \fBzipfs list\fR ?(\fB\-glob\fR|\fB\-regexp\fR)? ?\fIpattern\fR? -\fBzipfs lmkimg\fR \fIoutfile inlist\fR ?\fIpassword infile\fR? -\fBzipfs lmkzip\fR \fIoutfile inlist\fR ?\fIpassword\fR? -\fBzipfs mkimg\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? ?\fIinfile\fR? -\fBzipfs mkkey\fR \fIpassword\fR -\fBzipfs mkzip\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? +\fBzipfs lmkimg\fI outfile inlist\fR ?\fIpassword infile\fR? +\fBzipfs lmkzip\fI outfile inlist\fR ?\fIpassword\fR? +\fBzipfs mkimg\fI outfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? ?\fIinfile\fR? +\fBzipfs mkkey\fI password\fR +\fBzipfs mkzip\fI outfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? \fBzipfs mount\fR ?\fIzipfile\fR? ?\fImountpoint\fR? ?\fIpassword\fR? \fBzipfs root\fR -\fBzipfs unmount\fR \fImountpoint\fR +\fBzipfs unmount\fI mountpoint\fR .fi '\" The following subcommand is *UNDOCUMENTED* '\" \fBzipfs mount_data\fR ?\fIdata\fR ?\fImountpoint\fR?? @@ -49,6 +49,7 @@ 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. +.\" METHOD: canonical .TP \fBzipfs canonical\fR ?\fImountpoint\fR? \fIfilename\fR ?\fIinZipfs\fR? . @@ -57,19 +58,22 @@ mapped into a zipfs mount as its result. If specified, \fImountpoint\fR says within which mount the mapping will be done; if omitted, the main root of the zipfs system is used. The \fIinZipfs\fR argument is a an optional boolean which controls whether to fully canonicalise the name; it defaults to true. +.\" METHOD: exists .TP -\fBzipfs exists\fR \fIfilename\fR +\fBzipfs exists\fI filename\fR . Return 1 if the given filename exists in the mounted zipfs and 0 if it does not. +.\" METHOD: find .TP -\fBzipfs find\fR \fIdirectoryName\fR +\fBzipfs find\fI directoryName\fR . Returns the list of paths under directory \fIdirectoryName\fR which need not be within a zipfs mounted archive. The paths are prefixed with \fIdirectoryName\fR. This command is also used by the \fBzipfs mkzip\fR and \fBzipfs mkimg\fR commands. +.\" METHOD: info .TP -\fBzipfs info\fR \fIfile\fR +\fBzipfs info\fI file\fR . Return information about the given \fIfile\fR in the mounted zipfs. The information consists of: @@ -83,30 +87,32 @@ the compressed size of the file, and .IP (4) the offset of the compressed data in the ZIP archive file. .PP -As a special case, querying the mount point gives the start of the zip data as the offset -in (4), which can be used to truncate the zip information from an executable. -Querying an ancestor of a mount point will raise an error. +As a special case, querying the mount point gives the start of the zip data +as the offset in (4), which can be used to truncate the zip information from +an executable. Querying an ancestor of a mount point will raise an error. .RE +.\" METHOD: list .TP \fBzipfs list\fR ?(\fB\-glob\fR|\fB\-regexp\fR)? ?\fIpattern\fR? . If \fIpattern\fR is not specified, the command returns a list of files across all zipfs mounted archives. If \fIpattern\fR is specified, only those paths -matching the pattern are returned. By default, or with the \fB-glob\fR option, +matching the pattern are returned. By default, or with the \fB\-glob\fR option, the pattern is treated as a glob pattern and matching is done as described for -the \fBstring match\fR command. Alternatively, the \fB-regexp\fR option may be +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. The returned paths only include those actually in the archive and does not include intermediate directories in mount paths. +.\" METHOD: mount .TP \fBzipfs mount\fR .TP -\fBzipfs mount\fR \fImountpoint\fR +\fBzipfs mount\fI mountpoint\fR .TP -\fBzipfs mount\fR \fIzipfile\fR \fImountpoint\fR ?\fIpassword\fR? +\fBzipfs mount\fI zipfile mountpoint\fR ?\fIpassword\fR? .RS .PP The \fBzipfs mount\fR command mounts ZIP archives as Tcl virtual file systems @@ -118,10 +124,10 @@ mount points to the path of the corresponding ZIP archive. In the single argument form, the command returns the file path of the ZIP archive mounted at the specified mount point. .PP -In the third form, the command mounts the ZIP archive \fIzipfile\fR as a Tcl virtual -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 +In the third form, the command mounts the ZIP archive \fIzipfile\fR as a Tcl +virtual 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 \fB[zipfs root]\fR. The command returns the normalized mount point path. .PP @@ -137,6 +143,7 @@ uses direct access to the OS rather than through Tcl's filesystem API, it will not see the current directory as being inside the mount and will not be able to access the files inside the mount). .RE +.\" METHOD: root .TP \fBzipfs root\fR . @@ -145,6 +152,7 @@ for the current platform. This value is .QW \fB//zipfs:/\fR on most platforms. +.\" METHOD: unmount .TP \fBzipfs unmount \fImountpoint\fR . @@ -154,8 +162,9 @@ 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 archives as Tcl applications. +.\" METHOD: mkzip .TP -\fBzipfs mkzip\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? +\fBzipfs mkzip\fI outfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? . Creates a ZIP archive file named \fIoutfile\fR from the contents of the input directory \fIindir\fR (contained regular files only) with optional ZIP @@ -168,8 +177,9 @@ the whole source directory name or the name of its parent directory. \fBCaution:\fR the choice of the \fIindir\fR parameter (less the optional stripped prefix) determines the later root name of the archive's content. .RE +.\" METHOD: mkimg .TP -\fBzipfs mkimg\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? ?\fIinfile\fR? +\fBzipfs mkimg\fI outfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? ?\fIinfile\fR? . Creates an image (potentially a new executable file) similar to \fBzipfs mkzip\fR; see that command for a description of most parameters to this @@ -196,20 +206,23 @@ that script has been executed. \fBCaution:\fR highly experimental, not usable on Android, only partially tested on Linux and Windows. .RE +.\" METHOD: mkkey .TP -\fBzipfs mkkey\fR \fIpassword\fR +\fBzipfs mkkey\fI password\fR . Given the clear text \fIpassword\fR argument, an obfuscated string version is returned with the same format used in the \fBzipfs mkimg\fR command. +.\" METHOD: lmkimg .TP -\fBzipfs lmkimg\fR \fIoutfile inlist\fR ?\fIpassword infile\fR? +\fBzipfs lmkimg\fI outfile inlist\fR ?\fIpassword infile\fR? . This command is like \fBzipfs mkimg\fR, but instead of an input directory, \fIinlist\fR must be a Tcl list where the odd elements are the names of files to be copied into the archive in the image, and the even elements are their respective names within that archive. +.\" METHOD: lmkzip .TP -\fBzipfs lmkzip\fR \fIoutfile inlist\fR ?\fIpassword\fR? +\fBzipfs lmkzip\fI outfile inlist\fR ?\fIpassword\fR? . This command is like \fBzipfs mkzip\fR, but instead of an input directory, \fIinlist\fR must be a Tcl list where the odd elements are the names of files @@ -21,24 +21,28 @@ The \fBzlib\fR command provides access to the compression and check-summing facilities of the Zlib library by Jean-loup Gailly and Mark Adler. It has the following subcommands. .SS "COMPRESSION SUBCOMMANDS" +.\" METHOD: compress .TP \fBzlib compress\fI string\fR ?\fIlevel\fR? . Returns the zlib-format compressed binary data of the binary string in \fIstring\fR. If present, \fIlevel\fR gives the compression level to use (from 0, which is uncompressed, to 9, maximally compressed). +.\" METHOD: decompress .TP \fBzlib decompress\fI string\fR ?\fIbufferSize\fR? . Returns the uncompressed version of the raw compressed binary data in \fIstring\fR. If present, \fIbufferSize\fR is a hint as to what size of buffer is to be used to receive the data. +.\" METHOD: deflate .TP \fBzlib deflate\fI string\fR ?\fIlevel\fR? . Returns the raw compressed binary data of the binary string in \fIstring\fR. If present, \fIlevel\fR gives the compression level to use (from 0, which is uncompressed, to 9, maximally compressed). +.\" METHOD: gunzip .TP \fBzlib gunzip\fI string\fR ?\fB\-headerVar \fIvarName\fR? . @@ -47,39 +51,26 @@ have been in gzip format. If \fB\-headerVar\fR is given, store a dictionary describing the contents of the gzip header in the variable called \fIvarName\fR. The keys of the dictionary that may be present are: .RS -.TP -\fBcomment\fR -. +.IP \fBcomment\fR The comment field from the header, if present. -.TP -\fBcrc\fR -. +.IP \fBcrc\fR A boolean value describing whether a CRC of the header is computed. -.TP -\fBfilename\fR -. +.IP \fBfilename\fR The filename field from the header, if present. -.TP -\fBos\fR -. +.IP \fBos\fR The operating system type code field from the header (if not the QW unknown value). See RFC 1952 for the meaning of these codes. -.TP -\fBsize\fR -. +.IP \fBsize\fR The size of the uncompressed data. -.TP -\fBtime\fR -. +.IP \fBtime\fR The time field from the header if non-zero, expected to be time that the file named by the \fBfilename\fR field was modified. Suitable for use with \fBclock format\fR. -.TP -\fBtype\fR -. +.IP \fBtype\fR The type of the uncompressed data (\fBbinary\fR or \fBtext\fR) if known. .RE +.\" METHOD: gzip .TP \fBzlib gzip\fI string\fR ?\fB\-level \fIlevel\fR? ?\fB\-header \fIdict\fR? . @@ -89,35 +80,24 @@ If \fB\-level\fR is given, \fIlevel\fR gives the compression level to use is given, \fIdict\fR is a dictionary containing values used for the gzip header. The following keys may be defined: .RS -.TP -\fBcomment\fR -. +.IP \fBcomment\fR Add the given comment to the header of the gzip-format data. -.TP -\fBcrc\fR -. +.IP \fBcrc\fR A boolean saying whether to compute a CRC of the header. Note that if the data is to be interchanged with the \fBgzip\fR program, a header CRC should \fInot\fR be computed. -.TP -\fBfilename\fR -. +.IP \fBfilename\fR The name of the file that the data to be compressed came from. -.TP -\fBos\fR -. +.IP \fBos\fR The operating system type code, which should be one of the values described in RFC 1952. -.TP -\fBtime\fR -. +.IP \fBtime\fR The time that the file named in the \fBfilename\fR key was last modified. This will be in the same as is returned by \fBclock seconds\fR or \fBfile mtime\fR. -.TP -\fBtype\fR -. +.IP \fBtype\fR The type of the data being compressed, being \fBbinary\fR or \fBtext\fR. .RE +.\" METHOD: inflate .TP \fBzlib inflate\fI string\fR ?\fIbufferSize\fR? . @@ -125,6 +105,7 @@ Returns the uncompressed version of the raw compressed binary data in \fIstring\fR. If present, \fIbufferSize\fR is a hint as to what size of buffer is to be used to receive the data. .SS "CHANNEL SUBCOMMAND" +.\" METHOD: push .TP \fBzlib push\fI mode channel\fR ?\fIoptions ...\fR? . @@ -134,34 +115,22 @@ The transformation can be removed again with \fBchan pop\fR. The \fImode\fR argument determines what type of transformation is pushed; the following are supported: .RS -.TP -\fBcompress\fR -. +.IP \fBcompress\fR The transformation will be a compressing transformation that produces zlib-format data on \fIchannel\fR, which must be writable. -.TP -\fBdecompress\fR -. +.IP \fBdecompress\fR The transformation will be a decompressing transformation that reads zlib-format data from \fIchannel\fR, which must be readable. -.TP -\fBdeflate\fR -. +.IP \fBdeflate\fR The transformation will be a compressing transformation that produces raw compressed data on \fIchannel\fR, which must be writable. -.TP -\fBgunzip\fR -. +.IP \fBgunzip\fR The transformation will be a decompressing transformation that reads gzip-format data from \fIchannel\fR, which must be readable. -.TP -\fBgzip\fR -. +.IP \fBgzip\fR The transformation will be a compressing transformation that produces gzip-format data on \fIchannel\fR, which must be writable. -.TP -\fBinflate\fR -. +.IP \fBinflate\fR The transformation will be a decompressing transformation that reads raw compressed data from \fIchannel\fR, which must be readable. .PP @@ -169,6 +138,7 @@ The following options may be set when creating a transformation via the .QW "\fIoptions ...\fR" to the \fBzlib push\fR command: +.\" OPTION: -dictionary .TP \fB\-dictionary\fI binData\fR .VS "TIP 400" @@ -180,16 +150,19 @@ with the most commonly used strings preferably put towards the end of the dictionary. Tcl provides no mechanism for choosing a good such dictionary for a particular data sequence. .VE +.\" OPTION: -header .TP \fB\-header\fI dictionary\fR . Passes a description of the gzip header to create, in the same format that \fBzlib gzip\fR understands. +.\" OPTION: -level .TP \fB\-level\fI compressionLevel\fR . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). +.\" OPTION: -limit .TP \fB\-limit\fI readaheadLimit\fR . @@ -209,6 +182,7 @@ to further readers. Both compressing and decompressing channel transformations add extra configuration options that may be accessed through \fBchan configure\fR. The options are: +.\" OPTION: -checksum .TP \fB\-checksum\fI checksum\fR . @@ -216,6 +190,7 @@ This read-only option gets the current checksum for the uncompressed data that the compression engine has seen so far. It is valid for both compressing and decompressing transforms, but not for the raw inflate and deflate formats. The compression algorithm depends on what format is being produced or consumed. +.\" OPTION: -dictionary .TP \fB\-dictionary\fI binData\fR .VS "TIP 400" @@ -227,6 +202,7 @@ the transformation is stacked. Note that this cannot be used to get the current active compression dictionary mid-stream, as that information is not exposed by the underlying library. .VE +.\" OPTION: -flush .TP \fB\-flush\fI type\fR . @@ -236,12 +212,14 @@ underlying channel. It is only valid for compressing transformations. The expensive flush respectively. Flushing degrades the compression ratio, but makes it easier for a decompressor to recover more of the file in the case of data corruption. +.\" OPTION: -header .TP \fB\-header\fI dictionary\fR . This read-only option, only valid for decompressing transforms that are processing gzip-format data, returns the dictionary describing the header read off the data stream. +.\" OPTION: -limit .TP \fB\-limit\fI readaheadLimit\fR . @@ -250,6 +228,7 @@ maximum number of bytes ahead to read from the underlying data source. See above for more information. .RE .SS "STREAMING SUBCOMMAND" +.\" METHOD: stream .TP \fBzlib stream\fI mode\fR ?\fIoptions\fR? . @@ -311,11 +290,13 @@ is correct. .VE .RE .SS "CHECKSUMMING SUBCOMMANDS" +.\" METHOD: adler32 .TP \fBzlib adler32\fI string\fR ?\fIinitValue\fR? . Compute a checksum of binary string \fIstring\fR using the Adler-32 algorithm. If given, \fIinitValue\fR is used to initialize the checksum engine. +.\" METHOD: crc32 .TP \fBzlib crc32\fI string\fR ?\fIinitValue\fR? . @@ -330,6 +311,7 @@ the transformed data. .PP The full set of subcommands supported by a streaming instance command, \fIstream\fR, is as follows: +.\" METHOD: add .TP \fIstream \fBadd\fR ?\fIoption...\fR? \fIdata\fR . @@ -337,47 +319,56 @@ A short-cut for .QW "\fIstream \fBput \fR?\fIoption...\fR? \fIdata\fR" followed by .QW "\fIstream \fBget\fR" . +.\" METHOD: checksum .TP \fIstream \fBchecksum\fR . Returns the checksum of the uncompressed data seen so far by this stream. +.\" METHOD: close .TP \fIstream \fBclose\fR . Deletes this stream and frees up all resources associated with it. +.\" METHOD: eof .TP \fIstream \fBeof\fR . Returns a boolean indicating whether the end of the stream (as determined by the compressed data itself) has been reached. Not all formats support detection of the end of the stream. +.\" METHOD: finalize .TP \fIstream \fBfinalize\fR . A short-cut for .QW "\fIstream \fBput \-finalize {}\fR" . +.\" METHOD: flush .TP \fIstream \fBflush\fR . A short-cut for .QW "\fIstream \fBput \-flush {}\fR" . +.\" METHOD: fullflush .TP \fIstream \fBfullflush\fR . A short-cut for .QW "\fIstream \fBput \-fullflush {}\fR" . +.\" METHOD: get .TP \fIstream \fBget \fR?\fIcount\fR? . Return up to \fIcount\fR bytes from \fIstream\fR's internal buffers with the transformation applied. If \fIcount\fR is omitted, the entire contents of the buffers are returned. -. +.\" METHOD: header +.TP \fIstream \fBheader\fR . Return the gzip header description dictionary extracted from the stream. Only supported for streams created with their \fImode\fR parameter set to \fBgunzip\fR. +.\" METHOD: put .TP \fIstream \fBput\fR ?\fIoption...\fR? \fIdata\fR . @@ -386,12 +377,14 @@ buffers while applying the transformation. The following \fIoption\fRs are supported (or an unambiguous prefix of them), which are used to modify the way in which the transformation is applied: .RS +.\" OPTION: -dictionary .TP \fB\-dictionary\fI binData\fR .VS "TIP 400" Sets the compression dictionary to use when working with compressing or decompressing the data to be \fIbinData\fR. .VE +.\" OPTION: -finalize .TP \fB\-finalize\fR . @@ -405,6 +398,7 @@ of the stream with the \fBget\fR subcommand. This option is mutually exclusive with the \fB\-flush\fR and \fB\-fullflush\fR options. .RE +.\" OPTION: -flush .TP \fB\-flush\fR . @@ -416,6 +410,7 @@ compressed so far, at some performance penalty. This option is mutually exclusive with the \fB\-finalize\fR and \fB\-fullflush\fR options. .RE +.\" OPTION: -fullflush .TP \fB\-fullflush\fR . @@ -429,6 +424,7 @@ This option is mutually exclusive with the \fB\-finalize\fR and \fB\-flush\fR options. .RE .RE +.\" METHOD: reset .TP \fIstream \fBreset\fR . diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c index 3b4f1e4..dc699cf 100644 --- a/generic/regc_cvec.c +++ b/generic/regc_cvec.c @@ -36,14 +36,14 @@ /* - newcvec - allocate a new cvec - ^ static struct cvec *newcvec(int, int); + ^ static struct cvec *newcvec(size_t, size_t); */ static struct cvec * newcvec( - int nchrs, /* to hold this many chrs... */ - int nranges) /* ... and this many ranges... */ + size_t nchrs, /* to hold this many chrs... */ + size_t nranges) /* ... and this many ranges... */ { - size_t nc = (size_t)nchrs + (size_t)nranges*2; + size_t nc = nchrs + nranges*2; size_t n = sizeof(struct cvec) + nc*sizeof(chr); struct cvec *cv = (struct cvec *) MALLOC(n); @@ -108,8 +108,8 @@ addrange( static struct cvec * getcvec( struct vars *v, /* context */ - int nchrs, /* to hold this many chrs... */ - int nranges) /* ... and this many ranges... */ + size_t nchrs, /* to hold this many chrs... */ + size_t nranges) /* ... and this many ranges... */ { if ((v->cv != NULL) && (nchrs <= v->cv->chrspace) && (nranges <= v->cv->rangespace)) { diff --git a/generic/regc_lex.c b/generic/regc_lex.c index 28ae821..bf936ca 100644 --- a/generic/regc_lex.c +++ b/generic/regc_lex.c @@ -889,7 +889,7 @@ lexescape( * Ugly heuristic (first test is "exactly 1 digit?") */ - if (v->now - save == 0 || ((int) c > 0 && (int)c <= v->nsubexp)) { + if (v->now - save == 0 || ((int) c > 0 && (size_t)c <= v->nsubexp)) { NOTE(REG_UBACKREF); RETV(BACKREF, (chr)c); } diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 9a984f5..c5ba880 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -110,7 +110,7 @@ static const struct cname { {"right-brace", '}'}, {"right-curly-bracket", '}'}, {"tilde", '~'}, - {"DEL", '\177'}, + {"DEL", '\x7F'}, {NULL, 0} }; @@ -825,8 +825,6 @@ static const chr graphCharTable[] = { /* * End of auto-generated Unicode character ranges declarations. */ - -#define CH NOCELT /* - element - map collating-element name to celt @@ -919,9 +917,9 @@ range( for (c=a; c<=b; c++) { addchr(cv, c); - lc = Tcl_UniCharToLower((chr)c); - uc = Tcl_UniCharToUpper((chr)c); - tc = Tcl_UniCharToTitle((chr)c); + lc = Tcl_UniCharToLower(c); + uc = Tcl_UniCharToUpper(c); + tc = Tcl_UniCharToTitle(c); if (c != lc) { addchr(cv, lc); } @@ -970,11 +968,11 @@ eclass( if ((v->cflags®_FAKE) && c == 'x') { cv = getcvec(v, 4, 0); - addchr(cv, (chr)'x'); - addchr(cv, (chr)'y'); + addchr(cv, 'x'); + addchr(cv, 'y'); if (cases) { - addchr(cv, (chr)'X'); - addchr(cv, (chr)'Y'); + addchr(cv, 'X'); + addchr(cv, 'Y'); } return cv; } @@ -988,7 +986,7 @@ eclass( } cv = getcvec(v, 1, 0); assert(cv != NULL); - addchr(cv, (chr)c); + addchr(cv, c); return cv; } @@ -1004,12 +1002,11 @@ cclass( const chr *endp, /* just past the end of the name */ int cases) /* case-independent? */ { - size_t len; + size_t i, len; struct cvec *cv = NULL; Tcl_DString ds; const char *np; const char *const *namePtr; - int i, index; /* * The following arrays define the valid character class names. @@ -1021,9 +1018,10 @@ cclass( }; enum classes { + CC_NULL = -1, CC_ALNUM, CC_ALPHA, CC_ASCII, CC_BLANK, CC_CNTRL, CC_DIGIT, CC_GRAPH, CC_LOWER, CC_PRINT, CC_PUNCT, CC_SPACE, CC_UPPER, CC_XDIGIT - }; + } index; /* @@ -1032,24 +1030,20 @@ cclass( len = endp - startp; Tcl_DStringInit(&ds); - np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); + np = Tcl_UniCharToUtfDString(startp, len, &ds); /* * Map the name to the corresponding enumerated value. */ - index = -1; + index = CC_NULL; for (namePtr=classNames,i=0 ; *namePtr!=NULL ; namePtr++,i++) { if ((strlen(*namePtr) == len) && (strncmp(*namePtr, np, len) == 0)) { - index = i; + index = (enum classes)i; break; } } Tcl_DStringFree(&ds); - if (index == -1) { - ERR(REG_ECTYPE); - return NULL; - } /* * Remap lower and upper to alpha if the match is case insensitive. @@ -1063,18 +1057,21 @@ cclass( * Now compute the character class contents. */ - switch((enum classes) index) { + switch (index) { + case CC_NULL: + ERR(REG_ECTYPE); + return NULL; case CC_ALNUM: cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE); if (cv) { - for (i=0 ; (size_t)i<NUM_ALPHA_CHAR ; i++) { + for (i=0 ; i<NUM_ALPHA_CHAR ; i++) { addchr(cv, alphaCharTable[i]); } - for (i=0 ; (size_t)i<NUM_ALPHA_RANGE ; i++) { + for (i=0 ; i<NUM_ALPHA_RANGE ; i++) { addrange(cv, alphaRangeTable[i].start, alphaRangeTable[i].end); } - for (i=0 ; (size_t)i<NUM_DIGIT_RANGE ; i++) { + for (i=0 ; i<NUM_DIGIT_RANGE ; i++) { addrange(cv, digitRangeTable[i].start, digitRangeTable[i].end); } @@ -1083,11 +1080,11 @@ cclass( case CC_ALPHA: cv = getcvec(v, NUM_ALPHA_CHAR, NUM_ALPHA_RANGE); if (cv) { - for (i=0 ; (size_t)i<NUM_ALPHA_RANGE ; i++) { + for (i=0 ; i<NUM_ALPHA_RANGE ; i++) { addrange(cv, alphaRangeTable[i].start, alphaRangeTable[i].end); } - for (i=0 ; (size_t)i<NUM_ALPHA_CHAR ; i++) { + for (i=0 ; i<NUM_ALPHA_CHAR ; i++) { addchr(cv, alphaCharTable[i]); } } @@ -1106,11 +1103,11 @@ cclass( case CC_CNTRL: cv = getcvec(v, NUM_CONTROL_CHAR, NUM_CONTROL_RANGE); if (cv) { - for (i=0 ; (size_t)i<NUM_CONTROL_RANGE ; i++) { + for (i=0 ; i<NUM_CONTROL_RANGE ; i++) { addrange(cv, controlRangeTable[i].start, controlRangeTable[i].end); } - for (i=0 ; (size_t)i<NUM_CONTROL_CHAR ; i++) { + for (i=0 ; i<NUM_CONTROL_CHAR ; i++) { addchr(cv, controlCharTable[i]); } } @@ -1118,7 +1115,7 @@ cclass( case CC_DIGIT: cv = getcvec(v, 0, NUM_DIGIT_RANGE); if (cv) { - for (i=0 ; (size_t)i<NUM_DIGIT_RANGE ; i++) { + for (i=0 ; i<NUM_DIGIT_RANGE ; i++) { addrange(cv, digitRangeTable[i].start, digitRangeTable[i].end); } @@ -1127,11 +1124,11 @@ cclass( case CC_PUNCT: cv = getcvec(v, NUM_PUNCT_CHAR, NUM_PUNCT_RANGE); if (cv) { - for (i=0 ; (size_t)i<NUM_PUNCT_RANGE ; i++) { + for (i=0 ; i<NUM_PUNCT_RANGE ; i++) { addrange(cv, punctRangeTable[i].start, punctRangeTable[i].end); } - for (i=0 ; (size_t)i<NUM_PUNCT_CHAR ; i++) { + for (i=0 ; i<NUM_PUNCT_CHAR ; i++) { addchr(cv, punctCharTable[i]); } } @@ -1156,11 +1153,11 @@ cclass( case CC_SPACE: cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE); if (cv) { - for (i=0 ; (size_t)i<NUM_SPACE_RANGE ; i++) { + for (i=0 ; i<NUM_SPACE_RANGE ; i++) { addrange(cv, spaceRangeTable[i].start, spaceRangeTable[i].end); } - for (i=0 ; (size_t)i<NUM_SPACE_CHAR ; i++) { + for (i=0 ; i<NUM_SPACE_CHAR ; i++) { addchr(cv, spaceCharTable[i]); } } @@ -1168,11 +1165,11 @@ cclass( case CC_LOWER: cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE); if (cv) { - for (i=0 ; (size_t)i<NUM_LOWER_RANGE ; i++) { + for (i=0 ; i<NUM_LOWER_RANGE ; i++) { addrange(cv, lowerRangeTable[i].start, lowerRangeTable[i].end); } - for (i=0 ; (size_t)i<NUM_LOWER_CHAR ; i++) { + for (i=0 ; i<NUM_LOWER_CHAR ; i++) { addchr(cv, lowerCharTable[i]); } } @@ -1180,11 +1177,11 @@ cclass( case CC_UPPER: cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE); if (cv) { - for (i=0 ; (size_t)i<NUM_UPPER_RANGE ; i++) { + for (i=0 ; i<NUM_UPPER_RANGE ; i++) { addrange(cv, upperRangeTable[i].start, upperRangeTable[i].end); } - for (i=0 ; (size_t)i<NUM_UPPER_CHAR ; i++) { + for (i=0 ; i<NUM_UPPER_CHAR ; i++) { addchr(cv, upperCharTable[i]); } } @@ -1192,18 +1189,18 @@ cclass( case CC_PRINT: cv = getcvec(v, NUM_SPACE_CHAR + NUM_GRAPH_CHAR, NUM_SPACE_RANGE + NUM_GRAPH_RANGE - 1); if (cv) { - for (i=1 ; (size_t)i<NUM_SPACE_RANGE ; i++) { + for (i=1 ; i<NUM_SPACE_RANGE ; i++) { addrange(cv, spaceRangeTable[i].start, spaceRangeTable[i].end); } - for (i=0 ; (size_t)i<NUM_SPACE_CHAR ; i++) { + for (i=0 ; i<NUM_SPACE_CHAR ; i++) { addchr(cv, spaceCharTable[i]); } - for (i=0 ; (size_t)i<NUM_GRAPH_RANGE ; i++) { + for (i=0 ; i<NUM_GRAPH_RANGE ; i++) { addrange(cv, graphRangeTable[i].start, graphRangeTable[i].end); } - for (i=0 ; (size_t)i<NUM_GRAPH_CHAR ; i++) { + for (i=0 ; i<NUM_GRAPH_CHAR ; i++) { addchr(cv, graphCharTable[i]); } } @@ -1211,11 +1208,11 @@ cclass( case CC_GRAPH: cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE); if (cv) { - for (i=0 ; (size_t)i<NUM_GRAPH_RANGE ; i++) { + for (i=0 ; i<NUM_GRAPH_RANGE ; i++) { addrange(cv, graphRangeTable[i].start, graphRangeTable[i].end); } - for (i=0 ; (size_t)i<NUM_GRAPH_CHAR ; i++) { + for (i=0 ; i<NUM_GRAPH_CHAR ; i++) { addchr(cv, graphCharTable[i]); } } @@ -1242,9 +1239,9 @@ allcases( chr c = (chr)pc; chr lc, uc, tc; - lc = Tcl_UniCharToLower((chr)c); - uc = Tcl_UniCharToUpper((chr)c); - tc = Tcl_UniCharToTitle((chr)c); + lc = Tcl_UniCharToLower(c); + uc = Tcl_UniCharToUpper(c); + tc = Tcl_UniCharToTitle(c); if (tc != uc) { cv = getcvec(v, 3, 0); diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 71bcb09..5357571 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -108,7 +108,7 @@ freenfa( } nfa->slast = NULL; - nfa->nstates = -1; + nfa->nstates = FREESTATE; nfa->pre = NULL; nfa->post = NULL; FREE(nfa); @@ -143,7 +143,7 @@ newstate( s->noas = 0; } - assert(nfa->nstates >= 0); + assert(nfa->nstates != FREESTATE); s->no = nfa->nstates++; s->flag = 0; if (nfa->states == NULL) { @@ -2494,7 +2494,7 @@ clonesuccessorstates( struct arc * refarc, char *curdonemap, char *outerdonemap, - int nstates) + size_t nstates) { char *donemap; struct arc *a; @@ -2691,7 +2691,7 @@ cleanup( { struct state *s; struct state *nexts; - int n; + size_t n; /* * Clear out unreachable or dead-end states. Use pre to mark reachable, @@ -2847,7 +2847,7 @@ compact( ca = cnfa->arcs; for (s = nfa->states; s != NULL; s = s->next) { - assert((size_t) s->no < nstates); + assert(s->no < nstates); cnfa->stflags[s->no] = 0; cnfa->states[s->no] = ca; first = ca; @@ -2951,10 +2951,10 @@ dumpnfa( { #ifdef REG_DEBUG struct state *s; - int nstates = 0; - int narcs = 0; + size_t nstates = 0; + size_t narcs = 0; - fprintf(f, "pre %d, post %d", nfa->pre->no, nfa->post->no); + fprintf(f, "pre %" TCL_Z_MODIFIER "u, post %" TCL_Z_MODIFIER "u", nfa->pre->no, nfa->post->no); if (nfa->bos[0] != COLORLESS) { fprintf(f, ", bos [%ld]", (long) nfa->bos[0]); } @@ -2973,7 +2973,7 @@ dumpnfa( nstates++; narcs += s->nouts; } - fprintf(f, "total of %d states, %d arcs\n", nstates, narcs); + fprintf(f, "total of %" TCL_Z_MODIFIER "u states, %" TCL_Z_MODIFIER "u arcs\n", nstates, narcs); if (nfa->parent == NULL) { dumpcolors(nfa->cm, f); } @@ -3000,7 +3000,7 @@ dumpstate( { struct arc *a; - fprintf(f, "%d%s%c", s->no, (s->tmp != NULL) ? "T" : "", + fprintf(f, "%" TCL_Z_MODIFIER "u%s%c", s->no, (s->tmp != NULL) ? "T" : "", (s->flag) ? s->flag : '.'); if (s->prev != NULL && s->prev->next != s) { fprintf(f, "\tstate chain bad\n"); @@ -3013,7 +3013,7 @@ dumpstate( fflush(f); for (a = s->ins; a != NULL; a = a->inchain) { if (a->to != s) { - fprintf(f, "\tlink from %d to %d on %d's in-chain\n", + fprintf(f, "\tlink from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u on %" TCL_Z_MODIFIER "u's in-chain\n", a->from->no, a->to->no, s->no); } } @@ -3091,7 +3091,7 @@ dumparc( break; } if (a->from != s) { - fprintf(f, "?%d?", a->from->no); + fprintf(f, "?%" TCL_Z_MODIFIER "u?", a->from->no); } for (ab = &a->from->oas; ab != NULL; ab = ab->next) { for (aa = &ab->a[0]; aa < &ab->a[ABSIZE]; aa++) { @@ -3111,7 +3111,7 @@ dumparc( fprintf(f, "NULL"); return; } - fprintf(f, "%d", a->to->no); + fprintf(f, "%" TCL_Z_MODIFIER "u", a->to->no); for (aa = a->to->ins; aa != NULL; aa = aa->inchain) { if (aa == a) { break; /* NOTE BREAK OUT */ @@ -3137,9 +3137,9 @@ dumpcnfa( FILE *f) { #ifdef REG_DEBUG - int st; + size_t st; - fprintf(f, "pre %d, post %d", cnfa->pre, cnfa->post); + fprintf(f, "pre %" TCL_Z_MODIFIER "u, post %" TCL_Z_MODIFIER "u", cnfa->pre, cnfa->post); if (cnfa->bos[0] != COLORLESS) { fprintf(f, ", bos [%ld]", (long) cnfa->bos[0]); } @@ -3182,15 +3182,15 @@ dumpcstate( FILE *f) { struct carc *ca; - int pos; + size_t pos; fprintf(f, "%d%s", st, (cnfa->stflags[st] & CNFA_NOPROGRESS) ? ":" : "."); pos = 1; for (ca = cnfa->states[st]; ca->co != COLORLESS; ca++) { if (ca->co < cnfa->ncolors) { - fprintf(f, "\t[%ld]->%d", (long) ca->co, ca->to); + fprintf(f, "\t[%d]->%" TCL_Z_MODIFIER "u", ca->co, ca->to); } else { - fprintf(f, "\t:%ld:->%d", (long) (ca->co - cnfa->ncolors), ca->to); + fprintf(f, "\t:%d:->%" TCL_Z_MODIFIER "u", ca->co - cnfa->ncolors, ca->to); } if (pos == 5) { fprintf(f, "\n"); diff --git a/generic/regcomp.c b/generic/regcomp.c index 983cd7a..012e37c 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -39,7 +39,7 @@ /* automatically gathered by fwd; do not hand-edit */ /* === regcomp.c === */ int compile(regex_t *, const chr *, size_t, int); -static void moresubs(struct vars *, int); +static void moresubs(struct vars *, size_t); static int freev(struct vars *, int); static void makesearch(struct vars *, struct nfa *); static struct subre *parse(struct vars *, int, int, struct state *, struct state *); @@ -156,7 +156,7 @@ static void fixconstraintloops(struct nfa *, FILE *); static int findconstraintloop(struct nfa *, struct state *); static void breakconstraintloop(struct nfa *, struct state *); static void clonesuccessorstates(struct nfa *, struct state *, struct state *, - struct state *, struct arc *, char *, char *, int); + struct state *, struct arc *, char *, char *, size_t); static void cleanup(struct nfa *); static void markreachable(struct nfa *, struct state *, struct state *, struct state *); static void markcanreach(struct nfa *, struct state *, struct state *, struct state *); @@ -179,8 +179,8 @@ static void dumpcstate(int, struct cnfa *, FILE *); static struct cvec *clearcvec(struct cvec *); static void addchr(struct cvec *, pchr); static void addrange(struct cvec *, pchr, pchr); -static struct cvec *newcvec(int, int); -static struct cvec *getcvec(struct vars *, int, int); +static struct cvec *newcvec(size_t, size_t); +static struct cvec *getcvec(struct vars *, size_t, size_t); static void freecvec(struct cvec *); /* === regc_locale.c === */ static celt element(struct vars *, const chr *, const chr *); @@ -205,11 +205,11 @@ struct vars { int cflags; /* copy of compile flags */ int lasttype; /* type of previous token */ int nexttype; /* type of next token */ - int nextvalue; /* value (if any) of next token */ + size_t nextvalue; /* value (if any) of next token */ int lexcon; /* lexical context type (see lex.c) */ - int nsubexp; /* subexpression count */ + size_t nsubexp; /* subexpression count */ struct subre **subs; /* subRE pointer vector */ - int nsubs; /* length of vector */ + size_t nsubs; /* length of vector */ struct subre *sub10[10]; /* initial vector, enough for most */ struct nfa *nfa; /* the NFA */ struct colormap *cm; /* character color map */ @@ -222,7 +222,7 @@ struct vars { struct cvec *cv; /* interface cvec */ struct cvec *cv2; /* utility cvec */ struct subre *lacons; /* lookahead-constraint vector */ - int nlacons; /* size of lacons */ + size_t nlacons; /* size of lacons */ size_t spaceused; /* approx. space used for compilation */ }; @@ -287,7 +287,7 @@ compile( { AllocVars(v); struct guts *g; - int i, j; + size_t i, j; FILE *debug = (flags®_PROGRESS) ? stdout : NULL; #define CNOERR() { if (ISERR()) return freev(v, v->err); } @@ -338,7 +338,6 @@ compile( v->spaceused = 0; re->re_magic = REMAGIC; re->re_info = 0; /* bits get set during parse */ - re->re_csize = sizeof(chr); re->re_guts = NULL; re->re_fns = (void*)(&functions); @@ -411,7 +410,7 @@ compile( assert(v->nlacons == 0 || v->lacons != NULL); for (i = 1; i < v->nlacons; i++) { if (debug != NULL) { - fprintf(debug, "\n\n\n========= LA%d ==========\n", i); + fprintf(debug, "\n\n\n========= LA%" TCL_Z_MODIFIER "u ==========\n", i); } nfanode(v, &v->lacons[i], debug); } @@ -467,15 +466,15 @@ compile( /* - moresubs - enlarge subRE vector - ^ static void moresubs(struct vars *, int); + ^ static void moresubs(struct vars *, size_t); */ static void moresubs( struct vars *v, - int wanted) /* want enough room for this one */ + size_t wanted) /* want enough room for this one */ { struct subre **p; - int n; + size_t n; assert(wanted > 0 && wanted >= v->nsubs); n = wanted * 3 / 2 + 1; @@ -795,7 +794,7 @@ parseqatom( struct subre *t; int cap; /* capturing parens? */ int pos; /* positive lookahead? */ - int subno; /* capturing-parens or backref number */ + size_t subno; /* capturing-parens or backref number */ int atomtype; int qprefer; /* quantifier short/long preference */ int f; @@ -2048,7 +2047,7 @@ dump( { #ifdef REG_DEBUG struct guts *g; - int i; + size_t i; if (re->re_magic != REMAGIC) { fprintf(f, "bad magic number (0x%x not 0x%x)\n", @@ -2065,8 +2064,8 @@ dump( } fprintf(f, "\n\n\n========= DUMP ==========\n"); - fprintf(f, "nsub %d, info 0%lo, csize %d, ntree %d\n", - (int) re->re_nsub, re->re_info, re->re_csize, g->ntree); + fprintf(f, "nsub %" TCL_Z_MODIFIER "u, info 0%lo, ntree %" TCL_Z_MODIFIER "u\n", + re->re_nsub, re->re_info, g->ntree); dumpcolors(&g->cmap, f); if (!NULLCNFA(g->search)) { @@ -2074,7 +2073,7 @@ dump( dumpcnfa(&g->search, f); } for (i = 1; i < g->nlacons; i++) { - fprintf(f, "\nla%d (%s):\n", i, + fprintf(f, "\nla%" TCL_Z_MODIFIER "u (%s):\n", i, (g->lacons[i].subno) ? "positive" : "negative"); dumpcnfa(&g->lacons[i].cnfa, f); } @@ -2146,7 +2145,7 @@ stdump( fprintf(f, "}"); } if (nfapresent) { - fprintf(f, " %d-%d", t->begin->no, t->end->no); + fprintf(f, " %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u", t->begin->no, t->end->no); } if (t->left != NULL) { fprintf(f, " L:%s", stid(t->left, idbuf, sizeof(idbuf))); diff --git a/generic/regcustom.h b/generic/regcustom.h index 56bf571..e5d7f12 100644 --- a/generic/regcustom.h +++ b/generic/regcustom.h @@ -36,9 +36,9 @@ * Overrides for regguts.h definitions, if any. */ -#define MALLOC(n) (void*)(attemptckalloc(n)) -#define FREE(p) ckfree((void*)(p)) -#define REALLOC(p,n) (void*)(attemptckrealloc((void*)(p),n)) +#define MALLOC(n) Tcl_AttemptAlloc(n) +#define FREE(p) Tcl_Free(p) +#define REALLOC(p,n) Tcl_AttemptRealloc(p,n) /* * Do not insert extras between the "begin" and "end" lines - this chunk is @@ -56,9 +56,6 @@ #ifdef __REG_WIDE_EXEC #undef __REG_WIDE_EXEC #endif -#ifdef __REG_REGOFF_T -#undef __REG_REGOFF_T -#endif #ifdef __REG_NOFRONT #undef __REG_NOFRONT #endif @@ -67,7 +64,6 @@ #endif /* Interface types */ #define __REG_WIDE_T Tcl_UniChar -#define __REG_REGOFF_T long /* Not really right, but good enough... */ /* Names and declarations */ #define __REG_WIDE_COMPILE TclReComp #define __REG_WIDE_EXEC TclReExec diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c index eddfea2..5d49aa5 100644 --- a/generic/rege_dfa.c +++ b/generic/rege_dfa.c @@ -47,7 +47,7 @@ longest( color co; struct sset *css, *ss; chr *post; - int i; + size_t i; struct colormap *cm = d->cm; /* @@ -292,7 +292,7 @@ lastCold( { struct sset *ss; chr *nopr = d->lastnopr; - int i; + size_t i; if (nopr == NULL) { nopr = v->start; @@ -319,7 +319,7 @@ newDFA( { struct dfa *d; size_t nss = cnfa->nstates * 2; - int wordsper = (cnfa->nstates + UBITS - 1) / UBITS; + size_t wordsper = (cnfa->nstates + UBITS - 1) / UBITS; struct smalldfa *smallwas = sml; assert(cnfa != NULL && cnfa->nstates != 0); @@ -442,7 +442,7 @@ initialize( chr *const start) { struct sset *ss; - int i; + size_t i; /* * Is previous one still there? @@ -492,7 +492,8 @@ miss( unsigned h; struct carc *ca; struct sset *p; - int i, isPost, noProgress, gotState, doLAConstraints, sawLAConstraints; + size_t i; + int isPost, noProgress, gotState, doLAConstraints, sawLAConstraints; /* * For convenience, we can be called even if it might not be a miss. @@ -526,7 +527,7 @@ miss( if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) { noProgress = 0; } - FDEBUG(("%d -> %d\n", i, ca->to)); + FDEBUG(("%" TCL_Z_MODIFIER "u -> %" TCL_Z_MODIFIER "u\n", i, ca->to)); } } } @@ -556,7 +557,7 @@ miss( if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) { noProgress = 0; } - FDEBUG(("%d :> %d\n", i, ca->to)); + FDEBUG(("%" TCL_Z_MODIFIER "u :> %" TCL_Z_MODIFIER"u\n", i, ca->to)); } } } @@ -615,7 +616,7 @@ checkLAConstraint( chr *const cp, const pcolor co) /* "color" of the lookahead constraint */ { - int n; + size_t n; struct subre *sub; struct dfa *d; struct smalldfa sd; @@ -623,7 +624,7 @@ checkLAConstraint( n = co - pcnfa->ncolors; assert(n < v->g->nlacons && v->g->lacons != NULL); - FDEBUG(("=== testing lacon %d\n", n)); + FDEBUG(("=== testing lacon %" TCL_Z_MODIFIER "u\n", n)); sub = &v->g->lacons[n]; d = newDFA(v, &sub->cnfa, &v->g->cmap, &sd); if (d == NULL) { @@ -632,7 +633,7 @@ checkLAConstraint( } end = longest(v, d, cp, v->stop, NULL); freeDFA(d); - FDEBUG(("=== lacon %d match %d\n", n, (end != NULL))); + FDEBUG(("=== lacon %" TCL_Z_MODIFIER "u match %d\n", n, (end != NULL))); return (sub->subno) ? (end != NULL) : (end == NULL); } @@ -738,21 +739,21 @@ pickNextSS( */ if (d->nssused < d->nssets) { - i = d->nssused; + size_t j = d->nssused; d->nssused++; - ss = &d->ssets[i]; - FDEBUG(("new c%d\n", i)); + ss = &d->ssets[j]; + FDEBUG(("new c%" TCL_Z_MODIFIER "u\n", j)); /* * Set up innards. */ - ss->states = &d->statesarea[i * d->wordsper]; + ss->states = &d->statesarea[j * d->wordsper]; ss->flags = 0; ss->ins.ss = NULL; ss->ins.co = WHITE; /* give it some value */ - ss->outs = &d->outsarea[i * d->ncolors]; - ss->inchain = &d->incarea[i * d->ncolors]; + ss->outs = &d->outsarea[j * d->ncolors]; + ss->inchain = &d->incarea[j * d->ncolors]; for (i = 0; i < d->ncolors; i++) { ss->outs[i] = NULL; ss->inchain[i].ss = NULL; @@ -764,7 +765,7 @@ pickNextSS( * Look for oldest, or old enough anyway. */ - if (cp - start > d->nssets*2/3) { /* oldest 33% are expendable */ + if ((size_t)(cp - start) > d->nssets*2/3) { /* oldest 33% are expendable */ ancient = cp - d->nssets*2/3; } else { ancient = start; @@ -773,7 +774,7 @@ pickNextSS( if ((ss->lastseen == NULL || ss->lastseen < ancient) && !(ss->flags&LOCKED)) { d->search = ss + 1; - FDEBUG(("replacing c%d\n", (int) (ss - d->ssets))); + FDEBUG(("replacing c%" TCL_Z_MODIFIER "u\n", (size_t)(ss - d->ssets))); return ss; } } @@ -781,7 +782,7 @@ pickNextSS( if ((ss->lastseen == NULL || ss->lastseen < ancient) && !(ss->flags&LOCKED)) { d->search = ss + 1; - FDEBUG(("replacing c%d\n", (int) (ss - d->ssets))); + FDEBUG(("replacing c%" TCL_Z_MODIFIER "u\n", (size_t)(ss - d->ssets))); return ss; } } diff --git a/generic/regerror.c b/generic/regerror.c index 775c640..5caab8a 100644 --- a/generic/regerror.c +++ b/generic/regerror.c @@ -86,7 +86,7 @@ regerror( if (r->code >= 0) { msg = r->name; } else { /* Unknown; tell him the number */ - snprintf(convbuf, sizeof(convbuf), "REG_%u", (unsigned)icode); + snprintf(convbuf, sizeof(convbuf), "REG_%u", icode); msg = convbuf; } break; diff --git a/generic/regex.h b/generic/regex.h index dba3ab4..72f7037 100644 --- a/generic/regex.h +++ b/generic/regex.h @@ -89,9 +89,6 @@ extern "C" { #ifdef __REG_WIDE_EXEC #undef __REG_WIDE_EXEC #endif -#ifdef __REG_REGOFF_T -#undef __REG_REGOFF_T -#endif #ifdef __REG_NOFRONT #undef __REG_NOFRONT #endif @@ -100,7 +97,6 @@ extern "C" { #endif /* interface types */ #define __REG_WIDE_T Tcl_UniChar -#define __REG_REGOFF_T long /* not really right, but good enough... */ /* names and declarations */ #define __REG_WIDE_COMPILE TclReComp #define __REG_WIDE_EXEC TclReExec @@ -115,25 +111,14 @@ extern "C" { */ /* - * regoff_t has to be large enough to hold either off_t or ssize_t, and must - * be signed; it's only a guess that long is suitable, so we offer - * <sys/types.h> an override. - */ -#ifdef __REG_REGOFF_T -typedef __REG_REGOFF_T regoff_t; -#else -typedef long regoff_t; -#endif - -/* * other interface types */ /* the biggie, a compiled RE (or rather, a front end to same) */ typedef struct { int re_magic; /* magic number */ - size_t re_nsub; /* number of subexpressions */ long re_info; /* information about RE */ + size_t re_nsub; /* number of subexpressions */ #define REG_UBACKREF 000001 #define REG_ULOOKAHEAD 000002 #define REG_UBOUNDS 000004 @@ -148,7 +133,6 @@ typedef struct { #define REG_UEMPTYMATCH 004000 #define REG_UIMPOSSIBLE 010000 #define REG_USHORTEST 020000 - int re_csize; /* sizeof(character) */ char *re_endp; /* backward compatibility kludge */ /* the rest is opaque pointers to hidden innards */ void *re_guts; @@ -157,8 +141,8 @@ typedef struct { /* result reporting (may acquire more fields later) */ typedef struct { - regoff_t rm_so; /* start of substring */ - regoff_t rm_eo; /* end of substring */ + size_t rm_so; /* start of substring */ + size_t rm_eo; /* end of substring */ } regmatch_t; /* supplementary control and reporting */ diff --git a/generic/regexec.c b/generic/regexec.c index 7ef048e..7b84f0f 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -57,11 +57,12 @@ struct sset { /* state set */ }; struct dfa { - int nssets; /* size of cache */ - int nssused; /* how many entries occupied yet */ - int nstates; /* number of states */ + size_t nssets; /* size of cache */ + size_t nssused; /* how many entries occupied yet */ + size_t nstates; /* number of states */ + size_t wordsper; /* length of state-set bitvectors */ int ncolors; /* length of outarc and inchain vectors */ - int wordsper; /* length of state-set bitvectors */ + int cptsmalloced; /* were the areas individually malloced? */ struct sset *ssets; /* state-set cache */ unsigned *statesarea; /* bitvector storage */ unsigned *work; /* pointer to work area within statesarea */ @@ -72,7 +73,6 @@ struct dfa { chr *lastpost; /* location of last cache-flushed success */ chr *lastnopr; /* location of last cache-flushed NOPROGRESS */ struct sset *search; /* replacement-search-pointer memory */ - int cptsmalloced; /* were the areas individually malloced? */ char *mallocarea; /* self, or malloced area, or NULL */ }; @@ -186,10 +186,6 @@ exec( FreeVars(v); return REG_INVARG; } - if (re->re_csize != sizeof(chr)) { - FreeVars(v); - return REG_MIXED; - } /* * Setup. @@ -554,8 +550,8 @@ zapallsubs( size_t i; for (i = n-1; i > 0; i--) { - p[i].rm_so = -1; - p[i].rm_eo = -1; + p[i].rm_so = FREESTATE; + p[i].rm_eo = FREESTATE; } } @@ -569,11 +565,11 @@ zaptreesubs( struct subre *const t) { if (t->op == '(') { - int n = t->subno; + size_t n = t->subno; assert(n > 0); - if ((size_t) n < v->nmatch) { - v->pmatch[n].rm_so = -1; - v->pmatch[n].rm_eo = -1; + if (n < v->nmatch) { + v->pmatch[n].rm_so = FREESTATE; + v->pmatch[n].rm_eo = FREESTATE; } } @@ -893,7 +889,7 @@ cbrdissect( MDEBUG(("cbackref n%d %d{%d-%d}\n", t->id, n, min, max)); /* get the backreferenced string */ - if (v->pmatch[n].rm_so == TCL_INDEX_NONE) { + if (v->pmatch[n].rm_so == FREESTATE) { return REG_NOMATCH; } brstring = v->start + v->pmatch[n].rm_so; diff --git a/generic/regguts.h b/generic/regguts.h index 62ab889..e135874 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -203,11 +203,11 @@ struct colormap { /* Representation of a set of characters. */ struct cvec { - int nchrs; /* number of chrs */ - int chrspace; /* number of chrs possible */ + size_t nchrs; /* number of chrs */ + size_t chrspace; /* number of chrs possible */ chr *chrs; /* pointer to vector of chrs */ - int nranges; /* number of ranges (chr pairs) */ - int rangespace; /* number of chrs possible */ + size_t nranges; /* number of ranges (chr pairs) */ + size_t rangespace; /* number of chrs possible */ chr *ranges; /* pointer to vector of chr pairs */ }; @@ -242,19 +242,19 @@ struct arcbatch { /* for bulk allocation of arcs */ }; struct state { - int no; -#define FREESTATE (-1) + size_t no; +#define FREESTATE ((size_t)-1) char flag; /* marks special states */ - int nins; /* number of inarcs */ + size_t nins; /* number of inarcs */ struct arc *ins; /* chain of inarcs */ - int nouts; /* number of outarcs */ + size_t nouts; /* number of outarcs */ struct arc *outs; /* chain of outarcs */ struct arc *free; /* chain of free arcs */ struct state *tmp; /* temporary for traversal algorithms */ struct state *next; /* chain for traversing all */ struct state *prev; /* back chain */ struct arcbatch oas; /* first arcbatch, avoid malloc in easy case */ - int noas; /* number of arcs used in first arcbatch */ + size_t noas; /* number of arcs used in first arcbatch */ }; struct nfa { @@ -262,7 +262,7 @@ struct nfa { struct state *init; /* initial state */ struct state *final; /* final state */ struct state *post; /* postfinal state */ - int nstates; /* for numbering states */ + size_t nstates; /* for numbering states */ struct state *states; /* state-chain header */ struct state *slast; /* tail of the chain */ struct state *free; /* free list */ @@ -290,16 +290,16 @@ struct nfa { struct carc { color co; /* COLORLESS is list terminator */ - int to; /* next-state number */ + size_t to; /* next-state number */ }; struct cnfa { - int nstates; /* number of states */ + size_t nstates; /* number of states */ int ncolors; /* number of colors */ int flags; #define HASLACONS 01 /* uses lookahead constraints */ - int pre; /* setup state number */ - int post; /* teardown state number */ + size_t pre; /* setup state number */ + size_t post; /* teardown state number */ color bos[2]; /* colors, if any, assigned to BOS and BOL */ color eos[2]; /* colors, if any, assigned to EOS and EOL */ char *stflags; /* vector of per-state flags bytes */ @@ -396,11 +396,11 @@ struct guts { size_t nsub; /* copy of re_nsub */ struct subre *tree; struct cnfa search; /* for fast preliminary search */ - int ntree; /* number of subre's, plus one */ + size_t ntree; /* number of subre's, plus one */ struct colormap cmap; int (*compare) (const chr *, const chr *, size_t); struct subre *lacons; /* lookahead-constraint vector */ - int nlacons; /* size of lacons */ + size_t nlacons; /* size of lacons */ }; /* diff --git a/generic/tcl.decls b/generic/tcl.decls index ec135a5..8e047d0 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -40,22 +40,22 @@ declare 2 { TCL_NORETURN void Tcl_Panic(const char *format, ...) } declare 3 { - char *Tcl_Alloc(TCL_HASH_TYPE size) + void *Tcl_Alloc(TCL_HASH_TYPE size) } declare 4 { - void Tcl_Free(char *ptr) + void Tcl_Free(void *ptr) } declare 5 { - char *Tcl_Realloc(char *ptr, TCL_HASH_TYPE size) + void *Tcl_Realloc(void *ptr, TCL_HASH_TYPE size) } declare 6 { - char *Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line) + void *Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line) } declare 7 { - void Tcl_DbCkfree(char *ptr, const char *file, int line) + void Tcl_DbCkfree(void *ptr, const char *file, int line) } declare 8 { - char *Tcl_DbCkrealloc(char *ptr, TCL_HASH_TYPE size, + void *Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size, const char *file, int line) } @@ -63,11 +63,11 @@ declare 8 { # but they are part of the old generic interface, so we include them here for # compatibility reasons. -declare 9 unix { +declare 9 { void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, void *clientData) } -declare 10 unix { +declare 10 { void Tcl_DeleteFileHandler(int fd) } declare 11 { @@ -104,9 +104,10 @@ declare 20 { declare 21 { int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line) } -declare 22 {deprecated {No longer in use, changed to macro}} { - Tcl_Obj *Tcl_DbNewBooleanObj(int intValue, const char *file, int line) -} +# Removed in 9.0 (changed to macro): +#declare 22 { +# Tcl_Obj *Tcl_DbNewBooleanObj(int intValue, const char *file, int line) +#} declare 23 { Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes, const char *file, int line) @@ -119,9 +120,10 @@ declare 25 { Tcl_Obj *Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv, const char *file, int line) } -declare 26 {deprecated {No longer in use, changed to macro}} { - Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line) -} +# Removed in 9.0 (changed to macro): +#declare 26 { +# Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line) +#} declare 27 { Tcl_Obj *Tcl_DbNewObj(const char *file, int line) } @@ -153,10 +155,11 @@ declare 35 { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } -declare 36 {deprecated {No longer in use, changed to macro}} { - int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - const char *const *tablePtr, const char *msg, int flags, int *indexPtr) -} +# Removed in 9.0, replaced by macro. +#declare 36 { +# int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, +# const char *const *tablePtr, const char *msg, int flags, int *indexPtr) +#} declare 37 { int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr) } @@ -167,10 +170,10 @@ declare 39 { int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr) } declare 40 { - CONST86 Tcl_ObjType *Tcl_GetObjType(const char *typeName) + const Tcl_ObjType *Tcl_GetObjType(const char *typeName) } declare 41 { - char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr) + char *TclGetStringFromObj(Tcl_Obj *objPtr, void *lengthPtr) } declare 42 { void Tcl_InvalidateStringRep(Tcl_Obj *objPtr) @@ -184,48 +187,52 @@ declare 44 { Tcl_Obj *objPtr) } declare 45 { - int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, - int *objcPtr, Tcl_Obj ***objvPtr) + int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, + void *objcPtr, Tcl_Obj ***objvPtr) } declare 46 { int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr) } declare 47 { - int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, - int *lengthPtr) + int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, + void *lengthPtr) } declare 48 { int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first, Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[]) } -declare 49 {deprecated {No longer in use, changed to macro}} { - Tcl_Obj *Tcl_NewBooleanObj(int intValue) -} +# Removed in 9.0 (changed to macro): +#declare 49 { +# Tcl_Obj *Tcl_NewBooleanObj(int intValue) +#} declare 50 { Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes) } declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) } -declare 52 {deprecated {No longer in use, changed to macro}} { - Tcl_Obj *Tcl_NewIntObj(int intValue) -} +# Removed in 9.0 (changed to macro): +#declare 52 { +# Tcl_Obj *Tcl_NewIntObj(int intValue) +#} declare 53 { Tcl_Obj *Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[]) } -declare 54 {deprecated {No longer in use, changed to macro}} { - Tcl_Obj *Tcl_NewLongObj(long longValue) -} +# Removed in 9.0 (changed to macro): +#declare 54 { +# Tcl_Obj *Tcl_NewLongObj(long longValue) +#} declare 55 { Tcl_Obj *Tcl_NewObj(void) } declare 56 { Tcl_Obj *Tcl_NewStringObj(const char *bytes, Tcl_Size length) } -declare 57 {deprecated {No longer in use, changed to macro}} { - void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue) -} +# Removed in 9.0 (changed to macro): +#declare 57 { +# void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue) +#} declare 58 { unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, Tcl_Size numBytes) } @@ -236,28 +243,32 @@ declare 59 { declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) } -declare 61 {deprecated {No longer in use, changed to macro}} { - void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) -} +# Removed in 9.0 (changed to macro): +#declare 61 { +# void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) +#} declare 62 { void Tcl_SetListObj(Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[]) } -declare 63 {deprecated {No longer in use, changed to macro}} { - void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) -} +# Removed in 9.0 (changed to macro): +#declare 63 { +# void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) +#} declare 64 { void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length) } declare 65 { void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length) } -declare 66 {deprecated {No longer in use, changed to macro}} { - void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) -} -declare 67 {deprecated {No longer in use, changed to macro}} { - void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, - Tcl_Size length) -} +# Removed in 9.0, replaced by macro. +#declare 66 { +# void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) +#} +# Removed in 9.0, replaced by macro. +#declare 67 { +# void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, +# Tcl_Size length) +#} declare 68 { void Tcl_AllowExceptions(Tcl_Interp *interp) } @@ -283,12 +294,14 @@ declare 74 { declare 75 { int Tcl_AsyncReady(void) } -declare 76 {deprecated {No longer in use, changed to macro}} { - void Tcl_BackgroundError(Tcl_Interp *interp) -} -declare 77 {deprecated {Use Tcl_UtfBackslash}} { - char Tcl_Backslash(const char *src, int *readPtr) -} +# Removed in 9.0 +#declare 76 { +# void Tcl_BackgroundError(Tcl_Interp *interp) +#} +# Removed in 9.0: +#declare 77 { +# char Tcl_Backslash(const char *src, int *readPtr) +#} declare 78 { int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName, const char *optionList) @@ -354,11 +367,12 @@ declare 93 { declare 94 { Tcl_Interp *Tcl_CreateInterp(void) } -declare 95 {deprecated {}} { - void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, - int numArgs, Tcl_ValueType *argTypes, - Tcl_MathProc *proc, void *clientData) -} +# Removed in 9.0: +#declare 95 { +# void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, +# int numArgs, Tcl_ValueType *argTypes, +# Tcl_MathProc *proc, void *clientData) +#} declare 96 { Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, @@ -468,15 +482,17 @@ declare 127 { declare 128 { const char *Tcl_ErrnoMsg(int err) } -declare 129 { - int Tcl_Eval(Tcl_Interp *interp, const char *script) -} +# Removed in 9.0, replaced by macro. +#declare 129 { +# int Tcl_Eval(Tcl_Interp *interp, const char *script) +#} declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } -declare 131 {deprecated {No longer in use, changed to macro}} { - int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -} +# Removed in 9.0, replaced by macro. +#declare 131 { +# int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +#} declare 132 { void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc) } @@ -515,9 +531,10 @@ declare 142 { declare 143 { void Tcl_Finalize(void) } -declare 144 {nostub {Don't use this function in a stub-enabled extension}} { - const char *Tcl_FindExecutable(const char *argv0) -} +# Removed in 9.0 (stub entry only) +#declare 144 { +# const char *Tcl_FindExecutable(const char *argv0) +#} declare 145 { Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr) @@ -525,9 +542,10 @@ declare 145 { declare 146 { int Tcl_Flush(Tcl_Channel chan) } -declare 147 {deprecated {see TIP #559. Use Tcl_ResetResult}} { - void Tcl_FreeResult(Tcl_Interp *interp) -} +# Removed in 9.0, TIP 559 +#declare 147 { +# void Tcl_FreeResult(Tcl_Interp *interp) +#} declare 148 { int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, @@ -567,7 +585,7 @@ declare 157 { const char *optionName, Tcl_DString *dsPtr) } declare 158 { - CONST86 Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan) + const Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan) } declare 159 { int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, @@ -599,7 +617,7 @@ declare 166 { # Tcl_GetOpenFile is only available on unix, but it is a part of the old # generic interface, so we include it here for compatibility reasons. -declare 167 unix { +declare 167 { int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr) } @@ -623,23 +641,27 @@ declare 172 { declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) } -declare 174 { - const char *Tcl_GetStringResult(Tcl_Interp *interp) -} -declare 175 {deprecated {No longer in use, changed to macro}} { - const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, - int flags) -} +# Removed in 9.0, replaced by macro. +#declare 174 { +# const char *Tcl_GetStringResult(Tcl_Interp *interp) +#} +# Removed in 9.0, replaced by macro. +#declare 175 { +# const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, +# int flags) +#} declare 176 { const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } -declare 177 { - int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) -} -declare 178 {deprecated {No longer in use, changed to macro}} { - int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -} +# Removed in 9.0, replaced by macro. +#declare 177 { +# int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) +#} +# Removed in 9.0, replaced by macro. +#declare 178 { +# int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +#} declare 179 { int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken) @@ -680,9 +702,10 @@ declare 187 { declare 189 { Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode) } -declare 190 {deprecated {}} { - int Tcl_MakeSafe(Tcl_Interp *interp) -} +# Removed in 9.0 +#declare 190 { +# int Tcl_MakeSafe(Tcl_Interp *interp) +#} declare 191 { Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket) } @@ -781,9 +804,10 @@ declare 218 { declare 219 { Tcl_Size Tcl_ScanCountedElement(const char *src, Tcl_Size length, int *flagPtr) } -declare 220 {deprecated {}} { - int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) -} +# Removed in 9.0: +#declare 220 { +# int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) +#} declare 221 { int Tcl_ServiceAll(void) } @@ -814,16 +838,18 @@ declare 228 { declare 229 { void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr) } -declare 230 {nostub {Don't use this function in a stub-enabled extension}} { - const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) -} +# Removed in 9.0 (stub entry only) +#declare 230 { +# const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) +#} declare 231 { Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp, Tcl_Size depth) } -declare 232 { - void Tcl_SetResult(Tcl_Interp *interp, char *result, - Tcl_FreeProc *freeProc) -} +# Removed in 9.0, replaced by macro. +#declare 232 { +# void Tcl_SetResult(Tcl_Interp *interp, char *result, +# Tcl_FreeProc *freeProc) +#} declare 233 { int Tcl_SetServiceMode(int mode) } @@ -836,10 +862,11 @@ declare 235 { declare 236 { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } -declare 237 {deprecated {No longer in use, changed to macro}} { - const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, - const char *newValue, int flags) -} +# Removed in 9.0, replaced by macro. +#declare 237 { +# const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, +# const char *newValue, int flags) +#} declare 238 { const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags) @@ -854,27 +881,31 @@ declare 241 { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 { - int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, + int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr, const char ***argvPtr) } # Obsolete, use Tcl_FSSplitPath declare 243 { - void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr) -} -declare 244 {nostub {Don't use this function in a stub-enabled extension}} { - void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, - Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) -} -declare 245 {deprecated {No longer in use, changed to macro}} { - int Tcl_StringMatch(const char *str, const char *pattern) -} -declare 246 {deprecated {}} { - int Tcl_TellOld(Tcl_Channel chan) -} -declare 247 {deprecated {No longer in use, changed to macro}} { - int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, - Tcl_VarTraceProc *proc, void *clientData) -} + void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr) +} +# Removed in 9.0 (stub entry only) +#declare 244 { +# void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, +# Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) +#} +# Removed in 9.0 (stub entry only) +#declare 245 { +# int Tcl_StringMatch(const char *str, const char *pattern) +#} +# Removed in 9.0: +#declare 246 { +# int Tcl_TellOld(Tcl_Channel chan) +#} +# Removed in 9.0, replaced by macro. +#declare 247 { +# int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, +# Tcl_VarTraceProc *proc, void *clientData) +#} declare 248 { int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData) @@ -892,17 +923,19 @@ declare 251 { declare 252 { int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan) } -declare 253 {deprecated {No longer in use, changed to macro}} { - int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags) -} +# Removed in 9.0, replaced by macro. +#declare 253 { +# int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags) +#} declare 254 { int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } -declare 255 {deprecated {No longer in use, changed to macro}} { - void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, - Tcl_VarTraceProc *proc, void *clientData) -} +# Removed in 9.0, replaced by macro. +#declare 255 { +# void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, +# Tcl_VarTraceProc *proc, void *clientData) +#} declare 256 { void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, @@ -911,10 +944,11 @@ declare 256 { declare 257 { void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName) } -declare 258 {deprecated {No longer in use, changed to macro}} { - int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, - const char *varName, const char *localName, int flags) -} +# Removed in 9.0, replaced by macro. +#declare 258 { +# int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, +# const char *varName, const char *localName, int flags) +#} declare 259 { int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags) @@ -922,10 +956,11 @@ declare 259 { declare 260 { int Tcl_VarEval(Tcl_Interp *interp, ...) } -declare 261 {deprecated {No longer in use, changed to macro}} { - void *Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, - int flags, Tcl_VarTraceProc *procPtr, void *prevClientData) -} +# Removed in 9.0, replaced by macro. +#declare 261 { +# void *Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, +# int flags, Tcl_VarTraceProc *procPtr, void *prevClientData) +#} declare 262 { void *Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, @@ -944,12 +979,14 @@ declare 265 { declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } -declare 267 {deprecated {see TIP #422}} { - void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) -} -declare 268 {deprecated {see TIP #422}} { - void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) -} +# Removed in 9.0: +#declare 267 { +# void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) +#} +# Removed in 9.0: +#declare 268 { +# void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) +#} declare 269 { char *Tcl_HashStats(Tcl_HashTable *tablePtr) } @@ -957,36 +994,42 @@ declare 270 { const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, const char **termPtr) } -declare 271 {deprecated {No longer in use, changed to macro}} { - const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, - const char *version, int exact) -} +# Removed in 9.0, replaced by macro. +#declare 271 { +# const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, +# const char *version, int exact) +#} declare 272 { const char *Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr) } -declare 273 {deprecated {No longer in use, changed to macro}} { - int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, - const char *version) -} +# Removed in 9.0, replaced by macro. +#declare 273 { +# int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, +# const char *version) +#} # TIP #268: The internally used new Require function is in slot 573. -declare 274 {deprecated {No longer in use, changed to macro}} { - const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, - const char *version, int exact) -} -declare 275 {deprecated {see TIP #422}} { - void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) -} -declare 276 {deprecated {see TIP #422}} { - int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) -} +# Removed in 9.0, replaced by macro. +#declare 274 { +# const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, +# const char *version, int exact) +#} +# Removed in 9.0: +#declare 275 { +# void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) +#} +# Removed in 9.0: +#declare 276 { +# int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) +#} declare 277 { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } -declare 278 {deprecated {see TIP #422}} { - TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) -} +# Removed in 9.0: +#declare 278 { +# TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) +#} declare 279 { void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type) } @@ -1043,9 +1086,10 @@ declare 288 { declare 289 { void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData) } -declare 290 {deprecated {Use Tcl_DiscardInterpState}} { - void Tcl_DiscardResult(Tcl_SavedResult *statePtr) -} +# Removed in 9.0 +#declare 290 { +# void Tcl_DiscardResult(Tcl_SavedResult *statePtr) +#} declare 291 { int Tcl_EvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags) @@ -1120,18 +1164,20 @@ declare 311 { const Tcl_Time *timePtr) } declare 312 { - Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length) + Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length) } declare 313 { Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, Tcl_Size charsToRead, int appendFlag) } -declare 314 {deprecated {Use Tcl_RestoreInterpState}} { - void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) -} -declare 315 {deprecated {Use Tcl_SaveInterpState}} { - void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) -} +# Removed in 9.0 +#declare 314 { +# void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) +#} +# Removed in 9.0 +#declare 315 { +# void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) +#} declare 316 { int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name) } @@ -1162,7 +1208,7 @@ declare 324 { Tcl_Size Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - const char *Tcl_UtfAtIndex(const char *src, Tcl_Size index) + const char *TclUtfAtIndex(const char *src, Tcl_Size index) } declare 326 { int TclUtfCharComplete(const char *src, Tcl_Size length) @@ -1213,12 +1259,14 @@ declare 339 { declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } -declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} { - const char *Tcl_GetDefaultEncodingDir(void) -} -declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} { - void Tcl_SetDefaultEncodingDir(const char *path) -} +# Removed in 9.0: +#declare 341 { +# const char *Tcl_GetDefaultEncodingDir(void) +#} +# Removed in 9.0: +#declare 342 { +# void Tcl_SetDefaultEncodingDir(const char *path) +#} declare 343 { void Tcl_AlertNotifier(void *clientData) } @@ -1249,10 +1297,11 @@ declare 351 { declare 352 { Tcl_Size Tcl_Char16Len(const unsigned short *uniStr) } -declare 353 {deprecated {Use Tcl_UtfNcmp}} { - int Tcl_UniCharNcmp(const unsigned short *ucs, const unsigned short *uct, - unsigned long numChars) -} +# Removed in 9.0: +#declare 353 { +# int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, +# unsigned long numChars) +#} declare 354 { char *Tcl_Char16ToUtfDString(const unsigned short *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr) @@ -1265,10 +1314,11 @@ declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) } -declare 357 {deprecated {Use Tcl_EvalTokensStandard}} { - Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, - Tcl_Size count) -} +# Removed in 9.0: +#declare 357 { +# Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, +# Tcl_Size count) +#} declare 358 { void Tcl_FreeParse(Tcl_Parse *parsePtr) } @@ -1313,10 +1363,10 @@ declare 368 { int Tcl_Stat(const char *path, struct stat *bufPtr) } declare 369 { - int Tcl_UtfNcmp(const char *s1, const char *s2, unsigned long n) + int TclUtfNcmp(const char *s1, const char *s2, size_t n) } declare 370 { - int Tcl_UtfNcasecmp(const char *s1, const char *s2, unsigned long n) + int TclUtfNcasecmp(const char *s1, const char *s2, size_t n) } declare 371 { int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase) @@ -1341,26 +1391,27 @@ declare 377 { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 { - Tcl_Obj *Tcl_NewUnicodeObj(const unsigned short *unicode, Tcl_Size numChars) + Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, Tcl_Size numChars) } declare 379 { - void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const unsigned short *unicode, + void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size numChars) } declare 380 { - Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr) + Tcl_Size TclGetCharLength(Tcl_Obj *objPtr) } declare 381 { - int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index) -} -declare 382 {deprecated {No longer in use, changed to macro}} { - unsigned short *Tcl_GetUnicode(Tcl_Obj *objPtr) + int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index) } +# Removed in 9.0, replaced by macro. +#declare 382 { +# Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) +#} declare 383 { - Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last) + Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last) } declare 384 { - void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const unsigned short *unicode, + void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size length) } declare 385 { @@ -1418,10 +1469,11 @@ declare 400 { Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc( const Tcl_ChannelType *chanTypePtr) } -declare 401 {deprecated {Use Tcl_ChannelClose2Proc}} { - Tcl_DriverCloseProc *Tcl_ChannelCloseProc( - const Tcl_ChannelType *chanTypePtr) -} +# Removed in 9.0 +#declare 401 { +# Tcl_DriverCloseProc *Tcl_ChannelCloseProc( +# const Tcl_ChannelType *chanTypePtr) +#} declare 402 { Tcl_DriverClose2Proc *Tcl_ChannelClose2Proc( const Tcl_ChannelType *chanTypePtr) @@ -1434,10 +1486,11 @@ declare 404 { Tcl_DriverOutputProc *Tcl_ChannelOutputProc( const Tcl_ChannelType *chanTypePtr) } -declare 405 {deprecated {Use Tcl_ChannelWideSeekProc}} { - Tcl_DriverSeekProc *Tcl_ChannelSeekProc( - const Tcl_ChannelType *chanTypePtr) -} +# Removed in 9.0 +#declare 405 { +# Tcl_DriverSeekProc *Tcl_ChannelSeekProc( +# const Tcl_ChannelType *chanTypePtr) +#} declare 406 { Tcl_DriverSetOptionProc *Tcl_ChannelSetOptionProc( const Tcl_ChannelType *chanTypePtr) @@ -1485,21 +1538,25 @@ declare 417 { declare 418 { int Tcl_IsChannelExisting(const char *channelName) } -declare 419 {deprecated {Use Tcl_UtfNcasecmp}} { - int Tcl_UniCharNcasecmp(const unsigned short *ucs, const unsigned short *uct, - unsigned long numChars) -} -declare 420 {deprecated {Use Tcl_StringCaseMatch}} { - int Tcl_UniCharCaseMatch(const unsigned short *uniStr, - const unsigned short *uniPattern, int nocase) -} -declare 421 { - Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key) -} -declare 422 { - Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, - const void *key, int *newPtr) -} +# Removed in 9.0: +#declare 419 { +# int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, +# unsigned long numChars) +#} +# Removed in 9.0: +#declare 420 { +# int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, +# const Tcl_UniChar *uniPattern, int nocase) +#} +# Removed in 9.0, as it is actually a macro: +#declare 421 { +# Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key) +#} +# Removed in 9.0, as it is actually a macro: +#declare 422 { +# Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, +# const void *key, int *newPtr) +#} declare 423 { void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr) @@ -1521,16 +1578,16 @@ declare 427 { int flags, Tcl_CommandTraceProc *proc, void *clientData) } declare 428 { - char *Tcl_AttemptAlloc(TCL_HASH_TYPE size) + void *Tcl_AttemptAlloc(TCL_HASH_TYPE size) } declare 429 { - char *Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line) + void *Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line) } declare 430 { - char *Tcl_AttemptRealloc(char *ptr, TCL_HASH_TYPE size) + void *Tcl_AttemptRealloc(void *ptr, TCL_HASH_TYPE size) } declare 431 { - char *Tcl_AttemptDbCkrealloc(char *ptr, TCL_HASH_TYPE size, + void *Tcl_AttemptDbCkrealloc(void *ptr, TCL_HASH_TYPE size, const char *file, int line) } declare 432 { @@ -1544,18 +1601,20 @@ declare 433 { # introduced in 8.4a3 declare 434 { - unsigned short *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) + Tcl_UniChar *TclGetUnicodeFromObj(Tcl_Obj *objPtr, void *lengthPtr) } # TIP#15 (math function introspection) dkf -declare 435 {deprecated {}} { - int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, - int *numArgsPtr, Tcl_ValueType **argTypesPtr, - Tcl_MathProc **procPtr, void **clientDataPtr) -} -declare 436 {deprecated {}} { - Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern) -} +# Removed in 9.0: +#declare 435 { +# int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, +# int *numArgsPtr, Tcl_ValueType **argTypesPtr, +# Tcl_MathProc **procPtr, void **clientDataPtr) +#} +# Removed in 9.0: +#declare 436 { +# Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern) +#} # TIP#36 (better access to 'subst') dkf declare 437 { @@ -1617,7 +1676,7 @@ declare 452 { int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr) } declare 453 { - const char *CONST86 *Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, + const char *const *Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) } declare 454 { @@ -1643,7 +1702,7 @@ declare 460 { Tcl_Obj *Tcl_FSJoinPath(Tcl_Obj *listObj, Tcl_Size elements) } declare 461 { - Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr) + Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr) } declare 462 { int Tcl_FSEqualPaths(Tcl_Obj *firstPtr, Tcl_Obj *secondPtr) @@ -1695,7 +1754,7 @@ declare 476 { Tcl_Obj *pathPtr) } declare 477 { - CONST86 Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr) + const Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr) } declare 478 { Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr) @@ -1782,7 +1841,7 @@ declare 496 { Tcl_Obj *keyPtr) } declare 497 { - int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr) + int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, void *sizePtr) } declare 498 { int Tcl_DictObjFirst(Tcl_Interp *interp, Tcl_Obj *dictPtr, @@ -1870,10 +1929,10 @@ declare 518 { const char *encodingName) } -# TIP#121 (exit handler) dkf for Joe Mistachkin -declare 519 {nostub {Don't use this function in a stub-enabled extension}} { - Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) -} +# Removed in 9.0 (stub entry only) +#declare 519 {nostub {Don't use this function in a stub-enabled extension}} { +# Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) +#} # TIP#143 (resource limits) dkf declare 520 { @@ -2210,8 +2269,8 @@ declare 603 { # TIP#265 (option parser) dkf for Sam Bromley declare 604 { - int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, - int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) + int TclParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, + void *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) } # TIP#336 (manipulate the error line) dgp @@ -2408,8 +2467,26 @@ declare 648 { # TIP #568 declare 649 { + unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + void *numBytesPtr) +} +declare 650 { unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int *numBytesPtr) + Tcl_Size *numBytesPtr) +} + +# TIP #481 +declare 651 { + char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, Tcl_Size *lengthPtr) +} +declare 652 { + Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, Tcl_Size *lengthPtr) +} + +# TIP 660 +declare 653 { + int Tcl_GetSizeIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + Tcl_Size *sizePtr) } # TIP #575 @@ -2443,24 +2520,51 @@ declare 660 { int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber) } +# TIP #616 +declare 661 { + int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Size *objcPtr, Tcl_Obj ***objvPtr) +} +declare 662 { + int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Size *lengthPtr) +} +declare 663 { + int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size *sizePtr) +} +declare 664 { + int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, Tcl_Size *argcPtr, + const char ***argvPtr) +} +declare 665 { + void Tcl_SplitPath(const char *path, Tcl_Size *argcPtr, const char ***argvPtr) +} +declare 666 { + Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr) +} +declare 667 { + int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, + Tcl_Size *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) +} + # TIP #617 declare 668 { Tcl_Size Tcl_UniCharLen(const int *uniStr) } declare 669 { - Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length) + Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length) } declare 670 { - Tcl_Size TclGetCharLength(Tcl_Obj *objPtr) + Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr) } declare 671 { - const char *TclUtfAtIndex(const char *src, Tcl_Size index) + const char *Tcl_UtfAtIndex(const char *src, Tcl_Size index) } declare 672 { - Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last) + Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last) } declare 673 { - int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index) + int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index) } declare 674 { @@ -2471,6 +2575,28 @@ declare 675 { int Tcl_GetBoolFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr) } +declare 676 { + Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp, + const char *cmdName, + Tcl_ObjCmdProc2 *proc2, void *clientData, + Tcl_CmdDeleteProc *deleteProc) +} +declare 677 { + Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, Tcl_Size level, int flags, + Tcl_CmdObjTraceProc2 *objProc2, void *clientData, + Tcl_CmdObjTraceDeleteProc *delProc) +} +declare 678 { + Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp, + const char *cmdName, Tcl_ObjCmdProc2 *proc, + Tcl_ObjCmdProc2 *nreProc2, void *clientData, + Tcl_CmdDeleteProc *deleteProc) +} +declare 679 { + int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, + void *clientData, Tcl_Size objc, Tcl_Obj *const objv[]) +} + # TIP #638. declare 680 { int Tcl_GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -2503,10 +2629,10 @@ declare 685 { } declare 686 { - int TclUtfNcmp(const char *s1, const char *s2, size_t n) + int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n) } declare 687 { - int TclUtfNcasecmp(const char *s1, const char *s2, size_t n) + int Tcl_UtfNcasecmp(const char *s1, const char *s2, size_t n) } # ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- # @@ -2527,45 +2653,28 @@ interface tclPlat # (none) ################################ -# Windows specific functions - -# Added in Tcl 8.1 - -declare 0 win { - TCHAR *Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr) -} -declare 1 win { - char *Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr) -} -declare 3 win { - void Tcl_WinConvertError(unsigned errCode) -} - -################################ # Mac OS X specific functions -declare 0 macosx { - int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, - const char *bundleName, int hasResourceFile, - Tcl_Size maxPathLen, char *libraryPath) -} -declare 1 macosx { +declare 1 { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath) } -declare 2 macosx { +declare 2 { void Tcl_MacOSXNotifierAddRunLoopMode(const void *runLoopMode) } +################################ +# Windows specific functions +declare 3 { + void Tcl_WinConvertError(unsigned errCode) +} + ############################################################################## # Public functions that are not accessible via the stubs table. export { - void Tcl_Main(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc) -} -export { void Tcl_MainEx(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp) } diff --git a/generic/tcl.h b/generic/tcl.h index 80be1a5..0f53228 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -48,34 +48,18 @@ extern "C" { */ #if !defined(TCL_MAJOR_VERSION) -# define TCL_MAJOR_VERSION 8 +# define TCL_MAJOR_VERSION 9 #endif -#if TCL_MAJOR_VERSION != 8 -# error "This header-file is for Tcl 8 only" -#endif -#define TCL_MINOR_VERSION 7 -#define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE -#define TCL_RELEASE_SERIAL 6 +#if TCL_MAJOR_VERSION == 9 +# define TCL_MINOR_VERSION 0 +# define TCL_RELEASE_LEVEL TCL_BETA_RELEASE +# define TCL_RELEASE_SERIAL 1 -#define TCL_VERSION "8.7" -#define TCL_PATCH_LEVEL "8.7a6" +# define TCL_VERSION "9.0" +# define TCL_PATCH_LEVEL "9.0b1" +#endif /* TCL_MAJOR_VERSION */ -#if !defined(TCL_NO_DEPRECATED) || defined(RC_INVOKED) -/* - *---------------------------------------------------------------------------- - * The following definitions set up the proper options for Windows compilers. - * We use this method because there is no autoconf equivalent. - */ - -#ifdef _WIN32 -# ifndef __WIN32__ -# define __WIN32__ -# endif -# ifndef WIN32 -# define WIN32 -# endif -#endif - +#if defined(RC_INVOKED) /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double * quotation marks), JOIN joins two arguments. @@ -89,11 +73,7 @@ extern "C" { # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif - -#ifndef TCL_THREADS -# define TCL_THREADS 1 -#endif -#endif /* !TCL_NO_DEPRECATED */ +#endif /* RC_INVOKED */ /* * A special definition used to allow this header file to be included from @@ -125,23 +105,6 @@ extern "C" { #include <stdio.h> #include <stddef.h> -/* - *---------------------------------------------------------------------------- - * Support for functions with a variable number of arguments. - * - * The following TCL_VARARGS* macros are to support old extensions - * written for older versions of Tcl where the macros permitted - * support for the varargs.h system as well as stdarg.h . - * - * New code should just directly be written to use stdarg.h conventions. - */ - -#include <stdarg.h> -#ifndef TCL_NO_DEPRECATED -# define TCL_VARARGS(type, name) (type name, ...) -# define TCL_VARARGS_DEF(type, name) (type name, ...) -# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) -#endif /* !TCL_NO_DEPRECATED */ #if defined(__GNUC__) && (__GNUC__ > 2) # if defined(_WIN32) && defined(__USE_MINGW_ANSI_STDIO) && __USE_MINGW_ANSI_STDIO # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__MINGW_PRINTF_FORMAT, a, b))) @@ -150,11 +113,7 @@ extern "C" { # endif # define TCL_NORETURN __attribute__ ((noreturn)) # define TCL_NOINLINE __attribute__ ((noinline)) -# if defined(BUILD_tcl) || defined(BUILD_tk) -# define TCL_NORETURN1 __attribute__ ((noreturn)) -# else -# define TCL_NORETURN1 /* nothing */ -# endif +# define TCL_NORETURN1 __attribute__ ((noreturn)) #else # define TCL_FORMAT_PRINTF(a,b) # if defined(_MSC_VER) @@ -249,33 +208,7 @@ extern "C" { # endif #endif -/* - * The following _ANSI_ARGS_ macro is to support old extensions - * written for older versions of Tcl where it permitted support - * for compilers written in the pre-prototype era of C. - * - * New code should use prototypes. - */ - -#ifndef TCL_NO_DEPRECATED -# undef _ANSI_ARGS_ -# define _ANSI_ARGS_(x) x - -/* - * Definitions that allow this header file to be used either with or without - * ANSI C features. - */ - -#ifndef INLINE -# define INLINE -#endif -#ifndef CONST -# define CONST const -#endif - -#endif /* !TCL_NO_DEPRECATED */ - -#ifndef CONST86 +#if !defined(CONST86) && !defined(TCL_NO_DEPRECATED) # define CONST86 const #endif @@ -294,33 +227,6 @@ extern "C" { #endif /* - *---------------------------------------------------------------------------- - * The following code is copied from winnt.h. If we don't replicate it here, - * then <windows.h> can't be included after tcl.h, since tcl.h also defines - * VOID. This block is skipped under Cygwin and Mingw. - */ - -#ifndef TCL_NO_DEPRECATED -#if defined(_WIN32) -#ifndef VOID -#define VOID void -typedef char CHAR; -typedef short SHORT; -typedef long LONG; -#endif -#endif /* _WIN32 */ - -/* - * Macro to use instead of "void" for arguments that must have type "void *" - * in ANSI C; maps them to type "char *" in non-ANSI systems. - */ - -#ifndef __VXWORKS__ -# define VOID void -#endif -#endif /* !TCL_NO_DEPRECATED */ - -/* * Miscellaneous declarations. */ @@ -449,10 +355,6 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; struct {long tv_sec;} st_mtim; struct {long tv_sec;} st_ctim; } Tcl_StatBuf; -#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) \ - && (!defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64) \ - && (!defined(_TIME_BITS) || _TIME_BITS != 64) - typedef struct stat64 Tcl_StatBuf; #else typedef struct stat Tcl_StatBuf; #endif @@ -460,35 +362,9 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; /* *---------------------------------------------------------------------------- * Data structures defined opaquely in this module. The definitions below just - * provide dummy types. A few fields are made visible in Tcl_Interp - * structures, namely those used for returning a string result from commands. - * Direct access to the result field is discouraged in Tcl 8.0. The - * interpreter result is either an object or a string, and the two values are - * kept consistent unless some C code sets interp->result directly. - * Programmers should use either the function Tcl_GetObjResult() or - * Tcl_GetStringResult() to read the interpreter's result. See the SetResult - * man page for details. - * - * Note: any change to the Tcl_Interp definition below must be mirrored in the - * "real" definition in tclInt.h. - * - * Note: Tcl_ObjCmdProc functions do not directly set result and freeProc. - * Instead, they set a Tcl_Obj member in the "real" structure that can be - * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). + * provide dummy types. */ -typedef struct Tcl_Interp -#ifndef TCL_NO_DEPRECATED -{ - /* TIP #330: Strongly discourage extensions from using the string - * result. */ - char *resultDontUse; /* Don't use in extensions! */ - void (*freeProcDontUse) (char *); /* Don't use in extensions! */ - int errorLineDontUse; /* Don't use in extensions! */ -} -#endif /* !TCL_NO_DEPRECATED */ -Tcl_Interp; - typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; @@ -498,6 +374,7 @@ typedef struct Tcl_Dict_ *Tcl_Dict; typedef struct Tcl_EncodingState_ *Tcl_EncodingState; typedef struct Tcl_Encoding_ *Tcl_Encoding; typedef struct Tcl_Event Tcl_Event; +typedef struct Tcl_Interp Tcl_Interp; typedef struct Tcl_InterpState_ *Tcl_InterpState; typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle; typedef struct Tcl_Mutex_ *Tcl_Mutex; @@ -645,10 +522,6 @@ typedef struct stat *Tcl_OldStat_; #define TCL_BREAK 3 #define TCL_CONTINUE 4 -#ifndef TCL_NO_DEPRECATED -#define TCL_RESULT_SIZE 200 -#endif - /* *---------------------------------------------------------------------------- * Flags to control what substitutions are performed by Tcl_SubstObj(): @@ -660,27 +533,6 @@ typedef struct stat *Tcl_OldStat_; #define TCL_SUBST_ALL 007 /* - * Argument descriptors for math function callbacks in expressions: - */ - -#ifndef TCL_NO_DEPRECATED -typedef enum { - TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT -} Tcl_ValueType; - -typedef struct Tcl_Value { - Tcl_ValueType type; /* Indicates intValue or doubleValue is valid, - * or both. */ - long intValue; /* Integer value. */ - double doubleValue; /* Double-precision floating value. */ - Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */ -} Tcl_Value; -#else -#define Tcl_ValueType void /* Just enough to prevent compilation error in Tcl */ -#define Tcl_Value void /* Just enough to prevent compilation error in Tcl */ -#endif - -/* * Forward declaration of Tcl_Obj to prevent an error when the forward * reference to Tcl_Obj is encountered in the function types declared below. */ @@ -706,7 +558,6 @@ typedef void (Tcl_CmdTraceProc) (void *clientData, Tcl_Interp *interp, typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); -#define Tcl_CmdObjTraceProc2 Tcl_CmdObjTraceProc typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr); @@ -722,16 +573,28 @@ typedef void (Tcl_ExitProc) (void *clientData); typedef void (Tcl_FileProc) (void *clientData, int mask); typedef void (Tcl_FileFreeProc) (void *clientData); typedef void (Tcl_FreeInternalRepProc) (struct Tcl_Obj *objPtr); -typedef void (Tcl_FreeProc) (char *blockPtr); typedef void (Tcl_IdleProc) (void *clientData); typedef void (Tcl_InterpDeleteProc) (void *clientData, Tcl_Interp *interp); -typedef int (Tcl_MathProc) (void *clientData, Tcl_Interp *interp, - Tcl_Value *args, Tcl_Value *resultPtr); typedef void (Tcl_NamespaceDeleteProc) (void *clientData); typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); +#if TCL_MAJOR_VERSION > 8 +typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp, + Tcl_Size objc, struct Tcl_Obj *const *objv); +typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, + Tcl_Size level, const char *command, Tcl_Command commandInfo, Tcl_Size objc, + struct Tcl_Obj *const *objv); +typedef void (Tcl_FreeProc) (void *blockPtr); +#define Tcl_ExitProc Tcl_FreeProc +#define Tcl_FileFreeProc Tcl_FreeProc +#define Tcl_FileFreeProc Tcl_FreeProc +#define Tcl_EncodingFreeProc Tcl_FreeProc +#else #define Tcl_ObjCmdProc2 Tcl_ObjCmdProc +#define Tcl_CmdObjTraceProc2 Tcl_CmdObjTraceProc +typedef void (Tcl_FreeProc) (char *blockPtr); +#endif typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); @@ -753,6 +616,28 @@ typedef void *(Tcl_InitNotifierProc) (void); typedef void (Tcl_FinalizeNotifierProc) (void *clientData); typedef void (Tcl_MainLoopProc) (void); +/* Abstract List functions */ +typedef Tcl_Size (Tcl_ObjTypeLengthProc) (struct Tcl_Obj *listPtr); +typedef int (Tcl_ObjTypeIndexProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + Tcl_Size index, struct Tcl_Obj** elemObj); +typedef int (Tcl_ObjTypeSliceProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + Tcl_Size fromIdx, Tcl_Size toIdx, + struct Tcl_Obj **newObjPtr); +typedef int (Tcl_ObjTypeReverseProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + struct Tcl_Obj **newObjPtr); +typedef int (Tcl_ObjTypeGetElements) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + Tcl_Size *objcptr, struct Tcl_Obj ***objvptr); +typedef struct Tcl_Obj* (Tcl_ObjTypeSetElement) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + Tcl_Size indexCount, + struct Tcl_Obj *const indexArray[], + struct Tcl_Obj *valueObj); +typedef int (Tcl_ObjTypeReplaceProc) (Tcl_Interp *interp, struct Tcl_Obj *listObj, + Tcl_Size first, Tcl_Size numToDelete, + Tcl_Size numToInsert, + struct Tcl_Obj *const insertObjs[]); +typedef int (Tcl_ObjTypeInOperatorProc) (Tcl_Interp *interp, struct Tcl_Obj *valueObj, + struct Tcl_Obj *listObj, int *boolResult); + #ifndef TCL_NO_DEPRECATED # define Tcl_PackageInitProc Tcl_LibraryInitProc # define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc @@ -781,8 +666,40 @@ typedef struct Tcl_ObjType { /* Called to convert the object's internal rep * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ +#if TCL_MAJOR_VERSION > 8 + size_t version; + + /* List emulation functions - ObjType Version 1 */ + Tcl_ObjTypeLengthProc *lengthProc; /* Return the [llength] of the + ** AbstractList */ + Tcl_ObjTypeIndexProc *indexProc; /* Return a value (Tcl_Obj) for + ** [lindex $al $index] */ + Tcl_ObjTypeSliceProc *sliceProc; /* Return an AbstractList for + ** [lrange $al $start $end] */ + Tcl_ObjTypeReverseProc *reverseProc; /* Return an AbstractList for + ** [lreverse $al] */ + Tcl_ObjTypeGetElements *getElementsProc; /* Return an objv[] of all elements in + ** the list */ + Tcl_ObjTypeSetElement *setElementProc; /* Replace the element at the indicie + ** with the given valueObj. */ + Tcl_ObjTypeReplaceProc *replaceProc; /* Replace subset with subset */ + Tcl_ObjTypeInOperatorProc *inOperProc; /* "in" and "ni" expr list + ** operation Determine if the given + ** string value matches an element in + ** the list */ +#endif } Tcl_ObjType; -#define TCL_OBJTYPE_V0 /* just empty */ + +#if TCL_MAJOR_VERSION > 8 +# define TCL_OBJTYPE_V0 0, \ + 0,0,0,0,0,0,0,0 /* Pre-Tcl 9 */ +# define TCL_OBJTYPE_V1(a) offsetof(Tcl_ObjType, indexProc), \ + a,0,0,0,0,0,0,0 /* Tcl 9 Version 1 */ +# define TCL_OBJTYPE_V2(a,b,c,d,e,f,g,h) sizeof(Tcl_ObjType), \ + a,b,c,d,e,f,g,h /* Tcl 9 - AbstractLists */ +#else +# define TCL_OBJTYPE_V0 /* just empty */ +#endif /* * The following structure stores an internal representation (internalrep) for @@ -820,7 +737,7 @@ typedef struct Tcl_Obj { * must be followed by a null byte (i.e., at * offset length) but may also contain * embedded null characters. The array's - * storage is allocated by ckalloc. NULL means + * storage is allocated by Tcl_Alloc. NULL means * the string rep is invalid and must be * regenerated from the internal rep. Clients * should use Tcl_GetStringFromObj or @@ -838,25 +755,6 @@ typedef struct Tcl_Obj { /* *---------------------------------------------------------------------------- - * The following structure contains the state needed by Tcl_SaveResult. No-one - * outside of Tcl should access any of these fields. This structure is - * typically allocated on the stack. - */ - -#ifndef TCL_NO_DEPRECATED -typedef struct Tcl_SavedResult { - char *result; - Tcl_FreeProc *freeProc; - Tcl_Obj *objResultPtr; - char *appendResult; - int appendAvl; - int appendUsed; - char resultSpace[200+1]; -} Tcl_SavedResult; -#endif - -/* - *---------------------------------------------------------------------------- * The following definitions support Tcl's namespace facility. Note: the first * five fields must match exactly the fields in a Namespace structure (see * tclInt.h). @@ -935,7 +833,7 @@ typedef struct Tcl_CallFrame { * then calls the other function. */ -typedef struct Tcl_CmdInfo { +typedef struct { int isNativeObjectProc; /* 1 if objProc was registered by a call to * Tcl_CreateObjCommand; 2 if objProc was registered by * a call to Tcl_CreateObjCommand2; 0 otherwise. @@ -954,8 +852,8 @@ typedef struct Tcl_CmdInfo { * change a command's namespace; use * TclRenameCommand or Tcl_Eval (of 'rename') * to do that. */ - Tcl_ObjCmdProc2 *objProc2; /* Not used in Tcl 8.7. */ - void *objClientData2; /* Not used in Tcl 8.7. */ + Tcl_ObjCmdProc2 *objProc2; /* Command's object2-based function. */ + void *objClientData2; /* ClientData for object2 proc. */ } Tcl_CmdInfo; /* @@ -969,8 +867,8 @@ typedef struct Tcl_CmdInfo { typedef struct Tcl_DString { char *string; /* Points to beginning of string: either * staticSpace below or a malloced array. */ - Tcl_Size length; /* Number of non-NULL characters in the - * string. */ + Tcl_Size length; /* Number of bytes in string excluding + * terminating nul */ Tcl_Size spaceAvl; /* Total number of bytes available for the * string and its terminating NULL char. */ char staticSpace[TCL_DSTRING_STATIC_SIZE]; @@ -980,9 +878,6 @@ typedef struct Tcl_DString { #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) -#ifndef TCL_NO_DEPRECATED -# define Tcl_DStringTrunc Tcl_DStringSetLength -#endif /* * Definitions for the maximum number of digits of precision that may be @@ -1043,7 +938,7 @@ typedef struct Tcl_DString { /* * Flags that may be passed to Tcl_UniCharToUtf. - * TCL_COMBINE Combine surrogates (default in Tcl 8.x) + * TCL_COMBINE Combine surrogates */ #if TCL_MAJOR_VERSION > 8 @@ -1104,16 +999,8 @@ typedef struct Tcl_DString { #define TCL_TRACE_UNSETS 0x40 #define TCL_TRACE_DESTROYED 0x80 -#ifndef TCL_NO_DEPRECATED -#define TCL_INTERP_DESTROYED 0x100 -#endif - #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 -#ifndef TCL_NO_DEPRECATED -/* Required to support old variable/vdelete/vinfo traces. */ -#define TCL_TRACE_OLD_STYLE 0x1000 -#endif /* Indicate the semantics of the result of a trace. */ #define TCL_TRACE_RESULT_DYNAMIC 0x8000 #define TCL_TRACE_RESULT_OBJECT 0x10000 @@ -1136,17 +1023,6 @@ typedef struct Tcl_DString { #define TCL_ALLOW_INLINE_COMPILATION 0x20000 /* - * The TCL_PARSE_PART1 flag is deprecated and has no effect. The part1 is now - * always parsed whenever the part2 is NULL. (This is to avoid a common error - * when converting code to use the new object based APIs and forgetting to - * give the flag) - */ - -#ifndef TCL_NO_DEPRECATED -# define TCL_PARSE_PART1 0x400 -#endif - -/* * Types for linked variables: */ @@ -1160,13 +1036,8 @@ typedef struct Tcl_DString { #define TCL_LINK_SHORT 8 #define TCL_LINK_USHORT 9 #define TCL_LINK_UINT 10 -#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__) #define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT) #define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT) -#else -#define TCL_LINK_LONG 11 -#define TCL_LINK_ULONG 12 -#endif #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 #define TCL_LINK_CHARS 15 @@ -1205,9 +1076,7 @@ struct Tcl_HashEntry { Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket, * or NULL for end of chain. */ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ - void *hash; /* Hash value, stored as pointer to ensure - * that the offsets of the fields in this - * structure are not changed. */ + size_t hash; /* Hash value. */ void *clientData; /* Application stores something here with * Tcl_SetHashValue. */ union { /* Key has one of these forms: */ @@ -1428,12 +1297,20 @@ typedef enum { */ typedef struct Tcl_Time { +#if TCL_MAJOR_VERSION > 8 + long long sec; /* Seconds. */ +#else long sec; /* Seconds. */ +#endif +#if defined(_CYGWIN_) && TCL_MAJOR_VERSION > 8 + int usec; /* Microseconds. */ +#else long usec; /* Microseconds. */ +#endif } Tcl_Time; -typedef void (Tcl_SetTimerProc) (CONST86 Tcl_Time *timePtr); -typedef int (Tcl_WaitForEventProc) (CONST86 Tcl_Time *timePtr); +typedef void (Tcl_SetTimerProc) (const Tcl_Time *timePtr); +typedef int (Tcl_WaitForEventProc) (const Tcl_Time *timePtr); /* * TIP #233 (Virtualized Time) @@ -1479,19 +1356,13 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData); #if TCL_MAJOR_VERSION > 8 # define TCL_CLOSE2PROC NULL #else -# define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)(void *)(size_t)1) +# define TCL_CLOSE2PROC ((void *) 1) #endif /* * Channel version tag. This was introduced in 8.3.2/8.4. */ -#ifndef TCL_NO_DEPRECATED -#define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1) -#define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2) -#define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3) -#define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4) -#endif #define TCL_CHANNEL_VERSION_5 ((Tcl_ChannelTypeVersion) 0x5) /* @@ -1506,16 +1377,14 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData); */ typedef int (Tcl_DriverBlockModeProc) (void *instanceData, int mode); -typedef int (Tcl_DriverCloseProc) (void *instanceData, - Tcl_Interp *interp); +typedef void Tcl_DriverCloseProc; typedef int (Tcl_DriverClose2Proc) (void *instanceData, Tcl_Interp *interp, int flags); typedef int (Tcl_DriverInputProc) (void *instanceData, char *buf, int toRead, int *errorCodePtr); typedef int (Tcl_DriverOutputProc) (void *instanceData, const char *buf, int toWrite, int *errorCodePtr); -typedef int (Tcl_DriverSeekProc) (void *instanceData, long offset, - int mode, int *errorCodePtr); +typedef void Tcl_DriverSeekProc; typedef int (Tcl_DriverSetOptionProc) (void *instanceData, Tcl_Interp *interp, const char *optionName, const char *value); @@ -1558,17 +1427,12 @@ typedef struct Tcl_ChannelType { * type. */ Tcl_ChannelTypeVersion version; /* Version of the channel type. */ - Tcl_DriverCloseProc *closeProc; - /* Function to call to close the channel, or - * NULL or TCL_CLOSE2PROC if the close2Proc should be - * used instead. */ + void *closeProc; /* Not used any more. */ Tcl_DriverInputProc *inputProc; /* Function to call for input on channel. */ Tcl_DriverOutputProc *outputProc; /* Function to call for output on channel. */ - Tcl_DriverSeekProc *seekProc; - /* Function to call to seek on the channel. - * May be NULL. */ + void *seekProc; /* Not used any more. */ Tcl_DriverSetOptionProc *setOptionProc; /* Set an option on a channel. */ Tcl_DriverGetOptionProc *getOptionProc; @@ -1586,9 +1450,6 @@ typedef struct Tcl_ChannelType { Tcl_DriverBlockModeProc *blockModeProc; /* Set blocking mode for the raw channel. May * be NULL. */ - /* - * Only valid in TCL_CHANNEL_VERSION_2 channels or later. - */ Tcl_DriverFlushProc *flushProc; /* Function to call to flush a channel. May be * NULL. */ @@ -1596,26 +1457,15 @@ typedef struct Tcl_ChannelType { /* Function to call to handle a channel event. * This will be passed up the stacked channel * chain. */ - /* - * Only valid in TCL_CHANNEL_VERSION_3 channels or later. - */ Tcl_DriverWideSeekProc *wideSeekProc; /* Function to call to seek on the channel * which can handle 64-bit offsets. May be * NULL, and must be NULL if seekProc is * NULL. */ - /* - * Only valid in TCL_CHANNEL_VERSION_4 channels or later. - * TIP #218, Channel Thread Actions. - */ Tcl_DriverThreadActionProc *threadActionProc; /* Function to call to notify the driver of * thread specific activity for a channel. May * be NULL. */ - /* - * Only valid in TCL_CHANNEL_VERSION_5 channels or later. - * TIP #208, File Truncation. - */ Tcl_DriverTruncateProc *truncateProc; /* Function to call to truncate the underlying * file to a particular length. May be NULL if @@ -1711,7 +1561,7 @@ typedef int (Tcl_FSNormalizePathProc) (Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); typedef int (Tcl_FSFileAttrsGetProc) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); -typedef const char *CONST86 * (Tcl_FSFileAttrStringsProc) (Tcl_Obj *pathPtr, +typedef const char *const * (Tcl_FSFileAttrStringsProc) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); typedef int (Tcl_FSFileAttrsSetProc) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); @@ -1723,7 +1573,7 @@ typedef int (Tcl_FSPathInFilesystemProc) (Tcl_Obj *pathPtr, void **clientDataPtr); typedef Tcl_Obj * (Tcl_FSFilesystemPathTypeProc) (Tcl_Obj *pathPtr); typedef Tcl_Obj * (Tcl_FSFilesystemSeparatorProc) (Tcl_Obj *pathPtr); -typedef void (Tcl_FSFreeInternalRepProc) (void *clientData); +#define Tcl_FSFreeInternalRepProc Tcl_FreeProc typedef void *(Tcl_FSDupInternalRepProc) (void *clientData); typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) (void *clientData); typedef void *(Tcl_FSCreateInternalRepProc) (Tcl_Obj *pathPtr); @@ -2106,7 +1956,7 @@ typedef struct Tcl_EncodingType { Tcl_EncodingConvertProc *fromUtfProc; /* Function to convert from UTF-8 into * external encoding. */ - Tcl_EncodingFreeProc *freeProc; + Tcl_FreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ void *clientData; /* Arbitrary value associated with encoding @@ -2138,14 +1988,7 @@ typedef struct Tcl_EncodingType { * reset to an initial state. If the source * buffer contains the entire input stream to be * converted, this flag should be set. - * TCL_ENCODING_STOPONERROR - If set, the converter returns immediately upon - * encountering an invalid byte sequence or a - * source character that has no mapping in the - * target encoding. If clear, the converter - * substitutes the problematic character(s) with - * one or more "close" characters in the - * destination buffer and then continues to - * convert the source. Only for Tcl 8.x. + * TCL_ENCODING_STOPONERROR - Not used any more. * TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a * terminating NUL byte. Since it does not need * an extra byte for a terminating NUL, it fills @@ -2170,7 +2013,11 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 -#define TCL_ENCODING_STOPONERROR 0x04 +#if TCL_MAJOR_VERSION > 8 +# define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */ +#else +# define TCL_ENCODING_STOPONERROR 0x04 +#endif #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 /* Internal use bits, do not define bits in this space. See above comment */ @@ -2203,13 +2050,10 @@ typedef struct Tcl_EncodingType { * TCL_CONVERT_SYNTAX - The source stream contained an invalid * character sequence. This may occur if the * input stream has been damaged or if the input - * encoding method was misidentified. This error - * is reported only if TCL_ENCODING_STOPONERROR - * was specified. + * encoding method was misidentified. * TCL_CONVERT_UNKNOWN - The source string contained a character that * could not be represented in the target - * encoding. This error is reported only if - * TCL_ENCODING_STOPONERROR was specified. + * encoding. */ #define TCL_CONVERT_MULTIBYTE (-1) @@ -2220,12 +2064,13 @@ typedef struct Tcl_EncodingType { /* * The maximum number of bytes that are necessary to represent a single * Unicode character in UTF-8. The valid values are 3 and 4. If > 3, - * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default for the - * Tcl core). If == 3, then Tcl_UniChar must be 2-bytes in size (UTF-16). + * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default). If == 3, + * then Tcl_UniChar must be 2-bytes in size (UTF-16). Since Tcl 9.0, UCS-4 + * mode is the default and recommended mode. */ #ifndef TCL_UTF_MAX -# ifdef BUILD_tcl +# if TCL_MAJOR_VERSION > 8 # define TCL_UTF_MAX 4 # else # define TCL_UTF_MAX 3 @@ -2278,7 +2123,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 /* @@ -2452,28 +2301,50 @@ const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version, int exact, int magic); const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); +const char * TclInitStubTable(const char *version); +void * TclStubCall(void *arg); #if defined(_WIN32) - TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...); + TCL_NORETURN1 void Tcl_ConsolePanic(const char *format, ...); #else -# define Tcl_ConsolePanic ((Tcl_PanicProc *)NULL) +# define Tcl_ConsolePanic NULL #endif #ifdef USE_TCL_STUBS +#if TCL_MAJOR_VERSION < 9 # if TCL_UTF_MAX < 4 # define Tcl_InitStubs(interp, version, exact) \ (Tcl_InitStubs)(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + (exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \ TCL_STUB_MAGIC) # else # define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + (Tcl_InitStubs)(interp, "8.7.0", \ + (exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \ TCL_STUB_MAGIC) # endif +#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + TCL_STUB_MAGIC) +#else +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + TCL_STUB_MAGIC) +#endif #else +#if TCL_MAJOR_VERSION < 9 +# error "Please define -DUSE_TCL_STUBS" +#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE # define Tcl_InitStubs(interp, version, exact) \ Tcl_PkgInitStubsCheck(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#else +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#endif #endif /* @@ -2482,22 +2353,65 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ - ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)())) -EXTERN void Tcl_MainEx(Tcl_Size argc, char **argv, + ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp()))) +EXTERN TCL_NORETURN void Tcl_MainEx(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN const char * Tcl_InitSubsystems(void); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); +EXTERN const char * Tcl_FindExecutable(const char *argv0); EXTERN const char * Tcl_SetPreInitScript(const char *string); +EXTERN const char * Tcl_SetPanicProc( + TCL_NORETURN1 Tcl_PanicProc *panicProc); +EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp, + const char *prefix, + Tcl_LibraryInitProc *initProc, + Tcl_LibraryInitProc *safeInitProc); #ifndef TCL_NO_DEPRECATED # define Tcl_StaticPackage Tcl_StaticLibrary #endif +EXTERN Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); #ifdef _WIN32 EXTERN const char *TclZipfs_AppHook(int *argc, wchar_t ***argv); #else EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); #endif +#if defined(_WIN32) && defined(UNICODE) +#ifndef USE_TCL_STUBS +# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) +#endif +# define Tcl_MainEx Tcl_MainExW + EXTERN TCL_NORETURN void Tcl_MainExW(Tcl_Size argc, wchar_t **argv, + Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); +#endif +#if defined(USE_TCL_STUBS) && (TCL_MAJOR_VERSION > 8) +#define Tcl_SetPanicProc(panicProc) \ + TclInitStubTable(((const char *(*)(Tcl_PanicProc *))TclStubCall((void *)panicProc))(panicProc)) +#define Tcl_InitSubsystems() \ + TclInitStubTable(((const char *(*)(void))TclStubCall((void *)1))()) +#define Tcl_FindExecutable(argv0) \ + TclInitStubTable(((const char *(*)(const char *))TclStubCall((void *)2))(argv0)) +#define TclZipfs_AppHook(argcp, argvp) \ + TclInitStubTable(((const char *(*)(int *, void *))TclStubCall((void *)3))(argcp, argvp)) +#define Tcl_MainExW(argc, argv, appInitProc, interp) \ + (void)((const char *(*)(Tcl_Size, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ + TclStubCall((void *)4))(argc, argv, appInitProc, interp) +#if !defined(_WIN32) || !defined(UNICODE) +#define Tcl_MainEx(argc, argv, appInitProc, interp) \ + (void)((const char *(*)(Tcl_Size, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ + TclStubCall((void *)5))(argc, argv, appInitProc, interp) +#endif +#define Tcl_StaticLibrary(interp, pkgName, initProc, safeInitProc) \ + (void)((const char *(*)(Tcl_Interp *, const char *, Tcl_LibraryInitProc *, Tcl_LibraryInitProc *)) \ + TclStubCall((void *)6))(interp, pkgName, initProc, safeInitProc) +#define Tcl_SetExitProc(proc) \ + ((Tcl_ExitProc *(*)(Tcl_ExitProc *))TclStubCall((void *)7))(proc) +#define Tcl_GetMemoryInfo(dsPtr) \ + (void)((const char *(*)(Tcl_DString *))TclStubCall((void *)8))(dsPtr) +#define Tcl_SetPreInitScript(string) \ + ((const char *(*)(const char *))TclStubCall((void *)9))(string) +#endif /* *---------------------------------------------------------------------------- @@ -2522,25 +2436,26 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); /* *---------------------------------------------------------------------------- - * The following declarations either map ckalloc and ckfree to malloc and - * free, or they map them to functions with all sorts of debugging hooks - * defined in tclCkalloc.c. - */ - -#ifdef TCL_MEM_DEBUG - -# define ckalloc(x) \ - ((void *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__)) -# define ckfree(x) \ - Tcl_DbCkfree((char *)(x), __FILE__, __LINE__) -# define ckrealloc(x,y) \ - ((void *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) -# define attemptckalloc(x) \ - ((void *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__)) -# define attemptckrealloc(x,y) \ - ((void *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) + * The following declarations map ckalloc and ckfree to Tcl_Alloc and + * Tcl_Free for use in Tcl-8.x-compatible extensions. + */ + +#ifndef BUILD_tcl +# define ckalloc Tcl_Alloc +# define attemptckalloc Tcl_AttemptAlloc +# ifdef _MSC_VER + /* Silence invalid C4090 warnings */ +# define ckfree(a) Tcl_Free((void *)(a)) +# define ckrealloc(a,b) Tcl_Realloc((void *)(a),(b)) +# define attemptckrealloc(a,b) Tcl_AttemptRealloc((void *)(a),(b)) +# else +# define ckfree Tcl_Free +# define ckrealloc Tcl_Realloc +# define attemptckrealloc Tcl_AttemptRealloc +# endif +#endif -#else /* !TCL_MEM_DEBUG */ +#ifndef TCL_MEM_DEBUG /* * If we are not using the debugging allocator, we should call the Tcl_Alloc, @@ -2548,16 +2463,6 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); * memory allocator both inside and outside of the Tcl library. */ -# define ckalloc(x) \ - ((void *) Tcl_Alloc((unsigned)(x))) -# define ckfree(x) \ - Tcl_Free((char *)(x)) -# define ckrealloc(x,y) \ - ((void *) Tcl_Realloc((char *)(x), (unsigned)(y))) -# define attemptckalloc(x) \ - ((void *) Tcl_AttemptAlloc((unsigned)(x))) -# define attemptckrealloc(x,y) \ - ((void *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y))) # undef Tcl_InitMemory # define Tcl_InitMemory(x) # undef Tcl_DumpActiveMemory @@ -2577,10 +2482,29 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); # undef Tcl_IsShared # define Tcl_IsShared(objPtr) \ Tcl_DbIsShared(objPtr, __FILE__, __LINE__) +/* + * Free the Obj by effectively doing: + * + * Tcl_IncrRefCount(objPtr); + * Tcl_DecrRefCount(objPtr); + * + * This will free the obj if there are no references to the obj. + */ +# define Tcl_BounceRefCount(objPtr) \ + TclBounceRefCount(objPtr, __FILE__, __LINE__) + +static inline void TclBounceRefCount(Tcl_Obj* objPtr, const char* fn, int line) +{ + if (objPtr) { + if ((objPtr)->refCount == 0) { + Tcl_DbDecrRefCount(objPtr, fn, line); + } + } +} #else # undef Tcl_IncrRefCount # define Tcl_IncrRefCount(objPtr) \ - ++(objPtr)->refCount + ((void)++(objPtr)->refCount) /* * Use do/while0 idiom for optimum correctness without compiler warnings. * https://wiki.c2.com/?TrivialDoWhileLoop @@ -2596,6 +2520,24 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); # undef Tcl_IsShared # define Tcl_IsShared(objPtr) \ ((objPtr)->refCount > 1) + +/* + * Declare that obj will no longer be used or referenced. + * This will release the obj if there is no referece count, + * otherwise let it be. + */ +# define Tcl_BounceRefCount(objPtr) \ + TclBounceRefCount(objPtr); + +static inline void TclBounceRefCount(Tcl_Obj* objPtr) +{ + if (objPtr) { + if ((objPtr)->refCount == 0) { + Tcl_DecrRefCount(objPtr); + } + } +} + #endif /* @@ -2656,38 +2598,6 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) -/* - *---------------------------------------------------------------------------- - * Deprecated Tcl functions: - */ - -#ifndef TCL_NO_DEPRECATED -/* - * These function have been renamed. The old names are deprecated, but we - * define these macros for backwards compatibility. - */ - -# define Tcl_Ckalloc Tcl_Alloc -# define Tcl_Ckfree Tcl_Free -# define Tcl_Ckrealloc Tcl_Realloc -# define Tcl_Return Tcl_SetResult -# define Tcl_TildeSubst Tcl_TranslateFileName -#if !defined(__APPLE__) /* On OSX, there is a conflict with "mach/mach.h" */ -# define panic Tcl_Panic -#endif -# define panicVA Tcl_PanicVA - -/* - *---------------------------------------------------------------------------- - * Convenience declaration of Tcl_AppInit for backwards compatibility. This - * function is not *implemented* by the tcl library, so the storage class is - * neither DLLEXPORT nor DLLIMPORT. - */ - -extern Tcl_AppInitProc Tcl_AppInit; - -#endif /* !TCL_NO_DEPRECATED */ - #endif /* RC_INVOKED */ /* diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 800b0ae..3c4fac3 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -251,11 +251,11 @@ TclFinalizeAllocSubsystem(void) void * TclpAlloc( - unsigned int numBytes) /* Number of bytes to allocate. */ + size_t numBytes) /* Number of bytes to allocate. */ { union overhead *overPtr; size_t bucket; - unsigned amount; + size_t amount; struct block *bigBlockPtr = NULL; if (!allocInit) { @@ -274,8 +274,8 @@ TclpAlloc( if (numBytes >= MAXMALLOC - OVERHEAD) { if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) { - bigBlockPtr = (struct block *) TclpSysAlloc( - sizeof(struct block) + OVERHEAD + numBytes, 0); + bigBlockPtr = TclpSysAlloc( + sizeof(struct block) + OVERHEAD + numBytes); } if (bigBlockPtr == NULL) { Tcl_MutexUnlock(allocMutexPtr); @@ -304,7 +304,7 @@ TclpAlloc( #endif Tcl_MutexUnlock(allocMutexPtr); - return (char *)(overPtr+1); + return (void *)(overPtr+1); } /* @@ -405,8 +405,7 @@ MoreCore( numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = (struct block *) TclpSysAlloc( - (sizeof(struct block) + amount), 1); + blockPtr = TclpSysAlloc(sizeof(struct block) + amount); /* no more room! */ if (blockPtr == NULL) { return; @@ -512,7 +511,7 @@ TclpFree( void * TclpRealloc( void *oldPtr, /* Pointer to alloc'ed block. */ - unsigned int numBytes) /* New size of memory. */ + size_t numBytes) /* New size of memory. */ { int i; union overhead *overPtr; @@ -692,9 +691,10 @@ mstats( *---------------------------------------------------------------------- */ +#undef TclpAlloc void * TclpAlloc( - unsigned int numBytes) /* Number of bytes to allocate. */ + size_t numBytes) /* Number of bytes to allocate. */ { return malloc(numBytes); } @@ -715,6 +715,7 @@ TclpAlloc( *---------------------------------------------------------------------- */ +#undef TclpFree void TclpFree( void *oldPtr) /* Pointer to memory to free. */ @@ -742,7 +743,7 @@ TclpFree( void * TclpRealloc( void *oldPtr, /* Pointer to alloced block. */ - unsigned int numBytes) /* New size of memory. */ + size_t numBytes) /* New size of memory. */ { return realloc(oldPtr, numBytes); } diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 34fd635..1a244db 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -10,6 +10,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include "tcl.h" #include "tclInt.h" #include <assert.h> #include <math.h> @@ -66,18 +67,36 @@ typedef struct { /* -------------------------- ArithSeries object ---------------------------- */ +static int TclArithSeriesObjIndex(TCL_UNUSED(Tcl_Interp *), Tcl_Obj *arithSeriesObj, + Tcl_Size index, Tcl_Obj **elemObj); + +static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj); +static int TclArithSeriesObjRange(Tcl_Interp *interp, Tcl_Obj *arithSeriesObj, + Tcl_Size fromIdx, Tcl_Size toIdx, Tcl_Obj **newObjPtr); +static int TclArithSeriesObjReverse(Tcl_Interp *interp, Tcl_Obj *arithSeriesObj, Tcl_Obj **newObjPtr); +static int TclArithSeriesGetElements(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); static void DupArithSeriesInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr); static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr); static int SetArithSeriesFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj); - -const Tcl_ObjType tclArithSeriesType = { +static int ArithSeriesInOperation(Tcl_Interp *interp, Tcl_Obj *valueObj, Tcl_Obj *arithSeriesObj, + int *boolResult); +static const Tcl_ObjType arithSeriesType = { "arithseries", /* name */ FreeArithSeriesInternalRep, /* freeIntRepProc */ DupArithSeriesInternalRep, /* dupIntRepProc */ UpdateStringOfArithSeries, /* updateStringProc */ - SetArithSeriesFromAny /* setFromAnyProc */ + SetArithSeriesFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V2( + ArithSeriesObjLength, + TclArithSeriesObjIndex, + TclArithSeriesObjRange, + TclArithSeriesObjReverse, + TclArithSeriesGetElements, + NULL, // SetElement + NULL, // Replace + ArithSeriesInOperation) // "in" operator }; /* @@ -131,7 +150,7 @@ static inline ArithSeries* ArithSeriesGetInternalRep(Tcl_Obj *objPtr) { const Tcl_ObjInternalRep *irPtr; - irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType); + irPtr = TclFetchInternalRep((objPtr), &arithSeriesType); return irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; } @@ -162,6 +181,7 @@ maxPrecision(double start, double end, double step) return dp; } +static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesObj, Tcl_Obj **stepObj); /* *---------------------------------------------------------------------- @@ -236,8 +256,7 @@ DupArithSeriesInternalRep( Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { ArithSeries *srcArithSeriesRepPtr = - (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1; - + (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1; /* * Allocate a new ArithSeries structure. */ @@ -245,19 +264,19 @@ DupArithSeriesInternalRep( ArithSeriesDbl *srcArithSeriesDblRepPtr = (ArithSeriesDbl *)srcArithSeriesRepPtr; ArithSeriesDbl *copyArithSeriesDblRepPtr = - (ArithSeriesDbl *) ckalloc(sizeof(ArithSeriesDbl)); + (ArithSeriesDbl *) Tcl_Alloc(sizeof(ArithSeriesDbl)); *copyArithSeriesDblRepPtr = *srcArithSeriesDblRepPtr; copyArithSeriesDblRepPtr->elements = NULL; copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesDblRepPtr; } else { ArithSeries *copyArithSeriesRepPtr = - (ArithSeries *)ckalloc(sizeof(ArithSeries)); + (ArithSeries *) Tcl_Alloc(sizeof(ArithSeries)); *copyArithSeriesRepPtr = *srcArithSeriesRepPtr; copyArithSeriesRepPtr->elements = NULL; copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; } copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclArithSeriesType; + copyPtr->typePtr = &arithSeriesType; } /* @@ -277,18 +296,19 @@ DupArithSeriesInternalRep( static void FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated memory */ { - ArithSeries *arithSeriesRepPtr = - (ArithSeries *)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; + ArithSeries *arithSeriesRepPtr = (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; - if (arithSeriesRepPtr->elements) { - Tcl_Size i; - for(i=0; i<arithSeriesRepPtr->len; i++) { - Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]); + if (arithSeriesRepPtr) { + if (arithSeriesRepPtr->elements) { + Tcl_WideInt i, len = arithSeriesRepPtr->len; + for (i=0; i<len; i++) { + Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]); + } + Tcl_Free((char*)arithSeriesRepPtr->elements); + arithSeriesRepPtr->elements = NULL; } - ckfree((char *)arithSeriesRepPtr->elements); - arithSeriesRepPtr->elements = NULL; + Tcl_Free((char*)arithSeriesRepPtr); } - ckfree((char *)arithSeriesRepPtr); } @@ -327,7 +347,7 @@ NewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_Wide return arithSeriesObj; } - arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries)); + arithSeriesRepPtr = (ArithSeries*) Tcl_Alloc(sizeof (ArithSeries)); arithSeriesRepPtr->isDouble = 0; arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; @@ -336,7 +356,7 @@ NewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_Wide arithSeriesRepPtr->elements = NULL; arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesObj->typePtr = &tclArithSeriesType; + arithSeriesObj->typePtr = &arithSeriesType; if (length > 0) Tcl_InvalidateStringRep(arithSeriesObj); @@ -381,7 +401,7 @@ NewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) return arithSeriesObj; } - arithSeriesRepPtr = (ArithSeriesDbl*) ckalloc(sizeof (ArithSeriesDbl)); + arithSeriesRepPtr = (ArithSeriesDbl*) Tcl_Alloc(sizeof (ArithSeriesDbl)); arithSeriesRepPtr->isDouble = 1; arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; @@ -391,7 +411,7 @@ NewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) arithSeriesRepPtr->precision = maxPrecision(start,end,step); arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesObj->typePtr = &tclArithSeriesType; + arithSeriesObj->typePtr = &arithSeriesType; if (length > 0) { Tcl_InvalidateStringRep(arithSeriesObj); @@ -564,40 +584,43 @@ TclNewArithSeriesObj( * * Returns the element with the specified index in the list * represented by the specified Arithmetic Sequence object. - * If the index is out of range, NULL is returned. + * If the index is out of range, TCL_ERROR is returned, + * otherwise TCL_OK is returned and the integer value of the + * element is stored in *element. * * Results: * - * The element on success, NULL on index out of range. + * TCL_OK on success. * * Side Effects: * * On success, the integer pointed by *element is modified. + * An empty string ("") is assigned if index is out-of-bounds. * *---------------------------------------------------------------------- */ -Tcl_Obj * +int TclArithSeriesObjIndex( - TCL_UNUSED(Tcl_Interp *), - Tcl_Obj *arithSeriesObj, - Tcl_Size index) + TCL_UNUSED(Tcl_Interp *),/* Used for error reporting if not NULL. */ + Tcl_Obj *arithSeriesObj, /* List obj */ + Tcl_Size index, /* index to element of interest */ + Tcl_Obj **elemObj) /* Return value */ { - ArithSeries *arithSeriesRepPtr; + ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); - if (arithSeriesObj->typePtr != &tclArithSeriesType) { - Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); - } - arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); - if (index < 0 || index >= arithSeriesRepPtr->len) { - return Tcl_NewObj(); - } - /* List[i] = Start + (Step * index) */ - if (arithSeriesRepPtr->isDouble) { - return Tcl_NewDoubleObj(ArithSeriesIndexDbl(arithSeriesRepPtr, index)); + if (index < 0 || arithSeriesRepPtr->len <= index) { + *elemObj = NULL; } else { - return Tcl_NewWideIntObj(ArithSeriesIndexInt(arithSeriesRepPtr, index)); + /* List[i] = Start + (Step * index) */ + if (arithSeriesRepPtr->isDouble) { + *elemObj = Tcl_NewDoubleObj(ArithSeriesIndexDbl(arithSeriesRepPtr, index)); + } else { + *elemObj = Tcl_NewWideIntObj(ArithSeriesIndexInt(arithSeriesRepPtr, index)); + } } + + return TCL_OK; } /* @@ -617,7 +640,7 @@ TclArithSeriesObjIndex( * *---------------------------------------------------------------------- */ -Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj) +Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj) { ArithSeries *arithSeriesRepPtr = (ArithSeries*) arithSeriesObj->internalRep.twoPtrValue.ptr1; @@ -627,7 +650,7 @@ Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj) /* *---------------------------------------------------------------------- * - * ArithSeriesObjStep -- + * TclArithSeriesObjStep -- * * Return a Tcl_Obj with the step value from the give ArithSeries Obj. * refcount = 0. @@ -642,23 +665,19 @@ Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj) * None. *---------------------------------------------------------------------- */ -Tcl_Obj * -ArithSeriesObjStep( - Tcl_Obj *arithSeriesObj) -{ - ArithSeries *arithSeriesRepPtr; - Tcl_Obj *stepObj; - if (arithSeriesObj->typePtr != &tclArithSeriesType) { - Tcl_Panic("ArithSeriesObjStep called with a not ArithSeries Obj."); - } - arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); +int +TclArithSeriesObjStep( + Tcl_Obj *arithSeriesObj, + Tcl_Obj **stepObj) +{ + ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); if (arithSeriesRepPtr->isDouble) { - TclNewDoubleObj(stepObj, ((ArithSeriesDbl*)(arithSeriesRepPtr))->step); + *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step); } else { - TclNewIntObj(stepObj, arithSeriesRepPtr->step); + *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); } - return stepObj; + return TCL_OK; } /* @@ -711,28 +730,33 @@ SetArithSeriesFromAny( *---------------------------------------------------------------------- */ -Tcl_Obj * +int TclArithSeriesObjRange( Tcl_Interp *interp, /* For error message(s) */ Tcl_Obj *arithSeriesObj, /* List object to take a range from. */ Tcl_Size fromIdx, /* Index of first element to include. */ - Tcl_Size toIdx) /* Index of last element to include. */ + Tcl_Size toIdx, /* Index of last element to include. */ + Tcl_Obj **newObjPtr) /* return value */ { ArithSeries *arithSeriesRepPtr; Tcl_Obj *startObj, *endObj, *stepObj; + (void)interp; /* silence compiler */ + arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); - if (fromIdx < TCL_INDEX_NONE) { + if (fromIdx == TCL_INDEX_NONE) { fromIdx = 0; } + if (toIdx >= arithSeriesRepPtr->len) { + toIdx = arithSeriesRepPtr->len-1; + } + if (fromIdx > toIdx || - (toIdx > arithSeriesRepPtr->len-1 && - fromIdx > arithSeriesRepPtr->len-1)) { - Tcl_Obj *obj; - TclNewObj(obj); - return obj; + fromIdx >= arithSeriesRepPtr->len) { + TclNewObj(*newObjPtr); + return TCL_OK; } if (fromIdx < 0) { @@ -745,31 +769,22 @@ TclArithSeriesObjRange( toIdx = arithSeriesRepPtr->len-1; } - startObj = TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx); - if (startObj == NULL) { - return NULL; - } + TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj); Tcl_IncrRefCount(startObj); - endObj = TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx); - if (endObj == NULL) { - return NULL; - } + TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj); Tcl_IncrRefCount(endObj); - stepObj = ArithSeriesObjStep(arithSeriesObj); + TclArithSeriesObjStep(arithSeriesObj, &stepObj); Tcl_IncrRefCount(stepObj); if (Tcl_IsShared(arithSeriesObj) || ((arithSeriesObj->refCount > 1))) { - Tcl_Obj *newSlicePtr; - if (TclNewArithSeriesObj(interp, &newSlicePtr, - arithSeriesRepPtr->isDouble, startObj, endObj, - stepObj, NULL) != TCL_OK) { - newSlicePtr = NULL; - } + int status = TclNewArithSeriesObj(NULL, newObjPtr, + arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL); + Tcl_DecrRefCount(startObj); Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - return newSlicePtr; + return status; } /* @@ -795,7 +810,7 @@ TclArithSeriesObjRange( arithSeriesDblRepPtr->step = step; arithSeriesDblRepPtr->precision = maxPrecision(start, end, step); arithSeriesDblRepPtr->len = - ArithSeriesLenDbl(start, end, step, arithSeriesDblRepPtr->precision); + ArithSeriesLenDbl(start, end, step, arithSeriesDblRepPtr->precision); arithSeriesDblRepPtr->elements = NULL; } else { @@ -814,7 +829,8 @@ TclArithSeriesObjRange( Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - return arithSeriesObj; + *newObjPtr = arithSeriesObj; + return TCL_OK; } /* @@ -856,7 +872,7 @@ TclArithSeriesGetElements( Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ { - if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { + if (TclHasInternalRep(objPtr,&arithSeriesType)) { ArithSeries *arithSeriesRepPtr; Tcl_Obj **objv; int i, objc; @@ -870,7 +886,7 @@ TclArithSeriesGetElements( objv = arithSeriesRepPtr->elements; } else { /* Construct the elements array */ - objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * objc); + objv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * objc); if (objv == NULL) { if (interp) { Tcl_SetObjResult( @@ -882,8 +898,8 @@ TclArithSeriesGetElements( } arithSeriesRepPtr->elements = objv; for (i = 0; i < objc; i++) { - objv[i] = TclArithSeriesObjIndex(interp, objPtr, i); - if (objv[i] == NULL) { + int status = TclArithSeriesObjIndex(interp, objPtr, i, &objv[i]); + if (status) { return TCL_ERROR; } Tcl_IncrRefCount(objv[i]); @@ -911,24 +927,23 @@ TclArithSeriesGetElements( * * TclArithSeriesObjReverse -- * - * Reverse the order of the ArithSeries value. - * *arithSeriesObj must be known to be a valid list. + * Reverse the order of the ArithSeries value. The arithSeriesObj is + * assumed to be a valid ArithSeries. The new Obj has the Start and End + * values appropriately swapped and the Step value sign is changed. * * Results: - * Returns a pointer to the reordered series. - * This may be a new object or the same object if not shared. + * The result will be an ArithSeries in the reverse order. * * Side effects: - * ?The possible conversion of the object referenced by listPtr? - * ?to a list object.? + * The ogiginal obj will be modified and returned if it is not Shared. * *---------------------------------------------------------------------- */ - -Tcl_Obj * +int TclArithSeriesObjReverse( Tcl_Interp *interp, /* For error message(s) */ - Tcl_Obj *arithSeriesObj) /* List object to reverse. */ + Tcl_Obj *arithSeriesObj, /* List object to reverse. */ + Tcl_Obj **newObjPtr) { ArithSeries *arithSeriesRepPtr; Tcl_Obj *startObj, *endObj, *stepObj; @@ -937,16 +952,22 @@ TclArithSeriesObjReverse( double dstart, dend, dstep; int isDouble; + (void)interp; + + if (newObjPtr == NULL) { + return TCL_ERROR; + } + arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); isDouble = arithSeriesRepPtr->isDouble; len = arithSeriesRepPtr->len; - startObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, (len-1)); + TclArithSeriesObjIndex(NULL, arithSeriesObj, (len-1), &startObj); Tcl_IncrRefCount(startObj); - endObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, 0); + TclArithSeriesObjIndex(NULL, arithSeriesObj, 0, &endObj); Tcl_IncrRefCount(endObj); - stepObj = ArithSeriesObjStep(arithSeriesObj); + TclArithSeriesObjStep(arithSeriesObj, &stepObj); Tcl_IncrRefCount(stepObj); if (isDouble) { @@ -967,7 +988,7 @@ TclArithSeriesObjReverse( ((arithSeriesObj->refCount > 1))) { Tcl_Obj *lenObj; TclNewIntObj(lenObj, len); - if (TclNewArithSeriesObj(interp, &resultObj, isDouble, + if (TclNewArithSeriesObj(NULL, &resultObj, isDouble, startObj, endObj, stepObj, lenObj) != TCL_OK) { resultObj = NULL; } @@ -996,7 +1017,7 @@ TclArithSeriesObjReverse( for (i=0; i<len; i++) { Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]); } - ckfree((char*)arithSeriesRepPtr->elements); + Tcl_Free((char*)arithSeriesRepPtr->elements); } arithSeriesRepPtr->elements = NULL; @@ -1007,7 +1028,9 @@ TclArithSeriesObjReverse( Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - return resultObj; + *newObjPtr = resultObj; + + return TCL_OK; } /* @@ -1041,13 +1064,10 @@ TclArithSeriesObjReverse( static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr) { - ArithSeries *arithSeriesRepPtr = - (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; + ArithSeries *arithSeriesRepPtr = (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; char *p; - Tcl_Obj *elemObj; - Tcl_Size i; - Tcl_Size length = 0; - Tcl_Size slen; + Tcl_Obj *eleObj; + Tcl_Size i, bytlen = 0; /* * Pass 1: estimate space. @@ -1055,8 +1075,8 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr) if (!arithSeriesRepPtr->isDouble) { for (i = 0; i < arithSeriesRepPtr->len; i++) { double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i); - slen = d>0 ? log10(d)+1 : d<0 ? log10((0-d))+2 : 1; - length += slen; + size_t slen = d>0 ? log10(d)+1 : d<0 ? log10((0-d))+2 : 1; + bytlen += slen; } } else { for (i = 0; i < arithSeriesRepPtr->len; i++) { @@ -1064,37 +1084,118 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr) char tmp[TCL_DOUBLE_SPACE+2]; tmp[0] = 0; Tcl_PrintDouble(NULL,d,tmp); - if ((length + strlen(tmp)) > TCL_SIZE_MAX) { + if ((bytlen + strlen(tmp)) > TCL_SIZE_MAX) { break; // overflow } - length += strlen(tmp); + bytlen += strlen(tmp); } } - length += arithSeriesRepPtr->len; // Space for each separator + bytlen += arithSeriesRepPtr->len; // Space for each separator /* * Pass 2: generate the string repr. */ - p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, length); - if (p == NULL) { - Tcl_Panic("Unable to allocate string size %d", length); - } + p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen); for (i = 0; i < arithSeriesRepPtr->len; i++) { - elemObj = TclArithSeriesObjIndex(NULL, arithSeriesObjPtr, i); - char *str = Tcl_GetStringFromObj(elemObj, &slen); - if (((p - arithSeriesObjPtr->bytes)+slen) > length) { - break; - } - strncpy(p, str, slen); - p[slen] = ' '; - p += slen+1; - Tcl_DecrRefCount(elemObj); + if (TclArithSeriesObjIndex(NULL, arithSeriesObjPtr, i, &eleObj) == TCL_OK) { + Tcl_Size slen; + char *str = Tcl_GetStringFromObj(eleObj, &slen); + strcpy(p, str); + p[slen] = ' '; + p += slen+1; + Tcl_DecrRefCount(eleObj); + } // else TODO: report error here? } - if (length > 0) arithSeriesObjPtr->bytes[length-1] = '\0'; - arithSeriesObjPtr->length = length-1; + if (bytlen > 0) arithSeriesObjPtr->bytes[bytlen-1] = '\0'; + arithSeriesObjPtr->length = bytlen-1; } + +/* + *---------------------------------------------------------------------- + * + * ArithSeriesInOperator -- + * + * Evaluate the "in" operation for expr + * + * This can be done more efficiently in the Arith Series relative to + * doing a linear search as implemented in expr. + * + * Results: + * Boolean true or false (1/0) + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +static int +ArithSeriesInOperation( + Tcl_Interp *interp, + Tcl_Obj *valueObj, + Tcl_Obj *arithSeriesObjPtr, + int *boolResult) +{ + ArithSeries *arithSeriesRepPtr = (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; + ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl*)arithSeriesRepPtr; + int status; + Tcl_Size index, incr, elen, vlen; + if (arithSeriesRepPtr->isDouble) { + double y; + int test = 0; + + incr = 0; // Check index+incr where incr is 0 and 1 + status = Tcl_GetDoubleFromObj(interp, valueObj, &y); + if (status != TCL_OK) { + test = 0; + } else { + const char *vstr = Tcl_GetStringFromObj(valueObj, &vlen); + index = (y - dblRepPtr->start) / dblRepPtr->step; + while (incr<2) { + Tcl_Obj *elemObj; + elen = 0; + TclArithSeriesObjIndex(interp, arithSeriesObjPtr, (index+incr), &elemObj); + const char *estr = elemObj ? Tcl_GetStringFromObj(elemObj, &elen) : ""; + /* "in" operation defined as a string compare */ + test = (elen == vlen) ? (memcmp(estr, vstr, elen) == 0) : 0; + Tcl_BounceRefCount(elemObj); + /* Stop if we have a match */ + if (test) { + break; + } + incr++; + } + } + if (boolResult) { + *boolResult = test; + } + } else { + ArithSeries *intRepPtr = arithSeriesRepPtr; + Tcl_WideInt y; + + status = Tcl_GetWideIntFromObj(NULL, valueObj, &y); + if (status != TCL_OK) { + if (boolResult) { + *boolResult = 0; + } + } else { + Tcl_Obj *elemObj; + elen = 0; + index = (y - intRepPtr->start) / intRepPtr->step; + TclArithSeriesObjIndex(interp, arithSeriesObjPtr, index, &elemObj); + char const *vstr = Tcl_GetStringFromObj(valueObj, &vlen); + char const *estr = elemObj ? Tcl_GetStringFromObj(elemObj, &elen) : ""; + if (boolResult) { + *boolResult = (elen == vlen) ? (memcmp(estr, vstr, elen) == 0) : 0; + } + Tcl_BounceRefCount(elemObj); + } + } + return TCL_OK; +} + /* * Local Variables: * mode: c diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index e7ce6e6..ce5ced6 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -222,9 +222,9 @@ typedef struct AssemblyEnv { Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose * values are 'label' objects storing the code * offsets of the labels. */ - int cmdLine; /* Current line number within the assembly + Tcl_Size cmdLine; /* Current line number within the assembly * code */ - int* clNext; /* Invisible continuation line for + Tcl_Size* clNext; /* Invisible continuation line for * [info frame] */ BasicBlock* head_bb; /* First basic block in the code */ BasicBlock* curr_bb; /* Current basic block */ @@ -277,7 +277,7 @@ static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); static void FillInJumpOffsets(AssemblyEnv*); static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable); -static int FindLocalVar(AssemblyEnv* envPtr, +static size_t FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr); static int FinishAssembly(AssemblyEnv*); static void FreeAssemblyEnv(AssemblyEnv*); @@ -325,7 +325,8 @@ static const Tcl_ObjType assembleCodeType = { FreeAssembleCodeInternalRep, /* freeIntRepProc */ DupAssembleCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -409,7 +410,6 @@ static const TalInstDesc TalInstructionTable[] = { {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0}, {"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0}, {"label", ASSEM_LABEL, 0, 0, 0}, - {"land", ASSEM_1BYTE, INST_LAND, 2, 1}, {"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8 | INST_LAPPEND_SCALAR4), 1, 1}, @@ -437,7 +437,6 @@ static const TalInstDesc TalInstructionTable[] = { | INST_LOAD_ARRAY4), 1, 1}, {"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1}, {"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1}, - {"lor", ASSEM_1BYTE, INST_LOR, 2, 1}, {"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1}, {"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1}, {"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1}, @@ -772,7 +771,7 @@ BBEmitInst1or4( int Tcl_AssembleObjCmd( - ClientData clientData, /* clientData */ + void *clientData, /* clientData */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -787,7 +786,7 @@ Tcl_AssembleObjCmd( int TclNRAssembleObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -858,7 +857,7 @@ CompileAssembleObj( * names in the bytecode resolve */ int status; /* Status return from Tcl_AssembleCode */ const char* source; /* String representation of the source code */ - int sourceLen; /* Length of the source code in bytes */ + Tcl_Size sourceLen; /* Length of the source code in bytes */ /* * Get the expression ByteCode from the object. If it exists, make sure it @@ -889,7 +888,7 @@ CompileAssembleObj( * Set up the compilation environment, and assemble the code. */ - source = TclGetStringFromObj(objPtr, &sourceLen); + source = Tcl_GetStringFromObj(objPtr, &sourceLen); TclInitCompileEnv(interp, &compEnv, source, sourceLen, NULL, 0); status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT); if (status != TCL_OK) { @@ -965,9 +964,9 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ - int numCommands = envPtr->numCommands; + size_t numCommands = envPtr->numCommands; int offset = envPtr->codeNext - envPtr->codeStart; - int depth = envPtr->currStackDepth; + size_t depth = envPtr->currStackDepth; /* * Make sure that the command has a single arg that is a simple word. */ @@ -990,7 +989,7 @@ TclCompileAssembleCmd( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s\" body, line %d)", - parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, + (int)parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, Tcl_GetErrorLine(interp))); envPtr->numCommands = numCommands; envPtr->codeNext = envPtr->codeStart + offset; @@ -1077,7 +1076,7 @@ TclAssembleCode( */ if (parsePtr->numWords > 0) { - int instLen = parsePtr->commandSize; + size_t instLen = parsePtr->commandSize; /* Length in bytes of the current command */ if (parsePtr->term == parsePtr->commandStart + instLen - 1) { @@ -1091,7 +1090,7 @@ TclAssembleCode( #ifdef TCL_COMPILE_DEBUG if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) { printf(" %4" TCL_Z_MODIFIER "d Assembling: ", - (size_t)(envPtr->codeNext - envPtr->codeStart)); + envPtr->codeNext - envPtr->codeStart); TclPrintSource(stdout, parsePtr->commandStart, TclMin(instLen, 55)); printf("\n"); @@ -1217,14 +1216,14 @@ FreeAssemblyEnv( Tcl_DecrRefCount(thisBB->jumpTarget); } if (thisBB->foreignExceptions != NULL) { - ckfree(thisBB->foreignExceptions); + Tcl_Free(thisBB->foreignExceptions); } nextBB = thisBB->successor1; if (thisBB->jtPtr != NULL) { DeleteMirrorJumpTable(thisBB->jtPtr); thisBB->jtPtr = NULL; } - ckfree(thisBB); + Tcl_Free(thisBB); } /* @@ -1270,10 +1269,10 @@ AssembleOneLine( Tcl_Obj* operand1Obj = NULL; /* First operand to the instruction */ const char* operand1; /* String rep of the operand */ - int operand1Len; /* String length of the operand */ + Tcl_Size operand1Len; /* String length of the operand */ int opnd; /* Integer representation of an operand */ int litIndex; /* Literal pool index of a constant */ - int localVar; /* LVT index of a local variable */ + Tcl_Size localVar; /* LVT index of a local variable */ int flags; /* Flags for a basic block */ JumptableInfo* jtPtr; /* Pointer to a jumptable */ int infoIndex; /* Index of the jumptable in auxdata */ @@ -1313,7 +1312,7 @@ AssembleOneLine( if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { goto cleanup; } - operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); + operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); break; @@ -1480,7 +1479,7 @@ AssembleOneLine( &operand1Obj) != TCL_OK) { goto cleanup; } else { - operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); + operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); /* @@ -1543,7 +1542,7 @@ AssembleOneLine( goto cleanup; } - jtPtr = (JumptableInfo*)ckalloc(sizeof(JumptableInfo)); + jtPtr = (JumptableInfo*)Tcl_Alloc(sizeof(JumptableInfo)); Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; @@ -1813,15 +1812,15 @@ CompileEmbeddedScript( * code. */ - int savedStackDepth = envPtr->currStackDepth; - int savedMaxStackDepth = envPtr->maxStackDepth; + size_t savedStackDepth = envPtr->currStackDepth; + size_t savedMaxStackDepth = envPtr->maxStackDepth; int savedExceptArrayNext = envPtr->exceptArrayNext; envPtr->currStackDepth = 0; envPtr->maxStackDepth = 0; StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); - switch(instPtr->tclInstCode) { + switch (instPtr->tclInstCode) { case INST_EVAL_STK: TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); break; @@ -1937,7 +1936,7 @@ MoveExceptionRangesToBasicBlock( curr_bb->foreignExceptionBase = savedExceptArrayNext; curr_bb->foreignExceptionCount = exceptionCount; curr_bb->foreignExceptions = - (ExceptionRange*)ckalloc(exceptionCount * sizeof(ExceptionRange)); + (ExceptionRange*)Tcl_Alloc(exceptionCount * sizeof(ExceptionRange)); memcpy(curr_bb->foreignExceptions, envPtr->exceptArrayPtr + savedExceptArrayNext, exceptionCount * sizeof(ExceptionRange)); @@ -1970,7 +1969,7 @@ CreateMirrorJumpTable( AssemblyEnv* assemEnvPtr, /* Assembly environment */ Tcl_Obj* jumps) /* List of alternating keywords and labels */ { - int objc; /* Number of elements in the 'jumps' list */ + Tcl_Size objc; /* Number of elements in the 'jumps' list */ Tcl_Obj** objv; /* Pointers to the elements in the list */ CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ @@ -1983,7 +1982,7 @@ CreateMirrorJumpTable( Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */ int isNew; /* Flag==1 if the key is not yet in the * table. */ - int i; + Tcl_Size i; if (TclListObjLengthM(interp, jumps, &objc) != TCL_OK) { return TCL_ERROR; @@ -2005,7 +2004,7 @@ CreateMirrorJumpTable( * Allocate the jumptable. */ - jtPtr = (JumptableInfo*)ckalloc(sizeof(JumptableInfo)); + jtPtr = (JumptableInfo*)Tcl_Alloc(sizeof(JumptableInfo)); jtHashPtr = &jtPtr->hashTable; Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS); @@ -2070,7 +2069,7 @@ DeleteMirrorJumpTable( Tcl_SetHashValue(entry, NULL); } Tcl_DeleteHashTable(jtHashPtr); - ckfree(jtPtr); + Tcl_Free(jtPtr); } /* @@ -2248,7 +2247,7 @@ static int GetListIndexOperand( AssemblyEnv* assemEnvPtr, /* Assembly environment */ Tcl_Token** tokenPtrPtr, /* Current token from the parser */ - int* result) /* OUTPUT: Integer extracted from the token */ + int* result) /* OUTPUT: encoded index derived from the token */ { CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ @@ -2300,7 +2299,7 @@ GetListIndexOperand( *----------------------------------------------------------------------------- */ -static int +static size_t FindLocalVar( AssemblyEnv* assemEnvPtr, /* Assembly environment */ Tcl_Token** tokenPtrPtr) @@ -2314,27 +2313,27 @@ FindLocalVar( * source code. */ Tcl_Obj* varNameObj; /* Name of the variable */ const char* varNameStr; - int varNameLen; - int localVar; /* Index of the variable in the LVT */ + Tcl_Size varNameLen; + Tcl_Size localVar; /* Index of the variable in the LVT */ if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { - return -1; + return TCL_INDEX_NONE; } - varNameStr = TclGetStringFromObj(varNameObj, &varNameLen); + varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { Tcl_DecrRefCount(varNameObj); - return -1; + return TCL_INDEX_NONE; } localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr); Tcl_DecrRefCount(varNameObj); - if (localVar == -1) { + if (localVar < 0) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { 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", (void *)NULL); } - return -1; + return TCL_INDEX_NONE; } *tokenPtrPtr = TokenAfter(tokenPtr); return localVar; @@ -2654,7 +2653,7 @@ AllocBB( AssemblyEnv* assemEnvPtr) /* Assembly environment */ { CompileEnv* envPtr = assemEnvPtr->envPtr; - BasicBlock *bb = (BasicBlock*)ckalloc(sizeof(BasicBlock)); + BasicBlock *bb = (BasicBlock*)Tcl_Alloc(sizeof(BasicBlock)); bb->originalStartOffset = bb->startOffset = envPtr->codeNext - envPtr->codeStart; @@ -2916,7 +2915,7 @@ CheckJumpTableLabels( valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, TclGetString(symbolObj)); DEBUG_PRINT(" %s -> %s (%d)\n", - (char*) Tcl_GetHashKey(symHash, symEntryPtr), + (char *)Tcl_GetHashKey(symHash, symEntryPtr), TclGetString(symbolObj), (valEntryPtr != NULL)); if (valEntryPtr == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); @@ -3121,7 +3120,7 @@ ResolveJumpTableTargets( realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr, Tcl_GetHashKey(symHash, symEntryPtr), &junk); DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n", - (char*) Tcl_GetHashKey(symHash, symEntryPtr), + (char *)Tcl_GetHashKey(symHash, symEntryPtr), TclGetString(symbolObj), jumpTargetBBPtr, jumpTargetBBPtr->startOffset, realJumpEntryPtr); @@ -3322,7 +3321,7 @@ CheckStack( { CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ - int maxDepth; /* Maximum stack depth overall */ + Tcl_Size maxDepth; /* Maximum stack depth overall */ /* * Checking the head block will check all the other blocks recursively. @@ -3932,8 +3931,8 @@ BuildExceptionRanges( * Allocate memory for a stack of active catches. */ - catches = (BasicBlock**)ckalloc(maxCatchDepth * sizeof(BasicBlock*)); - catchIndices = (int *)ckalloc(maxCatchDepth * sizeof(int)); + catches = (BasicBlock**)Tcl_Alloc(maxCatchDepth * sizeof(BasicBlock*)); + catchIndices = (int *)Tcl_Alloc(maxCatchDepth * sizeof(int)); for (i = 0; i < maxCatchDepth; ++i) { catches[i] = NULL; catchIndices[i] = -1; @@ -3972,8 +3971,8 @@ BuildExceptionRanges( /* Free temp storage */ - ckfree(catchIndices); - ckfree(catches); + Tcl_Free(catchIndices); + Tcl_Free(catches); return TCL_OK; } @@ -4131,7 +4130,7 @@ StackFreshCatches( TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; range->nestingLevel = envPtr->exceptDepth + catchDepth; - envPtr->maxExceptDepth = + envPtr->maxExceptDepth= TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth); range->codeOffset = bbPtr->startOffset; @@ -4168,7 +4167,7 @@ RestoreEmbeddedExceptionRanges( BasicBlock* bbPtr; /* Current basic block */ int rangeBase; /* Base of the foreign exception ranges when * they are reinstalled */ - int rangeIndex; /* Index of the current foreign exception + size_t rangeIndex; /* Index of the current foreign exception * range as reinstalled */ ExceptionRange* range; /* Current foreign exception range */ unsigned char opcode; /* Current instruction's opcode */ @@ -4195,7 +4194,7 @@ RestoreEmbeddedExceptionRanges( range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth; memcpy(envPtr->exceptArrayPtr + rangeIndex, range, sizeof(ExceptionRange)); - if (range->nestingLevel >= envPtr->maxExceptDepth) { + if (range->nestingLevel + 1 >= envPtr->maxExceptDepth + 1) { envPtr->maxExceptDepth = range->nestingLevel + 1; } } diff --git a/generic/tclAsync.c b/generic/tclAsync.c index 9ce2c88..f0f0c9c 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -30,7 +30,7 @@ typedef struct AsyncHandler { * for the process. */ Tcl_AsyncProc *proc; /* Procedure to call when handler is * invoked. */ - ClientData clientData; /* Value to pass to handler when it is + void *clientData; /* Value to pass to handler when it is * invoked. */ struct ThreadSpecificData *originTsd; /* Used in Tcl_AsyncMark to modify thread- @@ -38,7 +38,7 @@ typedef struct AsyncHandler { * associated to. */ Tcl_ThreadId originThrdId; /* Origin thread where this token was created * and where it will be yielded. */ - ClientData notifierData; /* Platform notifier data or NULL. */ + void *notifierData; /* Platform notifier data or NULL. */ } AsyncHandler; typedef struct ThreadSpecificData { @@ -115,7 +115,7 @@ TclFinalizeAsync(void) while (toDelete != NULL) { token = toDelete; toDelete = toDelete->nextPtr; - ckfree(token); + Tcl_Free(token); } } @@ -142,12 +142,12 @@ Tcl_AsyncHandler Tcl_AsyncCreate( Tcl_AsyncProc *proc, /* Procedure to call when handler is * invoked. */ - ClientData clientData) /* Argument to pass to handler. */ + void *clientData) /* Argument to pass to handler. */ { AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - asyncPtr = (AsyncHandler*)ckalloc(sizeof(AsyncHandler)); + asyncPtr = (AsyncHandler*)Tcl_Alloc(sizeof(AsyncHandler)); asyncPtr->ready = 0; asyncPtr->nextPtr = NULL; asyncPtr->prevPtr = NULL; @@ -406,7 +406,7 @@ Tcl_AsyncDelete( asyncPtr->nextPtr->prevPtr = asyncPtr->prevPtr; } Tcl_MutexUnlock(&asyncMutex); - ckfree(asyncPtr); + Tcl_Free(asyncPtr); } /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b01717e..e8ff3d9 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -113,18 +113,6 @@ TclGetCStackPtr(void) #endif /* - * The following structure defines the client data for a math function - * registered with Tcl_CreateMathFunc - */ - -typedef struct OldMathFuncData { - Tcl_MathProc *proc; /* Handler function */ - int numArgs; /* Number of args expected */ - Tcl_ValueType *argTypes; /* Types of the args */ - void *clientData; /* Client data for the handler function */ -} OldMathFuncData; - -/* * This is the script cancellation struct and hash table. The hash table is * used to keep track of the information necessary to process script * cancellation requests, including the original interp, asynchronous handler @@ -196,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; @@ -225,22 +214,18 @@ static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static Tcl_NRPostProc NRCommand; -#if !defined(TCL_NO_DEPRECATED) -static Tcl_ObjCmdProc OldMathFuncProc; -static void OldMathFuncDeleteProc(void *clientData); -#endif /* !defined(TCL_NO_DEPRECATED) */ static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int RewindCoroutine(CoroutineData *corPtr, int result); static void TEOV_SwitchVarFrame(Tcl_Interp *interp); static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, - Tcl_Size objc, Tcl_Obj *const objv[], int flags); + int objc, Tcl_Obj *const objv[], int flags); static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, Tcl_Obj *namePtr, Namespace *lookupNsPtr); -static int TEOV_NotFound(Tcl_Interp *interp, Tcl_Size objc, +static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, - Command **cmdPtrPtr, Tcl_Obj *commandPtr, Tcl_Size objc, + Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -315,6 +300,12 @@ typedef struct { * The built-in commands, and the functions that implement them: */ +int procObjCmd(void *clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) { + return Tcl_ProcObjCmd(clientData, interp, objc, objv); +} + + static const CmdInfo builtInCmds[] = { /* * Commands in the generic core. @@ -323,11 +314,9 @@ static const CmdInfo builtInCmds[] = { {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, -#endif {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, + {"const", Tcl_ConstObjCmd, TclCompileConstCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE}, {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE}, @@ -345,7 +334,7 @@ static const CmdInfo builtInCmds[] = { {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, - {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, @@ -362,7 +351,7 @@ static const CmdInfo builtInCmds[] = { {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, - {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"proc", procObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE}, @@ -658,10 +647,10 @@ TclFinalizeEvaluation(void) */ static int -buildInfoObjCmd( +buildInfoObjCmd2( void *clientData, Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc > 2) { @@ -670,7 +659,7 @@ buildInfoObjCmd( } if (objc == 2) { Tcl_Size len; - const char *arg = TclGetStringFromObj(objv[1], &len); + const char *arg = Tcl_GetStringFromObj(objv[1], &len); if (len == 7 && !strcmp(arg, "version")) { char buf[80]; const char *p = strchr((char *)clientData, '.'); @@ -743,6 +732,16 @@ buildInfoObjCmd( return TCL_OK; } +static int +buildInfoObjCmd( + void *clientData, + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return buildInfoObjCmd2(clientData, interp, objc, objv); +} + /* *---------------------------------------------------------------------- * @@ -794,16 +793,13 @@ Tcl_CreateInterp(void) Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); } -#if defined(_WIN32) && !defined(_WIN64) && !defined(_USE_64BIT_TIME_T) - /* If Tcl is compiled on Win32 using -D_USE_64BIT_TIME_T - * the result is a binary incompatible with the 'standard' build of - * Tcl: All extensions using Tcl_StatBuf need to be recompiled in - * the same way. Therefore, this is not officially supported. - * In stead, it is recommended to use Win64 or Tcl 9.0 (not released yet) - */ +#if defined(_WIN32) && !defined(_WIN64) + if (sizeof(time_t) != 8) { + Tcl_Panic("<time.h> is not compatible with VS2005+"); + } if ((offsetof(Tcl_StatBuf,st_atime) != 32) - || (offsetof(Tcl_StatBuf,st_ctime) != 40)) { - Tcl_Panic("<sys/stat.h> is not compatible with MSVC"); + || (offsetof(Tcl_StatBuf,st_ctime) != 48)) { + Tcl_Panic("<sys/stat.h> is not compatible with VS2005+"); } #endif @@ -837,15 +833,13 @@ Tcl_CreateInterp(void) * object type table and other object management code. */ - iPtr = (Interp *)ckalloc(sizeof(Interp)); + iPtr = (Interp *)Tcl_Alloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; -#ifdef TCL_NO_DEPRECATED - iPtr->result = &tclEmptyString; -#else - iPtr->result = iPtr->resultSpace; -#endif - iPtr->freeProc = NULL; + iPtr->legacyResult = NULL; + /* Special invalid value: Any attempt to free the legacy result + * will cause a crash. */ + iPtr->legacyFreeProc = (void (*) (void))-1; iPtr->errorLine = 0; iPtr->stubTable = &tclStubs; TclNewObj(iPtr->objResultPtr); @@ -855,8 +849,7 @@ Tcl_CreateInterp(void) iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; - TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable)); - iPtr->extra.optimizer = TclOptimizeBytecode; + iPtr->optimizer = TclOptimizeBytecode; iPtr->numLevels = 0; iPtr->maxNestingDepth = MAX_NESTING_DEPTH; @@ -869,10 +862,10 @@ Tcl_CreateInterp(void) */ iPtr->cmdFramePtr = NULL; - iPtr->linePBodyPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineBCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineLAPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + iPtr->linePBodyPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + iPtr->lineBCPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + iPtr->lineLAPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + iPtr->lineLABCPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS); @@ -905,12 +898,6 @@ Tcl_CreateInterp(void) iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; -#ifndef TCL_NO_DEPRECATED - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - iPtr->appendUsed = 0; -#endif - Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; @@ -943,9 +930,6 @@ Tcl_CreateInterp(void) TclNewObj(iPtr->emptyObjPtr); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); -#ifndef TCL_NO_DEPRECATED - iPtr->resultSpace[0] = 0; -#endif iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ @@ -979,7 +963,7 @@ Tcl_CreateInterp(void) */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ - framePtr = (CallFrame *)ckalloc(sizeof(CallFrame)); + framePtr = (CallFrame *)Tcl_Alloc(sizeof(CallFrame)); (void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); framePtr->objc = 0; @@ -1009,7 +993,7 @@ Tcl_CreateInterp(void) TclNewObj(iPtr->asyncCancelMsg); - cancelInfo = (CancelInfo *)ckalloc(sizeof(CancelInfo)); + cancelInfo = (CancelInfo *)Tcl_Alloc(sizeof(CancelInfo)); cancelInfo->interp = interp; iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo); @@ -1084,7 +1068,7 @@ Tcl_CreateInterp(void) /* * Create the core commands. Do it here, rather than calling Tcl_CreateObjCommand, * because it's faster (there's no need to check for a preexisting command - * by the same name). Set the Tcl_CmdProc to TclInvokeObjectCommand. + * by the same name). Set the Tcl_CmdProc to NULL. */ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { @@ -1097,13 +1081,13 @@ Tcl_CreateInterp(void) hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, cmdInfoPtr->name, &isNew); if (isNew) { - cmdPtr = (Command *)ckalloc(sizeof(Command)); + cmdPtr = (Command *)Tcl_Alloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; 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; @@ -1227,7 +1211,7 @@ Tcl_CreateInterp(void) #define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */ memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN); for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){ - TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)ckalloc(sizeof(TclOpCmdClientData)); + TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)Tcl_Alloc(sizeof(TclOpCmdClientData)); occdPtr->op = opcmdInfoPtr->name; occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs; @@ -1285,24 +1269,8 @@ Tcl_CreateInterp(void) Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY); -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - Tcl_TraceVar2(interp, "tcl_precision", NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - TclPrecTraceProc, NULL); -#endif /* !TCL_NO_DEPRECATED */ TclpSetVariables(interp); -#if TCL_THREADS && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - /* - * The existence of the "threaded" element of the tcl_platform array - * indicates that this particular Tcl shell has been compiled with threads - * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can - * introspect on the interpreter level of thread safety. - */ - - Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY); -#endif - /* * Register Tcl's version number. * TIP #268: Full patchlevel instead of just major.minor @@ -1311,8 +1279,13 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs); - Tcl_CreateObjCommand(interp, "::tcl::build-info", + Tcl_CmdInfo info2; + Tcl_Command buildInfoCmd = Tcl_CreateObjCommand(interp, "::tcl::build-info", buildInfoObjCmd, (void *)version, NULL); + Tcl_GetCommandInfoFromToken(buildInfoCmd, &info2); + info2.objProc2 = buildInfoObjCmd2; + info2.objClientData2 = (void *)version; + Tcl_SetCommandInfoFromToken(buildInfoCmd, &info2); if (TclTommath_Init(interp) != TCL_OK) { Tcl_Panic("%s", Tcl_GetStringResult(interp)); @@ -1346,7 +1319,7 @@ DeleteOpCmdClientData( { TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; - ckfree(occdPtr); + Tcl_Free(occdPtr); } /* @@ -1555,14 +1528,14 @@ Tcl_CallWhenDeleted( (int *)Tcl_GetThreadData(&assocDataCounterKey, sizeof(int)); int isNew; char buffer[32 + TCL_INTEGER_SPACE]; - AssocData *dPtr = (AssocData *)ckalloc(sizeof(AssocData)); + AssocData *dPtr = (AssocData *)Tcl_Alloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; snprintf(buffer, sizeof(buffer), "Assoc Data Key #%d", *assocDataCounterPtr); (*assocDataCounterPtr)++; if (iPtr->assocData == NULL) { - iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + iPtr->assocData = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew); @@ -1611,7 +1584,7 @@ Tcl_DontCallWhenDeleted( hPtr = Tcl_NextHashEntry(&hSearch)) { dPtr = (AssocData *)Tcl_GetHashValue(hPtr); if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { - ckfree(dPtr); + Tcl_Free(dPtr); Tcl_DeleteHashEntry(hPtr); return; } @@ -1651,14 +1624,14 @@ Tcl_SetAssocData( int isNew; if (iPtr->assocData == NULL) { - iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + iPtr->assocData = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew); if (isNew == 0) { dPtr = (AssocData *)Tcl_GetHashValue(hPtr); } else { - dPtr = (AssocData *)ckalloc(sizeof(AssocData)); + dPtr = (AssocData *)Tcl_Alloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; @@ -1704,7 +1677,7 @@ Tcl_DeleteAssocData( if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - ckfree(dPtr); + Tcl_Free(dPtr); } /* @@ -1851,7 +1824,7 @@ Tcl_DeleteInterp( static void DeleteInterpProc( - char *blockPtr) /* Interpreter to delete. */ + void *blockPtr) /* Interpreter to delete. */ { Tcl_Interp *interp = (Tcl_Interp *) blockPtr; Interp *iPtr = (Interp *) interp; @@ -1900,9 +1873,9 @@ DeleteInterpProc( if (cancelInfo != NULL) { if (cancelInfo->result != NULL) { - ckfree(cancelInfo->result); + Tcl_Free(cancelInfo->result); } - ckfree(cancelInfo); + Tcl_Free(cancelInfo); } Tcl_DeleteHashEntry(hPtr); @@ -1957,7 +1930,7 @@ DeleteInterpProc( Tcl_DeleteCommandFromToken(interp, (Tcl_Command)Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); - ckfree(hTablePtr); + Tcl_Free(hTablePtr); } @@ -1977,10 +1950,10 @@ DeleteInterpProc( dPtr->proc(dPtr->clientData, interp); } Tcl_DeleteHashEntry(hPtr); - ckfree(dPtr); + Tcl_Free(dPtr); } Tcl_DeleteHashTable(hTablePtr); - ckfree(hTablePtr); + Tcl_Free(hTablePtr); iPtr->assocData = NULL; } @@ -1993,7 +1966,7 @@ DeleteInterpProc( Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top"); } Tcl_PopCallFrame(interp); - ckfree(iPtr->rootFramePtr); + Tcl_Free(iPtr->rootFramePtr); iPtr->rootFramePtr = NULL; Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); @@ -2002,10 +1975,6 @@ DeleteInterpProc( * could have transferred ownership of the result string to Tcl. */ -#ifndef TCL_NO_DEPRECATED - Tcl_FreeResult(interp); - iPtr->result = NULL; -#endif Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); @@ -2027,12 +1996,6 @@ DeleteInterpProc( if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } -#ifndef TCL_NO_DEPRECATED - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; - } -#endif TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); @@ -2050,8 +2013,8 @@ DeleteInterpProc( resPtr = iPtr->resolverPtr; while (resPtr) { nextResPtr = resPtr->nextPtr; - ckfree(resPtr->name); - ckfree(resPtr); + Tcl_Free(resPtr->name); + Tcl_Free(resPtr); resPtr = nextResPtr; } @@ -2078,13 +2041,13 @@ DeleteInterpProc( if (cfPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfPtr->data.eval.path); } - ckfree(cfPtr->line); - ckfree(cfPtr); + Tcl_Free(cfPtr->line); + Tcl_Free(cfPtr); } Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(iPtr->linePBodyPtr); - ckfree(iPtr->linePBodyPtr); + Tcl_Free(iPtr->linePBodyPtr); iPtr->linePBodyPtr = NULL; /* @@ -2100,18 +2063,18 @@ DeleteInterpProc( Tcl_DecrRefCount(eclPtr->path); } for (i=0; i<eclPtr->nuloc; i++) { - ckfree(eclPtr->loc[i].line); + Tcl_Free(eclPtr->loc[i].line); } if (eclPtr->loc != NULL) { - ckfree(eclPtr->loc); + Tcl_Free(eclPtr->loc); } - ckfree(eclPtr); + Tcl_Free(eclPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(iPtr->lineBCPtr); - ckfree(iPtr->lineBCPtr); + Tcl_Free(iPtr->lineBCPtr); iPtr->lineBCPtr = NULL; /* @@ -2130,7 +2093,7 @@ DeleteInterpProc( } Tcl_DeleteHashTable(iPtr->lineLAPtr); - ckfree(iPtr->lineLAPtr); + Tcl_Free(iPtr->lineLAPtr); iPtr->lineLAPtr = NULL; if (iPtr->lineLABCPtr->numEntries && !TclInExit()) { @@ -2143,7 +2106,7 @@ DeleteInterpProc( } Tcl_DeleteHashTable(iPtr->lineLABCPtr); - ckfree(iPtr->lineLABCPtr); + Tcl_Free(iPtr->lineLABCPtr); iPtr->lineLABCPtr = NULL; /* @@ -2154,7 +2117,7 @@ DeleteInterpProc( Tcl_DeleteHashTable(&iPtr->varTraces); Tcl_DeleteHashTable(&iPtr->varSearches); - ckfree(iPtr); + Tcl_Free(iPtr); } /* @@ -2222,7 +2185,7 @@ Tcl_HideCommand( if (strstr(hiddenCmdToken, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use namespace qualifiers in hidden command" - " token (rename)", TCL_INDEX_NONE)); + " token (rename)", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", (void *)NULL); return TCL_ERROR; } @@ -2247,7 +2210,7 @@ Tcl_HideCommand( if (cmdPtr->nsPtr != iPtr->globalNsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only hide global namespace commands (use rename then hide)", - TCL_INDEX_NONE)); + -1)); Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", (void *)NULL); return TCL_ERROR; } @@ -2258,7 +2221,7 @@ Tcl_HideCommand( hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr == NULL) { - hiddenCmdTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + hiddenCmdTablePtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } @@ -2377,7 +2340,7 @@ Tcl_ExposeCommand( if (strstr(cmdName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot expose to a namespace (use expose to toplevel, then rename)", - TCL_INDEX_NONE)); + -1)); Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", (void *)NULL); return TCL_ERROR; } @@ -2414,7 +2377,7 @@ Tcl_ExposeCommand( Tcl_SetObjResult(interp, Tcl_NewStringObj( "trying to expose a non-global command namespace command", - TCL_INDEX_NONE)); + -1)); return TCL_ERROR; } @@ -2514,7 +2477,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. * @@ -2624,7 +2587,7 @@ Tcl_CreateCommand( * infinite loop). */ - ckfree(Tcl_GetHashValue(hPtr)); + Tcl_Free(Tcl_GetHashValue(hPtr)); } if (!deleted) { @@ -2649,14 +2612,14 @@ Tcl_CreateCommand( TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = (Command *)ckalloc(sizeof(Command)); + cmdPtr = (Command *)Tcl_Alloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = NULL; - cmdPtr->objProc = TclInvokeStringCommand; + cmdPtr->objProc = InvokeStringCommand; cmdPtr->objClientData = cmdPtr; cmdPtr->proc = proc; cmdPtr->clientData = clientData; @@ -2707,7 +2670,6 @@ Tcl_CreateCommand( * Side effects: * If a command named "cmdName" already exists for interp, it is * first deleted. Then the new command is created from the arguments. - * [***] (See below for exception). * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based @@ -2718,6 +2680,66 @@ Tcl_CreateCommand( *---------------------------------------------------------------------- */ +typedef struct { + Tcl_ObjCmdProc2 *proc; + void *clientData; /* Arbitrary value to pass to proc function. */ + Tcl_CmdDeleteProc *deleteProc; + void *deleteData; /* Arbitrary value to pass to deleteProc function. */ + Tcl_ObjCmdProc2 *nreProc; +} CmdWrapperInfo; + + +static int cmdWrapperProc(void *clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj * const *objv) +{ + CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; + if (objc < 0) { + objc = -1; + } + return info->proc(info->clientData, interp, objc, objv); +} + +static void cmdWrapperDeleteProc(void *clientData) { + CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; + + clientData = info->deleteData; + Tcl_CmdDeleteProc *deleteProc = info->deleteProc; + Tcl_Free(info); + if (deleteProc != NULL) { + deleteProc(clientData); + } +} + +Tcl_Command +Tcl_CreateObjCommand2( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ + const char *cmdName, /* Name of command. If it contains namespace + * qualifiers, the new command is put in the + * specified namespace; otherwise it is put in + * the global namespace. */ + Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with + * name. */ + void *clientData, /* Arbitrary value to pass to object + * function. */ + Tcl_CmdDeleteProc *deleteProc + /* If not NULL, gives a function to call when + * this command is deleted. */ +) +{ + CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); + info->proc = proc; + info->clientData = clientData; + info->deleteProc = deleteProc; + info->deleteData = clientData; + + return Tcl_CreateObjCommand(interp, cmdName, + (proc ? cmdWrapperProc : NULL), + info, cmdWrapperDeleteProc); +} + Tcl_Command Tcl_CreateObjCommand( Tcl_Interp *interp, /* Token for command interpreter (returned by @@ -2816,24 +2838,7 @@ TclCreateObjCommandInNs( cmdPtr = (Command *)Tcl_GetHashValue(hPtr); /* - * [***] This is wrong. See Tcl Bug a16752c252. - * However, this buggy behavior is kept under particular circumstances - * to accommodate deployed binaries of the "tclcompiler" program - * <http://sourceforge.net/projects/tclpro/> that crash if the bug is - * fixed. - */ - - if (cmdPtr->objProc == TclInvokeStringCommand - && cmdPtr->clientData == clientData - && cmdPtr->deleteData == clientData - && cmdPtr->deleteProc == deleteProc) { - cmdPtr->objProc = proc; - cmdPtr->objClientData = clientData; - return (Tcl_Command) cmdPtr; - } - - /* - * Otherwise, we delete the old command. Be careful to preserve any + * Command already exists; delete it. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain * intact. @@ -2869,7 +2874,7 @@ TclCreateObjCommandInNs( * infinite loop). */ - ckfree(Tcl_GetHashValue(hPtr)); + Tcl_Free(Tcl_GetHashValue(hPtr)); } if (!deleted) { @@ -2894,7 +2899,7 @@ TclCreateObjCommandInNs( TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = (Command *)ckalloc(sizeof(Command)); + cmdPtr = (Command *)Tcl_Alloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -2903,7 +2908,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; @@ -2944,7 +2949,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 @@ -2957,13 +2962,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. */ @@ -2992,78 +2997,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); - } - - /* - * Move the interpreter's object result to the string result, then reset - * the object result. - */ - - (void) Tcl_GetStringResult(interp); - - /* - * 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 @@ -3223,11 +3156,11 @@ TclRenameCommand( */ Tcl_DStringInit(&newFullName); - Tcl_DStringAppend(&newFullName, newNsPtr->fullName, TCL_INDEX_NONE); + Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1); if (newNsPtr != iPtr->globalNsPtr) { TclDStringAppendLiteral(&newFullName, "::"); } - Tcl_DStringAppend(&newFullName, newTail, TCL_INDEX_NONE); + Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName), Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); @@ -3322,6 +3255,40 @@ Tcl_SetCommandInfo( *---------------------------------------------------------------------- */ +static int +invokeObj2Command( + void *clientData, /* Points to command's Command structure. */ + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Size objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int result; + Command *cmdPtr = (Command *) clientData; + + if (objc > INT_MAX) { + return TclCommandWordLimitError(interp, objc); + } + if (cmdPtr->objProc != NULL) { + result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); + } else { + result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, + cmdPtr->objClientData, objc, objv); + } + return result; +} + +static int cmdWrapper2Proc(void *clientData, + Tcl_Interp *interp, + Tcl_Size objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr = (Command *)clientData; + if (objc > INT_MAX) { + return TclCommandWordLimitError(interp, objc); + } + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); +} + int Tcl_SetCommandInfoFromToken( Tcl_Command cmd, @@ -3341,7 +3308,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 { @@ -3351,8 +3318,36 @@ Tcl_SetCommandInfoFromToken( } cmdPtr->objClientData = infoPtr->objClientData; } - cmdPtr->deleteProc = infoPtr->deleteProc; - cmdPtr->deleteData = infoPtr->deleteData; + if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { + CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; + if (infoPtr->objProc2 == NULL) { + info->proc = invokeObj2Command; + info->clientData = cmdPtr; + info->nreProc = NULL; + } else { + if (infoPtr->objProc2 != info->proc) { + info->nreProc = NULL; + info->proc = infoPtr->objProc2; + } + info->clientData = infoPtr->objClientData2; + } + info->deleteProc = infoPtr->deleteProc; + info->deleteData = infoPtr->deleteData; + } else { + if ((infoPtr->objProc2 != NULL) && (infoPtr->objProc2 != cmdWrapper2Proc)) { + CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); + info->proc = infoPtr->objProc2; + info->clientData = infoPtr->objClientData2; + info->nreProc = NULL; + info->deleteProc = infoPtr->deleteProc; + info->deleteData = infoPtr->deleteData; + cmdPtr->deleteProc = cmdWrapperDeleteProc; + cmdPtr->deleteData = info; + } else { + cmdPtr->deleteProc = infoPtr->deleteProc; + cmdPtr->deleteData = infoPtr->deleteData; + } + } return 1; } @@ -3419,18 +3414,32 @@ Tcl_GetCommandInfoFromToken( /* * Set isNativeObjectProc 1 if objProc was registered by a call to - * Tcl_CreateObjCommand. Otherwise set it to 0. + * Tcl_CreateObjCommand. Set isNativeObjectProc 2 if objProc was + * registered by a call to Tcl_CreateObjCommand2. Otherwise set it to 0. */ cmdPtr = (Command *) cmd; infoPtr->isNativeObjectProc = - (cmdPtr->objProc != TclInvokeStringCommand); + (cmdPtr->objProc != InvokeStringCommand); infoPtr->objProc = cmdPtr->objProc; infoPtr->objClientData = cmdPtr->objClientData; infoPtr->proc = cmdPtr->proc; infoPtr->clientData = cmdPtr->clientData; - infoPtr->deleteProc = cmdPtr->deleteProc; - infoPtr->deleteData = cmdPtr->deleteData; + if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { + CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; + infoPtr->deleteProc = info->deleteProc; + infoPtr->deleteData = info->deleteData; + infoPtr->objProc2 = info->proc; + infoPtr->objClientData2 = info->clientData; + if (cmdPtr->objProc == cmdWrapperProc) { + infoPtr->isNativeObjectProc = 2; + } + } else { + infoPtr->deleteProc = cmdPtr->deleteProc; + infoPtr->deleteData = cmdPtr->deleteData; + infoPtr->objProc2 = cmdWrapper2Proc; + infoPtr->objClientData2 = cmdPtr; + } infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; return 1; } @@ -3515,14 +3524,14 @@ Tcl_GetCommandFullName( if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) { if (cmdPtr->nsPtr != NULL) { - Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, TCL_INDEX_NONE); + Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1); if (cmdPtr->nsPtr != iPtr->globalNsPtr) { Tcl_AppendToObj(objPtr, "::", 2); } } if (cmdPtr->hPtr != NULL) { name = (char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); - Tcl_AppendToObj(objPtr, name, TCL_INDEX_NONE); + Tcl_AppendToObj(objPtr, name, -1); } } } @@ -3658,7 +3667,7 @@ Tcl_DeleteCommandFromToken( CommandTrace *nextPtr = tracePtr->nextPtr; if (tracePtr->refCount-- <= 1) { - ckfree(tracePtr); + Tcl_Free(tracePtr); } tracePtr = nextPtr; } @@ -3710,10 +3719,10 @@ Tcl_DeleteCommandFromToken( * If you are getting a crash during the call to deleteProc and * cmdPtr->deleteProc is a pointer to the function free(), the most * likely cause is that your extension allocated memory for the - * clientData argument to Tcl_CreateObjCommand with the ckalloc() + * clientData argument to Tcl_CreateObjCommand with the Tcl_Alloc() * macro and you are now trying to deallocate this memory with free() - * instead of ckfree(). You should pass a pointer to your own method - * that calls ckfree(). + * instead of Tcl_Free(). You should pass a pointer to your own method + * that calls Tcl_Free(). */ cmdPtr->deleteProc(cmdPtr->deleteData); @@ -3851,7 +3860,7 @@ CallCommandTraces( oldName, newName, flags); cmdPtr->flags &= ~tracePtr->flags; if (tracePtr->refCount-- <= 1) { - ckfree(tracePtr); + Tcl_Free(tracePtr); } } @@ -3982,372 +3991,9 @@ TclCleanupCommand( * be freed. */ { if (cmdPtr->refCount-- <= 1) { - ckfree(cmdPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateMathFunc -- - * - * Creates a new math function for expressions in a given interpreter. - * - * Results: - * None. - * - * Side effects: - * The Tcl function defined by "name" is created or redefined. If the - * function already exists then its definition is replaced; this includes - * the builtin functions. Redefining a builtin function forces all - * existing code to be invalidated since that code may be compiled using - * an instruction specific to the replaced function. In addition, - * redefining a non-builtin function will force existing code to be - * invalidated if the number of arguments has changed. - * - *---------------------------------------------------------------------- - */ - -#if !defined(TCL_NO_DEPRECATED) -void -Tcl_CreateMathFunc( - Tcl_Interp *interp, /* Interpreter in which function is to be - * available. */ - const char *name, /* Name of function (e.g. "sin"). */ - int numArgs, /* Number of arguments required by - * function. */ - Tcl_ValueType *argTypes, /* Array of types acceptable for each - * argument. */ - Tcl_MathProc *proc, /* C function that implements the math - * function. */ - void *clientData) /* Additional value to pass to the - * function. */ -{ - Tcl_DString bigName; - OldMathFuncData *data = (OldMathFuncData *)ckalloc(sizeof(OldMathFuncData)); - - data->proc = proc; - data->numArgs = numArgs; - data->argTypes = (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType)); - if ((numArgs > 0) && (argTypes != NULL)) { - memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); - } - data->clientData = clientData; - - Tcl_DStringInit(&bigName); - TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::"); - Tcl_DStringAppend(&bigName, name, -1); - - Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName), - OldMathFuncProc, data, OldMathFuncDeleteProc); - Tcl_DStringFree(&bigName); -} - -/* - *---------------------------------------------------------------------- - * - * OldMathFuncProc -- - * - * Dispatch to a math function created with Tcl_CreateMathFunc - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Whatever the math function does. - * - *---------------------------------------------------------------------- - */ - -static int -OldMathFuncProc( - void *clientData, /* Pointer to OldMathFuncData describing the - * function being called */ - Tcl_Interp *interp, /* Tcl interpreter */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Parameter vector */ -{ - Tcl_Obj *valuePtr; - OldMathFuncData *dataPtr = (OldMathFuncData *)clientData; - Tcl_Value funcResult, *args; - int result; - int j, k; - double d; - - /* - * Check argument count. - */ - - if (objc != dataPtr->numArgs + 1) { - MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv); - return TCL_ERROR; - } - - /* - * Convert arguments from Tcl_Obj's to Tcl_Value's. - */ - - args = (Tcl_Value *)ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); - for (j = 1, k = 0; j < objc; ++j, ++k) { - /* TODO: Convert to Tcl_GetNumberFromObj? */ - valuePtr = objv[j]; - result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); -#ifdef ACCEPT_NAN - if (result != TCL_OK) { - const Tcl_ObjInternalRep *irPtr - = TclFetchInternalRep(valuePtr, &tclDoubleType); - - if (irPtr) { - d = irPtr->doubleValue; - result = TCL_OK; - } - } -#endif - if (result != TCL_OK) { - /* - * We have a non-numeric argument. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "argument to math function didn't have numeric value", - -1)); - TclCheckBadOctal(interp, TclGetString(valuePtr)); - ckfree(args); - return TCL_ERROR; - } - - /* - * Copy the object's numeric value to the argument record, converting - * it if necessary. - * - * NOTE: no bignum support; use the new mathfunc interface for that. - */ - - args[k].type = dataPtr->argTypes[k]; - switch (args[k].type) { - case TCL_EITHER: - if (Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue) - == TCL_OK) { - args[k].type = TCL_INT; - break; - } - if (TclGetWideIntFromObj(interp, valuePtr, &args[k].wideValue) - == TCL_OK) { - args[k].type = TCL_WIDE_INT; - break; - } - args[k].type = TCL_DOUBLE; - /* FALLTHROUGH */ - - case TCL_DOUBLE: - args[k].doubleValue = d; - break; - case TCL_INT: - if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { - ckfree(args); - return TCL_ERROR; - } - valuePtr = Tcl_GetObjResult(interp); - Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue); - Tcl_ResetResult(interp); - break; - case TCL_WIDE_INT: - if (ExprWideFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { - ckfree(args); - return TCL_ERROR; - } - valuePtr = Tcl_GetObjResult(interp); - TclGetWideIntFromObj(NULL, valuePtr, &args[k].wideValue); - Tcl_ResetResult(interp); - break; - } - } - - /* - * Call the function. - */ - - errno = 0; - result = dataPtr->proc(dataPtr->clientData, interp, args, &funcResult); - ckfree(args); - if (result != TCL_OK) { - return result; - } - - /* - * Return the result of the call. - */ - - if (funcResult.type == TCL_INT) { - TclNewIntObj(valuePtr, funcResult.intValue); - } else if (funcResult.type == TCL_WIDE_INT) { - TclNewIntObj(valuePtr, funcResult.wideValue); - } else { - return CheckDoubleResult(interp, funcResult.doubleValue); - } - Tcl_SetObjResult(interp, valuePtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * OldMathFuncDeleteProc -- - * - * Cleans up after deleting a math function registered with - * Tcl_CreateMathFunc - * - * Results: - * None. - * - * Side effects: - * Frees allocated memory. - * - *---------------------------------------------------------------------- - */ - -static void -OldMathFuncDeleteProc( - void *clientData) -{ - OldMathFuncData *dataPtr = (OldMathFuncData *)clientData; - - ckfree(dataPtr->argTypes); - ckfree(dataPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetMathFuncInfo -- - * - * Discovers how a particular math function was created in a given - * interpreter. - * - * Results: - * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the - * interpreter result if that happens.) - * - * Side effects: - * If this function succeeds, the variables pointed to by the numArgsPtr - * and argTypePtr arguments will be updated to detail the arguments - * allowed by the function. The variable pointed to by the procPtr - * argument will be set to NULL if the function is a builtin function, - * and will be set to the address of the C function used to implement the - * math function otherwise (in which case the variable pointed to by the - * clientDataPtr argument will also be updated.) - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetMathFuncInfo( - Tcl_Interp *interp, - const char *name, - int *numArgsPtr, - Tcl_ValueType **argTypesPtr, - Tcl_MathProc **procPtr, - void **clientDataPtr) -{ - Tcl_Obj *cmdNameObj; - Command *cmdPtr; - - /* - * Get the command that implements the math function. - */ - - TclNewLiteralStringObj(cmdNameObj, "tcl::mathfunc::"); - Tcl_AppendToObj(cmdNameObj, name, -1); - Tcl_IncrRefCount(cmdNameObj); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdNameObj); - Tcl_DecrRefCount(cmdNameObj); - - /* - * Report unknown functions. - */ - - if (cmdPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown math function \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, (void *)NULL); - *numArgsPtr = -1; - *argTypesPtr = NULL; - *procPtr = NULL; - *clientDataPtr = NULL; - return TCL_ERROR; - } - - /* - * Retrieve function info for user defined functions; return dummy - * information for builtins. - */ - - if (cmdPtr->objProc == &OldMathFuncProc) { - OldMathFuncData *dataPtr = (OldMathFuncData *)cmdPtr->clientData; - - *procPtr = dataPtr->proc; - *numArgsPtr = dataPtr->numArgs; - *argTypesPtr = dataPtr->argTypes; - *clientDataPtr = dataPtr->clientData; - } else { - *procPtr = NULL; - *numArgsPtr = -1; - *argTypesPtr = NULL; - *procPtr = NULL; - *clientDataPtr = NULL; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ListMathFuncs -- - * - * Produces a list of all the math functions defined in a given - * interpreter. - * - * Results: - * A pointer to a Tcl_Obj structure with a reference count of zero, or - * NULL in the case of an error (in which case a suitable error message - * will be left in the interpreter result.) - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_ListMathFuncs( - Tcl_Interp *interp, - const char *pattern) -{ - Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1); - Tcl_Obj *result; - Tcl_InterpState state; - - if (pattern) { - Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); - Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj); - - Tcl_AppendObjToObj(script, arg); - Tcl_DecrRefCount(arg); /* Should tear down patternObj too */ + Tcl_Free(cmdPtr); } - - state = Tcl_SaveInterpState(interp, TCL_OK); - Tcl_IncrRefCount(script); - if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) { - result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); - } else { - TclNewObj(result); - } - Tcl_DecrRefCount(script); - Tcl_RestoreInterpState(interp, state); - - return result; } -#endif /* !defined(TCL_NO_DEPRECATED) */ /* *---------------------------------------------------------------------- @@ -4362,7 +4008,7 @@ Tcl_ListMathFuncs( * otherwise. * * Side effects: - * The interpreters object and string results are cleared. + * The interpreter's result is cleared. * *---------------------------------------------------------------------- */ @@ -4386,7 +4032,7 @@ TclInterpReady( if (iPtr->flags & DELETED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to call eval in deleted interpreter", TCL_INDEX_NONE)); + "attempt to call eval in deleted interpreter", -1)); Tcl_SetErrorCode(interp, "TCL", "IDELETE", "attempt to call eval in deleted interpreter", (void *)NULL); return TCL_ERROR; @@ -4415,7 +4061,7 @@ TclInterpReady( } Tcl_SetObjResult(interp, Tcl_NewStringObj( - "too many nested evaluations (infinite loop?)", TCL_INDEX_NONE)); + "too many nested evaluations (infinite loop?)", -1)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", (void *)NULL); return TCL_ERROR; } @@ -4532,7 +4178,7 @@ Tcl_Canceled( */ if (iPtr->asyncCancelMsg != NULL) { - message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length); + message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); } else { length = 0; } @@ -4549,7 +4195,7 @@ Tcl_Canceled( } } - Tcl_SetObjResult(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1)); Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, (void *)NULL); } @@ -4631,8 +4277,8 @@ Tcl_CancelEval( */ if (resultObjPtr != NULL) { - result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length); - cancelInfo->result = (char *)ckrealloc(cancelInfo->result,cancelInfo->length); + result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length); + cancelInfo->result = (char *)Tcl_Realloc(cancelInfo->result,cancelInfo->length); memcpy(cancelInfo->result, result, cancelInfo->length); TclDecrRefCount(resultObjPtr); /* Discard their result object. */ } else { @@ -4754,7 +4400,7 @@ EvalObjvCore( { Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0]; int flags = PTR2INT(data[1]); - Tcl_Size objc = PTR2INT(data[2]); + int objc = PTR2INT(data[2]); Tcl_Obj **objv = (Tcl_Obj **)data[3]; Interp *iPtr = (Interp *) interp; Namespace *lookupNsPtr = NULL; @@ -4914,14 +4560,14 @@ Dispatch( { Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0]; void *clientData = data[1]; - int objc = PTR2INT(data[2]); + Tcl_Size objc = PTR2INT(data[2]); Tcl_Obj **objv = (Tcl_Obj **)data[3]; Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; - int i = 0; + Tcl_Size i = 0; while (i < 10) { a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; @@ -4931,7 +4577,7 @@ Dispatch( } if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); - const char *a[6]; int i[2]; + const char *a[6]; Tcl_Size i[2]; TclDTraceInfo(info, a, i); TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); @@ -4959,30 +4605,6 @@ TclNRRunCallbacks( /* All callbacks down to rootPtr not inclusive * are to be run. */ { -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - Interp *iPtr = (Interp *) interp; -#endif /* !defined(TCL_NO_DEPRECATED) */ - - /* - * If the interpreter has a non-empty string result, the result object is - * either empty or stale because some function set interp->result - * directly. If so, move the string result to the result object, then - * reset the string result. - * - * This only needs to be done for the first item in the list: all other - * are for NR function calls, and those are Tcl_Obj based. - */ - -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - if (*(iPtr->result) != 0) { - (void) Tcl_GetObjResult(interp); - } -#endif /* !defined(TCL_NO_DEPRECATED) */ - - /* - * This is the trampoline. - */ - while (TOP_CB(interp) != rootPtr) { NRE_callback *callbackPtr = TOP_CB(interp); Tcl_NRPostProc *procPtr = callbackPtr->procPtr; @@ -5051,7 +4673,7 @@ NRCommand( static void TEOV_PushExceptionHandlers( Tcl_Interp *interp, - Tcl_Size objc, + int objc, Tcl_Obj *const objv[], int flags) { @@ -5147,7 +4769,7 @@ TEOV_Error( Tcl_Obj *listPtr; const char *cmdString; Tcl_Size cmdLen; - Tcl_Size objc = PTR2INT(data[0]); + int objc = PTR2INT(data[0]); Tcl_Obj **objv = (Tcl_Obj **)data[1]; if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { @@ -5158,7 +4780,7 @@ TEOV_Error( */ listPtr = Tcl_NewListObj(objc, objv); - cmdString = TclGetStringFromObj(listPtr, &cmdLen); + cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); Tcl_DecrRefCount(listPtr); } @@ -5169,7 +4791,7 @@ TEOV_Error( static int TEOV_NotFound( Tcl_Interp *interp, - Tcl_Size objc, + int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr) { @@ -5270,11 +4892,11 @@ TEOV_NotFoundCallback( int result) { Interp *iPtr = (Interp *) interp; - Tcl_Size objc = PTR2INT(data[0]); + int objc = PTR2INT(data[0]); Tcl_Obj **objv = (Tcl_Obj **)data[1]; Namespace *savedNsPtr = (Namespace *)data[2]; - Tcl_Size i; + int i; if (savedNsPtr) { iPtr->varFramePtr->nsPtr = savedNsPtr; @@ -5297,14 +4919,14 @@ TEOV_RunEnterTraces( Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, - Tcl_Size objc, + int objc, Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; Tcl_Size length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch; int traceCode = TCL_OK; - const char *command = TclGetStringFromObj(commandPtr, &length); + const char *command = Tcl_GetStringFromObj(commandPtr, &length); /* * Call trace functions. @@ -5351,12 +4973,12 @@ TEOV_RunLeaveTraces( { Interp *iPtr = (Interp *) interp; int traceCode = TCL_OK; - Tcl_Size objc = PTR2INT(data[0]); + int objc = PTR2INT(data[0]); Tcl_Obj *commandPtr = (Tcl_Obj *)data[1]; Command *cmdPtr = (Command *)data[2]; Tcl_Obj **objv = (Tcl_Obj **)data[3]; Tcl_Size length; - const char *command = TclGetStringFromObj(commandPtr, &length); + const char *command = Tcl_GetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_DYING)) { if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { @@ -5445,56 +5067,6 @@ Tcl_EvalTokensStandard( NULL, NULL); } -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalTokens -- - * - * Given an array of tokens parsed from a Tcl command (e.g., the tokens - * that make up a word or the index for an array variable) this function - * evaluates the tokens and concatenates their values to form a single - * result value. - * - * Results: - * The return value is a pointer to a newly allocated Tcl_Obj containing - * the value of the array of tokens. The reference count of the returned - * object has been incremented. If an error occurs in evaluating the - * tokens then a NULL value is returned and an error message is left in - * interp's result. - * - * Side effects: - * A new object is allocated to hold the result. - * - *---------------------------------------------------------------------- - * - * This uses a non-standard return convention; its use is now deprecated. It - * is a wrapper for the new function Tcl_EvalTokensStandard, and is not used - * in the core any longer. It is only kept for backward compatibility. - */ - -Tcl_Obj * -Tcl_EvalTokens( - Tcl_Interp *interp, /* Interpreter in which to lookup variables, - * execute nested commands, and report - * errors. */ - Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to - * evaluate and concatenate. */ - Tcl_Size count) /* Number of tokens to consider at tokenPtr. - * Must be at least 1. */ -{ - Tcl_Obj *resPtr; - - if (Tcl_EvalTokensStandard(interp, tokenPtr, count) != TCL_OK) { - return NULL; - } - resPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(resPtr); - Tcl_ResetResult(interp); - return resPtr; -} -#endif /* !TCL_NO_DEPRECATED */ - /* *---------------------------------------------------------------------- * @@ -5720,9 +5292,9 @@ TclEvalEx( */ if (numWords > minObjs) { - expand = (int *)ckalloc(numWords * sizeof(int)); - objvSpace = (Tcl_Obj **)ckalloc(numWords * sizeof(Tcl_Obj *)); - lineSpace = (Tcl_Size *)ckalloc(numWords * sizeof(Tcl_Size)); + expand = (int *)Tcl_Alloc(numWords * sizeof(int)); + objvSpace = (Tcl_Obj **)Tcl_Alloc(numWords * sizeof(Tcl_Obj *)); + lineSpace = (Tcl_Size *)Tcl_Alloc(numWords * sizeof(Tcl_Size)); } expandRequested = 0; objv = objvSpace; @@ -5732,6 +5304,8 @@ TclEvalEx( for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr; objectsUsed < numWords; objectsUsed++, tokenPtr += tokenPtr->numComponents+1) { + Tcl_Size additionalObjsCount; + /* * TIP #280. Track lines to current word. Save the information * on a per-word basis, signaling dynamic words as needed. @@ -5774,19 +5348,29 @@ TclEvalEx( */ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (expanding word %d)", objectsUsed)); + "\n (expanding word %" TCL_Z_MODIFIER "u)", objectsUsed)); Tcl_DecrRefCount(objv[objectsUsed]); break; } expandRequested = 1; expand[objectsUsed] = 1; - objectsNeeded += (numElements ? numElements : 1); + additionalObjsCount = (numElements ? numElements : 1); + } else { expand[objectsUsed] = 0; - objectsNeeded++; + additionalObjsCount = 1; } + /* Currently max command words in INT_MAX */ + if (additionalObjsCount > INT_MAX || + objectsNeeded > (INT_MAX - additionalObjsCount)) { + code = TclCommandWordLimitError(interp, -1); + Tcl_DecrRefCount(objv[objectsUsed]); + break; + } + objectsNeeded += additionalObjsCount; + if (wordCLNext) { TclContinuationsEnterDerived(objv[objectsUsed], wordStart - outerScript, wordCLNext); @@ -5808,8 +5392,8 @@ TclEvalEx( if ((numWords > minObjs) || (objectsNeeded > minObjs)) { objv = objvSpace = - (Tcl_Obj **)ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); - lines = lineSpace = (Tcl_Size *)ckalloc(objectsNeeded * sizeof(Tcl_Size)); + (Tcl_Obj **)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Obj *)); + lines = lineSpace = (Tcl_Size *)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Size)); } objectsUsed = 0; @@ -5836,10 +5420,10 @@ TclEvalEx( objv += objIdx+1; if (copy != stackObjArray) { - ckfree(copy); + Tcl_Free(copy); } if (lcopy != linesStack) { - ckfree(lcopy); + Tcl_Free(lcopy); } } @@ -5884,9 +5468,9 @@ TclEvalEx( } objectsUsed = 0; if (objvSpace != stackObjArray) { - ckfree(objvSpace); + Tcl_Free(objvSpace); objvSpace = stackObjArray; - ckfree(lineSpace); + Tcl_Free(lineSpace); lineSpace = linesStack; } @@ -5896,7 +5480,7 @@ TclEvalEx( */ if (expand != expandStack) { - ckfree(expand); + Tcl_Free(expand); expand = expandStack; } } @@ -5962,11 +5546,11 @@ TclEvalEx( Tcl_FreeParse(parsePtr); } if (objvSpace != stackObjArray) { - ckfree(objvSpace); - ckfree(lineSpace); + Tcl_Free(objvSpace); + Tcl_Free(lineSpace); } if (expand != expandStack) { - ckfree(expand); + Tcl_Free(expand); } iPtr->varFramePtr = savedVarFramePtr; @@ -6103,12 +5687,11 @@ void TclArgumentEnter( Tcl_Interp *interp, Tcl_Obj **objv, - Tcl_Size objc, + int objc, CmdFrame *cfPtr) { Interp *iPtr = (Interp *) interp; - int isNew; - Tcl_Size i; + int isNew, i; Tcl_HashEntry *hPtr; CFWord *cfwPtr; @@ -6131,7 +5714,7 @@ TclArgumentEnter( * and initialize references. */ - cfwPtr = (CFWord *)ckalloc(sizeof(CFWord)); + cfwPtr = (CFWord *)Tcl_Alloc(sizeof(CFWord)); cfwPtr->framePtr = cfPtr; cfwPtr->word = i; cfwPtr->refCount = 1; @@ -6172,10 +5755,10 @@ void TclArgumentRelease( Tcl_Interp *interp, Tcl_Obj **objv, - Tcl_Size objc) + int objc) { Interp *iPtr = (Interp *) interp; - Tcl_Size i; + int i; for (i = 1; i < objc; i++) { CFWord *cfwPtr; @@ -6191,7 +5774,7 @@ TclArgumentRelease( continue; } - ckfree(cfwPtr); + Tcl_Free(cfwPtr); Tcl_DeleteHashEntry(hPtr); } } @@ -6220,14 +5803,14 @@ void TclArgumentBCEnter( Tcl_Interp *interp, Tcl_Obj *objv[], - Tcl_Size objc, + int objc, void *codePtr, CmdFrame *cfPtr, Tcl_Size cmd, Tcl_Size pc) { ExtCmdLoc *eclPtr; - Tcl_Size word; + int word; ECL *ePtr; CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; @@ -6273,7 +5856,7 @@ TclArgumentBCEnter( int isNew; Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, objv[word], &isNew); - CFWordBC *cfwPtr = (CFWordBC *)ckalloc(sizeof(CFWordBC)); + CFWordBC *cfwPtr = (CFWordBC *)Tcl_Alloc(sizeof(CFWordBC)); cfwPtr->framePtr = cfPtr; cfwPtr->obj = objv[word]; @@ -6351,7 +5934,7 @@ TclArgumentBCRelease( Tcl_DeleteHashEntry(hPtr); } - ckfree(cfwPtr); + Tcl_Free(cfwPtr); cfwPtr = nextPtr; } @@ -6433,83 +6016,6 @@ TclArgumentGet( /* *---------------------------------------------------------------------- * - * Tcl_Eval -- - * - * Execute a Tcl command in a string. This function executes the script - * directly, rather than compiling it to bytecodes. Before the arrival of - * the bytecode compiler in Tcl 8.0 Tcl_Eval was the main function used - * for executing Tcl commands, but nowadays it isn't used much. - * - * Results: - * The return value is one of the return codes defined in tcl.h (such as - * TCL_OK), and interp's result contains a value to supplement the return - * code. The value of the result will persist only until the next call to - * Tcl_Eval or Tcl_EvalObj: you must copy it or lose it! - * - * Side effects: - * Can be almost arbitrary, depending on the commands in the script. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_Eval -int -Tcl_Eval( - Tcl_Interp *interp, /* Token for command interpreter (returned by - * previous call to Tcl_CreateInterp). */ - const char *script) /* Pointer to TCL command to execute. */ -{ - int code = Tcl_EvalEx(interp, script, TCL_INDEX_NONE, 0); - - /* - * For backwards compatibility with old C code that predates the object - * system in Tcl 8.0, we have to mirror the object result back into the - * string result (some callers may expect it there). - */ - - (void) Tcl_GetStringResult(interp); - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalObj, Tcl_GlobalEvalObj -- - * - * These functions are deprecated but we keep them around for backwards - * compatibility reasons. - * - * Results: - * See the functions they call. - * - * Side effects: - * See the functions they call. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_EvalObj -int -Tcl_EvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - return Tcl_EvalObjEx(interp, objPtr, 0); -} -#undef Tcl_GlobalEvalObj -int -Tcl_GlobalEvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_EvalObjEx, TclEvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are @@ -6727,7 +6233,7 @@ TclNREvalObjEx( Tcl_IncrRefCount(objPtr); - script = TclGetStringFromObj(objPtr, &numSrcBytes); + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); TclDecrRefCount(objPtr); @@ -6758,7 +6264,7 @@ TEOEx_ByteCodeCallback( ProcessUnexpectedResult(interp, result); result = TCL_ERROR; - script = TclGetStringFromObj(objPtr, &numSrcBytes); + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } @@ -6839,10 +6345,10 @@ ProcessUnexpectedResult( Tcl_ResetResult(interp); if (returnCode == TCL_BREAK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invoked \"break\" outside of a loop", TCL_INDEX_NONE)); + "invoked \"break\" outside of a loop", -1)); } else if (returnCode == TCL_CONTINUE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invoked \"continue\" outside of a loop", TCL_INDEX_NONE)); + "invoked \"continue\" outside of a loop", -1)); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "command returned bad code: %d", returnCode)); @@ -6888,13 +6394,10 @@ Tcl_ExprLong( *ptr = 0; } else { - exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE); + exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprLongObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); - if (result != TCL_OK) { - (void) Tcl_GetStringResult(interp); - } } return result; } @@ -6916,14 +6419,11 @@ Tcl_ExprDouble( *ptr = 0.0; } else { - exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE); + exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); /* Discard the expression object. */ - if (result != TCL_OK) { - (void) Tcl_GetStringResult(interp); - } } return result; } @@ -6944,19 +6444,11 @@ Tcl_ExprBoolean( return TCL_OK; } else { int result; - Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE); + Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); - if (result != TCL_OK) { - /* - * Move the interpreter's object result to the string result, then - * reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - } return result; } } @@ -7109,7 +6601,7 @@ int TclObjInvokeNamespace( Tcl_Interp *interp, /* Interpreter in which command is to be * invoked. */ - Tcl_Size objc, /* Count of arguments. */ + int objc, /* Count of arguments. */ Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the * name of the command to invoke. */ Tcl_Namespace *nsPtr, /* The namespace to use. */ @@ -7165,7 +6657,7 @@ TclObjInvoke( } if ((objc < 1) || (objv == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "illegal argument vector", TCL_INDEX_NONE)); + "illegal argument vector", -1)); return TCL_ERROR; } if ((flags & TCL_INVOKE_HIDDEN) == 0) { @@ -7264,7 +6756,7 @@ Tcl_ExprString( Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); } else { - Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, TCL_INDEX_NONE); + Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1); Tcl_IncrRefCount(exprObj); code = Tcl_ExprObj(interp, exprObj, &resultPtr); @@ -7274,12 +6766,6 @@ Tcl_ExprString( Tcl_DecrRefCount(resultPtr); } } - - /* - * Force the string rep of the interp result. - */ - - (void) Tcl_GetStringResult(interp); return code; } @@ -7302,83 +6788,17 @@ Tcl_ExprString( *---------------------------------------------------------------------- */ -#undef Tcl_AddObjErrorInfo void Tcl_AppendObjToErrorInfo( Tcl_Interp *interp, /* Interpreter to which error information * pertains. */ Tcl_Obj *objPtr) /* Message to record. */ { - int length; - const char *message = TclGetStringFromObj(objPtr, &length); + Tcl_Size length; + const char *message = Tcl_GetStringFromObj(objPtr, &length); + Interp *iPtr = (Interp *) interp; Tcl_IncrRefCount(objPtr); - Tcl_AddObjErrorInfo(interp, message, length); - Tcl_DecrRefCount(objPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AddErrorInfo -- - * - * Add information to the errorInfo field that describes the current - * error. - * - * Results: - * None. - * - * Side effects: - * The contents of message are appended to the errorInfo field. If we are - * just starting to log an error, errorInfo is initialized from the error - * message in the interpreter's result. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_AddErrorInfo -void -Tcl_AddErrorInfo( - Tcl_Interp *interp, /* Interpreter to which error information - * pertains. */ - const char *message) /* Message to record. */ -{ - Tcl_AddObjErrorInfo(interp, message, -1); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_AddObjErrorInfo -- - * - * Add information to the errorInfo field that describes the current - * error. This routine differs from Tcl_AddErrorInfo by taking a byte - * pointer and length. - * - * Results: - * None. - * - * Side effects: - * "length" bytes from "message" are appended to the errorInfo field. If - * "length" is negative, use bytes up to the first NULL byte. If we are - * just starting to log an error, errorInfo is initialized from the error - * message in the interpreter's result. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AddObjErrorInfo( - Tcl_Interp *interp, /* Interpreter to which error information - * pertains. */ - const char *message, /* Points to the first byte of an array of - * bytes of the message. */ - Tcl_Size length) /* The number of bytes in the message. If < 0, - * then append all bytes up to a NULL byte. */ -{ - Interp *iPtr = (Interp *) interp; /* * If we are just starting to log an error, errorInfo is initialized from @@ -7387,20 +6807,7 @@ Tcl_AddObjErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - if (*(iPtr->result) != 0) { - /* - * The interp's string result is set, apparently by some extension - * making a deprecated direct write to it. That extension may - * expect interp->result to continue to be set, so we'll take - * special pains to avoid clearing it, until we drop support for - * interp->result completely. - */ - - iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, TCL_INDEX_NONE); - } else -#endif /* !defined(TCL_NO_DEPRECATED) */ - iPtr->errorInfo = iPtr->objResultPtr; + iPtr->errorInfo = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", (void *)NULL); @@ -7419,12 +6826,13 @@ Tcl_AddObjErrorInfo( } Tcl_AppendToObj(iPtr->errorInfo, message, length); } + Tcl_DecrRefCount(objPtr); } /* *---------------------------------------------------------------------- * - * Tcl_VarEvalVA -- + * Tcl_VarEval -- * * Given a variable number of string arguments, concatenate them all * together and execute the result as a Tcl command. @@ -7440,18 +6848,20 @@ Tcl_AddObjErrorInfo( */ int -Tcl_VarEvalVA( - Tcl_Interp *interp, /* Interpreter in which to evaluate command */ - va_list argList) /* Variable argument list. */ +Tcl_VarEval( + Tcl_Interp *interp, + ...) { + va_list argList; + int result; Tcl_DString buf; char *string; - int result; + va_start(argList, interp); /* * Copy the strings one after the other into a single larger string. Use * stack-allocated space for small commands, but if the command gets too - * large than call ckalloc to create the space. + * large than call Tcl_Alloc to create the space. */ Tcl_DStringInit(&buf); @@ -7471,78 +6881,6 @@ Tcl_VarEvalVA( /* *---------------------------------------------------------------------- * - * Tcl_VarEval -- - * - * Given a variable number of string arguments, concatenate them all - * together and execute the result as a Tcl command. - * - * Results: - * A standard Tcl return result. An error message or other result may be - * left in the interp. - * - * Side effects: - * Depends on what was done by the command. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_VarEval( - Tcl_Interp *interp, - ...) -{ - va_list argList; - int result; - - va_start(argList, interp); - result = Tcl_VarEvalVA(interp, argList); - va_end(argList); - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GlobalEval -- - * - * Evaluate a command at global level in an interpreter. - * - * Results: - * A standard Tcl result is returned, and the interp's result is modified - * accordingly. - * - * Side effects: - * The command string is executed in interp, and the execution is carried - * out in the variable context of global level (no functions active), - * just as if an "uplevel #0" command were being executed. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_GlobalEval -int -Tcl_GlobalEval( - Tcl_Interp *interp, /* Interpreter in which to evaluate - * command. */ - const char *command) /* Command to evaluate. */ -{ - Interp *iPtr = (Interp *) interp; - int result; - CallFrame *savedVarFramePtr; - - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = iPtr->rootFramePtr; - result = Tcl_EvalEx(interp, command, -1, 0); - iPtr->varFramePtr = savedVarFramePtr; - return result; -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_SetRecursionLimit -- * * Set the maximum number of recursive calls that may be active for an @@ -7838,7 +7176,7 @@ ExprIsqrtFunc( negarg: Tcl_SetObjResult(interp, Tcl_NewStringObj( - "square root of negative argument", TCL_INDEX_NONE)); + "square root of negative argument", -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", (void *)NULL); return TCL_ERROR; @@ -8041,7 +7379,7 @@ ExprAbsFunc( } else if (l == 0) { if (TclHasStringRep(objv[1])) { Tcl_Size numBytes; - const char *bytes = TclGetStringFromObj(objv[1], &numBytes); + const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes); while (numBytes) { if (*bytes == '-') { @@ -9009,7 +8347,7 @@ void TclDTraceInfo( Tcl_Obj *info, const char **args, - int *argsi) + Tcl_Size *argsi) { static Tcl_Obj *keys[10] = { NULL }; Tcl_Obj **k = keys, *val; @@ -9049,7 +8387,7 @@ TclDTraceInfo( for (i = 0; i < 2; i++) { Tcl_DictObjGet(NULL, info, *k++, &val); if (val) { - TclGetIntFromObj(NULL, val, &argsi[i]); + Tcl_GetSizeIntFromObj(NULL, val, &argsi[i]); } else { argsi[i] = 0; } @@ -9130,6 +8468,45 @@ Tcl_NRCallObjProc( return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } +int wrapperNRObjProc( + void *clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; + clientData = info->clientData; + Tcl_ObjCmdProc2 *proc = info->proc; + Tcl_Free(info); + if (objc < 0) { + objc = -1; + } + return proc(clientData, interp, (Tcl_Size)objc, objv); +} + +int +Tcl_NRCallObjProc2( + Tcl_Interp *interp, + Tcl_ObjCmdProc2 *objProc, + void *clientData, + Tcl_Size objc, + Tcl_Obj *const objv[]) +{ + if (objc > INT_MAX) { + Tcl_WrongNumArgs(interp, 1, objv, "?args?"); + return TCL_ERROR; + } + + NRE_callback *rootPtr = TOP_CB(interp); + CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); + info->clientData = clientData; + info->proc = objProc; + + TclNRAddCallback(interp, Dispatch, wrapperNRObjProc, info, + INT2PTR(objc), objv); + return TclNRRunCallbacks(interp, TCL_OK, rootPtr); +} + /* *---------------------------------------------------------------------- * @@ -9144,7 +8521,7 @@ Tcl_NRCallObjProc( * 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. @@ -9158,6 +8535,50 @@ Tcl_NRCallObjProc( *---------------------------------------------------------------------- */ +static int cmdWrapperNreProc( + void *clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; + if (objc < 0) { + objc = -1; + } + return info->nreProc(info->clientData, interp, objc, objv); +} + +Tcl_Command +Tcl_NRCreateCommand2( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ + const char *cmdName, /* Name of command. If it contains namespace + * qualifiers, the new command is put in the + * specified namespace; otherwise it is put in + * the global namespace. */ + Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with + * name, provides direct access for direct + * calls. */ + Tcl_ObjCmdProc2 *nreProc, /* Object-based function to associate with + * name, provides NR implementation */ + void *clientData, /* Arbitrary value to pass to object + * function. */ + Tcl_CmdDeleteProc *deleteProc) + /* If not NULL, gives a function to call when + * this command is deleted. */ +{ + CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); + info->proc = proc; + info->clientData = clientData; + info->nreProc = nreProc; + info->deleteProc = deleteProc; + info->deleteData = clientData; + return Tcl_NRCreateCommand(interp, cmdName, + (proc ? cmdWrapperProc : NULL), + (nreProc ? cmdWrapperNreProc : NULL), + info, cmdWrapperDeleteProc); +} + Tcl_Command Tcl_NRCreateCommand( Tcl_Interp *interp, /* Token for command interpreter (returned by @@ -9369,7 +8790,7 @@ TclNRTailcallObjCmd( if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "tailcall can only be called from a proc, lambda or method", TCL_INDEX_NONE)); + "tailcall can only be called from a proc, lambda or method", -1)); Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (void *)NULL); return TCL_ERROR; } @@ -9399,7 +8820,7 @@ TclNRTailcallObjCmd( * namespace, the rest the command to be tailcalled. */ - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE); + nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); listPtr = Tcl_NewListObj(objc, objv); TclListObjSetElement(interp, listPtr, 0, nsObjPtr); @@ -9531,7 +8952,7 @@ TclNRYieldObjCmd( if (!corPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yield can only be called in a coroutine", TCL_INDEX_NONE)); + "yield can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (void *)NULL); return TCL_ERROR; } @@ -9564,14 +8985,14 @@ TclNRYieldToObjCmd( if (!corPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto can only be called in a coroutine", TCL_INDEX_NONE)); + "yieldto can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (void *)NULL); return TCL_ERROR; } if (((Namespace *) nsPtr)->flags & NS_DYING) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto called in deleted namespace", TCL_INDEX_NONE)); + "yieldto called in deleted namespace", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", (void *)NULL); return TCL_ERROR; @@ -9584,7 +9005,7 @@ TclNRYieldToObjCmd( */ listPtr = Tcl_NewListObj(objc, objv); - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE); + nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); TclListObjSetElement(interp, listPtr, 0, nsObjPtr); /* @@ -9665,7 +9086,7 @@ NRCoroutineCallerCallback( NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr); NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr); NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr); - ckfree(corPtr); + Tcl_Free(corPtr); return result; } @@ -9724,7 +9145,7 @@ NRCoroutineExitCallback( */ Tcl_DeleteHashTable(corPtr->lineLABCPtr); - ckfree(corPtr->lineLABCPtr); + Tcl_Free(corPtr->lineLABCPtr); corPtr->lineLABCPtr = NULL; RESTORE_CONTEXT(corPtr->caller); @@ -9807,7 +9228,7 @@ TclNRCoroutineActivateCallback( Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot yield: C stack busy", TCL_INDEX_NONE)); + "cannot yield: C stack busy", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", (void *)NULL); return TCL_ERROR; @@ -9896,7 +9317,7 @@ CoroTypeObjCmd( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only get coroutine type of a coroutine", TCL_INDEX_NONE)); + "can only get coroutine type of a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", TclGetString(objv[1]), (void *)NULL); return TCL_ERROR; @@ -9909,7 +9330,7 @@ CoroTypeObjCmd( corPtr = (CoroutineData *)cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("active", TCL_INDEX_NONE)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1)); return TCL_OK; } @@ -9920,14 +9341,14 @@ CoroTypeObjCmd( switch (corPtr->nargs) { case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: - Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", TCL_INDEX_NONE)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1)); return TCL_OK; case COROUTINE_ARGUMENTS_ARBITRARY: - Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", TCL_INDEX_NONE)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1)); return TCL_OK; default: Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unknown coroutine type", TCL_INDEX_NONE)); + "unknown coroutine type", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", (void *)NULL); return TCL_ERROR; } @@ -9956,7 +9377,7 @@ GetCoroutineFromObj( Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_INDEX_NONE)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", TclGetString(objPtr), (void *)NULL); return NULL; @@ -9990,7 +9411,7 @@ TclNRCoroInjectObjCmd( } if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a suspended coroutine", TCL_INDEX_NONE)); + "can only inject a command into a suspended coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (void *)NULL); return TCL_ERROR; } @@ -10036,7 +9457,7 @@ TclNRCoroProbeObjCmd( if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only inject a probe command into a suspended coroutine", - TCL_INDEX_NONE)); + -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (void *)NULL); return TCL_ERROR; } @@ -10227,7 +9648,7 @@ NRInjectObjCmd( } if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a suspended coroutine", TCL_INDEX_NONE)); + "can only inject a command into a suspended coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (void *)NULL); return TCL_ERROR; } @@ -10281,7 +9702,7 @@ TclNRInterpCoroutine( if (corPtr->nargs + 1 != objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong coro nargs; how did we get here? " - "not implemented!", TCL_INDEX_NONE)); + "not implemented!", -1)); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL); return TCL_ERROR; } @@ -10352,7 +9773,7 @@ TclNRCoroutineObjCmd( * struct and create the corresponding command. */ - corPtr = (CoroutineData *)ckalloc(sizeof(CoroutineData)); + corPtr = (CoroutineData *)Tcl_Alloc(sizeof(CoroutineData)); cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, @@ -10374,7 +9795,7 @@ TclNRCoroutineObjCmd( Tcl_HashSearch hSearch; Tcl_HashEntry *hePtr; - corPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + corPtr->lineLABCPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch); diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 9b59ee7..429f7c1 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -55,25 +55,22 @@ * Prototypes for local procedures defined in this file: */ -static void DupByteArrayInternalRep(Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr); static void DupProperByteArrayInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static int FormatNumber(Tcl_Interp *interp, int type, Tcl_Obj *src, unsigned char **cursorPtr); -static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr); static int GetFormatSpec(const char **formatPtr, char *cmdPtr, Tcl_Size *countPtr, int *flagsPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, int flags, Tcl_HashTable **numberCachePtr); -static int SetByteArrayFromAny(Tcl_Interp *interp, +static int SetByteArrayFromAny(Tcl_Interp *interp, Tcl_Size limit, Tcl_Obj *objPtr); static void UpdateStringOfByteArray(Tcl_Obj *listPtr); static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); static int NeedReversing(int format); static void CopyNumber(const void *from, void *to, - unsigned int length, int type); + size_t length, int type); /* Binary ensemble commands */ static Tcl_ObjCmdProc BinaryFormatCmd; static Tcl_ObjCmdProc BinaryScanCmd; @@ -148,9 +145,6 @@ static const EnsembleImplMap decodeMap[] = { * or damage. Such values are useful for things like encoded strings or Tk * images to name just two. * - * It's strange to have two Tcl_ObjTypes in place for this task when one would - * do, so a bit of detail and history will aid understanding. - * * A bytearray is an ordered sequence of bytes. Each byte is an integer value * in the range [0-255]. To be a Tcl value type, we need a way to encode each * value in the value set as a Tcl string. A simple encoding is to @@ -158,50 +152,9 @@ static const EnsembleImplMap decodeMap[] = { * bytes is encoded into a Tcl string of N characters where the codepoint of * each character is the value of corresponding byte. This approach creates a * one-to-one map between all bytearray values and a subset of Tcl string - * values. - * - * When converting a Tcl string value to the bytearray internal rep, the - * question arises what to do with strings outside that subset? That is, - * those Tcl strings containing at least one codepoint greater than 255? The - * obviously correct answer is to raise an error! That string value does not - * represent any valid bytearray value. - * - * Unfortunately this was not the path taken by the authors of the original - * tclByteArrayType. They chose to accept all Tcl string values as acceptable - * string encodings of the bytearray values that result from masking away the - * high bits of any codepoint value at all. This meant that every bytearray - * value had multiple accepted string representations. - * - * The implications of this choice are truly ugly, and motivated the proposal - * of TIP 568 to migrate away from it and to the more sensible design where - * each bytearray value has only one string representation. Full details are - * recorded in that TIP for those who seek them. - * - * The Tcl_ObjType "properByteArrayType" is (nearly) a correct implementation - * of bytearrays. Any Tcl value with the type properByteArrayType can have - * its bytearray value fetched and used with confidence that acting on that - * value is equivalent to acting on the true Tcl string value. This still - * implies a side testing burden -- past mistakes will not let us avoid that - * immediately, but it is at least a conventional test of type, and can be - * implemented entirely by examining the objPtr fields, with no need to query - * the internalrep, as a canonical flag would require. This benefit is made - * available to extensions through the public routine Tcl_GetBytesFromObj(), - * first available in Tcl 8.7. - * - * The public routines Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() - * must continue to follow their documented behavior through the 8.* series of - * releases. To support that legacy operation, we need a mechanism to retain - * compatibility with the deployed callers of the broken interface. That's - * what the retained "tclByteArrayType" provides. In those unusual - * circumstances where we convert an invalid bytearray value to a bytearray - * type, it is to this legacy type. Essentially any time this legacy type - * shows up, it's a signal of a bug being ignored. - * - * In Tcl 9, the incompatibility in the behavior of these public routines - * has been approved, and the legacy internal rep is no longer retained. - * The internal changes seen below are the limit of what can be done - * in a Tcl 8.* release. They provide a great expansion of the histories - * over which bytearray values can be useful. + * values. Tcl string values outside that subset do no represent any valid + * bytearray value. Attempts to treat those values as bytearrays will lead + * to errors. See TIP 568 for how this differs from Tcl 8. */ static const Tcl_ObjType properByteArrayType = { @@ -209,15 +162,8 @@ static const Tcl_ObjType properByteArrayType = { FreeProperByteArrayInternalRep, DupProperByteArrayInternalRep, UpdateStringOfByteArray, - NULL -}; - -const Tcl_ObjType tclByteArrayType = { - "bytearray", - FreeByteArrayInternalRep, - DupByteArrayInternalRep, NULL, - SetByteArrayFromAny + TCL_OBJTYPE_V0 }; /* @@ -227,26 +173,25 @@ const Tcl_ObjType tclByteArrayType = { * fewer mallocs. */ -typedef struct ByteArray { - unsigned int bad; /* Index of first character that is a nonbyte. - * If all characters are bytes, bad = used. */ - unsigned int used; /* The number of bytes used in the byte - * array. Must be <= allocated. The bytes - * used to store the value are indexed from - * 0 to used-1. */ - unsigned int allocated; /* The number of bytes of space allocated. */ - unsigned char bytes[TCLFLEXARRAY]; - /* The array of bytes. The actual size of this - * field is stored in the 'allocated' field +typedef struct { + Tcl_Size used; /* The number of bytes used in the byte + * array. */ + Tcl_Size allocated; /* The amount of space actually allocated + * minus 1 byte. */ + unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this + * field depends on the 'allocated' field * above. */ } ByteArray; +#define BYTEARRAY_MAX_LEN (TCL_SIZE_MAX - (Tcl_Size)offsetof(ByteArray, bytes)) #define BYTEARRAY_SIZE(len) \ - (offsetof(ByteArray, bytes) + (len)) + ( (len < 0 || BYTEARRAY_MAX_LEN < (len)) \ + ? (Tcl_Panic("negative length specified or max size of a Tcl value exceeded"), 0) \ + : (offsetof(ByteArray, bytes) + (len)) ) #define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) #define SET_BYTEARRAY(irPtr, baPtr) \ - (irPtr)->twoPtrValue.ptr1 = (void *) (baPtr) - + (irPtr)->twoPtrValue.ptr1 = (baPtr) + int TclIsPureByteArray( Tcl_Obj * objPtr) @@ -263,7 +208,7 @@ TclIsPureByteArray( * from the given array of bytes. * * Results: - * The newly created object is returned. This object has no initial + * The newly create object is returned. This object will have no initial * string representation. The returned object has a ref count of 0. * * Side effects: @@ -278,8 +223,7 @@ Tcl_Obj * Tcl_NewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - int numBytes) /* Number of bytes in the array, - * must be >= 0. */ + Tcl_Size numBytes) /* Number of bytes in the array */ { #ifdef TCL_MEM_DEBUG return Tcl_DbNewByteArrayObj(bytes, numBytes, "unknown", 0); @@ -322,8 +266,7 @@ Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - int numBytes, /* Number of bytes in the array, - * must be >= 0. */ + Tcl_Size numBytes, /* Number of bytes in the array */ const char *file, /* The name of the source file calling this * procedure; used for debugging. */ int line) /* Line number in the source file; used for @@ -340,8 +283,7 @@ Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - int numBytes, /* Number of bytes in the array, - * must be >= 0. */ + Tcl_Size numBytes, /* Number of bytes in the array */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { @@ -372,8 +314,8 @@ Tcl_SetByteArrayObj( Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */ const unsigned char *bytes, /* The array of bytes to use as the new value. * May be NULL even if numBytes > 0. */ - int numBytes) /* Number of bytes in the array, - * must be >= 0. */ + Tcl_Size numBytes) /* Number of bytes in the array. + * Must be >= 0 */ { ByteArray *byteArrayPtr; Tcl_ObjInternalRep ir; @@ -384,8 +326,7 @@ Tcl_SetByteArrayObj( TclInvalidateStringRep(objPtr); assert(numBytes >= 0); - byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(numBytes)); - byteArrayPtr->bad = numBytes; + byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes)); byteArrayPtr->used = numBytes; byteArrayPtr->allocated = numBytes; @@ -400,7 +341,7 @@ Tcl_SetByteArrayObj( /* *---------------------------------------------------------------------- * - * Tcl_GetBytesFromObj -- + * TclGetBytesFromObj -- * * Attempt to extract the value from objPtr in the representation * of a byte sequence. On success return the extracted byte sequence. @@ -414,36 +355,23 @@ Tcl_SetByteArrayObj( *---------------------------------------------------------------------- */ +#undef Tcl_GetBytesFromObj unsigned char * Tcl_GetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj *objPtr, /* Value to extract from */ - int *numBytesPtr) /* If non-NULL, write the number of bytes + Tcl_Size *numBytesPtr) /* If non-NULL, write the number of bytes * in the array here */ { ByteArray *baPtr; - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); + const Tcl_ObjInternalRep *irPtr + = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - if (interp) { - const char *nonbyte; - int ucs4; - - irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); - baPtr = GET_BYTEARRAY(irPtr); - nonbyte = TclUtfAtIndex(Tcl_GetString(objPtr), baPtr->bad); - Tcl_UtfToUniChar(nonbyte, &ucs4); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected byte sequence but character %d " - "was '%1s' (U+%06X)", baPtr->bad, nonbyte, ucs4)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", (void *)NULL); - } + if (TCL_ERROR == SetByteArrayFromAny(interp, TCL_INDEX_NONE, objPtr)) { return NULL; } + irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); } baPtr = GET_BYTEARRAY(irPtr); @@ -452,49 +380,36 @@ Tcl_GetBytesFromObj( } return baPtr->bytes; } - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetByteArrayFromObj -- - * - * Attempt to get the array of bytes from the Tcl object. If the object - * is not already a ByteArray object, an attempt will be made to convert - * it to one. - * - * Results: - * Pointer to array of bytes representing the ByteArray object. - * - * Side effects: - * Frees old internal rep. Allocates memory for new internal rep. - * - *---------------------------------------------------------------------- - */ +#if !defined(TCL_NO_DEPRECATED) unsigned char * -Tcl_GetByteArrayFromObj( - Tcl_Obj *objPtr, /* The ByteArray object. */ - Tcl_Size *numBytesPtr) /* If non-NULL, write the number of bytes +TclGetBytesFromObj( + Tcl_Interp *interp, /* For error reporting */ + Tcl_Obj *objPtr, /* Value to extract from */ + void *numBytesPtr) /* If non-NULL, write the number of bytes * in the array here */ { - ByteArray *baPtr; - const Tcl_ObjInternalRep *irPtr; - unsigned char *result = Tcl_GetBytesFromObj(NULL, objPtr, numBytesPtr); - - if (result) { - return result; - } + Tcl_Size numBytes = 0; + unsigned char *bytes = Tcl_GetBytesFromObj(interp, objPtr, &numBytes); - irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); - assert(irPtr != NULL); - - baPtr = GET_BYTEARRAY(irPtr); + if (bytes && numBytesPtr) { + if (numBytes > INT_MAX) { + /* Caller asked for numBytes to be written to an int, but the + * value is outside the int range. */ - if (numBytesPtr != NULL) { - *numBytesPtr = baPtr->used; + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "byte sequence length exceeds INT_MAX", -1)); + Tcl_SetErrorCode(interp, "TCL", "API", "OUTDATED", (void *)NULL); + } + return NULL; + } else { + *(int *)numBytesPtr = (int) numBytes; + } } - return (unsigned char *) baPtr->bytes; + return bytes; } +#endif /* *---------------------------------------------------------------------- @@ -521,110 +436,157 @@ Tcl_GetByteArrayFromObj( unsigned char * Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ - int numBytes) /* Number of bytes in resized array */ + Tcl_Size numBytes) /* Number of bytes in resized array + * Must be >= 0 */ { ByteArray *byteArrayPtr; - unsigned newLength; Tcl_ObjInternalRep *irPtr; assert(numBytes >= 0); - newLength = (unsigned int)numBytes; - if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); - if (irPtr == NULL) { - SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); - } + if (TCL_ERROR == SetByteArrayFromAny(NULL, numBytes, objPtr)) { + return NULL; } + irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); } - /* Note that during truncation, the implementation does not free - * memory that is no longer needed. */ - byteArrayPtr = GET_BYTEARRAY(irPtr); - if (newLength > byteArrayPtr->allocated) { - byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength)); - byteArrayPtr->allocated = newLength; + if (numBytes > byteArrayPtr->allocated) { + byteArrayPtr = (ByteArray *)Tcl_Realloc(byteArrayPtr, + BYTEARRAY_SIZE(numBytes)); + byteArrayPtr->allocated = numBytes; SET_BYTEARRAY(irPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - objPtr->typePtr = &properByteArrayType; - byteArrayPtr->bad = newLength; - byteArrayPtr->used = newLength; + byteArrayPtr->used = numBytes; return byteArrayPtr->bytes; } /* *---------------------------------------------------------------------- * + * MakeByteArray -- + * + * Generate a ByteArray internal rep from the string rep of objPtr. + * The generated byte sequence may have no more than limit bytes. + * A negative value for limit indicates no limit imposed. If + * boolean argument demandProper is true, then no byte sequence should + * be output to the caller (write NULL instead). When no bytes sequence + * is output and interp is not NULL, leave an error message and error + * code in interp explaining why a proper byte sequence could not be + * made. + * + * Results: + * Returns a boolean indicating whether the bytes generated (up to + * limit bytes) are a proper representation of (a limited prefix of) + * the string. Writes a pointer to the generated ByteArray to + * *byteArrayPtrPtr. If not NULL it needs to be released with Tcl_Free(). + * + *---------------------------------------------------------------------- + */ + +static int +MakeByteArray( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Size limit, + int demandProper, + ByteArray **byteArrayPtrPtr) +{ + Tcl_Size length; + const char *src = Tcl_GetStringFromObj(objPtr, &length); + Tcl_Size numBytes = (limit >= 0 && limit < length) ? limit : length; + ByteArray *byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes)); + unsigned char *dst = byteArrayPtr->bytes; + unsigned char *dstEnd = dst + numBytes; + const char *srcEnd = src + length; + int proper = 1; + + for (; src < srcEnd && dst < dstEnd; ) { + int ch; + int count = Tcl_UtfToUniChar(src, &ch); + + if (ch > 255) { + proper = 0; + if (demandProper) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected byte sequence but character %" + TCL_Z_MODIFIER "u was '%1s' (U+%06X)", + dst - byteArrayPtr->bytes, src, ch)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", (void *)NULL); + } + Tcl_Free(byteArrayPtr); + *byteArrayPtrPtr = NULL; + return proper; + } + } + src += count; + *dst++ = UCHAR(ch); + } + byteArrayPtr->used = dst - byteArrayPtr->bytes; + byteArrayPtr->allocated = numBytes; + + *byteArrayPtrPtr = byteArrayPtr; + return proper; +} + +static Tcl_Obj * +TclNarrowToBytes( + Tcl_Obj *objPtr) +{ + if (NULL == TclFetchInternalRep(objPtr, &properByteArrayType)) { + Tcl_ObjInternalRep ir; + ByteArray *byteArrayPtr; + + if (0 == MakeByteArray(NULL, objPtr, TCL_INDEX_NONE, 0, &byteArrayPtr)) { + TclNewObj(objPtr); + TclInvalidateStringRep(objPtr); + } + SET_BYTEARRAY(&ir, byteArrayPtr); + Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir); + } + Tcl_IncrRefCount(objPtr); + return objPtr; +} + + +/* + *---------------------------------------------------------------------- + * * SetByteArrayFromAny -- * * Generate the ByteArray internal rep from the string rep. * * Results: - * The return value is always TCL_OK. + * Tcl return code indicating OK or ERROR. * * Side effects: - * A ByteArray object is stored as the internal rep of objPtr. + * A ByteArray struct may be stored as the internal rep of objPtr. * *---------------------------------------------------------------------- */ static int SetByteArrayFromAny( - TCL_UNUSED(Tcl_Interp *), + Tcl_Interp *interp, /* For error reporting. */ + Tcl_Size limit, /* Create no more than this many bytes */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { - int length, bad; - const char *src, *srcEnd; - unsigned char *dst; - Tcl_UniChar ch = 0; ByteArray *byteArrayPtr; Tcl_ObjInternalRep ir; - if (TclHasInternalRep(objPtr, &properByteArrayType)) { - return TCL_OK; - } - if (TclHasInternalRep(objPtr, &tclByteArrayType)) { - return TCL_OK; - } - - src = TclGetStringFromObj(objPtr, &length); - bad = length; - srcEnd = src + length; - - /* Note the allocation is over-sized, possibly by a factor of four, - * or even a factor of two with a proper byte array value. */ - - byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); - for (dst = byteArrayPtr->bytes; src < srcEnd; ) { - src += TclUtfToUniChar(src, &ch); - if ((bad == length) && (ch > 255)) { - bad = dst - byteArrayPtr->bytes; - } - *dst++ = UCHAR(ch); + if (0 == MakeByteArray(interp, objPtr, limit, 1, &byteArrayPtr)) { + return TCL_ERROR; } SET_BYTEARRAY(&ir, byteArrayPtr); - byteArrayPtr->allocated = length; - byteArrayPtr->used = dst - byteArrayPtr->bytes; - - if (bad == length) { - byteArrayPtr->bad = byteArrayPtr->used; - Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir); - } else { - byteArrayPtr->bad = bad; - Tcl_StoreInternalRep(objPtr, &tclByteArrayType, &ir); - } - + Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir); return TCL_OK; } @@ -646,17 +608,10 @@ SetByteArrayFromAny( */ static void -FreeByteArrayInternalRep( - Tcl_Obj *objPtr) /* Object with internal rep to free. */ -{ - ckfree(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &tclByteArrayType))); -} - -static void FreeProperByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ckfree(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &properByteArrayType))); + Tcl_Free(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &properByteArrayType))); } /* @@ -677,41 +632,18 @@ FreeProperByteArrayInternalRep( */ static void -DupByteArrayInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ -{ - unsigned int length; - ByteArray *srcArrayPtr, *copyArrayPtr; - Tcl_ObjInternalRep ir; - - srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &tclByteArrayType)); - length = srcArrayPtr->used; - - copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); - copyArrayPtr->bad = srcArrayPtr->bad; - copyArrayPtr->used = length; - copyArrayPtr->allocated = length; - memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); - - SET_BYTEARRAY(&ir, copyArrayPtr); - Tcl_StoreInternalRep(copyPtr, &tclByteArrayType, &ir); -} - -static void DupProperByteArrayInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - unsigned int length; + Tcl_Size length; ByteArray *srcArrayPtr, *copyArrayPtr; Tcl_ObjInternalRep ir; srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &properByteArrayType)); length = srcArrayPtr->used; - copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); - copyArrayPtr->bad = length; + copyArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length)); copyArrayPtr->used = length; copyArrayPtr->allocated = length; memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); @@ -745,21 +677,18 @@ UpdateStringOfByteArray( const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr); unsigned char *src = byteArrayPtr->bytes; - unsigned int i, length = byteArrayPtr->used; - unsigned int size = length; + Tcl_Size i, length = byteArrayPtr->used; + Tcl_Size size = length; /* * How much space will string rep need? */ - for (i = 0; i < length && size <= INT_MAX; i++) { + for (i = 0; i < length; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } } - if (size > INT_MAX) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } if (size == length) { char *dst = Tcl_InitStringRep(objPtr, (char *)src, size); @@ -798,10 +727,10 @@ void TclAppendBytesToByteArray( Tcl_Obj *objPtr, const unsigned char *bytes, - int len) + Tcl_Size len) { ByteArray *byteArrayPtr; - unsigned int length, needed; + Tcl_Size needed; Tcl_ObjInternalRep *irPtr; if (Tcl_IsShared(objPtr)) { @@ -819,73 +748,41 @@ TclAppendBytesToByteArray( return; } - length = (unsigned int) len; - irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); - if (irPtr == NULL) { - SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); - } + if (TCL_ERROR == SetByteArrayFromAny(NULL, TCL_INDEX_NONE, objPtr)) { + Tcl_Panic("attempt to append bytes to non-bytearray"); } + irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); } byteArrayPtr = GET_BYTEARRAY(irPtr); - if (length > INT_MAX - byteArrayPtr->used) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - - needed = byteArrayPtr->used + length; /* * If we need to, resize the allocated space in the byte array. */ + if ((BYTEARRAY_MAX_LEN - byteArrayPtr->used) < len) { + /* Will wrap around !! */ + Tcl_Panic("max size of a byte array exceeded"); + } + needed = byteArrayPtr->used + len; if (needed > byteArrayPtr->allocated) { - ByteArray *ptr = NULL; - unsigned int attempt; - - if (needed <= INT_MAX/2) { - /* - * Try to allocate double the total space that is needed. - */ - - attempt = 2 * needed; - ptr = (ByteArray *)attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); - } - if (ptr == NULL) { - /* - * Try to allocate double the increment that is needed (plus). - */ - - unsigned int limit = INT_MAX - needed; - unsigned int extra = length + TCL_MIN_GROWTH; - int growth = (int) ((extra > limit) ? limit : extra); - - attempt = needed + growth; - ptr = (ByteArray *)attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); - } - if (ptr == NULL) { - /* - * Last chance: Try to allocate exactly what is needed. - */ - - attempt = needed; - ptr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); - } - byteArrayPtr = ptr; - byteArrayPtr->allocated = attempt; + Tcl_Size newCapacity; + byteArrayPtr = + (ByteArray *)TclReallocElemsEx(byteArrayPtr, + needed, + 1, + offsetof(ByteArray, bytes), + &newCapacity); + byteArrayPtr->allocated = newCapacity; SET_BYTEARRAY(irPtr, byteArrayPtr); } if (bytes) { - memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, length); + memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); } - byteArrayPtr->used += length; + byteArrayPtr->used += len; TclInvalidateStringRep(objPtr); - objPtr->typePtr = &properByteArrayType; } /* @@ -944,7 +841,7 @@ BinaryFormatCmd( int value = 0; /* Current integer value to be packed. * Initialized to avoid compiler warning. */ char cmd; /* Current format character. */ - int count; /* Count associated with current format + Tcl_Size count; /* Count associated with current format * character. */ int flags; /* Format field flags */ const char *format; /* Pointer to current position in format @@ -956,7 +853,7 @@ BinaryFormatCmd( * cursor has visited.*/ const char *errorString; const char *errorValue, *str; - int offset, size, length; + Tcl_Size offset, size, length; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg ...?"); @@ -995,7 +892,9 @@ BinaryFormatCmd( goto badIndex; } if (count == BINARY_ALL) { - Tcl_GetByteArrayFromObj(objv[arg], &count); + if (Tcl_GetBytesFromObj(NULL, objv[arg], &count) == NULL) { + count = Tcl_GetCharLength(objv[arg]); + } } else if (count == BINARY_NOCOUNT) { count = 1; } @@ -1052,7 +951,7 @@ BinaryFormatCmd( arg++; count = 1; } else { - int listc; + Tcl_Size listc; Tcl_Obj **listv; /* @@ -1162,8 +1061,9 @@ BinaryFormatCmd( case 'A': { char pad = (char) (cmd == 'a' ? '\0' : ' '); unsigned char *bytes; + Tcl_Obj *copy = TclNarrowToBytes(objv[arg++]); - bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); + bytes = Tcl_GetBytesFromObj(NULL, copy, &length); if (count == BINARY_ALL) { count = length; @@ -1177,13 +1077,14 @@ BinaryFormatCmd( memset(cursor + length, pad, count - length); } cursor += count; + Tcl_DecrRefCount(copy); break; } case 'b': case 'B': { unsigned char *last; - str = TclGetStringFromObj(objv[arg], &length); + str = Tcl_GetStringFromObj(objv[arg], &length); arg++; if (count == BINARY_ALL) { count = length; @@ -1245,7 +1146,7 @@ BinaryFormatCmd( unsigned char *last; int c; - str = TclGetStringFromObj(objv[arg], &length); + str = Tcl_GetStringFromObj(objv[arg], &length); arg++; if (count == BINARY_ALL) { count = length; @@ -1332,7 +1233,7 @@ BinaryFormatCmd( case 'q': case 'Q': case 'f': { - int listc, i; + Tcl_Size listc, i; Tcl_Obj **listv; if (count == BINARY_NOCOUNT) { @@ -1453,7 +1354,7 @@ BinaryScanCmd( int value = 0; /* Current integer value to be packed. * Initialized to avoid compiler warning. */ char cmd; /* Current format character. */ - int count; /* Count associated with current format + Tcl_Size count; /* Count associated with current format * character. */ int flags; /* Format field flags */ const char *format; /* Pointer to current position in format @@ -1462,7 +1363,7 @@ BinaryScanCmd( unsigned char *buffer; /* Start of result buffer. */ const char *errorString; const char *str; - int offset, size, length, i; + Tcl_Size offset, size, length = 0, i; Tcl_Obj *valuePtr, *elementPtr; Tcl_HashTable numberCacheHash; @@ -1473,9 +1374,12 @@ BinaryScanCmd( "value formatString ?varName ...?"); return TCL_ERROR; } + buffer = Tcl_GetBytesFromObj(interp, objv[1], &length); + if (buffer == NULL) { + return TCL_ERROR; + } numberCachePtr = &numberCacheHash; Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); - buffer = Tcl_GetByteArrayFromObj(objv[1], &length); format = TclGetString(objv[2]); arg = 3; offset = 0; @@ -1501,7 +1405,7 @@ BinaryScanCmd( if (count == BINARY_NOCOUNT) { count = 1; } - if (count > (length - offset)) { + if (count > length - offset) { goto done; } } @@ -1699,7 +1603,7 @@ BinaryScanCmd( goto badIndex; } if (count == BINARY_NOCOUNT) { - if ((length - offset) < size) { + if (length < size + offset) { goto done; } valuePtr = ScanNumber(buffer+offset, cmd, flags, @@ -1829,7 +1733,7 @@ static int GetFormatSpec( const char **formatPtr, /* Pointer to format string. */ char *cmdPtr, /* Pointer to location of command char. */ - int *countPtr, /* Pointer to repeat count value. */ + Tcl_Size *countPtr, /* Pointer to repeat count value. */ int *flagsPtr) /* Pointer to field flags */ { /* @@ -1862,14 +1766,14 @@ GetFormatSpec( (*formatPtr)++; *countPtr = BINARY_ALL; } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ - unsigned long count; + unsigned long long count; errno = 0; - count = strtoul(*formatPtr, (char **) formatPtr, 10); - if (errno || (count > (unsigned long) INT_MAX)) { - *countPtr = INT_MAX; + count = strtoull(*formatPtr, (char **) formatPtr, 10); + if (errno || (count > TCL_SIZE_MAX)) { + *countPtr = TCL_SIZE_MAX; } else { - *countPtr = (int) count; + *countPtr = count; } } else { *countPtr = BINARY_NOCOUNT; @@ -1995,7 +1899,7 @@ static void CopyNumber( const void *from, /* source */ void *to, /* destination */ - unsigned length, /* Number of bytes to copy */ + size_t length, /* Number of bytes to copy */ int type) /* What type of thing are we copying? */ { switch (NeedReversing(type)) { @@ -2062,7 +1966,7 @@ CopyNumber( * * FormatNumber -- * - * This routine is called by BinaryFormatCmd to format a number into a + * This routine is called by Tcl_BinaryObjCmd to format a number into a * location pointed at by cursor. * * Results: @@ -2235,7 +2139,7 @@ FormatNumber( * * ScanNumber -- * - * This routine is called by BinaryScanCmd to scan a number out of a + * This routine is called by Tcl_BinaryObjCmd to scan a number out of a * buffer. * * Results: @@ -2340,9 +2244,9 @@ ScanNumber( if (flags & BINARY_UNSIGNED) { return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value); } - if ((value & (((unsigned) 1) << 31)) && (value > 0)) { - value -= (((unsigned) 1) << 31); - value -= (((unsigned) 1) << 31); + if ((value & (1U << 31)) && (value > 0)) { + value -= (1U << 31); + value -= (1U << 31); } returnNumericObject: @@ -2533,15 +2437,19 @@ BinaryEncodeHex( Tcl_Obj *resultObj = NULL; unsigned char *data = NULL; unsigned char *cursor = NULL; - int offset = 0, count = 0; + Tcl_Size offset = 0, count = 0; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "data"); return TCL_ERROR; } + data = Tcl_GetBytesFromObj(interp, objv[1], &count); + if (data == NULL) { + return TCL_ERROR; + } + TclNewObj(resultObj); - data = Tcl_GetByteArrayFromObj(objv[1], &count); cursor = Tcl_SetByteArrayLength(resultObj, count * 2); for (offset = 0; offset < count; ++offset) { *cursor++ = HexDigits[(data[offset] >> 4) & 0x0F]; @@ -2577,7 +2485,8 @@ BinaryDecodeHex( Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor, c; - int i, index, value, size, pure = 1, count = 0, cut = 0, strict = 0; + int i, index, value, pure = 1, strict = 0; + Tcl_Size size, cut = 0, count = 0; int ucs4; enum {OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; @@ -2602,7 +2511,7 @@ BinaryDecodeHex( data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); if (data == NULL) { pure = 0; - data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); + data = (unsigned char *) Tcl_GetStringFromObj(objv[objc - 1], &count); } datastart = data; dataend = data + count; @@ -2656,8 +2565,8 @@ BinaryDecodeHex( } TclDecrRefCount(resultObj); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid hexadecimal digit \"%c\" (U+%06X) at position %d", - ucs4, ucs4, (int) (data - datastart - 1))); + "invalid hexadecimal digit \"%c\" (U+%06X) at position %" + TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL); return TCL_ERROR; } @@ -2702,8 +2611,9 @@ BinaryEncode64( unsigned char *data, *limit; Tcl_WideInt maxlen = 0; const char *wrapchar = "\n"; - int wrapcharlen = 1; - int offset, i, index, size, outindex = 0, count = 0, purewrap = 1; + Tcl_Size wrapcharlen = 1; + int index, purewrap = 1; + Tcl_Size i, offset, size, outindex = 0, count = 0; enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; @@ -2719,7 +2629,7 @@ BinaryEncode64( } switch (index) { case OPT_MAXLEN: - if (Tcl_GetWideIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) { return TCL_ERROR; } if (maxlen < 0) { @@ -2735,7 +2645,7 @@ BinaryEncode64( objv[i + 1], &wrapcharlen); if (wrapchar == NULL) { purewrap = 0; - wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen); + wrapchar = Tcl_GetStringFromObj(objv[i + 1], &wrapcharlen); } break; } @@ -2744,8 +2654,11 @@ BinaryEncode64( maxlen = 0; } + data = Tcl_GetBytesFromObj(interp, objv[objc - 1], &count); + if (data == NULL) { + return TCL_ERROR; + } TclNewObj(resultObj); - data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); if (count > 0) { unsigned char *cursor = NULL; @@ -2822,12 +2735,12 @@ BinaryEncodeUu( { Tcl_Obj *resultObj; unsigned char *data, *start, *cursor; - int offset, count, rawLength, i, j, bits, index; + int i, bits, index; unsigned int n; int lineLength = 61; const unsigned char SingleNewline[] = { UCHAR('\n') }; const unsigned char *wrapchar = SingleNewline; - int wrapcharlen = sizeof(SingleNewline); + Tcl_Size j, rawLength, offset, count = 0, wrapcharlen = sizeof(SingleNewline); enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; @@ -2857,11 +2770,11 @@ BinaryEncodeUu( lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */ break; case OPT_WRAPCHAR: - wrapchar = (const unsigned char *) TclGetStringFromObj( + wrapchar = (const unsigned char *) Tcl_GetStringFromObj( objv[i + 1], &wrapcharlen); { const unsigned char *p = wrapchar; - int numBytes = wrapcharlen; + Tcl_Size numBytes = wrapcharlen; while (numBytes) { switch (*p) { @@ -2897,9 +2810,12 @@ BinaryEncodeUu( * enough". */ - TclNewObj(resultObj); offset = 0; - data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); + data = Tcl_GetBytesFromObj(interp, objv[objc - 1], &count); + if (data == NULL) { + return TCL_ERROR; + } + TclNewObj(resultObj); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, (lineLength + wrapcharlen) * @@ -2914,7 +2830,7 @@ BinaryEncodeUu( */ while (offset < count) { - int lineLen = count - offset; + Tcl_Size lineLen = count - offset; if (lineLen > rawLength) { lineLen = rawLength; @@ -2972,7 +2888,8 @@ BinaryDecodeUu( Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor; - int i, index, size, pure = 1, count = 0, strict = 0, lineLen; + int i, index, pure = 1, strict = 0, lineLen; + Tcl_Size size, count = 0; unsigned char c; int ucs4; enum { OPT_STRICT }; @@ -2998,7 +2915,7 @@ BinaryDecodeUu( data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); if (data == NULL) { pure = 0; - data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); + data = (unsigned char *) Tcl_GetStringFromObj(objv[objc - 1], &count); } datastart = data; dataend = data + count; @@ -3112,8 +3029,8 @@ BinaryDecodeUu( Tcl_UtfToUniChar((const char *)(data - 1), &ucs4); } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid uuencode character \"%c\" (U+%06X) at position %d", - ucs4, ucs4, (int) (data - datastart - 1))); + "invalid uuencode character \"%c\" (U+%06X) at position %" + TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL); TclDecrRefCount(resultObj); return TCL_ERROR; @@ -3147,7 +3064,8 @@ BinaryDecode64( unsigned char *begin = NULL; unsigned char *cursor = NULL; int pure = 1, strict = 0; - int i, index, size, cut = 0, count = 0; + int i, index, cut = 0; + Tcl_Size size, count = 0; int ucs4; enum { OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; @@ -3172,7 +3090,7 @@ BinaryDecode64( data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); if (data == NULL) { pure = 0; - data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); + data = (unsigned char *) Tcl_GetStringFromObj(objv[objc - 1], &count); } datastart = data; dataend = data + count; @@ -3287,8 +3205,8 @@ BinaryDecode64( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid base64 character \"%c\" (U+%06X) at position %d", - ucs4, ucs4, (int) (data - datastart - 1))); + "invalid base64 character \"%c\" (U+%06X) at position %" + TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL); TclDecrRefCount(resultObj); return TCL_ERROR; diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index f0c625f..6b989c9 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -16,6 +16,7 @@ */ #include "tclInt.h" +#include <assert.h> #define FALSE 0 #define TRUE 1 @@ -121,7 +122,7 @@ static char dumpFile[100]; /* Records where to dump memory allocation /* * Mutex to serialize allocations. This is a low-level mutex that must be * explicitly initialized. This is necessary because the self initializing - * mutexes use ckalloc... + * mutexes use Tcl_Alloc... */ static Tcl_Mutex *ckallocMutexPtr; @@ -365,7 +366,7 @@ Tcl_DumpActiveMemory( /* *---------------------------------------------------------------------- * - * Tcl_DbCkalloc - debugging ckalloc + * Tcl_DbCkalloc - debugging Tcl_Alloc * * Allocate the requested amount of space plus some extra for guard bands * at both ends of the request, plus a size, panicking if there isn't @@ -374,15 +375,15 @@ Tcl_DumpActiveMemory( * * The second and third arguments are file and line, these contain the * filename and line number corresponding to the caller. These are sent - * by the ckalloc macro; it uses the preprocessor autodefines __FILE__ + * by the Tcl_Alloc macro; it uses the preprocessor autodefines __FILE__ * and __LINE__. * *---------------------------------------------------------------------- */ -char * +void * Tcl_DbCkalloc( - unsigned int size, + size_t size, const char *file, int line) { @@ -393,14 +394,14 @@ Tcl_DbCkalloc( } /* Don't let size argument to TclpAlloc overflow */ - if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) { + if (size <= (size_t)-2 - offsetof(struct mem_header, body) - HIGH_GUARD_SIZE) { result = (struct mem_header *) TclpAlloc(size + offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE); } if (result == NULL) { fflush(stdout); TclDumpMemoryInfo(stderr, 0); - Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); + Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes, %s line %d", size, file, line); } /* @@ -446,7 +447,7 @@ Tcl_DbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"ckalloc %p %u %s %d\n", + fprintf(stderr,"Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n", result->body, size, file, line); } @@ -470,9 +471,9 @@ Tcl_DbCkalloc( return result->body; } -char * +void * Tcl_AttemptDbCkalloc( - unsigned int size, + size_t size, const char *file, int line) { @@ -483,7 +484,7 @@ Tcl_AttemptDbCkalloc( } /* Don't let size argument to TclpAlloc overflow */ - if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) { + if (size <= (size_t)-2 - offsetof(struct mem_header, body) - HIGH_GUARD_SIZE) { result = (struct mem_header *) TclpAlloc(size + offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE); } @@ -535,7 +536,7 @@ Tcl_AttemptDbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"ckalloc %p %u %s %d\n", + fprintf(stderr,"Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n", result->body, size, file, line); } @@ -562,7 +563,7 @@ Tcl_AttemptDbCkalloc( /* *---------------------------------------------------------------------- * - * Tcl_DbCkfree - debugging ckfree + * Tcl_DbCkfree - debugging Tcl_Free * * Verify that the low and high guards are intact, and if so then free * the buffer else Tcl_Panic. @@ -571,7 +572,7 @@ Tcl_AttemptDbCkalloc( * * The second and third arguments are file and line, these contain the * filename and line number corresponding to the caller. These are sent - * by the ckfree macro; it uses the preprocessor autodefines __FILE__ and + * by the Tcl_Free macro; it uses the preprocessor autodefines __FILE__ and * __LINE__. * *---------------------------------------------------------------------- @@ -579,7 +580,7 @@ Tcl_AttemptDbCkalloc( void Tcl_DbCkfree( - char *ptr, + void *ptr, const char *file, int line) { @@ -600,7 +601,7 @@ Tcl_DbCkfree( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { - fprintf(stderr, "ckfree %p %" TCL_Z_MODIFIER "u %s %d\n", + fprintf(stderr, "Tcl_Free %p %" TCL_Z_MODIFIER "u %s %d\n", memp->body, memp->length, file, line); } @@ -644,7 +645,7 @@ Tcl_DbCkfree( /* *-------------------------------------------------------------------- * - * Tcl_DbCkrealloc - debugging ckrealloc + * Tcl_DbCkrealloc - debugging Tcl_Realloc * * Reallocate a chunk of memory by allocating a new one of the right * size, copying the old data to the new location, and then freeing the @@ -654,10 +655,10 @@ Tcl_DbCkfree( *-------------------------------------------------------------------- */ -char * +void * Tcl_DbCkrealloc( - char *ptr, - unsigned int size, + void *ptr, + size_t size, const char *file, int line) { @@ -685,10 +686,10 @@ Tcl_DbCkrealloc( return newPtr; } -char * +void * Tcl_AttemptDbCkrealloc( - char *ptr, - unsigned int size, + void *ptr, + size_t size, const char *file, int line) { @@ -737,38 +738,38 @@ Tcl_AttemptDbCkrealloc( *---------------------------------------------------------------------- */ -char * +void * Tcl_Alloc( - unsigned int size) + size_t size) { return Tcl_DbCkalloc(size, "unknown", 0); } -char * +void * Tcl_AttemptAlloc( - unsigned int size) + size_t size) { return Tcl_AttemptDbCkalloc(size, "unknown", 0); } void Tcl_Free( - char *ptr) + void *ptr) { Tcl_DbCkfree(ptr, "unknown", 0); } -char * +void * Tcl_Realloc( - char *ptr, - unsigned int size) + void *ptr, + size_t size) { return Tcl_DbCkrealloc(ptr, size, "unknown", 0); } -char * +void * Tcl_AttemptRealloc( - char *ptr, - unsigned int size) + void *ptr, + size_t size) { return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0); } @@ -836,7 +837,7 @@ MemoryCmd( if (objc != 3) { goto argError; } - if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } break_on_malloc = value; @@ -921,7 +922,7 @@ MemoryCmd( if (objc != 3) { goto argError; } - if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } trace_on_at_malloc = value; @@ -1030,11 +1031,11 @@ Tcl_InitMemory( *---------------------------------------------------------------------- */ -char * +void * Tcl_Alloc( - unsigned int size) + size_t size) { - char *result = (char *)TclpAlloc(size); + void *result = TclpAlloc(size); /* * Most systems will not alloc(0), instead bumping it to one so that NULL @@ -1047,22 +1048,23 @@ Tcl_Alloc( */ if ((result == NULL) && size) { - Tcl_Panic("unable to alloc %u bytes", size); + Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes", size); } return result; } -char * +void * Tcl_DbCkalloc( - unsigned int size, + size_t size, const char *file, int line) { - char *result = (char *)TclpAlloc(size); + void *result = TclpAlloc(size); if ((result == NULL) && size) { fflush(stdout); - Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); + Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes, %s line %d", + size, file, line); } return result; } @@ -1078,16 +1080,16 @@ Tcl_DbCkalloc( *---------------------------------------------------------------------- */ -char * +void * Tcl_AttemptAlloc( - unsigned int size) + size_t size) { return (char *)TclpAlloc(size); } -char * +void * Tcl_AttemptDbCkalloc( - unsigned int size, + size_t size, TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { @@ -1105,31 +1107,32 @@ Tcl_AttemptDbCkalloc( *---------------------------------------------------------------------- */ -char * +void * Tcl_Realloc( - char *ptr, - unsigned int size) + void *ptr, + size_t size) { - char *result = (char *)TclpRealloc(ptr, size); + void *result = TclpRealloc(ptr, size); if ((result == NULL) && size) { - Tcl_Panic("unable to realloc %u bytes", size); + Tcl_Panic("unable to realloc %" TCL_Z_MODIFIER "u bytes", size); } return result; } -char * +void * Tcl_DbCkrealloc( - char *ptr, - unsigned int size, + void *ptr, + size_t size, const char *file, int line) { - char *result = (char *)TclpRealloc(ptr, size); + void *result = TclpRealloc(ptr, size); if ((result == NULL) && size) { fflush(stdout); - Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line); + Tcl_Panic("unable to realloc %" TCL_Z_MODIFIER "u bytes, %s line %d", + size, file, line); } return result; } @@ -1145,18 +1148,18 @@ Tcl_DbCkrealloc( *---------------------------------------------------------------------- */ -char * +void * Tcl_AttemptRealloc( - char *ptr, - unsigned int size) + void *ptr, + size_t size) { return (char *)TclpRealloc(ptr, size); } -char * +void * Tcl_AttemptDbCkrealloc( - char *ptr, - unsigned int size, + void *ptr, + size_t size, TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { @@ -1177,14 +1180,14 @@ Tcl_AttemptDbCkrealloc( void Tcl_Free( - char *ptr) + void *ptr) { TclpFree(ptr); } void Tcl_DbCkfree( - char *ptr, + void *ptr, TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { @@ -1232,6 +1235,148 @@ TclDumpMemoryInfo( #endif /* TCL_MEM_DEBUG */ /* + *------------------------------------------------------------------------ + * + * TclAllocElemsEx -- + * + * See TclAttemptAllocElemsEx. This function differs in that it panics + * on failure. + * + * Results: + * Non-NULL pointer to allocated memory block. + * + * Side effects: + * Panics if memory of at least the requested size could not be + * allocated. + * + *------------------------------------------------------------------------ + */ +void * +TclAllocElemsEx( + Tcl_Size elemCount, /* Allocation will store at least these many... */ + Tcl_Size elemSize, /* ...elements of this size */ + Tcl_Size leadSize, /* Additional leading space in bytes */ + Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored + here if non-NULL. Only modified on success */ +{ + void *ptr = TclAttemptReallocElemsEx( + NULL, elemCount, elemSize, leadSize, capacityPtr); + if (ptr == NULL) { + Tcl_Panic("Failed to allocate %" TCL_SIZE_MODIFIER + "d elements of size %" TCL_SIZE_MODIFIER "d bytes.", + elemCount, + elemSize); + } + return ptr; +} + +/* + *------------------------------------------------------------------------ + * + * TclAttemptReallocElemsEx -- + * + * Attempts to allocate (oldPtr == NULL) or reallocate memory of the + * requested size plus some more for future growth. The amount of + * reallocation is adjusted depending on on failure. + * + * + * Results: + * Pointer to allocated memory block which is at least as large + * as the requested size or NULL if allocation failed. + * + *------------------------------------------------------------------------ + */ +void * +TclAttemptReallocElemsEx( + void *oldPtr, /* Pointer to memory block to reallocate or + * NULL to indicate this is a new allocation */ + Tcl_Size elemCount, /* Allocation will store at least these many... */ + Tcl_Size elemSize, /* ...elements of this size */ + Tcl_Size leadSize, /* Additional leading space in bytes */ + Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored + here if non-NULL. Only modified on success */ +{ + void *ptr; + Tcl_Size limit; + Tcl_Size attempt; + + assert(elemCount > 0); + assert(elemSize > 0); + assert(elemSize < TCL_SIZE_MAX); + assert(leadSize >= 0); + assert(leadSize < TCL_SIZE_MAX); + + limit = (TCL_SIZE_MAX - leadSize) / elemSize; + if (elemCount > limit) { + return NULL; + } + /* Loop trying for extra space, reducing request each time */ + attempt = TclUpsizeAlloc(0, elemCount, limit); + ptr = NULL; + while (attempt > elemCount) { + if (oldPtr) { + ptr = Tcl_AttemptRealloc(oldPtr, leadSize + attempt * elemSize); + } else { + ptr = Tcl_AttemptAlloc(leadSize + attempt * elemSize); + } + if (ptr) { + break; + } + attempt = TclUpsizeRetry(elemCount, attempt); + } + /* Try exact size as a last resort */ + if (ptr == NULL) { + attempt = elemCount; + if (oldPtr) { + ptr = Tcl_AttemptRealloc(oldPtr, leadSize + attempt * elemSize); + } else { + ptr = Tcl_AttemptAlloc(leadSize + attempt * elemSize); + } + } + if (ptr && capacityPtr) { + *capacityPtr = attempt; + } + return ptr; +} + +/* + *------------------------------------------------------------------------ + * + * TclReallocElemsEx -- + * + * See TclAttemptReallocElemsEx. This function differs in that it panics + * on failure. + * + * Results: + * Non-NULL pointer to allocated memory block. + * + * Side effects: + * Panics if memory of at least the requested size could not be + * allocated. + * + *------------------------------------------------------------------------ + */ +void * +TclReallocElemsEx( + void *oldPtr, /* Pointer to memory block to reallocate */ + Tcl_Size elemCount, /* Allocation will store at least these many... */ + Tcl_Size elemSize, /* ...elements of this size */ + Tcl_Size leadSize, /* Additional leading space in bytes */ + Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored + here if non-NULL. Only modified on success */ +{ + void *ptr = TclAttemptReallocElemsEx( + oldPtr, elemCount, elemSize, leadSize, capacityPtr); + if (ptr == NULL) { + Tcl_Panic("Failed to reallocate %" TCL_SIZE_MODIFIER + "d elements of size %" TCL_SIZE_MODIFIER "d bytes.", + elemCount, + elemSize); + } + return ptr; +} + +/* *--------------------------------------------------------------------------- * * TclFinalizeMemorySubsystem -- diff --git a/generic/tclClock.c b/generic/tclClock.c index 228937e..4951f04 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -101,7 +101,7 @@ typedef struct { * Structure containing the fields used in [clock format] and [clock scan] */ -typedef struct TclDateFields { +typedef struct { Tcl_WideInt seconds; /* Time expressed in seconds from the Posix * epoch */ Tcl_WideInt localSeconds; /* Local time expressed in nominal seconds @@ -143,17 +143,17 @@ TCL_DECLARE_MUTEX(clockMutex) static int ConvertUTCToLocal(Tcl_Interp *, TclDateFields *, Tcl_Obj *, int); static int ConvertUTCToLocalUsingTable(Tcl_Interp *, - TclDateFields *, int, Tcl_Obj *const[]); + TclDateFields *, Tcl_Size, Tcl_Obj *const[]); static int ConvertUTCToLocalUsingC(Tcl_Interp *, TclDateFields *, int); static int ConvertLocalToUTC(Tcl_Interp *, TclDateFields *, Tcl_Obj *, int); static int ConvertLocalToUTCUsingTable(Tcl_Interp *, - TclDateFields *, int, Tcl_Obj *const[]); + TclDateFields *, Tcl_Size, Tcl_Obj *const[]); static int ConvertLocalToUTCUsingC(Tcl_Interp *, TclDateFields *, int); static Tcl_Obj * LookupLastTransition(Tcl_Interp *, Tcl_WideInt, - int, Tcl_Obj *const *); + Tcl_Size, Tcl_Obj *const *); static void GetYearWeekDay(TclDateFields *, int); static void GetGregorianEraYearDay(TclDateFields *, int); static void GetMonthDay(TclDateFields *); @@ -256,9 +256,9 @@ TclClockInit( * Create the client data, which is a refcounted literal pool. */ - data = (ClockClientData *)ckalloc(sizeof(ClockClientData)); + data = (ClockClientData *)Tcl_Alloc(sizeof(ClockClientData)); data->refCount = 0; - data->literals = (Tcl_Obj **)ckalloc(LIT__END * sizeof(Tcl_Obj*)); + data->literals = (Tcl_Obj **)Tcl_Alloc(LIT__END * sizeof(Tcl_Obj*)); for (i = 0; i < LIT__END; ++i) { data->literals[i] = Tcl_NewStringObj(literals[i], -1); Tcl_IncrRefCount(data->literals[i]); @@ -730,7 +730,7 @@ ConvertLocalToUTC( Tcl_Obj *tzdata, /* Time zone data */ int changeover) /* Julian Day of the Gregorian transition */ { - int rowc; /* Number of rows in tzdata */ + Tcl_Size rowc; /* Number of rows in tzdata */ Tcl_Obj **rowv; /* Pointers to the rows */ /* @@ -775,11 +775,11 @@ static int ConvertLocalToUTCUsingTable( Tcl_Interp *interp, /* Tcl interpreter */ TclDateFields *fields, /* Time to convert, with 'seconds' filled in */ - int rowc, /* Number of points at which time changes */ + Tcl_Size rowc, /* Number of points at which time changes */ Tcl_Obj *const rowv[]) /* Points at which time changes */ { Tcl_Obj *row; - int cellc; + Tcl_Size cellc; Tcl_Obj **cellv; int have[8]; int nHave = 0; @@ -933,7 +933,7 @@ ConvertUTCToLocal( Tcl_Obj *tzdata, /* Time zone data */ int changeover) /* Julian Day of the Gregorian transition */ { - int rowc; /* Number of rows in tzdata */ + Tcl_Size rowc; /* Number of rows in tzdata */ Tcl_Obj **rowv; /* Pointers to the rows */ /* @@ -978,12 +978,12 @@ static int ConvertUTCToLocalUsingTable( Tcl_Interp *interp, /* Tcl interpreter */ TclDateFields *fields, /* Fields of the date */ - int rowc, /* Number of rows in the conversion table + Tcl_Size rowc, /* Number of rows in the conversion table * (>= 1) */ Tcl_Obj *const rowv[]) /* Rows of the conversion table */ { Tcl_Obj *row; /* Row containing the current information */ - int cellc; /* Count of cells in the row (must be 4) */ + Tcl_Size cellc; /* Count of cells in the row (must be 4) */ Tcl_Obj **cellv; /* Pointers to the cells */ /* @@ -1118,11 +1118,11 @@ static Tcl_Obj * LookupLastTransition( Tcl_Interp *interp, /* Interpreter for error messages */ Tcl_WideInt tick, /* Time from the epoch */ - int rowc, /* Number of rows of tzdata */ + Tcl_Size rowc, /* Number of rows of tzdata */ Tcl_Obj *const *rowv) /* Rows in tzdata */ { - int l; - int u; + Tcl_Size l; + Tcl_Size u; Tcl_Obj *compObj; Tcl_WideInt compVal; @@ -1763,13 +1763,13 @@ ClockClicksObjCmd( switch (index) { case CLICKS_MILLIS: Tcl_GetTime(&now); - clicks = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000; + clicks = (Tcl_WideInt)(unsigned long long)now.sec * 1000 + now.usec / 1000; break; case CLICKS_NATIVE: #ifdef TCL_WIDE_CLICKS clicks = TclpGetWideClicks(); #else - clicks = (Tcl_WideInt) TclpGetClicks(); + clicks = (Tcl_WideInt)TclpGetClicks(); #endif break; case CLICKS_MICROS: @@ -2041,7 +2041,7 @@ TzsetIfNecessary(void) { static WCHAR* tzWas = (WCHAR *)INT2PTR(-1); /* Previous value of TZ, protected by * clockMutex. */ - static long tzLastRefresh = 0; /* Used for latency before next refresh */ + static long long tzLastRefresh = 0; /* Used for latency before next refresh */ static size_t tzEnvEpoch = 0; /* Last env epoch, for faster signaling, that TZ changed via TCL */ const WCHAR *tzIsNow; /* Current value of TZ */ @@ -2066,13 +2066,13 @@ TzsetIfNecessary(void) || wcscmp(tzIsNow, tzWas) != 0)) { tzset(); if (tzWas != NULL && tzWas != (WCHAR *)INT2PTR(-1)) { - ckfree(tzWas); + Tcl_Free(tzWas); } - tzWas = (WCHAR *)ckalloc(sizeof(WCHAR) * (wcslen(tzIsNow) + 1)); + tzWas = (WCHAR *)Tcl_Alloc(sizeof(WCHAR) * (wcslen(tzIsNow) + 1)); wcscpy(tzWas, tzIsNow); } else if (tzIsNow == NULL && tzWas != NULL) { tzset(); - if (tzWas != (WCHAR *)INT2PTR(-1)) ckfree(tzWas); + if (tzWas != (WCHAR *)INT2PTR(-1)) Tcl_Free(tzWas); tzWas = NULL; } Tcl_MutexUnlock(&clockMutex); @@ -2103,8 +2103,8 @@ ClockDeleteCmdProc( for (i = 0; i < LIT__END; ++i) { Tcl_DecrRefCount(data->literals[i]); } - ckfree(data->literals); - ckfree(data); + Tcl_Free(data->literals); + Tcl_Free(data); } } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index e7e929f..e3f3698 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -13,6 +13,7 @@ #include "tclInt.h" #include "tclIO.h" +#include "tclTomMath.h" #ifdef _WIN32 # include "tclWinInt.h" #endif @@ -136,142 +137,6 @@ Tcl_BreakObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_CaseObjCmd -- - * - * This procedure is invoked to process the "case" Tcl command. See the - * user documentation for details on what it does. THIS COMMAND IS - * OBSOLETE AND DEPRECATED. SLATED FOR REMOVAL IN TCL 9.0. - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -int -Tcl_CaseObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int i; - int body, result, caseObjc; - const char *stringPtr, *arg; - Tcl_Obj *const *caseObjv; - Tcl_Obj *armPtr; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, - "string ?in? ?pattern body ...? ?default body?"); - return TCL_ERROR; - } - - stringPtr = TclGetString(objv[1]); - body = -1; - - arg = TclGetString(objv[2]); - if (strcmp(arg, "in") == 0) { - i = 3; - } else { - i = 2; - } - caseObjc = objc - i; - caseObjv = objv + i; - - /* - * If all of the pattern/command pairs are lumped into a single argument, - * split them out again. - */ - - if (caseObjc == 1) { - Tcl_Obj **newObjv; - - TclListObjGetElementsM(interp, caseObjv[0], &caseObjc, &newObjv); - caseObjv = newObjv; - } - - for (i = 0; i < caseObjc; i += 2) { - int patObjc, j; - const char **patObjv; - const char *pat, *p; - - if (i == caseObjc-1) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra case pattern with no body", -1)); - return TCL_ERROR; - } - - /* - * Check for special case of single pattern (no list) with no - * backslash sequences. - */ - - pat = TclGetString(caseObjv[i]); - for (p = pat; *p != '\0'; p++) { - if (TclIsSpaceProcM(*p) || (*p == '\\')) { - break; - } - } - if (*p == '\0') { - if ((*pat == 'd') && (strcmp(pat, "default") == 0)) { - body = i + 1; - } - if (Tcl_StringMatch(stringPtr, pat)) { - body = i + 1; - goto match; - } - continue; - } - - /* - * Break up pattern lists, then check each of the patterns in the - * list. - */ - - result = Tcl_SplitList(interp, pat, &patObjc, &patObjv); - if (result != TCL_OK) { - return result; - } - for (j = 0; j < patObjc; j++) { - if (Tcl_StringMatch(stringPtr, patObjv[j])) { - body = i + 1; - break; - } - } - ckfree(patObjv); - if (j < patObjc) { - break; - } - } - - match: - if (body != -1) { - armPtr = caseObjv[body - 1]; - result = Tcl_EvalObjEx(interp, caseObjv[body], 0); - if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"%.50s\" arm line %d)", - TclGetString(armPtr), Tcl_GetErrorLine(interp))); - } - return result; - } - - /* - * Nothing matched: return nothing. - */ - - return TCL_OK; -} -#endif /* !TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_CatchObjCmd -- * * This object-based procedure is invoked to process the "catch" Tcl @@ -409,13 +274,21 @@ Tcl_CdObjCmd( if (objc == 2) { dir = objv[1]; } else { - TclNewLiteralStringObj(dir, "~"); + dir = TclGetHomeDirObj(interp, NULL); + if (dir == NULL) { + return TCL_ERROR; + } Tcl_IncrRefCount(dir); } if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) { result = TCL_ERROR; } else { - result = Tcl_FSChdir(dir); + Tcl_DString ds; + result = Tcl_UtfToExternalDStringEx(NULL, TCLFSENCODING, TclGetString(dir), -1, 0, &ds, NULL); + Tcl_DStringFree(&ds); + if (result == TCL_OK) { + result = Tcl_FSChdir(dir); + } if (result != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't change working directory to \"%s\": %s", @@ -566,7 +439,7 @@ EncodingConvertParseOptions ( Tcl_Encoding encoding; Tcl_Obj *dataObj; Tcl_Obj *failVarObj; - int profile = TCL_ENCODING_PROFILE_TCL8; + int profile = TCL_ENCODING_PROFILE_STRICT; /* * Possible combinations: @@ -607,7 +480,7 @@ numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ switch (optIndex) { case PROFILE: if (TclEncodingProfileNameToId(interp, - TclGetString(objv[argIndex]), + Tcl_GetString(objv[argIndex]), &profile) != TCL_OK) { return TCL_ERROR; } @@ -657,7 +530,7 @@ EncodingConvertfromObjCmd( Tcl_Obj *data; /* Byte array to convert */ Tcl_DString ds; /* Buffer to hold the string */ Tcl_Encoding encoding; /* Encoding to use */ - Tcl_Size length; /* Length of the byte array being converted */ + Tcl_Size length = 0; /* Length of the byte array being converted */ const char *bytesPtr; /* Pointer to the first byte of the array */ int flags; int result; @@ -673,13 +546,7 @@ EncodingConvertfromObjCmd( /* * Convert the string into a byte array in 'ds'. */ -#if !defined(TCL_NO_DEPRECATED) - if (ENCODING_PROFILE_GET(flags) == TCL_ENCODING_PROFILE_TCL8) { - /* Permits high bits to be non-0 in byte array (Tcl 8 style) */ - bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); - } else -#endif - bytesPtr = (char *) Tcl_GetBytesFromObj(interp, data, &length); + bytesPtr = (char *) Tcl_GetBytesFromObj(interp, data, &length); if (bytesPtr == NULL) { return TCL_ERROR; @@ -780,7 +647,7 @@ EncodingConverttoObjCmd( * Convert the string to a byte array in 'ds' */ - stringPtr = TclGetStringFromObj(data, &length); + stringPtr = Tcl_GetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(interp, encoding, stringPtr, length, flags, &ds, failVarObj ? &errorLocation : NULL); /* NOTE: ds must be freed beyond this point even on error */ @@ -2387,10 +2254,16 @@ CheckAccess( * access(). */ { int value; + Tcl_DString ds; if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { value = 0; + } else if (Tcl_UtfToExternalDStringEx(NULL, TCLFSENCODING, TclGetString(pathPtr), + TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + value = 0; + Tcl_DStringFree(&ds); } else { + Tcl_DStringFree(&ds); value = (Tcl_FSAccess(pathPtr, mode) == 0); } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); @@ -2428,12 +2301,19 @@ GetStatBuf( * calling (*statProc)(). */ { int status; + Tcl_DString ds; if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return TCL_ERROR; } - status = statProc(pathPtr, statPtr); + if (Tcl_UtfToExternalDStringEx(NULL, TCLFSENCODING, TclGetString(pathPtr), + TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + status = -1; + } else { + status = statProc(pathPtr, statPtr); + } + Tcl_DStringFree(&ds); if (status < 0) { if (interp != NULL) { @@ -2508,8 +2388,6 @@ StoreStatData( } /* - * Assume Tcl_ObjSetVar2() does not keep a copy of the field name! - * * Might be a better idea to call Tcl_SetVar2Ex() instead, except we want * to have an object (i.e. possibly cached) array variable name but a * string element name, so no API exists. Messy. @@ -2942,9 +2820,7 @@ EachloopCmd( for (i=0 ; i<numLists ; i++) { /* List */ /* Variables */ - - /* Do not use TclListObjCopy here - shimmers arithseries to list */ - statePtr->vCopyList[i] = Tcl_DuplicateObj(objv[1+i*2]); + statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]); if (statePtr->vCopyList[i] == NULL) { result = TCL_ERROR; goto done; @@ -2969,15 +2845,15 @@ EachloopCmd( &statePtr->varcList[i], &statePtr->varvList[i]); /* Values */ - if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) { - /* Special case for Arith Series */ + if (TclObjTypeHasProc(objv[2+i*2],indexProc)) { + /* Special case for AbstractList */ statePtr->aCopyList[i] = Tcl_DuplicateObj(objv[2+i*2]); if (statePtr->aCopyList[i] == NULL) { result = TCL_ERROR; goto done; } /* Don't compute values here, wait until the last moment */ - statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->aCopyList[i]); + statePtr->argcList[i] = TclObjTypeLength(statePtr->aCopyList[i]); } else { /* List values */ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); @@ -3051,8 +2927,12 @@ ForeachLoopStep( break; case TCL_OK: if (statePtr->resultList != NULL) { - Tcl_ListObjAppendElement(interp, statePtr->resultList, - Tcl_GetObjResult(interp)); + result = Tcl_ListObjAppendElement( + interp, statePtr->resultList, Tcl_GetObjResult(interp)); + if (result != TCL_OK) { + /* e.g. memory alloc failure on big data tests */ + goto done; + } } break; case TCL_BREAK: @@ -3114,13 +2994,14 @@ ForeachAssignments( Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; i<statePtr->numLists ; i++) { - int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType); + int isAbstractList = + TclObjTypeHasProc(statePtr->aCopyList[i],indexProc) != NULL; + for (v=0 ; v<statePtr->varcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { - if (isarithseries) { - valuePtr = TclArithSeriesObjIndex(interp, statePtr->aCopyList[i], k); - if (valuePtr == NULL) { + if (isAbstractList) { + if (TclObjTypeIndex(interp, statePtr->aCopyList[i], k, &valuePtr) != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (setting %s loop variable \"%s\")", (statePtr->resultList != NULL ? "lmap" : "foreach"), diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 8f7cbe6..c759a54 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -38,7 +38,7 @@ typedef struct SortElement { } collationKey; union { /* Object being sorted, or its index. */ Tcl_Obj *objPtr; - Tcl_Size index; + size_t index; } payload; struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ @@ -50,6 +50,7 @@ typedef struct SortElement { */ typedef int (*SortStrCmpFn_t) (const char *, const char *); +typedef int (*SortMemCmpFn_t) (const void *, const void *, Tcl_Size); /* * The "lsort" command needs to pass certain information down to the function @@ -159,6 +160,8 @@ static const EnsembleImplMap defaultInfoMap[] = { {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"constant", TclInfoConstantCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"consts", TclInfoConstsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0}, {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, @@ -564,7 +567,7 @@ InfoBodyCmd( * the object do not invalidate the internal rep. */ - bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes); + bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes); Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes)); return TCL_OK; } @@ -989,8 +992,8 @@ InfoDefaultCmd( Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); } else { Tcl_Obj *nullObjPtr; - TclNewObj(nullObjPtr); + valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, nullObjPtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { @@ -1584,7 +1587,7 @@ InfoLevelCmd( Interp *iPtr = (Interp *) interp; if (objc == 1) { /* Just "info level" */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->varFramePtr->level)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((int)iPtr->varFramePtr->level)); return TCL_OK; } @@ -1603,7 +1606,7 @@ InfoLevelCmd( } for (framePtr=iPtr->varFramePtr ; framePtr!=rootFramePtr; framePtr=framePtr->callerVarPtr) { - if (framePtr->level == level) { + if ((int)framePtr->level == level) { break; } } @@ -1926,7 +1929,7 @@ InfoProcsCmd( if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) - TclGetOriginalCommand((Tcl_Command)cmdPtr); + TclGetOriginalCommand((Tcl_Command) cmdPtr); if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { goto procOK; } @@ -1934,7 +1937,7 @@ InfoProcsCmd( procOK: if (specificNsInPattern) { TclNewObj(elemObjPtr); - Tcl_GetCommandFullName(interp, (Tcl_Command)cmdPtr, + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(cmdName, -1); @@ -2162,7 +2165,7 @@ InfoCmdTypeCmd( } /* - * There's one special case: safe interpreters can't see aliases as + * There's one special case: safe child interpreters can't see aliases as * aliases as they're part of the security mechanisms. */ @@ -2201,7 +2204,7 @@ Tcl_JoinObjCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Size length, listLen; - int isArithSeries = 0; + int isAbstractList = 0; Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { @@ -2214,14 +2217,17 @@ Tcl_JoinObjCmd( * pointer to its array of element pointers. */ - if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { - isArithSeries = 1; - listLen = TclArithSeriesObjLength(objv[1]); - } else { - if (TclListObjGetElementsM(interp, objv[1], &listLen, - &elemPtrs) != TCL_OK) { + if (TclObjTypeHasProc(objv[1], getElementsProc)) { + listLen = TclObjTypeLength(objv[1]); + isAbstractList = (listLen ? 1 : 0); + if (listLen > 1 && + TclObjTypeGetElements(interp, objv[1], &listLen, &elemPtrs) + != TCL_OK) { return TCL_ERROR; } + } else if (TclListObjGetElementsM(interp, objv[1], &listLen, + &elemPtrs) != TCL_OK) { + return TCL_ERROR; } if (listLen == 0) { @@ -2230,14 +2236,15 @@ Tcl_JoinObjCmd( } if (listLen == 1) { /* One element; return it */ - if (isArithSeries) { - Tcl_Obj *valueObj = TclArithSeriesObjIndex(interp, objv[1], 0); - if (valueObj == NULL) { + if (!isAbstractList) { + Tcl_SetObjResult(interp, elemPtrs[0]); + } else { + Tcl_Obj *elemObj; + if (TclObjTypeIndex(interp, objv[1], 0, &elemObj) + != TCL_OK) { return TCL_ERROR; } - Tcl_SetObjResult(interp, valueObj); - } else { - Tcl_SetObjResult(interp, elemPtrs[0]); + Tcl_SetObjResult(interp, elemObj); } return TCL_OK; } @@ -2245,49 +2252,26 @@ Tcl_JoinObjCmd( joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); - (void) TclGetStringFromObj(joinObjPtr, &length); + (void) Tcl_GetStringFromObj(joinObjPtr, &length); if (length == 0) { resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); } else { Tcl_Size i; TclNewObj(resObjPtr); - if (isArithSeries) { - Tcl_Obj *valueObj; - for (i = 0; i < listLen; i++) { - if (i > 0) { - - /* - * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** - * to shimmer joinObjPtr. If it did, then the case where - * objv[1] and objv[2] are the same value would not be safe. - * Accessing elemPtrs would crash. - */ - - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); - } - valueObj = TclArithSeriesObjIndex(interp, objv[1], i); - if (valueObj == NULL) { - return TCL_ERROR; - } - Tcl_AppendObjToObj(resObjPtr, valueObj); - Tcl_DecrRefCount(valueObj); - } - } else { - for (i = 0; i < listLen; i++) { - if (i > 0) { + for (i = 0; i < listLen; i++) { + if (i > 0) { - /* - * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** - * to shimmer joinObjPtr. If it did, then the case where - * objv[1] and objv[2] are the same value would not be safe. - * Accessing elemPtrs would crash. - */ + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); - } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } } Tcl_DecrRefCount(joinObjPtr); @@ -2322,65 +2306,94 @@ Tcl_LassignObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *listCopyPtr; - Tcl_Obj **listObjv; /* The contents of the list. */ + Tcl_Obj *listPtr; Tcl_Size listObjc; /* The length of the list. */ Tcl_Size origListObjc; /* Original length */ - int code = TCL_OK; + int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?"); return TCL_ERROR; } - listCopyPtr = TclListObjCopy(interp, objv[1]); - if (listCopyPtr == NULL) { + /* + * Note: no need to Dup the list to avoid shimmering. That is only + * needed when Tcl_ListObjGetElements is used since that returns + * pointers to internal structures. Using Tcl_ListObjIndex does not + * have that problem. However, we now have to IncrRef each elemObj + * (see below). I see that as preferable as duping lists is potentially + * expensive for abstract lists when they have a string representation. + */ + listPtr = objv[1]; + + if (TclListObjLengthM(interp, listPtr, &listObjc) != TCL_OK) { return TCL_ERROR; } - Tcl_IncrRefCount(listCopyPtr); /* Important! fs */ - - TclListObjGetElementsM(NULL, listCopyPtr, &listObjc, &listObjv); origListObjc = listObjc; objc -= 2; objv += 2; - while (code == TCL_OK && objc > 0 && listObjc > 0) { - if (Tcl_ObjSetVar2(interp, *objv++, NULL, *listObjv++, - TCL_LEAVE_ERR_MSG) == NULL) { - code = TCL_ERROR; + for (i = 0; i < objc && i < listObjc; ++i) { + Tcl_Obj *elemObj; + if (Tcl_ListObjIndex(interp, listPtr, i, &elemObj) != TCL_OK) { + return TCL_ERROR; } - objc--; - listObjc--; + /* + * Must incrref elemObj. If the var name being set is same as the + * the list value, ObjSetVar2 will shimmer the list to a VAR freeing + * the elements in the list (in case list refCount was 1) BEFORE + * the elemObj is stored in the var. See tests 6.{25,26} + */ + Tcl_IncrRefCount(elemObj); + if (Tcl_ObjSetVar2(interp, *objv++, NULL, elemObj, TCL_LEAVE_ERR_MSG) == + NULL) { + Tcl_DecrRefCount(elemObj); + return TCL_ERROR; + } + Tcl_DecrRefCount(elemObj); } + objc -= i; + listObjc -= i; - if (code == TCL_OK && objc > 0) { + if (objc > 0) { + /* Still some variables left to be assigned */ Tcl_Obj *emptyObj; TclNewObj(emptyObj); Tcl_IncrRefCount(emptyObj); - while (code == TCL_OK && objc-- > 0) { + while (objc-- > 0) { if (Tcl_ObjSetVar2(interp, *objv++, NULL, emptyObj, TCL_LEAVE_ERR_MSG) == NULL) { - code = TCL_ERROR; + Tcl_DecrRefCount(emptyObj); + return TCL_ERROR; } } Tcl_DecrRefCount(emptyObj); } - if (code == TCL_OK && listObjc > 0) { - Tcl_Obj *resultObjPtr = TclListObjRange( - interp, listCopyPtr, origListObjc - listObjc, origListObjc - 1); - if (resultObjPtr == NULL) { - code = TCL_ERROR; - } else { - Tcl_SetObjResult(interp, resultObjPtr); + if (listObjc > 0) { + Tcl_Obj *resultObjPtr = NULL; + Tcl_Size fromIdx = origListObjc - listObjc; + Tcl_Size toIdx = origListObjc - 1; + if (TclObjTypeHasProc(listPtr, sliceProc)) { + if (TclObjTypeSlice( + interp, listPtr, fromIdx, toIdx, &resultObjPtr) != TCL_OK) { + return TCL_ERROR; + } + } + else { + resultObjPtr = TclListObjRange( + interp, listPtr, origListObjc - listObjc, origListObjc - 1); + if (resultObjPtr == NULL) { + return TCL_ERROR; + } } + Tcl_SetObjResult(interp, resultObjPtr); } - Tcl_DecrRefCount(listCopyPtr); - return code; + return TCL_OK; } - + /* *---------------------------------------------------------------------- * @@ -2465,7 +2478,7 @@ Tcl_LinsertObjCmd( { Tcl_Obj *listPtr; Tcl_Size len, index; - int result; + int copied = 0, result; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?"); @@ -2499,6 +2512,7 @@ Tcl_LinsertObjCmd( listPtr = objv[1]; if (Tcl_IsShared(listPtr)) { listPtr = TclListObjCopy(NULL, listPtr); + copied = 1; } if ((objc == 4) && (index == len)) { @@ -2506,10 +2520,19 @@ Tcl_LinsertObjCmd( * Special case: insert one element at the end of the list. */ - Tcl_ListObjAppendElement(NULL, listPtr, objv[3]); + result = Tcl_ListObjAppendElement(NULL, listPtr, objv[3]); + if (result != TCL_OK) { + if (copied) { + Tcl_DecrRefCount(listPtr); + } + return result; + } } else { if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, index, 0, (objc-3), &(objv[3]))) { + if (copied) { + Tcl_DecrRefCount(listPtr); + } return TCL_ERROR; } } @@ -2633,9 +2656,9 @@ Tcl_LpopObjCmd( /* Argument objects. */ { Tcl_Size listLen; - int result; + int copied = 0, result; Tcl_Obj *elemPtr, *stored; - Tcl_Obj *listPtr, **elemPtrs; + Tcl_Obj *listPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?"); @@ -2647,7 +2670,7 @@ Tcl_LpopObjCmd( return TCL_ERROR; } - result = TclListObjGetElementsM(interp, listPtr, &listLen, &elemPtrs); + result = TclListObjLengthM(interp, listPtr, &listLen); if (result != TCL_OK) { return result; } @@ -2666,7 +2689,12 @@ Tcl_LpopObjCmd( "OUTOFRANGE", (void *)NULL); return TCL_ERROR; } - elemPtr = elemPtrs[listLen - 1]; + + result = Tcl_ListObjIndex(interp, listPtr, (listLen-1), &elemPtr); + if (result != TCL_OK) { + return result; + } + Tcl_IncrRefCount(elemPtr); } else { elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2); @@ -2686,22 +2714,35 @@ Tcl_LpopObjCmd( if (objc == 2) { if (Tcl_IsShared(listPtr)) { listPtr = TclListObjCopy(NULL, listPtr); + copied = 1; } result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL); if (result != TCL_OK) { + if (copied) { + Tcl_DecrRefCount(listPtr); + } return result; } - Tcl_IncrRefCount(listPtr); } else { - listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); - - if (listPtr == NULL) { + Tcl_Obj *newListPtr; + Tcl_ObjTypeSetElement *proc = TclObjTypeHasProc(listPtr, setElementProc); + if (proc) { + newListPtr = proc(interp, listPtr, objc-2, objv+2, NULL); + } else { + newListPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); + } + if (newListPtr == NULL) { + if (copied) { + Tcl_DecrRefCount(listPtr); + } return TCL_ERROR; + } else { + listPtr = newListPtr; + TclUndoRefCount(listPtr); } } stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(listPtr); if (stored == NULL) { return TCL_ERROR; } @@ -2758,11 +2799,11 @@ Tcl_LrangeObjCmd( return result; } - if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { - Tcl_Obj *rangeObj; - rangeObj = TclArithSeriesObjRange(interp, objv[1], first, last); - if (rangeObj) { - Tcl_SetObjResult(interp, rangeObj); + if (TclObjTypeHasProc(objv[1], sliceProc)) { + Tcl_Obj *resultObj; + int status = TclObjTypeSlice(interp, objv[1], first, last, &resultObj); + if (status == TCL_OK) { + Tcl_SetObjResult(interp, resultObj); } else { return TCL_ERROR; } @@ -2839,7 +2880,7 @@ Tcl_LremoveObjCmd( Tcl_SetObjResult(interp, listObj); return TCL_OK; } - idxv = (Tcl_Size *)ckalloc((objc - 2) * sizeof(*idxv)); + idxv = (Tcl_Size *)Tcl_Alloc((objc - 2) * sizeof(*idxv)); for (i = 2; i < objc; i++) { status = (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1, &idxv[i - 2]) != TCL_OK); @@ -2918,7 +2959,7 @@ Tcl_LremoveObjCmd( } Tcl_SetObjResult(interp, listObj); done: - ckfree(idxv); + Tcl_Free(idxv); return status; } @@ -2941,7 +2982,7 @@ done: int Tcl_LrepeatObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) @@ -3092,7 +3133,7 @@ Tcl_LreplaceObjCmd( return result; } - if (first == TCL_INDEX_NONE) { + if (first < 0) { first = 0; } else if (first > listLen) { first = listLen; @@ -3102,7 +3143,7 @@ Tcl_LreplaceObjCmd( last = listLen - 1; } if (first <= last) { - numToDelete = (unsigned)last - (unsigned)first + 1; /* See [3d3124d01d] */ + numToDelete = (size_t)last - (size_t)first + 1; /* See [3d3124d01d] */ } else { numToDelete = 0; } @@ -3127,6 +3168,7 @@ Tcl_LreplaceObjCmd( if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, first, numToDelete, objc-4, objv+4)) { + Tcl_DecrRefCount(listPtr); return TCL_ERROR; } @@ -3171,20 +3213,18 @@ Tcl_LreverseObjCmd( } /* - * Handle ArithSeries special case - don't shimmer a series into a list - * just to reverse it. + * Handle AbstractList special case - do not shimmer into a list, if it + * supports a private Reverse function, just to reverse it. */ - if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { - Tcl_Obj *resObj = TclArithSeriesObjReverse(interp, objv[1]); - if (resObj) { - Tcl_SetObjResult(interp, resObj); + if (TclObjTypeHasProc(objv[1], reverseProc)) { + Tcl_Obj *resultObj; + + if (TclObjTypeReverse(interp, objv[1], &resultObj) == TCL_OK) { + Tcl_SetObjResult(interp, resultObj); return TCL_OK; - } else { - return TCL_ERROR; } - } /* end ArithSeries */ + } /* end Abstract List */ - /* True List */ if (TclListObjLengthM(interp, objv[1], &elemc) != TCL_OK) { return TCL_ERROR; } @@ -3269,15 +3309,15 @@ Tcl_LsearchObjCmd( { const char *bytes, *patternBytes; int match, result=TCL_OK, bisect; - Tcl_Size i, length, listc, elemLen, start, index; - Tcl_Size groupSize, groupOffset, lower, upper; + Tcl_Size i, length = 0, listc, elemLen, start, index; + Tcl_Size groupOffset, lower, upper; int allocatedIndexVector = 0; - int dataType, isIncreasing; - Tcl_WideInt patWide, objWide, wide; + int isIncreasing; + Tcl_WideInt patWide, objWide, wide, groupSize; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; - Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; + Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr = NULL; SortStrCmpFn_t strCmpFn = TclUtfCmp; Tcl_RegExp regexp = NULL; static const char *const options[] = { @@ -3296,7 +3336,7 @@ Tcl_LsearchObjCmd( }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL - }; + } dataType; enum modes { EXACT, GLOB, REGEXP, SORTED }; @@ -3330,12 +3370,13 @@ Tcl_LsearchObjCmd( } for (i = 1; i < objc-2; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) + enum lsearchoptions idx; + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &idx) != TCL_OK) { result = TCL_ERROR; goto done; } - switch ((enum lsearchoptions) index) { + switch (idx) { case LSEARCH_ALL: /* -all */ allMatches = 1; break; @@ -3429,13 +3470,13 @@ Tcl_LsearchObjCmd( result = TCL_ERROR; goto done; } - if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { result = TCL_ERROR; goto done; } - if ((wide < 1) || (wide > LIST_MAX)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "stride length must be between 1 and %d", LIST_MAX)); + if (wide < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "stride length must be at least 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE", (void *)NULL); result = TCL_ERROR; @@ -3509,7 +3550,7 @@ Tcl_LsearchObjCmd( } if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (-index option item number %" TCL_SIZE_MODIFIER "d)", j)); + "\n (-index option item number %" TCL_Z_MODIFIER "u)", j)); goto done; } sortInfo.indexv[j] = encoded; @@ -3663,10 +3704,10 @@ Tcl_LsearchObjCmd( patObj = objv[objc - 1]; patternBytes = NULL; if (mode == EXACT || mode == SORTED) { - switch ((enum datatypes) dataType) { + switch (dataType) { case ASCII: case DICTIONARY: - patternBytes = TclGetStringFromObj(patObj, &length); + patternBytes = Tcl_GetStringFromObj(patObj, &length); break; case INTEGER: result = TclGetWideIntFromObj(interp, patObj, &patWide); @@ -3696,7 +3737,7 @@ Tcl_LsearchObjCmd( break; } } else { - patternBytes = TclGetStringFromObj(patObj, &length); + patternBytes = Tcl_GetStringFromObj(patObj, &length); } /* @@ -3721,9 +3762,14 @@ Tcl_LsearchObjCmd( lower = start - groupSize; upper = listc; + itemPtr = NULL; while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; i -= i % groupSize; + + Tcl_BounceRefCount(itemPtr); + itemPtr = NULL; + if (sortInfo.indexc != 0) { itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { @@ -3733,7 +3779,7 @@ Tcl_LsearchObjCmd( } else { itemPtr = listv[i+groupOffset]; } - switch ((enum datatypes) dataType) { + switch (dataType) { case ASCII: bytes = TclGetString(itemPtr); match = strCmpFn(patternBytes, bytes); @@ -3822,6 +3868,9 @@ Tcl_LsearchObjCmd( } for (i = start; i < listc; i += groupSize) { match = 0; + Tcl_BounceRefCount(itemPtr); + itemPtr = NULL; + if (sortInfo.indexc != 0) { itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { @@ -3838,9 +3887,9 @@ Tcl_LsearchObjCmd( switch (mode) { case SORTED: case EXACT: - switch ((enum datatypes) dataType) { + switch (dataType) { case ASCII: - bytes = TclGetStringFromObj(itemPtr, &elemLen); + bytes = Tcl_GetStringFromObj(itemPtr, &elemLen); if (length == elemLen) { /* * This split allows for more optimal compilation of @@ -3921,6 +3970,7 @@ Tcl_LsearchObjCmd( */ if (returnSubindices && (sortInfo.indexc != 0)) { + Tcl_BounceRefCount(itemPtr); itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); Tcl_ListObjAppendElement(interp, listPtr, itemPtr); @@ -3928,6 +3978,7 @@ Tcl_LsearchObjCmd( Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, groupSize, &listv[i]); } else { + Tcl_BounceRefCount(itemPtr); itemPtr = listv[i]; Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } @@ -3937,7 +3988,8 @@ Tcl_LsearchObjCmd( TclNewIndexObj(itemPtr, i+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { Tcl_Obj *elObj; - TclNewIndexObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc)); + size_t elValue = TclIndexDecode(sortInfo.indexv[j], listc); + TclNewIndexObj(elObj, elValue); Tcl_ListObjAppendElement(interp, itemPtr, elObj); } Tcl_ListObjAppendElement(interp, listPtr, itemPtr); @@ -3947,6 +3999,9 @@ Tcl_LsearchObjCmd( } } + Tcl_BounceRefCount(itemPtr); + itemPtr = NULL; + /* * Return everything or a single value. */ @@ -3960,7 +4015,8 @@ Tcl_LsearchObjCmd( TclNewIndexObj(itemPtr, index+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { Tcl_Obj *elObj; - TclNewIndexObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc)); + size_t elValue = TclIndexDecode(sortInfo.indexv[j], listc); + TclNewIndexObj(elObj, elValue); Tcl_ListObjAppendElement(interp, itemPtr, elObj); } Tcl_SetObjResult(interp, itemPtr); @@ -3975,7 +4031,7 @@ Tcl_LsearchObjCmd( * default... */ - Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_NewObj()); } else { if (returnSubindices) { Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset], @@ -3993,6 +4049,9 @@ Tcl_LsearchObjCmd( */ done: + /* potential lingering abstract list element */ + Tcl_BounceRefCount(itemPtr); + if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } @@ -4142,7 +4201,7 @@ Tcl_LseqObjCmd( Tcl_WideInt values[5]; Tcl_Obj *numValues[5]; Tcl_Obj *numberObj; - int status, keyword, useDoubles = 0; + int status = TCL_ERROR, keyword, useDoubles = 0; Tcl_Obj *arithSeriesPtr; SequenceOperators opmode; SequenceDecoded decoded; @@ -4212,7 +4271,6 @@ Tcl_LseqObjCmd( case 0: Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); - status = TCL_ERROR; goto done; break; @@ -4259,7 +4317,6 @@ Tcl_LseqObjCmd( step = one; break; default: - status = TCL_ERROR; goto done; } break; @@ -4282,11 +4339,9 @@ Tcl_LseqObjCmd( break; case LSEQ_BY: /* Error case */ - status = TCL_ERROR; goto done; break; default: - status = TCL_ERROR; goto done; break; } @@ -4305,7 +4360,6 @@ Tcl_LseqObjCmd( case LSEQ_TO: case LSEQ_COUNT: default: - status = TCL_ERROR; goto done; break; } @@ -4321,7 +4375,6 @@ Tcl_LseqObjCmd( step = numValues[4]; break; default: - status = TCL_ERROR; goto done; break; } @@ -4337,7 +4390,6 @@ Tcl_LseqObjCmd( elementCount = numValues[2]; break; default: - status = TCL_ERROR; goto done; break; } @@ -4351,7 +4403,6 @@ Tcl_LseqObjCmd( case 1212: opmode = (SequenceOperators)values[3]; goto KeywordError; break; KeywordError: - status = TCL_ERROR; switch (opmode) { case LSEQ_DOTS: case LSEQ_TO: @@ -4367,14 +4418,12 @@ Tcl_LseqObjCmd( "missing \"by\" value.")); break; } - status = TCL_ERROR; goto done; break; /* All other argument errors */ default: Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); - status = TCL_ERROR; goto done; break; } @@ -4456,8 +4505,16 @@ Tcl_LsetObjCmd( if (objc == 4) { finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); } else { - finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, - objv[objc-1]); + if (TclObjTypeHasProc(listPtr, setElementProc)) { + finalValuePtr = TclObjTypeSetElement(interp, listPtr, + objc-3, objv+2, objv[objc-1]); + if (finalValuePtr) { + Tcl_IncrRefCount(finalValuePtr); + } + } else { + finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, + objv[objc-1]); + } } /* @@ -4506,17 +4563,18 @@ Tcl_LsetObjCmd( int Tcl_LsortObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { - int i, j, index, indices, length, nocase = 0, indexc; + int indices, nocase = 0, indexc; int sortMode = SORTMODE_ASCII; - int group, groupSize, groupOffset, idx, allocatedIndexVector = 0; + int group, allocatedIndexVector = 0; + Tcl_Size j, idx, groupOffset, length; + Tcl_WideInt wide, groupSize; Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; - size_t elmArrSize; - Tcl_WideInt wide; + Tcl_Size i, elmArrSize; SortElement *elementArray = NULL, *elementPtr; SortInfo sortInfo; /* Information about this sort that needs to * be passed to the comparison function. */ @@ -4536,7 +4594,7 @@ Tcl_LsortObjCmd( LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY, LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER, LSORT_NOCASE, LSORT_REAL, LSORT_STRIDE, LSORT_UNIQUE - }; + } index; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list"); @@ -4566,7 +4624,7 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done; } - switch ((enum Lsort_Switches) index) { + switch (index) { case LSORT_ASCII: sortInfo.sortMode = SORTMODE_ASCII; break; @@ -4633,7 +4691,7 @@ Tcl_LsortObjCmd( } if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (-index option item number %d)", j)); + "\n (-index option item number %" TCL_Z_MODIFIER "u)", j)); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -4666,13 +4724,13 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done; } - if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; goto done; } - if ((wide < 2) || (wide > LIST_MAX)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "stride length must be between 2 and %d", LIST_MAX)); + if (wide < 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "stride length must be at least 2", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE", (void *)NULL); sortInfo.resultCode = TCL_ERROR; @@ -4747,20 +4805,17 @@ Tcl_LsortObjCmd( if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr) != TCL_OK) { TclDecrRefCount(newCommandPtr); - TclDecrRefCount(listObj); - Tcl_IncrRefCount(newObjPtr); TclDecrRefCount(newObjPtr); sortInfo.resultCode = TCL_ERROR; goto done; } - TclNewObj(newObjPtr); - Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr); + Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); sortInfo.compareCmdPtr = newCommandPtr; } - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - sortInfo.resultCode = TclArithSeriesGetElements(interp, - listObj, &length, &listObjPtrs); + if (TclObjTypeHasProc(objv[1], getElementsProc)) { + sortInfo.resultCode = + TclObjTypeGetElements(interp, listObj, &length, &listObjPtrs); } else { sortInfo.resultCode = TclListObjGetElementsM(interp, listObj, &length, &listObjPtrs); @@ -4852,13 +4907,13 @@ Tcl_LsortObjCmd( elmArrSize = length * sizeof(SortElement); if (elmArrSize <= MAXCALLOC) { - elementArray = (SortElement *)ckalloc(elmArrSize); + elementArray = (SortElement *)Tcl_Alloc(elmArrSize); } else { elementArray = (SortElement *)malloc(elmArrSize); } if (!elementArray) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no enough memory to proccess sort of %d items", length)); + "no enough memory to proccess sort of %" TCL_Z_MODIFIER "u items", length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); sortInfo.resultCode = TCL_ERROR; goto done; @@ -5000,7 +5055,7 @@ Tcl_LsortObjCmd( } if (elementArray) { if (elmArrSize <= MAXCALLOC) { - ckfree((char *)elementArray); + Tcl_Free(elementArray); } else { free((char *)elementArray); } @@ -5072,7 +5127,7 @@ Tcl_LeditObjCmd( return result; } - if (first == TCL_INDEX_NONE) { + if (first < 0) { first = 0; } else if (first > listLen) { first = listLen; @@ -5082,7 +5137,7 @@ Tcl_LeditObjCmd( last = listLen - 1; } if (first <= last) { - numToDelete = (unsigned)last - (unsigned)first + 1; /* See [3d3124d01d] */ + numToDelete = (size_t)last - (size_t)first + 1; /* See [3d3124d01d] */ } else { numToDelete = 0; } @@ -5104,19 +5159,11 @@ Tcl_LeditObjCmd( } /* - * Tcl_ObjSetVar2 mau return a value different from listPtr in the - * presence of traces etc.. Note that finalValuePtr will always have a - * reference count of at least 1 corresponding to the reference from the - * var. If it is same as listPtr, then ref count will be at least 2 - * since we are incr'ing the latter below (safer when calling - * Tcl_ObjSetVar2 which can release it in some cases). Note that we - * leave the incrref of listPtr this late because we want to pass it as - * unshared to Tcl_ListObjReplace above if possible. + * Tcl_ObjSetVar2 may return a value different from listPtr in the + * presence of traces etc. */ - Tcl_IncrRefCount(listPtr); finalValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(listPtr); /* safe irrespective of createdNewObj */ if (finalValuePtr == NULL) { return TCL_ERROR; } @@ -5513,7 +5560,7 @@ SelectObjFromSublist( for (i=0 ; i<infoPtr->indexc ; i++) { Tcl_Size listLen; int index; - Tcl_Obj *currentObj; + Tcl_Obj *currentObj, *lastObj=NULL; if (TclListObjLengthM(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; @@ -5544,6 +5591,8 @@ SelectObjFromSublist( return NULL; } objPtr = currentObj; + Tcl_BounceRefCount(lastObj); + lastObj = currentObj; } return objPtr; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 5d82a9e..38e04cb 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -20,6 +20,7 @@ #include "tclCompile.h" #include "tclRegexp.h" #include "tclStringTrim.h" +#include "tclTomMath.h" static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); @@ -30,8 +31,8 @@ static Tcl_NRPostProc TryPostHandler; static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); static int StringCmpOpts(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int *nocase, - Tcl_Size *reqlength); + Tcl_Obj *const objv[], int *nocase, + Tcl_Size *reqlength); /* * Default set of characters to trim in [string trim] and friends. This is a @@ -144,18 +145,17 @@ Tcl_RegexpObjCmd( REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, REGEXP_NOCASE, REGEXP_START, REGEXP_LAST - }; + } index; indices = 0; about = 0; cflags = TCL_REG_ADVANCED; - offset = 0; + offset = TCL_INDEX_START; all = 0; doinline = 0; for (i = 1; i < objc; i++) { const char *name; - int index; name = TclGetString(objv[i]); if (name[0] != '-') { @@ -165,7 +165,7 @@ Tcl_RegexpObjCmd( &index) != TCL_OK) { goto optionError; } - switch ((enum regexpoptions) index) { + switch (index) { case REGEXP_ALL: all = 1; break; @@ -259,13 +259,13 @@ Tcl_RegexpObjCmd( */ objPtr = objv[1]; - stringLength = TclGetCharLength(objPtr); + stringLength = Tcl_GetCharLength(objPtr); if (startIndex) { TclGetIntForIndexM(interp, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { - offset = 0; + offset = TCL_INDEX_START; } } @@ -309,11 +309,11 @@ Tcl_RegexpObjCmd( * start of the string unless the previous character is a newline. */ - if (offset == 0) { + if (offset == TCL_INDEX_START) { eflags = 0; } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; - } else if (TclGetUniChar(objPtr, offset-1) == '\n') { + } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; @@ -375,7 +375,7 @@ Tcl_RegexpObjCmd( * area. (Scriptics Bug 4391/SF Bug #219232) */ - if (i <= info.nsubs && info.matches[i].start >= 0) { + if (i <= (int)info.nsubs && info.matches[i].start >= 0) { start = offset + info.matches[i].start; end = offset + info.matches[i].end; @@ -397,8 +397,8 @@ Tcl_RegexpObjCmd( newPtr = Tcl_NewListObj(2, objs); } else { - if ((i <= info.nsubs) && (info.matches[i].end > 0)) { - newPtr = TclGetRange(objPtr, + if ((i <= (int)info.nsubs) && (info.matches[i].end > 0)) { + newPtr = Tcl_GetRange(objPtr, offset + info.matches[i].start, offset + info.matches[i].end - 1); } else { @@ -491,7 +491,7 @@ Tcl_RegsubObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int result, cflags, all, match, command; - Tcl_Size idx, wlen, wsublen, offset, numMatches, numParts; + Tcl_Size idx, wlen, wsublen = 0, offset, numMatches, numParts; Tcl_Size start, end, subStart, subEnd; Tcl_RegExp regExpr; Tcl_RegExpInfo info; @@ -507,17 +507,16 @@ Tcl_RegsubObjCmd( REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START, REGSUB_LAST - }; + } index; cflags = TCL_REG_ADVANCED; all = 0; - offset = 0; + offset = TCL_INDEX_START; command = 0; resultPtr = NULL; for (idx = 1; idx < objc; idx++) { const char *name; - int index; name = TclGetString(objv[idx]); if (name[0] != '-') { @@ -527,7 +526,7 @@ Tcl_RegsubObjCmd( TCL_EXACT, &index) != TCL_OK) { goto optionError; } - switch ((enum regsubobjoptions) index) { + switch (index) { case REGSUB_ALL: all = 1; break; @@ -585,7 +584,7 @@ Tcl_RegsubObjCmd( objv += idx; if (startIndex) { - Tcl_Size stringLength = TclGetCharLength(objv[1]); + Tcl_Size stringLength = Tcl_GetCharLength(objv[1]); TclGetIntForIndexM(interp, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); @@ -611,9 +610,9 @@ Tcl_RegsubObjCmd( nocase = (cflags & TCL_REG_NOCASE); strCmpFn = nocase ? TclUniCharNcasecmp : TclUniCharNcmp; - wsrc = TclGetUnicodeFromObj(objv[0], &slen); - wstring = TclGetUnicodeFromObj(objv[1], &wlen); - wsubspec = TclGetUnicodeFromObj(objv[2], &wsublen); + wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); + wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); + wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); wend = wstring + wlen - (slen ? slen - 1 : 0); result = TCL_OK; @@ -624,11 +623,11 @@ Tcl_RegsubObjCmd( */ if (wstring < wend) { - resultPtr = TclNewUnicodeObj(wstring, 0); + resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); for (; wstring < wend; wstring++) { - TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); - TclAppendUnicodeToObj(resultPtr, wstring, 1); + Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); + Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); numMatches++; } wlen = 0; @@ -638,21 +637,20 @@ Tcl_RegsubObjCmd( for (p = wfirstChar = wstring; wstring < wend; wstring++) { if ((*wstring == *wsrc || (nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) && - (slen==1 || (strCmpFn(wstring, wsrc, - (unsigned long) slen) == 0))) { + (slen==1 || (strCmpFn(wstring, wsrc, slen) == 0))) { if (numMatches == 0) { - resultPtr = TclNewUnicodeObj(wstring, 0); + resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); } if (p != wstring) { - TclAppendUnicodeToObj(resultPtr, p, wstring - p); + Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); p = wstring + slen; } else { p += slen; } wstring = p - 1; - TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); + Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); numMatches++; } } @@ -704,14 +702,14 @@ Tcl_RegsubObjCmd( } else { objPtr = objv[1]; } - wstring = TclGetUnicodeFromObj(objPtr, &wlen); + wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); if (objv[2] == objv[0]) { subPtr = Tcl_DuplicateObj(objv[2]); } else { subPtr = objv[2]; } if (!command) { - wsubspec = TclGetUnicodeFromObj(subPtr, &wsublen); + wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); } result = TCL_OK; @@ -747,15 +745,15 @@ Tcl_RegsubObjCmd( break; } if (numMatches == 0) { - resultPtr = TclNewUnicodeObj(wstring, 0); + resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); - if (offset > 0) { + if (offset > TCL_INDEX_START) { /* * Copy the initial portion of the string in if an offset was * specified. */ - TclAppendUnicodeToObj(resultPtr, wstring, offset); + Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); } } numMatches++; @@ -768,7 +766,7 @@ Tcl_RegsubObjCmd( Tcl_RegExpGetInfo(regExpr, &info); start = info.matches[0].start; end = info.matches[0].end; - TclAppendUnicodeToObj(resultPtr, wstring + offset, start); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); /* * In command-prefix mode, the substitutions are added as quoted @@ -783,17 +781,17 @@ Tcl_RegsubObjCmd( TclListObjGetElementsM(interp, subPtr, &numParts, &parts); numArgs = numParts + info.nsubs + 1; - args = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * numArgs); + args = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * numArgs); memcpy(args, parts, sizeof(Tcl_Obj*) * numParts); for (idx = 0 ; idx <= info.nsubs ; idx++) { subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { - args[idx + numParts] = TclNewUnicodeObj( + args[idx + numParts] = Tcl_NewUnicodeObj( wstring + offset + subStart, subEnd - subStart); } else { - TclNewObj(args[idx + numParts]); + args[idx + numParts] = Tcl_NewObj(); } Tcl_IncrRefCount(args[idx + numParts]); } @@ -813,7 +811,7 @@ Tcl_RegsubObjCmd( for (idx = 0 ; idx <= info.nsubs ; idx++) { TclDecrRefCount(args[idx + numParts]); } - ckfree(args); + Tcl_Free(args); if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -831,7 +829,7 @@ Tcl_RegsubObjCmd( * the user code. */ - wstring = TclGetUnicodeFromObj(objPtr, &wlen); + wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); offset += end; if (end == 0 || start == end) { @@ -843,7 +841,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -872,7 +870,7 @@ Tcl_RegsubObjCmd( idx = ch - '0'; } else if ((ch == '\\') || (ch == '&')) { *wsrc = ch; - TclAppendUnicodeToObj(resultPtr, wfirstChar, + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar + 1); *wsrc = '\\'; wfirstChar = wsrc + 2; @@ -886,7 +884,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - TclAppendUnicodeToObj(resultPtr, wfirstChar, + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } @@ -894,7 +892,7 @@ Tcl_RegsubObjCmd( subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { - TclAppendUnicodeToObj(resultPtr, + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } @@ -906,7 +904,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { @@ -916,7 +914,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } else { @@ -928,7 +926,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -953,7 +951,7 @@ Tcl_RegsubObjCmd( resultPtr = objv[1]; Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, @@ -1057,7 +1055,7 @@ Tcl_ReturnObjCmd( */ int explicitResult = (0 == (objc % 2)); - Tcl_Size numOptionWords = objc - 1 - explicitResult; + int numOptionWords = objc - 1 - explicitResult; if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1, &returnOpts, &code, &level)) { @@ -1191,13 +1189,13 @@ Tcl_SplitObjCmd( splitChars = " \n\t\r"; splitCharLen = 4; } else if (objc == 3) { - splitChars = TclGetStringFromObj(objv[2], &splitCharLen); + splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); return TCL_ERROR; } - stringPtr = TclGetStringFromObj(objv[1], &stringLen); + stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen); end = stringPtr + stringLen; TclNewObj(listPtr); @@ -1312,7 +1310,7 @@ StringFirstCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size start = 0; + Tcl_Size start = TCL_INDEX_START; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1321,7 +1319,7 @@ StringFirstCmd( } if (objc == 4) { - Tcl_Size end = TclGetCharLength(objv[2]) - 1; + Tcl_Size end = Tcl_GetCharLength(objv[2]) - 1; if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &start)) { return TCL_ERROR; @@ -1365,7 +1363,7 @@ StringLastCmd( } if (objc == 4) { - Tcl_Size end = TclGetCharLength(objv[2]) - 1; + Tcl_Size end = Tcl_GetCharLength(objv[2]) - 1; if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &last)) { return TCL_ERROR; @@ -1411,13 +1409,13 @@ StringIndexCmd( * Get the char length to calculate what 'end' means. */ - end = TclGetCharLength(objv[1]) - 1; + end = Tcl_GetCharLength(objv[1]) - 1; if (TclGetIntForIndexM(interp, objv[2], end, &index) != TCL_OK) { return TCL_ERROR; } if ((index >= 0) && (index <= end)) { - int ch = TclGetUniChar(objv[1], index); + int ch = Tcl_GetUniChar(objv[1], index); if (ch == -1) { return TCL_OK; @@ -1436,9 +1434,6 @@ StringIndexCmd( char buf[4] = ""; end = Tcl_UniCharToUtf(ch, buf); - if ((ch >= 0xD800) && (end < 3)) { - end += Tcl_UniCharToUtf(-1, buf + end); - } Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, end)); } } @@ -1479,13 +1474,13 @@ StringInsertCmd( return TCL_ERROR; } - length = TclGetCharLength(objv[1]); + length = Tcl_GetCharLength(objv[1]); if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) { return TCL_ERROR; } if (index < 0) { - index = 0; + index = TCL_INDEX_START; } if (index > length) { index = length; @@ -1529,7 +1524,8 @@ StringIsCmd( { const char *string1, *end, *stop; int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ - int i, failat = 0, result = 1, strict = 0, index, length1, length2; + int i, result = 1, strict = 0; + Tcl_Size failat = 0, length1, length2, length3; Tcl_Obj *objPtr, *failVarObj = NULL; Tcl_WideInt w; @@ -1548,13 +1544,13 @@ StringIsCmd( STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_UNICODE, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT - }; + } index; static const char *const isOptions[] = { "-strict", "-failindex", NULL }; enum isOptionsEnum { OPT_STRICT, OPT_FAILIDX - }; + } idx2; if (objc < 3 || objc > 6) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1568,13 +1564,11 @@ StringIsCmd( if (objc != 3) { for (i = 2; i < objc-1; i++) { - int idx2; - if (Tcl_GetIndexFromObj(interp, objv[i], isOptions, "option", 0, &idx2) != TCL_OK) { return TCL_ERROR; } - switch ((enum isOptionsEnum) idx2) { + switch (idx2) { case OPT_STRICT: strict = 1; break; @@ -1603,7 +1597,7 @@ StringIsCmd( * When entering here, result == 1 and failat == 0. */ - switch ((enum isClassesEnum) index) { + switch (index) { case STR_IS_ALNUM: chcomp = Tcl_UniCharIsAlnum; break; @@ -1621,14 +1615,12 @@ StringIsCmd( if (strict) { result = 0; } else { - string1 = TclGetStringFromObj(objPtr, &length1); + string1 = Tcl_GetStringFromObj(objPtr, &length1); result = length1 == 0; } - } else if (index != STR_IS_BOOL) { - TclGetBooleanFromObj(NULL, objPtr, &i); - if ((index == STR_IS_TRUE) ^ i) { - result = 0; - } + } else if ((objPtr->internalRep.wideValue != 0) + ? (index == STR_IS_FALSE) : (index == STR_IS_TRUE)) { + result = 0; } break; case STR_IS_CONTROL: @@ -1652,7 +1644,7 @@ StringIsCmd( Tcl_Size lenRemain, elemSize; const char *p; - string1 = TclGetStringFromObj(objPtr, &length1); + string1 = Tcl_GetStringFromObj(objPtr, &length1); end = string1 + length1; failat = -1; for (p=string1, lenRemain=length1; lenRemain > 0; @@ -1675,7 +1667,7 @@ StringIsCmd( p++; } TclNewStringObj(tmpStr, string1, p-string1); - failat = TclGetCharLength(tmpStr); + failat = Tcl_GetCharLength(tmpStr); TclDecrRefCount(tmpStr); break; } @@ -1692,7 +1684,7 @@ StringIsCmd( TclHasInternalRep(objPtr, &tclBignumType)) { break; } - string1 = TclGetStringFromObj(objPtr, &length1); + string1 = Tcl_GetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { result = 0; @@ -1722,7 +1714,7 @@ StringIsCmd( TclHasInternalRep(objPtr, &tclBignumType)) { break; } - string1 = TclGetStringFromObj(objPtr, &length1); + string1 = Tcl_GetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { result = 0; @@ -1764,7 +1756,7 @@ StringIsCmd( break; } - string1 = TclGetStringFromObj(objPtr, &length1); + string1 = Tcl_GetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { result = 0; @@ -1817,7 +1809,7 @@ StringIsCmd( * well-formed lists. */ - if (TCL_OK == TclListObjLengthM(NULL, objPtr, &length2)) { + if (TCL_OK == TclListObjLengthM(NULL, objPtr, &length3)) { break; } @@ -1829,10 +1821,11 @@ StringIsCmd( */ const char *elemStart, *nextElem; - Tcl_Size lenRemain, elemSize; + Tcl_Size lenRemain; + Tcl_Size elemSize; const char *p; - string1 = TclGetStringFromObj(objPtr, &length1); + string1 = Tcl_GetStringFromObj(objPtr, &length1); end = string1 + length1; failat = -1; for (p=string1, lenRemain=length1; lenRemain > 0; @@ -1855,7 +1848,7 @@ StringIsCmd( p++; } TclNewStringObj(tmpStr, string1, p-string1); - failat = TclGetCharLength(tmpStr); + failat = Tcl_GetCharLength(tmpStr); TclDecrRefCount(tmpStr); break; } @@ -1890,7 +1883,7 @@ StringIsCmd( } if (chcomp != NULL) { - string1 = TclGetStringFromObj(objPtr, &length1); + string1 = Tcl_GetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { result = 0; @@ -1964,7 +1957,7 @@ StringMapCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size length1, length2, mapElemc, index; + Tcl_Size length1, length2, mapElemc, index; int nocase = 0, mapWithDict = 0, copySource = 0; Tcl_Obj **mapElemv, *sourceObj, *resultPtr; Tcl_UniChar *ustring1, *ustring2, *p, *end; @@ -1976,7 +1969,7 @@ StringMapCmd( } if (objc == 4) { - const char *string = TclGetStringFromObj(objv[1], &length2); + const char *string = Tcl_GetStringFromObj(objv[1], &length2); if ((length2 > 1) && strncmp(string, "-nocase", length2) == 0) { @@ -1997,7 +1990,8 @@ StringMapCmd( if (!TclHasStringRep(objv[objc-2]) && TclHasInternalRep(objv[objc-2], &tclDictType)) { - int i, done; + Tcl_Size i; + int done; Tcl_DictSearch search; /* @@ -2005,8 +1999,8 @@ StringMapCmd( * sure. This shortens this code quite a bit. */ - Tcl_DictObjSize(interp, objv[objc-2], &mapElemc); - if (mapElemc == 0) { + Tcl_DictObjSize(interp, objv[objc-2], &i); + if (i == 0) { /* * Empty charMap, just return whatever string was given. */ @@ -2015,7 +2009,7 @@ StringMapCmd( return TCL_OK; } - mapElemc *= 2; + mapElemc = 2 * i; mapWithDict = 1; /* @@ -2026,15 +2020,17 @@ StringMapCmd( mapElemv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, mapElemv+1, &done); - for (i=2 ; i<mapElemc ; i+=2) { - Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done); + for (index=2 ; index<mapElemc ; index+=2) { + Tcl_DictObjNext(&search, mapElemv+index, mapElemv+index+1, &done); } Tcl_DictObjDone(&search); } else { - if (TclListObjGetElementsM(interp, objv[objc-2], &mapElemc, + Tcl_Size i; + if (TclListObjGetElementsM(interp, objv[objc-2], &i, &mapElemv) != TCL_OK) { return TCL_ERROR; } + mapElemc = i; if (mapElemc == 0) { /* * empty charMap, just return whatever string was given. @@ -2066,7 +2062,7 @@ StringMapCmd( } else { sourceObj = objv[objc-1]; } - ustring1 = TclGetUnicodeFromObj(sourceObj, &length1); + ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); if (length1 == 0) { /* * Empty input string, just stop now. @@ -2082,7 +2078,7 @@ StringMapCmd( * Force result to be Unicode */ - resultPtr = TclNewUnicodeObj(ustring1, 0); + resultPtr = Tcl_NewUnicodeObj(ustring1, 0); if (mapElemc == 2) { /* @@ -2096,7 +2092,7 @@ StringMapCmd( int u2lc; Tcl_UniChar *mapString; - ustring2 = TclGetUnicodeFromObj(mapElemv[0], &length2); + ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); p = ustring1; if ((length2 > length1) || (length2 == 0)) { /* @@ -2105,29 +2101,29 @@ StringMapCmd( ustring1 = end; } else { - mapString = TclGetUnicodeFromObj(mapElemv[1], &mapLen); + mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); for (; ustring1 < end; ustring1++) { if (((*ustring1 == *ustring2) || (nocase&&Tcl_UniCharToLower(*ustring1)==u2lc)) && (length2==1 || strCmpFn(ustring1, ustring2, - (unsigned long) length2) == 0)) { + length2) == 0)) { if (p != ustring1) { - TclAppendUnicodeToObj(resultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - TclAppendUnicodeToObj(resultPtr, mapString, mapLen); + Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); } } } } else { Tcl_UniChar **mapStrings; Tcl_Size *mapLens; - int *u2lc = NULL; + int *u2lc = 0; /* * Precompute pointers to the Unicode string and length. This saves us @@ -2142,7 +2138,7 @@ StringMapCmd( u2lc = (int *)TclStackAlloc(interp, mapElemc * sizeof(int)); } for (index = 0; index < mapElemc; index++) { - mapStrings[index] = TclGetUnicodeFromObj(mapElemv[index], + mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], mapLens+index); if (nocase && ((index % 2) == 0)) { u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); @@ -2159,14 +2155,14 @@ StringMapCmd( if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase && (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && /* Restrict max compare length. */ - (end-ustring1 >= length2) && ((length2 == 1) || + ((end-ustring1) >= length2) && ((length2 == 1) || !strCmpFn(ustring2, ustring1, length2))) { if (p != ustring1) { /* * Put the skipped chars onto the result first. */ - TclAppendUnicodeToObj(resultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; @@ -2182,7 +2178,7 @@ StringMapCmd( * Append the map value to the Unicode string. */ - TclAppendUnicodeToObj(resultPtr, + Tcl_AppendUnicodeToObj(resultPtr, mapStrings[index+1], mapLens[index+1]); break; } @@ -2199,7 +2195,7 @@ StringMapCmd( * Put the rest of the unmapped chars onto result. */ - TclAppendUnicodeToObj(resultPtr, p, ustring1 - p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); } Tcl_SetObjResult(interp, resultPtr); done: @@ -2246,7 +2242,7 @@ StringMatchCmd( if (objc == 4) { Tcl_Size length; - const char *string = TclGetStringFromObj(objv[1], &length); + const char *string = Tcl_GetStringFromObj(objv[1], &length); if ((length > 1) && strncmp(string, "-nocase", length) == 0) { @@ -2301,7 +2297,7 @@ StringRangeCmd( * 'end' refers to the last character, not one past it. */ - end = TclGetCharLength(objv[1]) - 1; + end = Tcl_GetCharLength(objv[1]) - 1; if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { @@ -2309,7 +2305,7 @@ StringRangeCmd( } if (last >= 0) { - Tcl_SetObjResult(interp, TclGetRange(objv[1], first, last)); + Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); } return TCL_OK; } @@ -2339,7 +2335,7 @@ StringReptCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int count; + Tcl_WideInt count; Tcl_Obj *resultPtr; if (objc != 3) { @@ -2347,7 +2343,7 @@ StringReptCmd( return TCL_ERROR; } - if (TclGetIntFromObj(interp, objv[2], &count) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[2], &count) != TCL_OK) { return TCL_ERROR; } @@ -2402,7 +2398,7 @@ StringRplcCmd( return TCL_ERROR; } - end = TclGetCharLength(objv[1]) - 1; + end = Tcl_GetCharLength(objv[1]) - 1; if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { @@ -2415,7 +2411,7 @@ StringRplcCmd( * result is the original string. */ - if ((last < 0) || /* Range ends before start of string */ + if ((last < 0) || /* Range ends before start of string */ (first > end) || /* Range begins after end of string */ (last < first)) { /* Range begins after it starts */ /* @@ -2429,7 +2425,7 @@ StringRplcCmd( Tcl_Obj *resultPtr; if (first < 0) { - first = 0; + first = TCL_INDEX_START; } if (last > end) { last = end; @@ -2515,7 +2511,7 @@ StringStartCmd( return TCL_ERROR; } - string = TclGetUnicodeFromObj(objv[1], &length); + string = Tcl_GetUnicodeFromObj(objv[1], &length); if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { return TCL_ERROR; } @@ -2535,7 +2531,7 @@ StringStartCmd( break; } - next = (p > string) ? p - 1 : p; + next = ((p > string) ? (p - 1) : p); do { next += delta; ch = *next; @@ -2586,7 +2582,7 @@ StringEndCmd( return TCL_ERROR; } - string = TclGetUnicodeFromObj(objv[1], &length); + string = Tcl_GetUnicodeFromObj(objv[1], &length); if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { return TCL_ERROR; } @@ -2657,7 +2653,7 @@ StringEqualCmd( } for (i = 1; i < objc-2; i++) { - string2 = TclGetStringFromObj(objv[i], &length); + string2 = Tcl_GetStringFromObj(objv[i], &length); if ((length > 1) && !strncmp(string2, "-nocase", length)) { nocase = 1; } else if ((length > 1) @@ -2666,7 +2662,7 @@ StringEqualCmd( goto str_cmp_args; } i++; - if (Tcl_GetWideIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } if ((Tcl_WideUInt)reqlength > TCL_SIZE_MAX) { @@ -2760,7 +2756,7 @@ StringCmpOpts( } for (i = 1; i < objc-2; i++) { - string = TclGetStringFromObj(objv[i], &length); + string = Tcl_GetStringFromObj(objv[i], &length); if ((length > 1) && !strncmp(string, "-nocase", length)) { *nocase = 1; } else if ((length > 1) @@ -2769,7 +2765,7 @@ StringCmpOpts( goto str_cmp_args; } i++; - if (Tcl_GetWideIntFromObj(interp, objv[i], &wreqlength) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[i], &wreqlength) != TCL_OK) { return TCL_ERROR; } if ((Tcl_WideUInt)wreqlength > TCL_SIZE_MAX) { @@ -2836,45 +2832,6 @@ StringCatCmd( /* *---------------------------------------------------------------------- * - * StringBytesCmd -- - * - * This procedure is invoked to process the "string bytelength" Tcl - * command. See the user documentation for details on what it does. Note - * that this command only functions correctly on properly formed Tcl UTF - * strings. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ -#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) -static int -StringBytesCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int length; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "string"); - return TCL_ERROR; - } - - (void) TclGetStringFromObj(objv[1], &length); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length)); - return TCL_OK; -} -#endif - -/* - *---------------------------------------------------------------------- - * * StringLenCmd -- * * This procedure is invoked to process the "string length" Tcl command. @@ -2902,7 +2859,7 @@ StringLenCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclGetCharLength(objv[1]))); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_GetCharLength(objv[1]))); return TCL_OK; } @@ -2940,7 +2897,7 @@ StringLowerCmd( return TCL_ERROR; } - string1 = TclGetStringFromObj(objv[1], &length1); + string1 = Tcl_GetStringFromObj(objv[1], &length1); if (objc == 2) { Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); @@ -2953,7 +2910,7 @@ StringLowerCmd( const char *start, *end; Tcl_Obj *resultPtr; - length1 = TclNumUtfChars(string1, length1) - 1; + length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } @@ -2975,9 +2932,9 @@ StringLowerCmd( return TCL_OK; } - string1 = TclGetStringFromObj(objv[1], &length1); - start = TclUtfAtIndex(string1, first); - end = TclUtfAtIndex(start, last - first + 1); + string1 = Tcl_GetStringFromObj(objv[1], &length1); + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); resultPtr = Tcl_NewStringObj(string1, end - string1); string2 = TclGetString(resultPtr) + (start - string1); @@ -3025,7 +2982,7 @@ StringUpperCmd( return TCL_ERROR; } - string1 = TclGetStringFromObj(objv[1], &length1); + string1 = Tcl_GetStringFromObj(objv[1], &length1); if (objc == 2) { Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); @@ -3038,7 +2995,7 @@ StringUpperCmd( const char *start, *end; Tcl_Obj *resultPtr; - length1 = TclNumUtfChars(string1, length1) - 1; + length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } @@ -3060,9 +3017,9 @@ StringUpperCmd( return TCL_OK; } - string1 = TclGetStringFromObj(objv[1], &length1); - start = TclUtfAtIndex(string1, first); - end = TclUtfAtIndex(start, last - first + 1); + string1 = Tcl_GetStringFromObj(objv[1], &length1); + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); resultPtr = Tcl_NewStringObj(string1, end - string1); string2 = TclGetString(resultPtr) + (start - string1); @@ -3110,7 +3067,7 @@ StringTitleCmd( return TCL_ERROR; } - string1 = TclGetStringFromObj(objv[1], &length1); + string1 = Tcl_GetStringFromObj(objv[1], &length1); if (objc == 2) { Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); @@ -3123,7 +3080,7 @@ StringTitleCmd( const char *start, *end; Tcl_Obj *resultPtr; - length1 = TclNumUtfChars(string1, length1) - 1; + length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } @@ -3145,9 +3102,9 @@ StringTitleCmd( return TCL_OK; } - string1 = TclGetStringFromObj(objv[1], &length1); - start = TclUtfAtIndex(string1, first); - end = TclUtfAtIndex(start, last - first + 1); + string1 = Tcl_GetStringFromObj(objv[1], &length1); + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); resultPtr = Tcl_NewStringObj(string1, end - string1); string2 = TclGetString(resultPtr) + (start - string1); @@ -3187,10 +3144,10 @@ StringTrimCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *string2; - int triml, trimr, length1, length2; + Tcl_Size triml, trimr, length1, length2; if (objc == 3) { - string2 = TclGetStringFromObj(objv[2], &length2); + string2 = Tcl_GetStringFromObj(objv[2], &length2); } else if (objc == 2) { string2 = tclDefaultTrimSet; length2 = strlen(tclDefaultTrimSet); @@ -3198,7 +3155,7 @@ StringTrimCmd( Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; } - string1 = TclGetStringFromObj(objv[1], &length1); + string1 = Tcl_GetStringFromObj(objv[1], &length1); triml = TclTrim(string1, length1, string2, length2, &trimr); @@ -3238,7 +3195,7 @@ StringTrimLCmd( Tcl_Size length1, length2; if (objc == 3) { - string2 = TclGetStringFromObj(objv[2], &length2); + string2 = Tcl_GetStringFromObj(objv[2], &length2); } else if (objc == 2) { string2 = tclDefaultTrimSet; length2 = strlen(tclDefaultTrimSet); @@ -3246,7 +3203,7 @@ StringTrimLCmd( Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; } - string1 = TclGetStringFromObj(objv[1], &length1); + string1 = Tcl_GetStringFromObj(objv[1], &length1); trim = TclTrimLeft(string1, length1, string2, length2); @@ -3285,7 +3242,7 @@ StringTrimRCmd( Tcl_Size length1, length2; if (objc == 3) { - string2 = TclGetStringFromObj(objv[2], &length2); + string2 = Tcl_GetStringFromObj(objv[2], &length2); } else if (objc == 2) { string2 = tclDefaultTrimSet; length2 = strlen(tclDefaultTrimSet); @@ -3293,7 +3250,7 @@ StringTrimRCmd( Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; } - string1 = TclGetStringFromObj(objv[1], &length1); + string1 = Tcl_GetStringFromObj(objv[1], &length1); trim = TclTrimRight(string1, length1, string2, length2); @@ -3329,9 +3286,6 @@ TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { -#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) - {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, -#endif {"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0}, {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, @@ -3483,7 +3437,7 @@ TclNRSwitchObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, index, mode, foundmode, splitObjs, numMatchesSaved; + int i, mode, foundmode, splitObjs, numMatchesSaved; int noCase; Tcl_Size patternLength, j; const char *pattern; @@ -3509,7 +3463,7 @@ TclNRSwitchObjCmd( enum switchOptionsEnum { OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST - }; + } index; typedef int (*strCmpFn_t)(const char *, const char *); strCmpFn_t strCmpFn = TclUtfCmp; @@ -3527,7 +3481,7 @@ TclNRSwitchObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum switchOptionsEnum) index) { + switch (index) { /* * General options. */ @@ -3633,9 +3587,10 @@ TclNRSwitchObjCmd( splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; + Tcl_Size listc; blist = objv[0]; - if (TclListObjLengthM(interp, objv[0], &objc) != TCL_OK) { + if (TclListObjLengthM(interp, objv[0], &listc) != TCL_OK) { return TCL_ERROR; } @@ -3643,14 +3598,15 @@ TclNRSwitchObjCmd( * Ensure that the list is non-empty. */ - if (objc < 1) { + if (listc < 1 || listc > INT_MAX) { Tcl_WrongNumArgs(interp, 1, savedObjv, "?-option ...? string {?pattern body ...? ?default body?}"); return TCL_ERROR; } - if (TclListObjGetElementsM(interp, objv[0], &objc, &listv) != TCL_OK) { + if (TclListObjGetElementsM(interp, objv[0], &listc, &listv) != TCL_OK) { return TCL_ERROR; } + objc = listc; objv = listv; splitObjs = 1; } @@ -3711,7 +3667,7 @@ TclNRSwitchObjCmd( * See if the pattern matches the string. */ - pattern = TclGetStringFromObj(objv[i], &patternLength); + pattern = Tcl_GetStringFromObj(objv[i], &patternLength); if ((i == objc - 2) && (*pattern == 'd') && (strcmp(pattern, "default") == 0)) { @@ -3819,7 +3775,7 @@ TclNRSwitchObjCmd( Tcl_Obj *substringObj; if (info.matches[j].end > 0) { - substringObj = TclGetRange(stringObj, + substringObj = Tcl_GetRange(stringObj, info.matches[j].start, info.matches[j].end-1); } else { TclNewObj(substringObj); @@ -3900,7 +3856,7 @@ TclNRSwitchObjCmd( if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { int bline = ctxPtr->line[bidx]; - ctxPtr->line = (Tcl_Size *)ckalloc(objc * sizeof(Tcl_Size)); + ctxPtr->line = (Tcl_Size *)Tcl_Alloc(objc * sizeof(Tcl_Size)); ctxPtr->nline = objc; TclListLines(blist, bline, objc, ctxPtr->line, objv); } else { @@ -3914,7 +3870,7 @@ TclNRSwitchObjCmd( int k; - ctxPtr->line = (Tcl_Size *)ckalloc(objc * sizeof(Tcl_Size)); + ctxPtr->line = (Tcl_Size *)Tcl_Alloc(objc * sizeof(Tcl_Size)); ctxPtr->nline = objc; for (k=0; k < objc; k++) { ctxPtr->line[k] = -1; @@ -3964,7 +3920,7 @@ SwitchPostProc( */ if (splitObjs) { - ckfree(ctxPtr->line); + Tcl_Free(ctxPtr->line); if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* * Death of SrcInfo reference. @@ -3984,7 +3940,7 @@ SwitchPostProc( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s%s\" arm line %d)", - (overflow ? limit : patternLength), pattern, + (int) (overflow ? limit : patternLength), pattern, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } TclStackFree(interp, ctxPtr); @@ -4207,7 +4163,7 @@ Tcl_TimeRateObjCmd( ByteCode *codePtr = NULL; for (i = 1; i < objc - 1; i++) { - int index; + enum timeRateOptionsEnum index; if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT, &index) != TCL_OK) { @@ -4217,7 +4173,7 @@ Tcl_TimeRateObjCmd( i++; break; } - switch ((enum timeRateOptionsEnum)index) { + switch (index) { case TMRT_EV_DIRECT: direct = objv[i]; break; @@ -4246,14 +4202,15 @@ Tcl_TimeRateObjCmd( } objPtr = objv[i++]; if (i < objc) { /* max-time */ - result = Tcl_GetWideIntFromObj(interp, objv[i++], &maxms); + result = TclGetWideIntFromObj(interp, objv[i], &maxms); + i++; // Keep this separate from TclGetWideIntFromObj macro above! if (result != TCL_OK) { return result; } if (i < objc) { /* max-count*/ Tcl_WideInt v; - result = Tcl_GetWideIntFromObj(interp, objv[i], &v); + result = TclGetWideIntFromObj(interp, objv[i], &v); if (result != TCL_OK) { return result; } @@ -4757,7 +4714,7 @@ TclNRTryObjCmd( bodyShared = 0; haveHandlers = 0; for (i=2 ; i<objc ; i++) { - int type; + enum Handlers type; Tcl_Obj *info[5]; if (Tcl_GetIndexFromObj(interp, objv[i], handlerNames, "handler type", @@ -4765,7 +4722,7 @@ TclNRTryObjCmd( Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } - switch ((enum Handlers) type) { + switch (type) { case TryFinally: /* finally script */ if (i < objc-2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 0104285..495c307 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -286,7 +286,8 @@ TclCompileArraySetCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *dataTokenPtr; int isScalar, localIndex, code = TCL_OK; - int isDataLiteral, isDataValid, isDataEven, len; + int isDataLiteral, isDataValid, isDataEven; + Tcl_Size len; int keyVar, valVar, infoIndex; int fwd, offsetBack, offsetFwd; Tcl_Obj *literalObj; @@ -390,9 +391,9 @@ TclCompileArraySetCmd( keyVar = AnonymousLocal(envPtr); valVar = AnonymousLocal(envPtr); - infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *)); + infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *)); infoPtr->numLists = 1; - infoPtr->varLists[0] = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(int)); + infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(Tcl_Size)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; @@ -583,7 +584,7 @@ TclCompileCatchCmd( * Let runtime checks determine if syntax has changed. */ - if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) { + if (((int)parsePtr->numWords < 2) || ((int)parsePtr->numWords > 4)) { return TCL_ERROR; } @@ -592,7 +593,7 @@ TclCompileCatchCmd( * (not in a procedure), don't compile it inline: the payoff is too small. */ - if ((parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { + if (((int)parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { return TCL_ERROR; } @@ -603,7 +604,7 @@ TclCompileCatchCmd( resultIndex = optsIndex = -1; cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (parsePtr->numWords >= 3) { + if ((int)parsePtr->numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); /* DGP */ resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr); @@ -686,8 +687,8 @@ TclCompileCatchCmd( /* Stack at this point on both branches: result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", - (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); + Tcl_Panic("TclCompileCatchCmd: bad jump distance %" TCL_Z_MODIFIER "d", + (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } /* @@ -876,7 +877,7 @@ TclCompileConcatCmd( */ TclNewObj(listObj); - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { @@ -890,13 +891,13 @@ TclCompileConcatCmd( if (listObj != NULL) { Tcl_Obj **objs; const char *bytes; - int len; + Tcl_Size len, slen; TclListObjGetElementsM(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); - bytes = TclGetStringFromObj(objPtr, &len); - PushLiteral(envPtr, bytes, len); + bytes = Tcl_GetStringFromObj(objPtr, &slen); + PushLiteral(envPtr, bytes, slen); Tcl_DecrRefCount(objPtr); return TCL_OK; } @@ -905,7 +906,7 @@ TclCompileConcatCmd( * General case: runtime concat. */ - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -918,6 +919,84 @@ TclCompileConcatCmd( /* *---------------------------------------------------------------------- * + * TclCompileConstCmd -- + * + * Procedure called to compile the "const" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "const" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileConstCmd( + Tcl_Interp *interp, /* The interpreter. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + TCL_UNUSED(Command *), + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *varTokenPtr, *valueTokenPtr; + int isScalar, localIndex; + + /* + * Need exactly two arguments. + */ + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &isScalar, 1); + + /* + * If the user specified an array element, we don't bother handling + * that. + */ + if (!isScalar) { + return TCL_ERROR; + } + + /* + * We are doing an assignment to set the value of the constant. This will + * need to be extended to push a value for each argument. + */ + + valueTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, valueTokenPtr, interp, 2); + + if (localIndex < 0) { + TclEmitOpcode(INST_CONST_STK, envPtr); + } else { + TclEmitInstInt4(INST_CONST_IMM, localIndex, envPtr); + } + + /* + * The const command's result is an empty string. + */ + PushStringLiteral(envPtr, ""); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileContinueCmd -- * * Procedure called to compile the "continue" command. @@ -1012,7 +1091,7 @@ TclCompileDictSetCmd( * There must be at least one argument after the command. */ - if (parsePtr->numWords < 4) { + if ((int)parsePtr->numWords < 4) { return TCL_ERROR; } @@ -1033,7 +1112,7 @@ TclCompileDictSetCmd( */ tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i< parsePtr->numWords ; i++) { + for (i=2 ; i< (int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -1042,7 +1121,7 @@ TclCompileDictSetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); + TclEmitInstInt4( INST_DICT_SET, (int)parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; @@ -1065,7 +1144,7 @@ TclCompileDictIncrCmd( * There must be at least two arguments after the command. */ - if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { + if ((int)parsePtr->numWords < 3 || (int)parsePtr->numWords > 4) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1077,7 +1156,8 @@ TclCompileDictIncrCmd( if (parsePtr->numWords == 4) { const char *word; - int numBytes, code; + Tcl_Size numBytes; + int code; Tcl_Token *incrTokenPtr; Tcl_Obj *intObj; @@ -1138,7 +1218,7 @@ TclCompileDictGetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1147,11 +1227,11 @@ TclCompileDictGetCmd( * Only compile this because we need INST_DICT_GET anyway. */ - for (i=1 ; i<parsePtr->numWords ; i++) { + for (i=1 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); + TclEmitInstInt4(INST_DICT_GET, (int)parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1173,16 +1253,16 @@ TclCompileDictGetWithDefaultCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 4) { + if ((int)parsePtr->numWords < 4) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<parsePtr->numWords ; i++) { + for (i=1 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr); + TclEmitInstInt4(INST_DICT_GET_DEF, (int)parsePtr->numWords-3, envPtr); TclAdjustStackDepth(-2, envPtr); return TCL_OK; } @@ -1205,7 +1285,7 @@ TclCompileDictExistsCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1214,11 +1294,11 @@ TclCompileDictExistsCmd( * Now we do the code generation. */ - for (i=1 ; i<parsePtr->numWords ; i++) { + for (i=1 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); + TclEmitInstInt4(INST_DICT_EXISTS, (int)parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1242,7 +1322,7 @@ TclCompileDictUnsetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1262,7 +1342,7 @@ TclCompileDictUnsetCmd( * Remaining words (the key path) can be handled normally. */ - for (i=2 ; i<parsePtr->numWords ; i++) { + for (i=2 ; i<(int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -1271,7 +1351,7 @@ TclCompileDictUnsetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr); + TclEmitInstInt4( INST_DICT_UNSET, (int)parsePtr->numWords-2, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; } @@ -1290,7 +1370,8 @@ TclCompileDictCreateCmd( Tcl_Token *tokenPtr; Tcl_Obj *keyObj, *valueObj, *dictObj; const char *bytes; - int i, len; + int i; + Tcl_Size len; if ((parsePtr->numWords & 1) == 0) { return TCL_ERROR; @@ -1303,7 +1384,7 @@ TclCompileDictCreateCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); TclNewObj(dictObj); Tcl_IncrRefCount(dictObj); - for (i=1 ; i<parsePtr->numWords ; i+=2) { + for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { TclNewObj(keyObj); Tcl_IncrRefCount(keyObj); if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) { @@ -1330,7 +1411,7 @@ TclCompileDictCreateCmd( * We did! Excellent. The "verifyDict" is to do type forcing. */ - bytes = TclGetStringFromObj(dictObj, &len); + bytes = Tcl_GetStringFromObj(dictObj, &len); PushLiteral(envPtr, bytes, len); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_DICT_VERIFY, envPtr); @@ -1353,7 +1434,7 @@ TclCompileDictCreateCmd( Emit14Inst( INST_STORE_SCALAR, worker, envPtr); TclEmitOpcode( INST_POP, envPtr); tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<parsePtr->numWords ; i+=2) { + for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i+1); @@ -1388,7 +1469,7 @@ TclCompileDictMergeCmd( */ /* TODO: Consider support for compiling expanded args. (less likely) */ - if (parsePtr->numWords < 2) { + if ((int)parsePtr->numWords < 2) { PushStringLiteral(envPtr, ""); return TCL_OK; } else if (parsePtr->numWords == 2) { @@ -1430,7 +1511,7 @@ TclCompileDictMergeCmd( outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); ExceptionRangeStarts(envPtr, outLoop); - for (i=2 ; i<parsePtr->numWords ; i++) { + for (i=2 ; i<(int)parsePtr->numWords ; i++) { /* * Get the dictionary, and merge its pairs into the first dict (using * a small loop). @@ -1525,7 +1606,8 @@ CompileDictEachCmd( Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; - int numVars, endTargetOffset; + Tcl_Size numVars; + int endTargetOffset; int collectVar = -1; /* Index of temp var holding the result * dict. */ const char **argv; @@ -1573,7 +1655,7 @@ CompileDictEachCmd( } Tcl_DStringFree(&buffer); if (numVars != 2) { - ckfree(argv); + Tcl_Free((void *)argv); return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1581,7 +1663,7 @@ CompileDictEachCmd( keyVarIndex = LocalScalar(argv[0], nameChars, envPtr); nameChars = strlen(argv[1]); valueVarIndex = LocalScalar(argv[1], nameChars, envPtr); - ckfree(argv); + Tcl_Free((void *)argv); if ((keyVarIndex < 0) || (valueVarIndex < 0)) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); @@ -1757,7 +1839,7 @@ TclCompileDictUpdateCmd( * There must be at least one argument after the command. */ - if (parsePtr->numWords < 5) { + if ((int)parsePtr->numWords < 5) { return TCL_ERROR; } @@ -1766,7 +1848,7 @@ TclCompileDictUpdateCmd( * dict update <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit> */ - if ((parsePtr->numWords - 1) & 1) { + if (((int)parsePtr->numWords - 1) & 1) { return TCL_ERROR; } numVars = (parsePtr->numWords - 3) / 2; @@ -1789,7 +1871,7 @@ TclCompileDictUpdateCmd( * that are to be used. */ - duiPtr = (DictUpdateInfo *)ckalloc(offsetof(DictUpdateInfo, varIndices) + sizeof(int) * numVars); + duiPtr = (DictUpdateInfo *)Tcl_Alloc(offsetof(DictUpdateInfo, varIndices) + sizeof(size_t) * numVars); duiPtr->length = numVars; keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); @@ -1808,7 +1890,7 @@ TclCompileDictUpdateCmd( */ duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr); - if (duiPtr->varIndices[i] < 0) { + if (duiPtr->varIndices[i] == TCL_INDEX_NONE) { goto failedUpdateInfoAssembly; } tokenPtr = TokenAfter(tokenPtr); @@ -1872,8 +1954,8 @@ TclCompileDictUpdateCmd( TclEmitInvoke(envPtr,INST_RETURN_STK); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", - (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d", + CurrentOffset(envPtr) - jumpFixup.codeOffset); } TclStackFree(interp, keyTokenPtrs); return TCL_OK; @@ -1883,7 +1965,7 @@ TclCompileDictUpdateCmd( */ failedUpdateInfoAssembly: - ckfree(duiPtr); + Tcl_Free(duiPtr); TclStackFree(interp, keyTokenPtrs); issueFallback: return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); @@ -1909,7 +1991,7 @@ TclCompileDictAppendCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords<4 || parsePtr->numWords>100) { + if ((int)parsePtr->numWords<4 || (int)parsePtr->numWords>100) { return TCL_ERROR; } @@ -1928,12 +2010,12 @@ TclCompileDictAppendCmd( */ tokenPtr = TokenAfter(tokenPtr); - for (i=2 ; i<parsePtr->numWords ; i++) { + for (i=2 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - if (parsePtr->numWords > 4) { - TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr); + if ((int)parsePtr->numWords > 4) { + TclEmitInstInt1(INST_STR_CONCAT1, (int)parsePtr->numWords-3, envPtr); } /* @@ -2010,7 +2092,7 @@ TclCompileDictWithCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } @@ -2021,7 +2103,7 @@ TclCompileDictWithCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(varTokenPtr); - for (i=3 ; i<parsePtr->numWords ; i++) { + for (i=3 ; i<(int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -2049,7 +2131,7 @@ TclCompileDictWithCmd( * Determine if we're manipulating a dict in a simple local variable. */ - gotPath = (parsePtr->numWords > 3); + gotPath = ((int)parsePtr->numWords > 3); dictVar = LocalScalarFromToken(varTokenPtr, envPtr); /* @@ -2068,11 +2150,11 @@ TclCompileDictWithCmd( */ tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i<parsePtr->numWords-1 ; i++) { + for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); + TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); @@ -2095,11 +2177,11 @@ TclCompileDictWithCmd( */ tokenPtr = varTokenPtr; - for (i=1 ; i<parsePtr->numWords-1 ; i++) { + for (i=1 ; i<(int)parsePtr->numWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); + TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); @@ -2150,11 +2232,11 @@ TclCompileDictWithCmd( } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { - for (i=2 ; i<parsePtr->numWords-1 ; i++) { + for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); + TclEmitInstInt4( INST_LIST, (int)parsePtr->numWords-3,envPtr); Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -2216,7 +2298,7 @@ TclCompileDictWithCmd( if (dictVar == -1) { Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); } - if (parsePtr->numWords > 3) { + if ((int)parsePtr->numWords > 3) { Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { PushStringLiteral(envPtr, ""); @@ -2234,8 +2316,8 @@ TclCompileDictWithCmd( */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", - (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d", + CurrentOffset(envPtr) - jumpFixup.codeOffset); } return TCL_OK; } @@ -2271,8 +2353,8 @@ DupDictUpdateInfo( size_t len; dui1Ptr = (DictUpdateInfo *)clientData; - len = offsetof(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length; - dui2Ptr = (DictUpdateInfo *)ckalloc(len); + len = offsetof(DictUpdateInfo, varIndices) + sizeof(size_t) * dui1Ptr->length; + dui2Ptr = (DictUpdateInfo *)Tcl_Alloc(len); memcpy(dui2Ptr, dui1Ptr, len); return dui2Ptr; } @@ -2281,7 +2363,7 @@ static void FreeDictUpdateInfo( void *clientData) { - ckfree(clientData); + Tcl_Free(clientData); } static void @@ -2289,16 +2371,16 @@ PrintDictUpdateInfo( void *clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData; - int i; + Tcl_Size i; for (i=0 ; i<duiPtr->length ; i++) { if (i) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]); + Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", duiPtr->varIndices[i]); } } @@ -2307,10 +2389,10 @@ DisassembleDictUpdateInfo( void *clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData; - int i; + Tcl_Size i; Tcl_Obj *variables; TclNewObj(variables); @@ -2355,7 +2437,7 @@ TclCompileErrorCmd( * General syntax: [error message ?errorInfo? ?errorCode?] */ - if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { + if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 4) { return TCL_ERROR; } @@ -2435,7 +2517,7 @@ TclCompileExprCmd( envPtr->extCmdMapPtr->nuloc-1].line[1]; firstWordPtr = TokenAfter(parsePtr->tokenPtr); - TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords-1, envPtr); + TclCompileExprWords(interp, firstWordPtr, (int)parsePtr->numWords-1, envPtr); return TCL_OK; } @@ -2685,7 +2767,8 @@ CompileEachloopCmd( Tcl_Token *tokenPtr, *bodyTokenPtr; int jumpBackOffset, infoIndex, range; - int numWords, numLists, i, j, code = TCL_OK; + int numWords, numLists, i, code = TCL_OK; + Tcl_Size j; Tcl_Obj *varListObj = NULL; /* @@ -2697,7 +2780,7 @@ CompileEachloopCmd( return TCL_ERROR; } - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; if ((numWords < 4) || (numWords%2 != 0)) { return TCL_ERROR; } @@ -2722,7 +2805,7 @@ CompileEachloopCmd( */ numLists = (numWords - 2)/2; - infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + numLists * sizeof(ForeachVarList *)); infoPtr->numLists = 0; /* Count this up as we go */ @@ -2737,7 +2820,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { ForeachVarList *varListPtr; - int numVars; + Tcl_Size numVars; if (i%2 != 1) { continue; @@ -2756,8 +2839,8 @@ CompileEachloopCmd( goto done; } - varListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes) - + numVars * sizeof(int)); + varListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + + numVars * sizeof(varListPtr->varIndexes[0])); varListPtr->numVars = numVars; infoPtr->varLists[i/2] = varListPtr; infoPtr->numLists++; @@ -2765,11 +2848,13 @@ CompileEachloopCmd( for (j = 0; j < numVars; j++) { Tcl_Obj *varNameObj; const char *bytes; - int numBytes, varIndex; + int varIndex; + Tcl_Size length; + Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); - bytes = TclGetStringFromObj(varNameObj, &numBytes); - varIndex = LocalScalar(bytes, numBytes, envPtr); + bytes = Tcl_GetStringFromObj(varNameObj, &length); + varIndex = LocalScalar(bytes, length, envPtr); if (varIndex < 0) { code = TCL_ERROR; goto done; @@ -2892,7 +2977,7 @@ DupForeachInfo( ForeachVarList *srcListPtr, *dupListPtr; int numVars, i, j, numLists = srcPtr->numLists; - dupPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + dupPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + numLists * sizeof(ForeachVarList *)); dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; @@ -2901,8 +2986,8 @@ DupForeachInfo( for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; numVars = srcListPtr->numVars; - dupListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes) - + numVars * sizeof(int)); + dupListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + + numVars * sizeof(size_t)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; @@ -2938,14 +3023,13 @@ FreeForeachInfo( { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *listPtr; - int numLists = infoPtr->numLists; - int i; + size_t i, numLists = infoPtr->numLists; for (i = 0; i < numLists; i++) { listPtr = infoPtr->varLists[i]; - ckfree(listPtr); + Tcl_Free(listPtr); } - ckfree(infoPtr); + Tcl_Free(infoPtr); } /* @@ -2970,11 +3054,11 @@ PrintForeachInfo( void *clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - int i, j; + Tcl_Size i, j; Tcl_AppendToObj(appendObj, "data=[", -1); @@ -2982,24 +3066,24 @@ PrintForeachInfo( if (i) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) (infoPtr->firstValueTemp + i)); + Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", + (infoPtr->firstValueTemp + i)); } - Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u", - (unsigned) infoPtr->loopCtTemp); + Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%" TCL_Z_MODIFIER "u", + infoPtr->loopCtTemp); for (i=0 ; i<infoPtr->numLists ; i++) { if (i) { Tcl_AppendToObj(appendObj, ",", -1); } - Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[", - (unsigned) (infoPtr->firstValueTemp + i)); + Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%" TCL_Z_MODIFIER "u\t[", + (infoPtr->firstValueTemp + i)); varsPtr = infoPtr->varLists[i]; for (j=0 ; j<varsPtr->numVars ; j++) { if (j) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) varsPtr->varIndexes[j]); + Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", + varsPtr->varIndexes[j]); } Tcl_AppendToObj(appendObj, "]", -1); } @@ -3010,13 +3094,13 @@ PrintNewForeachInfo( void *clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - int i, j; + Tcl_Size i, j; - Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=", + Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+" TCL_Z_MODIFIER "d, vars=", infoPtr->loopCtTemp); for (i=0 ; i<infoPtr->numLists ; i++) { if (i) { @@ -3028,8 +3112,8 @@ PrintNewForeachInfo( if (j) { Tcl_AppendToObj(appendObj, ",", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) varsPtr->varIndexes[j]); + Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", + varsPtr->varIndexes[j]); } Tcl_AppendToObj(appendObj, "]", -1); } @@ -3040,11 +3124,11 @@ DisassembleForeachInfo( void *clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - int i, j; + Tcl_Size i, j; Tcl_Obj *objPtr, *innerPtr; /* @@ -3087,11 +3171,11 @@ DisassembleNewForeachInfo( void *clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - int i, j; + Tcl_Size i, j; Tcl_Obj *objPtr, *innerPtr; /* @@ -3149,13 +3233,14 @@ TclCompileFormatCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; Tcl_Obj **objv, *formatObj, *tmpObj; const char *bytes, *start; - int i, j, len; + int i, j; + Tcl_Size len; /* * Don't handle any guaranteed-error cases. */ - if (parsePtr->numWords < 2) { + if ((int)parsePtr->numWords < 2) { return TCL_ERROR; } @@ -3172,8 +3257,8 @@ TclCompileFormatCmd( return TCL_ERROR; } - objv = (Tcl_Obj **)ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); - for (i=0 ; i+2 < parsePtr->numWords ; i++) { + objv = (Tcl_Obj **)Tcl_Alloc(((int)parsePtr->numWords-2) * sizeof(Tcl_Obj *)); + for (i=0 ; i+2 < (int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objv[i]); Tcl_IncrRefCount(objv[i]); @@ -3188,11 +3273,11 @@ TclCompileFormatCmd( */ tmpObj = Tcl_Format(interp, TclGetString(formatObj), - parsePtr->numWords-2, objv); + (int)parsePtr->numWords-2, objv); for (; --i>=0 ;) { Tcl_DecrRefCount(objv[i]); } - ckfree(objv); + Tcl_Free(objv); Tcl_DecrRefCount(formatObj); if (tmpObj == NULL) { TclCompileSyntaxError(interp, envPtr); @@ -3204,7 +3289,7 @@ TclCompileFormatCmd( * literal. Job done. */ - bytes = TclGetStringFromObj(tmpObj, &len); + bytes = Tcl_GetStringFromObj(tmpObj, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(tmpObj); return TCL_OK; @@ -3222,7 +3307,7 @@ TclCompileFormatCmd( for (; i>=0 ; i--) { Tcl_DecrRefCount(objv[i]); } - ckfree(objv); + Tcl_Free(objv); tokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(tokenPtr); i = 0; @@ -3249,7 +3334,7 @@ TclCompileFormatCmd( * Check if the number of things to concatenate will fit in a byte. */ - if (i+2 != parsePtr->numWords || i > 125) { + if (i+2 != (int)parsePtr->numWords || i > 125) { Tcl_DecrRefCount(formatObj); return TCL_ERROR; } @@ -3275,7 +3360,7 @@ TclCompileFormatCmd( if (*++bytes == '%') { Tcl_AppendToObj(tmpObj, "%", 1); } else { - const char *b = TclGetStringFromObj(tmpObj, &len); + const char *b = Tcl_GetStringFromObj(tmpObj, &len); /* * If there is a non-empty literal from the format string, @@ -3309,7 +3394,7 @@ TclCompileFormatCmd( */ Tcl_AppendToObj(tmpObj, start, bytes - start); - bytes = TclGetStringFromObj(tmpObj, &len); + bytes = Tcl_GetStringFromObj(tmpObj, &len); if (len > 0) { PushLiteral(envPtr, bytes, len); i++; @@ -3339,7 +3424,7 @@ TclCompileFormatCmd( * Returns the non-negative integer index value into the table of * compiled locals corresponding to a local scalar variable name. * If the arguments passed in do not identify a local scalar variable - * then return -1. + * then return TCL_INDEX_NONE. * * Side effects: * May add an entry into the table of compiled locals. @@ -3347,13 +3432,12 @@ TclCompileFormatCmd( *---------------------------------------------------------------------- */ -Tcl_Size +size_t TclLocalScalarFromToken( Tcl_Token *tokenPtr, CompileEnv *envPtr) { - int isScalar; - Tcl_Size index; + int isScalar, index; TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar); if (!isScalar) { @@ -3362,10 +3446,10 @@ TclLocalScalarFromToken( return index; } -Tcl_Size +size_t TclLocalScalar( const char *bytes, - TCL_HASH_TYPE numBytes, + size_t numBytes, CompileEnv *envPtr) { Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, @@ -3416,9 +3500,10 @@ TclPushVarName( { const char *p; const char *last, *name, *elName; - int n; + size_t n; Tcl_Token *elemTokenPtr = NULL; - int nameLen, elNameLen, simpleVarName, localIndex; + size_t nameLen, elNameLen; + int simpleVarName, localIndex; int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; /* @@ -3493,7 +3578,7 @@ TclPushVarName( } } if (simpleVarName) { - int remainingLen; + size_t remainingLen; /* * Check the last token: if it is just ')', do not count it. diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index ea1e42d..f35cd50 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -49,8 +49,8 @@ static int IndexTailVarIfKnown(Tcl_Interp *interp, int TclGetIndexFromToken( Tcl_Token *tokenPtr, - Tcl_Size before, - Tcl_Size after, + size_t before, + size_t after, int *indexPtr) { Tcl_Obj *tmpObj; @@ -181,7 +181,7 @@ TclCompileIfCmd( * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; int jumpIndex = 0; /* Avoid compiler warning. */ - int numBytes, j; + size_t numBytes, j; int jumpFalseDist, numWords, wordIdx, code; const char *word; int realCond = 1; /* Set to 0 for static conditions: @@ -498,7 +498,7 @@ TclCompileIncrCmd( incrTokenPtr = TokenAfter(varTokenPtr); if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { const char *word = incrTokenPtr[1].start; - int numBytes = incrTokenPtr[1].size; + size_t numBytes = incrTokenPtr[1].size; int code; Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); @@ -1359,7 +1359,7 @@ TclCompileLinsertCmd( Tcl_Token *tokenPtr; int i; - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1370,7 +1370,7 @@ TclCompileLinsertCmd( CompileWord(envPtr, tokenPtr, interp, 2); /* Push new elements to be inserted */ - for (i=3 ; i<parsePtr->numWords ; i++) { + for (i=3 ; i<(int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -1424,7 +1424,7 @@ TclCompileLreplaceCmd( CompileWord(envPtr, tokenPtr, interp, 3); /* Push new elements to be inserted */ - for (i=4 ; i<parsePtr->numWords ; i++) { + for (i=4 ; i< (int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -1502,7 +1502,7 @@ TclCompileLsetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { /* * Fail at run time, not in compilation. */ @@ -1526,7 +1526,7 @@ TclCompileLsetCmd( * Push the "index" args and the new element value. */ - for (i=2 ; i<parsePtr->numWords ; ++i) { + for (i=2 ; i<(int)parsePtr->numWords ; ++i) { varTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, varTokenPtr, interp, i); } @@ -1811,7 +1811,7 @@ TclCompileNamespaceUpvarCmd( * Only compile [namespace upvar ...]: needs an even number of args, >=4 */ - numWords = parsePtr->numWords; + numWords = (int)parsePtr->numWords; if ((numWords % 2) || (numWords < 4)) { return TCL_ERROR; } @@ -1863,7 +1863,7 @@ TclCompileNamespaceWhichCmd( Tcl_Token *tokenPtr, *opt; int idx; - if (parsePtr->numWords < 2 || parsePtr->numWords > 3) { + if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1925,7 +1925,7 @@ TclCompileRegexpCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the RE or string. */ - int len; + size_t len; int i, nocase, exact, sawLast, simple; const char *str; @@ -1936,7 +1936,7 @@ TclCompileRegexpCmd( * regexp ?-nocase? ?--? {^staticString$} $var */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1951,7 +1951,7 @@ TclCompileRegexpCmd( * handling, but satisfies our stricter needs. */ - for (i = 1; i < parsePtr->numWords - 2; i++) { + for (i = 1; i < (int)parsePtr->numWords - 2; i++) { varTokenPtr = TokenAfter(varTokenPtr); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* @@ -1977,7 +1977,7 @@ TclCompileRegexpCmd( } } - if ((parsePtr->numWords - i) != 2) { + if (((int)parsePtr->numWords - i) != 2) { /* * We don't support capturing to variables. */ @@ -2030,7 +2030,7 @@ TclCompileRegexpCmd( } if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2); + CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 2); } /* @@ -2038,7 +2038,7 @@ TclCompileRegexpCmd( */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1); + CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 1); if (simple) { if (exact && !nocase) { @@ -2115,7 +2115,7 @@ TclCompileRegsubCmd( int exact, quantified, result = TCL_ERROR; Tcl_Size len; - if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { + if ((int)parsePtr->numWords < 5 || (int)parsePtr->numWords > 6) { return TCL_ERROR; } @@ -2172,7 +2172,7 @@ TclCompileRegsubCmd( * replacement "simple"? */ - bytes = TclGetStringFromObj(patternObj, &len); + bytes = Tcl_GetStringFromObj(patternObj, &len); if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified) != TCL_OK || exact || quantified) { goto done; @@ -2191,7 +2191,7 @@ TclCompileRegsubCmd( */ len = Tcl_DStringLength(&pattern) - 2; - if (len > 0) { + if (len + 2 > 2) { goto isSimpleGlob; } @@ -2220,9 +2220,9 @@ TclCompileRegsubCmd( result = TCL_OK; bytes = Tcl_DStringValue(&pattern) + 1; PushLiteral(envPtr, bytes, len); - bytes = TclGetStringFromObj(replacementObj, &len); + bytes = Tcl_GetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2); + CompileWord(envPtr, stringTokenPtr, interp, (int)parsePtr->numWords - 2); TclEmitOpcode( INST_STR_MAP, envPtr); done: @@ -2267,11 +2267,11 @@ TclCompileReturnCmd( * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ - int level, code, status = TCL_OK; + int level, code, objc, status = TCL_OK; Tcl_Size size; - Tcl_Size numWords = parsePtr->numWords; - Tcl_Size explicitResult = (0 == (numWords % 2)); - Tcl_Size objc, numOptionWords = numWords - 1 - explicitResult; + int numWords = parsePtr->numWords; + int explicitResult = (0 == (numWords % 2)); + int numOptionWords = numWords - 1 - explicitResult; Tcl_Obj *returnOpts, **objv; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -2479,7 +2479,7 @@ TclCompileSyntaxError( { Tcl_Obj *msg = Tcl_GetObjResult(interp); Tcl_Size numBytes; - const char *bytes = TclGetStringFromObj(msg, &numBytes); + const char *bytes = Tcl_GetStringFromObj(msg, &numBytes); TclErrorStackResetIf(interp, bytes, numBytes); TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr); @@ -2737,7 +2737,7 @@ IndexTailVarIfKnown( Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size); } - tailName = TclGetStringFromObj(tailPtr, &len); + tailName = Tcl_GetStringFromObj(tailPtr, &len); if (len) { if (*(tailName + len - 1) == ')') { @@ -2798,11 +2798,11 @@ TclCompileObjectNextCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; - if (parsePtr->numWords > 255) { + if ((int)parsePtr->numWords > 255) { return TCL_ERROR; } - for (i=0 ; i<parsePtr->numWords ; i++) { + for (i=0 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -2822,11 +2822,11 @@ TclCompileObjectNextToCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; - if (parsePtr->numWords < 2 || parsePtr->numWords > 255) { + if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 255) { return TCL_ERROR; } - for (i=0 ; i<parsePtr->numWords ; i++) { + for (i=0 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 5d190a1..0a21226 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -41,12 +41,12 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp, CompileEnv *envPtr); static void IssueSwitchChainedTests(Tcl_Interp *interp, CompileEnv *envPtr, int mode, int noCase, - int numWords, Tcl_Token **bodyToken, - int *bodyLines, int **bodyNext); + Tcl_Size numWords, Tcl_Token **bodyToken, + Tcl_Size *bodyLines, Tcl_Size **bodyNext); static void IssueSwitchJumpTable(Tcl_Interp *interp, CompileEnv *envPtr, int numWords, - Tcl_Token **bodyToken, int *bodyLines, - int **bodyContLines); + Tcl_Token **bodyToken, Tcl_Size *bodyLines, + Tcl_Size **bodyContLines); static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, @@ -252,8 +252,8 @@ TclCompileStringCatCmd( } else { Tcl_DecrRefCount(obj); if (folded) { - int len; - const char *bytes = TclGetStringFromObj(folded, &len); + Tcl_Size len; + const char *bytes = Tcl_GetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); @@ -270,8 +270,8 @@ TclCompileStringCatCmd( wordTokenPtr = TokenAfter(wordTokenPtr); } if (folded) { - int len; - const char *bytes = TclGetStringFromObj(folded, &len); + Tcl_Size len; + const char *bytes = Tcl_GetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); @@ -518,8 +518,8 @@ TclCompileStringIsCmd( STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_UNICODE, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT - }; - int t, range, allowEmpty = 0, end; + } t; + int range, allowEmpty = 0, end; InstStringClassType strClassType; Tcl_Obj *isClass; @@ -573,9 +573,9 @@ TclCompileStringIsCmd( * 5. Lists */ - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + CompileWord(envPtr, tokenPtr, interp, (int)parsePtr->numWords-1); - switch ((enum isClassesEnum) t) { + switch (t) { case STR_IS_ALNUM: strClassType = STR_CLASS_ALNUM; goto compileStrClass; @@ -683,6 +683,8 @@ TclCompileStringIsCmd( FIXJUMP1( over); OP( LNOT); return TCL_OK; + default: + break; } break; @@ -748,6 +750,8 @@ TclCompileStringIsCmd( PUSH( "3"); OP( LE); break; + default: + break; } FIXJUMP1( end); return TCL_OK; @@ -794,7 +798,8 @@ TclCompileStringMatchCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, length, exactMatch = 0, nocase = 0; + size_t length; + int i, exactMatch = 0, nocase = 0; const char *str; if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { @@ -890,9 +895,9 @@ TclCompileStringLenCmd( */ char buf[TCL_INTEGER_SPACE]; - int len = TclGetCharLength(objPtr); + size_t len = Tcl_GetCharLength(objPtr); - len = snprintf(buf, sizeof(buf), "%d", len); + len = snprintf(buf, sizeof(buf), "%" TCL_Z_MODIFIER "u", len); PushLiteral(envPtr, buf, len); } else { SetLineInformation(1); @@ -916,7 +921,7 @@ TclCompileStringMapCmd( Tcl_Token *mapTokenPtr, *stringTokenPtr; Tcl_Obj *mapObj, **objv; const char *bytes; - int len; + Tcl_Size len, slen; /* * We only handle the case: @@ -952,13 +957,13 @@ TclCompileStringMapCmd( * correct semantics for mapping. */ - bytes = TclGetStringFromObj(objv[0], &len); - if (len == 0) { + bytes = Tcl_GetStringFromObj(objv[0], &slen); + if (slen == 0) { CompileWord(envPtr, stringTokenPtr, interp, 2); } else { - PushLiteral(envPtr, bytes, len); - bytes = TclGetStringFromObj(objv[1], &len); - PushLiteral(envPtr, bytes, len); + PushLiteral(envPtr, bytes, slen); + bytes = Tcl_GetStringFromObj(objv[1], &slen); + PushLiteral(envPtr, bytes, slen); CompileWord(envPtr, stringTokenPtr, interp, 2); OP(STR_MAP); } @@ -1053,7 +1058,7 @@ TclCompileStringReplaceCmd( Tcl_Token *tokenPtr, *valueTokenPtr; int first, last; - if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { + if ((int)parsePtr->numWords < 4 || (int)parsePtr->numWords > 5) { return TCL_ERROR; } @@ -1512,13 +1517,14 @@ void TclSubstCompile( Tcl_Interp *interp, const char *bytes, - int numBytes, + Tcl_Size numBytes, int flags, - int line, + Tcl_Size line, CompileEnv *envPtr) { Tcl_Token *endTokenPtr, *tokenPtr; - int breakOffset = 0, count = 0, bline = line; + int breakOffset = 0, count = 0; + Tcl_Size bline = line; Tcl_Parse parse; Tcl_InterpState state = NULL; @@ -1543,7 +1549,8 @@ TclSubstCompile( for (endTokenPtr = tokenPtr + parse.numTokens; tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { - int length, literal, catchRange, breakJump; + Tcl_Size length; + int literal, catchRange, breakJump; char buf[4] = ""; JumpFixup startFixup, okFixup, returnFixup, breakFixup; JumpFixup continueFixup, otherFixup, endFixup; @@ -1574,7 +1581,8 @@ TclSubstCompile( */ if (tokenPtr->numComponents > 1) { - int i, foundCommand = 0; + Tcl_Size i; + int foundCommand = 0; for (i=2 ; i<=tokenPtr->numComponents ; i++) { if (tokenPtr[i].type == TCL_TOKEN_COMMAND) { @@ -1613,8 +1621,8 @@ TclSubstCompile( /* Start */ if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d", - (int) (CurrentOffset(envPtr) - startFixup.codeOffset)); + Tcl_Panic("TclCompileSubstCmd: bad start jump distance %" TCL_Z_MODIFIER "d", + CurrentOffset(envPtr) - startFixup.codeOffset); } } @@ -1672,8 +1680,8 @@ TclSubstCompile( TclAdjustStackDepth(1, envPtr); /* BREAK destination */ if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", - (int) (CurrentOffset(envPtr) - breakFixup.codeOffset)); + Tcl_Panic("TclCompileSubstCmd: bad break jump distance %" TCL_Z_MODIFIER "d", + CurrentOffset(envPtr) - breakFixup.codeOffset); } OP( POP); OP( POP); @@ -1688,8 +1696,8 @@ TclSubstCompile( TclAdjustStackDepth(2, envPtr); /* CONTINUE destination */ if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", - (int) (CurrentOffset(envPtr) - continueFixup.codeOffset)); + Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %" TCL_Z_MODIFIER "d", + CurrentOffset(envPtr) - continueFixup.codeOffset); } OP( POP); OP( POP); @@ -1698,12 +1706,12 @@ TclSubstCompile( TclAdjustStackDepth(2, envPtr); /* RETURN + other destination */ if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", - (int) (CurrentOffset(envPtr) - returnFixup.codeOffset)); + Tcl_Panic("TclCompileSubstCmd: bad return jump distance %" TCL_Z_MODIFIER "d", + CurrentOffset(envPtr) - returnFixup.codeOffset); } if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d", - (int) (CurrentOffset(envPtr) - otherFixup.codeOffset)); + Tcl_Panic("TclCompileSubstCmd: bad other jump distance %" TCL_Z_MODIFIER "d", + CurrentOffset(envPtr) - otherFixup.codeOffset); } /* @@ -1715,8 +1723,8 @@ TclSubstCompile( /* OK destination */ if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", - (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); + Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %" TCL_Z_MODIFIER "d", + CurrentOffset(envPtr) - okFixup.codeOffset); } if (count > 1) { OP1(STR_CONCAT1, count); @@ -1725,8 +1733,8 @@ TclSubstCompile( /* CONTINUE jump to here */ if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d", - (int) (CurrentOffset(envPtr) - endFixup.codeOffset)); + Tcl_Panic("TclCompileSubstCmd: bad end jump distance %" TCL_Z_MODIFIER "d", + CurrentOffset(envPtr) - endFixup.codeOffset); } bline = envPtr->line; } @@ -1792,14 +1800,14 @@ TclCompileSwitchCmd( Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ - int *bodyLines; /* Array of line numbers for body list + Tcl_Size *bodyLines; /* Array of line numbers for body list * items. */ - int **bodyContLines; /* Array of continuation line info. */ + Tcl_Size **bodyContLines; /* Array of continuation line info. */ int noCase; /* Has the -nocase flag been given? */ int foundMode = 0; /* Have we seen a mode flag yet? */ int i, valueIndex; int result = TCL_ERROR; - int *clNext = envPtr->clNext; + Tcl_Size *clNext = envPtr->clNext; /* * Only handle the following versions: @@ -1846,7 +1854,7 @@ TclCompileSwitchCmd( */ for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) { - unsigned size = tokenPtr[1].size; + size_t size = tokenPtr[1].size; const char *chrs = tokenPtr[1].start; /* @@ -1937,8 +1945,8 @@ TclCompileSwitchCmd( if (numWords == 1) { const char *bytes; - int maxLen, numBytes; - int bline; /* TIP #280: line of the pattern/action list, + Tcl_Size maxLen, numBytes; + Tcl_Size bline; /* TIP #280: line of the pattern/action list, * and start of list for when tracking the * location. This list comes immediately after * the value we switch on. */ @@ -1954,10 +1962,10 @@ TclCompileSwitchCmd( if (maxLen < 2) { return TCL_ERROR; } - bodyTokenArray = (Tcl_Token *)ckalloc(sizeof(Tcl_Token) * maxLen); - bodyToken = (Tcl_Token **)ckalloc(sizeof(Tcl_Token *) * maxLen); - bodyLines = (int *)ckalloc(sizeof(int) * maxLen); - bodyContLines = (int **)ckalloc(sizeof(int*) * maxLen); + bodyTokenArray = (Tcl_Token *)Tcl_Alloc(sizeof(Tcl_Token) * maxLen); + bodyToken = (Tcl_Token **)Tcl_Alloc(sizeof(Tcl_Token *) * maxLen); + bodyLines = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size) * maxLen); + bodyContLines = (Tcl_Size **)Tcl_Alloc(sizeof(Tcl_Size*) * maxLen); bline = mapPtr->loc[eclIndex].line[valueIndex+1]; numWords = 0; @@ -1995,10 +2003,10 @@ TclCompileSwitchCmd( } if (numWords % 2) { abort: - ckfree(bodyToken); - ckfree(bodyTokenArray); - ckfree(bodyLines); - ckfree(bodyContLines); + Tcl_Free(bodyToken); + Tcl_Free(bodyTokenArray); + Tcl_Free(bodyLines); + Tcl_Free(bodyContLines); return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { @@ -2016,9 +2024,9 @@ TclCompileSwitchCmd( * Multi-word definition of patterns & actions. */ - bodyToken = (Tcl_Token **)ckalloc(sizeof(Tcl_Token *) * numWords); - bodyLines = (int *)ckalloc(sizeof(int) * numWords); - bodyContLines = (int **)ckalloc(sizeof(int*) * numWords); + bodyToken = (Tcl_Token **)Tcl_Alloc(sizeof(Tcl_Token *) * numWords); + bodyLines = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size) * numWords); + bodyContLines = (Tcl_Size **)Tcl_Alloc(sizeof(Tcl_Size*) * numWords); bodyTokenArray = NULL; for (i=0 ; i<numWords ; i++) { /* @@ -2077,11 +2085,11 @@ TclCompileSwitchCmd( */ freeTemporaries: - ckfree(bodyToken); - ckfree(bodyLines); - ckfree(bodyContLines); + Tcl_Free(bodyToken); + Tcl_Free(bodyLines); + Tcl_Free(bodyContLines); if (bodyTokenArray != NULL) { - ckfree(bodyTokenArray); + Tcl_Free(bodyTokenArray); } return result; } @@ -2108,13 +2116,13 @@ IssueSwitchChainedTests( CompileEnv *envPtr, /* Holds resulting instructions. */ int mode, /* Exact, Glob or Regexp */ int noCase, /* Case-insensitivity flag. */ - int numBodyTokens, /* Number of tokens describing things the + Tcl_Size numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ - int *bodyLines, /* Array of line numbers for body list + Tcl_Size *bodyLines, /* Array of line numbers for body list * items. */ - int **bodyContLines) /* Array of continuation line info. */ + Tcl_Size **bodyContLines) /* Array of continuation line info. */ { enum {Switch_Exact, Switch_Glob, Switch_Regexp}; int foundDefault; /* Flag to indicate whether a "default" clause @@ -2360,9 +2368,9 @@ IssueSwitchJumpTable( * switch can match against and bodies to * execute when the match succeeds. */ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ - int *bodyLines, /* Array of line numbers for body list + Tcl_Size *bodyLines, /* Array of line numbers for body list * items. */ - int **bodyContLines) /* Array of continuation line info. */ + Tcl_Size **bodyContLines) /* Array of continuation line info. */ { JumptableInfo *jtPtr; int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; @@ -2380,7 +2388,7 @@ IssueSwitchJumpTable( * Start by allocating the jump table itself, plus some workspace. */ - jtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo)); + jtPtr = (JumptableInfo *)Tcl_Alloc(sizeof(JumptableInfo)); Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); finalFixups = (int *)TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2)); @@ -2552,7 +2560,7 @@ DupJumptableInfo( void *clientData) { JumptableInfo *jtPtr = (JumptableInfo *)clientData; - JumptableInfo *newJtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo)); + JumptableInfo *newJtPtr = (JumptableInfo *)Tcl_Alloc(sizeof(JumptableInfo)); Tcl_HashEntry *hPtr, *newHPtr; Tcl_HashSearch search; int isNew; @@ -2574,7 +2582,7 @@ FreeJumptableInfo( JumptableInfo *jtPtr = (JumptableInfo *)clientData; Tcl_DeleteHashTable(&jtPtr->hashTable); - ckfree(jtPtr); + Tcl_Free(jtPtr); } static void @@ -2582,13 +2590,13 @@ PrintJumptableInfo( void *clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - unsigned int pcOffset) + size_t pcOffset) { JumptableInfo *jtPtr = (JumptableInfo *)clientData; Tcl_HashEntry *hPtr; Tcl_HashSearch search; const char *keyPtr; - int offset, i = 0; + size_t offset, i = 0; hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { @@ -2601,7 +2609,7 @@ PrintJumptableInfo( Tcl_AppendToObj(appendObj, "\n\t\t", -1); } } - Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d", + Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %" TCL_Z_MODIFIER "u", keyPtr, pcOffset + offset); } } @@ -2611,7 +2619,7 @@ DisassembleJumptableInfo( void *clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + TCL_UNUSED(size_t)) { JumptableInfo *jtPtr = (JumptableInfo *)clientData; Tcl_Obj *mapping; @@ -2669,11 +2677,11 @@ TclCompileTailcallCmd( /* make room for the nsObjPtr */ /* TODO: Doesn't this have to be a known value? */ CompileWord(envPtr, tokenPtr, interp, 0); - for (i=1 ; i<parsePtr->numWords ; i++) { + for (i=1 ; i<(int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr); + TclEmitInstInt1( INST_TAILCALL, (int)parsePtr->numWords, envPtr); return TCL_OK; } @@ -2707,7 +2715,8 @@ TclCompileThrowCmd( int numWords = parsePtr->numWords; Tcl_Token *codeToken, *msgToken; Tcl_Obj *objPtr; - int codeKnown, codeIsList, codeIsValid, len; + int codeKnown, codeIsList, codeIsValid; + Tcl_Size len; if (numWords != 3) { return TCL_ERROR; @@ -2848,7 +2857,7 @@ TclCompileTryCmd( for (i=0 ; i<numHandlers ; i++) { Tcl_Obj *tmpObj, **objv; - int objc; + Tcl_Size objc; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { goto failedToCompile; @@ -2913,8 +2922,8 @@ TclCompileTryCmd( goto failedToCompile; } if (objc > 0) { - int len; - const char *varname = TclGetStringFromObj(objv[0], &len); + Tcl_Size len; + const char *varname = Tcl_GetStringFromObj(objv[0], &len); resultVarIndices[i] = LocalScalar(varname, len, envPtr); if (resultVarIndices[i] < 0) { @@ -2925,8 +2934,8 @@ TclCompileTryCmd( resultVarIndices[i] = -1; } if (objc == 2) { - int len; - const char *varname = TclGetStringFromObj(objv[1], &len); + Tcl_Size len; + const char *varname = Tcl_GetStringFromObj(objv[1], &len); optionVarIndices[i] = LocalScalar(varname, len, envPtr); if (optionVarIndices[i] < 0) { @@ -3046,7 +3055,8 @@ IssueTryClausesInstructions( { DefineLineInformation; /* TIP #280 */ int range, resultVar, optionsVar; - int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; + int i, j, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; + Tcl_Size slen, len; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; int *noError; char buf[TCL_INTEGER_SPACE]; @@ -3132,8 +3142,8 @@ IssueTryClausesInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = TclGetStringFromObj(matchClauses[i], &len); - PushLiteral(envPtr, p, len); + p = Tcl_GetStringFromObj(matchClauses[i], &slen); + PushLiteral(envPtr, p, slen); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); } else { @@ -3256,10 +3266,11 @@ IssueTryClausesFinallyInstructions( Tcl_Token *finallyToken) /* Not NULL */ { DefineLineInformation; /* TIP #280 */ - int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0; + int range, resultVar, optionsVar, i, j, forwardsNeedFixing = 0; int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; + Tcl_Size slen, len; resultVar = AnonymousLocal(envPtr); optionsVar = AnonymousLocal(envPtr); @@ -3343,8 +3354,8 @@ IssueTryClausesFinallyInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = TclGetStringFromObj(matchClauses[i], &len); - PushLiteral(envPtr, p, len); + p = Tcl_GetStringFromObj(matchClauses[i], &slen); + PushLiteral(envPtr, p, slen); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); } else { @@ -3630,7 +3641,7 @@ TclCompileUnsetCmd( * push/rotate. [Bug 3970f54c4e] */ - for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) { + for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<(int)parsePtr->numWords ; i++) { Tcl_Obj *leadingWord; TclNewObj(leadingWord); @@ -3669,9 +3680,9 @@ TclCompileUnsetCmd( } if (varCount == 0) { const char *bytes; - int len; + Tcl_Size len; - bytes = TclGetStringFromObj(leadingWord, &len); + bytes = Tcl_GetStringFromObj(leadingWord, &len); if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; haveFlags++; @@ -3694,7 +3705,7 @@ TclCompileUnsetCmd( for (i=0; i<haveFlags;i++) { varTokenPtr = TokenAfter(varTokenPtr); } - for (i=1+haveFlags ; i<parsePtr->numWords ; i++) { + for (i=1+haveFlags ; i<(int)parsePtr->numWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a @@ -3979,12 +3990,12 @@ TclCompileYieldToCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int i; - if (parsePtr->numWords < 2) { + if ((int)parsePtr->numWords < 2) { return TCL_ERROR; } OP( NS_CURRENT); - for (i = 1 ; i < parsePtr->numWords ; i++) { + for (i = 1 ; i < (int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -4062,7 +4073,7 @@ CompileAssociativeBinaryOpCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int words; + Tcl_Size words; /* TODO: Consider support for compiling expanded args. */ for (words=1 ; words<parsePtr->numWords ; words++) { @@ -4149,7 +4160,7 @@ CompileComparisonOpCmd( Tcl_Token *tokenPtr; /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { PUSH("1"); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -4165,7 +4176,7 @@ CompileComparisonOpCmd( return TCL_ERROR; } else { int tmpIndex = AnonymousLocal(envPtr); - int words; + Tcl_Size words; tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); @@ -4301,7 +4312,7 @@ TclCompilePowOpCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int words; + Tcl_Size words; /* * This one has its own implementation because the ** operator is the only @@ -4502,7 +4513,7 @@ TclCompileMinusOpCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int words; + Tcl_Size words; /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { @@ -4547,7 +4558,7 @@ TclCompileDivOpCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int words; + Tcl_Size words; /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index e97c552..41b8b65 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -22,7 +22,7 @@ * The tree is composed of OpNodes. */ -typedef struct OpNode { +typedef struct { int left; /* "Pointer" to the left operand. */ int right; /* "Pointer" to the right operand. */ union { @@ -511,16 +511,16 @@ static void CompileExprTree(Tcl_Interp *interp, OpNode *nodes, int index, Tcl_Obj *const **litObjvPtr, Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr, CompileEnv *envPtr, int optimize); -static void ConvertTreeToTokens(const char *start, int numBytes, +static void ConvertTreeToTokens(const char *start, Tcl_Size numBytes, OpNode *nodes, Tcl_Token *tokenPtr, Tcl_Parse *parsePtr); static int ExecConstantExprTree(Tcl_Interp *interp, OpNode *nodes, int index, Tcl_Obj * const **litObjvPtr); static int ParseExpr(Tcl_Interp *interp, const char *start, - int numBytes, OpNode **opTreePtr, + Tcl_Size numBytes, OpNode **opTreePtr, Tcl_Obj *litList, Tcl_Obj *funcList, Tcl_Parse *parsePtr, int parseOnly); -static int ParseLexeme(const char *start, int numBytes, +static Tcl_Size ParseLexeme(const char *start, Tcl_Size numBytes, unsigned char *lexemePtr, Tcl_Obj **literalPtr); /* @@ -546,7 +546,7 @@ static int ParseLexeme(const char *start, int numBytes, * Side effects: * Memory will be allocated. If TCL_OK is returned, the caller must clean * up the returned data structures. The (OpNode *) value written to - * opTreePtr should be passed to ckfree() and the parsePtr argument + * opTreePtr should be passed to Tcl_Free() and the parsePtr argument * should be passed to Tcl_FreeParse(). The elements appended to the * litList and funcList will automatically be freed whenever the refcount * on those lists indicates they can be freed. @@ -558,7 +558,7 @@ static int ParseExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *start, /* Start of source string to parse. */ - int numBytes, /* Number of bytes in string. */ + Tcl_Size numBytes, /* Number of bytes in string. */ OpNode **opTreePtr, /* Points to space where a pointer to the * allocated OpNode tree should go. */ Tcl_Obj *litList, /* List to append literals to. */ @@ -581,7 +581,7 @@ ParseExpr( * no need for array growth and * reallocation. */ unsigned int nodesUsed = 0; /* Number of OpNodes filled. */ - int scanned = 0; /* Capture number of byte scanned by parsing + Tcl_Size scanned = 0; /* Capture number of byte scanned by parsing * routines. */ int lastParsed; /* Stores info about what the lexeme parsed * the previous pass through the parsing loop @@ -633,7 +633,7 @@ ParseExpr( TclParseInit(interp, start, numBytes, parsePtr); - nodes = (OpNode *)attemptckalloc(nodesAvailable * sizeof(OpNode)); + nodes = (OpNode *)Tcl_AttemptAlloc(nodesAvailable * sizeof(OpNode)); if (nodes == NULL) { TclNewLiteralStringObj(msg, "not enough memory to parse expression"); errCode = "NOMEM"; @@ -677,7 +677,7 @@ ParseExpr( do { if (size <= UINT_MAX/sizeof(OpNode)) { - newPtr = (OpNode *) attemptckrealloc(nodes, + newPtr = (OpNode *) Tcl_AttemptRealloc(nodes, size * sizeof(OpNode)); } } while ((newPtr == NULL) @@ -717,12 +717,12 @@ ParseExpr( continue; case INVALID: msg = Tcl_ObjPrintf("invalid character \"%.*s\"", - scanned, start); + (int)scanned, start); errCode = "BADCHAR"; goto error; case INCOMPLETE: msg = Tcl_ObjPrintf("incomplete operator \"%.*s\"", - scanned, start); + (int)scanned, start); errCode = "PARTOP"; goto error; case BAREWORD: @@ -777,16 +777,16 @@ ParseExpr( Tcl_DecrRefCount(literal); msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"", - (scanned < limit) ? scanned : limit - 3, start, + (int)((scanned < limit) ? scanned : limit - 3), start, (scanned < limit) ? "" : "..."); post = Tcl_ObjPrintf( "should be \"$%.*s%s\" or \"{%.*s%s}\"", - (scanned < limit) ? scanned : limit - 3, + (int) ((scanned < limit) ? scanned : limit - 3), start, (scanned < limit) ? "" : "...", - (scanned < limit) ? scanned : limit - 3, + (int) ((scanned < limit) ? scanned : limit - 3), start, (scanned < limit) ? "" : "..."); Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...", - (scanned < limit) ? scanned : limit - 3, + (int) ((scanned < limit) ? scanned : limit - 3), start, (scanned < limit) ? "" : "..."); errCode = "BAREWORD"; if (start[0] == '0') { @@ -1418,7 +1418,7 @@ ParseExpr( */ if (nodes != NULL) { - ckfree(nodes); + Tcl_Free(nodes); } if (interp == NULL) { @@ -1447,13 +1447,13 @@ ParseExpr( Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < parsePtr->string) ? "" : "...", ((start - limit) < parsePtr->string) - ? (int) (start - parsePtr->string) : limit - 3, + ? (int) (start - parsePtr->string) : (int)limit - 3, ((start - limit) < parsePtr->string) ? parsePtr->string : start - limit + 3, - (scanned < limit) ? scanned : limit - 3, start, + (scanned < limit) ? (int)scanned : (int)limit - 3, start, (scanned < limit) ? "" : "...", insertMark ? mark : "", (start + scanned + limit > parsePtr->end) - ? (int) (parsePtr->end - start) - scanned : limit-3, + ? (int) (parsePtr->end - start) - (int)scanned : (int)limit-3, start + scanned, (start + scanned + limit > parsePtr->end) ? "" : "..."); @@ -1475,7 +1475,7 @@ ParseExpr( numBytes = parsePtr->end - parsePtr->string; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (parsing expression \"%.*s%s\")", - (numBytes < limit) ? numBytes : limit - 3, + (numBytes < limit) ? (int)numBytes : (int)limit - 3, parsePtr->string, (numBytes < limit) ? "" : "...")); if (errCode) { Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode, @@ -1512,7 +1512,7 @@ ParseExpr( static void ConvertTreeToTokens( const char *start, - int numBytes, + Tcl_Size numBytes, OpNode *nodes, Tcl_Token *tokenPtr, Tcl_Parse *parsePtr) @@ -1601,7 +1601,7 @@ ConvertTreeToTokens( TclGrowParseTokenArray(parsePtr, toCopy); subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; memcpy(subExprTokenPtr, tokenPtr, - (size_t) toCopy * sizeof(Tcl_Token)); + toCopy * sizeof(Tcl_Token)); subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; parsePtr->numTokens += toCopy; } else { @@ -1618,7 +1618,7 @@ ConvertTreeToTokens( subExprTokenPtr->numComponents++; subExprTokenPtr++; memcpy(subExprTokenPtr, tokenPtr, - (size_t) toCopy * sizeof(Tcl_Token)); + toCopy * sizeof(Tcl_Token)); parsePtr->numTokens += toCopy + 1; } @@ -1730,7 +1730,7 @@ ConvertTreeToTokens( scanned = ParseLexeme(start, numBytes, &lexeme, NULL); - switch(nodePtr->lexeme) { + switch (nodePtr->lexeme) { case OPEN_PAREN: case COMMA: case COLON: @@ -1806,7 +1806,7 @@ ConvertTreeToTokens( */ subExprTokenPtr->numComponents = - (parsePtr->numTokens - subExprTokenIdx) - 1; + ((int)parsePtr->numTokens - subExprTokenIdx) - 1; /* * Finally, as we return up the tree to our parent, pop the @@ -1860,7 +1860,7 @@ int Tcl_ParseExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *start, /* Start of source string to parse. */ - int numBytes, /* Number of bytes in string. If < 0, the + Tcl_Size numBytes, /* Number of bytes in string. If -1, the * string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr) /* Structure to fill with information about @@ -1896,7 +1896,7 @@ Tcl_ParseExpr( Tcl_FreeParse(exprParsePtr); TclStackFree(interp, exprParsePtr); - ckfree(opTree); + Tcl_Free(opTree); return code; } @@ -1917,17 +1917,16 @@ Tcl_ParseExpr( *---------------------------------------------------------------------- */ -static int +static Tcl_Size ParseLexeme( const char *start, /* Start of lexeme to parse. */ - int numBytes, /* Number of bytes in string. */ + Tcl_Size numBytes, /* Number of bytes in string. */ unsigned char *lexemePtr, /* Write code of parsed lexeme to this * storage. */ Tcl_Obj **literalPtr) /* Write corresponding literal value to this storage, if non-NULL. */ { const char *end; - int scanned, size; int ch; Tcl_Obj *literal = NULL; unsigned char byte; @@ -1942,15 +1941,18 @@ ParseLexeme( return 1; } switch (byte) { - case '#': + case '#': { /* * Scan forward over the comment contents. */ + Tcl_Size size; + for (size = 0; byte != '\n' && byte != 0 && size < numBytes; size++) { byte = UCHAR(start[size]); } *lexemePtr = COMMENT; return size - (byte == '\n'); + } case '*': if ((numBytes > 1) && (start[1] == '*')) { @@ -2145,6 +2147,7 @@ ParseLexeme( */ if (!TclIsBareword(*start) || *start == '_') { + Tcl_Size scanned; if (Tcl_UtfCharComplete(start, numBytes)) { scanned = Tcl_UtfToUniChar(start, &ch); } else { @@ -2194,7 +2197,7 @@ void TclCompileExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *script, /* The source script to compile. */ - int numBytes, /* Number of bytes in script. */ + Tcl_Size numBytes, /* Number of bytes in script. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int optimize) /* 0 for one-off expressions. */ { @@ -2215,7 +2218,7 @@ TclCompileExpr( * Valid parse; compile the tree. */ - int objc; + Tcl_Size objc; Tcl_Obj *const *litObjv; Tcl_Obj **funcObjv; @@ -2235,7 +2238,7 @@ TclCompileExpr( TclStackFree(interp, parsePtr); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); - ckfree(opTree); + Tcl_Free(opTree); } /* @@ -2345,11 +2348,11 @@ CompileExprTree( case FUNCTION: { Tcl_DString cmdName; const char *p; - int length; + Tcl_Size length; Tcl_DStringInit(&cmdName); TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::"); - p = TclGetStringFromObj(*funcObjv, &length); + p = Tcl_GetStringFromObj(*funcObjv, &length); funcObjv++; Tcl_DStringAppend(&cmdName, p, length); TclEmitPush(TclRegisterLiteral(envPtr, @@ -2504,8 +2507,8 @@ CompileExprTree( Tcl_Obj *literal = *litObjv; if (optimize) { - int length; - const char *bytes = TclGetStringFromObj(literal, &length); + Tcl_Size length; + const char *bytes = Tcl_GetStringFromObj(literal, &length); int idx = TclRegisterLiteral(envPtr, bytes, length, 0); Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx); @@ -2563,9 +2566,9 @@ CompileExprTree( if (TclHasStringRep(objPtr)) { Tcl_Obj *tableValue; - int numBytes; + Tcl_Size numBytes; const char *bytes - = TclGetStringFromObj(objPtr, &numBytes); + = Tcl_GetStringFromObj(objPtr, &numBytes); idx = TclRegisterLiteral(envPtr, bytes, numBytes, 0); tableValue = TclFetchLiteral(envPtr, idx); @@ -2616,7 +2619,7 @@ CompileExprTree( int TclSingleOpCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2669,7 +2672,7 @@ TclSingleOpCmd( int TclSortingOpCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2749,7 +2752,7 @@ TclSortingOpCmd( int TclVariadicOpCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2868,7 +2871,7 @@ TclVariadicOpCmd( int TclNoIdentOpCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7ca9e77..e321fc7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -129,10 +129,6 @@ InstructionDesc const tclInstructionTable[] = { {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ - {"lor", 1, -1, 0, {OPERAND_NONE}}, - /* Logical or: push (stknext || stktop) */ - {"land", 1, -1, 0, {OPERAND_NONE}}, - /* Logical and: push (stknext && stktop) */ {"bitor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise or: push (stknext | stktop) */ {"bitxor", 1, -1, 0, {OPERAND_NONE}}, @@ -173,10 +169,6 @@ InstructionDesc const tclInstructionTable[] = { /* Bitwise not: push ~stktop */ {"not", 1, 0, 0, {OPERAND_NONE}}, /* Logical not: push !stktop */ - {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}}, - /* Call builtin math function with index op1; any args are on stk */ - {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */ {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, /* Try converting stktop to first int then double if possible. */ @@ -186,13 +178,6 @@ InstructionDesc const tclInstructionTable[] = { /* Skip to next iteration of closest enclosing loop; if none, return * TCL_CONTINUE code. */ - {"foreach_start4", 5, 0, 1, {OPERAND_AUX4}}, - /* Initialize execution of a foreach loop. Operand is aux data index - * of the ForeachInfo structure for the foreach command. */ - {"foreach_step4", 5, +1, 1, {OPERAND_AUX4}}, - /* "Step" or begin next iteration of foreach loop. Push 0 if to - * terminate loop, else push 1. */ - {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, /* Record start of catch with the operand's exception index. Push the * current stack depth onto a special catch stack. */ @@ -340,9 +325,6 @@ InstructionDesc const tclInstructionTable[] = { {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, /* Get the next iteration from the iterator in op4's local scalar. * Stack: ... => ... value key doneBool */ - {"dictDone", 5, 0, 1, {OPERAND_LVT4}}, - /* Terminate the iterator in op4's local scalar. Use unsetScalar - * instead (with 0 for flags). */ {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}}, /* Create the variables (described in the aux data referred to by the * second immediate argument) to mirror the state of the dictionary in @@ -683,6 +665,13 @@ InstructionDesc const tclInstructionTable[] = { * set in flags. */ + {"constImm", 5, -1, 1, {OPERAND_LVT4}}, + /* Create constant. Index into LVT is immediate, value is on stack. + * Stack: ... value => ... */ + {"constStk", 1, -2, 0, {OPERAND_NONE}}, + /* Create constant. Variable name and value on stack. + * Stack: ... varName value => ... */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -698,9 +687,9 @@ static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, ByteCode *codePtr, unsigned char *startPtr); static void EnterCmdExtentData(CompileEnv *envPtr, - int cmdNumber, int numSrcBytes, int numCodeBytes); + Tcl_Size cmdNumber, Tcl_Size numSrcBytes, Tcl_Size numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, - int cmdNumber, int srcOffset, int codeOffset); + Tcl_Size cmdNumber, Tcl_Size srcOffset, Tcl_Size codeOffset); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); @@ -717,9 +706,10 @@ static void StartExpanding(CompileEnv *envPtr); * TIP #280: Helper for building the per-word line information of all compiled * commands. */ -static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, +static void EnterCmdWordData(ExtCmdLoc *eclPtr, Tcl_Size srcOffset, Tcl_Token *tokenPtr, const char *cmd, - int numWords, int line, int *clNext, int **lines, + Tcl_Size numWords, Tcl_Size line, + Tcl_Size *clNext, Tcl_Size **lines, CompileEnv *envPtr); static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); @@ -733,12 +723,13 @@ const Tcl_ObjType tclByteCodeType = { FreeByteCodeInternalRep, /* freeIntRepProc */ DupByteCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetByteCodeFromAny /* setFromAnyProc */ + SetByteCodeFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* - * subtCodeType provides the standard type managemnt procedures for the - * substcode type, which represents substiution within a Tcl value. + * substCodeType provides the standard type management procedures for the + * substcode type, which represents substitution within a Tcl value. */ static const Tcl_ObjType substCodeType = { @@ -747,6 +738,7 @@ static const Tcl_ObjType substCodeType = { DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2 @@ -792,7 +784,7 @@ TclSetByteCodeFromAny( Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - int length; + Tcl_Size length; int result = TCL_OK; const char *stringPtr; Proc *procPtr = iPtr->compiledProcPtr; @@ -808,7 +800,7 @@ TclSetByteCodeFromAny( } #endif - stringPtr = TclGetStringFromObj(objPtr, &length); + stringPtr = Tcl_GetStringFromObj(objPtr, &length); /* * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked, and @@ -873,8 +865,8 @@ TclSetByteCodeFromAny( * instruction generator boundaries. */ - if (iPtr->extra.optimizer) { - (iPtr->extra.optimizer)(&compEnv); + if (iPtr->optimizer) { + (iPtr->optimizer)(&compEnv); } /* @@ -886,6 +878,18 @@ TclSetByteCodeFromAny( } /* + * After optimization is all done, check that byte code length limits + * are not exceeded. Bug [27b3ce2997]. + */ + if ((compEnv.codeNext - compEnv.codeStart) > INT_MAX) { + /* + * Cannot just return TCL_ERROR as callers ignore return value. + * TODO - May be use TclCompileSyntaxError here? + */ + Tcl_Panic("Maximum byte code length %d exceeded.", INT_MAX); + } + + /* * Change the object into a ByteCode object. Ownership of the literal * objects and aux data items passes to the ByteCode object. */ @@ -1160,7 +1164,7 @@ CleanupByteCode( } TclHandleRelease(codePtr->interpHandle); - ckfree(codePtr); + Tcl_Free(codePtr); } /* @@ -1344,8 +1348,8 @@ CompileSubstObj( } if (codePtr == NULL) { CompileEnv compEnv; - int numBytes; - const char *bytes = TclGetStringFromObj(objPtr, &numBytes); + Tcl_Size numBytes; + const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); /* TODO: Check for more TIP 280 */ TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0); @@ -1407,20 +1411,20 @@ static void ReleaseCmdWordData( ExtCmdLoc *eclPtr) { - int i; + Tcl_Size i; if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eclPtr->path); } for (i=0 ; i<eclPtr->nuloc ; i++) { - ckfree(eclPtr->loc[i].line); + Tcl_Free(eclPtr->loc[i].line); } if (eclPtr->loc != NULL) { - ckfree(eclPtr->loc); + Tcl_Free(eclPtr->loc); } - ckfree(eclPtr); + Tcl_Free(eclPtr); } /* @@ -1447,14 +1451,14 @@ TclInitCompileEnv( CompileEnv *envPtr,/* Points to the CompileEnv structure to * initialize. */ const char *stringPtr, /* The source string to be compiled. */ - TCL_HASH_TYPE numBytes, /* Number of bytes in source string. */ + size_t numBytes, /* Number of bytes in source string. */ const CmdFrame *invoker, /* Location context invoking the bcc */ int word) /* Index of the word in that context getting * compiled */ { Interp *iPtr = (Interp *) interp; - assert(tclInstructionTable[LAST_INST_OPCODE+1].name == NULL); + assert(tclInstructionTable[LAST_INST_OPCODE].name == NULL); envPtr->iPtr = iPtr; envPtr->source = stringPtr; @@ -1499,7 +1503,7 @@ TclInitCompileEnv( * non-compiling evaluator */ - envPtr->extCmdMapPtr = (ExtCmdLoc *)ckalloc(sizeof(ExtCmdLoc)); + envPtr->extCmdMapPtr = (ExtCmdLoc *)Tcl_Alloc(sizeof(ExtCmdLoc)); envPtr->extCmdMapPtr->loc = NULL; envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; @@ -1654,7 +1658,7 @@ TclFreeCompileEnv( CompileEnv *envPtr)/* Points to the CompileEnv structure. */ { if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){ - ckfree(envPtr->localLitTable.buckets); + Tcl_Free(envPtr->localLitTable.buckets); envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets; } if (envPtr->iPtr) { @@ -1663,7 +1667,7 @@ TclFreeCompileEnv( * have transferred to it. */ - int i; + Tcl_Size i; LiteralEntry *entryPtr = envPtr->literalArrayPtr; AuxData *auxDataPtr = envPtr->auxDataArrayPtr; @@ -1684,20 +1688,20 @@ TclFreeCompileEnv( } } if (envPtr->mallocedCodeArray) { - ckfree(envPtr->codeStart); + Tcl_Free(envPtr->codeStart); } if (envPtr->mallocedLiteralArray) { - ckfree(envPtr->literalArrayPtr); + Tcl_Free(envPtr->literalArrayPtr); } if (envPtr->mallocedExceptArray) { - ckfree(envPtr->exceptArrayPtr); - ckfree(envPtr->exceptAuxArrayPtr); + Tcl_Free(envPtr->exceptArrayPtr); + Tcl_Free(envPtr->exceptAuxArrayPtr); } if (envPtr->mallocedCmdMap) { - ckfree(envPtr->cmdMapPtr); + Tcl_Free(envPtr->cmdMapPtr); } if (envPtr->mallocedAuxDataArray) { - ckfree(envPtr->auxDataArrayPtr); + Tcl_Free(envPtr->auxDataArrayPtr); } if (envPtr->extCmdMapPtr) { ReleaseCmdWordData(envPtr->extCmdMapPtr); @@ -1764,7 +1768,7 @@ TclWordKnownAtCompileTime( case TCL_TOKEN_BS: if (tempPtr != NULL) { char utfBuf[4] = ""; - int length = TclParseBackslash(tokenPtr->start, + size_t length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, utfBuf); Tcl_AppendToObj(tempPtr, utfBuf, length); @@ -1807,7 +1811,7 @@ TclWordKnownAtCompileTime( static int ExpandRequested( Tcl_Token *tokenPtr, - int numWords) + size_t numWords) { /* Determine whether any words of the command require expansion */ while (numWords--) { @@ -1828,15 +1832,15 @@ CompileCmdLiteral( const char *bytes; Command *cmdPtr; int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME; - int numBytes; + Tcl_Size length; cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { extraLiteralFlags |= LITERAL_UNSHARED; } - bytes = TclGetStringFromObj(cmdObj, &numBytes); - cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags); + bytes = Tcl_GetStringFromObj(cmdObj, &length); + cmdLitIdx = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags); if (cmdPtr && TclRoutineHasName(cmdPtr)) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); @@ -1849,11 +1853,11 @@ TclCompileInvocation( Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, - int numWords, + size_t numWords, CompileEnv *envPtr) { DefineLineInformation; - int wordIdx = 0; + size_t wordIdx = 0; int depth = TclGetStackDepth(envPtr); if (cmdObj) { @@ -1957,7 +1961,8 @@ CompileCmdCompileProc( CompileEnv *envPtr) { DefineLineInformation; - int unwind = 0, incrOffset = -1; + int unwind = 0; + Tcl_Size incrOffset = -1; int depth = TclGetStackDepth(envPtr); /* @@ -2018,7 +2023,7 @@ CompileCmdCompileProc( while (mapPtr->nuloc - 1 > eclIndex) { mapPtr->nuloc--; - ckfree(mapPtr->loc[mapPtr->nuloc].line); + Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; } @@ -2044,14 +2049,14 @@ CompileCommandTokens( Command *cmdPtr = NULL; int code = TCL_ERROR; int cmdKnown, expand = -1; - int *wlines, wlineat; - int cmdLine = envPtr->line; - int *clNext = envPtr->clNext; - int cmdIdx = envPtr->numCommands; - int startCodeOffset = envPtr->codeNext - envPtr->codeStart; + Tcl_Size *wlines, wlineat; + Tcl_Size cmdLine = envPtr->line; + Tcl_Size *clNext = envPtr->clNext; + Tcl_Size cmdIdx = envPtr->numCommands; + Tcl_Size startCodeOffset = envPtr->codeNext - envPtr->codeStart; int depth = TclGetStackDepth(envPtr); - assert (parsePtr->numWords > 0); + assert ((int)parsePtr->numWords > 0); /* Precompile */ @@ -2096,7 +2101,7 @@ CompileCommandTokens( } } if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { - expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords); if (expand) { /* We need to expand, but compileProc cannot. */ cmdPtr = NULL; @@ -2111,15 +2116,15 @@ CompileCommandTokens( if (code == TCL_ERROR) { if (expand < 0) { - expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords); } if (expand) { CompileExpanded(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); + cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr); } else { TclCompileInvocation(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); + cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr); } } @@ -2137,8 +2142,8 @@ CompileCommandTokens( envPtr->line = cmdLine; envPtr->clNext = clNext; - ckfree(eclPtr->loc[wlineat].line); - ckfree(eclPtr->loc[wlineat].next); + Tcl_Free(eclPtr->loc[wlineat].line); + Tcl_Free(eclPtr->loc[wlineat].next); eclPtr->loc[wlineat].line = wlines; eclPtr->loc[wlineat].next = NULL; @@ -2152,7 +2157,7 @@ TclCompileScript( * serves as context for finding and compiling * commands. May not be NULL. */ const char *script, /* The source script to compile. */ - int numBytes, /* Number of bytes in script. If < 0, the + Tcl_Size numBytes, /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ @@ -2183,15 +2188,32 @@ TclCompileScript( return; } + if (numBytes < 0) { + numBytes = strlen(script); + } + /* Each iteration compiles one command from the script. */ if (numBytes > 0) { + if (numBytes >= INT_MAX) { + /* + * Note this gets -errorline as 1. Not worth figuring out which line + * crosses the limit to get -errorline for this error case. + */ + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Script length %" TCL_SIZE_MODIFIER + "d exceeds max permitted length %d.", + numBytes, INT_MAX-1)); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "SCRIPTLENGTH", (void *)NULL); + TclCompileSyntaxError(interp, envPtr); + return; + } /* * Don't use system stack (size of Tcl_Parse is ca. 400 bytes), so * many nested compilations (body enclosed in body) can cause abnormal * program termination with a stack overflow exception, bug [fec0c17d39]. */ - Tcl_Parse *parsePtr = (Tcl_Parse *)ckalloc(sizeof(Tcl_Parse)); + Tcl_Parse *parsePtr = (Tcl_Parse *)Tcl_Alloc(sizeof(Tcl_Parse)); do { const char *next; @@ -2204,7 +2226,7 @@ TclCompileScript( Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, parsePtr->term + 1 - parsePtr->commandStart); TclCompileSyntaxError(interp, envPtr); - ckfree(parsePtr); + Tcl_Free(parsePtr); return; } @@ -2254,7 +2276,7 @@ TclCompileScript( * Tcl_FreeParse() to do. * * The advantage of this shortcut is that CompileCommandTokens() - * can be written with an assumption that parsePtr->numWords > 0, with + * can be written with an assumption that (int)parsePtr->numWords > 0, with * the implication the CCT() always generates bytecode. */ continue; @@ -2280,7 +2302,7 @@ TclCompileScript( Tcl_FreeParse(parsePtr); } while (numBytes > 0); - ckfree(parsePtr); + Tcl_Free(parsePtr); } if (lastCmdIdx == -1) { @@ -2339,7 +2361,8 @@ TclCompileVarSubst( CompileEnv *envPtr) { const char *p, *name = tokenPtr[1].start; - int i, localVar, nameBytes = tokenPtr[1].size; + Tcl_Size i, nameBytes = tokenPtr[1].size; + Tcl_Size localVar; int localVarName = 1; /* @@ -2367,7 +2390,7 @@ TclCompileVarSubst( * of local variables in a procedure frame. */ - localVar = TCL_INDEX_NONE; + localVar = -1; if (localVarName != -1) { localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr); } @@ -2407,20 +2430,22 @@ TclCompileTokens( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * compile. */ - int count, /* Number of tokens to consider at tokenPtr. + size_t count1, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[4] = ""; - int i, numObjsToConcat, adjust; - int length; + Tcl_Size i, numObjsToConcat, adjust; + size_t length; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 - int isLiteral, maxNumCL, numCL; - int *clPosition = NULL; + int isLiteral; + Tcl_Size maxNumCL, numCL; + Tcl_Size *clPosition = NULL; int depth = TclGetStackDepth(envPtr); + int count = count1; /* * If this is actually a literal, handle continuation lines by @@ -2448,7 +2473,7 @@ TclCompileTokens( if (isLiteral) { maxNumCL = NUM_STATIC_POS; - clPosition = (int *)ckalloc(maxNumCL * sizeof(int)); + clPosition = (Tcl_Size *)Tcl_Alloc(maxNumCL * sizeof(Tcl_Size)); } adjust = 0; @@ -2488,8 +2513,8 @@ TclCompileTokens( if (numCL >= maxNumCL) { maxNumCL *= 2; - clPosition = (int *)ckrealloc(clPosition, - maxNumCL * sizeof(int)); + clPosition = (Tcl_Size *)Tcl_Realloc(clPosition, + maxNumCL * sizeof(Tcl_Size)); } clPosition[numCL] = clPos; numCL ++; @@ -2546,7 +2571,7 @@ TclCompileTokens( default: Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s", - tokenPtr->type, tokenPtr->size, tokenPtr->start); + tokenPtr->type, (int)tokenPtr->size, tokenPtr->start); } } @@ -2593,7 +2618,7 @@ TclCompileTokens( */ if (maxNumCL) { - ckfree(clPosition); + Tcl_Free(clPosition); } TclCheckStackDepth(depth+1, envPtr); } @@ -2624,10 +2649,12 @@ TclCompileCmdWord( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for * a command word to compile inline. */ - int count, /* Number of tokens to consider at tokenPtr. + size_t count1, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { + int count = count1; + if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { /* * The common case that there is a single text token. Compile it @@ -2673,13 +2700,14 @@ TclCompileExprWords( Tcl_Token *tokenPtr, /* Points to first in an array of word tokens * tokens for the expression to compile * inline. */ - int numWords, /* Number of word tokens starting at tokenPtr. + size_t numWords1, /* Number of word tokens starting at tokenPtr. * Must be at least 1. Each word token * contains one or more subtokens. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_Token *wordPtr; int i, concatItems; + int numWords = numWords1; /* * If the expression is a single word that doesn't require substitutions, @@ -2745,7 +2773,7 @@ TclCompileNoOp( int i; tokenPtr = parsePtr->tokenPtr; - for (i = 1; i < parsePtr->numWords; i++) { + for (i = 1; i < (int)parsePtr->numWords; i++) { tokenPtr = tokenPtr + tokenPtr->numComponents + 1; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -2787,7 +2815,7 @@ PreventCycle( Tcl_Obj *objPtr, CompileEnv *envPtr) { - int i; + Tcl_Size i; for (i = 0; i < envPtr->literalArrayNext; i++) { if (objPtr == TclFetchLiteral(envPtr, i)) { @@ -2802,8 +2830,8 @@ PreventCycle( * can be sure we do not have any lingering cycles hiding in * the internalrep. */ - int numBytes; - const char *bytes = TclGetStringFromObj(objPtr, &numBytes); + Tcl_Size numBytes; + const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes); Tcl_IncrRefCount(copyPtr); @@ -2864,7 +2892,7 @@ TclInitByteCode( namespacePtr = envPtr->iPtr->globalNsPtr; } - p = (unsigned char *)ckalloc(structureSize); + p = (unsigned char *)Tcl_Alloc(structureSize); codePtr = (ByteCode *) p; codePtr->interpHandle = TclHandlePreserve(iPtr->handle); codePtr->compileEpoch = iPtr->compileEpoch; @@ -3004,19 +3032,19 @@ TclInitByteCodeObj( *---------------------------------------------------------------------- */ -int +Tcl_Size TclFindCompiledLocal( const char *name, /* Points to first character of the name of a * scalar or array variable. If NULL, a * temporary var should be created. */ - int nameBytes, /* Number of bytes in the name. */ + Tcl_Size nameBytes, /* Number of bytes in the name. */ int create, /* If 1, allocate a local frame entry for the * variable if it is new. */ CompileEnv *envPtr) /* Points to the current compile environment*/ { CompiledLocal *localPtr; - int localVar = TCL_INDEX_NONE; - int i; + Tcl_Size localVar = TCL_INDEX_NONE; + Tcl_Size i; Proc *procPtr; /* @@ -3035,7 +3063,7 @@ TclFindCompiledLocal( LocalCache *cachePtr = envPtr->iPtr->varFramePtr->localCachePtr; const char *localName; Tcl_Obj **varNamePtr; - int len; + Tcl_Size len; if (!cachePtr || !name) { return TCL_INDEX_NONE; @@ -3044,7 +3072,7 @@ TclFindCompiledLocal( varNamePtr = &cachePtr->varName0; for (i=0; i < cachePtr->numVars; varNamePtr++, i++) { if (*varNamePtr) { - localName = TclGetStringFromObj(*varNamePtr, &len); + localName = Tcl_GetStringFromObj(*varNamePtr, &len); if ((len == nameBytes) && !strncmp(name, localName, len)) { return i; } @@ -3054,7 +3082,7 @@ TclFindCompiledLocal( } if (name != NULL) { - int localCt = procPtr->numCompiledLocals; + Tcl_Size localCt = procPtr->numCompiledLocals; localPtr = procPtr->firstLocalPtr; for (i = 0; i < localCt; i++) { @@ -3062,7 +3090,7 @@ TclFindCompiledLocal( char *localName = localPtr->name; if ((nameBytes == localPtr->nameLength) && - (strncmp(name, localName, nameBytes) == 0)) { + (strncmp(name,localName,nameBytes) == 0)) { return i; } } @@ -3076,7 +3104,7 @@ TclFindCompiledLocal( if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; - localPtr = (CompiledLocal *)ckalloc(offsetof(CompiledLocal, name) + 1U + nameBytes); + localPtr = (CompiledLocal *)Tcl_Alloc(offsetof(CompiledLocal, name) + 1U + nameBytes); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -3139,14 +3167,14 @@ TclExpandCodeArray( size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart); if (envPtr->mallocedCodeArray) { - envPtr->codeStart = (unsigned char *)ckrealloc(envPtr->codeStart, newBytes); + envPtr->codeStart = (unsigned char *)Tcl_Realloc(envPtr->codeStart, newBytes); } else { /* * envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so * perform the equivalent of Tcl_Realloc directly. */ - unsigned char *newPtr = (unsigned char *)ckalloc(newBytes); + unsigned char *newPtr = (unsigned char *)Tcl_Alloc(newBytes); memcpy(newPtr, envPtr->codeStart, currBytes); envPtr->codeStart = newPtr; @@ -3182,15 +3210,15 @@ EnterCmdStartData( CompileEnv *envPtr, /* Points to the compilation environment * structure in which to enter command * location information. */ - int cmdIndex, /* Index of the command whose start data is + Tcl_Size cmdIndex, /* Index of the command whose start data is * being set. */ - int srcOffset, /* Offset of first char of the command. */ - int codeOffset) /* Offset of first byte of command code. */ + Tcl_Size srcOffset, /* Offset of first char of the command. */ + Tcl_Size codeOffset) /* Offset of first byte of command code. */ { CmdLocation *cmdLocPtr; - if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { - Tcl_Panic("EnterCmdStartData: bad command index %d", cmdIndex); + if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) { + Tcl_Panic("EnterCmdStartData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex); } if (cmdIndex >= envPtr->cmdMapEnd) { @@ -3206,14 +3234,14 @@ EnterCmdStartData( size_t newBytes = newElems * sizeof(CmdLocation); if (envPtr->mallocedCmdMap) { - envPtr->cmdMapPtr = (CmdLocation *)ckrealloc(envPtr->cmdMapPtr, newBytes); + envPtr->cmdMapPtr = (CmdLocation *)Tcl_Realloc(envPtr->cmdMapPtr, newBytes); } else { /* - * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a - * ckrealloc equivalent for ourselves. + * envPtr->cmdMapPtr isn't a Tcl_Alloc'd pointer, so we must code a + * Tcl_Realloc equivalent for ourselves. */ - CmdLocation *newPtr = (CmdLocation *)ckalloc(newBytes); + CmdLocation *newPtr = (CmdLocation *)Tcl_Alloc(newBytes); memcpy(newPtr, envPtr->cmdMapPtr, currBytes); envPtr->cmdMapPtr = newPtr; @@ -3261,19 +3289,19 @@ EnterCmdExtentData( CompileEnv *envPtr, /* Points to the compilation environment * structure in which to enter command * location information. */ - int cmdIndex, /* Index of the command whose source and code + Tcl_Size cmdIndex, /* Index of the command whose source and code * length data is being set. */ - int numSrcBytes, /* Number of command source chars. */ - int numCodeBytes) /* Offset of last byte of command code. */ + Tcl_Size numSrcBytes, /* Number of command source chars. */ + Tcl_Size numCodeBytes) /* Offset of last byte of command code. */ { CmdLocation *cmdLocPtr; - if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { - Tcl_Panic("EnterCmdExtentData: bad command index %d", cmdIndex); + if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) { + Tcl_Panic("EnterCmdExtentData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex); } if (cmdIndex > envPtr->cmdMapEnd) { - Tcl_Panic("EnterCmdExtentData: missing start data for command %d", + Tcl_Panic("EnterCmdExtentData: missing start data for command %" TCL_Z_MODIFIER "u", cmdIndex); } @@ -3307,19 +3335,19 @@ EnterCmdWordData( ExtCmdLoc *eclPtr, /* Points to the map environment structure in * which to enter command location * information. */ - int srcOffset, /* Offset of first char of the command. */ + Tcl_Size srcOffset, /* Offset of first char of the command. */ Tcl_Token *tokenPtr, const char *cmd, - int numWords, - int line, - int *clNext, - int **wlines, + Tcl_Size numWords, + Tcl_Size line, + Tcl_Size *clNext, + Tcl_Size **wlines, CompileEnv *envPtr) { ECL *ePtr; const char *last; - int wordIdx, wordLine; - int *wwlines, *wordNext; + Tcl_Size wordIdx, wordLine; + Tcl_Size *wwlines, *wordNext; if (eclPtr->nuloc >= eclPtr->nloc) { /* @@ -3332,16 +3360,16 @@ EnterCmdWordData( size_t newElems = (currElems ? 2*currElems : 1); size_t newBytes = newElems * sizeof(ECL); - eclPtr->loc = (ECL *)ckrealloc(eclPtr->loc, newBytes); + eclPtr->loc = (ECL *)Tcl_Realloc(eclPtr->loc, newBytes); eclPtr->nloc = newElems; } ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; - ePtr->line = (int *)ckalloc(numWords * sizeof(int)); - ePtr->next = (int **)ckalloc(numWords * sizeof(int *)); + ePtr->line = (Tcl_Size *)Tcl_Alloc(numWords * sizeof(Tcl_Size)); + ePtr->next = (Tcl_Size **)Tcl_Alloc(numWords * sizeof(Tcl_Size *)); ePtr->nline = numWords; - wwlines = (int *)ckalloc(numWords * sizeof(int)); + wwlines = (Tcl_Size *)Tcl_Alloc(numWords * sizeof(Tcl_Size)); last = cmd; wordLine = line; @@ -3354,7 +3382,7 @@ EnterCmdWordData( /* See Ticket 4b61afd660 */ wwlines[wordIdx] = ((wordIdx == 0) || TclWordKnownAtCompileTime(tokenPtr, NULL)) - ? wordLine : TCL_INDEX_NONE; + ? wordLine : -1; ePtr->line[wordIdx] = wordLine; ePtr->next[wordIdx] = wordNext; last = tokenPtr->start; @@ -3384,7 +3412,7 @@ EnterCmdWordData( *---------------------------------------------------------------------- */ -int +Tcl_Size TclCreateExceptRange( ExceptionRangeType type, /* The kind of ExceptionRange desired. */ CompileEnv *envPtr)/* Points to CompileEnv for which to create a @@ -3392,7 +3420,7 @@ TclCreateExceptRange( { ExceptionRange *rangePtr; ExceptionAux *auxPtr; - int index = envPtr->exceptArrayNext; + Tcl_Size index = envPtr->exceptArrayNext; if (index >= envPtr->exceptArrayEnd) { /* @@ -3410,17 +3438,17 @@ TclCreateExceptRange( if (envPtr->mallocedExceptArray) { envPtr->exceptArrayPtr = - (ExceptionRange *)ckrealloc(envPtr->exceptArrayPtr, newBytes); + (ExceptionRange *)Tcl_Realloc(envPtr->exceptArrayPtr, newBytes); envPtr->exceptAuxArrayPtr = - (ExceptionAux *)ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2); + (ExceptionAux *)Tcl_Realloc(envPtr->exceptAuxArrayPtr, newBytes2); } else { /* - * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must - * code a ckrealloc equivalent for ourselves. + * envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so we must + * code a Tcl_Realloc equivalent for ourselves. */ - ExceptionRange *newPtr = (ExceptionRange *)ckalloc(newBytes); - ExceptionAux *newPtr2 = (ExceptionAux *)ckalloc(newBytes2); + ExceptionRange *newPtr = (ExceptionRange *)Tcl_Alloc(newBytes); + ExceptionAux *newPtr2 = (ExceptionAux *)Tcl_Alloc(newBytes2); memcpy(newPtr, envPtr->exceptArrayPtr, currBytes); memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2); @@ -3480,9 +3508,9 @@ TclGetInnermostExceptionRange( while (i > 0) { rangePtr--; i--; - if (CurrentOffset(envPtr) >= rangePtr->codeOffset && + if (CurrentOffset(envPtr) >= (int)rangePtr->codeOffset && (rangePtr->numCodeBytes == TCL_INDEX_NONE || CurrentOffset(envPtr) < - rangePtr->codeOffset+rangePtr->numCodeBytes) && + (int)rangePtr->codeOffset+(int)rangePtr->numCodeBytes) && (returnCode != TCL_CONTINUE || envPtr->exceptAuxArrayPtr[i].supportsContinue)) { @@ -3523,11 +3551,11 @@ TclAddLoopBreakFixup( auxPtr->allocBreakTargets *= 2; auxPtr->allocBreakTargets += 2; if (auxPtr->breakTargets) { - auxPtr->breakTargets = (unsigned int *)ckrealloc(auxPtr->breakTargets, - sizeof(int) * auxPtr->allocBreakTargets); + auxPtr->breakTargets = (size_t *)Tcl_Realloc(auxPtr->breakTargets, + sizeof(size_t) * auxPtr->allocBreakTargets); } else { auxPtr->breakTargets = - (unsigned int *)ckalloc(sizeof(int) * auxPtr->allocBreakTargets); + (size_t *)Tcl_Alloc(sizeof(size_t) * auxPtr->allocBreakTargets); } } auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); @@ -3549,11 +3577,11 @@ TclAddLoopContinueFixup( auxPtr->allocContinueTargets *= 2; auxPtr->allocContinueTargets += 2; if (auxPtr->continueTargets) { - auxPtr->continueTargets = (unsigned int *)ckrealloc(auxPtr->continueTargets, - sizeof(int) * auxPtr->allocContinueTargets); + auxPtr->continueTargets = (size_t *)Tcl_Realloc(auxPtr->continueTargets, + sizeof(size_t) * auxPtr->allocContinueTargets); } else { auxPtr->continueTargets = - (unsigned int *)ckalloc(sizeof(int) * auxPtr->allocContinueTargets); + (size_t *)Tcl_Alloc(sizeof(size_t) * auxPtr->allocContinueTargets); } } auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = @@ -3585,7 +3613,7 @@ TclCleanupStackForBreakContinue( while (toPop --> 0) { TclEmitOpcode(INST_EXPAND_DROP, envPtr); } - TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth, + TclAdjustStackDepth((int)(auxPtr->expandTargetDepth - envPtr->currStackDepth), envPtr); envPtr->currStackDepth = auxPtr->expandTargetDepth; } @@ -3621,7 +3649,7 @@ StartExpanding( * where this expansion started. */ - for (i=0 ; i<envPtr->exceptArrayNext ; i++) { + for (i=0 ; i<(int)envPtr->exceptArrayNext ; i++) { ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i]; @@ -3629,7 +3657,7 @@ StartExpanding( * Ignore loops unless they're still being built. */ - if (rangePtr->codeOffset > CurrentOffset(envPtr)) { + if ((int)rangePtr->codeOffset > CurrentOffset(envPtr)) { continue; } if (rangePtr->numCodeBytes != TCL_INDEX_NONE) { @@ -3685,12 +3713,12 @@ TclFinalizeLoopExceptionRange( * there is no need to fuss around with updating code offsets. */ - for (i=0 ; i<auxPtr->numBreakTargets ; i++) { + for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) { site = envPtr->codeStart + auxPtr->breakTargets[i]; offset = rangePtr->breakOffset - auxPtr->breakTargets[i]; TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); } - for (i=0 ; i<auxPtr->numContinueTargets ; i++) { + for (i=0 ; i<(int)auxPtr->numContinueTargets ; i++) { site = envPtr->codeStart + auxPtr->continueTargets[i]; if (rangePtr->continueOffset == TCL_INDEX_NONE) { int j; @@ -3715,12 +3743,12 @@ TclFinalizeLoopExceptionRange( */ if (auxPtr->breakTargets) { - ckfree(auxPtr->breakTargets); + Tcl_Free(auxPtr->breakTargets); auxPtr->breakTargets = NULL; auxPtr->numBreakTargets = 0; } if (auxPtr->continueTargets) { - ckfree(auxPtr->continueTargets); + Tcl_Free(auxPtr->continueTargets); auxPtr->continueTargets = NULL; auxPtr->numContinueTargets = 0; } @@ -3745,7 +3773,7 @@ TclFinalizeLoopExceptionRange( *---------------------------------------------------------------------- */ -int +Tcl_Size TclCreateAuxData( void *clientData, /* The compilation auxiliary data to store in * the new aux data record. */ @@ -3754,7 +3782,7 @@ TclCreateAuxData( CompileEnv *envPtr)/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { - int index; /* Index for the new AuxData structure. */ + Tcl_Size index; /* Index for the new AuxData structure. */ AuxData *auxDataPtr; /* Points to the new AuxData structure */ @@ -3772,14 +3800,14 @@ TclCreateAuxData( if (envPtr->mallocedAuxDataArray) { envPtr->auxDataArrayPtr = - (AuxData *)ckrealloc(envPtr->auxDataArrayPtr, newBytes); + (AuxData *)Tcl_Realloc(envPtr->auxDataArrayPtr, newBytes); } else { /* - * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must - * code a ckrealloc equivalent for ourselves. + * envPtr->auxDataArrayPtr isn't a Tcl_Alloc'd pointer, so we must + * code a Tcl_Realloc equivalent for ourselves. */ - AuxData *newPtr = (AuxData *)ckalloc(newBytes); + AuxData *newPtr = (AuxData *)Tcl_Alloc(newBytes); memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes); envPtr->auxDataArrayPtr = newPtr; @@ -3860,14 +3888,14 @@ TclExpandJumpFixupArray( size_t newBytes = newElems * sizeof(JumpFixup); if (fixupArrayPtr->mallocedArray) { - fixupArrayPtr->fixup = (JumpFixup *)ckrealloc(fixupArrayPtr->fixup, newBytes); + fixupArrayPtr->fixup = (JumpFixup *)Tcl_Realloc(fixupArrayPtr->fixup, newBytes); } else { /* - * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a - * ckrealloc equivalent for ourselves. + * fixupArrayPtr->fixup isn't a Tcl_Alloc'd pointer, so we must code a + * Tcl_Realloc equivalent for ourselves. */ - JumpFixup *newPtr = (JumpFixup *)ckalloc(newBytes); + JumpFixup *newPtr = (JumpFixup *)Tcl_Alloc(newBytes); memcpy(newPtr, fixupArrayPtr->fixup, currBytes); fixupArrayPtr->fixup = newPtr; @@ -3899,7 +3927,7 @@ TclFreeJumpFixupArray( * free. */ { if (fixupArrayPtr->mallocedArray) { - ckfree(fixupArrayPtr->fixup); + Tcl_Free(fixupArrayPtr->fixup); } } @@ -4083,16 +4111,16 @@ TclFixupForwardJump( } } - for (k = 0 ; k < envPtr->exceptArrayNext ; k++) { + for (k = 0 ; k < (int)envPtr->exceptArrayNext ; k++) { ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k]; int i; - for (i=0 ; i<auxPtr->numBreakTargets ; i++) { + for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) { if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) { auxPtr->breakTargets[i] += 3; } } - for (i=0 ; i<auxPtr->numContinueTargets ; i++) { + for (i=0 ; i<(int)auxPtr->numContinueTargets ; i++) { if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) { auxPtr->continueTargets[i] += 3; } @@ -4244,8 +4272,8 @@ TclEmitInvoke( */ if (auxBreakPtr != NULL || auxContinuePtr != NULL) { - int savedStackDepth = envPtr->currStackDepth; - int savedExpandCount = envPtr->expandCount; + size_t savedStackDepth = envPtr->currStackDepth; + size_t savedExpandCount = envPtr->expandCount; JumpFixup nonTrapFixup; if (auxBreakPtr != NULL) { @@ -4427,10 +4455,10 @@ EncodeCmdLocMap( * is to be stored. */ { CmdLocation *mapPtr = envPtr->cmdMapPtr; - int numCmds = envPtr->numCommands; + Tcl_Size i, codeDelta, codeLen, srcLen, prevOffset; + Tcl_Size numCmds = envPtr->numCommands; unsigned char *p = startPtr; - int codeDelta, codeLen, srcDelta, srcLen, prevOffset; - int i; + int srcDelta; /* * Encode the code offset for each command as a sequence of deltas. @@ -4553,12 +4581,12 @@ RecordByteCodeStats( statsPtr = &(iPtr->stats); statsPtr->numCompilations++; - statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; + statsPtr->totalSrcBytes += (double)codePtr->numSrcBytes; statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; - statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; + statsPtr->currentSrcBytes += (double) (int)codePtr->numSrcBytes; statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; - statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; + statsPtr->srcCount[TclLog2((int)codePtr->numSrcBytes)]++; statsPtr->byteCodeCount[TclLog2((int) codePtr->structureSize)]++; statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1d748b5..2ea2565 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -316,6 +316,10 @@ typedef struct CompileEnv { * array byte. */ int mallocedCodeArray; /* Set 1 if code array was expanded and * codeStart points into the heap.*/ +#if TCL_MAJOR_VERSION > 8 + int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and + * exceptArrayPtr points in heap, else 0. */ +#endif LiteralEntry *literalArrayPtr; /* Points to start of LiteralEntry array. */ Tcl_Size literalArrayNext; /* Index of next free object array entry. */ @@ -331,8 +335,9 @@ typedef struct CompileEnv { * current range's array entry. */ Tcl_Size exceptArrayEnd; /* Index after the last ExceptionRange array * entry. */ - int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and - * exceptArrayPtr points in heap, else 0. */ +#if TCL_MAJOR_VERSION < 9 + int mallocedExceptArray; +#endif ExceptionAux *exceptAuxArrayPtr; /* Array of information used to restore the * state when processing BREAK/CONTINUE @@ -345,14 +350,19 @@ typedef struct CompileEnv { Tcl_Size cmdMapEnd; /* Index after last CmdLocation entry. */ int mallocedCmdMap; /* 1 if command map array was expanded and * cmdMapPtr points in the heap, else 0. */ +#if TCL_MAJOR_VERSION > 8 + int mallocedAuxDataArray; /* 1 if aux data array was expanded and + * auxDataArrayPtr points in heap else 0. */ +#endif AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ Tcl_Size auxDataArrayNext; /* Next free compile aux data array index. * auxDataArrayNext is the number of aux data * items and (auxDataArrayNext-1) is index of * current aux data array entry. */ Tcl_Size auxDataArrayEnd; /* Index after last aux data array entry. */ - int mallocedAuxDataArray; /* 1 if aux data array was expanded and - * auxDataArrayPtr points in heap else 0. */ +#if TCL_MAJOR_VERSION < 9 + int mallocedAuxDataArray; +#endif unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; /* Initial storage for code. */ LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; @@ -540,318 +550,300 @@ typedef struct ByteCode { * tclExecute.c. */ -/* Opcodes 0 to 9 */ -#define INST_DONE 0 -#define INST_PUSH1 1 -#define INST_PUSH4 2 -#define INST_POP 3 -#define INST_DUP 4 -#define INST_STR_CONCAT1 5 -#define INST_INVOKE_STK1 6 -#define INST_INVOKE_STK4 7 -#define INST_EVAL_STK 8 -#define INST_EXPR_STK 9 - -/* Opcodes 10 to 23 */ -#define INST_LOAD_SCALAR1 10 -#define INST_LOAD_SCALAR4 11 -#define INST_LOAD_SCALAR_STK 12 -#define INST_LOAD_ARRAY1 13 -#define INST_LOAD_ARRAY4 14 -#define INST_LOAD_ARRAY_STK 15 -#define INST_LOAD_STK 16 -#define INST_STORE_SCALAR1 17 -#define INST_STORE_SCALAR4 18 -#define INST_STORE_SCALAR_STK 19 -#define INST_STORE_ARRAY1 20 -#define INST_STORE_ARRAY4 21 -#define INST_STORE_ARRAY_STK 22 -#define INST_STORE_STK 23 - -/* Opcodes 24 to 33 */ -#define INST_INCR_SCALAR1 24 -#define INST_INCR_SCALAR_STK 25 -#define INST_INCR_ARRAY1 26 -#define INST_INCR_ARRAY_STK 27 -#define INST_INCR_STK 28 -#define INST_INCR_SCALAR1_IMM 29 -#define INST_INCR_SCALAR_STK_IMM 30 -#define INST_INCR_ARRAY1_IMM 31 -#define INST_INCR_ARRAY_STK_IMM 32 -#define INST_INCR_STK_IMM 33 - -/* Opcodes 34 to 39 */ -#define INST_JUMP1 34 -#define INST_JUMP4 35 -#define INST_JUMP_TRUE1 36 -#define INST_JUMP_TRUE4 37 -#define INST_JUMP_FALSE1 38 -#define INST_JUMP_FALSE4 39 - -/* Opcodes 40 to 64 */ -#define INST_LOR 40 -#define INST_LAND 41 -#define INST_BITOR 42 -#define INST_BITXOR 43 -#define INST_BITAND 44 -#define INST_EQ 45 -#define INST_NEQ 46 -#define INST_LT 47 -#define INST_GT 48 -#define INST_LE 49 -#define INST_GE 50 -#define INST_LSHIFT 51 -#define INST_RSHIFT 52 -#define INST_ADD 53 -#define INST_SUB 54 -#define INST_MULT 55 -#define INST_DIV 56 -#define INST_MOD 57 -#define INST_UPLUS 58 -#define INST_UMINUS 59 -#define INST_BITNOT 60 -#define INST_LNOT 61 -#define INST_CALL_BUILTIN_FUNC1 62 -#define INST_CALL_FUNC1 63 -#define INST_TRY_CVT_TO_NUMERIC 64 - -/* Opcodes 65 to 66 */ -#define INST_BREAK 65 -#define INST_CONTINUE 66 - -/* Opcodes 67 to 68 */ -#define INST_FOREACH_START4 67 /* DEPRECATED */ -#define INST_FOREACH_STEP4 68 /* DEPRECATED */ - -/* Opcodes 69 to 72 */ -#define INST_BEGIN_CATCH4 69 -#define INST_END_CATCH 70 -#define INST_PUSH_RESULT 71 -#define INST_PUSH_RETURN_CODE 72 - -/* Opcodes 73 to 78 */ -#define INST_STR_EQ 73 -#define INST_STR_NEQ 74 -#define INST_STR_CMP 75 -#define INST_STR_LEN 76 -#define INST_STR_INDEX 77 -#define INST_STR_MATCH 78 - -/* Opcodes 78 to 81 */ -#define INST_LIST 79 -#define INST_LIST_INDEX 80 -#define INST_LIST_LENGTH 81 - -/* Opcodes 82 to 87 */ -#define INST_APPEND_SCALAR1 82 -#define INST_APPEND_SCALAR4 83 -#define INST_APPEND_ARRAY1 84 -#define INST_APPEND_ARRAY4 85 -#define INST_APPEND_ARRAY_STK 86 -#define INST_APPEND_STK 87 - -/* Opcodes 88 to 93 */ -#define INST_LAPPEND_SCALAR1 88 -#define INST_LAPPEND_SCALAR4 89 -#define INST_LAPPEND_ARRAY1 90 -#define INST_LAPPEND_ARRAY4 91 -#define INST_LAPPEND_ARRAY_STK 92 -#define INST_LAPPEND_STK 93 - -/* TIP #22 - LINDEX operator with flat arg list */ - -#define INST_LIST_INDEX_MULTI 94 - -/* - * TIP #33 - 'lset' command. Code gen also required a Forth-like - * OVER operation. - */ - -#define INST_OVER 95 -#define INST_LSET_LIST 96 -#define INST_LSET_FLAT 97 - -/* TIP#90 - 'return' command. */ - -#define INST_RETURN_IMM 98 - -/* TIP#123 - exponentiation operator. */ - -#define INST_EXPON 99 - -/* TIP #157 - {*}... (word expansion) language syntax support. */ - -#define INST_EXPAND_START 100 -#define INST_EXPAND_STKTOP 101 -#define INST_INVOKE_EXPANDED 102 - -/* - * TIP #57 - 'lassign' command. Code generation requires immediate - * LINDEX and LRANGE operators. - */ - -#define INST_LIST_INDEX_IMM 103 -#define INST_LIST_RANGE_IMM 104 - -#define INST_START_CMD 105 - -#define INST_LIST_IN 106 -#define INST_LIST_NOT_IN 107 - -#define INST_PUSH_RETURN_OPTIONS 108 -#define INST_RETURN_STK 109 - -/* - * Dictionary (TIP#111) related commands. - */ - -#define INST_DICT_GET 110 -#define INST_DICT_SET 111 -#define INST_DICT_UNSET 112 -#define INST_DICT_INCR_IMM 113 -#define INST_DICT_APPEND 114 -#define INST_DICT_LAPPEND 115 -#define INST_DICT_FIRST 116 -#define INST_DICT_NEXT 117 -#define INST_DICT_DONE 118 -#define INST_DICT_UPDATE_START 119 -#define INST_DICT_UPDATE_END 120 - -/* - * Instruction to support jumps defined by tables (instead of the classic - * [switch] technique of chained comparisons). - */ - -#define INST_JUMP_TABLE 121 - -/* - * Instructions to support compilation of global, variable, upvar and - * [namespace upvar]. - */ - -#define INST_UPVAR 122 -#define INST_NSUPVAR 123 -#define INST_VARIABLE 124 - -/* Instruction to support compiling syntax error to bytecode */ - -#define INST_SYNTAX 125 - -/* Instruction to reverse N items on top of stack */ - -#define INST_REVERSE 126 - -/* regexp instruction */ - -#define INST_REGEXP 127 - -/* For [info exists] compilation */ -#define INST_EXIST_SCALAR 128 -#define INST_EXIST_ARRAY 129 -#define INST_EXIST_ARRAY_STK 130 -#define INST_EXIST_STK 131 - -/* For [subst] compilation */ -#define INST_NOP 132 -#define INST_RETURN_CODE_BRANCH 133 - -/* For [unset] compilation */ -#define INST_UNSET_SCALAR 134 -#define INST_UNSET_ARRAY 135 -#define INST_UNSET_ARRAY_STK 136 -#define INST_UNSET_STK 137 - -/* For [dict with], [dict exists], [dict create] and [dict merge] */ -#define INST_DICT_EXPAND 138 -#define INST_DICT_RECOMBINE_STK 139 -#define INST_DICT_RECOMBINE_IMM 140 -#define INST_DICT_EXISTS 141 -#define INST_DICT_VERIFY 142 - -/* For [string map] and [regsub] compilation */ -#define INST_STR_MAP 143 -#define INST_STR_FIND 144 -#define INST_STR_FIND_LAST 145 -#define INST_STR_RANGE_IMM 146 -#define INST_STR_RANGE 147 - -/* For operations to do with coroutines and other NRE-manipulators */ -#define INST_YIELD 148 -#define INST_COROUTINE_NAME 149 -#define INST_TAILCALL 150 - -/* For compilation of basic information operations */ -#define INST_NS_CURRENT 151 -#define INST_INFO_LEVEL_NUM 152 -#define INST_INFO_LEVEL_ARGS 153 -#define INST_RESOLVE_COMMAND 154 - -/* For compilation relating to TclOO */ -#define INST_TCLOO_SELF 155 -#define INST_TCLOO_CLASS 156 -#define INST_TCLOO_NS 157 -#define INST_TCLOO_IS_OBJECT 158 - -/* For compilation of [array] subcommands */ -#define INST_ARRAY_EXISTS_STK 159 -#define INST_ARRAY_EXISTS_IMM 160 -#define INST_ARRAY_MAKE_STK 161 -#define INST_ARRAY_MAKE_IMM 162 - -#define INST_INVOKE_REPLACE 163 - -#define INST_LIST_CONCAT 164 - -#define INST_EXPAND_DROP 165 - -/* New foreach implementation */ -#define INST_FOREACH_START 166 -#define INST_FOREACH_STEP 167 -#define INST_FOREACH_END 168 -#define INST_LMAP_COLLECT 169 - -/* For compilation of [string trim] and related */ -#define INST_STR_TRIM 170 -#define INST_STR_TRIM_LEFT 171 -#define INST_STR_TRIM_RIGHT 172 - -#define INST_CONCAT_STK 173 - -#define INST_STR_UPPER 174 -#define INST_STR_LOWER 175 -#define INST_STR_TITLE 176 -#define INST_STR_REPLACE 177 - -#define INST_ORIGIN_COMMAND 178 - -#define INST_TCLOO_NEXT 179 -#define INST_TCLOO_NEXT_CLASS 180 - -#define INST_YIELD_TO_INVOKE 181 - -#define INST_NUM_TYPE 182 -#define INST_TRY_CVT_TO_BOOLEAN 183 -#define INST_STR_CLASS 184 - -#define INST_LAPPEND_LIST 185 -#define INST_LAPPEND_LIST_ARRAY 186 -#define INST_LAPPEND_LIST_ARRAY_STK 187 -#define INST_LAPPEND_LIST_STK 188 - -#define INST_CLOCK_READ 189 - -#define INST_DICT_GET_DEF 190 - -/* TIP 461 */ -#define INST_STR_LT 191 -#define INST_STR_GT 192 -#define INST_STR_LE 193 -#define INST_STR_GE 194 - -#define INST_LREPLACE4 195 - -/* The last opcode */ -#define LAST_INST_OPCODE 195 +enum TclInstruction { + /* Opcodes 0 to 9 */ + INST_DONE = 0, + INST_PUSH1, + INST_PUSH4, + INST_POP, + INST_DUP, + INST_STR_CONCAT1, + INST_INVOKE_STK1, + INST_INVOKE_STK4, + INST_EVAL_STK, + INST_EXPR_STK, + + /* Opcodes 10 to 23 */ + INST_LOAD_SCALAR1, + INST_LOAD_SCALAR4, + INST_LOAD_SCALAR_STK, + INST_LOAD_ARRAY1, + INST_LOAD_ARRAY4, + INST_LOAD_ARRAY_STK, + INST_LOAD_STK, + INST_STORE_SCALAR1, + INST_STORE_SCALAR4, + INST_STORE_SCALAR_STK, + INST_STORE_ARRAY1, + INST_STORE_ARRAY4, + INST_STORE_ARRAY_STK, + INST_STORE_STK, + + /* Opcodes 24 to 33 */ + INST_INCR_SCALAR1, + INST_INCR_SCALAR_STK, + INST_INCR_ARRAY1, + INST_INCR_ARRAY_STK, + INST_INCR_STK, + INST_INCR_SCALAR1_IMM, + INST_INCR_SCALAR_STK_IMM, + INST_INCR_ARRAY1_IMM, + INST_INCR_ARRAY_STK_IMM, + INST_INCR_STK_IMM, + + /* Opcodes 34 to 39 */ + INST_JUMP1, + INST_JUMP4, + INST_JUMP_TRUE1, + INST_JUMP_TRUE4, + INST_JUMP_FALSE1, + INST_JUMP_FALSE4, + + /* Opcodes 42 to 64 */ + INST_BITOR, + INST_BITXOR, + INST_BITAND, + INST_EQ, + INST_NEQ, + INST_LT, + INST_GT, + INST_LE, + INST_GE, + INST_LSHIFT, + INST_RSHIFT, + INST_ADD, + INST_SUB, + INST_MULT, + INST_DIV, + INST_MOD, + INST_UPLUS, + INST_UMINUS, + INST_BITNOT, + INST_LNOT, + INST_TRY_CVT_TO_NUMERIC, + + /* Opcodes 65 to 66 */ + INST_BREAK, + INST_CONTINUE, + + /* Opcodes 69 to 72 */ + INST_BEGIN_CATCH4, + INST_END_CATCH, + INST_PUSH_RESULT, + INST_PUSH_RETURN_CODE, + + /* Opcodes 73 to 78 */ + INST_STR_EQ, + INST_STR_NEQ, + INST_STR_CMP, + INST_STR_LEN, + INST_STR_INDEX, + INST_STR_MATCH, + + /* Opcodes 79 to 81 */ + INST_LIST, + INST_LIST_INDEX, + INST_LIST_LENGTH, + + /* Opcodes 82 to 87 */ + INST_APPEND_SCALAR1, + INST_APPEND_SCALAR4, + INST_APPEND_ARRAY1, + INST_APPEND_ARRAY4, + INST_APPEND_ARRAY_STK, + INST_APPEND_STK, + + /* Opcodes 88 to 93 */ + INST_LAPPEND_SCALAR1, + INST_LAPPEND_SCALAR4, + INST_LAPPEND_ARRAY1, + INST_LAPPEND_ARRAY4, + INST_LAPPEND_ARRAY_STK, + INST_LAPPEND_STK, + + /* TIP #22 - LINDEX operator with flat arg list */ + INST_LIST_INDEX_MULTI, + + /* + * TIP #33 - 'lset' command. Code gen also required a Forth-like + * OVER operation. + */ + INST_OVER, + INST_LSET_LIST, + INST_LSET_FLAT, + + /* TIP#90 - 'return' command. */ + INST_RETURN_IMM, + + /* TIP#123 - exponentiation operator. */ + INST_EXPON, + + /* TIP #157 - {*}... (word expansion) language syntax support. */ + INST_EXPAND_START, + INST_EXPAND_STKTOP, + INST_INVOKE_EXPANDED, + + /* + * TIP #57 - 'lassign' command. Code generation requires immediate + * LINDEX and LRANGE operators. + */ + INST_LIST_INDEX_IMM, + INST_LIST_RANGE_IMM, + INST_START_CMD, + INST_LIST_IN, + INST_LIST_NOT_IN, + INST_PUSH_RETURN_OPTIONS, + INST_RETURN_STK, + + /* + * Dictionary (TIP#111) related commands. + */ + INST_DICT_GET, + INST_DICT_SET, + INST_DICT_UNSET, + INST_DICT_INCR_IMM, + INST_DICT_APPEND, + INST_DICT_LAPPEND, + INST_DICT_FIRST, + INST_DICT_NEXT, + INST_DICT_UPDATE_START, + INST_DICT_UPDATE_END, + + /* + * Instruction to support jumps defined by tables (instead of the classic + * [switch] technique of chained comparisons). + */ + INST_JUMP_TABLE, + + /* + * Instructions to support compilation of global, variable, upvar and + * [namespace upvar]. + */ + INST_UPVAR, + INST_NSUPVAR, + INST_VARIABLE, + + /* Instruction to support compiling syntax error to bytecode */ + INST_SYNTAX, + + /* Instruction to reverse N items on top of stack */ + INST_REVERSE, + + /* regexp instruction */ + INST_REGEXP, + + /* For [info exists] compilation */ + INST_EXIST_SCALAR, + INST_EXIST_ARRAY, + INST_EXIST_ARRAY_STK, + INST_EXIST_STK, + + /* For [subst] compilation */ + INST_NOP, + INST_RETURN_CODE_BRANCH, + + /* For [unset] compilation */ + INST_UNSET_SCALAR, + INST_UNSET_ARRAY, + INST_UNSET_ARRAY_STK, + INST_UNSET_STK, + + /* For [dict with], [dict exists], [dict create] and [dict merge] */ + INST_DICT_EXPAND, + INST_DICT_RECOMBINE_STK, + INST_DICT_RECOMBINE_IMM, + INST_DICT_EXISTS, + INST_DICT_VERIFY, + + /* For [string map] and [regsub] compilation */ + INST_STR_MAP, + INST_STR_FIND, + INST_STR_FIND_LAST, + INST_STR_RANGE_IMM, + INST_STR_RANGE, + + /* For operations to do with coroutines and other NRE-manipulators */ + INST_YIELD, + INST_COROUTINE_NAME, + INST_TAILCALL, + + /* For compilation of basic information operations */ + INST_NS_CURRENT, + INST_INFO_LEVEL_NUM, + INST_INFO_LEVEL_ARGS, + INST_RESOLVE_COMMAND, + + /* For compilation relating to TclOO */ + INST_TCLOO_SELF, + INST_TCLOO_CLASS, + INST_TCLOO_NS, + INST_TCLOO_IS_OBJECT, + + /* For compilation of [array] subcommands */ + INST_ARRAY_EXISTS_STK, + INST_ARRAY_EXISTS_IMM, + INST_ARRAY_MAKE_STK, + INST_ARRAY_MAKE_IMM, + + INST_INVOKE_REPLACE, + + INST_LIST_CONCAT, + + INST_EXPAND_DROP, + + /* New foreach implementation */ + INST_FOREACH_START, + INST_FOREACH_STEP, + INST_FOREACH_END, + INST_LMAP_COLLECT, + + /* For compilation of [string trim] and related */ + INST_STR_TRIM, + INST_STR_TRIM_LEFT, + INST_STR_TRIM_RIGHT, + + INST_CONCAT_STK, + + INST_STR_UPPER, + INST_STR_LOWER, + INST_STR_TITLE, + INST_STR_REPLACE, + + INST_ORIGIN_COMMAND, + + INST_TCLOO_NEXT, + INST_TCLOO_NEXT_CLASS, + + INST_YIELD_TO_INVOKE, + + INST_NUM_TYPE, + INST_TRY_CVT_TO_BOOLEAN, + INST_STR_CLASS, + + INST_LAPPEND_LIST, + INST_LAPPEND_LIST_ARRAY, + INST_LAPPEND_LIST_ARRAY_STK, + INST_LAPPEND_LIST_STK, + + INST_CLOCK_READ, + + INST_DICT_GET_DEF, + + /* TIP 461 */ + INST_STR_LT, + INST_STR_GT, + INST_STR_LE, + INST_STR_GE, + + INST_LREPLACE4, + + /* TIP 667: const */ + INST_CONST_IMM, + INST_CONST_STK, + + /* The last opcode */ + LAST_INST_OPCODE +}; /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -1076,6 +1068,7 @@ typedef struct { *---------------------------------------------------------------- */ +#if TCL_MAJOR_VERSION > 8 MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; /* @@ -1100,15 +1093,15 @@ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int count, + Tcl_Token *tokenPtr, size_t count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, CompileEnv *envPtr, int optimize); MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int numWords, + Tcl_Token *tokenPtr, size_t numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, + Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, size_t numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, @@ -1116,7 +1109,7 @@ MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int count, + Tcl_Token *tokenPtr, size_t count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); @@ -1124,9 +1117,9 @@ MODULE_SCOPE Tcl_Size TclCreateAuxData(void *clientData, const AuxDataType *typePtr, CompileEnv *envPtr); MODULE_SCOPE Tcl_Size TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); -MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, TCL_HASH_TYPE size); +MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, size_t size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, - Tcl_Size length, TCL_HASH_TYPE hash, int *newPtr, + Tcl_Size length, size_t hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); @@ -1140,7 +1133,7 @@ MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); -MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, TCL_HASH_TYPE index); +MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, Tcl_Size index); MODULE_SCOPE Tcl_Size TclFindCompiledLocal(const char *name, Tcl_Size nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, @@ -1149,13 +1142,13 @@ MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, - int before, int after, int *indexPtr); + size_t before, size_t after, int *indexPtr); MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, - TCL_HASH_TYPE numBytes, const CmdFrame *invoker, int word); + size_t numBytes, const CmdFrame *invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, @@ -1170,9 +1163,9 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif -MODULE_SCOPE Tcl_Size TclLocalScalar(const char *bytes, TCL_HASH_TYPE numBytes, +MODULE_SCOPE size_t TclLocalScalar(const char *bytes, size_t numBytes, CompileEnv *envPtr); -MODULE_SCOPE Tcl_Size TclLocalScalarFromToken(Tcl_Token *tokenPtr, +MODULE_SCOPE size_t TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG @@ -1214,6 +1207,8 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int isLambda); +#endif /* TCL_MAJOR_VERSION > 8 */ + /* *---------------------------------------------------------------- @@ -1246,7 +1241,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define TclAdjustStackDepth(delta, envPtr) \ do { \ if ((delta) < 0) { \ - if ((envPtr)->maxStackDepth < (envPtr)->currStackDepth) { \ + if ((int)(envPtr)->maxStackDepth < (int)(envPtr)->currStackDepth) { \ (envPtr)->maxStackDepth = (envPtr)->currStackDepth; \ } \ } \ @@ -1459,7 +1454,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \ TclFixupForwardJump((envPtr), (fixupPtr), \ - (envPtr)->codeNext-(envPtr)->codeStart-(fixupPtr)->codeOffset, \ + (envPtr)->codeNext-(envPtr)->codeStart-(int)(fixupPtr)->codeOffset, \ (threshold)) /* @@ -1509,12 +1504,12 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, * Macros used to compute the minimum and maximum of two values. The ANSI C * "prototypes" for these macros are: * - * int TclMin(int i, int j); - * int TclMax(int i, int j); + * size_t TclMin(size_t i, size_t j); + * size_t TclMax(size_t i, size_t j); */ -#define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) -#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) +#define TclMin(i, j) ((((size_t) i) + 1 < ((size_t) j) + 1 )? (i) : (j)) +#define TclMax(i, j) ((((size_t) i) + 1 > ((size_t) j) + 1 )? (i) : (j)) /* * Convenience macros for use when compiling bodies of commands. The ANSI C @@ -1594,7 +1589,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define ExceptionRangeEnds(envPtr, index) \ (((envPtr)->exceptDepth--), \ ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ - CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)) + CurrentOffset(envPtr) - (int)(envPtr)->exceptArrayPtr[(index)].codeOffset)) #define ExceptionRangeTarget(envPtr, index, targetType) \ ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) @@ -1763,7 +1758,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define TCL_DTRACE_DEBUG_LOG() MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, - int *argsi); + Tcl_Size *argsi); #else /* USE_DTRACE */ @@ -1818,7 +1813,7 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, MODULE_SCOPE int tclDTraceDebugEnabled, tclDTraceDebugIndent; MODULE_SCOPE FILE *tclDTraceDebugLog; MODULE_SCOPE void TclDTraceOpenDebugLog(void); -MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi); +MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, Tcl_Size *argsi); #define TCL_DTRACE_DEBUG_LOG() \ int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED; \ @@ -1856,7 +1851,7 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi); #define TCL_DTRACE_PROC_INFO_ENABLED() 1 #define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) \ tclDTraceDebugIndent++; \ - TclDTraceDbgMsg("-> proc-entry", "%s %d %p", a0, a1, a2) + TclDTraceDbgMsg("-> proc-entry", "%s %" TCL_SIZE_MODIFIER "d %p", a0, a1, a2) #define TCL_DTRACE_PROC_RETURN(a0, a1) \ TclDTraceDbgMsg("<- proc-return", "%s %d", a0, a1); \ tclDTraceDebugIndent-- @@ -1876,7 +1871,7 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi); #define TCL_DTRACE_CMD_INFO_ENABLED() 1 #define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) \ tclDTraceDebugIndent++; \ - TclDTraceDbgMsg("-> cmd-entry", "%s %d %p", a0, a1, a2) + TclDTraceDbgMsg("-> cmd-entry", "%s %" TCL_SIZE_MODIFIER "d %p", a0, a1, a2) #define TCL_DTRACE_CMD_RETURN(a0, a1) \ TclDTraceDbgMsg("<- cmd-return", "%s %d", a0, a1); \ tclDTraceDebugIndent-- @@ -1886,7 +1881,7 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi); TclDTraceDbgMsg(" | cmd-args", "%s %s %s %s %s %s %s %s %s %s", a0, \ a1, a2, a3, a4, a5, a6, a7, a8, a9) #define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ - TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %d %d %s %s", a0, a1, \ + TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %" TCL_SIZE_MODIFIER "d %" TCL_SIZE_MODIFIER "d %s %s", a0, a1, \ a2, a3, a4, a5, a6, a7) #define TCL_DTRACE_INST_START_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 28853a1..9fb2fa7 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -31,7 +31,7 @@ * the (Tcl_Interp *) in which it is stored, and the encoding. */ -typedef struct QCCD { +typedef struct { Tcl_Obj *pkg; Tcl_Interp *interp; char *encoding; @@ -76,11 +76,11 @@ Tcl_RegisterConfig( Tcl_Obj *pDB, *pkgDict; Tcl_DString cmdName; const Tcl_Config *cfg; - QCCD *cdPtr = (QCCD *)ckalloc(sizeof(QCCD)); + QCCD *cdPtr = (QCCD *)Tcl_Alloc(sizeof(QCCD)); cdPtr->interp = interp; if (valEncoding) { - cdPtr->encoding = (char *)ckalloc(strlen(valEncoding)+1); + cdPtr->encoding = (char *)Tcl_Alloc(strlen(valEncoding)+1); strcpy(cdPtr->encoding, valEncoding); } else { cdPtr->encoding = NULL; @@ -191,7 +191,7 @@ Tcl_RegisterConfig( static int QueryConfigObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -199,13 +199,13 @@ QueryConfigObjCmd( QCCD *cdPtr = (QCCD *)clientData; Tcl_Obj *pkgName = cdPtr->pkg; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; - int n, index; + Tcl_Size m, n = 0; static const char *const subcmdStrings[] = { "get", "list", NULL }; enum subcmds { CFG_GET, CFG_LIST - }; + } index; Tcl_DString conv; Tcl_Encoding venc = NULL; const char *value; @@ -233,7 +233,7 @@ QueryConfigObjCmd( return TCL_ERROR; } - switch ((enum subcmds) index) { + switch (index) { case CFG_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "key"); @@ -258,7 +258,10 @@ QueryConfigObjCmd( * Value is stored as-is in a byte array, see Bug [9b2e636361], * so we have to decode it first. */ - value = (const char *) Tcl_GetByteArrayFromObj(val, &n); + value = (const char *) Tcl_GetBytesFromObj(interp, val, &n); + if (value == NULL) { + return TCL_ERROR; + } value = Tcl_ExternalToUtfDString(venc, value, n, &conv); Tcl_SetObjResult(interp, Tcl_NewStringObj(value, Tcl_DStringLength(&conv))); @@ -271,8 +274,8 @@ QueryConfigObjCmd( return TCL_ERROR; } - Tcl_DictObjSize(interp, pkgDict, &n); - listPtr = Tcl_NewListObj(n, NULL); + Tcl_DictObjSize(interp, pkgDict, &m); + listPtr = Tcl_NewListObj(m, NULL); if (!listPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -281,7 +284,7 @@ QueryConfigObjCmd( return TCL_ERROR; } - if (n) { + if (m) { Tcl_DictSearch s; Tcl_Obj *key; int done; @@ -321,7 +324,7 @@ QueryConfigObjCmd( static void QueryConfigDelete( - ClientData clientData) + void *clientData) { QCCD *cdPtr = (QCCD *)clientData; Tcl_Obj *pkgName = cdPtr->pkg; @@ -330,9 +333,9 @@ QueryConfigDelete( Tcl_DictObjRemove(NULL, pDB, pkgName); Tcl_DecrRefCount(pkgName); if (cdPtr->encoding) { - ckfree(cdPtr->encoding); + Tcl_Free(cdPtr->encoding); } - ckfree(cdPtr); + Tcl_Free(cdPtr); } /* @@ -388,7 +391,7 @@ GetConfigDict( static void ConfigDictDeleteProc( - ClientData clientData, /* Pointer to Tcl_Obj. */ + void *clientData, /* Pointer to Tcl_Obj. */ TCL_UNUSED(Tcl_Interp *)) { Tcl_DecrRefCount((Tcl_Obj *)clientData); diff --git a/generic/tclDTrace.d b/generic/tclDTrace.d index f5493b1..c0ef517 100644 --- a/generic/tclDTrace.d +++ b/generic/tclDTrace.d @@ -10,6 +10,8 @@ */ typedef struct Tcl_Obj Tcl_Obj; + +typedef ptrdiff_t Tcl_Size; /* * Tcl DTrace probes @@ -21,10 +23,10 @@ provider tcl { * tcl*:::proc-entry probe * triggered immediately before proc bytecode execution * arg0: proc name (string) - * arg1: number of arguments (int) + * arg1: number of arguments (Tcl_Size) * arg2: array of proc argument objects (Tcl_Obj**) */ - probe proc__entry(const char *name, int objc, struct Tcl_Obj **objv); + probe proc__entry(const char *name, Tcl_Size objc, struct Tcl_Obj **objv); /* * tcl*:::proc-return probe * triggered immediately after proc bytecode execution @@ -62,12 +64,12 @@ provider tcl { * arg2: TIP 280 proc (string) * arg3: TIP 280 file (string) * arg4: TIP 280 line (int) - * arg5: TIP 280 level (int) + * arg5: TIP 280 level (Tcl_Size) * arg6: TclOO method (string) * arg7: TclOO class/object (string) */ probe proc__info(const char *cmd, const char *type, const char *proc, - const char *file, int line, int level, const char *method, + const char *file, int line, Tcl_Size level, const char *method, const char *class); /***************************** cmd probes ******************************/ @@ -75,10 +77,10 @@ provider tcl { * tcl*:::cmd-entry probe * triggered immediately before commmand execution * arg0: command name (string) - * arg1: number of arguments (int) + * arg1: number of arguments (Tcl_Size) * arg2: array of command argument objects (Tcl_Obj**) */ - probe cmd__entry(const char *name, int objc, struct Tcl_Obj **objv); + probe cmd__entry(const char *name, Tcl_Size objc, struct Tcl_Obj **objv); /* * tcl*:::cmd-return probe * triggered immediately after commmand execution @@ -121,7 +123,7 @@ provider tcl { * arg7: TclOO class/object (string) */ probe cmd__info(const char *cmd, const char *type, const char *proc, - const char *file, int line, int level, const char *method, + const char *file, int line, Tcl_Size level, const char *method, const char *class); /***************************** inst probes *****************************/ @@ -129,18 +131,18 @@ provider tcl { * tcl*:::inst-start probe * triggered immediately before execution of a bytecode * arg0: bytecode name (string) - * arg1: depth of stack (int) + * arg1: depth of stack (Tcl_Size) * arg2: top of stack (Tcl_Obj**) */ - probe inst__start(const char *name, int depth, struct Tcl_Obj **stack); + probe inst__start(const char *name, Tcl_Size depth, struct Tcl_Obj **stack); /* * tcl*:::inst-done probe * triggered immediately after execution of a bytecode * arg0: bytecode name (string) - * arg1: depth of stack (int) + * arg1: depth of stack (Tcl_Size) * arg2: top of stack (Tcl_Obj**) */ - probe inst__done(const char *name, int depth, struct Tcl_Obj **stack); + probe inst__done(const char *name, Tcl_Size depth, struct Tcl_Obj **stack); /***************************** obj probes ******************************/ /* @@ -178,12 +180,21 @@ typedef struct Tcl_ObjType { void *dupIntRepProc; void *updateStringProc; void *setFromAnyProc; + size_t version; + void *lengthProc; + void *indexProc; + void *sliceProc; + void *reverseProc; + void *getElementsProc; + void *setElementProc; + void *replaceProc; + void *inOperProc; } Tcl_ObjType; struct Tcl_Obj { - int refCount; + Tcl_Size refCount; char *bytes; - int length; + Tcl_Size length; const Tcl_ObjType *typePtr; union { long longValue; diff --git a/generic/tclDate.c b/generic/tclDate.c index 2f05753..78e65b9 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -145,8 +145,8 @@ typedef struct DateInfo { int dateDigitCount; } DateInfo; -#define YYMALLOC ckalloc -#define YYFREE(x) (ckfree((void*) (x))) +#define YYMALLOC Tcl_Alloc +#define YYFREE(x) (Tcl_Free((void*) (x))) #define yyDSTmode (info->dateDSTmode) #define yyDayOrdinal (info->dateDayOrdinal) @@ -2754,7 +2754,7 @@ TclClockOldscanObjCmd( return TCL_ERROR; } - yyInput = TclGetString( objv[1] ); + yyInput = TclGetString(objv[1]); dateInfo.dateStart = yyInput; yyHaveDate = 0; @@ -2841,26 +2841,25 @@ TclClockOldscanObjCmd( TclNewObj(resultElement); if (yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyYear)); + Tcl_NewIntObj(yyYear)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyMonth)); + Tcl_NewIntObj(yyMonth)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyDay)); + Tcl_NewIntObj(yyDay)); } Tcl_ListObjAppendElement(interp, result, resultElement); if (yyHaveTime) { - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int) + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj( ToSeconds(yyHour, yyMinutes, yySeconds, (MERIDIAN)yyMeridian))); } else { - TclNewObj(resultElement); - Tcl_ListObjAppendElement(interp, result, resultElement); + Tcl_ListObjAppendElement(interp, result, Tcl_NewObj()); } TclNewObj(resultElement); if (yyHaveZone) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) -yyTimezone)); + Tcl_NewIntObj(-yyTimezone)); Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj(1 - yyDSTmode)); } @@ -2869,29 +2868,29 @@ TclClockOldscanObjCmd( TclNewObj(resultElement); if (yyHaveRel) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyRelMonth)); + Tcl_NewIntObj(yyRelMonth)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyRelDay)); + Tcl_NewIntObj(yyRelDay)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyRelSeconds)); + Tcl_NewIntObj(yyRelSeconds)); } Tcl_ListObjAppendElement(interp, result, resultElement); TclNewObj(resultElement); if (yyHaveDay && !yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyDayOrdinal)); + Tcl_NewIntObj(yyDayOrdinal)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyDayNumber)); + Tcl_NewIntObj(yyDayNumber)); } Tcl_ListObjAppendElement(interp, result, resultElement); TclNewObj(resultElement); if (yyHaveOrdinalMonth) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyMonthOrdinal)); + Tcl_NewIntObj(yyMonthOrdinal)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyMonth)); + Tcl_NewIntObj(yyMonth)); } Tcl_ListObjAppendElement(interp, result, resultElement); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 447bd9a..afa29a1 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -14,10 +14,6 @@ #include <stddef.h> /* for size_t */ -#ifdef TCL_NO_DEPRECATED -# define Tcl_SavedResult void -#endif /* TCL_NO_DEPRECATED */ - #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT @@ -65,37 +61,24 @@ EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, /* 2 */ EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ -EXTERN char * Tcl_Alloc(TCL_HASH_TYPE size); +EXTERN void * Tcl_Alloc(TCL_HASH_TYPE size); /* 4 */ -EXTERN void Tcl_Free(char *ptr); +EXTERN void Tcl_Free(void *ptr); /* 5 */ -EXTERN char * Tcl_Realloc(char *ptr, TCL_HASH_TYPE size); +EXTERN void * Tcl_Realloc(void *ptr, TCL_HASH_TYPE size); /* 6 */ -EXTERN char * Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, +EXTERN void * Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line); /* 7 */ -EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line); +EXTERN void Tcl_DbCkfree(void *ptr, const char *file, int line); /* 8 */ -EXTERN char * Tcl_DbCkrealloc(char *ptr, TCL_HASH_TYPE size, +EXTERN void * Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size, const char *file, int line); -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, void *clientData); -#endif /* UNIX */ -#ifdef MAC_OSX_TCL /* MACOSX */ -/* 9 */ -EXTERN void Tcl_CreateFileHandler(int fd, int mask, - Tcl_FileProc *proc, void *clientData); -#endif /* MACOSX */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ -/* 10 */ -EXTERN void Tcl_DeleteFileHandler(int fd); -#endif /* UNIX */ -#ifdef MAC_OSX_TCL /* MACOSX */ /* 10 */ EXTERN void Tcl_DeleteFileHandler(int fd); -#endif /* MACOSX */ /* 11 */ EXTERN void Tcl_SetTimer(const Tcl_Time *timePtr); /* 12 */ @@ -124,10 +107,7 @@ EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, /* 21 */ EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line); -/* 22 */ -TCL_DEPRECATED("No longer in use, changed to macro") -Tcl_Obj * Tcl_DbNewBooleanObj(int intValue, const char *file, - int line); +/* Slot 22 is reserved */ /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes, const char *file, @@ -138,10 +118,7 @@ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, /* 25 */ EXTERN Tcl_Obj * Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv, const char *file, int line); -/* 26 */ -TCL_DEPRECATED("No longer in use, changed to macro") -Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file, - int line); +/* Slot 26 is reserved */ /* 27 */ EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line); /* 28 */ @@ -166,11 +143,7 @@ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, /* 35 */ EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); -/* 36 */ -TCL_DEPRECATED("No longer in use, changed to macro") -int Tcl_GetIndexFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, const char *const *tablePtr, - const char *msg, int flags, int *indexPtr); +/* Slot 36 is reserved */ /* 37 */ EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr); @@ -181,9 +154,9 @@ EXTERN int Tcl_GetIntFromObj(Tcl_Interp *interp, EXTERN int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 40 */ -EXTERN CONST86 Tcl_ObjType * Tcl_GetObjType(const char *typeName); +EXTERN const Tcl_ObjType * Tcl_GetObjType(const char *typeName); /* 41 */ -EXTERN char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr); +EXTERN char * TclGetStringFromObj(Tcl_Obj *objPtr, void *lengthPtr); /* 42 */ EXTERN void Tcl_InvalidateStringRep(Tcl_Obj *objPtr); /* 43 */ @@ -193,44 +166,36 @@ EXTERN int Tcl_ListObjAppendList(Tcl_Interp *interp, EXTERN int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 45 */ -EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp, - Tcl_Obj *listPtr, int *objcPtr, +EXTERN int TclListObjGetElements(Tcl_Interp *interp, + Tcl_Obj *listPtr, void *objcPtr, Tcl_Obj ***objvPtr); /* 46 */ EXTERN int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr); /* 47 */ -EXTERN int Tcl_ListObjLength(Tcl_Interp *interp, - Tcl_Obj *listPtr, int *lengthPtr); +EXTERN int TclListObjLength(Tcl_Interp *interp, + Tcl_Obj *listPtr, void *lengthPtr); /* 48 */ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first, Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[]); -/* 49 */ -TCL_DEPRECATED("No longer in use, changed to macro") -Tcl_Obj * Tcl_NewBooleanObj(int intValue); +/* Slot 49 is reserved */ /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); -/* 52 */ -TCL_DEPRECATED("No longer in use, changed to macro") -Tcl_Obj * Tcl_NewIntObj(int intValue); +/* Slot 52 is reserved */ /* 53 */ EXTERN Tcl_Obj * Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[]); -/* 54 */ -TCL_DEPRECATED("No longer in use, changed to macro") -Tcl_Obj * Tcl_NewLongObj(long longValue); +/* Slot 54 is reserved */ /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj(void); /* 56 */ EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, Tcl_Size length); -/* 57 */ -TCL_DEPRECATED("No longer in use, changed to macro") -void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue); +/* Slot 57 is reserved */ /* 58 */ EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, Tcl_Size numBytes); @@ -240,28 +205,18 @@ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, Tcl_Size numBytes); /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); -/* 61 */ -TCL_DEPRECATED("No longer in use, changed to macro") -void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); +/* Slot 61 is reserved */ /* 62 */ EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[]); -/* 63 */ -TCL_DEPRECATED("No longer in use, changed to macro") -void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue); +/* Slot 63 is reserved */ /* 64 */ EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length); /* 65 */ EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); -/* 66 */ -TCL_DEPRECATED("No longer in use, changed to macro") -void Tcl_AddErrorInfo(Tcl_Interp *interp, - const char *message); -/* 67 */ -TCL_DEPRECATED("No longer in use, changed to macro") -void Tcl_AddObjErrorInfo(Tcl_Interp *interp, - const char *message, Tcl_Size length); +/* Slot 66 is reserved */ +/* Slot 67 is reserved */ /* 68 */ EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp); /* 69 */ @@ -280,12 +235,8 @@ EXTERN int Tcl_AsyncInvoke(Tcl_Interp *interp, int code); EXTERN void Tcl_AsyncMark(Tcl_AsyncHandler async); /* 75 */ EXTERN int Tcl_AsyncReady(void); -/* 76 */ -TCL_DEPRECATED("No longer in use, changed to macro") -void Tcl_BackgroundError(Tcl_Interp *interp); -/* 77 */ -TCL_DEPRECATED("Use Tcl_UtfBackslash") -char Tcl_Backslash(const char *src, int *readPtr); +/* Slot 76 is reserved */ +/* Slot 77 is reserved */ /* 78 */ EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName, @@ -342,12 +293,7 @@ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData); /* 94 */ EXTERN Tcl_Interp * Tcl_CreateInterp(void); -/* 95 */ -TCL_DEPRECATED("") -void Tcl_CreateMathFunc(Tcl_Interp *interp, - const char *name, int numArgs, - Tcl_ValueType *argTypes, Tcl_MathProc *proc, - void *clientData); +/* Slot 95 is reserved */ /* 96 */ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, @@ -435,14 +381,11 @@ EXTERN int Tcl_Eof(Tcl_Channel chan); EXTERN const char * Tcl_ErrnoId(void); /* 128 */ EXTERN const char * Tcl_ErrnoMsg(int err); -/* 129 */ -EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script); +/* Slot 129 is reserved */ /* 130 */ EXTERN int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); -/* 131 */ -TCL_DEPRECATED("No longer in use, changed to macro") -int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +/* Slot 131 is reserved */ /* 132 */ EXTERN void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc); @@ -477,16 +420,13 @@ EXTERN int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, EXTERN int Tcl_ExprString(Tcl_Interp *interp, const char *expr); /* 143 */ EXTERN void Tcl_Finalize(void); -/* 144 */ -EXTERN const char * Tcl_FindExecutable(const char *argv0); +/* Slot 144 is reserved */ /* 145 */ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); -/* 147 */ -TCL_DEPRECATED("see TIP #559. Use Tcl_ResetResult") -void Tcl_FreeResult(Tcl_Interp *interp); +/* Slot 147 is reserved */ /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd, @@ -522,7 +462,7 @@ EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 158 */ -EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); +EXTERN const Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); /* 159 */ EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); @@ -542,18 +482,10 @@ EXTERN Tcl_Interp * Tcl_GetParent(Tcl_Interp *interp); EXTERN const char * Tcl_GetNameOfExecutable(void); /* 166 */ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ -/* 167 */ -EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, - const char *chanID, int forWriting, - int checkUsage, void **filePtr); -#endif /* UNIX */ -#ifdef MAC_OSX_TCL /* MACOSX */ /* 167 */ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); -#endif /* MACOSX */ /* 168 */ EXTERN Tcl_PathType Tcl_GetPathType(const char *path); /* 169 */ @@ -566,22 +498,13 @@ EXTERN int Tcl_GetServiceMode(void); EXTERN Tcl_Interp * Tcl_GetChild(Tcl_Interp *interp, const char *name); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); -/* 174 */ -EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp); -/* 175 */ -TCL_DEPRECATED("No longer in use, changed to macro") -const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName, - int flags); +/* Slot 174 is reserved */ +/* Slot 175 is reserved */ /* 176 */ EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); -/* 177 */ -EXTERN int Tcl_GlobalEval(Tcl_Interp *interp, - const char *command); -/* 178 */ -TCL_DEPRECATED("No longer in use, changed to macro") -int Tcl_GlobalEvalObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); +/* Slot 177 is reserved */ +/* Slot 178 is reserved */ /* 179 */ EXTERN int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName, @@ -608,9 +531,7 @@ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, /* Slot 188 is reserved */ /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode); -/* 190 */ -TCL_DEPRECATED("") -int Tcl_MakeSafe(Tcl_Interp *interp); +/* Slot 190 is reserved */ /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket); /* 192 */ @@ -690,9 +611,7 @@ EXTERN Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr); /* 219 */ EXTERN Tcl_Size Tcl_ScanCountedElement(const char *src, Tcl_Size length, int *flagPtr); -/* 220 */ -TCL_DEPRECATED("") -int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); +/* Slot 220 is reserved */ /* 221 */ EXTERN int Tcl_ServiceAll(void); /* 222 */ @@ -718,15 +637,11 @@ EXTERN void Tcl_SetErrno(int err); EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...); /* 229 */ EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr); -/* 230 */ -EXTERN const char * Tcl_SetPanicProc( - TCL_NORETURN1 Tcl_PanicProc *panicProc); +/* Slot 230 is reserved */ /* 231 */ EXTERN Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp, Tcl_Size depth); -/* 232 */ -EXTERN void Tcl_SetResult(Tcl_Interp *interp, char *result, - Tcl_FreeProc *freeProc); +/* Slot 232 is reserved */ /* 233 */ EXTERN int Tcl_SetServiceMode(int mode); /* 234 */ @@ -737,10 +652,7 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 236 */ EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type); -/* 237 */ -TCL_DEPRECATED("No longer in use, changed to macro") -const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName, - const char *newValue, int flags); +/* Slot 237 is reserved */ /* 238 */ EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, @@ -752,28 +664,15 @@ EXTERN const char * Tcl_SignalMsg(int sig); /* 241 */ EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp); /* 242 */ -EXTERN int Tcl_SplitList(Tcl_Interp *interp, - const char *listStr, int *argcPtr, - const char ***argvPtr); +EXTERN int TclSplitList(Tcl_Interp *interp, const char *listStr, + void *argcPtr, const char ***argvPtr); /* 243 */ -EXTERN void Tcl_SplitPath(const char *path, int *argcPtr, +EXTERN void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr); -/* 244 */ -EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp, - const char *prefix, - Tcl_LibraryInitProc *initProc, - Tcl_LibraryInitProc *safeInitProc); -/* 245 */ -TCL_DEPRECATED("No longer in use, changed to macro") -int Tcl_StringMatch(const char *str, const char *pattern); -/* 246 */ -TCL_DEPRECATED("") -int Tcl_TellOld(Tcl_Channel chan); -/* 247 */ -TCL_DEPRECATED("No longer in use, changed to macro") -int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, - int flags, Tcl_VarTraceProc *proc, - void *clientData); +/* Slot 244 is reserved */ +/* Slot 245 is reserved */ +/* Slot 246 is reserved */ +/* Slot 247 is reserved */ /* 248 */ EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, @@ -790,18 +689,11 @@ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp, /* 252 */ EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan); -/* 253 */ -TCL_DEPRECATED("No longer in use, changed to macro") -int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, - int flags); +/* Slot 253 is reserved */ /* 254 */ EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); -/* 255 */ -TCL_DEPRECATED("No longer in use, changed to macro") -void Tcl_UntraceVar(Tcl_Interp *interp, - const char *varName, int flags, - Tcl_VarTraceProc *proc, void *clientData); +/* Slot 255 is reserved */ /* 256 */ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, @@ -810,23 +702,14 @@ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp, /* 257 */ EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName); -/* 258 */ -TCL_DEPRECATED("No longer in use, changed to macro") -int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, - const char *varName, const char *localName, - int flags); +/* Slot 258 is reserved */ /* 259 */ EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 260 */ EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...); -/* 261 */ -TCL_DEPRECATED("No longer in use, changed to macro") -void * Tcl_VarTraceInfo(Tcl_Interp *interp, - const char *varName, int flags, - Tcl_VarTraceProc *procPtr, - void *prevClientData); +/* Slot 261 is reserved */ /* 262 */ EXTERN void * Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, const char *part2, @@ -842,47 +725,25 @@ EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, Tcl_Size objc, EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); -/* 267 */ -TCL_DEPRECATED("see TIP #422") -void Tcl_AppendResultVA(Tcl_Interp *interp, - va_list argList); -/* 268 */ -TCL_DEPRECATED("see TIP #422") -void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, - va_list argList); +/* Slot 267 is reserved */ +/* Slot 268 is reserved */ /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, const char **termPtr); -/* 271 */ -TCL_DEPRECATED("No longer in use, changed to macro") -const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name, - const char *version, int exact); +/* Slot 271 is reserved */ /* 272 */ EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); -/* 273 */ -TCL_DEPRECATED("No longer in use, changed to macro") -int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, - const char *version); -/* 274 */ -TCL_DEPRECATED("No longer in use, changed to macro") -const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name, - const char *version, int exact); -/* 275 */ -TCL_DEPRECATED("see TIP #422") -void Tcl_SetErrorCodeVA(Tcl_Interp *interp, - va_list argList); -/* 276 */ -TCL_DEPRECATED("see TIP #422") -int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); +/* Slot 273 is reserved */ +/* Slot 274 is reserved */ +/* Slot 275 is reserved */ +/* Slot 276 is reserved */ /* 277 */ EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options); -/* 278 */ -TCL_DEPRECATED("see TIP #422") -TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); +/* Slot 278 is reserved */ /* 279 */ EXTERN void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type); @@ -912,9 +773,7 @@ EXTERN void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, /* 289 */ EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData); -/* 290 */ -TCL_DEPRECATED("Use Tcl_DiscardInterpState") -void Tcl_DiscardResult(Tcl_SavedResult *statePtr); +/* Slot 290 is reserved */ /* 291 */ EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags); @@ -974,18 +833,12 @@ EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr); EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 312 */ -EXTERN Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length); +EXTERN Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length); /* 313 */ EXTERN Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, Tcl_Size charsToRead, int appendFlag); -/* 314 */ -TCL_DEPRECATED("Use Tcl_RestoreInterpState") -void Tcl_RestoreResult(Tcl_Interp *interp, - Tcl_SavedResult *statePtr); -/* 315 */ -TCL_DEPRECATED("Use Tcl_SaveInterpState") -void Tcl_SaveResult(Tcl_Interp *interp, - Tcl_SavedResult *statePtr); +/* Slot 314 is reserved */ +/* Slot 315 is reserved */ /* 316 */ EXTERN int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name); @@ -1009,7 +862,7 @@ EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN Tcl_Size Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ -EXTERN const char * Tcl_UtfAtIndex(const char *src, Tcl_Size index); +EXTERN const char * TclUtfAtIndex(const char *src, Tcl_Size index); /* 326 */ EXTERN int TclUtfCharComplete(const char *src, Tcl_Size length); /* 327 */ @@ -1050,12 +903,8 @@ EXTERN Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, EXTERN Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); -/* 341 */ -TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath") -const char * Tcl_GetDefaultEncodingDir(void); -/* 342 */ -TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath") -void Tcl_SetDefaultEncodingDir(const char *path); +/* Slot 341 is reserved */ +/* Slot 342 is reserved */ /* 343 */ EXTERN void Tcl_AlertNotifier(void *clientData); /* 344 */ @@ -1076,11 +925,7 @@ EXTERN int Tcl_UniCharIsUpper(int ch); EXTERN int Tcl_UniCharIsWordChar(int ch); /* 352 */ EXTERN Tcl_Size Tcl_Char16Len(const unsigned short *uniStr); -/* 353 */ -TCL_DEPRECATED("Use Tcl_UtfNcmp") -int Tcl_UniCharNcmp(const unsigned short *ucs, - const unsigned short *uct, - unsigned long numChars); +/* Slot 353 is reserved */ /* 354 */ EXTERN char * Tcl_Char16ToUtfDString(const unsigned short *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); @@ -1090,10 +935,7 @@ EXTERN unsigned short * Tcl_UtfToChar16DString(const char *src, /* 356 */ EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); -/* 357 */ -TCL_DEPRECATED("Use Tcl_EvalTokensStandard") -Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Size count); +/* Slot 357 is reserved */ /* 358 */ EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr); /* 359 */ @@ -1130,11 +972,10 @@ EXTERN int Tcl_Access(const char *path, int mode); /* 368 */ EXTERN int Tcl_Stat(const char *path, struct stat *bufPtr); /* 369 */ -EXTERN int Tcl_UtfNcmp(const char *s1, const char *s2, - unsigned long n); +EXTERN int TclUtfNcmp(const char *s1, const char *s2, size_t n); /* 370 */ -EXTERN int Tcl_UtfNcasecmp(const char *s1, const char *s2, - unsigned long n); +EXTERN int TclUtfNcasecmp(const char *s1, const char *s2, + size_t n); /* 371 */ EXTERN int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase); @@ -1155,26 +996,23 @@ EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp, EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 378 */ -EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const unsigned short *unicode, +EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, Tcl_Size numChars); /* 379 */ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, - const unsigned short *unicode, + const Tcl_UniChar *unicode, Tcl_Size numChars); /* 380 */ -EXTERN Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr); +EXTERN Tcl_Size TclGetCharLength(Tcl_Obj *objPtr); /* 381 */ -EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index); -/* 382 */ -TCL_DEPRECATED("No longer in use, changed to macro") -unsigned short * Tcl_GetUnicode(Tcl_Obj *objPtr); +EXTERN int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index); +/* Slot 382 is reserved */ /* 383 */ -EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, +EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 384 */ EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, - const unsigned short *unicode, - Tcl_Size length); + const Tcl_UniChar *unicode, Tcl_Size length); /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); @@ -1217,10 +1055,7 @@ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion( /* 400 */ EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc( const Tcl_ChannelType *chanTypePtr); -/* 401 */ -TCL_DEPRECATED("Use Tcl_ChannelClose2Proc") -Tcl_DriverCloseProc * Tcl_ChannelCloseProc( - const Tcl_ChannelType *chanTypePtr); +/* Slot 401 is reserved */ /* 402 */ EXTERN Tcl_DriverClose2Proc * Tcl_ChannelClose2Proc( const Tcl_ChannelType *chanTypePtr); @@ -1230,10 +1065,7 @@ EXTERN Tcl_DriverInputProc * Tcl_ChannelInputProc( /* 404 */ EXTERN Tcl_DriverOutputProc * Tcl_ChannelOutputProc( const Tcl_ChannelType *chanTypePtr); -/* 405 */ -TCL_DEPRECATED("Use Tcl_ChannelWideSeekProc") -Tcl_DriverSeekProc * Tcl_ChannelSeekProc( - const Tcl_ChannelType *chanTypePtr); +/* Slot 405 is reserved */ /* 406 */ EXTERN Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc( const Tcl_ChannelType *chanTypePtr); @@ -1267,21 +1099,10 @@ EXTERN void Tcl_SpliceChannel(Tcl_Channel channel); EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ EXTERN int Tcl_IsChannelExisting(const char *channelName); -/* 419 */ -TCL_DEPRECATED("Use Tcl_UtfNcasecmp") -int Tcl_UniCharNcasecmp(const unsigned short *ucs, - const unsigned short *uct, - unsigned long numChars); -/* 420 */ -TCL_DEPRECATED("Use Tcl_StringCaseMatch") -int Tcl_UniCharCaseMatch(const unsigned short *uniStr, - const unsigned short *uniPattern, int nocase); -/* 421 */ -EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr, - const void *key); -/* 422 */ -EXTERN Tcl_HashEntry * Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, - const void *key, int *newPtr); +/* Slot 419 is reserved */ +/* Slot 420 is reserved */ +/* Slot 421 is reserved */ +/* Slot 422 is reserved */ /* 423 */ EXTERN void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); @@ -1301,14 +1122,14 @@ EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 428 */ -EXTERN char * Tcl_AttemptAlloc(TCL_HASH_TYPE size); +EXTERN void * Tcl_AttemptAlloc(TCL_HASH_TYPE size); /* 429 */ -EXTERN char * Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, +EXTERN void * Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line); /* 430 */ -EXTERN char * Tcl_AttemptRealloc(char *ptr, TCL_HASH_TYPE size); +EXTERN void * Tcl_AttemptRealloc(void *ptr, TCL_HASH_TYPE size); /* 431 */ -EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, TCL_HASH_TYPE size, +EXTERN void * Tcl_AttemptDbCkrealloc(void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 432 */ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, @@ -1316,18 +1137,10 @@ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ -EXTERN unsigned short * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, - int *lengthPtr); -/* 435 */ -TCL_DEPRECATED("") -int Tcl_GetMathFuncInfo(Tcl_Interp *interp, - const char *name, int *numArgsPtr, - Tcl_ValueType **argTypesPtr, - Tcl_MathProc **procPtr, void **clientDataPtr); -/* 436 */ -TCL_DEPRECATED("") -Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, - const char *pattern); +EXTERN Tcl_UniChar * TclGetUnicodeFromObj(Tcl_Obj *objPtr, + void *lengthPtr); +/* Slot 435 is reserved */ +/* Slot 436 is reserved */ /* 437 */ EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); @@ -1377,7 +1190,7 @@ EXTERN int Tcl_FSFileAttrsGet(Tcl_Interp *interp, int index, EXTERN int Tcl_FSFileAttrsSet(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); /* 453 */ -EXTERN const char *CONST86 * Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, +EXTERN const char *const * Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 454 */ EXTERN int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); @@ -1397,7 +1210,7 @@ EXTERN int Tcl_FSConvertToPathType(Tcl_Interp *interp, /* 460 */ EXTERN Tcl_Obj * Tcl_FSJoinPath(Tcl_Obj *listObj, Tcl_Size elements); /* 461 */ -EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr); +EXTERN Tcl_Obj * TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr); /* 462 */ EXTERN int Tcl_FSEqualPaths(Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); @@ -1438,7 +1251,7 @@ EXTERN void * Tcl_FSData(const Tcl_Filesystem *fsPtr); EXTERN const char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 477 */ -EXTERN CONST86 Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr); +EXTERN const Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr); /* 478 */ EXTERN Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr); /* 479 */ @@ -1493,8 +1306,8 @@ EXTERN int Tcl_DictObjGet(Tcl_Interp *interp, Tcl_Obj *dictPtr, EXTERN int Tcl_DictObjRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); /* 497 */ -EXTERN int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, - int *sizePtr); +EXTERN int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, + void *sizePtr); /* 498 */ EXTERN int Tcl_DictObjFirst(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr, @@ -1561,8 +1374,7 @@ EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, /* 518 */ EXTERN int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); -/* 519 */ -EXTERN Tcl_ExitProc * Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); +/* Slot 519 is reserved */ /* 520 */ EXTERN void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, @@ -1800,8 +1612,8 @@ EXTERN int Tcl_SetEnsembleParameterList(Tcl_Interp *interp, EXTERN int Tcl_GetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 604 */ -EXTERN int Tcl_ParseArgsObjv(Tcl_Interp *interp, - const Tcl_ArgvInfo *argTable, int *objcPtr, +EXTERN int TclParseArgsObjv(Tcl_Interp *interp, + const Tcl_ArgvInfo *argTable, void *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 605 */ EXTERN int Tcl_GetErrorLine(Tcl_Interp *interp); @@ -1932,12 +1744,20 @@ EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, EXTERN int * Tcl_UtfToUniCharDString(const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 649 */ +EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, void *numBytesPtr); +/* 650 */ EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *numBytesPtr); -/* Slot 650 is reserved */ -/* Slot 651 is reserved */ -/* Slot 652 is reserved */ -/* Slot 653 is reserved */ + Tcl_Obj *objPtr, Tcl_Size *numBytesPtr); +/* 651 */ +EXTERN char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, + Tcl_Size *lengthPtr); +/* 652 */ +EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, + Tcl_Size *lengthPtr); +/* 653 */ +EXTERN int Tcl_GetSizeIntFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Size *sizePtr); /* 654 */ EXTERN int Tcl_UtfCharComplete(const char *src, Tcl_Size length); /* 655 */ @@ -1961,36 +1781,69 @@ EXTERN int Tcl_UtfToExternalDStringEx(Tcl_Interp *interp, /* 660 */ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber); -/* Slot 661 is reserved */ -/* Slot 662 is reserved */ -/* Slot 663 is reserved */ -/* Slot 664 is reserved */ -/* Slot 665 is reserved */ -/* Slot 666 is reserved */ -/* Slot 667 is reserved */ +/* 661 */ +EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp, + Tcl_Obj *listPtr, Tcl_Size *objcPtr, + Tcl_Obj ***objvPtr); +/* 662 */ +EXTERN int Tcl_ListObjLength(Tcl_Interp *interp, + Tcl_Obj *listPtr, Tcl_Size *lengthPtr); +/* 663 */ +EXTERN int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, + Tcl_Size *sizePtr); +/* 664 */ +EXTERN int Tcl_SplitList(Tcl_Interp *interp, + const char *listStr, Tcl_Size *argcPtr, + const char ***argvPtr); +/* 665 */ +EXTERN void Tcl_SplitPath(const char *path, Tcl_Size *argcPtr, + const char ***argvPtr); +/* 666 */ +EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr); +/* 667 */ +EXTERN int Tcl_ParseArgsObjv(Tcl_Interp *interp, + const Tcl_ArgvInfo *argTable, + Tcl_Size *objcPtr, Tcl_Obj *const *objv, + Tcl_Obj ***remObjv); /* 668 */ EXTERN Tcl_Size Tcl_UniCharLen(const int *uniStr); /* 669 */ -EXTERN Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length); +EXTERN Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length); /* 670 */ -EXTERN Tcl_Size TclGetCharLength(Tcl_Obj *objPtr); +EXTERN Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr); /* 671 */ -EXTERN const char * TclUtfAtIndex(const char *src, Tcl_Size index); +EXTERN const char * Tcl_UtfAtIndex(const char *src, Tcl_Size index); /* 672 */ -EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, +EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 673 */ -EXTERN int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index); +EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index); /* 674 */ EXTERN int Tcl_GetBool(Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 675 */ EXTERN int Tcl_GetBoolFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); -/* Slot 676 is reserved */ -/* Slot 677 is reserved */ -/* Slot 678 is reserved */ -/* Slot 679 is reserved */ +/* 676 */ +EXTERN Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp, + const char *cmdName, Tcl_ObjCmdProc2 *proc2, + void *clientData, + Tcl_CmdDeleteProc *deleteProc); +/* 677 */ +EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, + Tcl_Size level, int flags, + Tcl_CmdObjTraceProc2 *objProc2, + void *clientData, + Tcl_CmdObjTraceDeleteProc *delProc); +/* 678 */ +EXTERN Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp, + const char *cmdName, Tcl_ObjCmdProc2 *proc, + Tcl_ObjCmdProc2 *nreProc2, void *clientData, + Tcl_CmdDeleteProc *deleteProc); +/* 679 */ +EXTERN int Tcl_NRCallObjProc2(Tcl_Interp *interp, + Tcl_ObjCmdProc2 *objProc2, void *clientData, + Tcl_Size objc, Tcl_Obj *const objv[]); /* 680 */ EXTERN int Tcl_GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, @@ -2010,9 +1863,9 @@ EXTERN int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, /* 685 */ EXTERN Tcl_Obj * Tcl_DStringToObj(Tcl_DString *dsPtr); /* 686 */ -EXTERN int TclUtfNcmp(const char *s1, const char *s2, size_t n); +EXTERN int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n); /* 687 */ -EXTERN int TclUtfNcasecmp(const char *s1, const char *s2, +EXTERN int Tcl_UtfNcasecmp(const char *s1, const char *s2, size_t n); /* 688 */ EXTERN void TclUnusedStubEntry(void); @@ -2030,30 +1883,14 @@ typedef struct TclStubs { int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ - char * (*tcl_Alloc) (TCL_HASH_TYPE size); /* 3 */ - void (*tcl_Free) (char *ptr); /* 4 */ - char * (*tcl_Realloc) (char *ptr, TCL_HASH_TYPE size); /* 5 */ - char * (*tcl_DbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 6 */ - void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */ - char * (*tcl_DbCkrealloc) (char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 8 */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ + void * (*tcl_Alloc) (TCL_HASH_TYPE size); /* 3 */ + void (*tcl_Free) (void *ptr); /* 4 */ + void * (*tcl_Realloc) (void *ptr, TCL_HASH_TYPE size); /* 5 */ + void * (*tcl_DbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 6 */ + void (*tcl_DbCkfree) (void *ptr, const char *file, int line); /* 7 */ + void * (*tcl_DbCkrealloc) (void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 8 */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */ -#endif /* UNIX */ -#if defined(_WIN32) /* WIN */ - void (*reserved9)(void); -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ - void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */ -#endif /* MACOSX */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*tcl_DeleteFileHandler) (int fd); /* 10 */ -#endif /* UNIX */ -#if defined(_WIN32) /* WIN */ - void (*reserved10)(void); -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ void (*tcl_DeleteFileHandler) (int fd); /* 10 */ -#endif /* MACOSX */ void (*tcl_SetTimer) (const Tcl_Time *timePtr); /* 11 */ void (*tcl_Sleep) (int ms); /* 12 */ int (*tcl_WaitForEvent) (const Tcl_Time *timePtr); /* 13 */ @@ -2065,11 +1902,11 @@ typedef struct TclStubs { void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int intValue, const char *file, int line); /* 22 */ + void (*reserved22)(void); Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (Tcl_Size objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */ + void (*reserved26)(void); Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, Tcl_Size length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ @@ -2079,38 +1916,38 @@ typedef struct TclStubs { unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, Tcl_Size *numBytesPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ + void (*reserved36)(void); int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */ int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */ int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */ - CONST86 Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */ - char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 41 */ + const Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */ + char * (*tclGetStringFromObj) (Tcl_Obj *objPtr, void *lengthPtr); /* 41 */ void (*tcl_InvalidateStringRep) (Tcl_Obj *objPtr); /* 42 */ int (*tcl_ListObjAppendList) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 43 */ int (*tcl_ListObjAppendElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 44 */ - int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 45 */ + int (*tclListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, void *objcPtr, Tcl_Obj ***objvPtr); /* 45 */ int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr); /* 46 */ - int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ + int (*tclListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, void *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first, Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[]); /* 48 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int intValue); /* 49 */ + void (*reserved49)(void); Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ + void (*reserved52)(void); Tcl_Obj * (*tcl_NewListObj) (Tcl_Size objc, Tcl_Obj *const objv[]); /* 53 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ + void (*reserved54)(void); Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, Tcl_Size length); /* 56 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int intValue); /* 57 */ + void (*reserved57)(void); unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, Tcl_Size numBytes); /* 58 */ void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, Tcl_Size numBytes); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ + void (*reserved61)(void); void (*tcl_SetListObj) (Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[]); /* 62 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */ + void (*reserved63)(void); void (*tcl_SetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 64 */ void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); /* 65 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, Tcl_Size length); /* 67 */ + void (*reserved66)(void); + void (*reserved67)(void); void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */ void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */ void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */ @@ -2119,8 +1956,8 @@ typedef struct TclStubs { int (*tcl_AsyncInvoke) (Tcl_Interp *interp, int code); /* 73 */ void (*tcl_AsyncMark) (Tcl_AsyncHandler async); /* 74 */ int (*tcl_AsyncReady) (void); /* 75 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */ - TCL_DEPRECATED_API("Use Tcl_UtfBackslash") char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */ + void (*reserved76)(void); + void (*reserved77)(void); int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */ void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 79 */ void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, void *clientData); /* 80 */ @@ -2138,7 +1975,7 @@ typedef struct TclStubs { void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 92 */ void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 93 */ Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */ - TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, void *clientData); /* 95 */ + void (*reserved95)(void); Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 98 */ @@ -2172,9 +2009,9 @@ typedef struct TclStubs { int (*tcl_Eof) (Tcl_Channel chan); /* 126 */ const char * (*tcl_ErrnoId) (void); /* 127 */ const char * (*tcl_ErrnoMsg) (int err); /* 128 */ - int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ + void (*reserved129)(void); int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ + void (*reserved131)(void); void (*tcl_EventuallyFree) (void *clientData, Tcl_FreeProc *freeProc); /* 132 */ TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */ int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */ @@ -2187,10 +2024,10 @@ typedef struct TclStubs { int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */ int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */ void (*tcl_Finalize) (void); /* 143 */ - TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") const char * (*tcl_FindExecutable) (const char *argv0); /* 144 */ + void (*reserved144)(void); Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ - TCL_DEPRECATED_API("see TIP #559. Use Tcl_ResetResult") void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ + void (*reserved147)(void); int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ void * (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ @@ -2201,7 +2038,7 @@ typedef struct TclStubs { int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */ const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */ - CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ + const Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */ const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ @@ -2210,26 +2047,18 @@ typedef struct TclStubs { Tcl_Interp * (*tcl_GetParent) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */ -#endif /* UNIX */ -#if defined(_WIN32) /* WIN */ - void (*reserved167)(void); -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ - int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */ -#endif /* MACOSX */ Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */ Tcl_Size (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ Tcl_Size (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ int (*tcl_GetServiceMode) (void); /* 171 */ Tcl_Interp * (*tcl_GetChild) (Tcl_Interp *interp, const char *name); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ - const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ + void (*reserved174)(void); + void (*reserved175)(void); const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ - int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */ + void (*reserved177)(void); + void (*reserved178)(void); int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */ int (*tcl_Init) (Tcl_Interp *interp); /* 180 */ void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */ @@ -2241,7 +2070,7 @@ typedef struct TclStubs { int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */ void (*reserved188)(void); Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */ - TCL_DEPRECATED_API("") int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ + void (*reserved190)(void); Tcl_Channel (*tcl_MakeTcpClientChannel) (void *tcpSocket); /* 191 */ char * (*tcl_Merge) (Tcl_Size argc, const char *const *argv); /* 192 */ Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */ @@ -2271,7 +2100,7 @@ typedef struct TclStubs { void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ Tcl_Size (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ Tcl_Size (*tcl_ScanCountedElement) (const char *src, Tcl_Size length, int *flagPtr); /* 219 */ - TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ + void (*reserved220)(void); int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 223 */ @@ -2281,55 +2110,55 @@ typedef struct TclStubs { void (*tcl_SetErrno) (int err); /* 227 */ void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */ void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */ - TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") const char * (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */ + void (*reserved230)(void); Tcl_Size (*tcl_SetRecursionLimit) (Tcl_Interp *interp, Tcl_Size depth); /* 231 */ - void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */ + void (*reserved232)(void); int (*tcl_SetServiceMode) (int mode); /* 233 */ void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */ void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */ void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ + void (*reserved237)(void); const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ const char * (*tcl_SignalId) (int sig); /* 239 */ const char * (*tcl_SignalMsg) (int sig); /* 240 */ void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */ - int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */ - void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */ - TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_StaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 244 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ - TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 247 */ + int (*tclSplitList) (Tcl_Interp *interp, const char *listStr, void *argcPtr, const char ***argvPtr); /* 242 */ + void (*tclSplitPath) (const char *path, void *argcPtr, const char ***argvPtr); /* 243 */ + void (*reserved244)(void); + void (*reserved245)(void); + void (*reserved246)(void); + void (*reserved247)(void); int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ Tcl_Size (*tcl_Ungets) (Tcl_Channel chan, const char *str, Tcl_Size len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ + void (*reserved253)(void); int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 255 */ + void (*reserved255)(void); void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 256 */ void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ + void (*reserved258)(void); int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */ int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") void * (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 261 */ + void (*reserved261)(void); void * (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 262 */ Tcl_Size (*tcl_Write) (Tcl_Channel chan, const char *s, Tcl_Size slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ - TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ - TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ + void (*reserved267)(void); + void (*reserved268)(void); char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ + void (*reserved271)(void); const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ - TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ - TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ + void (*reserved273)(void); + void (*reserved274)(void); + void (*reserved275)(void); + void (*reserved276)(void); Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ - TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ + void (*reserved278)(void); void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */ void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */ Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, void *instanceData, int mask, Tcl_Channel prevChan); /* 281 */ @@ -2341,7 +2170,7 @@ typedef struct TclStubs { Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */ void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */ void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */ - TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */ + void (*reserved290)(void); int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags); /* 291 */ int (*tcl_EvalObjv) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ @@ -2363,10 +2192,10 @@ typedef struct TclStubs { void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */ void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */ void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */ - Tcl_Size (*tcl_NumUtfChars) (const char *src, Tcl_Size length); /* 312 */ + Tcl_Size (*tclNumUtfChars) (const char *src, Tcl_Size length); /* 312 */ Tcl_Size (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, Tcl_Size charsToRead, int appendFlag); /* 313 */ - TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */ - TCL_DEPRECATED_API("Use Tcl_SaveInterpState") void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */ + void (*reserved314)(void); + void (*reserved315)(void); int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */ Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */ void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ @@ -2376,7 +2205,7 @@ typedef struct TclStubs { int (*tcl_UniCharToTitle) (int ch); /* 322 */ int (*tcl_UniCharToUpper) (int ch); /* 323 */ Tcl_Size (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - const char * (*tcl_UtfAtIndex) (const char *src, Tcl_Size index); /* 325 */ + const char * (*tclUtfAtIndex) (const char *src, Tcl_Size index); /* 325 */ int (*tclUtfCharComplete) (const char *src, Tcl_Size length); /* 326 */ Tcl_Size (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ @@ -2392,8 +2221,8 @@ typedef struct TclStubs { Tcl_Size (*tcl_WriteChars) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 338 */ Tcl_Size (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ - TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ - TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ + void (*reserved341)(void); + void (*reserved342)(void); void (*tcl_AlertNotifier) (void *clientData); /* 343 */ void (*tcl_ServiceModeHook) (int mode); /* 344 */ int (*tcl_UniCharIsAlnum) (int ch); /* 345 */ @@ -2404,11 +2233,11 @@ typedef struct TclStubs { int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ Tcl_Size (*tcl_Char16Len) (const unsigned short *uniStr); /* 352 */ - TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */ + void (*reserved353)(void); char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 354 */ unsigned short * (*tcl_UtfToChar16DString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ - TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count); /* 357 */ + void (*reserved357)(void); void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */ void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, Tcl_Size length); /* 359 */ int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */ @@ -2420,8 +2249,8 @@ typedef struct TclStubs { int (*tcl_Chdir) (const char *dirName); /* 366 */ int (*tcl_Access) (const char *path, int mode); /* 367 */ int (*tcl_Stat) (const char *path, struct stat *bufPtr); /* 368 */ - int (*tcl_UtfNcmp) (const char *s1, const char *s2, unsigned long n); /* 369 */ - int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, unsigned long n); /* 370 */ + int (*tclUtfNcmp) (const char *s1, const char *s2, size_t n); /* 369 */ + int (*tclUtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 370 */ int (*tcl_StringCaseMatch) (const char *str, const char *pattern, int nocase); /* 371 */ int (*tcl_UniCharIsControl) (int ch); /* 372 */ int (*tcl_UniCharIsGraph) (int ch); /* 373 */ @@ -2429,13 +2258,13 @@ typedef struct TclStubs { int (*tcl_UniCharIsPunct) (int ch); /* 375 */ int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, Tcl_Size offset, Tcl_Size nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ - Tcl_Obj * (*tcl_NewUnicodeObj) (const unsigned short *unicode, Tcl_Size numChars); /* 378 */ - void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const unsigned short *unicode, Tcl_Size numChars); /* 379 */ - Tcl_Size (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ - int (*tcl_GetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 381 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") unsigned short * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ - Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 383 */ - void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, Tcl_Size length); /* 384 */ + Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, Tcl_Size numChars); /* 378 */ + void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size numChars); /* 379 */ + Tcl_Size (*tclGetCharLength) (Tcl_Obj *objPtr); /* 380 */ + int (*tclGetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 381 */ + void (*reserved382)(void); + Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 383 */ + void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ @@ -2452,11 +2281,11 @@ typedef struct TclStubs { const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */ Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */ - TCL_DEPRECATED_API("Use Tcl_ChannelClose2Proc") Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */ + void (*reserved401)(void); Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) (const Tcl_ChannelType *chanTypePtr); /* 402 */ Tcl_DriverInputProc * (*tcl_ChannelInputProc) (const Tcl_ChannelType *chanTypePtr); /* 403 */ Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) (const Tcl_ChannelType *chanTypePtr); /* 404 */ - TCL_DEPRECATED_API("Use Tcl_ChannelWideSeekProc") Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 405 */ + void (*reserved405)(void); Tcl_DriverSetOptionProc * (*tcl_ChannelSetOptionProc) (const Tcl_ChannelType *chanTypePtr); /* 406 */ Tcl_DriverGetOptionProc * (*tcl_ChannelGetOptionProc) (const Tcl_ChannelType *chanTypePtr); /* 407 */ Tcl_DriverWatchProc * (*tcl_ChannelWatchProc) (const Tcl_ChannelType *chanTypePtr); /* 408 */ @@ -2470,24 +2299,24 @@ typedef struct TclStubs { void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */ void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ - TCL_DEPRECATED_API("Use Tcl_UtfNcasecmp") int (*tcl_UniCharNcasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */ - TCL_DEPRECATED_API("Use Tcl_StringCaseMatch") int (*tcl_UniCharCaseMatch) (const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 420 */ - Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, const void *key); /* 421 */ - Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */ + void (*reserved419)(void); + void (*reserved420)(void); + void (*reserved421)(void); + void (*reserved422)(void); void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */ void (*tcl_InitObjHashTable) (Tcl_HashTable *tablePtr); /* 424 */ void * (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 425 */ int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 426 */ void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */ - char * (*tcl_AttemptAlloc) (TCL_HASH_TYPE size); /* 428 */ - char * (*tcl_AttemptDbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 429 */ - char * (*tcl_AttemptRealloc) (char *ptr, TCL_HASH_TYPE size); /* 430 */ - char * (*tcl_AttemptDbCkrealloc) (char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 431 */ + void * (*tcl_AttemptAlloc) (TCL_HASH_TYPE size); /* 428 */ + void * (*tcl_AttemptDbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 429 */ + void * (*tcl_AttemptRealloc) (void *ptr, TCL_HASH_TYPE size); /* 430 */ + void * (*tcl_AttemptDbCkrealloc) (void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 431 */ int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ - unsigned short * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ - TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, void **clientDataPtr); /* 435 */ - TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ + Tcl_UniChar * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, void *lengthPtr); /* 434 */ + void (*reserved435)(void); + void (*reserved436)(void); Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */ int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */ int (*tcl_IsStandardChannel) (Tcl_Channel channel); /* 439 */ @@ -2504,7 +2333,7 @@ typedef struct TclStubs { int (*tcl_FSUtime) (Tcl_Obj *pathPtr, struct utimbuf *tval); /* 450 */ int (*tcl_FSFileAttrsGet) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 451 */ int (*tcl_FSFileAttrsSet) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); /* 452 */ - const char *CONST86 * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */ + const char *const * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */ int (*tcl_FSStat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 454 */ int (*tcl_FSAccess) (Tcl_Obj *pathPtr, int mode); /* 455 */ Tcl_Channel (*tcl_FSOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *modeString, int permissions); /* 456 */ @@ -2512,7 +2341,7 @@ typedef struct TclStubs { int (*tcl_FSChdir) (Tcl_Obj *pathPtr); /* 458 */ int (*tcl_FSConvertToPathType) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 459 */ Tcl_Obj * (*tcl_FSJoinPath) (Tcl_Obj *listObj, Tcl_Size elements); /* 460 */ - Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, int *lenPtr); /* 461 */ + Tcl_Obj * (*tclFSSplitPath) (Tcl_Obj *pathPtr, void *lenPtr); /* 461 */ int (*tcl_FSEqualPaths) (Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); /* 462 */ Tcl_Obj * (*tcl_FSGetNormalizedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 463 */ Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, Tcl_Size objc, Tcl_Obj *const objv[]); /* 464 */ @@ -2528,7 +2357,7 @@ typedef struct TclStubs { int (*tcl_FSUnregister) (const Tcl_Filesystem *fsPtr); /* 474 */ void * (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */ const char * (*tcl_FSGetTranslatedStringPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 476 */ - CONST86 Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */ + const Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */ Tcl_PathType (*tcl_FSGetPathType) (Tcl_Obj *pathPtr); /* 478 */ int (*tcl_OutputBuffered) (Tcl_Channel chan); /* 479 */ void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */ @@ -2548,7 +2377,7 @@ typedef struct TclStubs { int (*tcl_DictObjPut) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj *valuePtr); /* 494 */ int (*tcl_DictObjGet) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj **valuePtrPtr); /* 495 */ int (*tcl_DictObjRemove) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); /* 496 */ - int (*tcl_DictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr); /* 497 */ + int (*tclDictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, void *sizePtr); /* 497 */ int (*tcl_DictObjFirst) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 498 */ void (*tcl_DictObjNext) (Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 499 */ void (*tcl_DictObjDone) (Tcl_DictSearch *searchPtr); /* 500 */ @@ -2570,7 +2399,7 @@ typedef struct TclStubs { Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 516 */ void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */ int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */ - TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */ + void (*reserved519)(void); void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */ void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData); /* 521 */ int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */ @@ -2655,7 +2484,7 @@ typedef struct TclStubs { unsigned (*tcl_GetBlockSizeFromStat) (const Tcl_StatBuf *statPtr); /* 601 */ int (*tcl_SetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *paramList); /* 602 */ int (*tcl_GetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 603 */ - int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 604 */ + int (*tclParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, void *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 604 */ int (*tcl_GetErrorLine) (Tcl_Interp *interp); /* 605 */ void (*tcl_SetErrorLine) (Tcl_Interp *interp, int lineNum); /* 606 */ void (*tcl_TransferResult) (Tcl_Interp *sourceInterp, int code, Tcl_Interp *targetInterp); /* 607 */ @@ -2700,11 +2529,11 @@ typedef struct TclStubs { Tcl_Size (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ char * (*tcl_UniCharToUtfDString) (const int *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 647 */ int * (*tcl_UtfToUniCharDString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 648 */ - unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */ - void (*reserved650)(void); - void (*reserved651)(void); - void (*reserved652)(void); - void (*reserved653)(void); + unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void *numBytesPtr); /* 649 */ + unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *numBytesPtr); /* 650 */ + char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 651 */ + Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 652 */ + int (*tcl_GetSizeIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *sizePtr); /* 653 */ int (*tcl_UtfCharComplete) (const char *src, Tcl_Size length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ @@ -2712,33 +2541,33 @@ typedef struct TclStubs { int (*tcl_ExternalToUtfDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 658 */ int (*tcl_UtfToExternalDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 659 */ int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ - void (*reserved661)(void); - void (*reserved662)(void); - void (*reserved663)(void); - void (*reserved664)(void); - void (*reserved665)(void); - void (*reserved666)(void); - void (*reserved667)(void); + int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 661 */ + int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size *lengthPtr); /* 662 */ + int (*tcl_DictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size *sizePtr); /* 663 */ + int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, Tcl_Size *argcPtr, const char ***argvPtr); /* 664 */ + void (*tcl_SplitPath) (const char *path, Tcl_Size *argcPtr, const char ***argvPtr); /* 665 */ + Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, Tcl_Size *lenPtr); /* 666 */ + int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, Tcl_Size *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 667 */ Tcl_Size (*tcl_UniCharLen) (const int *uniStr); /* 668 */ - Tcl_Size (*tclNumUtfChars) (const char *src, Tcl_Size length); /* 669 */ - Tcl_Size (*tclGetCharLength) (Tcl_Obj *objPtr); /* 670 */ - const char * (*tclUtfAtIndex) (const char *src, Tcl_Size index); /* 671 */ - Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 672 */ - int (*tclGetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 673 */ + Tcl_Size (*tcl_NumUtfChars) (const char *src, Tcl_Size length); /* 669 */ + Tcl_Size (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 670 */ + const char * (*tcl_UtfAtIndex) (const char *src, Tcl_Size index); /* 671 */ + Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 672 */ + int (*tcl_GetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 673 */ int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 674 */ int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); /* 675 */ - void (*reserved676)(void); - void (*reserved677)(void); - void (*reserved678)(void); - void (*reserved679)(void); + Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */ + Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ + Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */ + int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, Tcl_Size objc, Tcl_Obj *const objv[]); /* 679 */ int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */ int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, Tcl_Size numBytes, void **clientDataPtr, int *typePtr); /* 681 */ int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */ Tcl_Size (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */ int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */ Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */ - int (*tclUtfNcmp) (const char *s1, const char *s2, size_t n); /* 686 */ - int (*tclUtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 687 */ + int (*tcl_UtfNcmp) (const char *s1, const char *s2, size_t n); /* 686 */ + int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 687 */ void (*tclUnusedStubEntry) (void); /* 688 */ } TclStubs; @@ -2772,22 +2601,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DbCkfree) /* 7 */ #define Tcl_DbCkrealloc \ (tclStubsPtr->tcl_DbCkrealloc) /* 8 */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ -#define Tcl_CreateFileHandler \ - (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ -#endif /* UNIX */ -#ifdef MAC_OSX_TCL /* MACOSX */ #define Tcl_CreateFileHandler \ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ -#endif /* MACOSX */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ -#define Tcl_DeleteFileHandler \ - (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ -#endif /* UNIX */ -#ifdef MAC_OSX_TCL /* MACOSX */ #define Tcl_DeleteFileHandler \ (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ -#endif /* MACOSX */ #define Tcl_SetTimer \ (tclStubsPtr->tcl_SetTimer) /* 11 */ #define Tcl_Sleep \ @@ -2810,16 +2627,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DbIncrRefCount) /* 20 */ #define Tcl_DbIsShared \ (tclStubsPtr->tcl_DbIsShared) /* 21 */ -#define Tcl_DbNewBooleanObj \ - (tclStubsPtr->tcl_DbNewBooleanObj) /* 22 */ +/* Slot 22 is reserved */ #define Tcl_DbNewByteArrayObj \ (tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */ #define Tcl_DbNewDoubleObj \ (tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */ #define Tcl_DbNewListObj \ (tclStubsPtr->tcl_DbNewListObj) /* 25 */ -#define Tcl_DbNewLongObj \ - (tclStubsPtr->tcl_DbNewLongObj) /* 26 */ +/* Slot 26 is reserved */ #define Tcl_DbNewObj \ (tclStubsPtr->tcl_DbNewObj) /* 27 */ #define Tcl_DbNewStringObj \ @@ -2838,8 +2653,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetDouble) /* 34 */ #define Tcl_GetDoubleFromObj \ (tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */ -#define Tcl_GetIndexFromObj \ - (tclStubsPtr->tcl_GetIndexFromObj) /* 36 */ +/* Slot 36 is reserved */ #define Tcl_GetInt \ (tclStubsPtr->tcl_GetInt) /* 37 */ #define Tcl_GetIntFromObj \ @@ -2848,60 +2662,52 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetLongFromObj) /* 39 */ #define Tcl_GetObjType \ (tclStubsPtr->tcl_GetObjType) /* 40 */ -#define Tcl_GetStringFromObj \ - (tclStubsPtr->tcl_GetStringFromObj) /* 41 */ +#define TclGetStringFromObj \ + (tclStubsPtr->tclGetStringFromObj) /* 41 */ #define Tcl_InvalidateStringRep \ (tclStubsPtr->tcl_InvalidateStringRep) /* 42 */ #define Tcl_ListObjAppendList \ (tclStubsPtr->tcl_ListObjAppendList) /* 43 */ #define Tcl_ListObjAppendElement \ (tclStubsPtr->tcl_ListObjAppendElement) /* 44 */ -#define Tcl_ListObjGetElements \ - (tclStubsPtr->tcl_ListObjGetElements) /* 45 */ +#define TclListObjGetElements \ + (tclStubsPtr->tclListObjGetElements) /* 45 */ #define Tcl_ListObjIndex \ (tclStubsPtr->tcl_ListObjIndex) /* 46 */ -#define Tcl_ListObjLength \ - (tclStubsPtr->tcl_ListObjLength) /* 47 */ +#define TclListObjLength \ + (tclStubsPtr->tclListObjLength) /* 47 */ #define Tcl_ListObjReplace \ (tclStubsPtr->tcl_ListObjReplace) /* 48 */ -#define Tcl_NewBooleanObj \ - (tclStubsPtr->tcl_NewBooleanObj) /* 49 */ +/* Slot 49 is reserved */ #define Tcl_NewByteArrayObj \ (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */ #define Tcl_NewDoubleObj \ (tclStubsPtr->tcl_NewDoubleObj) /* 51 */ -#define Tcl_NewIntObj \ - (tclStubsPtr->tcl_NewIntObj) /* 52 */ +/* Slot 52 is reserved */ #define Tcl_NewListObj \ (tclStubsPtr->tcl_NewListObj) /* 53 */ -#define Tcl_NewLongObj \ - (tclStubsPtr->tcl_NewLongObj) /* 54 */ +/* Slot 54 is reserved */ #define Tcl_NewObj \ (tclStubsPtr->tcl_NewObj) /* 55 */ #define Tcl_NewStringObj \ (tclStubsPtr->tcl_NewStringObj) /* 56 */ -#define Tcl_SetBooleanObj \ - (tclStubsPtr->tcl_SetBooleanObj) /* 57 */ +/* Slot 57 is reserved */ #define Tcl_SetByteArrayLength \ (tclStubsPtr->tcl_SetByteArrayLength) /* 58 */ #define Tcl_SetByteArrayObj \ (tclStubsPtr->tcl_SetByteArrayObj) /* 59 */ #define Tcl_SetDoubleObj \ (tclStubsPtr->tcl_SetDoubleObj) /* 60 */ -#define Tcl_SetIntObj \ - (tclStubsPtr->tcl_SetIntObj) /* 61 */ +/* Slot 61 is reserved */ #define Tcl_SetListObj \ (tclStubsPtr->tcl_SetListObj) /* 62 */ -#define Tcl_SetLongObj \ - (tclStubsPtr->tcl_SetLongObj) /* 63 */ +/* Slot 63 is reserved */ #define Tcl_SetObjLength \ (tclStubsPtr->tcl_SetObjLength) /* 64 */ #define Tcl_SetStringObj \ (tclStubsPtr->tcl_SetStringObj) /* 65 */ -#define Tcl_AddErrorInfo \ - (tclStubsPtr->tcl_AddErrorInfo) /* 66 */ -#define Tcl_AddObjErrorInfo \ - (tclStubsPtr->tcl_AddObjErrorInfo) /* 67 */ +/* Slot 66 is reserved */ +/* Slot 67 is reserved */ #define Tcl_AllowExceptions \ (tclStubsPtr->tcl_AllowExceptions) /* 68 */ #define Tcl_AppendElement \ @@ -2918,10 +2724,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_AsyncMark) /* 74 */ #define Tcl_AsyncReady \ (tclStubsPtr->tcl_AsyncReady) /* 75 */ -#define Tcl_BackgroundError \ - (tclStubsPtr->tcl_BackgroundError) /* 76 */ -#define Tcl_Backslash \ - (tclStubsPtr->tcl_Backslash) /* 77 */ +/* Slot 76 is reserved */ +/* Slot 77 is reserved */ #define Tcl_BadChannelOption \ (tclStubsPtr->tcl_BadChannelOption) /* 78 */ #define Tcl_CallWhenDeleted \ @@ -2956,8 +2760,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_CreateExitHandler) /* 93 */ #define Tcl_CreateInterp \ (tclStubsPtr->tcl_CreateInterp) /* 94 */ -#define Tcl_CreateMathFunc \ - (tclStubsPtr->tcl_CreateMathFunc) /* 95 */ +/* Slot 95 is reserved */ #define Tcl_CreateObjCommand \ (tclStubsPtr->tcl_CreateObjCommand) /* 96 */ #define Tcl_CreateChild \ @@ -3024,12 +2827,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ErrnoId) /* 127 */ #define Tcl_ErrnoMsg \ (tclStubsPtr->tcl_ErrnoMsg) /* 128 */ -#define Tcl_Eval \ - (tclStubsPtr->tcl_Eval) /* 129 */ +/* Slot 129 is reserved */ #define Tcl_EvalFile \ (tclStubsPtr->tcl_EvalFile) /* 130 */ -#define Tcl_EvalObj \ - (tclStubsPtr->tcl_EvalObj) /* 131 */ +/* Slot 131 is reserved */ #define Tcl_EventuallyFree \ (tclStubsPtr->tcl_EventuallyFree) /* 132 */ #define Tcl_Exit \ @@ -3054,14 +2855,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ExprString) /* 142 */ #define Tcl_Finalize \ (tclStubsPtr->tcl_Finalize) /* 143 */ -#define Tcl_FindExecutable \ - (tclStubsPtr->tcl_FindExecutable) /* 144 */ +/* Slot 144 is reserved */ #define Tcl_FirstHashEntry \ (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ #define Tcl_Flush \ (tclStubsPtr->tcl_Flush) /* 146 */ -#define Tcl_FreeResult \ - (tclStubsPtr->tcl_FreeResult) /* 147 */ +/* Slot 147 is reserved */ #define Tcl_GetAlias \ (tclStubsPtr->tcl_GetAlias) /* 148 */ #define Tcl_GetAliasObj \ @@ -3100,14 +2899,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #define Tcl_GetObjResult \ (tclStubsPtr->tcl_GetObjResult) /* 166 */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ -#define Tcl_GetOpenFile \ - (tclStubsPtr->tcl_GetOpenFile) /* 167 */ -#endif /* UNIX */ -#ifdef MAC_OSX_TCL /* MACOSX */ #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ -#endif /* MACOSX */ #define Tcl_GetPathType \ (tclStubsPtr->tcl_GetPathType) /* 168 */ #define Tcl_Gets \ @@ -3120,16 +2913,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetChild) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ -#define Tcl_GetStringResult \ - (tclStubsPtr->tcl_GetStringResult) /* 174 */ -#define Tcl_GetVar \ - (tclStubsPtr->tcl_GetVar) /* 175 */ +/* Slot 174 is reserved */ +/* Slot 175 is reserved */ #define Tcl_GetVar2 \ (tclStubsPtr->tcl_GetVar2) /* 176 */ -#define Tcl_GlobalEval \ - (tclStubsPtr->tcl_GlobalEval) /* 177 */ -#define Tcl_GlobalEvalObj \ - (tclStubsPtr->tcl_GlobalEvalObj) /* 178 */ +/* Slot 177 is reserved */ +/* Slot 178 is reserved */ #define Tcl_HideCommand \ (tclStubsPtr->tcl_HideCommand) /* 179 */ #define Tcl_Init \ @@ -3151,8 +2940,7 @@ extern const TclStubs *tclStubsPtr; /* Slot 188 is reserved */ #define Tcl_MakeFileChannel \ (tclStubsPtr->tcl_MakeFileChannel) /* 189 */ -#define Tcl_MakeSafe \ - (tclStubsPtr->tcl_MakeSafe) /* 190 */ +/* Slot 190 is reserved */ #define Tcl_MakeTcpClientChannel \ (tclStubsPtr->tcl_MakeTcpClientChannel) /* 191 */ #define Tcl_Merge \ @@ -3211,8 +2999,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ScanElement) /* 218 */ #define Tcl_ScanCountedElement \ (tclStubsPtr->tcl_ScanCountedElement) /* 219 */ -#define Tcl_SeekOld \ - (tclStubsPtr->tcl_SeekOld) /* 220 */ +/* Slot 220 is reserved */ #define Tcl_ServiceAll \ (tclStubsPtr->tcl_ServiceAll) /* 221 */ #define Tcl_ServiceEvent \ @@ -3231,12 +3018,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetErrorCode) /* 228 */ #define Tcl_SetMaxBlockTime \ (tclStubsPtr->tcl_SetMaxBlockTime) /* 229 */ -#define Tcl_SetPanicProc \ - (tclStubsPtr->tcl_SetPanicProc) /* 230 */ +/* Slot 230 is reserved */ #define Tcl_SetRecursionLimit \ (tclStubsPtr->tcl_SetRecursionLimit) /* 231 */ -#define Tcl_SetResult \ - (tclStubsPtr->tcl_SetResult) /* 232 */ +/* Slot 232 is reserved */ #define Tcl_SetServiceMode \ (tclStubsPtr->tcl_SetServiceMode) /* 233 */ #define Tcl_SetObjErrorCode \ @@ -3245,8 +3030,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetObjResult) /* 235 */ #define Tcl_SetStdChannel \ (tclStubsPtr->tcl_SetStdChannel) /* 236 */ -#define Tcl_SetVar \ - (tclStubsPtr->tcl_SetVar) /* 237 */ +/* Slot 237 is reserved */ #define Tcl_SetVar2 \ (tclStubsPtr->tcl_SetVar2) /* 238 */ #define Tcl_SignalId \ @@ -3255,18 +3039,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SignalMsg) /* 240 */ #define Tcl_SourceRCFile \ (tclStubsPtr->tcl_SourceRCFile) /* 241 */ -#define Tcl_SplitList \ - (tclStubsPtr->tcl_SplitList) /* 242 */ -#define Tcl_SplitPath \ - (tclStubsPtr->tcl_SplitPath) /* 243 */ -#define Tcl_StaticLibrary \ - (tclStubsPtr->tcl_StaticLibrary) /* 244 */ -#define Tcl_StringMatch \ - (tclStubsPtr->tcl_StringMatch) /* 245 */ -#define Tcl_TellOld \ - (tclStubsPtr->tcl_TellOld) /* 246 */ -#define Tcl_TraceVar \ - (tclStubsPtr->tcl_TraceVar) /* 247 */ +#define TclSplitList \ + (tclStubsPtr->tclSplitList) /* 242 */ +#define TclSplitPath \ + (tclStubsPtr->tclSplitPath) /* 243 */ +/* Slot 244 is reserved */ +/* Slot 245 is reserved */ +/* Slot 246 is reserved */ +/* Slot 247 is reserved */ #define Tcl_TraceVar2 \ (tclStubsPtr->tcl_TraceVar2) /* 248 */ #define Tcl_TranslateFileName \ @@ -3277,24 +3057,20 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UnlinkVar) /* 251 */ #define Tcl_UnregisterChannel \ (tclStubsPtr->tcl_UnregisterChannel) /* 252 */ -#define Tcl_UnsetVar \ - (tclStubsPtr->tcl_UnsetVar) /* 253 */ +/* Slot 253 is reserved */ #define Tcl_UnsetVar2 \ (tclStubsPtr->tcl_UnsetVar2) /* 254 */ -#define Tcl_UntraceVar \ - (tclStubsPtr->tcl_UntraceVar) /* 255 */ +/* Slot 255 is reserved */ #define Tcl_UntraceVar2 \ (tclStubsPtr->tcl_UntraceVar2) /* 256 */ #define Tcl_UpdateLinkedVar \ (tclStubsPtr->tcl_UpdateLinkedVar) /* 257 */ -#define Tcl_UpVar \ - (tclStubsPtr->tcl_UpVar) /* 258 */ +/* Slot 258 is reserved */ #define Tcl_UpVar2 \ (tclStubsPtr->tcl_UpVar2) /* 259 */ #define Tcl_VarEval \ (tclStubsPtr->tcl_VarEval) /* 260 */ -#define Tcl_VarTraceInfo \ - (tclStubsPtr->tcl_VarTraceInfo) /* 261 */ +/* Slot 261 is reserved */ #define Tcl_VarTraceInfo2 \ (tclStubsPtr->tcl_VarTraceInfo2) /* 262 */ #define Tcl_Write \ @@ -3305,30 +3081,22 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DumpActiveMemory) /* 265 */ #define Tcl_ValidateAllMemory \ (tclStubsPtr->tcl_ValidateAllMemory) /* 266 */ -#define Tcl_AppendResultVA \ - (tclStubsPtr->tcl_AppendResultVA) /* 267 */ -#define Tcl_AppendStringsToObjVA \ - (tclStubsPtr->tcl_AppendStringsToObjVA) /* 268 */ +/* Slot 267 is reserved */ +/* Slot 268 is reserved */ #define Tcl_HashStats \ (tclStubsPtr->tcl_HashStats) /* 269 */ #define Tcl_ParseVar \ (tclStubsPtr->tcl_ParseVar) /* 270 */ -#define Tcl_PkgPresent \ - (tclStubsPtr->tcl_PkgPresent) /* 271 */ +/* Slot 271 is reserved */ #define Tcl_PkgPresentEx \ (tclStubsPtr->tcl_PkgPresentEx) /* 272 */ -#define Tcl_PkgProvide \ - (tclStubsPtr->tcl_PkgProvide) /* 273 */ -#define Tcl_PkgRequire \ - (tclStubsPtr->tcl_PkgRequire) /* 274 */ -#define Tcl_SetErrorCodeVA \ - (tclStubsPtr->tcl_SetErrorCodeVA) /* 275 */ -#define Tcl_VarEvalVA \ - (tclStubsPtr->tcl_VarEvalVA) /* 276 */ +/* Slot 273 is reserved */ +/* Slot 274 is reserved */ +/* Slot 275 is reserved */ +/* Slot 276 is reserved */ #define Tcl_WaitPid \ (tclStubsPtr->tcl_WaitPid) /* 277 */ -#define Tcl_PanicVA \ - (tclStubsPtr->tcl_PanicVA) /* 278 */ +/* Slot 278 is reserved */ #define Tcl_GetVersion \ (tclStubsPtr->tcl_GetVersion) /* 279 */ #define Tcl_InitMemory \ @@ -3350,8 +3118,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */ #define Tcl_DeleteThreadExitHandler \ (tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */ -#define Tcl_DiscardResult \ - (tclStubsPtr->tcl_DiscardResult) /* 290 */ +/* Slot 290 is reserved */ #define Tcl_EvalEx \ (tclStubsPtr->tcl_EvalEx) /* 291 */ #define Tcl_EvalObjv \ @@ -3394,14 +3161,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ConditionNotify) /* 310 */ #define Tcl_ConditionWait \ (tclStubsPtr->tcl_ConditionWait) /* 311 */ -#define Tcl_NumUtfChars \ - (tclStubsPtr->tcl_NumUtfChars) /* 312 */ +#define TclNumUtfChars \ + (tclStubsPtr->tclNumUtfChars) /* 312 */ #define Tcl_ReadChars \ (tclStubsPtr->tcl_ReadChars) /* 313 */ -#define Tcl_RestoreResult \ - (tclStubsPtr->tcl_RestoreResult) /* 314 */ -#define Tcl_SaveResult \ - (tclStubsPtr->tcl_SaveResult) /* 315 */ +/* Slot 314 is reserved */ +/* Slot 315 is reserved */ #define Tcl_SetSystemEncoding \ (tclStubsPtr->tcl_SetSystemEncoding) /* 316 */ #define Tcl_SetVar2Ex \ @@ -3420,8 +3185,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUpper) /* 323 */ #define Tcl_UniCharToUtf \ (tclStubsPtr->tcl_UniCharToUtf) /* 324 */ -#define Tcl_UtfAtIndex \ - (tclStubsPtr->tcl_UtfAtIndex) /* 325 */ +#define TclUtfAtIndex \ + (tclStubsPtr->tclUtfAtIndex) /* 325 */ #define TclUtfCharComplete \ (tclStubsPtr->tclUtfCharComplete) /* 326 */ #define Tcl_UtfBackslash \ @@ -3452,10 +3217,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_WriteObj) /* 339 */ #define Tcl_GetString \ (tclStubsPtr->tcl_GetString) /* 340 */ -#define Tcl_GetDefaultEncodingDir \ - (tclStubsPtr->tcl_GetDefaultEncodingDir) /* 341 */ -#define Tcl_SetDefaultEncodingDir \ - (tclStubsPtr->tcl_SetDefaultEncodingDir) /* 342 */ +/* Slot 341 is reserved */ +/* Slot 342 is reserved */ #define Tcl_AlertNotifier \ (tclStubsPtr->tcl_AlertNotifier) /* 343 */ #define Tcl_ServiceModeHook \ @@ -3476,16 +3239,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ #define Tcl_Char16Len \ (tclStubsPtr->tcl_Char16Len) /* 352 */ -#define Tcl_UniCharNcmp \ - (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ +/* Slot 353 is reserved */ #define Tcl_Char16ToUtfDString \ (tclStubsPtr->tcl_Char16ToUtfDString) /* 354 */ #define Tcl_UtfToChar16DString \ (tclStubsPtr->tcl_UtfToChar16DString) /* 355 */ #define Tcl_GetRegExpFromObj \ (tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */ -#define Tcl_EvalTokens \ - (tclStubsPtr->tcl_EvalTokens) /* 357 */ +/* Slot 357 is reserved */ #define Tcl_FreeParse \ (tclStubsPtr->tcl_FreeParse) /* 358 */ #define Tcl_LogCommandInfo \ @@ -3508,10 +3269,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_Access) /* 367 */ #define Tcl_Stat \ (tclStubsPtr->tcl_Stat) /* 368 */ -#define Tcl_UtfNcmp \ - (tclStubsPtr->tcl_UtfNcmp) /* 369 */ -#define Tcl_UtfNcasecmp \ - (tclStubsPtr->tcl_UtfNcasecmp) /* 370 */ +#define TclUtfNcmp \ + (tclStubsPtr->tclUtfNcmp) /* 369 */ +#define TclUtfNcasecmp \ + (tclStubsPtr->tclUtfNcasecmp) /* 370 */ #define Tcl_StringCaseMatch \ (tclStubsPtr->tcl_StringCaseMatch) /* 371 */ #define Tcl_UniCharIsControl \ @@ -3530,14 +3291,13 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ -#define Tcl_GetCharLength \ - (tclStubsPtr->tcl_GetCharLength) /* 380 */ -#define Tcl_GetUniChar \ - (tclStubsPtr->tcl_GetUniChar) /* 381 */ -#define Tcl_GetUnicode \ - (tclStubsPtr->tcl_GetUnicode) /* 382 */ -#define Tcl_GetRange \ - (tclStubsPtr->tcl_GetRange) /* 383 */ +#define TclGetCharLength \ + (tclStubsPtr->tclGetCharLength) /* 380 */ +#define TclGetUniChar \ + (tclStubsPtr->tclGetUniChar) /* 381 */ +/* Slot 382 is reserved */ +#define TclGetRange \ + (tclStubsPtr->tclGetRange) /* 383 */ #define Tcl_AppendUnicodeToObj \ (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */ #define Tcl_RegExpMatchObj \ @@ -3572,16 +3332,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ChannelVersion) /* 399 */ #define Tcl_ChannelBlockModeProc \ (tclStubsPtr->tcl_ChannelBlockModeProc) /* 400 */ -#define Tcl_ChannelCloseProc \ - (tclStubsPtr->tcl_ChannelCloseProc) /* 401 */ +/* Slot 401 is reserved */ #define Tcl_ChannelClose2Proc \ (tclStubsPtr->tcl_ChannelClose2Proc) /* 402 */ #define Tcl_ChannelInputProc \ (tclStubsPtr->tcl_ChannelInputProc) /* 403 */ #define Tcl_ChannelOutputProc \ (tclStubsPtr->tcl_ChannelOutputProc) /* 404 */ -#define Tcl_ChannelSeekProc \ - (tclStubsPtr->tcl_ChannelSeekProc) /* 405 */ +/* Slot 405 is reserved */ #define Tcl_ChannelSetOptionProc \ (tclStubsPtr->tcl_ChannelSetOptionProc) /* 406 */ #define Tcl_ChannelGetOptionProc \ @@ -3608,14 +3366,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */ #define Tcl_IsChannelExisting \ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ -#define Tcl_UniCharNcasecmp \ - (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */ -#define Tcl_UniCharCaseMatch \ - (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */ -#define Tcl_FindHashEntry \ - (tclStubsPtr->tcl_FindHashEntry) /* 421 */ -#define Tcl_CreateHashEntry \ - (tclStubsPtr->tcl_CreateHashEntry) /* 422 */ +/* Slot 419 is reserved */ +/* Slot 420 is reserved */ +/* Slot 421 is reserved */ +/* Slot 422 is reserved */ #define Tcl_InitCustomHashTable \ (tclStubsPtr->tcl_InitCustomHashTable) /* 423 */ #define Tcl_InitObjHashTable \ @@ -3638,12 +3392,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */ #define Tcl_GetChannelThread \ (tclStubsPtr->tcl_GetChannelThread) /* 433 */ -#define Tcl_GetUnicodeFromObj \ - (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */ -#define Tcl_GetMathFuncInfo \ - (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */ -#define Tcl_ListMathFuncs \ - (tclStubsPtr->tcl_ListMathFuncs) /* 436 */ +#define TclGetUnicodeFromObj \ + (tclStubsPtr->tclGetUnicodeFromObj) /* 434 */ +/* Slot 435 is reserved */ +/* Slot 436 is reserved */ #define Tcl_SubstObj \ (tclStubsPtr->tcl_SubstObj) /* 437 */ #define Tcl_DetachChannel \ @@ -3692,8 +3444,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FSConvertToPathType) /* 459 */ #define Tcl_FSJoinPath \ (tclStubsPtr->tcl_FSJoinPath) /* 460 */ -#define Tcl_FSSplitPath \ - (tclStubsPtr->tcl_FSSplitPath) /* 461 */ +#define TclFSSplitPath \ + (tclStubsPtr->tclFSSplitPath) /* 461 */ #define Tcl_FSEqualPaths \ (tclStubsPtr->tcl_FSEqualPaths) /* 462 */ #define Tcl_FSGetNormalizedPath \ @@ -3764,8 +3516,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DictObjGet) /* 495 */ #define Tcl_DictObjRemove \ (tclStubsPtr->tcl_DictObjRemove) /* 496 */ -#define Tcl_DictObjSize \ - (tclStubsPtr->tcl_DictObjSize) /* 497 */ +#define TclDictObjSize \ + (tclStubsPtr->tclDictObjSize) /* 497 */ #define Tcl_DictObjFirst \ (tclStubsPtr->tcl_DictObjFirst) /* 498 */ #define Tcl_DictObjNext \ @@ -3808,8 +3560,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ #define Tcl_FSEvalFileEx \ (tclStubsPtr->tcl_FSEvalFileEx) /* 518 */ -#define Tcl_SetExitProc \ - (tclStubsPtr->tcl_SetExitProc) /* 519 */ +/* Slot 519 is reserved */ #define Tcl_LimitAddHandler \ (tclStubsPtr->tcl_LimitAddHandler) /* 520 */ #define Tcl_LimitRemoveHandler \ @@ -3978,8 +3729,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetEnsembleParameterList) /* 602 */ #define Tcl_GetEnsembleParameterList \ (tclStubsPtr->tcl_GetEnsembleParameterList) /* 603 */ -#define Tcl_ParseArgsObjv \ - (tclStubsPtr->tcl_ParseArgsObjv) /* 604 */ +#define TclParseArgsObjv \ + (tclStubsPtr->tclParseArgsObjv) /* 604 */ #define Tcl_GetErrorLine \ (tclStubsPtr->tcl_GetErrorLine) /* 605 */ #define Tcl_SetErrorLine \ @@ -4068,12 +3819,16 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */ #define Tcl_UtfToUniCharDString \ (tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */ +#define TclGetBytesFromObj \ + (tclStubsPtr->tclGetBytesFromObj) /* 649 */ #define Tcl_GetBytesFromObj \ - (tclStubsPtr->tcl_GetBytesFromObj) /* 649 */ -/* Slot 650 is reserved */ -/* Slot 651 is reserved */ -/* Slot 652 is reserved */ -/* Slot 653 is reserved */ + (tclStubsPtr->tcl_GetBytesFromObj) /* 650 */ +#define Tcl_GetStringFromObj \ + (tclStubsPtr->tcl_GetStringFromObj) /* 651 */ +#define Tcl_GetUnicodeFromObj \ + (tclStubsPtr->tcl_GetUnicodeFromObj) /* 652 */ +#define Tcl_GetSizeIntFromObj \ + (tclStubsPtr->tcl_GetSizeIntFromObj) /* 653 */ #define Tcl_UtfCharComplete \ (tclStubsPtr->tcl_UtfCharComplete) /* 654 */ #define Tcl_UtfNext \ @@ -4088,33 +3843,44 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UtfToExternalDStringEx) /* 659 */ #define Tcl_AsyncMarkFromSignal \ (tclStubsPtr->tcl_AsyncMarkFromSignal) /* 660 */ -/* Slot 661 is reserved */ -/* Slot 662 is reserved */ -/* Slot 663 is reserved */ -/* Slot 664 is reserved */ -/* Slot 665 is reserved */ -/* Slot 666 is reserved */ -/* Slot 667 is reserved */ +#define Tcl_ListObjGetElements \ + (tclStubsPtr->tcl_ListObjGetElements) /* 661 */ +#define Tcl_ListObjLength \ + (tclStubsPtr->tcl_ListObjLength) /* 662 */ +#define Tcl_DictObjSize \ + (tclStubsPtr->tcl_DictObjSize) /* 663 */ +#define Tcl_SplitList \ + (tclStubsPtr->tcl_SplitList) /* 664 */ +#define Tcl_SplitPath \ + (tclStubsPtr->tcl_SplitPath) /* 665 */ +#define Tcl_FSSplitPath \ + (tclStubsPtr->tcl_FSSplitPath) /* 666 */ +#define Tcl_ParseArgsObjv \ + (tclStubsPtr->tcl_ParseArgsObjv) /* 667 */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 668 */ -#define TclNumUtfChars \ - (tclStubsPtr->tclNumUtfChars) /* 669 */ -#define TclGetCharLength \ - (tclStubsPtr->tclGetCharLength) /* 670 */ -#define TclUtfAtIndex \ - (tclStubsPtr->tclUtfAtIndex) /* 671 */ -#define TclGetRange \ - (tclStubsPtr->tclGetRange) /* 672 */ -#define TclGetUniChar \ - (tclStubsPtr->tclGetUniChar) /* 673 */ +#define Tcl_NumUtfChars \ + (tclStubsPtr->tcl_NumUtfChars) /* 669 */ +#define Tcl_GetCharLength \ + (tclStubsPtr->tcl_GetCharLength) /* 670 */ +#define Tcl_UtfAtIndex \ + (tclStubsPtr->tcl_UtfAtIndex) /* 671 */ +#define Tcl_GetRange \ + (tclStubsPtr->tcl_GetRange) /* 672 */ +#define Tcl_GetUniChar \ + (tclStubsPtr->tcl_GetUniChar) /* 673 */ #define Tcl_GetBool \ (tclStubsPtr->tcl_GetBool) /* 674 */ #define Tcl_GetBoolFromObj \ (tclStubsPtr->tcl_GetBoolFromObj) /* 675 */ -/* Slot 676 is reserved */ -/* Slot 677 is reserved */ -/* Slot 678 is reserved */ -/* Slot 679 is reserved */ +#define Tcl_CreateObjCommand2 \ + (tclStubsPtr->tcl_CreateObjCommand2) /* 676 */ +#define Tcl_CreateObjTrace2 \ + (tclStubsPtr->tcl_CreateObjTrace2) /* 677 */ +#define Tcl_NRCreateCommand2 \ + (tclStubsPtr->tcl_NRCreateCommand2) /* 678 */ +#define Tcl_NRCallObjProc2 \ + (tclStubsPtr->tcl_NRCallObjProc2) /* 679 */ #define Tcl_GetNumberFromObj \ (tclStubsPtr->tcl_GetNumberFromObj) /* 680 */ #define Tcl_GetNumber \ @@ -4127,10 +3893,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetWideUIntFromObj) /* 684 */ #define Tcl_DStringToObj \ (tclStubsPtr->tcl_DStringToObj) /* 685 */ -#define TclUtfNcmp \ - (tclStubsPtr->tclUtfNcmp) /* 686 */ -#define TclUtfNcasecmp \ - (tclStubsPtr->tclUtfNcasecmp) /* 687 */ +#define Tcl_UtfNcmp \ + (tclStubsPtr->tcl_UtfNcmp) /* 686 */ +#define Tcl_UtfNcasecmp \ + (tclStubsPtr->tcl_UtfNcasecmp) /* 687 */ #define TclUnusedStubEntry \ (tclStubsPtr->tclUnusedStubEntry) /* 688 */ @@ -4140,138 +3906,71 @@ extern const TclStubs *tclStubsPtr; #undef TclUnusedStubEntry -#if defined(USE_TCL_STUBS) -# undef Tcl_CreateInterp -# undef Tcl_FindExecutable -# undef Tcl_GetStringResult -# undef Tcl_Init -# undef Tcl_SetPanicProc -# undef Tcl_SetExitProc -# undef Tcl_ObjSetVar2 -# undef Tcl_StaticLibrary -# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) -# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) -# define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) -# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ - (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) -#endif - -#if defined(_WIN32) && defined(UNICODE) -# if defined(TCL_NO_DEPRECATED) -# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) -# else -# define Tcl_FindExecutable(arg) ((void)((Tcl_FindExecutable)((const char *)(arg)))) -# define Tcl_SetPanicProc(arg) ((void)((Tcl_SetPanicProc)(arg))) -# endif -# define Tcl_MainEx Tcl_MainExW - EXTERN void Tcl_MainExW(Tcl_Size argc, wchar_t **argv, - Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); -#elif !defined(TCL_NO_DEPRECATED) -# define Tcl_FindExecutable(arg) ((void)((Tcl_FindExecutable)(arg))) -# define Tcl_SetPanicProc(arg) ((void)((Tcl_SetPanicProc)(arg))) +#ifdef _WIN32 +# undef Tcl_CreateFileHandler +# undef Tcl_DeleteFileHandler +# undef Tcl_GetOpenFile #endif #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#undef Tcl_SeekOld -#undef Tcl_TellOld - -#undef Tcl_PkgPresent #define Tcl_PkgPresent(interp, name, version, exact) \ Tcl_PkgPresentEx(interp, name, version, exact, NULL) -#undef Tcl_PkgProvide #define Tcl_PkgProvide(interp, name, version) \ Tcl_PkgProvideEx(interp, name, version, NULL) -#undef Tcl_PkgRequire #define Tcl_PkgRequire(interp, name, version, exact) \ Tcl_PkgRequireEx(interp, name, version, exact, NULL) -#undef Tcl_GetIndexFromObj #define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, \ sizeof(char *), msg, flags, indexPtr) -#undef Tcl_NewBooleanObj #define Tcl_NewBooleanObj(intValue) \ Tcl_NewWideIntObj((intValue)!=0) -#undef Tcl_DbNewBooleanObj #define Tcl_DbNewBooleanObj(intValue, file, line) \ Tcl_DbNewWideIntObj((intValue)!=0, file, line) -#undef Tcl_SetBooleanObj #define Tcl_SetBooleanObj(objPtr, intValue) \ Tcl_SetWideIntObj(objPtr, (intValue)!=0) -#undef Tcl_SetVar #define Tcl_SetVar(interp, varName, newValue, flags) \ Tcl_SetVar2(interp, varName, NULL, newValue, flags) -#undef Tcl_UnsetVar #define Tcl_UnsetVar(interp, varName, flags) \ Tcl_UnsetVar2(interp, varName, NULL, flags) -#undef Tcl_GetVar #define Tcl_GetVar(interp, varName, flags) \ Tcl_GetVar2(interp, varName, NULL, flags) -#undef Tcl_TraceVar #define Tcl_TraceVar(interp, varName, flags, proc, clientData) \ Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData) -#undef Tcl_UntraceVar #define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \ Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData) -#undef Tcl_VarTraceInfo #define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \ Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData) -#undef Tcl_UpVar #define Tcl_UpVar(interp, frameName, varName, localName, flags) \ Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags) -#undef Tcl_AddErrorInfo #define Tcl_AddErrorInfo(interp, message) \ - Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE)) -#undef Tcl_AddObjErrorInfo + Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1)) #define Tcl_AddObjErrorInfo(interp, message, length) \ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) -#ifdef TCL_NO_DEPRECATED -#undef Tcl_FreeResult -#undef Tcl_AppendResultVA -#undef Tcl_AppendStringsToObjVA -#undef Tcl_SetErrorCodeVA -#undef Tcl_VarEvalVA -#undef Tcl_PanicVA -#undef Tcl_GetStringResult -#undef Tcl_GetDefaultEncodingDir -#undef Tcl_SetDefaultEncodingDir -#undef Tcl_UniCharNcmp -#undef Tcl_EvalTokens -#undef Tcl_UniCharNcasecmp -#undef Tcl_UniCharCaseMatch -#undef Tcl_GetMathFuncInfo -#undef Tcl_ListMathFuncs -#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) -#undef Tcl_Eval #define Tcl_Eval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, 0) -#undef Tcl_GlobalEval #define Tcl_GlobalEval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL) -#undef Tcl_SaveResult -#undef Tcl_RestoreResult -#undef Tcl_DiscardResult -#undef Tcl_SetResult +#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) #define Tcl_SetResult(interp, result, freeProc) \ do { \ const char *__result = result; \ Tcl_FreeProc *__freeProc = freeProc; \ - Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, TCL_INDEX_NONE)); \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \ if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \ if (__freeProc == TCL_DYNAMIC) { \ - ckfree((char *)__result); \ + Tcl_Free((char *)__result); \ } else { \ (*__freeProc)((char *)__result); \ } \ } \ } while(0) -#endif /* TCL_NO_DEPRECATED */ #if defined(USE_TCL_STUBS) -# if defined(_WIN32) && defined(_WIN64) +# if defined(_WIN32) && defined(_WIN64) && TCL_MAJOR_VERSION < 9 # undef Tcl_GetTime -/* Handle Win64 tk.dll being loaded in Cygwin64. */ +/* Handle Win64 tk.dll being loaded in Cygwin64 (only needed for Tcl 8). */ # define Tcl_GetTime(t) \ do { \ struct { \ @@ -4297,10 +3996,6 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_GetLongFromObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj -# undef Tcl_UniCharNcmp -# undef Tcl_UtfNcmp -# undef Tcl_UtfNcasecmp -# undef Tcl_UniCharNcasecmp # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) # define Tcl_ExprLong TclExprLong static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ @@ -4316,65 +4011,70 @@ extern const TclStubs *tclStubsPtr; if (result == TCL_OK) *ptr = (long)intValue; return result; } -# define Tcl_UniCharNcmp(ucs,uct,n) \ - ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n)) -# define Tcl_UtfNcmp(s1,s2,n) \ - ((int(*)(const char*,const char*,unsigned int))(void *)tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n)) -# define Tcl_UtfNcasecmp(s1,s2,n) \ - ((int(*)(const char*,const char*,unsigned int))(void *)tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n)) -# define Tcl_UniCharNcasecmp(ucs,uct,n) \ - ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))(void *)tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n)) # endif #endif #undef Tcl_GetString #undef Tcl_GetUnicode #define Tcl_GetString(objPtr) \ - Tcl_GetStringFromObj(objPtr, NULL) + Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL) #define Tcl_GetUnicode(objPtr) \ - Tcl_GetUnicodeFromObj(objPtr, NULL) + Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL) #undef Tcl_GetIndexFromObjStruct #undef Tcl_GetBooleanFromObj #undef Tcl_GetBoolean #ifdef __GNUC__ - /* If this gives: "error: size of array ‘_boolVar’ is negative", it means that sizeof(*boolPtr)>sizeof(int), which is not allowed */ + /* If this gives: "error: size of array ‘_bool_Var’ is negative", it means that sizeof(*boolPtr)>sizeof(int), which is not allowed */ # define TCLBOOLWARNING(boolPtr) ({__attribute__((unused)) char _bool_Var[sizeof(*(boolPtr)) > sizeof(int) ? -1 : 1];}), #else # define TCLBOOLWARNING(boolPtr) #endif #if defined(USE_TCL_STUBS) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) + (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \ + (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ - (sizeof(*(boolPtr)) >= sizeof(int) ? (TCLBOOLWARNING(boolPtr)tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr))) : \ + (TCLBOOLWARNING(boolPtr)(sizeof(*(boolPtr)) >= sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr))) #define Tcl_GetBoolean(interp, src, boolPtr) \ - (sizeof(*(boolPtr)) >= sizeof(int) ? (TCLBOOLWARNING(boolPtr)tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr))) : \ + (TCLBOOLWARNING(boolPtr)(sizeof(*(boolPtr)) >= sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr))) #else #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) + ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \ + (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ - (sizeof(*(boolPtr)) >= sizeof(int) ? (TCLBOOLWARNING(boolPtr)Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr))) : \ + (TCLBOOLWARNING(boolPtr)(sizeof(*(boolPtr)) >= sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr))) #define Tcl_GetBoolean(interp, src, boolPtr) \ - (sizeof(*(boolPtr)) >= sizeof(int) ? (TCLBOOLWARNING(boolPtr)Tcl_GetBoolean(interp, src, (int *)(boolPtr))) : \ + (TCLBOOLWARNING(boolPtr)(sizeof(*(boolPtr)) >= sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr))) #endif -#undef Tcl_NewLongObj +#ifdef TCL_MEM_DEBUG +# undef Tcl_Alloc +# define Tcl_Alloc(x) \ + (Tcl_DbCkalloc((x), __FILE__, __LINE__)) +# undef Tcl_Free +# define Tcl_Free(x) \ + Tcl_DbCkfree((x), __FILE__, __LINE__) +# undef Tcl_Realloc +# define Tcl_Realloc(x,y) \ + (Tcl_DbCkrealloc((x), (y), __FILE__, __LINE__)) +# undef Tcl_AttemptAlloc +# define Tcl_AttemptAlloc(x) \ + (Tcl_AttemptDbCkalloc((x), __FILE__, __LINE__)) +# undef Tcl_AttemptRealloc +# define Tcl_AttemptRealloc(x,y) \ + (Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__)) +#endif /* !TCL_MEM_DEBUG */ + #define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value)) -#undef Tcl_NewIntObj #define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value)) -#undef Tcl_DbNewLongObj #define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line) -#undef Tcl_SetIntObj #define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value)) -#undef Tcl_SetLongObj #define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value)) -#undef Tcl_BackgroundError #define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR) -#undef Tcl_StringMatch #define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0) #if TCL_UTF_MAX < 4 @@ -4386,7 +4086,14 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniChar Tcl_UtfToChar16 # undef Tcl_UniCharLen # define Tcl_UniCharLen Tcl_Char16Len -#elif !defined(BUILD_tcl) +# undef Tcl_UniCharToUtf +# if defined(USE_TCL_STUBS) +# define Tcl_UniCharToUtf(c, p) \ + (tclStubsPtr->tcl_UniCharToUtf((c)|TCL_COMBINE, (p))) +# else +# define Tcl_UniCharToUtf(c, p) \ + ((Tcl_UniCharToUtf)((c)|TCL_COMBINE, (p))) +# endif # undef Tcl_NumUtfChars # define Tcl_NumUtfChars TclNumUtfChars # undef Tcl_GetCharLength @@ -4410,12 +4117,12 @@ extern const TclStubs *tclStubsPtr; ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ - ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ - : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) + ? (Tcl_Size (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ + : (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) -#else /* !defined(USE_TCL_STUBS) */ +#else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_UniCharToUtfDString \ : (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString) @@ -4423,53 +4130,179 @@ extern const TclStubs *tclStubsPtr; ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ - ? (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ - : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) + ? (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ + : (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) -#endif /* defined(USE_TCL_STUBS) */ +#endif /* * Deprecated Tcl procedures: */ -#ifdef TCL_NO_DEPRECATED -# undef Tcl_SavedResult -#endif /* TCL_NO_DEPRECATED */ -#undef Tcl_EvalObj #define Tcl_EvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, 0) -#undef Tcl_GlobalEvalObj #define Tcl_GlobalEvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL) -#if defined(TCL_NO_DEPRECATED) && defined(USE_TCL_STUBS) -#undef Tcl_Close -#define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) +#if TCL_MAJOR_VERSION > 8 +# undef Tcl_Close +# define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) #endif #undef TclUtfCharComplete #undef TclUtfNext #undef TclUtfPrev -#if defined(USE_TCL_STUBS) && (TCL_UTF_MAX < 4) && !defined(TCL_NO_DEPRECATED) -# undef Tcl_UtfCharComplete -# undef Tcl_UtfNext -# undef Tcl_UtfPrev -# define Tcl_UtfCharComplete (tclStubsPtr->tclUtfCharComplete) -# define Tcl_UtfNext (tclStubsPtr->tclUtfNext) -# define Tcl_UtfPrev (tclStubsPtr->tclUtfPrev) +#ifndef TCL_NO_DEPRECATED +# define Tcl_CreateSlave Tcl_CreateChild +# define Tcl_GetSlave Tcl_GetChild +# define Tcl_GetMaster Tcl_GetParent +#endif + +#ifdef USE_TCL_STUBS + /* Protect those 10 functions, make them useless through the stub table */ +# undef TclGetStringFromObj +# undef TclGetBytesFromObj +# undef TclGetUnicodeFromObj +# undef TclListObjGetElements +# undef TclListObjLength +# undef TclDictObjSize +# undef TclSplitList +# undef TclSplitPath +# undef TclFSSplitPath +# undef TclParseArgsObjv #endif -#define Tcl_CreateSlave Tcl_CreateChild -#define Tcl_GetSlave Tcl_GetChild -#define Tcl_GetMaster Tcl_GetParent -#define Tcl_NRCallObjProc2 Tcl_NRCallObjProc -#define Tcl_CreateObjCommand2 Tcl_CreateObjCommand -#define Tcl_CreateObjTrace2 Tcl_CreateObjTrace -#define Tcl_NRCreateCommand2 Tcl_NRCreateCommand +#if TCL_MAJOR_VERSION < 9 + /* TIP #627 for 8.7 */ +# undef Tcl_CreateObjCommand2 +# define Tcl_CreateObjCommand2 Tcl_CreateObjCommand +# undef Tcl_CreateObjTrace2 +# define Tcl_CreateObjTrace2 Tcl_CreateObjTrace +# undef Tcl_NRCreateCommand2 +# define Tcl_NRCreateCommand2 Tcl_NRCreateCommand +# undef Tcl_NRCallObjProc2 +# define Tcl_NRCallObjProc2 Tcl_NRCallObjProc + /* TIP #660 for 8.7 */ +# undef Tcl_GetSizeIntFromObj +# define Tcl_GetSizeIntFromObj Tcl_GetIntFromObj -/* TIP #660 */ -#define Tcl_GetSizeIntFromObj Tcl_GetIntFromObj +# undef Tcl_GetBytesFromObj +# define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ + tclStubsPtr->tclGetBytesFromObj((interp), (objPtr), (sizePtr)) +# undef Tcl_GetStringFromObj +# define Tcl_GetStringFromObj(objPtr, sizePtr) \ + tclStubsPtr->tclGetStringFromObj((objPtr), (sizePtr)) +# undef Tcl_GetUnicodeFromObj +# define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ + tclStubsPtr->tclGetUnicodeFromObj((objPtr), (sizePtr)) +# undef Tcl_ListObjGetElements +# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) \ + tclStubsPtr->tclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)) +# undef Tcl_ListObjLength +# define Tcl_ListObjLength(interp, listPtr, lengthPtr) \ + tclStubsPtr->tclListObjLength((interp), (listPtr), (lengthPtr)) +# undef Tcl_DictObjSize +# define Tcl_DictObjSize(interp, dictPtr, sizePtr) \ + tclStubsPtr->tclDictObjSize((interp), (dictPtr), (sizePtr)) +# undef Tcl_SplitList +# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) \ + tclStubsPtr->tclSplitList((interp), (listStr), (argcPtr), (argvPtr)) +# undef Tcl_SplitPath +# define Tcl_SplitPath(path, argcPtr, argvPtr) \ + tclStubsPtr->tclSplitPath((path), (argcPtr), (argvPtr)) +# undef Tcl_FSSplitPath +# define Tcl_FSSplitPath(pathPtr, lenPtr) \ + tclStubsPtr->tclFSSplitPath((pathPtr), (lenPtr)) +# undef Tcl_ParseArgsObjv +# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) \ + tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) +#elif defined(TCL_8_API) +# undef Tcl_GetByteArrayFromObj +# undef Tcl_GetBytesFromObj +# undef Tcl_GetStringFromObj +# undef Tcl_GetUnicodeFromObj +# undef Tcl_ListObjGetElements +# undef Tcl_ListObjLength +# undef Tcl_DictObjSize +# undef Tcl_SplitList +# undef Tcl_SplitPath +# undef Tcl_FSSplitPath +# undef Tcl_ParseArgsObjv +# if !defined(USE_TCL_STUBS) +# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ + TclGetBytesFromObj(NULL, (objPtr), (sizePtr)) : \ + (Tcl_GetBytesFromObj)(NULL, (objPtr), (Tcl_Size *)(void *)(sizePtr))) +# define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ + TclGetBytesFromObj((interp), (objPtr), (sizePtr)) : \ + (Tcl_GetBytesFromObj)((interp), (objPtr), (Tcl_Size *)(void *)(sizePtr))) +# define Tcl_GetStringFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ + TclGetStringFromObj((objPtr), (sizePtr)) : \ + (Tcl_GetStringFromObj)((objPtr), (Tcl_Size *)(void *)(sizePtr))) +# define Tcl_GetUnicodeFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ + TclGetUnicodeFromObj((objPtr), (sizePtr)) : \ + (Tcl_GetUnicodeFromObj)((objPtr), (Tcl_Size *)(void *)(sizePtr))) +# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) <= sizeof(int) ? \ + TclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)) : \ + (Tcl_ListObjGetElements)((interp), (listPtr), (Tcl_Size *)(void *)(objcPtr), (objvPtr))) +# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) <= sizeof(int) ? \ + TclListObjLength((interp), (listPtr), (lengthPtr)) : \ + (Tcl_ListObjLength)((interp), (listPtr), (Tcl_Size *)(void *)(lengthPtr))) +# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ + TclDictObjSize((interp), (dictPtr), (sizePtr)) : \ + (Tcl_DictObjSize)((interp), (dictPtr), (Tcl_Size *)(void *)(sizePtr))) +# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ + TclSplitList((interp), (listStr), (argcPtr), (argvPtr)) : \ + (Tcl_SplitList)((interp), (listStr), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) +# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ + TclSplitPath((path), (argcPtr), (argvPtr)) : \ + (Tcl_SplitPath)((path), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) +# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) <= sizeof(int) ? \ + TclFSSplitPath((pathPtr), (lenPtr)) : \ + (Tcl_FSSplitPath)((pathPtr), (Tcl_Size *)(void *)(lenPtr))) +# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ + TclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) : \ + (Tcl_ParseArgsObjv)((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv))) +# elif !defined(BUILD_tcl) +# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ + tclStubsPtr->tclGetBytesFromObj(NULL, (objPtr), (sizePtr)) : \ + tclStubsPtr->tcl_GetBytesFromObj(NULL, (objPtr), (Tcl_Size *)(void *)(sizePtr))) +# define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ + tclStubsPtr->tclGetBytesFromObj((interp), (objPtr), (sizePtr)) : \ + tclStubsPtr->tcl_GetBytesFromObj((interp), (objPtr), (Tcl_Size *)(void *)(sizePtr))) +# define Tcl_GetStringFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ + tclStubsPtr->tclGetStringFromObj((objPtr), (sizePtr)) : \ + tclStubsPtr->tcl_GetStringFromObj((objPtr), (Tcl_Size *)(void *)(sizePtr))) +# define Tcl_GetUnicodeFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ + tclStubsPtr->tclGetUnicodeFromObj((objPtr), (sizePtr)) : \ + tclStubsPtr->tcl_GetUnicodeFromObj((objPtr), (Tcl_Size *)(void *)(sizePtr))) +# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) <= sizeof(int) ? \ + tclStubsPtr->tclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)) : \ + tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (Tcl_Size *)(void *)(objcPtr), (objvPtr))) +# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) <= sizeof(int) ? \ + tclStubsPtr->tclListObjLength((interp), (listPtr), (lengthPtr)) : \ + tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (Tcl_Size *)(void *)(lengthPtr))) +# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ + tclStubsPtr->tclDictObjSize((interp), (dictPtr), (sizePtr)) : \ + tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (Tcl_Size *)(void *)(sizePtr))) +# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ + tclStubsPtr->tclSplitList((interp), (listStr), (argcPtr), (argvPtr)) : \ + tclStubsPtr->tcl_SplitList((interp), (listStr), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) +# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ + tclStubsPtr->tclSplitPath((path), (argcPtr), (argvPtr)) : \ + tclStubsPtr->tcl_SplitPath((path), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) +# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) <= sizeof(int) ? \ + tclStubsPtr->tclFSSplitPath((pathPtr), (lenPtr)) : \ + tclStubsPtr->tcl_FSSplitPath((pathPtr), (Tcl_Size *)(void *)(lenPtr))) +# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ + tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) : \ + tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv))) +# endif /* defined(USE_TCL_STUBS) */ +#else /* !defined(TCL_8_API) */ +# undef Tcl_GetByteArrayFromObj +# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ + Tcl_GetBytesFromObj(NULL, (objPtr), (sizePtr)) +#endif /* defined(TCL_8_API) */ #endif /* _TCLDECLS */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 9e0baea..7c56c49 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -61,6 +61,8 @@ static Tcl_ObjCmdProc DictForNRCmd; static Tcl_ObjCmdProc DictMapNRCmd; static Tcl_NRPostProc DictForLoopCallback; static Tcl_NRPostProc DictMapLoopCallback; +static Tcl_ObjTypeLengthProc DictAsListLength; +/* static Tcl_ObjTypeIndexProc DictAsListIndex; Needs rewrite */ /* * Table of dict subcommand names and implementations. @@ -129,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 @@ -143,10 +145,22 @@ typedef struct Dict { const Tcl_ObjType tclDictType = { "dict", - FreeDictInternalRep, /* freeIntRepProc */ - DupDictInternalRep, /* dupIntRepProc */ - UpdateStringOfDict, /* updateStringProc */ - SetDictFromAny /* setFromAnyProc */ + FreeDictInternalRep, /* freeIntRepProc */ + DupDictInternalRep, /* dupIntRepProc */ + UpdateStringOfDict, /* updateStringProc */ + SetDictFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V2( /* Extended type for AbstractLists */ + DictAsListLength, /* return "list" length of dict value w/o + * shimmering */ + NULL, /* return key or value at "list" index + * location. (keysare at even indicies, + * values at odd indicies) */ + NULL, + NULL, + NULL, + NULL, + NULL, + NULL) }; #define DictSetInternalRep(objPtr, dictRepPtr) \ @@ -228,7 +242,7 @@ AllocChainEntry( Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; ChainEntry *cPtr; - cPtr = (ChainEntry *)ckalloc(sizeof(ChainEntry)); + cPtr = (ChainEntry *)Tcl_Alloc(sizeof(ChainEntry)); cPtr->entry.key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); Tcl_SetHashValue(&cPtr->entry, NULL); @@ -359,7 +373,7 @@ DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict, *newDict = (Dict *)ckalloc(sizeof(Dict)); + Dict *oldDict, *newDict = (Dict *)Tcl_Alloc(sizeof(Dict)); ChainEntry *cPtr; DictGetInternalRep(srcPtr, oldDict); @@ -454,7 +468,7 @@ DeleteDict( Dict *dict) { DeleteChainTable(dict); - ckfree(dict); + Tcl_Free(dict); } /* @@ -488,8 +502,8 @@ UpdateStringOfDict( Dict *dict; ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; - int i, length; - TCL_HASH_TYPE bytesNeeded = 0; + Tcl_Size i, length; + size_t bytesNeeded = 0; const char *elem; char *dst; @@ -498,7 +512,7 @@ UpdateStringOfDict( * is not exposed by any API function... */ - int numElems; + Tcl_Size numElems; DictGetInternalRep(dictPtr, dict); @@ -519,7 +533,7 @@ UpdateStringOfDict( if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { - flagPtr = (char *)ckalloc(numElems); + flagPtr = (char *)Tcl_Alloc(numElems); } for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { /* @@ -529,22 +543,12 @@ UpdateStringOfDict( flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); - elem = TclGetStringFromObj(keyPtr, &length); + elem = Tcl_GetStringFromObj(keyPtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); - if (bytesNeeded > INT_MAX) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - flagPtr[i+1] = TCL_DONT_QUOTE_HASH; valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); - elem = TclGetStringFromObj(valuePtr, &length); + elem = Tcl_GetStringFromObj(valuePtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i+1); - if (bytesNeeded > INT_MAX) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - } - if (bytesNeeded + numElems > INT_MAX + 1U) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems; @@ -557,13 +561,13 @@ UpdateStringOfDict( for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); - elem = TclGetStringFromObj(keyPtr, &length); + elem = Tcl_GetStringFromObj(keyPtr, &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; flagPtr[i+1] |= TCL_DONT_QUOTE_HASH; valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); - elem = TclGetStringFromObj(valuePtr, &length); + elem = Tcl_GetStringFromObj(valuePtr, &length); dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); *dst++ = ' '; } @@ -571,7 +575,7 @@ UpdateStringOfDict( (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); if (flagPtr != localFlags) { - ckfree(flagPtr); + Tcl_Free(flagPtr); } } @@ -602,7 +606,7 @@ SetDictFromAny( { Tcl_HashEntry *hPtr; int isNew; - Dict *dict = (Dict *)ckalloc(sizeof(Dict)); + Dict *dict = (Dict *)Tcl_Alloc(sizeof(Dict)); InitChainTable(dict); @@ -613,7 +617,7 @@ SetDictFromAny( */ if (TclHasInternalRep(objPtr, &tclListType)) { - int objc, i; + Tcl_Size objc, i; Tcl_Obj **objv; /* Cannot fail, we already know the Tcl_ObjType is "list". */ @@ -643,14 +647,14 @@ SetDictFromAny( Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */ } } else { - int length; - const char *nextElem = TclGetStringFromObj(objPtr, &length); + Tcl_Size length; + const char *nextElem = Tcl_GetStringFromObj(objPtr, &length); const char *limit = (nextElem + length); while (nextElem < limit) { Tcl_Obj *keyPtr, *valuePtr; const char *elemStart; - int elemSize; + Tcl_Size elemSize; int literal; if (TclFindDictElement(interp, nextElem, (limit - nextElem), @@ -731,7 +735,7 @@ SetDictFromAny( } errorInFindDictElement: DeleteChainTable(dict); - ckfree(dict); + Tcl_Free(dict); return TCL_ERROR; } @@ -788,12 +792,12 @@ Tcl_Obj * TclTraceDictPath( Tcl_Interp *interp, Tcl_Obj *dictPtr, - int keyc, + Tcl_Size keyc, Tcl_Obj *const keyv[], int flags) { Dict *dict, *newDict; - int i; + Tcl_Size i; DictGetInternalRep(dictPtr, dict); if (dict == NULL) { @@ -1057,6 +1061,26 @@ Tcl_DictObjRemove( /* *---------------------------------------------------------------------- * + * Tcl_DictGetSize + * + * Returns the size of dictPtr. Caller must ensure that dictPtr has type + * 'tclDicttype'. + * + * + *---------------------------------------------------------------------- + */ + +Tcl_Size +TclDictGetSize(Tcl_Obj *dictPtr) +{ + Dict *dict; + DictGetInternalRep(dictPtr, dict); + return dict->table.numEntries; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DictObjSize -- * * How many key,value pairs are there in the dictionary? @@ -1077,7 +1101,7 @@ int Tcl_DictObjSize( Tcl_Interp *interp, Tcl_Obj *dictPtr, - int *sizePtr) + Tcl_Size *sizePtr) { Dict *dict; @@ -1290,7 +1314,7 @@ int Tcl_DictObjPutKeyList( Tcl_Interp *interp, Tcl_Obj *dictPtr, - int keyc, + Tcl_Size keyc, Tcl_Obj *const keyv[], Tcl_Obj *valuePtr) { @@ -1351,7 +1375,7 @@ int Tcl_DictObjRemoveKeyList( Tcl_Interp *interp, Tcl_Obj *dictPtr, - int keyc, + Tcl_Size keyc, Tcl_Obj *const keyv[]) { Dict *dict; @@ -1410,7 +1434,7 @@ Tcl_NewDictObj(void) TclNewObj(dictPtr); TclInvalidateStringRep(dictPtr); - dict = (Dict *)ckalloc(sizeof(Dict)); + dict = (Dict *)Tcl_Alloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 1; dict->chain = NULL; @@ -1458,7 +1482,7 @@ Tcl_DbNewDictObj( TclDbNewObj(dictPtr, file, line); TclInvalidateStringRep(dictPtr); - dict = (Dict *)ckalloc(sizeof(Dict)); + dict = (Dict *)Tcl_Alloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 1; dict->chain = NULL; @@ -2034,7 +2058,7 @@ DictSizeCmd( Tcl_Obj *const *objv) { int result; - int size; + Tcl_Size size; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary"); @@ -2129,7 +2153,7 @@ DictInfoCmd( statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); - ckfree(statsStr); + Tcl_Free(statsStr); return TCL_OK; } @@ -2472,7 +2496,7 @@ DictForNRCmd( Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj; Tcl_DictSearch *searchPtr; - int varc; + Tcl_Size varc; int done; if (objc != 4) { @@ -2667,7 +2691,7 @@ DictMapNRCmd( Interp *iPtr = (Interp *) interp; Tcl_Obj **varv, *keyObj, *valueObj; DictMapStorage *storagePtr; - int varc; + Tcl_Size varc; int done; if (objc != 4) { @@ -3002,12 +3026,12 @@ DictFilterCmd( }; enum FilterTypes { FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES - }; + } index; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj; Tcl_DictSearch search; - int index, done, result, satisfied; - int varc; + int done, result, satisfied; + Tcl_Size varc; const char *pattern; if (objc < 3) { @@ -3019,7 +3043,7 @@ DictFilterCmd( return TCL_ERROR; } - switch ((enum FilterTypes) index) { + switch (index) { case FILTER_KEYS: /* * Create a dictionary whose keys all match a certain pattern. @@ -3285,7 +3309,7 @@ DictUpdateCmd( Interp *iPtr = (Interp *) interp; Tcl_Obj *dictPtr, *objPtr; int i; - int dummy; + Tcl_Size dummy; if (objc < 5 || !(objc & 1)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -3338,7 +3362,7 @@ FinalizeDictUpdate( { Tcl_Obj *dictPtr, *objPtr, **objv; Tcl_InterpState state; - int i, objc; + Tcl_Size i, objc; Tcl_Obj *varName = (Tcl_Obj *)data[0]; Tcl_Obj *argsObj = (Tcl_Obj *)data[1]; @@ -3488,7 +3512,7 @@ FinalizeDictWith( int result) { Tcl_Obj **pathv; - int pathc; + Tcl_Size pathc; Tcl_InterpState state; Tcl_Obj *varName = (Tcl_Obj *)data[0]; Tcl_Obj *keysPtr = (Tcl_Obj *)data[1]; @@ -3565,7 +3589,7 @@ Tcl_Obj * TclDictWithInit( Tcl_Interp *interp, Tcl_Obj *dictPtr, - int pathc, + Tcl_Size pathc, Tcl_Obj *const pathv[]) { Tcl_DictSearch s; @@ -3652,7 +3676,7 @@ TclDictWithFinish( * the result value from TclDictWithInit. */ { Tcl_Obj *dictPtr, *leafPtr, *valPtr; - int i, allocdict, keyc; + Tcl_Size i, allocdict, keyc; Tcl_Obj **keyv; /* @@ -3778,6 +3802,159 @@ TclInitDictCmd( } /* + *---------------------------------------------------------------------- + * + * DictAsListLength -- + * + * Compute the length of a list as if the dict value were converted to a + * list. + * + * Note: the list length may not match the dict size * 2. This occurs when + * there are duplicate keys in the original string representation. + * + * Side Effects -- + * + * The intent is to have no side effects. + */ + +static Tcl_Size +DictAsListLength( + Tcl_Obj *objPtr) +{ + Tcl_Size estCount, length, llen; + const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length); + Tcl_Obj *elemPtr; + + /* + * Allocate enough space to hold a (Tcl_Obj *) for each + * (possible) list element. + */ + + estCount = TclMaxListLength(nextElem, length, &limit); + estCount += (estCount == 0); /* Smallest list struct holds 1 + * element. */ + elemPtr = Tcl_NewObj(); + + llen = 0; + + while (nextElem < limit) { + const char *elemStart; + char *check; + Tcl_Size elemSize; + int literal; + + if (TCL_OK != TclFindElement(NULL, nextElem, limit - nextElem, + &elemStart, &nextElem, &elemSize, &literal)) { + Tcl_DecrRefCount(elemPtr); + return 0; + } + if (elemStart == limit) { + break; + } + + TclInvalidateStringRep(elemPtr); + check = Tcl_InitStringRep(elemPtr, literal ? elemStart : NULL, + elemSize); + if (elemSize && check == NULL) { + Tcl_DecrRefCount(elemPtr); + return 0; + } + if (!literal) { + Tcl_InitStringRep(elemPtr, NULL, + TclCopyAndCollapse(elemSize, elemStart, check)); + } + llen++; + } + Tcl_DecrRefCount(elemPtr); + return llen; +} + + +/* + *---------------------------------------------------------------------- + * + * DictAsListIndex -- + * + * Return the key or value at the given "list" index, i.e., as if the string + * value where treated as a list. The intent is to support this list + * operation w/o causing the Obj value to shimmer into a List. + * + * Side Effects -- + * + * The intent is to have no side effects. + * + */ +#if 0 /* Needs rewrite */ +static int +DictAsListIndex( + Tcl_Interp *interp, + struct Tcl_Obj *objPtr, + Tcl_Size index, + Tcl_Obj** elemObjPtr) +{ + Tcl_Size /*estCount,*/ length, llen; + const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length); + Tcl_Obj *elemPtr; + + /* + * Compute limit of the list string + */ + + TclMaxListLength(nextElem, length, &limit); + elemPtr = Tcl_NewObj(); + + llen = 0; + + /* + * parse out each element until reaching the "index"th element. + * Sure this is slow, but shimmering is slower. + */ + while (nextElem < limit) { + const char *elemStart; + char *check; + Tcl_Size elemSize; + int literal; + + if (TCL_OK != TclFindElement(NULL, nextElem, limit - nextElem, + &elemStart, &nextElem, &elemSize, &literal)) { + Tcl_DecrRefCount(elemPtr); + return 0; + } + if (elemStart == limit) { + break; + } + + TclInvalidateStringRep(elemPtr); + check = Tcl_InitStringRep(elemPtr, literal ? elemStart : NULL, + elemSize); + if (elemSize && check == NULL) { + Tcl_DecrRefCount(elemPtr); + if (interp) { + // Need error message here + } + return TCL_ERROR; + } + if (!literal) { + Tcl_InitStringRep(elemPtr, NULL, + TclCopyAndCollapse(elemSize, elemStart, check)); + } + if (llen == index) { + *elemObjPtr = elemPtr; + return TCL_OK; + } + llen++; + } + + /* + * Index is beyond end of list - return empty + */ + Tcl_InitStringRep(elemPtr, NULL, 0); + *elemObjPtr = elemPtr; + return TCL_OK; +} +#endif + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index adbae1d..c2dd58d 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -42,6 +42,7 @@ static const Tcl_ObjType instNameType = { NULL, /* dupIntRepProc */ UpdateStringOfInstName, /* updateStringProc */ NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define InstNameSetInternalRep(objPtr, inst) \ @@ -198,7 +199,7 @@ TclPrintObject( char *bytes; Tcl_Size length; - bytes = TclGetStringFromObj(objPtr, &length); + bytes = Tcl_GetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } @@ -353,10 +354,10 @@ DisassembleByteCodeObj( * Print the ExceptionRange array. */ - if (codePtr->numExceptRanges > 0) { + if ((int)codePtr->numExceptRanges > 0) { Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %" TCL_SIZE_MODIFIER "d, depth %" TCL_SIZE_MODIFIER "d:\n", codePtr->numExceptRanges, codePtr->maxExceptDepth); - for (i = 0; i < codePtr->numExceptRanges; i++) { + for (i = 0; i < (int)codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; Tcl_AppendPrintfToObj(bufferObj, @@ -655,7 +656,7 @@ FormatInstruction( Tcl_Size length; Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length); + bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); } else if (suffixBuffer[0]) { Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); @@ -833,7 +834,7 @@ UpdateStringOfInstName( InstNameGetInternalRep(objPtr, inst); - if (inst > LAST_INST_OPCODE) { + if (inst >= LAST_INST_OPCODE) { dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); TclOOM(dst, TCL_INTEGER_SPACE + 5); snprintf(dst, TCL_INTEGER_SPACE + 5, "inst_%" TCL_Z_MODIFIER "u", inst); @@ -1113,7 +1114,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(aux); - for (i=0 ; i<codePtr->numAuxDataItems ; i++) { + for (i=0 ; i<(int)codePtr->numAuxDataItems ; i++) { AuxData *auxData = &codePtr->auxDataArrayPtr[i]; Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); @@ -1140,7 +1141,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(exn); - for (i=0 ; i<codePtr->numExceptRanges ; i++) { + for (i=0 ; i<(int)codePtr->numExceptRanges ; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; switch (rangePtr->type) { @@ -1180,7 +1181,7 @@ DisassembleByteCodeAsDicts( srcOffPtr = codePtr->srcDeltaStart; srcLenPtr = codePtr->srcLengthStart; codeOffset = sourceOffset = 0; - for (i=0 ; i<codePtr->numCommands ; i++) { + for (i=0 ; i<(int)codePtr->numCommands ; i++) { Tcl_Obj *cmd; codeOffset += Decode(codeOffPtr); @@ -1199,10 +1200,10 @@ DisassembleByteCodeAsDicts( */ Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1), - Tcl_NewWideIntObj(TclNumUtfChars(codePtr->source, + Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source, sourceOffset))); Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1), - Tcl_NewWideIntObj(TclNumUtfChars(codePtr->source, + Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source, sourceOffset + sourceLength - 1))); Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1), Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength)); @@ -1281,8 +1282,8 @@ Tcl_DisassembleObjCmd( DISAS_CLASS_CONSTRUCTOR, DISAS_CLASS_DESTRUCTOR, DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, DISAS_SCRIPT - }; - int idx, result; + } idx; + int result; Tcl_Obj *codeObjPtr = NULL; Proc *procPtr = NULL; Tcl_HashEntry *hPtr; @@ -1298,7 +1299,7 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } - switch ((enum Types) idx) { + switch (idx) { case DISAS_LAMBDA: { Command cmd; Tcl_Obj *nsObjPtr; @@ -1528,7 +1529,7 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *)objv[3]); + objv[3]); goto methodBody; case DISAS_OBJECT_METHOD: if (objc != 4) { @@ -1547,7 +1548,7 @@ Tcl_DisassembleObjCmd( if (oPtr->methodsPtr == NULL) { goto unknownMethod; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *)objv[3]); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[3]); /* * Compile (if necessary) and disassemble a method body. diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 2d1c983..c211dfb 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -192,7 +192,7 @@ Tcl_Encoding tclUtf8Encoding = NULL; * Names of encoding profiles and corresponding integer values. * Keep alphabetical order for error messages. */ -static const struct TclEncodingProfiles { +static struct TclEncodingProfiles { const char *name; int value; } encodingProfiles[] = { @@ -200,11 +200,14 @@ static const struct TclEncodingProfiles { {"strict", TCL_ENCODING_PROFILE_STRICT}, {"tcl8", TCL_ENCODING_PROFILE_TCL8}, }; -#define PROFILE_STRICT(flags_) \ - ((flags_) & TCL_ENCODING_PROFILE_STRICT) +#define PROFILE_TCL8(flags_) \ + (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8) + +#define PROFILE_REPLACE(flags_) \ + (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) -#define PROFILE_REPLACE(flags_) \ - ((ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) && !PROFILE_STRICT(flags_)) +#define PROFILE_STRICT(flags_) \ + (!PROFILE_TCL8(flags_) && !PROFILE_REPLACE(flags_)) #define UNICODE_REPLACE_CHAR ((Tcl_UniChar)0xFFFD) #define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800) @@ -266,7 +269,8 @@ static const Tcl_ObjType encodingType = { FreeEncodingInternalRep, DupEncodingInternalRep, NULL, - NULL + NULL, + TCL_OBJTYPE_V0 }; #define EncodingSetInternalRep(objPtr, encoding) \ @@ -409,52 +413,6 @@ Tcl_SetEncodingSearchPath( } /* - *---------------------------------------------------------------------- - * - * TclGetLibraryPath -- - * - * Keeps the per-thread copy of the library path current with changes to - * the global copy. - * - * Results: - * Returns a "list" (Tcl_Obj *) that contains the library path. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclGetLibraryPath(void) -{ - return TclGetProcessGlobalValue(&libraryPath); -} - -/* - *---------------------------------------------------------------------- - * - * TclSetLibraryPath -- - * - * Keeps the per-thread copy of the library path current with changes to - * the global copy. - * - * Since the result of this routine is void, if searchPath is not a valid - * list this routine silently does nothing. - * - *---------------------------------------------------------------------- - */ - -void -TclSetLibraryPath( - Tcl_Obj *path) -{ - Tcl_Size dummy; - - if (TCL_ERROR == TclListObjLengthM(NULL, path, &dummy)) { - return; - } - TclSetProcessGlobalValue(&libraryPath, path, NULL); -} - -/* *--------------------------------------------------------------------------- * * FillEncodingFileMap -- @@ -661,14 +619,14 @@ TclInitEncodingSubsystem(void) * code to duplicate the structure of a table encoding here. */ - dataPtr = (TableEncodingData *)ckalloc(sizeof(TableEncodingData)); + dataPtr = (TableEncodingData *)Tcl_Alloc(sizeof(TableEncodingData)); memset(dataPtr, 0, sizeof(TableEncodingData)); dataPtr->fallback = '?'; size = 256*(sizeof(unsigned short *) + sizeof(unsigned short)); - dataPtr->toUnicode = (unsigned short **)ckalloc(size); + dataPtr->toUnicode = (unsigned short **)Tcl_Alloc(size); memset(dataPtr->toUnicode, 0, size); - dataPtr->fromUnicode = (unsigned short **)ckalloc(size); + dataPtr->fromUnicode = (unsigned short **)Tcl_Alloc(size); memset(dataPtr->fromUnicode, 0, size); dataPtr->toUnicode[0] = (unsigned short *) (dataPtr->toUnicode + 256); @@ -747,70 +705,6 @@ TclFinalizeEncodingSubsystem(void) /* *------------------------------------------------------------------------- * - * Tcl_GetDefaultEncodingDir -- - * - * Legacy public interface to retrieve first directory in the encoding - * searchPath. - * - * Results: - * The directory pathname, as a string, or NULL for an empty encoding - * search path. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -const char * -Tcl_GetDefaultEncodingDir(void) -{ - int numDirs; - Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath(); - - TclListObjLengthM(NULL, searchPath, &numDirs); - if (numDirs == 0) { - return NULL; - } - Tcl_ListObjIndex(NULL, searchPath, 0, &first); - - return TclGetString(first); -} - -/* - *------------------------------------------------------------------------- - * - * Tcl_SetDefaultEncodingDir -- - * - * Legacy public interface to set the first directory in the encoding - * search path. - * - * Results: - * None. - * - * Side effects: - * Modifies the encoding search path. - * - *------------------------------------------------------------------------- - */ - -void -Tcl_SetDefaultEncodingDir( - const char *path) -{ - Tcl_Obj *searchPath = Tcl_GetEncodingSearchPath(); - Tcl_Obj *directory = Tcl_NewStringObj(path, TCL_INDEX_NONE); - - searchPath = Tcl_DuplicateObj(searchPath); - Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory); - Tcl_SetEncodingSearchPath(searchPath); -} -#endif - -/* - *------------------------------------------------------------------------- - * * Tcl_GetEncoding -- * * Given the name of a encoding, find the corresponding Tcl_Encoding @@ -920,9 +814,9 @@ FreeEncoding( Tcl_DeleteHashEntry(encodingPtr->hPtr); } if (encodingPtr->name) { - ckfree(encodingPtr->name); + Tcl_Free(encodingPtr->name); } - ckfree(encodingPtr); + Tcl_Free(encodingPtr); } } @@ -1137,7 +1031,7 @@ Tcl_CreateEncoding( const Tcl_EncodingType *typePtr) /* The encoding type. */ { - Encoding *encodingPtr = (Encoding *)ckalloc(sizeof(Encoding)); + Encoding *encodingPtr = (Encoding *)Tcl_Alloc(sizeof(Encoding)); encodingPtr->name = NULL; encodingPtr->toUtfProc = typePtr->toUtfProc; encodingPtr->fromUtfProc = typePtr->fromUtfProc; @@ -1171,7 +1065,7 @@ Tcl_CreateEncoding( replaceMe->hPtr = NULL; } - name = (char *)ckalloc(strlen(typePtr->encodingName) + 1); + name = (char *)Tcl_Alloc(strlen(typePtr->encodingName) + 1); encodingPtr->name = strcpy(name, typePtr->encodingName); encodingPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, encodingPtr); @@ -1202,6 +1096,7 @@ Tcl_CreateEncoding( *------------------------------------------------------------------------- */ +#undef Tcl_ExternalToUtfDString char * Tcl_ExternalToUtfDString( Tcl_Encoding encoding, /* The encoding for the source string, or NULL @@ -1274,7 +1169,7 @@ Tcl_ExternalToUtfDStringEx( char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; - int result, srcRead, dstWrote, dstChars; + int result; Tcl_Size dstLen, soFar; const char *srcStart = src; @@ -1303,23 +1198,44 @@ Tcl_ExternalToUtfDStringEx( if (src == NULL) { srcLen = 0; - } else if (srcLen < 0) { + } else if (srcLen == TCL_INDEX_NONE) { srcLen = encodingPtr->lengthProc(src); } - flags |= TCL_ENCODING_START | TCL_ENCODING_END; + flags |= TCL_ENCODING_START; if (encodingPtr->toUtfProc == UtfToUtfProc) { flags |= ENCODING_INPUT; } while (1) { + int srcChunkLen, srcChunkRead; + int dstChunkLen, dstChunkWrote, dstChunkChars; + + if (srcLen > INT_MAX) { + srcChunkLen = INT_MAX; + } else { + srcChunkLen = srcLen; + flags |= TCL_ENCODING_END; /* Last chunk */ + } + dstChunkLen = dstLen > INT_MAX ? INT_MAX : dstLen; + result = encodingPtr->toUtfProc(encodingPtr->clientData, src, - srcLen, flags, &state, dst, dstLen, - &srcRead, &dstWrote, &dstChars); - soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + srcChunkLen, flags, &state, dst, dstChunkLen, + &srcChunkRead, &dstChunkWrote, &dstChunkChars); + soFar = dst + dstChunkWrote - Tcl_DStringValue(dstPtr); + + src += srcChunkRead; - src += srcRead; - if (result != TCL_CONVERT_NOSPACE) { + /* + * Keep looping in two case - + * - our destination buffer did not have enough room + * - we had not passed in all the data and error indicated fragment + * of a multibyte character + * In both cases we have to grow buffer, move the input source pointer + * and loop. Otherwise, return the result we got. + */ + if ((result != TCL_CONVERT_NOSPACE) && + !(result == TCL_CONVERT_MULTIBYTE && (flags & TCL_ENCODING_END))) { Tcl_Size nBytesProcessed = (src - srcStart); Tcl_DStringSetLength(dstPtr, soFar); @@ -1350,9 +1266,9 @@ Tcl_ExternalToUtfDStringEx( return result; } - /* Expand space and continue */ flags &= ~TCL_ENCODING_START; - srcLen -= srcRead; + srcLen -= srcChunkRead; + if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); } @@ -1386,7 +1302,7 @@ Tcl_ExternalToUtf( Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ - Tcl_Size srcLen, /* Source string length in bytes, or < 0 for + Tcl_Size srcLen, /* Source string length in bytes, or TCL_INDEX_NONE for * encoding-specific string length. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state @@ -1424,13 +1340,20 @@ Tcl_ExternalToUtf( if (src == NULL) { srcLen = 0; - } else if (srcLen < 0) { + } else if (srcLen == TCL_INDEX_NONE) { srcLen = encodingPtr->lengthProc(src); } if (statePtr == NULL) { flags |= TCL_ENCODING_START | TCL_ENCODING_END; statePtr = &state; } + if (srcLen > INT_MAX) { + srcLen = INT_MAX; + flags &= ~TCL_ENCODING_END; + } + if (dstLen > INT_MAX) { + dstLen = INT_MAX; + } if (srcReadPtr == NULL) { srcReadPtr = &srcRead; } @@ -1445,9 +1368,9 @@ Tcl_ExternalToUtf( } if (!noTerminate) { - if (dstLen < 1) { - return TCL_CONVERT_NOSPACE; - } + if (dstLen < 1) { + return TCL_CONVERT_NOSPACE; + } /* * If there are any null characters in the middle of the buffer, * they will converted to the UTF-8 null character (\xC0\x80). To get @@ -1457,7 +1380,7 @@ Tcl_ExternalToUtf( dstLen--; } else { - if (dstLen < 0) { + if (dstLen <= 0 && srcLen > 0) { return TCL_CONVERT_NOSPACE; } } @@ -1473,7 +1396,7 @@ Tcl_ExternalToUtf( if (*dstCharsPtr <= maxChars) { break; } - dstLen = TclUtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1); + dstLen = Tcl_UtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1); *statePtr = savedState; } while (1); if (!noTerminate) { @@ -1504,7 +1427,7 @@ Tcl_ExternalToUtf( * *------------------------------------------------------------------------- */ - +#undef Tcl_UtfToExternalDString char * Tcl_UtfToExternalDString( Tcl_Encoding encoding, /* The encoding for the converted string, or @@ -1576,7 +1499,7 @@ Tcl_UtfToExternalDStringEx( char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; - int result, srcRead, dstWrote, dstChars; + int result; const char *srcStart = src; Tcl_Size dstLen, soFar; @@ -1605,21 +1528,44 @@ Tcl_UtfToExternalDStringEx( if (src == NULL) { srcLen = 0; - } else if (srcLen < 0) { + } else if (srcLen == TCL_INDEX_NONE) { srcLen = strlen(src); } - flags |= TCL_ENCODING_START | TCL_ENCODING_END; + flags |= TCL_ENCODING_START; while (1) { + int srcChunkLen, srcChunkRead; + int dstChunkLen, dstChunkWrote, dstChunkChars; + + if (srcLen > INT_MAX) { + srcChunkLen = INT_MAX; + } else { + srcChunkLen = srcLen; + flags |= TCL_ENCODING_END; /* Last chunk */ + } + dstChunkLen = dstLen > INT_MAX ? INT_MAX : dstLen; + result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, - srcLen, flags, &state, dst, dstLen, - &srcRead, &dstWrote, &dstChars); - soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + srcChunkLen, flags, &state, dst, dstChunkLen, + &srcChunkRead, &dstChunkWrote, &dstChunkChars); + soFar = dst + dstChunkWrote - Tcl_DStringValue(dstPtr); + + /* Move past the part processed in this go around */ + src += srcChunkRead; - src += srcRead; - if (result != TCL_CONVERT_NOSPACE) { + /* + * Keep looping in two case - + * - our destination buffer did not have enough room + * - we had not passed in all the data and error indicated fragment + * of a multibyte character + * In both cases we have to grow buffer, move the input source pointer + * and loop. Otherwise, return the result we got. + */ + if ((result != TCL_CONVERT_NOSPACE) && + !(result == TCL_CONVERT_MULTIBYTE && (flags & TCL_ENCODING_END))) { Tcl_Size nBytesProcessed = (src - srcStart); - int i = soFar + encodingPtr->nullSize - 1; + Tcl_Size i = soFar + encodingPtr->nullSize - 1; + /* Loop as DStringSetLength only stores one nul byte at a time */ while (i >= soFar) { Tcl_DStringSetLength(dstPtr, i--); } @@ -1632,7 +1578,7 @@ Tcl_UtfToExternalDStringEx( } else { /* Caller wants error message on failure */ if (result != TCL_OK && interp != NULL) { - Tcl_Size pos = TclNumUtfChars(srcStart, nBytesProcessed); + Tcl_Size pos = Tcl_NumUtfChars(srcStart, nBytesProcessed); int ucs4; char buf[TCL_INTEGER_SPACE]; Tcl_UtfToUniChar(&srcStart[nBytesProcessed], &ucs4); @@ -1655,7 +1601,8 @@ Tcl_UtfToExternalDStringEx( } flags &= ~TCL_ENCODING_START; - srcLen -= srcRead; + srcLen -= srcChunkRead; + if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); } @@ -1689,7 +1636,7 @@ Tcl_UtfToExternal( Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ - Tcl_Size srcLen, /* Source string length in bytes, or < 0 for + Tcl_Size srcLen, /* Source string length in bytes, or TCL_INDEX_NONE for * strlen(). */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state @@ -1724,13 +1671,20 @@ Tcl_UtfToExternal( if (src == NULL) { srcLen = 0; - } else if (srcLen < 0) { + } else if (srcLen == TCL_INDEX_NONE) { srcLen = strlen(src); } if (statePtr == NULL) { flags |= TCL_ENCODING_START | TCL_ENCODING_END; statePtr = &state; } + if (srcLen > INT_MAX) { + srcLen = INT_MAX; + flags &= ~TCL_ENCODING_END; + } + if (dstLen > INT_MAX) { + dstLen = INT_MAX; + } if (srcReadPtr == NULL) { srcReadPtr = &srcRead; } @@ -1971,7 +1925,7 @@ LoadEncodingFile( "invalid encoding file \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL); } - Tcl_Close(NULL, chan); + Tcl_CloseEx(NULL, chan, 0); return encoding; } @@ -2061,7 +2015,7 @@ LoadTableEncoding( #undef PAGESIZE #define PAGESIZE (256 * sizeof(unsigned short)) - dataPtr = (TableEncodingData *)ckalloc(sizeof(TableEncodingData)); + dataPtr = (TableEncodingData *)Tcl_Alloc(sizeof(TableEncodingData)); memset(dataPtr, 0, sizeof(TableEncodingData)); dataPtr->fallback = fallback; @@ -2073,7 +2027,7 @@ LoadTableEncoding( */ size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; - dataPtr->toUnicode = (unsigned short **)ckalloc(size); + dataPtr->toUnicode = (unsigned short **)Tcl_Alloc(size); memset(dataPtr->toUnicode, 0, size); pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256); @@ -2134,7 +2088,7 @@ LoadTableEncoding( } } size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; - dataPtr->fromUnicode = (unsigned short **)ckalloc(size); + dataPtr->fromUnicode = (unsigned short **)Tcl_Alloc(size); memset(dataPtr->fromUnicode, 0, size); pageMemPtr = (unsigned short *) (dataPtr->fromUnicode + 256); @@ -2230,7 +2184,7 @@ LoadTableEncoding( */ for (TclDStringClear(&lineString); - (len = Tcl_Gets(chan, &lineString)) >= 0; + (len = Tcl_Gets(chan, &lineString)) != -1; TclDStringClear(&lineString)) { const unsigned char *p; int to, from; @@ -2324,7 +2278,7 @@ LoadEscapeEncoding( Tcl_DString lineString; Tcl_DStringInit(&lineString); - if (Tcl_Gets(chan, &lineString) < 0) { + if (Tcl_Gets(chan, &lineString) == TCL_IO_FAILURE) { break; } line = Tcl_DStringValue(&lineString); @@ -2366,13 +2320,13 @@ LoadEscapeEncoding( Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); } } - ckfree(argv); + Tcl_Free(argv); Tcl_DStringFree(&lineString); } size = offsetof(EscapeEncodingData, subTables) + Tcl_DStringLength(&escapeData); - dataPtr = (EscapeEncodingData *)ckalloc(size); + dataPtr = (EscapeEncodingData *)Tcl_Alloc(size); dataPtr->initLen = strlen(init); memcpy(dataPtr->init, init, dataPtr->initLen + 1); dataPtr->finalLen = strlen(final); @@ -2531,6 +2485,7 @@ UtfToUtfProc( flags |= PTR2INT(clientData); dstEnd = dst + dstLen - ((flags & ENCODING_UTF) ? TCL_UTF_MAX : 6); + profile = ENCODING_PROFILE_GET(flags); for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { @@ -2569,8 +2524,7 @@ UtfToUtfProc( } } else { /* - * Convert 0xC080 to real nulls when we are in output mode, - * irrespective of the profile. + * For output convert 0xC080 to a real null. */ *dst++ = 0; src += 2; @@ -2579,10 +2533,10 @@ UtfToUtfProc( } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { /* * Incomplete byte sequence. - * Always check before using Tcl_UtfToUniChar. Not doing can so - * cause it run beyond the end of the buffer! If we happen such an - * incomplete char its bytes are made to represent themselves - * unless the user has explicitly asked to be told. + * Always check before using Tcl_UtfToUniChar. Not doing so can cause it + * run beyond the end of the buffer! If we happen on such an incomplete + * char its bytes are made to represent themselves unless the user has + * explicitly asked to be told. */ if (flags & ENCODING_INPUT) { @@ -2605,7 +2559,6 @@ UtfToUtfProc( } dst += Tcl_UniCharToUtf(ch, dst); } else { - int low; int isInvalid = 0; size_t len = Tcl_UtfToUniChar(src, &ch); if (flags & ENCODING_INPUT) { @@ -2635,39 +2588,10 @@ UtfToUtfProc( *dst++ = (char) (((ch >> 10) & 0x3F) | 0x80); ch = (ch & 0x0CFF) | 0xDC00; } - goto cesu8; - } else if ((ch | 0x7FF) == 0xDFFF) { - /* - * A surrogate character is detected, handle especially. - */ - if (PROFILE_STRICT(profile) && (flags & ENCODING_UTF)) { - result = TCL_CONVERT_UNKNOWN; - src = saveSrc; - break; - } - if (PROFILE_REPLACE(profile)) { - ch = UNICODE_REPLACE_CHAR; - } else { - low = ch; - len = (src <= srcEnd - 3) ? Tcl_UtfToUniChar(src, &low) : 0; - - if ((!LOW_SURROGATE(low)) || (ch & 0x400)) { - - if (PROFILE_STRICT(profile)) { - result = TCL_CONVERT_UNKNOWN; - src = saveSrc; - break; - } -cesu8: - *dst++ = (char)(((ch >> 12) | 0xE0) & 0xEF); - *dst++ = (char)(((ch >> 6) | 0x80) & 0xBF); - *dst++ = (char)((ch | 0x80) & 0xBF); - continue; - } - src += len; - dst += Tcl_UniCharToUtf(ch, dst); - ch = low; - } + *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); + *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); + *dst++ = (char) ((ch | 0x80) & 0xBF); + continue; } else if (PROFILE_STRICT(profile) && (!(flags & ENCODING_INPUT)) && SURROGATE(ch)) { @@ -2750,19 +2674,6 @@ Utf32ToUtfProc( srcLen -= bytesLeft; } - /* - * If last code point is a high surrogate, we cannot handle that yet, - * unless we are at the end. - */ - - if (!(flags & TCL_ENCODING_END) && (srcLen >= 4) && - ((src[srcLen - ((flags & TCL_ENCODING_LE)?3:2)] & 0xFC) == 0xD8) && - ((src[srcLen - ((flags & TCL_ENCODING_LE)?2:3)]) == 0) && - ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:4)]) == 0)) { - result = TCL_CONVERT_MULTIBYTE; - srcLen-= 4; - } - srcStart = src; srcEnd = src + srcLen; @@ -2775,17 +2686,11 @@ Utf32ToUtfProc( break; } - int prev = ch; if (flags & TCL_ENCODING_LE) { ch = (unsigned int)(src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16 | (src[1] & 0xFF) << 8 | (src[0] & 0xFF); } else { ch = (unsigned int)(src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); } - if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) { - /* Bug [10c2c17c32]. If Hi surrogate not followed by Lo surrogate, finish 3-byte UTF-8 */ - dst += Tcl_UniCharToUtf(-1, dst); - } - if ((unsigned)ch > 0x10FFFF) { ch = UNICODE_REPLACE_CHAR; if (PROFILE_STRICT(flags)) { @@ -2794,7 +2699,6 @@ Utf32ToUtfProc( } } else if (PROFILE_STRICT(flags) && SURROGATE(ch)) { result = TCL_CONVERT_SYNTAX; - ch = 0; break; } else if (PROFILE_REPLACE(flags) && SURROGATE(ch)) { ch = UNICODE_REPLACE_CHAR; @@ -2808,25 +2712,19 @@ Utf32ToUtfProc( if ((unsigned)ch - 1 < 0x7F) { *dst++ = (ch & 0xFF); } else { - if (!HIGH_SURROGATE(prev) && LOW_SURROGATE(ch)) { - *dst = 0; /* In case of lower surrogate, don't try to combine */ - } dst += Tcl_UniCharToUtf(ch, dst); } src += 4; } - if (HIGH_SURROGATE(ch)) { - /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */ - dst += Tcl_UniCharToUtf(-1, dst); - } - + /* + * If we had a truncated code unit at the end AND this is the last + * fragment AND profile is not "strict", stick FFFD in its place. + */ if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) { - /* We have a code fragment left-over at the end */ if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; } else { - /* destination is not full, so we really are at the end now */ if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; } else { @@ -3020,7 +2918,7 @@ Utf16ToUtfProc( dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; - for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { + for (numChars = 0; src < srcEnd && numChars <= charLimit; src += 2, numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; @@ -3039,9 +2937,23 @@ Utf16ToUtfProc( dst--; /* Also undo writing a single byte too much */ numChars--; break; - } + } else if (PROFILE_REPLACE(flags)) { + /* + * Previous loop wrote a single byte to mark the high surrogate. + * Replace it with the replacement character. Further, restart + * current loop iteration since need to recheck destination space + * and reset processing of current character. + */ + ch = UNICODE_REPLACE_CHAR; + dst--; + dst += Tcl_UniCharToUtf(ch, dst); + src -= 2; + numChars--; + continue; + } else { /* Bug [10c2c17c32]. If Hi surrogate not followed by Lo surrogate, finish 3-byte UTF-8 */ - dst += Tcl_UniCharToUtf(-1, dst); + dst += Tcl_UniCharToUtf(-1, dst); + } } /* @@ -3052,16 +2964,19 @@ Utf16ToUtfProc( if ((unsigned)ch - 1 < 0x7F) { *dst++ = (ch & 0xFF); } else if (HIGH_SURROGATE(prev) || HIGH_SURROGATE(ch)) { - dst += Tcl_UniCharToUtf(ch, dst); - } else if (LOW_SURROGATE(ch) && PROFILE_STRICT(flags)) { - /* Lo surrogate not preceded by Hi surrogate */ - result = TCL_CONVERT_SYNTAX; - break; + dst += Tcl_UniCharToUtf(ch | TCL_COMBINE, dst); + } else if (LOW_SURROGATE(ch) && !PROFILE_TCL8(flags)) { + /* Lo surrogate not preceded by Hi surrogate and not tcl8 profile */ + if (PROFILE_STRICT(flags)) { + result = TCL_CONVERT_UNKNOWN; + break; + } else { + /* PROFILE_REPLACE */ + dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); + } } else { - *dst = 0; /* In case of lower surrogate, don't try to combine */ dst += Tcl_UniCharToUtf(ch, dst); } - src += sizeof(unsigned short); } if (HIGH_SURROGATE(ch)) { @@ -3070,6 +2985,9 @@ Utf16ToUtfProc( src -= 2; dst--; numChars--; + } else if (PROFILE_REPLACE(flags)) { + dst--; + dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); } else { /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */ dst += Tcl_UniCharToUtf(-1, dst); @@ -3516,8 +3434,9 @@ TableFromUtfProc( /* Unicode chars > +U0FFFF cannot be represented in any table encoding */ if (ch & 0xFFFF0000) { word = 0; - } else - word = fromUnicode[(ch >> 8)][ch & 0xFF]; + } else { + word = fromUnicode[(ch >> 8)][ch & 0xFF]; + } if ((word == 0) && (ch != 0)) { if (PROFILE_STRICT(flags)) { @@ -3703,8 +3622,7 @@ Iso88591FromUtfProc( * Check for illegal characters. */ - if (ch > 0xFF - ) { + if (ch > 0xFF) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; @@ -3758,11 +3676,11 @@ TableFreeProc( * Make sure we aren't freeing twice on shutdown. [Bug 219314] */ - ckfree(dataPtr->toUnicode); + Tcl_Free(dataPtr->toUnicode); dataPtr->toUnicode = NULL; - ckfree(dataPtr->fromUnicode); + Tcl_Free(dataPtr->fromUnicode); dataPtr->fromUnicode = NULL; - ckfree(dataPtr); + Tcl_Free(dataPtr); } /* @@ -4238,7 +4156,7 @@ EscapeFreeProc( subTablePtr++; } } - ckfree(dataPtr); + Tcl_Free(dataPtr); } /* @@ -4352,7 +4270,7 @@ unilen4( static void InitializeEncodingSearchPath( char **valuePtr, - TCL_HASH_TYPE *lengthPtr, + size_t *lengthPtr, Tcl_Encoding *encodingPtr) { const char *bytes; @@ -4363,7 +4281,7 @@ InitializeEncodingSearchPath( TclNewObj(searchPathObj); Tcl_IncrRefCount(encodingObj); Tcl_IncrRefCount(searchPathObj); - libPathObj = TclGetLibraryPath(); + libPathObj = TclGetProcessGlobalValue(&libraryPath); Tcl_IncrRefCount(libPathObj); TclListObjLengthM(NULL, libPathObj, &numDirs); @@ -4386,10 +4304,10 @@ InitializeEncodingSearchPath( if (*encodingPtr) { ((Encoding *)(*encodingPtr))->refCount++; } - bytes = TclGetStringFromObj(searchPathObj, &numBytes); + bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes); *lengthPtr = numBytes; - *valuePtr = (char *)ckalloc(numBytes + 1); + *valuePtr = (char *)Tcl_Alloc(numBytes + 1); memcpy(*valuePtr, bytes, numBytes + 1); Tcl_DecrRefCount(searchPathObj); } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index cdc13af..8614171 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -81,7 +81,8 @@ static const Tcl_ObjType ensembleCmdType = { FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define ECRSetInternalRep(objPtr, ecRepPtr) \ @@ -163,7 +164,7 @@ TclNamespaceEnsembleCmd( Tcl_DictSearch search; Tcl_Obj *listObj; const char *simpleName; - int index; + enum EnsSubcmds index; int done; if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { @@ -185,7 +186,7 @@ TclNamespaceEnsembleCmd( return TCL_ERROR; } - switch ((enum EnsSubcmds) index) { + switch (index) { case ENS_CREATE: { const char *name; Tcl_Size len; @@ -221,14 +222,15 @@ TclNamespaceEnsembleCmd( */ for (; objc>1 ; objc-=2,objv+=2) { + enum EnsCreateOpts idx; if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions, - "option", 0, &index) != TCL_OK) { + "option", 0, &idx) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } - switch ((enum EnsCreateOpts) index) { + switch (idx) { case CRT_CMD: name = TclGetString(objv[1]); cxtPtr = nsPtr; @@ -400,13 +402,14 @@ TclNamespaceEnsembleCmd( } if (objc == 4) { + enum EnsConfigOpts idx; Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions, - "option", 0, &index) != TCL_OK) { + "option", 0, &idx) != TCL_OK) { return TCL_ERROR; } - switch ((enum EnsConfigOpts) index) { + switch (idx) { case CONF_SUBCMDS: Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); if (resultObj != NULL) { @@ -524,15 +527,16 @@ TclNamespaceEnsembleCmd( */ for (; objc>0 ; objc-=2,objv+=2) { + enum EnsConfigOpts idx; if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions, - "option", 0, &index) != TCL_OK) { + "option", 0, &idx) != TCL_OK) { freeMapAndError: if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } - switch ((enum EnsConfigOpts) index) { + switch (idx) { case CONF_SUBCMDS: if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) { goto freeMapAndError; @@ -686,12 +690,12 @@ TclCreateEnsembleInNs( EnsembleConfig *ensemblePtr; Tcl_Command token; - ensemblePtr = (EnsembleConfig *)ckalloc(sizeof(EnsembleConfig)); + ensemblePtr = (EnsembleConfig *)Tcl_Alloc(sizeof(EnsembleConfig)); token = TclNRCreateCommandInNs(interp, name, (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); if (token == NULL) { - ckfree(ensemblePtr); + Tcl_Free(ensemblePtr); return NULL; } @@ -1658,7 +1662,7 @@ TclMakeEnsemble( Tcl_DStringFree(&buf); Tcl_DStringFree(&hiddenBuf); if (nameParts != NULL) { - ckfree(nameParts); + Tcl_Free((void *)nameParts); } return ensemble; } @@ -1821,7 +1825,7 @@ NsEnsembleImplementationCmdNR( Tcl_Size tableLength = ensemblePtr->subcommandTable.numEntries; Tcl_Obj *fix; - subcmdName = TclGetStringFromObj(subObj, &stringLength); + subcmdName = Tcl_GetStringFromObj(subObj, &stringLength); for (i=0 ; i<tableLength ; i++) { int cmp = strncmp(subcmdName, ensemblePtr->subcommandArrayPtr[i], @@ -2106,8 +2110,8 @@ FreeER( Tcl_Obj **tmp = (Tcl_Obj **) data[0]; Tcl_Obj **store = (Tcl_Obj **) data[1]; - ckfree(store); - ckfree(tmp); + Tcl_Free(store); + Tcl_Free(tmp); return result; } @@ -2182,9 +2186,9 @@ TclSpellFix( if (search[0] == NULL) { store = (Tcl_Obj **) search[2]; } else { - Tcl_Obj **tmp = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *)); + Tcl_Obj **tmp = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *)); - store = (Tcl_Obj **)ckalloc(size * sizeof(Tcl_Obj *)); + store = (Tcl_Obj **)Tcl_Alloc(size * sizeof(Tcl_Obj *)); memcpy(store, iPtr->ensembleRewrite.sourceObjs, size * sizeof(Tcl_Obj *)); @@ -2437,7 +2441,7 @@ MakeCachedEnsembleCommand( * Replace any old internal representation with a new one. */ - ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep)); + ensembleCmd = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep)); ECRSetInternalRep(objPtr, ensembleCmd); } @@ -2489,7 +2493,7 @@ ClearTable( Tcl_DecrRefCount(prefixObj); hPtr = Tcl_NextHashEntry(&search); } - ckfree((char *) ensemblePtr->subcommandArrayPtr); + Tcl_Free(ensemblePtr->subcommandArrayPtr); } Tcl_DeleteHashTable(hash); } @@ -2656,7 +2660,7 @@ BuildEnsembleConfig( * Target was not in the dictionary. Map onto the namespace. * In this case there is no guarantee that the command * is actually there. It is the responsibility of the - * programmer (or [::unknown] of course) to provide the procedure. + * programmer (or [::unknown] of course) to provide the procedure. */ cmdObj = Tcl_NewStringObj(name, -1); @@ -2751,7 +2755,7 @@ BuildEnsembleConfig( */ ensemblePtr->subcommandArrayPtr = - (char **)ckalloc(sizeof(char *) * hash->numEntries); + (char **)Tcl_Alloc(sizeof(char *) * hash->numEntries); /* * Fill the array from both ends as this reduces the likelihood of @@ -2844,7 +2848,7 @@ FreeEnsembleCmdRep( if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } - ckfree(ensembleCmd); + Tcl_Free(ensembleCmd); } /* @@ -2871,7 +2875,7 @@ DupEnsembleCmdRep( Tcl_Obj *copyPtr) { EnsembleCmdRep *ensembleCmd; - EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep)); + EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep)); ECRGetInternalRep(objPtr, ensembleCmd); ECRSetInternalRep(copyPtr, ensembleCopy); @@ -2924,8 +2928,7 @@ TclCompileEnsemble( Command *oldCmdPtr = cmdPtr, *newCmdPtr; int result, flags = 0, depth = 1, invokeAnyway = 0; int ourResult = TCL_ERROR; - Tcl_Size i, len; - TCL_HASH_TYPE numBytes; + Tcl_Size i, len, numBytes; const char *word; TclNewObj(replaced); @@ -3003,8 +3006,8 @@ TclCompileEnsemble( goto failed; } for (i=0 ; i<len ; i++) { - str = TclGetStringFromObj(elems[i], &sclen); - if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) { + str = Tcl_GetStringFromObj(elems[i], &sclen); + if ((sclen == numBytes) && !memcmp(word, str, numBytes)) { /* * Exact match! Excellent! */ @@ -3157,7 +3160,7 @@ TclCompileEnsemble( if (cmdPtr->compileProc == TclCompileEnsemble) { tokenPtr = TokenAfter(tokenPtr); - if (parsePtr->numWords < depth + 1 + if ((int)parsePtr->numWords < depth + 1 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* * Too hard because the user has done something unpleasant like @@ -3192,7 +3195,7 @@ TclCompileEnsemble( while (mapPtr->nuloc > eclIndex + 1) { mapPtr->nuloc--; - ckfree(mapPtr->loc[mapPtr->nuloc].line); + Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; } @@ -3261,7 +3264,7 @@ TclAttemptCompileProc( Tcl_Size i; Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; Tcl_Size savedStackDepth = envPtr->currStackDepth; - TCL_HASH_TYPE savedCodeNext = envPtr->codeNext - envPtr->codeStart; + Tcl_Size savedCodeNext = envPtr->codeNext - envPtr->codeStart; Tcl_Size savedAuxDataArrayNext = envPtr->auxDataArrayNext; Tcl_Size savedExceptArrayNext = envPtr->exceptArrayNext; #ifdef TCL_COMPILE_DEBUG @@ -3325,12 +3328,12 @@ TclAttemptCompileProc( for (i = 0; i < savedExceptArrayNext; i++) { while (auxPtr->numBreakTargets > 0 - && auxPtr->breakTargets[auxPtr->numBreakTargets - 1] + && (Tcl_Size) auxPtr->breakTargets[auxPtr->numBreakTargets - 1] >= savedCodeNext) { auxPtr->numBreakTargets--; } while (auxPtr->numContinueTargets > 0 - && auxPtr->continueTargets[auxPtr->numContinueTargets - 1] + && (Tcl_Size) auxPtr->continueTargets[auxPtr->numContinueTargets - 1] >= savedCodeNext) { auxPtr->numContinueTargets--; } @@ -3368,7 +3371,7 @@ TclAttemptCompileProc( if (diff != 1) { Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, + " %.*s (was %d instead of 1)", (int)parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, diff); } #endif @@ -3407,7 +3410,7 @@ CompileToInvokedCommand( for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i <= numWords) { - bytes = TclGetStringFromObj(words[i-1], &length); + bytes = Tcl_GetStringFromObj(words[i-1], &length); PushLiteral(envPtr, bytes, length); continue; } @@ -3436,7 +3439,7 @@ CompileToInvokedCommand( TclNewObj(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = TclGetStringFromObj(objPtr, &length); + bytes = Tcl_GetStringFromObj(objPtr, &length); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { extraLiteralFlags |= LITERAL_UNSHARED; } @@ -3697,7 +3700,7 @@ TclCompileBasicMin0ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords < 1) { + if ((int)parsePtr->numWords < 1) { return TCL_ERROR; } @@ -3719,7 +3722,7 @@ TclCompileBasicMin1ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords < 2) { + if ((int)parsePtr->numWords < 2) { return TCL_ERROR; } @@ -3741,7 +3744,7 @@ TclCompileBasicMin2ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if (parsePtr->numWords < 3) { + if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } diff --git a/generic/tclEnv.c b/generic/tclEnv.c index ef5cfb7..ef4e946 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -280,11 +280,11 @@ TclSetEnv( */ if ((env.ourEnviron != tenviron) || (length+2 > env.ourEnvironSize)) { - techar **newEnviron = (techar **)ckalloc((length + 5) * sizeof(techar *)); + techar **newEnviron = (techar **)Tcl_Alloc((length + 5) * sizeof(techar *)); memcpy(newEnviron, tenviron, length * sizeof(techar *)); if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) { - ckfree(env.ourEnviron); + Tcl_Free(env.ourEnviron); } tenviron = (env.ourEnviron = newEnviron); env.ourEnvironSize = length + 5; @@ -324,14 +324,14 @@ TclSetEnv( */ valueLength = strlen(value); - p = (char *)ckalloc(nameLength + valueLength + 2); + p = (char *)Tcl_Alloc(nameLength + valueLength + 2); memcpy(p, name, nameLength); p[nameLength] = '='; memcpy(p+nameLength+1, value, valueLength+1); p2 = utf2tenvirondstr(p, &envString); if (p2 == NULL) { /* No way to signal error from here :-( but should not happen */ - ckfree(p); + Tcl_Free(p); Tcl_MutexUnlock(&envMutex); return; } @@ -340,7 +340,7 @@ TclSetEnv( * Copy the native string to heap memory. */ - p = (char *)ckrealloc(p, Tcl_DStringLength(&envString) + tNTL); + p = (char *)Tcl_Realloc(p, Tcl_DStringLength(&envString) + tNTL); memcpy(p, p2, Tcl_DStringLength(&envString) + tNTL); Tcl_DStringFree(&envString); @@ -369,20 +369,11 @@ TclSetEnv( * This putenv() copies instead of taking ownership. */ - ckfree(p); + Tcl_Free(p); #endif /* HAVE_PUTENV_THAT_COPIES */ } Tcl_MutexUnlock(&envMutex); - - if (!strcmp(name, "HOME")) { - /* - * If the user's home directory has changed, we must invalidate the - * filesystem cache, because '~' expansions will now be incorrect. - */ - - Tcl_FSMountsChanged(NULL); - } } /* @@ -511,12 +502,12 @@ TclUnsetEnv( */ #if defined(_WIN32) - string = (char *)ckalloc(length + 2); + string = (char *)Tcl_Alloc(length + 2); memcpy(string, name, length); string[length] = '='; string[length+1] = '\0'; #else - string = (char *)ckalloc(length + 1); + string = (char *)Tcl_Alloc(length + 1); memcpy(string, name, length); string[length] = '\0'; #endif /* _WIN32 */ @@ -526,7 +517,7 @@ TclUnsetEnv( Tcl_MutexUnlock(&envMutex); return; } - string = (char *)ckrealloc(string, Tcl_DStringLength(&envString) + tNTL); + string = (char *)Tcl_Realloc(string, Tcl_DStringLength(&envString) + tNTL); memcpy(string, Tcl_DStringValue(&envString), Tcl_DStringLength(&envString) + tNTL); Tcl_DStringFree(&envString); @@ -547,7 +538,7 @@ TclUnsetEnv( * This putenv() copies instead of taking ownership. */ - ckfree(string); + Tcl_Free(string); #endif /* HAVE_PUTENV_THAT_COPIES */ } #else /* !USE_PUTENV_FOR_UNSET */ @@ -673,8 +664,19 @@ EnvTraceProc( if (flags & TCL_TRACE_WRITES) { const char *value; + Tcl_DString ds; value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY); + Tcl_DStringInit(&ds); + if (Tcl_UtfToExternalDStringEx(NULL, TCLFSENCODING, name2, -1, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return (char *) "encoding error"; + } + if (Tcl_UtfToExternalDStringEx(NULL, TCLFSENCODING, value, -1, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return (char *) "encoding error"; + } + Tcl_DStringFree(&ds); TclSetEnv(name2, value); TclEnvEpoch++; } @@ -748,7 +750,7 @@ ReplaceString( */ if (env.cache[i]) { - ckfree(env.cache[i]); + Tcl_Free(env.cache[i]); } if (newStr) { @@ -766,11 +768,11 @@ ReplaceString( const int growth = 5; - env.cache = (char **)ckrealloc(env.cache, + env.cache = (char **)Tcl_Realloc(env.cache, (env.cacheSize + growth) * sizeof(char *)); env.cache[env.cacheSize] = newStr; (void) memset(env.cache+env.cacheSize+1, 0, - (size_t) (growth-1) * sizeof(char *)); + (growth-1) * sizeof(char *)); env.cacheSize += growth; } } @@ -809,15 +811,15 @@ TclFinalizeEnvironment(void) #ifdef PURIFY Tcl_Size i; for (i = 0; i < env.cacheSize; i++) { - ckfree(env.cache[i]); + Tcl_Free(env.cache[i]); } #endif - ckfree(env.cache); + Tcl_Free(env.cache); env.cache = NULL; env.cacheSize = 0; #ifndef USE_PUTENV if ((env.ourEnviron != NULL)) { - ckfree(env.ourEnviron); + Tcl_Free(env.ourEnviron); env.ourEnviron = NULL; } env.ourEnvironSize = 0; diff --git a/generic/tclEvent.c b/generic/tclEvent.c index ef87c47..af76051 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -143,7 +143,7 @@ static void FinalizeThread(int quick); /* *---------------------------------------------------------------------- * - * Tcl_BackgroundError -- + * Tcl_BackgroundException -- * * This function is invoked to handle errors that occur in Tcl commands * that are invoked in "background" (e.g. from event or timer bindings). @@ -158,17 +158,6 @@ static void FinalizeThread(int quick); *---------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -#undef Tcl_BackgroundError -void -Tcl_BackgroundError( - Tcl_Interp *interp) /* Interpreter in which an error has - * occurred. */ -{ - Tcl_BackgroundException(interp, TCL_ERROR); -} -#endif /* TCL_NO_DEPRECATED */ - void Tcl_BackgroundException( Tcl_Interp *interp, /* Interpreter in which an exception has @@ -182,7 +171,7 @@ Tcl_BackgroundException( return; } - errPtr = (BgError*)ckalloc(sizeof(BgError)); + errPtr = (BgError*)Tcl_Alloc(sizeof(BgError)); errPtr->errorMsg = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errPtr->errorMsg); errPtr->returnOpts = Tcl_GetReturnOptions(interp, code); @@ -250,7 +239,7 @@ HandleBgErrors( errPtr = assocPtr->firstBgPtr; TclListObjGetElementsM(NULL, copyObj, &prefixObjc, &prefixObjv); - tempObjv = (Tcl_Obj**)ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *)); + tempObjv = (Tcl_Obj**)Tcl_Alloc((prefixObjc+2) * sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; tempObjv[prefixObjc+1] = errPtr->returnOpts; @@ -265,8 +254,8 @@ HandleBgErrors( Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); assocPtr->firstBgPtr = errPtr->nextPtr; - ckfree(errPtr); - ckfree(tempObjv); + Tcl_Free(errPtr); + Tcl_Free(tempObjv); if (code == TCL_BREAK) { /* @@ -279,7 +268,7 @@ HandleBgErrors( assocPtr->firstBgPtr = errPtr->nextPtr; Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); - ckfree(errPtr); + Tcl_Free(errPtr); } } else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); @@ -556,7 +545,7 @@ TclSetBgErrorHandler( * First access: initialize. */ - assocPtr = (ErrAssocData*)ckalloc(sizeof(ErrAssocData)); + assocPtr = (ErrAssocData*)Tcl_Alloc(sizeof(ErrAssocData)); assocPtr->interp = interp; assocPtr->cmdPrefix = NULL; assocPtr->firstBgPtr = NULL; @@ -635,7 +624,7 @@ BgErrorDeleteProc( assocPtr->firstBgPtr = errPtr->nextPtr; Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); - ckfree(errPtr); + Tcl_Free(errPtr); } Tcl_CancelIdleCall(HandleBgErrors, assocPtr); Tcl_DecrRefCount(assocPtr->cmdPrefix); @@ -665,7 +654,7 @@ Tcl_CreateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ void *clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler)); + ExitHandler *exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; @@ -698,7 +687,7 @@ TclCreateLateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ void *clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler)); + ExitHandler *exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; @@ -743,7 +732,7 @@ Tcl_DeleteExitHandler( } else { prevPtr->nextPtr = exitPtr->nextPtr; } - ckfree(exitPtr); + Tcl_Free(exitPtr); break; } } @@ -786,7 +775,7 @@ TclDeleteLateExitHandler( } else { prevPtr->nextPtr = exitPtr->nextPtr; } - ckfree(exitPtr); + Tcl_Free(exitPtr); break; } } @@ -820,7 +809,7 @@ Tcl_CreateThreadExitHandler( ExitHandler *exitPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler)); + exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; exitPtr->nextPtr = tsdPtr->firstExitPtr; @@ -862,7 +851,7 @@ Tcl_DeleteThreadExitHandler( } else { prevPtr->nextPtr = exitPtr->nextPtr; } - ckfree(exitPtr); + Tcl_Free(exitPtr); return; } } @@ -940,7 +929,7 @@ InvokeExitHandlers(void) firstExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); exitPtr->proc(exitPtr->clientData); - ckfree(exitPtr); + Tcl_Free(exitPtr); Tcl_MutexLock(&exitMutex); } firstExitPtr = NULL; @@ -1248,7 +1237,7 @@ Tcl_Finalize(void) firstLateExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); exitPtr->proc(exitPtr->clientData); - ckfree(exitPtr); + Tcl_Free(exitPtr); Tcl_MutexLock(&exitMutex); } firstLateExitPtr = NULL; @@ -1359,7 +1348,7 @@ Tcl_Finalize(void) TclResetFilesystem(); /* - * At this point, there should no longer be any ckalloc'ed memory. + * At this point, there should no longer be any Tcl_Alloc'ed memory. */ TclFinalizeMemorySubsystem(); @@ -1418,7 +1407,7 @@ FinalizeThread( tsdPtr->firstExitPtr = exitPtr->nextPtr; exitPtr->proc(exitPtr->clientData); - ckfree(exitPtr); + Tcl_Free(exitPtr); } TclFinalizeIOSubsystem(); TclFinalizeNotifier(); @@ -1530,7 +1519,7 @@ Tcl_VwaitObjCmd( OPT_TIMEOUT, OPT_VARIABLE, OPT_WRITABLE, OPT_LAST } index; - if ((objc == 2) && (strcmp(TclGetString(objv[1]), "--") != 0)) { + if ((objc == 2) && (strcmp(Tcl_GetString(objv[1]), "--") != 0)) { /* * Legacy "vwait" syntax, skip option handling. */ @@ -1539,7 +1528,7 @@ Tcl_VwaitObjCmd( } if ((unsigned) objc - 1 > sizeof(localItems) / sizeof(localItems[0])) { - vwaitItems = (VwaitItem *) ckalloc(sizeof(VwaitItem) * (objc - 1)); + vwaitItems = (VwaitItem *) Tcl_Alloc(sizeof(VwaitItem) * (objc - 1)); } for (i = 1; i < objc; i++) { @@ -1869,7 +1858,7 @@ Tcl_VwaitObjCmd( result = Tcl_RestoreInterpState(interp, saved); } if (vwaitItems != localItems) { - ckfree(vwaitItems); + Tcl_Free(vwaitItems); } return result; } @@ -1966,8 +1955,7 @@ Tcl_UpdateObjCmd( { int flags = 0; /* Initialized to avoid compiler warning. */ static const char *const updateOptions[] = {"idletasks", NULL}; - enum updateOptionsEnum {OPT_IDLETASKS}; - int optionIndex; + enum updateOptionsEnum {OPT_IDLETASKS} optionIndex; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; @@ -1976,7 +1964,7 @@ Tcl_UpdateObjCmd( "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum updateOptionsEnum) optionIndex) { + switch (optionIndex) { case OPT_IDLETASKS: flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; @@ -2035,7 +2023,7 @@ NewThreadProc( threadProc = cdPtr->proc; threadClientData = cdPtr->clientData; - ckfree(clientData); /* Allocated in Tcl_CreateThread() */ + Tcl_Free(clientData); /* Allocated in Tcl_CreateThread() */ threadProc(threadClientData); @@ -2067,19 +2055,19 @@ 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. */ { #if TCL_THREADS - ThreadClientData *cdPtr = (ThreadClientData *)ckalloc(sizeof(ThreadClientData)); + ThreadClientData *cdPtr = (ThreadClientData *)Tcl_Alloc(sizeof(ThreadClientData)); int result; cdPtr->proc = proc; cdPtr->clientData = clientData; result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags); if (result != TCL_OK) { - ckfree(cdPtr); + Tcl_Free(cdPtr); } return result; #else diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fd955f5..225cc53 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -77,7 +77,7 @@ int tclTraceExec = 0; */ static const char *const operatorStrings[] = { - "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", + "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!" }; @@ -101,64 +101,6 @@ size_t tclObjsAlloced = 0; size_t tclObjsFreed = 0; size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ - -/* - * Support pre-8.5 bytecodes unless specifically requested otherwise. - */ - -#ifndef TCL_SUPPORT_84_BYTECODE -#define TCL_SUPPORT_84_BYTECODE 1 -#endif - -#if TCL_SUPPORT_84_BYTECODE -/* - * We need to know the tclBuiltinFuncTable to support translation of pre-8.5 - * math functions to the namespace-based ::tcl::mathfunc::op in 8.5+. - */ - -typedef struct { - const char *name; /* Name of function. */ - int numArgs; /* Number of arguments for function. */ -} BuiltinFunc; - -/* - * Table describing the built-in math functions. Entries in this table are - * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's - * operand byte. - */ - -static BuiltinFunc const tclBuiltinFuncTable[] = { - {"acos", 1}, - {"asin", 1}, - {"atan", 1}, - {"atan2", 2}, - {"ceil", 1}, - {"cos", 1}, - {"cosh", 1}, - {"exp", 1}, - {"floor", 1}, - {"fmod", 2}, - {"hypot", 2}, - {"log", 1}, - {"log10", 1}, - {"pow", 2}, - {"sin", 1}, - {"sinh", 1}, - {"sqrt", 1}, - {"tan", 1}, - {"tanh", 1}, - {"abs", 1}, - {"double", 1}, - {"int", 1}, - {"rand", 0}, - {"round", 1}, - {"srand", 1}, - {"wide", 1}, - {NULL, 0}, -}; - -#define LAST_BUILTIN_FUNC 25 -#endif /* * NR_TEBC @@ -693,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); @@ -701,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; @@ -719,7 +661,8 @@ static const Tcl_ObjType exprCodeType = { FreeExprCodeInternalRep, /* freeIntRepProc */ DupExprCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -730,7 +673,8 @@ static const Tcl_ObjType exprCodeType = { static const Tcl_ObjType dictIteratorType = { "dictIterator", ReleaseDictIterator, - NULL, NULL, NULL + NULL, NULL, NULL, + TCL_OBJTYPE_V0 }; /* @@ -768,7 +712,7 @@ ReleaseDictIterator( searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1; Tcl_DictObjDone(searchPtr); - ckfree(searchPtr); + Tcl_Free(searchPtr); dictPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2; TclDecrRefCount(dictPtr); @@ -848,11 +792,11 @@ 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 *)ckalloc(sizeof(ExecEnv)); - ExecStack *esPtr = (ExecStack *)ckalloc(offsetof(ExecStack, stackWords) + ExecEnv *eePtr = (ExecEnv *)Tcl_Alloc(sizeof(ExecEnv)); + ExecStack *esPtr = (ExecStack *)Tcl_Alloc(offsetof(ExecStack, stackWords) + size * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; @@ -912,7 +856,7 @@ DeleteExecStack( if (esPtr->nextPtr) { esPtr->nextPtr->prevPtr = esPtr->prevPtr; } - ckfree(esPtr); + Tcl_Free(esPtr); } void @@ -944,7 +888,7 @@ TclDeleteExecEnv( if (eePtr->corPtr && !cachedInExit) { Tcl_Panic("Deleting execEnv with existing coroutine"); } - ckfree(eePtr); + Tcl_Free(eePtr); } /* @@ -1030,12 +974,13 @@ static Tcl_Obj ** GrowEvaluationStack( ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation * stack to enlarge. */ - TCL_HASH_TYPE growth, /* 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; Tcl_Size moveWords = 0; @@ -1121,7 +1066,7 @@ GrowEvaluationStack( newBytes = offsetof(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *); oldPtr = esPtr; - esPtr = (ExecStack *)ckalloc(newBytes); + esPtr = (ExecStack *)Tcl_Alloc(newBytes); oldPtr->nextPtr = esPtr; esPtr->prevPtr = oldPtr; @@ -1181,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 @@ -1199,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; @@ -1220,7 +1165,7 @@ TclStackFree( Tcl_Obj **markerPtr, *marker; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - ckfree(freePtr); + Tcl_Free(freePtr); return; } @@ -1278,13 +1223,13 @@ 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 ckalloc(numBytes); + return Tcl_Alloc(numBytes); } numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return StackAllocWords(interp, numWords); @@ -1294,16 +1239,16 @@ 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 ckrealloc((char *)ptr, numBytes); + return Tcl_Realloc(ptr, numBytes); } eePtr = iPtr->execEnvPtr; @@ -1492,7 +1437,7 @@ CompileExprObj( */ Tcl_Size length; - const char *string = TclGetStringFromObj(objPtr, &length); + const char *string = Tcl_GetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); TclCompileExpr(interp, string, length, &compEnv, 0); @@ -1902,7 +1847,7 @@ ArgumentBCEnter( ByteCode *codePtr, TEBCdata *tdPtr, const unsigned char *pc, - Tcl_Size objc, + int objc, Tcl_Obj **objv) { Tcl_Size cmd; @@ -1943,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); @@ -2653,13 +2598,16 @@ TEBCresume( case INST_STR_CONCAT1: opnd = TclGetUInt1AtPtr(pc+1); + DECACHE_STACK_INFO(); objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), TCL_STRING_IN_PLACE); if (objResultPtr == NULL) { + CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } + CACHE_STACK_INFO(); TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); break; @@ -2683,7 +2631,7 @@ TEBCresume( * command starts. * * Use a Tcl_Obj as linked list element; slight mem waste, but faster - * allocation than ckalloc. This also abuses the Tcl_Obj structure, as + * allocation than Tcl_Alloc. This also abuses the Tcl_Obj structure, as * we do not define a special tclObjType for it. It is not dangerous * as the obj is never passed anywhere, so that all manipulations are * performed here and in INST_INVOKE_EXPANDED (in case of an expansion @@ -2718,7 +2666,7 @@ TEBCresume( case INST_EXPAND_STKTOP: { Tcl_Size i; TEBCdata *newTD; - ptrdiff_t oldCatchTopOff, oldTosPtrOff; + Tcl_Size oldCatchTopOff, oldTosPtrOff; /* * Make sure that the element at stackTop is a list; if not, just @@ -2879,93 +2827,12 @@ TEBCresume( pc += pcAdjustment; TEBC_YIELD(); - return TclNREvalObjv(interp, objc, objv, + if (objc > INT_MAX) { + return TclCommandWordLimitError(interp, objc); + } else { + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); - -#if TCL_SUPPORT_84_BYTECODE - case INST_CALL_BUILTIN_FUNC1: - /* - * Call one of the built-in pre-8.5 Tcl math functions. This - * translates to INST_INVOKE_STK1 with the first argument of - * ::tcl::mathfunc::$objv[0]. We need to insert the named math - * function into the stack. - */ - - opnd = TclGetUInt1AtPtr(pc+1); - if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { - TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); - Tcl_Panic("TclNRExecuteByteCode: unrecognized builtin function code %d", opnd); - } - - TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::"); - Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1); - - /* - * Only 0, 1 or 2 args. - */ - - { - int numArgs = tclBuiltinFuncTable[opnd].numArgs; - Tcl_Obj *tmpPtr1, *tmpPtr2; - - if (numArgs == 0) { - PUSH_OBJECT(objPtr); - } else if (numArgs == 1) { - tmpPtr1 = POP_OBJECT(); - PUSH_OBJECT(objPtr); - PUSH_OBJECT(tmpPtr1); - Tcl_DecrRefCount(tmpPtr1); - } else { - tmpPtr2 = POP_OBJECT(); - tmpPtr1 = POP_OBJECT(); - PUSH_OBJECT(objPtr); - PUSH_OBJECT(tmpPtr1); - PUSH_OBJECT(tmpPtr2); - Tcl_DecrRefCount(tmpPtr1); - Tcl_DecrRefCount(tmpPtr2); - } - objc = numArgs + 1; } - pcAdjustment = 2; - goto doInvocation; - - case INST_CALL_FUNC1: - /* - * Call a non-builtin Tcl math function previously registered by a - * call to Tcl_CreateMathFunc pre-8.5. This is essentially - * INST_INVOKE_STK1 converting the first arg to - * ::tcl::mathfunc::$objv[0]. - */ - - objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function - * name is the 0-th argument. */ - - objPtr = OBJ_AT_DEPTH(objc-1); - TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::"); - Tcl_AppendObjToObj(tmpPtr, objPtr); - Tcl_DecrRefCount(objPtr); - - /* - * Variation of PUSH_OBJECT. - */ - - OBJ_AT_DEPTH(objc-1) = tmpPtr; - Tcl_IncrRefCount(tmpPtr); - - pcAdjustment = 2; - goto doInvocation; -#else - /* - * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the - * changes to add a ::tcl::mathfunc namespace in 8.5. Optional support - * remains for existing bytecode precompiled files. - */ - - case INST_CALL_BUILTIN_FUNC1: - Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); - case INST_CALL_FUNC1: - Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found"); -#endif case INST_INVOKE_REPLACE: objc = TclGetUInt4AtPtr(pc+1); @@ -2979,10 +2846,10 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%" TCL_SIZE_MODIFIER "d => call (implementation %s) ", objc, O2S(objPtr))); + TRACE(("%" TCL_Z_MODIFIER "u => call (implementation %s) ", objc, O2S(objPtr))); } else { fprintf(stdout, - "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking (using implementation %s) ", + "%" TCL_Z_MODIFIER "d: (%" TCL_T_MODIFIER "u) invoking (using implementation %s) ", iPtr->numLevels, (pc - codePtr->codeStart), O2S(objPtr)); } @@ -4053,34 +3920,82 @@ TEBCresume( CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; + } + break; - /* - * This is really an unset operation these days. Do not issue. - */ + /* + * End of INST_UNSET instructions. + * ----------------------------------------------------------------- + * Start of INST_CONST instructions. + */ + { + const char *msgPart; - case INST_DICT_DONE: + case INST_CONST_IMM: opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => OK\n", opnd)); + pcAdjustment = 5; + cleanup = 1; + part1Ptr = NULL; + objPtr = OBJ_AT_TOS; + TRACE(("%u \"%.30s\" => \n", opnd, O2S(objPtr))); varPtr = LOCAL(opnd); + arrayPtr = NULL; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - } - varPtr->value.objPtr = NULL; + goto doConst; + case INST_CONST_STK: + opnd = -1; + pcAdjustment = 1; + cleanup = 2; + part1Ptr = OBJ_UNDER_TOS; + objPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(objPtr))); + varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, + /*createPart1*/1, /*createPart2*/0, &arrayPtr); + doConst: + if (TclIsVarConstant(varPtr)) { + TRACE_APPEND(("\n")); + NEXT_INST_V(pcAdjustment, cleanup, 0); + } + if (TclIsVarArray(varPtr)) { + msgPart = "variable is array"; + goto constError; + } else if (TclIsVarArrayElement(varPtr)) { + msgPart = "name refers to an element in an array"; + goto constError; + } else if (!TclIsVarUndefined(varPtr)) { + msgPart = "variable already exists"; + goto constError; + } + if (TclIsVarDirectModifyable(varPtr)) { + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); } else { + Tcl_Obj *resPtr; + DECACHE_STACK_INFO(); - TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, opnd); + resPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, NULL, + objPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); + if (resPtr == NULL) { + TRACE_ERROR(interp); + goto gotError; + } } - NEXT_INST_F(5, 0, 0); + TclSetVarConstant(varPtr); + TRACE_APPEND(("\n")); + NEXT_INST_V(pcAdjustment, cleanup, 0); + + constError: + TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", msgPart, opnd); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); + TRACE_ERROR(interp); + goto gotError; } - break; /* - * End of INST_UNSET instructions. + * End of INST_CONST instructions. * ----------------------------------------------------------------- * Start of INST_ARRAY instructions. */ @@ -4399,51 +4314,6 @@ TEBCresume( break; /* - * These two instructions are now redundant: the complete logic of the LOR - * and LAND is now handled by the expression compiler. - */ - - case INST_LOR: - case INST_LAND: { - /* - * Operands must be boolean or numeric. No int->double conversions are - * performed. - */ - - int i1, i2, iResult; - - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); - goto gotError; - } - - if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), - (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); - goto gotError; - } - - if (*pc == INST_LOR) { - iResult = (i1 || i2); - } else { - iResult = (i1 && i2); - } - objResultPtr = TCONST(iResult); - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); - NEXT_INST_F(1, 2, 1); - } - break; - - /* * ----------------------------------------------------------------- * Start of general introspector instructions. */ @@ -4474,7 +4344,7 @@ TEBCresume( } break; case INST_INFO_LEVEL_NUM: - TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); + TclNewIntObj(objResultPtr, (int)iPtr->varFramePtr->level); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); break; @@ -4491,7 +4361,7 @@ TEBCresume( if (level <= 0) { level += framePtr->level; } - for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ; + for (; ((int)framePtr->level!=level) && (framePtr!=rootFramePtr) ; framePtr = framePtr->callerVarPtr) { /* Empty loop body */ } @@ -4737,7 +4607,7 @@ TEBCresume( strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", - iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); + iPtr->numLevels, (pc - codePtr->codeStart)); } for (i = 0; i < opnd; i++) { TclPrintObject(stdout, objv[i], 15); @@ -4787,7 +4657,11 @@ TEBCresume( Method *const mPtr = contextPtr->callPtr->chain[newDepth].mPtr; - return mPtr->typePtr->callProc(mPtr->clientData, interp, + if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) { + return mPtr->typePtr->callProc(mPtr->clientData, interp, + (Tcl_ObjectContext) contextPtr, opnd, objv); + } + return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp, (Tcl_ObjectContext) contextPtr, opnd, objv); } @@ -4830,7 +4704,7 @@ TEBCresume( { int numIndices, nocase, match, cflags; - Tcl_Size length2, fromIdx, toIdx, index, s1len, s2len; + Tcl_Size slength, length2, fromIdx, toIdx, index, s1len, s2len; const char *s1, *s2; case INST_LIST: @@ -4859,21 +4733,25 @@ TEBCresume( valuePtr = OBJ_UNDER_TOS; TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - - /* special case for ArithSeries */ - if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { - length = TclArithSeriesObjLength(valuePtr); + /* special case for AbstractList */ + if (TclObjTypeHasProc(valuePtr,indexProc)) { + DECACHE_STACK_INFO(); + length = TclObjTypeLength(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index); - if (objResultPtr == NULL) { + if (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } + CACHE_STACK_INFO(); + if (objResultPtr == NULL) { + /* Index is out of range, return empty result. */ + TclNewObj(objResultPtr); + } Tcl_IncrRefCount(objResultPtr); // reference held here goto lindexDone; } @@ -4882,20 +4760,39 @@ TEBCresume( * Extract the desired list element. */ - if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK) - && !TclHasInternalRep(value2Ptr, &tclListType)) { - int code; + { + Tcl_Size value2Length; + Tcl_Obj *indexListPtr = value2Ptr; + if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK) + && ( + !TclHasInternalRep(value2Ptr, &tclListType) + || + ((Tcl_ListObjLength(interp,value2Ptr,&value2Length), + value2Length == 1 + ? (indexListPtr = TclListObjGetElement(value2Ptr, 0), 1) + : 0 + )) + ) + ) { + int code; + + /* increment the refCount of value2Ptr because TclListObjGetElement may + * have just extracted it from a list in the condition for this block. + */ + Tcl_IncrRefCount(indexListPtr); - DECACHE_STACK_INFO(); - code = TclGetIntForIndexM(interp, value2Ptr, objc-1, &index); - CACHE_STACK_INFO(); - if (code == TCL_OK) { - TclDecrRefCount(value2Ptr); - tosPtr--; - pcAdjustment = 1; - goto lindexFastPath; + DECACHE_STACK_INFO(); + code = TclGetIntForIndexM(interp, indexListPtr, objc-1, &index); + TclDecrRefCount(indexListPtr); + CACHE_STACK_INFO(); + if (code == TCL_OK) { + Tcl_DecrRefCount(value2Ptr); + tosPtr--; + pcAdjustment = 1; + goto lindexFastPath; + } + Tcl_ResetResult(interp); } - Tcl_ResetResult(interp); } DECACHE_STACK_INFO(); @@ -4926,34 +4823,36 @@ TEBCresume( opnd = TclGetInt4AtPtr(pc+1); TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); - /* special case for ArithSeries */ - if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { - length = TclArithSeriesObjLength(valuePtr); + /* + * Get the contents of the list, making sure that it really is a list + * in the process. + */ + + /* special case for AbstractList */ + if (TclObjTypeHasProc(valuePtr,indexProc)) { + length = TclObjTypeLength(valuePtr); /* Decode end-offset index values. */ - index = TclIndexDecode(opnd, length-1); - /* Compute value @ index */ if (index >= 0 && index < length) { - objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index); - if (objResultPtr == NULL) { + /* Compute value @ index */ + DECACHE_STACK_INFO(); + if (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } + CACHE_STACK_INFO(); } else { TclNewObj(objResultPtr); } + pcAdjustment = 5; goto lindexFastPath2; } - /* - * Get the contents of the list, making sure that it really is a list - * in the process. - */ - + /* List case */ if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -5026,9 +4925,17 @@ TEBCresume( * Compute the new variable value. */ - objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, + DECACHE_STACK_INFO(); + if (TclObjTypeHasProc(valuePtr, setElementProc)) { + objResultPtr = TclObjTypeSetElement(interp, + valuePtr, numIndices, + &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); + } else { + objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); + } if (!objResultPtr) { + CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } @@ -5036,7 +4943,7 @@ TEBCresume( /* * Set result. */ - + CACHE_STACK_INFO(); TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(5, numIndices+1, -1); @@ -5130,7 +5037,7 @@ TEBCresume( NEXT_INST_F(9, 1, 1); } toIdx = TclIndexDecode(toIdx, objc - 1); - if (toIdx < 0) { + if (toIdx == TCL_INDEX_NONE) { goto emptyList; } else if (toIdx >= objc) { toIdx = objc - 1; @@ -5148,16 +5055,21 @@ TEBCresume( fromIdx = TclIndexDecode(fromIdx, objc - 1); - if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { - objResultPtr = TclArithSeriesObjRange(interp, valuePtr, fromIdx, toIdx); + DECACHE_STACK_INFO(); + if (TclObjTypeHasProc(valuePtr, sliceProc)) { + if (TclObjTypeSlice(interp, valuePtr, fromIdx, toIdx, &objResultPtr) != TCL_OK) { + objResultPtr = NULL; + } } else { objResultPtr = TclListObjRange(interp, valuePtr, fromIdx, toIdx); } if (objResultPtr == NULL) { + CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } + CACHE_STACK_INFO(); TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); @@ -5166,42 +5078,60 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - s1 = TclGetStringFromObj(valuePtr, &s1len); - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - if (TclListObjLengthM(interp, value2Ptr, &length) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - match = 0; - if (length > 0) { - Tcl_Size i = 0; - Tcl_Obj *o; - int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType); - /* - * An empty list doesn't match anything. - */ - - do { - if (isArithSeries) { - o = TclArithSeriesObjIndex(NULL, value2Ptr, i); - } else { - Tcl_ListObjIndex(NULL, value2Ptr, i, &o); - } - if (o != NULL) { - s2 = TclGetStringFromObj(o, &s2len); - } else { - s2 = ""; - s2len = 0; - } - if (s1len == s2len) { - match = (memcmp(s1, s2, s1len) == 0); - } - if (isArithSeries) { - TclDecrRefCount(o); - } - i++; - } while (i < length && match == 0); - } + s1 = Tcl_GetStringFromObj(valuePtr, &s1len); + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); + + if (TclObjTypeHasProc(value2Ptr,inOperProc) != NULL) { + int status = TclObjTypeInOperator(interp, valuePtr, value2Ptr, &match); + if (status != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + } else { + + if (TclListObjLengthM(interp, value2Ptr, &length) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + match = 0; + if (length > 0) { + Tcl_Size i = 0; + Tcl_Obj *o; + int isAbstractList = TclObjTypeHasProc(value2Ptr,indexProc) != NULL; + + /* + * An empty list doesn't match anything. + */ + + do { + if (isAbstractList) { + DECACHE_STACK_INFO(); + if (TclObjTypeIndex(interp, value2Ptr, i, &o) != TCL_OK) { + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + CACHE_STACK_INFO(); + } else { + Tcl_ListObjIndex(NULL, value2Ptr, i, &o); + } + if (o != NULL) { + s2 = Tcl_GetStringFromObj(o, &s2len); + } else { + s2 = ""; + s2len = 0; + } + if (s1len == s2len) { + match = (memcmp(s1, s2, s1len) == 0); + } + + /* Could be an ephemeral abstract obj */ + Tcl_BounceRefCount(o); + + i++; + } while (i < length && match == 0); + } + } if (*pc == INST_LIST_NOT_IN) { match = !match; @@ -5242,7 +5172,7 @@ TEBCresume( case INST_LREPLACE4: { - TCL_HASH_TYPE numToDelete, numNewElems; + size_t numToDelete, numNewElems; int end_indicator; int haveSecondIndex, flags; Tcl_Obj *fromIdxObj, *toIdxObj; @@ -5288,11 +5218,13 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - if (toIdx > length) { - toIdx = length; - } - if (toIdx >= fromIdx) { - numToDelete = (unsigned)toIdx - (unsigned)fromIdx + 1; /* See [3d3124d01d] */ + if (toIdx != TCL_INDEX_NONE) { + if (toIdx > length) { + toIdx = length; + } + if (toIdx >= fromIdx) { + numToDelete = (size_t)toIdx - (size_t)fromIdx + 1; + } } } @@ -5396,24 +5328,24 @@ TEBCresume( case INST_STR_LEN: valuePtr = OBJ_AT_TOS; - length = TclGetCharLength(valuePtr); - TclNewIntObj(objResultPtr, length); - TRACE(("\"%.20s\" => %" TCL_SIZE_MODIFIER "d\n", O2S(valuePtr), length)); + slength = Tcl_GetCharLength(valuePtr); + TclNewIntObj(objResultPtr, slength); + TRACE(("\"%.20s\" => %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), slength)); NEXT_INST_F(1, 1, 1); case INST_STR_UPPER: valuePtr = OBJ_AT_TOS; TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &length); - TclNewStringObj(objResultPtr, s1, length); - length = Tcl_UtfToUpper(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, length); + s1 = Tcl_GetStringFromObj(valuePtr, &slength); + TclNewStringObj(objResultPtr, s1, slength); + slength = Tcl_UtfToUpper(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, slength); TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { - length = Tcl_UtfToUpper(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, length); + slength = Tcl_UtfToUpper(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, slength); TclFreeInternalRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); @@ -5422,15 +5354,15 @@ TEBCresume( valuePtr = OBJ_AT_TOS; TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &length); - TclNewStringObj(objResultPtr, s1, length); - length = Tcl_UtfToLower(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, length); + s1 = Tcl_GetStringFromObj(valuePtr, &slength); + TclNewStringObj(objResultPtr, s1, slength); + slength = Tcl_UtfToLower(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, slength); TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { - length = Tcl_UtfToLower(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, length); + slength = Tcl_UtfToLower(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, slength); TclFreeInternalRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); @@ -5439,15 +5371,15 @@ TEBCresume( valuePtr = OBJ_AT_TOS; TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &length); - TclNewStringObj(objResultPtr, s1, length); - length = Tcl_UtfToTitle(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, length); + s1 = Tcl_GetStringFromObj(valuePtr, &slength); + TclNewStringObj(objResultPtr, s1, slength); + slength = Tcl_UtfToTitle(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, slength); TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { - length = Tcl_UtfToTitle(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, length); + slength = Tcl_UtfToTitle(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, slength); TclFreeInternalRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); @@ -5462,26 +5394,26 @@ TEBCresume( * Get char length to calculate what 'end' means. */ - length = TclGetCharLength(valuePtr); + slength = Tcl_GetCharLength(valuePtr); DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { + if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } CACHE_STACK_INFO(); - if ((index < 0) || (index >= length)) { + if (index < 0 || index >= slength) { TclNewObj(objResultPtr); } else if (TclIsPureByteArray(valuePtr)) { objResultPtr = Tcl_NewByteArrayObj( - Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1); - } else if (valuePtr->bytes && length == valuePtr->length) { + Tcl_GetBytesFromObj(NULL, valuePtr, (Tcl_Size *)NULL)+index, 1); + } else if (valuePtr->bytes && slength == valuePtr->length) { objResultPtr = Tcl_NewStringObj((const char *) valuePtr->bytes+index, 1); } else { char buf[4] = ""; - int ch = TclGetUniChar(valuePtr, index); + int ch = Tcl_GetUniChar(valuePtr, index); /* * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) @@ -5491,11 +5423,8 @@ TEBCresume( if (ch == -1) { TclNewObj(objResultPtr); } else { - length = Tcl_UniCharToUtf(ch, buf); - if ((ch >= 0xD800) && (length < 3)) { - length += Tcl_UniCharToUtf(-1, buf + length); - } - objResultPtr = Tcl_NewStringObj(buf, length); + slength = Tcl_UniCharToUtf(ch, buf); + objResultPtr = Tcl_NewStringObj(buf, slength); } } @@ -5505,16 +5434,16 @@ TEBCresume( case INST_STR_RANGE: TRACE(("\"%.20s\" %.20s %.20s =>", O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); - length = TclGetCharLength(OBJ_AT_DEPTH(2)) - 1; + slength = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength, &fromIdx) != TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - if (TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + if (TclGetIntForIndexM(interp, OBJ_AT_TOS, slength, &toIdx) != TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); @@ -5522,10 +5451,10 @@ TEBCresume( } CACHE_STACK_INFO(); - if (toIdx < 0) { + if (toIdx == TCL_INDEX_NONE) { TclNewObj(objResultPtr); } else { - objResultPtr = TclGetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); + objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); } TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(1, 3, 1); @@ -5534,59 +5463,42 @@ TEBCresume( valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); - length = TclGetCharLength(valuePtr); - TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); + slength = Tcl_GetCharLength(valuePtr); + TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), (int)(fromIdx), (int)(toIdx))); /* Every range of an empty value is an empty value */ - if (length == 0) { + if (slength == 0) { TRACE_APPEND(("\n")); NEXT_INST_F(9, 0, 0); } /* Decode index operands. */ - /* - assert ( toIdx != TCL_INDEX_NONE ); - * - * Extra safety for legacy bytecodes: - */ + toIdx = TclIndexDecode(toIdx, slength - 1); + fromIdx = TclIndexDecode(fromIdx, slength - 1); if (toIdx == TCL_INDEX_NONE) { TclNewObj(objResultPtr); } else { - toIdx = TclIndexDecode(toIdx, length - 1); - /* - assert ( fromIdx != TCL_INDEX_NONE ); - * - * Extra safety for legacy bytecodes: - */ - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; - } - fromIdx = TclIndexDecode(fromIdx, length - 1); - if (toIdx < 0) { - TclNewObj(objResultPtr); - } else { - objResultPtr = TclGetRange(valuePtr, fromIdx, toIdx); - } + objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); { Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; - Tcl_Size length3, endIdx; + Tcl_Size length3; Tcl_Obj *value3Ptr; case INST_STR_REPLACE: value3Ptr = POP_OBJECT(); valuePtr = OBJ_AT_DEPTH(2); - endIdx = TclGetCharLength(valuePtr) - 1; + slength = Tcl_GetCharLength(valuePtr) - 1; TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx, + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength, &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx, + || TclGetIntForIndexM(interp, OBJ_AT_TOS, slength, &toIdx) != TCL_OK) { CACHE_STACK_INFO(); TclDecrRefCount(value3Ptr); @@ -5600,7 +5512,7 @@ TEBCresume( (void) POP_OBJECT(); if ((toIdx < 0) || - (fromIdx > endIdx) || + (fromIdx > slength) || (toIdx < fromIdx)) { TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); TclDecrRefCount(value3Ptr); @@ -5611,11 +5523,11 @@ TEBCresume( fromIdx = 0; } - if (toIdx > endIdx) { - toIdx = endIdx; + if (toIdx > slength) { + toIdx = slength; } - if ((fromIdx == 0) && (toIdx == endIdx)) { + if ((fromIdx == 0) && (toIdx == slength)) { TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); @@ -5647,28 +5559,28 @@ TEBCresume( objResultPtr = value3Ptr; goto doneStringMap; } - ustring1 = TclGetUnicodeFromObj(valuePtr, &length); - if (length == 0) { + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &slength); + if (slength == 0) { objResultPtr = valuePtr; goto doneStringMap; } - ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); - if (length2 > length || length2 == 0) { + ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + if (length2 > slength || length2 == 0) { objResultPtr = valuePtr; goto doneStringMap; - } else if (length2 == length) { - if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) { + } else if (length2 == slength) { + if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * slength)) { objResultPtr = valuePtr; } else { objResultPtr = value3Ptr; } goto doneStringMap; } - ustring3 = TclGetUnicodeFromObj(value3Ptr, &length3); + ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); - objResultPtr = TclNewUnicodeObj(ustring1, 0); + objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); p = ustring1; - end = ustring1 + length; + end = ustring1 + slength; for (; ustring1 < end; ustring1++) { if ((*ustring1 == *ustring2) && /* Fix bug [69218ab7b]: restrict max compare length. */ @@ -5676,14 +5588,14 @@ TEBCresume( memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) == 0)) { if (p != ustring1) { - TclAppendUnicodeToObj(objResultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - TclAppendUnicodeToObj(objResultPtr, ustring3, length3); + Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3); } } if (p != ustring1) { @@ -5691,7 +5603,7 @@ TEBCresume( * Put the rest of the unmapped chars onto result. */ - TclAppendUnicodeToObj(objResultPtr, p, ustring1 - p); + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); } doneStringMap: TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", @@ -5706,7 +5618,7 @@ TEBCresume( NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: - objResultPtr = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1); + objResultPtr = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, TCL_SIZE_MAX - 1); TRACE(("%.20s %.20s => %s\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr))); @@ -5717,11 +5629,11 @@ TEBCresume( valuePtr = OBJ_AT_TOS; TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, O2S(valuePtr))); - ustring1 = TclGetUnicodeFromObj(valuePtr, &length); + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &slength); match = 1; - if (length > 0) { + if (slength > 0) { int ch; - end = ustring1 + length; + end = ustring1 + slength; for (p=ustring1 ; p<end ; ) { ch = *p++; if (!tclStringClassTable[opnd].comparator(ch)) { @@ -5744,20 +5656,21 @@ TEBCresume( * both. */ - if (TclHasInternalRep(valuePtr, &tclUniCharStringType) - || TclHasInternalRep(value2Ptr, &tclUniCharStringType)) { + if (TclHasInternalRep(valuePtr, &tclStringType) + || TclHasInternalRep(value2Ptr, &tclStringType)) { Tcl_UniChar *ustring1, *ustring2; - ustring1 = TclGetUnicodeFromObj(valuePtr, &length); - ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); - match = TclUniCharMatch(ustring1, length, ustring2, length2, + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &slength); + ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + match = TclUniCharMatch(ustring1, slength, ustring2, length2, nocase); - } else if (TclIsPureByteArray(valuePtr) && !nocase) { + } else if (TclIsPureByteArray(valuePtr) && TclIsPureByteArray(value2Ptr) && !nocase) { unsigned char *bytes1, *bytes2; + Tcl_Size wlen1 = 0, wlen2 = 0; - bytes1 = Tcl_GetByteArrayFromObj(valuePtr, &length); - bytes2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2); - match = TclByteArrayMatch(bytes1, length, bytes2, length2, 0); + bytes1 = Tcl_GetBytesFromObj(NULL, valuePtr, &wlen1); + bytes2 = Tcl_GetBytesFromObj(NULL, value2Ptr, &wlen2); + match = TclByteArrayMatch(bytes1, wlen1, bytes2, wlen2, 0); } else { match = Tcl_StringCaseMatch(TclGetString(valuePtr), TclGetString(value2Ptr), nocase); @@ -5783,25 +5696,25 @@ TEBCresume( case INST_STR_TRIM_LEFT: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ - string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &length); - trim1 = TclTrimLeft(string1, length, string2, length2); + string2 = Tcl_GetStringFromObj(value2Ptr, &length2); + string1 = Tcl_GetStringFromObj(valuePtr, &slength); + trim1 = TclTrimLeft(string1, slength, string2, length2); trim2 = 0; goto createTrimmedString; case INST_STR_TRIM_RIGHT: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ - string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &length); - trim2 = TclTrimRight(string1, length, string2, length2); + string2 = Tcl_GetStringFromObj(value2Ptr, &length2); + string1 = Tcl_GetStringFromObj(valuePtr, &slength); + trim2 = TclTrimRight(string1, slength, string2, length2); trim1 = 0; goto createTrimmedString; case INST_STR_TRIM: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ - string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &length); - trim1 = TclTrim(string1, length, string2, length2, &trim2); + string2 = Tcl_GetStringFromObj(value2Ptr, &length2); + string1 = Tcl_GetStringFromObj(valuePtr, &slength); + trim1 = TclTrim(string1, slength, string2, length2, &trim2); createTrimmedString: /* * Careful here; trim set often contains non-ASCII characters so we @@ -5824,7 +5737,7 @@ TEBCresume( #endif NEXT_INST_F(1, 1, 0); } else { - objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2); + objResultPtr = Tcl_NewStringObj(string1+trim1, slength-trim1-trim2); #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { TclPrintObject(stdout, objResultPtr, 30); @@ -6586,177 +6499,11 @@ TEBCresume( { ForeachInfo *infoPtr; - Var *iterVarPtr, *listVarPtr; - Tcl_Obj *oldValuePtr, *listPtr, **elements; - ForeachVarList *varListPtr; - int numLists, listTmpIndex, listLen, numVars; - size_t iterNum; - int varIndex, valIndex, continueLoop, j, iterTmpIndex; - long i; - - case INST_FOREACH_START4: /* DEPRECATED */ - /* - * Initialize the temporary local var that holds the count of the - * number of iterations of the loop body to -1. - */ - - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData; - iterTmpIndex = infoPtr->loopCtTemp; - iterVarPtr = LOCAL(iterTmpIndex); - oldValuePtr = iterVarPtr->value.objPtr; - - if (oldValuePtr == NULL) { - TclNewIntObj(iterVarPtr->value.objPtr, -1); - Tcl_IncrRefCount(iterVarPtr->value.objPtr); - } else { - TclSetIntObj(oldValuePtr, -1); - } - TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); - -#ifndef TCL_COMPILE_DEBUG - /* - * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately - * after INST_FOREACH_START4 - let us just fall through instead of - * jumping back to the top. - */ - - pc += 5; - TCL_DTRACE_INST_NEXT(); -#else - NEXT_INST_F(5, 0, 0); -#endif - - case INST_FOREACH_STEP4: /* DEPRECATED */ - /* - * "Step" a foreach loop (i.e., begin its next iteration) by assigning - * the next value list element to each loop var. - */ - - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData; - numLists = infoPtr->numLists; - - /* - * Increment the temp holding the loop iteration number. - */ - - iterVarPtr = LOCAL(infoPtr->loopCtTemp); - valuePtr = iterVarPtr->value.objPtr; - iterNum = (size_t)valuePtr->internalRep.wideValue + 1; - TclSetIntObj(valuePtr, iterNum); - - /* - * Check whether all value lists are exhausted and we should stop the - * loop. - */ - - continueLoop = 0; - listTmpIndex = infoPtr->firstValueTemp; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - - listVarPtr = LOCAL(listTmpIndex); - listPtr = listVarPtr->value.objPtr; - if (TclListObjLengthM(interp, listPtr, &listLen) != TCL_OK) { - TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n", - i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - if ((size_t)listLen > iterNum * numVars) { - continueLoop = 1; - } - listTmpIndex++; - } - - /* - * If some var in some var list still has a remaining list element - * iterate one more time. Assign to var the next element from its - * value list. We already checked above that each list temp holds a - * valid list object (by calling Tcl_ListObjLength), but cannot rely - * on that check remaining valid: one list could have been shimmered - * as a side effect of setting a traced variable. - */ - - if (continueLoop) { - listTmpIndex = infoPtr->firstValueTemp; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - - listVarPtr = LOCAL(listTmpIndex); - /* Do not use TclListObjCopy here - shimmers arithseries to list */ - listPtr = Tcl_DuplicateObj(listVarPtr->value.objPtr); - TclListObjGetElementsM(interp, listPtr, &listLen, &elements); - - valIndex = (iterNum * numVars); - for (j = 0; j < numVars; j++) { - if (valIndex >= listLen) { - TclNewObj(valuePtr); - } else { - valuePtr = elements[valIndex]; - } - - varIndex = varListPtr->varIndexes[j]; - varPtr = LOCAL(varIndex); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - if (TclIsVarDirectWritable(varPtr)) { - value2Ptr = varPtr->value.objPtr; - if (valuePtr != value2Ptr) { - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); - } - varPtr->value.objPtr = valuePtr; - Tcl_IncrRefCount(valuePtr); - } - } else { - DECACHE_STACK_INFO(); - if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ - CACHE_STACK_INFO(); - TRACE_APPEND(( - "ERROR init. index temp %d: %s\n", - varIndex, O2S(Tcl_GetObjResult(interp)))); - TclDecrRefCount(listPtr); - goto gotError; - } - CACHE_STACK_INFO(); - } - valIndex++; - } - TclDecrRefCount(listPtr); - listTmpIndex++; - } - } - TRACE_APPEND(("%d lists, iter %" TCL_Z_MODIFIER "u, %s loop\n", - numLists, iterNum, (continueLoop? "continue" : "exit"))); - - /* - * Run-time peep-hole optimisation: the compiler ALWAYS follows - * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that - * instruction and jump direct from here. - */ - - pc += 5; - if (*pc == INST_JUMP_FALSE1) { - NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); - } else { - NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); - } - - } - { - ForeachInfo *infoPtr; Tcl_Obj *listPtr, **elements; ForeachVarList *varListPtr; Tcl_Size numLists, listLen, numVars, listTmpDepth; - size_t iterNum, iterMax, iterTmp; - int varIndex, valIndex, j; - long i; + Tcl_Size iterNum, iterMax, iterTmp; + Tcl_Size varIndex, valIndex, i, j; case INST_FOREACH_START: /* @@ -6779,17 +6526,15 @@ TEBCresume( varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); + DECACHE_STACK_INFO(); if (TclListObjLengthM(interp, listPtr, &listLen) != TCL_OK) { - TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", + CACHE_STACK_INFO(); + TRACE_APPEND(("ERROR converting list %" TCL_Z_MODIFIER "d, \"%s\": %s", i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } if (Tcl_IsShared(listPtr)) { - /* Do not use TclListObjCopy here - shimmers arithseries to list */ - objPtr = Tcl_DuplicateObj(listPtr); - if (!objPtr) { - goto gotError; - } + objPtr = TclListObjCopy(NULL, listPtr); Tcl_IncrRefCount(objPtr); Tcl_DecrRefCount(listPtr); OBJ_AT_DEPTH(listTmpDepth) = objPtr; @@ -6830,7 +6575,7 @@ TEBCresume( pc += 5 - infoPtr->loopCtTemp; - case INST_FOREACH_STEP: + case INST_FOREACH_STEP: /* TODO: address abstract list indexing here! */ /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. @@ -6866,8 +6611,7 @@ TEBCresume( int hasAbstractList; listPtr = OBJ_AT_DEPTH(listTmpDepth); - hasAbstractList = - TclHasInternalRep(listPtr, &tclArithSeriesType); + hasAbstractList = TclObjTypeHasProc(listPtr, indexProc) != 0; DECACHE_STACK_INFO(); if (hasAbstractList) { status = Tcl_ListObjLength(interp, listPtr, &listLen); @@ -6882,22 +6626,29 @@ TEBCresume( } CACHE_STACK_INFO(); + valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { if (valIndex >= listLen) { TclNewObj(valuePtr); } else { + DECACHE_STACK_INFO(); if (elements) { valuePtr = elements[valIndex]; } else { - DECACHE_STACK_INFO(); - valuePtr = TclArithSeriesObjIndex( - NULL, listPtr, valIndex); + status = Tcl_ListObjIndex( + interp, listPtr, valIndex, &valuePtr); + if (status != TCL_OK) { + /* Could happen for abstract lists */ + CACHE_STACK_INFO(); + goto gotError; + } if (valuePtr == NULL) { + /* Permitted for Tcl_LOI to return NULL */ TclNewObj(valuePtr); } - CACHE_STACK_INFO(); } + CACHE_STACK_INFO(); } varIndex = varListPtr->varIndexes[j]; @@ -7055,16 +6806,18 @@ TEBCresume( Tcl_DictSearch *searchPtr; DictUpdateInfo *duiPtr; - case INST_DICT_VERIFY: + case INST_DICT_VERIFY: { + Tcl_Size size; dictPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" => ", O2S(dictPtr))); - if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { + if (Tcl_DictObjSize(interp, dictPtr, &size) != TCL_OK) { TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n", O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } TRACE_APPEND(("OK\n")); NEXT_INST_F(1, 1, 0); + } break; case INST_DICT_EXISTS: { @@ -7412,7 +7165,7 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = POP_OBJECT(); - searchPtr = (Tcl_DictSearch *)ckalloc(sizeof(Tcl_DictSearch)); + searchPtr = (Tcl_DictSearch *)Tcl_Alloc(sizeof(Tcl_DictSearch)); if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, &valuePtr, &done) != TCL_OK) { @@ -7423,7 +7176,7 @@ TEBCresume( */ Tcl_DecrRefCount(dictPtr); - ckfree(searchPtr); + Tcl_Free(searchPtr); TRACE_ERROR(interp); goto gotError; } @@ -7877,11 +7630,12 @@ TEBCresume( } if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { const unsigned char *pcBeg; + Tcl_Size xxx1length; - bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL); + bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, &pcBeg, NULL); DECACHE_STACK_INFO(); TclLogCommandInfo(interp, codePtr->source, bytes, - bytes ? length : 0, pcBeg, tosPtr); + bytes ? xxx1length : 0, pcBeg, tosPtr); CACHE_STACK_INFO(); } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -8043,8 +7797,9 @@ TEBCresume( instStartCmdFailed: { const char *bytes; + Tcl_Size xxx1length; - length = 0; + xxx1length = 0; if (TclInterpReady(interp) == TCL_ERROR) { goto gotError; @@ -8061,11 +7816,11 @@ TEBCresume( */ codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); + bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, NULL, NULL); opnd = TclGetUInt4AtPtr(pc+1); pc += (opnd-1); assert(bytes); - PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); + PUSH_OBJECT(Tcl_NewStringObj(bytes, xxx1length)); goto instEvalStk; } } @@ -9236,13 +8991,13 @@ PrintByteCodeInfo( Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; - fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %u, interp 0x%p (epoch %u)\n", - codePtr, (size_t)codePtr->refCount, codePtr->compileEpoch, iPtr, + fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp 0x%p (epoch %" TCL_Z_MODIFIER "u)\n", + codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); - fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + fprintf(stdout, "\n Cmds %" TCL_Z_MODIFIER "u, src %" TCL_Z_MODIFIER "u, inst %" TCL_Z_MODIFIER "u, litObjs %" TCL_Z_MODIFIER "u, aux %" TCL_Z_MODIFIER "u, stkDepth %" TCL_Z_MODIFIER "u, code/src %.2f\n", codePtr->numCommands, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, @@ -9253,8 +9008,9 @@ PrintByteCodeInfo( 0.0); #ifdef TCL_COMPILE_STATS - fprintf(stdout, " Code %lu = header %" TCL_Z_MODIFIER "u+inst %d+litObj %" TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %d\n", - (unsigned long) codePtr->structureSize, + fprintf(stdout, " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %" TCL_Z_MODIFIER + "u+litObj %" TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %" TCL_Z_MODIFIER "u\n", + codePtr->structureSize, offsetof(ByteCode, localCachePtr), codePtr->numCodeBytes, codePtr->numLitObjects * sizeof(Tcl_Obj *), @@ -9264,7 +9020,7 @@ PrintByteCodeInfo( #endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { fprintf(stdout, - " Proc 0x%p, refCt %d, args %d, compiled locals %d\n", + " Proc 0x%p, refCt %" TCL_Z_MODIFIER "u, args %" TCL_Z_MODIFIER "u, compiled locals %" TCL_Z_MODIFIER "u\n", procPtr, procPtr->refCount, procPtr->numArgs, procPtr->numCompiledLocals); } @@ -9316,14 +9072,14 @@ ValidatePcAndStackTop( pc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); } - if ((unsigned) opCode > LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n", - (unsigned) opCode, relativePc); + if (opCode >= LAST_INST_OPCODE) { + fprintf(stderr, "\nBad opcode %u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n", + opCode, relativePc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } if (checkStack && (stackTop > stackUpperBound)) { - int numChars; + Tcl_Size numChars; const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); fprintf(stderr, "\nBad stack top %" TCL_Z_MODIFIER "u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %" TCL_Z_MODIFIER "u)", @@ -9379,20 +9135,11 @@ IllegalExprOperandType( if (opcode == INST_EXPON) { op = "**"; } else if (opcode <= INST_LNOT) { - op = operatorStrings[opcode - INST_LOR]; + op = operatorStrings[opcode - INST_BITOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { - Tcl_Size numBytes; - const char *bytes = TclGetStringFromObj(opndPtr, &numBytes); - - if (numBytes == 0) { - description = "empty string"; - } else if (TclCheckBadOctal(NULL, bytes)) { - description = "invalid octal number"; - } else { - description = "non-numeric string"; - } + description = "non-numeric string"; } else if (type == TCL_NUMBER_NAN) { description = "non-numeric floating-point value"; } else if (type == TCL_NUMBER_DOUBLE) { @@ -9435,7 +9182,7 @@ IllegalExprOperandType( Tcl_Obj * TclGetSourceFromFrame( CmdFrame *cfPtr, - Tcl_Size objc, + int objc, Tcl_Obj *const objv[]) { if (cfPtr == NULL) { @@ -9482,7 +9229,7 @@ TclGetSrcInfoForPc( ExtCmdLoc *eclPtr; ECL *locPtr = NULL; Tcl_Size srcOffset; - int i; + Tcl_Size i; Interp *iPtr = (Interp *) *codePtr->interpHandle; Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); @@ -9534,7 +9281,7 @@ GetSrcInfoForPc( const unsigned char **pcBeg,/* If non-NULL, the bytecode location * where the current instruction starts. * If NULL; no pointer is stored. */ - Tcl_Size *cmdIdxPtr) /* If non-NULL, the location where the index + Tcl_Size *cmdIdxPtr) /* If non-NULL, the location where the index * of the command containing the pc should * be stored. */ { @@ -9543,9 +9290,9 @@ GetSrcInfoForPc( unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; Tcl_Size codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; - int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ - Tcl_Size bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ - Tcl_Size bestSrcLength = -1; /* Initialized to avoid compiler warning. */ + Tcl_Size bestDist = TCL_SIZE_MAX; /* Distance of pc to best cmd's start pc. */ + Tcl_Size bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ + Tcl_Size bestSrcLength = -1; /* Initialized to avoid compiler warning. */ Tcl_Size bestCmdIdx = -1; /* The pc must point within the bytecode */ @@ -9625,7 +9372,7 @@ GetSrcInfoForPc( * instructions. Stop when crossing pc; keep previous. */ - curr = ((bestDist == INT_MAX) ? codePtr->codeStart : pc - bestDist); + curr = ((bestDist == TCL_SIZE_MAX) ? codePtr->codeStart : pc - bestDist); prev = curr; while (curr <= pc) { prev = curr; @@ -9634,7 +9381,7 @@ GetSrcInfoForPc( *pcBeg = prev; } - if (bestDist == INT_MAX) { + if (bestDist == TCL_SIZE_MAX) { return NULL; } @@ -9690,10 +9437,10 @@ GetExceptRangeForPc( * for the enclosing ExceptionRange. */ { ExceptionRange *rangeArrayPtr; - int numRanges = codePtr->numExceptRanges; + size_t numRanges = codePtr->numExceptRanges; ExceptionRange *rangePtr; - int pcOffset = pc - codePtr->codeStart; - int start; + size_t pcOffset = pc - codePtr->codeStart; + size_t start; if (numRanges == 0) { return NULL; @@ -9871,9 +9618,10 @@ EvalStatsCmd( double strBytesSharedMultX, strBytesSharedOnce; double numInstructions, currentHeaderBytes; size_t numCurrentByteCodes, numByteCodeLits; - size_t refCountSum, literalMgmtBytes, sum; - size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade, i; - int decadeHigh, length; + size_t refCountSum, literalMgmtBytes, sum, decadeHigh; + size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade; + Tcl_Size i, length; + size_t ui; char *litTableStats; LiteralEntry *entryPtr; Tcl_Obj *objPtr; @@ -10009,13 +9757,13 @@ EvalStatsCmd( strBytesIfUnshared = 0.0; strBytesSharedMultX = 0.0; strBytesSharedOnce = 0.0; - for (i = 0; i < globalTablePtr->numBuckets; i++) { + for (ui = 0; ui < globalTablePtr->numBuckets; ui++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) { numByteCodeLits++; } - (void) TclGetStringFromObj(entryPtr->objPtr, &length); + (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); strBytesIfUnshared += (entryPtr->refCount * (length+1)); @@ -10127,9 +9875,9 @@ EvalStatsCmd( } } sum = 0; - for (i = 0; i <= maxSizeDecade; i++) { - decadeHigh = (1 << (i+1)) - 1; - sum += statsPtr->literalCount[i]; + for (ui = 0; ui <= maxSizeDecade; ui++) { + decadeHigh = (1 << (ui+1)) - 1; + sum += statsPtr->literalCount[ui]; Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); } @@ -10137,7 +9885,7 @@ EvalStatsCmd( litTableStats = TclLiteralStats(globalTablePtr); Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n", litTableStats); - ckfree(litTableStats); + Tcl_Free(litTableStats); /* * Source and ByteCode size distributions. @@ -10152,16 +9900,17 @@ EvalStatsCmd( break; } } - for (i = 31; i != (size_t)-1; i--) { + for (i = 31; i != TCL_INDEX_NONE; i--) { if (statsPtr->srcCount[i] > 0) { - maxSizeDecade = i; - break; + break; /* maxSizeDecade to consume 'i' value + * below... */ } } + maxSizeDecade = i; sum = 0; - for (i = minSizeDecade; i <= maxSizeDecade; i++) { - decadeHigh = (1 << (i+1)) - 1; - sum += statsPtr->srcCount[i]; + for (ui = minSizeDecade; ui <= maxSizeDecade; ui++) { + decadeHigh = (1 << (ui+1)) - 1; + sum += statsPtr->srcCount[ui]; Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } @@ -10175,16 +9924,17 @@ EvalStatsCmd( break; } } - for (i = 31; i != (size_t)-1; i--) { + for (i = 31; i != TCL_INDEX_NONE; i--) { if (statsPtr->byteCodeCount[i] > 0) { - maxSizeDecade = i; - break; + break; /* maxSizeDecade to consume 'i' value + * below... */ } } + maxSizeDecade = i; sum = 0; - for (i = minSizeDecade; i <= maxSizeDecade; i++) { - decadeHigh = (1 << (i+1)) - 1; - sum += statsPtr->byteCodeCount[i]; + for (ui = minSizeDecade; ui <= maxSizeDecade; i++) { + decadeHigh = (1 << (ui+1)) - 1; + sum += statsPtr->byteCodeCount[ui]; Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } @@ -10198,16 +9948,17 @@ EvalStatsCmd( break; } } - for (i = 31; i != (size_t)-1; i--) { + for (i = 31; i != TCL_INDEX_NONE; i--) { if (statsPtr->lifetimeCount[i] > 0) { - maxSizeDecade = i; - break; + break; /* maxSizeDecade to consume 'i' value + * below... */ } } + maxSizeDecade = i; sum = 0; - for (i = minSizeDecade; i <= maxSizeDecade; i++) { - decadeHigh = (1 << (i+1)) - 1; - sum += statsPtr->lifetimeCount[i]; + for (ui = minSizeDecade; ui <= maxSizeDecade; ui++) { + decadeHigh = (1 << (ui+1)) - 1; + sum += statsPtr->lifetimeCount[ui]; Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n", decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed)); } @@ -10217,7 +9968,7 @@ EvalStatsCmd( */ Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); - for (i = 0; i <= LAST_INST_OPCODE; i++) { + for (i = 0; i < LAST_INST_OPCODE; i++) { Tcl_AppendPrintfToObj(objPtr, "%20s %8" TCL_Z_MODIFIER "u ", tclInstructionTable[i].name, statsPtr->instructionCount[i]); if (statsPtr->instructionCount[i]) { @@ -10238,7 +9989,7 @@ EvalStatsCmd( Tcl_SetObjResult(interp, objPtr); } else { Tcl_Channel outChan; - char *str = TclGetStringFromObj(objv[1], &length); + char *str = Tcl_GetStringFromObj(objv[1], &length); if (length) { if (strcmp(str, "stdout") == 0) { diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 8ca0c88..4cea92e 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -47,7 +47,7 @@ static int FileForceOption(Tcl_Interp *interp, int TclFileRenameCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Interp for error reporting or recursive * calls in the case of a tricky rename. */ int objc, /* Number of arguments. */ @@ -76,7 +76,7 @@ TclFileRenameCmd( int TclFileCopyCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Used for error reporting or recursive calls * in the case of a tricky copy. */ int objc, /* Number of arguments. */ @@ -113,6 +113,7 @@ FileCopyRename( int i, result, force; Tcl_StatBuf statBuf; Tcl_Obj *target; + Tcl_DString ds; i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { @@ -134,6 +135,12 @@ FileCopyRename( if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } + if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(target), + TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringFree(&ds); result = TCL_OK; @@ -214,16 +221,18 @@ FileCopyRename( int TclFileMakeDirsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Used for error reporting. */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */ { Tcl_Obj *errfile = NULL; - int result, i, j, pobjc; + int result, i; + Tcl_Size j, pobjc; Tcl_Obj *split = NULL; Tcl_Obj *target = NULL; Tcl_StatBuf statBuf; + Tcl_DString ds; result = TCL_OK; for (i = 1; i < objc; i++) { @@ -231,6 +240,13 @@ TclFileMakeDirsCmd( result = TCL_ERROR; break; } + if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[i]), + TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + result = TCL_ERROR; + break; + } + Tcl_DStringFree(&ds); split = Tcl_FSSplitPath(objv[i], &pobjc); Tcl_IncrRefCount(split); @@ -338,7 +354,7 @@ TclFileMakeDirsCmd( int TclFileDeleteCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Used for error reporting */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */ @@ -346,6 +362,7 @@ TclFileDeleteCmd( int i, force, result; Tcl_Obj *errfile; Tcl_Obj *errorBuffer = NULL; + Tcl_DString ds; i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { @@ -363,6 +380,13 @@ TclFileDeleteCmd( result = TCL_ERROR; goto done; } + if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[i]), + TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + result = TCL_ERROR; + goto done; + } + Tcl_DStringFree(&ds); /* * Call lstat() to get info so can delete symbolic link itself. @@ -482,13 +506,26 @@ CopyRenameOneFile( Tcl_Obj *actualSource=NULL; /* If source is a link, then this is the real * file/directory. */ Tcl_StatBuf sourceStatBuf, targetStatBuf; + Tcl_DString ds; if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { return TCL_ERROR; } + if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(source), + TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringFree(&ds); if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } + if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(target), + TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringFree(&ds); errfile = NULL; errorBuffer = NULL; @@ -870,10 +907,10 @@ FileForceOption( static Tcl_Obj * FileBasename( - Tcl_Interp *interp, /* Interp, for error return. */ + TCL_UNUSED(Tcl_Interp *), /* Interp, for error return. */ Tcl_Obj *pathPtr) /* Path whose basename to extract. */ { - int objc; + Tcl_Size objc; Tcl_Obj *splitPtr; Tcl_Obj *resultPtr = NULL; @@ -881,17 +918,8 @@ FileBasename( Tcl_IncrRefCount(splitPtr); if (objc != 0) { - if ((objc == 1) && (*TclGetString(pathPtr) == '~')) { - Tcl_DecrRefCount(splitPtr); - if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { - return NULL; - } - splitPtr = Tcl_FSSplitPath(pathPtr, &objc); - Tcl_IncrRefCount(splitPtr); - } - - /* - * Return the last component, unless it is the only component, and it + /* + * Return the last component, unless it is the only component, and it * is the root of an absolute path. */ @@ -946,7 +974,7 @@ FileBasename( int TclFileAttrsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter for error reporting. */ int objc, /* Number of command line arguments. */ Tcl_Obj *const objv[]) /* The command line objects. */ @@ -955,8 +983,9 @@ TclFileAttrsCmd( const char *const *attributeStrings; const char **attributeStringsAllocated = NULL; Tcl_Obj *objStrings = NULL; - int numObjStrings = -1; + Tcl_Size numObjStrings = TCL_INDEX_NONE; Tcl_Obj *filePtr; + Tcl_DString ds; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?"); @@ -967,6 +996,12 @@ TclFileAttrsCmd( if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { return TCL_ERROR; } + if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(filePtr), + TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringFree(&ds); objc -= 2; objv += 2; @@ -979,7 +1014,7 @@ TclFileAttrsCmd( attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings); if (attributeStrings == NULL) { - int index; + Tcl_Size index; Tcl_Obj *objPtr; if (objStrings == NULL) { @@ -1162,13 +1197,14 @@ TclFileAttrsCmd( int TclFileLinkCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *contents; int index; + Tcl_DString ds; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-linktype? linkname ?target?"); @@ -1211,6 +1247,12 @@ TclFileLinkCmd( if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { return TCL_ERROR; } + if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[index]), + TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringFree(&ds); /* * Create link from source to target. @@ -1268,6 +1310,12 @@ TclFileLinkCmd( if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { return TCL_ERROR; } + if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[index]), + TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringFree(&ds); /* * Read link @@ -1313,12 +1361,13 @@ TclFileLinkCmd( int TclFileReadLinkCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *contents; + Tcl_DString ds; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); @@ -1328,6 +1377,12 @@ TclFileReadLinkCmd( if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } + if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[1]), + TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringFree(&ds); contents = Tcl_FSLink(objv[1], NULL, 0); @@ -1364,7 +1419,7 @@ TclFileReadLinkCmd( int TclFileTemporaryCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1389,9 +1444,9 @@ TclFileTemporaryCmd( TclNewObj(nameObj); } if (objc > 2) { - int length; + Tcl_Size length; Tcl_Obj *templateObj = objv[2]; - const char *string = TclGetStringFromObj(templateObj, &length); + const char *string = Tcl_GetStringFromObj(templateObj, &length); /* * Treat an empty string as if it wasn't there. @@ -1523,7 +1578,7 @@ TclFileTemporaryCmd( int TclFileTempDirCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1541,9 +1596,9 @@ TclFileTempDirCmd( } if (objc > 1) { - int length; + Tcl_Size length; Tcl_Obj *templateObj = objv[1]; - const char *string = TclGetStringFromObj(templateObj, &length); + const char *string = Tcl_GetStringFromObj(templateObj, &length); const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS); /* @@ -1679,7 +1734,7 @@ TclFileHomeCmd( Tcl_WrongNumArgs(interp, 1, objv, "?user?"); return TCL_ERROR; } - homeDirObj = TclGetHomeDirObj(interp, objc == 1 ? NULL : TclGetString(objv[1])); + homeDirObj = TclGetHomeDirObj(interp, objc == 1 ? NULL : Tcl_GetString(objv[1])); if (homeDirObj == NULL) { return TCL_ERROR; } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 7f4f1cc..b7ac0fa 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -26,8 +26,6 @@ TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; * Prototypes for local procedures defined in this file: */ -static const char * DoTildeSubst(Tcl_Interp *interp, - const char *user, Tcl_DString *resultPtr); static const char * ExtractWinRoot(const char *path, Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr); @@ -43,11 +41,8 @@ static int TclGlob(Tcl_Interp *interp, char *pattern, /* Flag values used by TclGlob() */ -#ifdef TCL_NO_DEPRECATED -# define TCL_GLOBMODE_NO_COMPLAIN 1 -# define TCL_GLOBMODE_DIR 4 -# define TCL_GLOBMODE_TAILS 8 -#endif +#define TCL_GLOBMODE_DIR 4 +#define TCL_GLOBMODE_TAILS 8 /* * When there is no support for getting the block size of a file in a stat() @@ -373,12 +368,6 @@ Tcl_GetPathType( * file). The exported function Tcl_FSGetPathType should be used by * extensions. * - * Note that '~' paths are always considered TCL_PATH_ABSOLUTE, even - * though expanding the '~' could lead to any possible path type. This - * function should therefore be considered a low-level, string - * manipulation function only -- it doesn't actually do any expansion in - * making its determination. - * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or * TCL_PATH_VOLUME_RELATIVE. @@ -392,76 +381,60 @@ Tcl_GetPathType( Tcl_PathType TclpGetNativePathType( Tcl_Obj *pathPtr, /* Native path of interest */ - int *driveNameLengthPtr, /* Returns length of drive, if non-NULL and - * path was absolute */ + Tcl_Size *driveNameLengthPtr, /* Returns length of drive, if non-NULL and + * path was absolute */ Tcl_Obj **driveNameRef) { Tcl_PathType type = TCL_PATH_ABSOLUTE; - int pathLen; - const char *path = TclGetStringFromObj(pathPtr, &pathLen); - - if (path[0] == '~') { - /* - * This case is common to all platforms. Paths that begin with ~ are - * absolute. - */ - - if (driveNameLengthPtr != NULL) { - const char *end = path + 1; - while ((*end != '\0') && (*end != '/')) { - end++; - } - *driveNameLengthPtr = end - path; - } - } else { - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: { - const char *origPath = path; - - /* - * Paths that begin with / are absolute. - */ - - if (path[0] == '/') { - ++path; - /* - * Check for "//" network path prefix - */ - if ((*path == '/') && path[1] && (path[1] != '/')) { - path += 2; - while (*path && *path != '/') { - ++path; - } - } - if (driveNameLengthPtr != NULL) { - /* - * We need this addition in case the "//" code was used. - */ + const char *path = TclGetString(pathPtr); - *driveNameLengthPtr = (path - origPath); - } - } else { - type = TCL_PATH_RELATIVE; - } - break; - } - case TCL_PLATFORM_WINDOWS: { - Tcl_DString ds; - const char *rootEnd; - - Tcl_DStringInit(&ds); - rootEnd = ExtractWinRoot(path, &ds, 0, &type); - if ((rootEnd != path) && (driveNameLengthPtr != NULL)) { - *driveNameLengthPtr = rootEnd - path; - if (driveNameRef != NULL) { - *driveNameRef = Tcl_DStringToObj(&ds); - Tcl_IncrRefCount(*driveNameRef); - } - } - Tcl_DStringFree(&ds); - break; - } - } + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: { + const char *origPath = path; + + /* + * Paths that begin with / are absolute. + */ + + if (path[0] == '/') { + ++path; + /* + * Check for "//" network path prefix + */ + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } + } + if (driveNameLengthPtr != NULL) { + /* + * We need this addition in case the "//" code was used. + */ + + *driveNameLengthPtr = (path - origPath); + } + } else { + type = TCL_PATH_RELATIVE; + } + break; + } + case TCL_PLATFORM_WINDOWS: { + Tcl_DString ds; + const char *rootEnd; + + Tcl_DStringInit(&ds); + rootEnd = ExtractWinRoot(path, &ds, 0, &type); + if ((rootEnd != path) && (driveNameLengthPtr != NULL)) { + *driveNameLengthPtr = rootEnd - path; + if (driveNameRef != NULL) { + *driveNameRef = Tcl_DStringToObj(&ds); + Tcl_IncrRefCount(*driveNameRef); + } + } + Tcl_DStringFree(&ds); + break; + } } return type; } @@ -492,7 +465,7 @@ TclpGetNativePathType( Tcl_Obj * TclpNativeSplitPath( Tcl_Obj *pathPtr, /* Path to split. */ - int *lenPtr) /* int to store number of path elements. */ + Tcl_Size *lenPtr) /* int to store number of path elements. */ { Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ @@ -535,7 +508,7 @@ TclpNativeSplitPath( * *argcPtr will get filled in with the number of valid elements in the * array. A single block of memory is dynamically allocated to hold both * the argv array and a copy of the path elements. The caller must - * eventually free this memory by calling ckfree() on *argvPtr. Note: + * eventually free this memory by calling Tcl_Free() on *argvPtr. Note: * *argvPtr and *argcPtr are only modified if the procedure returns * normally. * @@ -549,14 +522,14 @@ TclpNativeSplitPath( void Tcl_SplitPath( const char *path, /* Pointer to string containing a path. */ - int *argcPtr, /* Pointer to location to fill in with the + Tcl_Size *argcPtr, /* Pointer to location to fill in with the * number of elements in the path. */ const char ***argvPtr) /* Pointer to place to store pointer to array * of pointers to path elements. */ { Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Obj *tmpPtr, *eltPtr; - int i, size, len; + Tcl_Size i, size, len; char *p; const char *str; @@ -577,7 +550,7 @@ Tcl_SplitPath( size = 1; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - TclGetStringFromObj(eltPtr, &len); + (void)Tcl_GetStringFromObj(eltPtr, &len); size += len + 1; } @@ -586,7 +559,7 @@ Tcl_SplitPath( * plus the argv pointers and the terminating NULL pointer. */ - *argvPtr = (const char **)ckalloc( + *argvPtr = (const char **)Tcl_Alloc( ((((*argcPtr) + 1) * sizeof(char *)) + size)); /* @@ -597,7 +570,7 @@ Tcl_SplitPath( p = (char *) &(*argvPtr)[(*argcPtr) + 1]; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - str = TclGetStringFromObj(eltPtr, &len); + str = Tcl_GetStringFromObj(eltPtr, &len); memcpy(p, str, len + 1); p += len+1; } @@ -642,7 +615,7 @@ static Tcl_Obj * SplitUnixPath( const char *path) /* Pointer to string containing a path. */ { - int length; + size_t length; const char *origPath = path, *elementStart; Tcl_Obj *result; @@ -671,8 +644,7 @@ SplitUnixPath( } /* - * Split on slashes. Embedded elements that start with tilde will be - * prefixed with "./" so they are not affected by tilde substitution. + * Split on slashes. */ for (;;) { @@ -683,13 +655,8 @@ SplitUnixPath( length = path - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart[0] == '~') && (elementStart != origPath)) { - TclNewLiteralStringObj(nextElt, "./"); - Tcl_AppendToObj(nextElt, elementStart, length); - } else { - nextElt = Tcl_NewStringObj(elementStart, length); - } - Tcl_ListObjAppendElement(NULL, result, nextElt); + nextElt = Tcl_NewStringObj(elementStart, length); + Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*path++ == '\0') { break; @@ -719,7 +686,7 @@ static Tcl_Obj * SplitWinPath( const char *path) /* Pointer to string containing a path. */ { - int length; + size_t length; const char *p, *elementStart; Tcl_PathType type = TCL_PATH_ABSOLUTE; Tcl_DString buf; @@ -739,9 +706,7 @@ SplitWinPath( Tcl_DStringFree(&buf); /* - * Split on slashes. Embedded elements that start with tilde or a drive - * letter will be prefixed with "./" so they are not affected by tilde - * substitution. + * Split on slashes. */ do { @@ -752,9 +717,9 @@ SplitWinPath( length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart != path) && ((elementStart[0] == '~') - || (isalpha(UCHAR(elementStart[0])) - && elementStart[1] == ':'))) { + if ((elementStart != path) && + isalpha(UCHAR(elementStart[0])) && + (elementStart[1] == ':')) { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { @@ -793,7 +758,7 @@ SplitWinPath( Tcl_Obj * Tcl_FSJoinToPath( Tcl_Obj *pathPtr, /* Valid path or NULL. */ - int objc, /* Number of array elements to join */ + Tcl_Size objc, /* Number of array elements to join */ Tcl_Obj *const objv[]) /* Path elements to join. */ { if (pathPtr == NULL) { @@ -809,13 +774,13 @@ Tcl_FSJoinToPath( pair[1] = objv[0]; return TclJoinPath(2, pair, 0); } else { - int elemc = objc + 1; - Tcl_Obj *ret, **elemv = (Tcl_Obj**)ckalloc(elemc*sizeof(Tcl_Obj *)); + Tcl_Size elemc = objc + 1; + Tcl_Obj *ret, **elemv = (Tcl_Obj**)Tcl_Alloc(elemc*sizeof(Tcl_Obj *)); elemv[0] = pathPtr; memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *)); ret = TclJoinPath(elemc, elemv, 0); - ckfree(elemv); + Tcl_Free(elemv); return ret; } } @@ -841,24 +806,25 @@ TclpNativeJoinPath( Tcl_Obj *prefix, const char *joining) { - int length, needsSep; + int needsSep; + Tcl_Size length; char *dest; const char *p; const char *start; - start = TclGetStringFromObj(prefix, &length); + start = Tcl_GetStringFromObj(prefix, &length); /* - * Remove the ./ from tilde prefixed elements, and drive-letter prefixed + * Remove the ./ from drive-letter prefixed * elements on Windows, unless it is the first component. */ p = joining; if (length != 0) { - if ((p[0] == '.') && (p[1] == '/') && ((p[2] == '~') - || (tclPlatform==TCL_PLATFORM_WINDOWS && isalpha(UCHAR(p[2])) - && (p[3] == ':')))) { + if ((p[0] == '.') && (p[1] == '/') && + (tclPlatform==TCL_PLATFORM_WINDOWS) && isalpha(UCHAR(p[2])) + && (p[3] == ':')) { p += 2; } } @@ -874,7 +840,7 @@ TclpNativeJoinPath( if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - TclGetStringFromObj(prefix, &length); + (void)Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; @@ -882,9 +848,9 @@ TclpNativeJoinPath( * Append the element, eliminating duplicate and trailing slashes. */ - Tcl_SetObjLength(prefix, length + (int) strlen(p)); + Tcl_SetObjLength(prefix, length + strlen(p)); - dest = Tcl_GetString(prefix) + length; + dest = TclGetString(prefix) + length; for (; *p != '\0'; p++) { if (*p == '/') { while (p[1] == '/') { @@ -898,7 +864,7 @@ TclpNativeJoinPath( needsSep = 1; } } - length = dest - Tcl_GetString(prefix); + length = dest - TclGetString(prefix); Tcl_SetObjLength(prefix, length); break; @@ -910,7 +876,7 @@ TclpNativeJoinPath( if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - TclGetStringFromObj(prefix, &length); + (void)Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; @@ -933,7 +899,7 @@ TclpNativeJoinPath( needsSep = 1; } } - length = dest - Tcl_GetString(prefix); + length = dest - TclGetString(prefix); Tcl_SetObjLength(prefix, length); break; } @@ -961,11 +927,11 @@ TclpNativeJoinPath( char * Tcl_JoinPath( - int argc, + Tcl_Size argc, const char *const *argv, Tcl_DString *resultPtr) /* Pointer to previously initialized DString */ { - int i, len; + Tcl_Size i, len; Tcl_Obj *listObj; Tcl_Obj *resultObj; const char *resultStr; @@ -993,7 +959,7 @@ Tcl_JoinPath( * Store the result. */ - resultStr = TclGetStringFromObj(resultObj, &len); + resultStr = Tcl_GetStringFromObj(resultObj, &len); Tcl_DStringAppend(resultPtr, resultStr, len); Tcl_DecrRefCount(resultObj); @@ -1010,19 +976,15 @@ Tcl_JoinPath( * Tcl_TranslateFileName -- * * Converts a file name into a form usable by the native system - * interfaces. If the name starts with a tilde, it will produce a name - * where the tilde and following characters have been replaced by the - * home directory location for the named user. + * interfaces. * * Results: - * The return value is a pointer to a string containing the name after - * tilde substitution. If there was no tilde substitution, the return - * value is a pointer to a copy of the original string. If there was an + * The return value is a pointer to a string containing the name. + * This may either be the name pointer passed in or space allocated in + * bufferPtr. In all cases, if the return value is not NULL, the caller + * must call Tcl_DStringFree() to free the space. If there was an * error in processing the name, then an error message is left in the * interp's result (if interp was not NULL) and the return value is NULL. - * Space for the return value is allocated in bufferPtr; the caller must - * call Tcl_DStringFree() to free the space if the return value was not - * NULL. * * Side effects: * None. @@ -1039,7 +1001,7 @@ Tcl_TranslateFileName( * "~<user>" (to indicate any user's home * directory). */ Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with - * name after tilde substitution. */ + * name. */ { Tcl_Obj *path = Tcl_NewStringObj(name, -1); Tcl_Obj *transPtr; @@ -1134,65 +1096,6 @@ TclGetExtension( /* *---------------------------------------------------------------------- * - * DoTildeSubst -- - * - * Given a string following a tilde, this routine returns the - * corresponding home directory. - * - * Results: - * The result is a pointer to a static string containing the home - * directory in native format. If there was an error in processing the - * substitution, then an error message is left in the interp's result and - * the return value is NULL. On success, the results are appended to - * resultPtr, and the contents of resultPtr are returned. - * - * Side effects: - * Information may be left in resultPtr. - * - *---------------------------------------------------------------------- - */ - -static const char * -DoTildeSubst( - Tcl_Interp *interp, /* Interpreter in which to store error message - * (if necessary). */ - const char *user, /* Name of user whose home directory should be - * substituted, or "" for current user. */ - Tcl_DString *resultPtr) /* Initialized DString filled with name after - * tilde substitution. */ -{ - const char *dir; - - if (*user == '\0') { - Tcl_DString dirString; - - dir = TclGetEnv("HOME", &dirString); - if (dir == NULL) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "couldn't find HOME environment " - "variable to expand path", -1)); - Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", (void *)NULL); - } - return NULL; - } - Tcl_JoinPath(1, &dir, resultPtr); - Tcl_DStringFree(&dirString); - } else if (TclpGetUserHome(user, resultPtr) == NULL) { - if (interp) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "user \"%s\" doesn't exist", user)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, (void *)NULL); - } - return NULL; - } - return Tcl_DStringValue(resultPtr); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_GlobObjCmd -- * * This procedure is invoked to process the "glob" Tcl command. See the @@ -1209,12 +1112,13 @@ DoTildeSubst( int Tcl_GlobObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int index, i, globFlags, length, join, dir, result; + int i, globFlags, join, dir, result; + Tcl_Size length; char *string; const char *separators; Tcl_Obj *typePtr, *look; @@ -1227,7 +1131,7 @@ Tcl_GlobObjCmd( enum globOptionsEnum { GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, GLOB_TYPE, GLOB_LAST - }; + } index; enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1}; Tcl_GlobTypeData *globTypes = NULL; @@ -1236,9 +1140,9 @@ Tcl_GlobObjCmd( dir = PATH_NONE; typePtr = NULL; for (i = 1; i < objc; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, - &index) != TCL_OK) { - string = TclGetStringFromObj(objv[i], &length); + if (Tcl_GetIndexFromObj(interp, objv[i], options, + "option", 0, &index) != TCL_OK) { + string = TclGetString(objv[i]); if (string[0] == '-') { /* * It looks like the command contains an option so signal an @@ -1257,9 +1161,12 @@ Tcl_GlobObjCmd( } } - switch ((enum globOptionsEnum) index) { + switch (index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ - globFlags |= TCL_GLOBMODE_NO_COMPLAIN; + /* + * Do nothing; This is normal operations in Tcl 9. + * Keep accepting as a no-op option to accommodate old scripts. + */ break; case GLOB_DIR: /* -dir */ if (i == (objc-1)) { @@ -1350,9 +1257,9 @@ Tcl_GlobObjCmd( } if (dir == PATH_GENERAL) { - int pathlength; + Tcl_Size pathlength; const char *last; - const char *first = TclGetStringFromObj(pathOrDir,&pathlength); + const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path @@ -1403,7 +1310,7 @@ Tcl_GlobObjCmd( * for the zipfs volume. */ - const char *temp = Tcl_GetString(pathOrDir); + const char *temp = TclGetString(pathOrDir); if (strpbrk(temp, "\\/") == NULL) { Tcl_AppendToObj(pathOrDir, last-1, 1); } else if (!strcmp(temp, "//zipfs:")) { @@ -1445,7 +1352,7 @@ Tcl_GlobObjCmd( */ TclListObjLengthM(interp, typePtr, &length); - if (length <= 0) { + if (length == 0) { goto skipTypes; } globTypes = (Tcl_GlobTypeData *)TclStackAlloc(interp, sizeof(Tcl_GlobTypeData)); @@ -1454,12 +1361,12 @@ Tcl_GlobObjCmd( globTypes->macType = NULL; globTypes->macCreator = NULL; - while (--length >= 0) { - int len; + while (length-- > 0) { + Tcl_Size len; const char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); - str = TclGetStringFromObj(look, &len); + str = Tcl_GetStringFromObj(look, &len); if (strcmp("readonly", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_RONLY; } else if (strcmp("hidden", str) == 0) { @@ -1513,13 +1420,14 @@ Tcl_GlobObjCmd( } else { Tcl_Obj *item; + Tcl_Size llen; - if ((TclListObjLengthM(NULL, look, &len) == TCL_OK) - && (len == 3)) { + if ((TclListObjLengthM(NULL, look, &llen) == TCL_OK) + && (llen == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); - if (!strcmp("macintosh", Tcl_GetString(item))) { + if (!strcmp("macintosh", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); - if (!strcmp("type", Tcl_GetString(item))) { + if (!strcmp("type", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 2, &item); if (globTypes->macType != NULL) { goto badMacTypesArg; @@ -1527,7 +1435,7 @@ Tcl_GlobObjCmd( globTypes->macType = item; Tcl_IncrRefCount(item); continue; - } else if (!strcmp("creator", Tcl_GetString(item))) { + } else if (!strcmp("creator", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 2, &item); if (globTypes->macCreator != NULL) { goto badMacTypesArg; @@ -1547,7 +1455,7 @@ Tcl_GlobObjCmd( badTypesArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument to \"-types\": %s", - Tcl_GetString(look))); + TclGetString(look))); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (void *)NULL); result = TCL_ERROR; join = 0; @@ -1611,7 +1519,7 @@ Tcl_GlobObjCmd( Tcl_DStringFree(&str); } else { for (i = 0; i < objc; i++) { - string = Tcl_GetString(objv[i]); + string = TclGetString(objv[i]); if (TclGlob(interp, string, pathOrDir, globFlags, globTypes) != TCL_OK) { result = TCL_ERROR; @@ -1620,41 +1528,6 @@ Tcl_GlobObjCmd( } } - if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { - if (TclListObjLengthM(interp, Tcl_GetObjResult(interp), - &length) != TCL_OK) { - /* - * This should never happen. Maybe we should be more dramatic. - */ - - result = TCL_ERROR; - goto endOfGlob; - } - - if (length == 0) { - Tcl_Obj *errorMsg = - Tcl_ObjPrintf("no files matched glob pattern%s \"", - (join || (objc == 1)) ? "" : "s"); - - if (join) { - Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1); - } else { - const char *sep = ""; - - for (i = 0; i < objc; i++) { - Tcl_AppendPrintfToObj(errorMsg, "%s%s", - sep, Tcl_GetString(objv[i])); - sep = " "; - } - } - Tcl_AppendToObj(errorMsg, "\"", -1); - Tcl_SetObjResult(interp, errorMsg); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH", - (void *)NULL); - result = TCL_ERROR; - } - } - endOfGlob: if (join || (dir == PATH_GENERAL)) { Tcl_DStringFree(&prefix); @@ -1679,8 +1552,7 @@ Tcl_GlobObjCmd( * * TclGlob -- * - * Sets the separator string based on the platform, performs tilde - * substitution, and calls DoGlob. + * Sets the separator string based on the platform and calls DoGlob. * * The interpreter's result, on entry to this function, must be a valid * Tcl list (e.g. it could be empty), since we will lappend any new @@ -1716,8 +1588,7 @@ TclGlob( * NULL. */ { const char *separators; - const char *head; - char *tail, *start; + char *tail; int result; Tcl_Obj *filenamesObj, *savedResultObj; @@ -1731,60 +1602,10 @@ TclGlob( break; } - if (pathPrefix == NULL) { - char c; - Tcl_DString buffer; - Tcl_DStringInit(&buffer); - - start = pattern; - - /* - * Perform tilde substitution, if needed. - */ - - if (start[0] == '~') { - /* - * Find the first path separator after the tilde. - */ - - for (tail = start; *tail != '\0'; tail++) { - if (*tail == '\\') { - if (strchr(separators, tail[1]) != NULL) { - break; - } - } else if (strchr(separators, *tail) != NULL) { - break; - } - } - - /* - * Determine the home directory for the specified user. - */ - - c = *tail; - *tail = '\0'; - head = DoTildeSubst(interp, start+1, &buffer); - *tail = c; - if (head == NULL) { - return TCL_ERROR; - } - if (head != Tcl_DStringValue(&buffer)) { - Tcl_DStringAppend(&buffer, head, -1); - } - pathPrefix = Tcl_DStringToObj(&buffer); - Tcl_IncrRefCount(pathPrefix); - globFlags |= TCL_GLOBMODE_DIR; - if (c != '\0') { - tail++; - } - Tcl_DStringFree(&buffer); - } else { - tail = pattern; - } - } else { + if (pathPrefix != NULL) { Tcl_IncrRefCount(pathPrefix); - tail = pattern; } + tail = pattern; /* * Handling empty path prefixes with glob patterns like 'C:' or @@ -1823,7 +1644,7 @@ TclGlob( Tcl_IncrRefCount(pathPrefix); } else if (pathPrefix == NULL && (tail[0] == '/' || (tail[0] == '\\' && tail[1] == '\\'))) { - int driveNameLen; + Tcl_Size driveNameLen; Tcl_Obj *driveName; Tcl_Obj *temp = Tcl_NewStringObj(tail, -1); Tcl_IncrRefCount(temp); @@ -1844,7 +1665,7 @@ TclGlob( Tcl_DecrRefCount(temp); return TCL_ERROR; } - pathPrefix = Tcl_NewStringObj(Tcl_GetString(cwd), 3); + pathPrefix = Tcl_NewStringObj(TclGetString(cwd), 3); Tcl_DecrRefCount(cwd); if (tail[0] == '/') { tail++; @@ -1891,9 +1712,9 @@ TclGlob( */ if (pathPrefix == NULL) { - int driveNameLen; + Tcl_Size driveNameLen; Tcl_Obj *driveName; - if (TclFSNonnativePathType(tail, (int) strlen(tail), NULL, + if (TclFSNonnativePathType(tail, strlen(tail), NULL, &driveNameLen, &driveName) == TCL_PATH_ABSOLUTE) { pathPrefix = driveName; tail += driveNameLen; @@ -1976,9 +1797,9 @@ TclGlob( */ if (globFlags & TCL_GLOBMODE_TAILS) { - int objc, i; + Tcl_Size objc, i; Tcl_Obj **objv; - int prefixLen; + Tcl_Size prefixLen; const char *pre; /* @@ -1989,7 +1810,7 @@ TclGlob( Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL"); } - pre = TclGetStringFromObj(pathPrefix, &prefixLen); + pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); if (prefixLen > 0 && (strchr(separators, pre[prefixLen-1]) == NULL)) { /* @@ -2006,8 +1827,8 @@ TclGlob( TclListObjGetElementsM(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { - int len; - const char *oldStr = TclGetStringFromObj(objv[i], &len); + Tcl_Size len; + const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); Tcl_Obj *elem; if (len == prefixLen) { @@ -2328,7 +2149,7 @@ DoGlob( pattern, &dirOnly); *p = save; if (result == TCL_OK) { - int subdirc, i, repair = -1; + Tcl_Size i, subdirc, repair = -1; Tcl_Obj **subdirv; result = TclListObjGetElementsM(interp, subdirsPtr, @@ -2336,34 +2157,27 @@ DoGlob( for (i=0; result==TCL_OK && i<subdirc; i++) { Tcl_Obj *copy = NULL; - if (pathPtr == NULL && Tcl_GetString(subdirv[i])[0] == '~') { - TclListObjLengthM(NULL, matchesObj, &repair); - copy = subdirv[i]; - subdirv[i] = Tcl_NewStringObj("./", 2); - Tcl_AppendObjToObj(subdirv[i], copy); - Tcl_IncrRefCount(subdirv[i]); - } result = DoGlob(interp, matchesObj, separators, subdirv[i], 1, p+1, types); if (copy) { - int end; + Tcl_Size end; Tcl_DecrRefCount(subdirv[i]); subdirv[i] = copy; TclListObjLengthM(NULL, matchesObj, &end); while (repair < end) { const char *bytes; - int numBytes; + Tcl_Size numBytes; Tcl_Obj *fixme, *newObj; Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme); - bytes = TclGetStringFromObj(fixme, &numBytes); + bytes = Tcl_GetStringFromObj(fixme, &numBytes); newObj = Tcl_NewStringObj(bytes+2, numBytes-2); Tcl_ListObjReplace(NULL, matchesObj, repair, 1, 1, &newObj); repair++; } - repair = -1; + repair = TCL_INDEX_NONE; } } } @@ -2376,7 +2190,7 @@ DoGlob( */ if (*p == '\0') { - int length; + Tcl_Size length; Tcl_DString append; /* @@ -2395,7 +2209,7 @@ DoGlob( Tcl_DStringAppend(&append, pattern, p-pattern); if (pathPtr != NULL) { - (void) TclGetStringFromObj(pathPtr, &length); + (void) Tcl_GetStringFromObj(pathPtr, &length); } else { length = 0; } @@ -2440,8 +2254,8 @@ DoGlob( * The current prefix must end in a separator. */ - int len; - const char *joined = TclGetStringFromObj(joinedPtr,&len); + Tcl_Size len; + const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { Tcl_AppendToObj(joinedPtr, "/", 1); @@ -2477,8 +2291,8 @@ DoGlob( * This behaviour is not currently tested for in the test suite. */ - int len; - const char *joined = TclGetStringFromObj(joinedPtr,&len); + Tcl_Size len; + const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { @@ -2507,7 +2321,7 @@ DoGlob( * * Results: * A pointer to a Tcl_StatBuf which may be deallocated by being passed to - * ckfree(). + * Tcl_Free(). * * Side effects: * None. @@ -2518,7 +2332,7 @@ DoGlob( Tcl_StatBuf * Tcl_AllocStatBuf(void) { - return (Tcl_StatBuf *)ckalloc(sizeof(Tcl_StatBuf)); + return (Tcl_StatBuf *)Tcl_Alloc(sizeof(Tcl_StatBuf)); } /* @@ -2527,8 +2341,8 @@ Tcl_AllocStatBuf(void) * Access functions for Tcl_StatBuf -- * * These functions provide portable read-only access to the portable - * fields of the Tcl_StatBuf structure (really a 'struct stat', 'struct - * stat64' or something else related). [TIP #316] + * fields of the Tcl_StatBuf structure (really a 'struct stat' + * or something else related). [TIP #316] * * Results: * The value from the field being retrieved. diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h index 503b204..e986d34 100644 --- a/generic/tclFileSystem.h +++ b/generic/tclFileSystem.h @@ -48,13 +48,13 @@ MODULE_SCOPE const Tcl_Filesystem tclNativeFilesystem; MODULE_SCOPE Tcl_PathType TclFSGetPathType(Tcl_Obj *pathPtr, const Tcl_Filesystem **filesystemPtrPtr, - int *driveNameLengthPtr); + Tcl_Size *driveNameLengthPtr); MODULE_SCOPE Tcl_PathType TclFSNonnativePathType(const char *pathPtr, - int pathLen, const Tcl_Filesystem **filesystemPtrPtr, - int *driveNameLengthPtr, Tcl_Obj **driveNameRef); + Tcl_Size pathLen, const Tcl_Filesystem **filesystemPtrPtr, + Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE Tcl_PathType TclGetPathType(Tcl_Obj *pathPtr, const Tcl_Filesystem **filesystemPtrPtr, - int *driveNameLengthPtr, Tcl_Obj **driveNameRef); + Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE int TclFSEpochOk(size_t filesystemEpoch); MODULE_SCOPE int TclFSCwdIsNative(void); MODULE_SCOPE Tcl_Obj * TclWinVolumeRelativeNormalize(Tcl_Interp *interp, diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 5a79cf2..a058f13 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -97,8 +97,8 @@ typedef struct DateInfo { int dateDigitCount; } DateInfo; -#define YYMALLOC ckalloc -#define YYFREE(x) (ckfree((void*) (x))) +#define YYMALLOC Tcl_Alloc +#define YYFREE(x) (Tcl_Free((void*) (x))) #define yyDSTmode (info->dateDSTmode) #define yyDayOrdinal (info->dateDayOrdinal) @@ -976,7 +976,7 @@ TclClockOldscanObjCmd( return TCL_ERROR; } - yyInput = TclGetString( objv[1] ); + yyInput = TclGetString(objv[1]); dateInfo.dateStart = yyInput; yyHaveDate = 0; @@ -1063,26 +1063,25 @@ TclClockOldscanObjCmd( TclNewObj(resultElement); if (yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyYear)); + Tcl_NewIntObj(yyYear)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyMonth)); + Tcl_NewIntObj(yyMonth)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyDay)); + Tcl_NewIntObj(yyDay)); } Tcl_ListObjAppendElement(interp, result, resultElement); if (yyHaveTime) { - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int) + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj( ToSeconds(yyHour, yyMinutes, yySeconds, (MERIDIAN)yyMeridian))); } else { - TclNewObj(resultElement); - Tcl_ListObjAppendElement(interp, result, resultElement); + Tcl_ListObjAppendElement(interp, result, Tcl_NewObj()); } TclNewObj(resultElement); if (yyHaveZone) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) -yyTimezone)); + Tcl_NewIntObj(-yyTimezone)); Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj(1 - yyDSTmode)); } @@ -1091,29 +1090,29 @@ TclClockOldscanObjCmd( TclNewObj(resultElement); if (yyHaveRel) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyRelMonth)); + Tcl_NewIntObj(yyRelMonth)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyRelDay)); + Tcl_NewIntObj(yyRelDay)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyRelSeconds)); + Tcl_NewIntObj(yyRelSeconds)); } Tcl_ListObjAppendElement(interp, result, resultElement); TclNewObj(resultElement); if (yyHaveDay && !yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyDayOrdinal)); + Tcl_NewIntObj(yyDayOrdinal)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyDayNumber)); + Tcl_NewIntObj(yyDayNumber)); } Tcl_ListObjAppendElement(interp, result, resultElement); TclNewObj(resultElement); if (yyHaveOrdinalMonth) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyMonthOrdinal)); + Tcl_NewIntObj(yyMonthOrdinal)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj((int) yyMonth)); + Tcl_NewIntObj(yyMonth)); } Tcl_ListObjAppendElement(interp, result, resultElement); diff --git a/generic/tclHash.c b/generic/tclHash.c index ea1b20e..4703cd2 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -14,13 +14,6 @@ #include "tclInt.h" /* - * Prevent macros from clashing with function definitions. - */ - -#undef Tcl_FindHashEntry -#undef Tcl_CreateHashEntry - -/* * When there are this many entries per bucket, on average, rebuild the hash * table to make it larger. */ @@ -35,7 +28,7 @@ */ #define RANDOM_INDEX(tablePtr, i) \ - ((((i)*1103515245UL) >> (tablePtr)->downShift) & (tablePtr)->mask) + ((((i)*(size_t)1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) /* * Prototypes for the array hash key methods. @@ -43,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. @@ -52,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: @@ -200,7 +193,7 @@ Tcl_InitCustomHashTable( /* *---------------------------------------------------------------------- * - * Tcl_FindHashEntry -- + * FindHashEntry -- * * Given a hash table find the entry with a matching key. * @@ -214,14 +207,6 @@ Tcl_InitCustomHashTable( *---------------------------------------------------------------------- */ -Tcl_HashEntry * -Tcl_FindHashEntry( - Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ - const void *key) /* Key to use to find matching entry. */ -{ - return (*((tablePtr)->findProc))(tablePtr, (const char *)key); -} - static Tcl_HashEntry * FindHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ @@ -234,7 +219,7 @@ FindHashEntry( /* *---------------------------------------------------------------------- * - * Tcl_CreateHashEntry -- + * CreateHashEntry -- * * Given a hash table with string keys, and a string key, find the entry * with a matching key. If there is no matching entry, then create a new @@ -252,17 +237,6 @@ FindHashEntry( *---------------------------------------------------------------------- */ -Tcl_HashEntry * -Tcl_CreateHashEntry( - Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ - const void *key, /* Key to use to find or create matching - * entry. */ - int *newPtr) /* Store info here telling whether a new entry - * was created. */ -{ - return (*((tablePtr)->createProc))(tablePtr, (const char *)key, newPtr); -} - static Tcl_HashEntry * CreateHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ @@ -273,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; @@ -307,7 +281,7 @@ CreateHashEntry( for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { - if (hash != PTR2UINT(hPtr->hash)) { + if (hash != hPtr->hash) { continue; } /* if keys pointers or values are equal */ @@ -323,7 +297,7 @@ CreateHashEntry( } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { - if (hash != PTR2UINT(hPtr->hash)) { + if (hash != hPtr->hash) { continue; } if (key == hPtr->key.oneWordValue) { @@ -347,13 +321,13 @@ CreateHashEntry( if (typePtr->allocEntryProc) { hPtr = typePtr->allocEntryProc(tablePtr, (void *) key); } else { - hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry)); + hPtr = (Tcl_HashEntry *)Tcl_Alloc(sizeof(Tcl_HashEntry)); hPtr->key.oneWordValue = (char *) key; Tcl_SetHashValue(hPtr, NULL); } hPtr->tablePtr = tablePtr; - hPtr->hash = UINT2PTR(hash); + hPtr->hash = hash; hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; tablePtr->numEntries++; @@ -395,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; @@ -412,9 +386,9 @@ Tcl_DeleteHashEntry( if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, PTR2UINT(entryPtr->hash)); + index = RANDOM_INDEX(tablePtr, entryPtr->hash); } else { - index = PTR2UINT(entryPtr->hash) & tablePtr->mask; + index = entryPtr->hash & tablePtr->mask; } bucketPtr = &tablePtr->buckets[index]; @@ -437,7 +411,7 @@ Tcl_DeleteHashEntry( if (typePtr->freeEntryProc) { typePtr->freeEntryProc(entryPtr); } else { - ckfree(entryPtr); + Tcl_Free(entryPtr); } } @@ -464,7 +438,7 @@ Tcl_DeleteHashTable( { Tcl_HashEntry *hPtr, *nextPtr; const Tcl_HashKeyType *typePtr; - int i; + Tcl_Size i; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; @@ -488,7 +462,7 @@ Tcl_DeleteHashTable( if (typePtr->freeEntryProc) { typePtr->freeEntryProc(hPtr); } else { - ckfree(hPtr); + Tcl_Free(hPtr); } hPtr = nextPtr; } @@ -502,7 +476,7 @@ Tcl_DeleteHashTable( if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { TclpSysFree((char *) tablePtr->buckets); } else { - ckfree(tablePtr->buckets); + Tcl_Free(tablePtr->buckets); } } @@ -613,8 +587,8 @@ Tcl_HashStats( Tcl_HashTable *tablePtr) /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 - int i; - TCL_HASH_TYPE count[NUM_COUNTERS], overflow, j; + Tcl_Size i; + size_t count[NUM_COUNTERS], overflow, j; double average, tmp; Tcl_HashEntry *hPtr; char *result, *p; @@ -648,16 +622,16 @@ Tcl_HashStats( * Print out the histogram and a few other pieces of information. */ - result = (char *)ckalloc((NUM_COUNTERS * 60) + 300); - snprintf(result, 60, "%u entries in table, %u buckets\n", + result = (char *)Tcl_Alloc((NUM_COUNTERS * 60) + 300); + snprintf(result, 60, "%" TCL_Z_MODIFIER "u entries in table, %" TCL_Z_MODIFIER "u buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); for (i = 0; i < NUM_COUNTERS; i++) { - snprintf(p, 60, "number of buckets with %u entries: %u\n", + snprintf(p, 60, "number of buckets with %" TCL_Z_MODIFIER "u entries: %" TCL_Z_MODIFIER "u\n", i, count[i]); p += strlen(p); } - snprintf(p, 60, "number of buckets with %u or more entries: %u\n", + snprintf(p, 60, "number of buckets with %d or more entries: %" TCL_Z_MODIFIER "u\n", NUM_COUNTERS, overflow); p += strlen(p); snprintf(p, 60, "average search distance for entry: %.1f", average); @@ -686,13 +660,13 @@ 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); } - hPtr = (Tcl_HashEntry *)ckalloc(size); + hPtr = (Tcl_HashEntry *)Tcl_Alloc(size); memcpy(hPtr->key.string, keyPtr, count); Tcl_SetHashValue(hPtr, NULL); @@ -745,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; @@ -790,7 +764,7 @@ AllocStringEntry( if (size < sizeof(hPtr->key)) { allocsize = sizeof(hPtr->key); } - hPtr = (Tcl_HashEntry *)ckalloc(offsetof(Tcl_HashEntry, key) + allocsize); + hPtr = (Tcl_HashEntry *)Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize); memset(hPtr, 0, offsetof(Tcl_HashEntry, key) + allocsize); memcpy(hPtr->key.string, string, size); Tcl_SetHashValue(hPtr, NULL); @@ -839,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; /* @@ -963,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; @@ -994,10 +968,10 @@ RebuildTable( tablePtr->numBuckets *= 4; if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { tablePtr->buckets = (Tcl_HashEntry **)TclpSysAlloc( - tablePtr->numBuckets * sizeof(Tcl_HashEntry *), 0); + tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); } else { tablePtr->buckets = - (Tcl_HashEntry **)ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); + (Tcl_HashEntry **)Tcl_Alloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); } for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; count > 0; count--, newChainPtr++) { @@ -1018,9 +992,9 @@ RebuildTable( *oldChainPtr = hPtr->nextPtr; if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, PTR2UINT(hPtr->hash)); + index = RANDOM_INDEX(tablePtr, hPtr->hash); } else { - index = PTR2UINT(hPtr->hash) & tablePtr->mask; + index = hPtr->hash & tablePtr->mask; } hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; @@ -1035,7 +1009,7 @@ RebuildTable( if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { TclpSysFree((char *) oldBuckets); } else { - ckfree(oldBuckets); + Tcl_Free(oldBuckets); } } } diff --git a/generic/tclHistory.c b/generic/tclHistory.c index f7d9ec8..dc5a67d 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -58,9 +58,8 @@ Tcl_RecordAndEval( const char *cmd, /* Command to record. */ int flags) /* Additional flags. TCL_NO_EVAL means only * record: don't execute command. - * TCL_EVAL_GLOBAL means evaluate the script - * in global variable context instead of the - * current procedure. */ + * TCL_EVAL_GLOBAL means use Tcl_GlobalEval + * instead of Tcl_Eval. */ { Tcl_Obj *cmdPtr; int result; @@ -75,13 +74,6 @@ Tcl_RecordAndEval( result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); /* - * Move the interpreter's object result to the string result, then - * reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - - /* * Discard the Tcl object created to hold the command. */ @@ -138,7 +130,7 @@ Tcl_RecordAndEvalObj( */ if (histObjsPtr == NULL) { - histObjsPtr = (HistoryObjs *)ckalloc(sizeof(HistoryObjs)); + histObjsPtr = (HistoryObjs *)Tcl_Alloc(sizeof(HistoryObjs)); TclNewLiteralStringObj(histObjsPtr->historyObj, "::history"); TclNewLiteralStringObj(histObjsPtr->addObj, "add"); Tcl_IncrRefCount(histObjsPtr->historyObj); @@ -211,14 +203,14 @@ Tcl_RecordAndEvalObj( static void DeleteHistoryObjs( - ClientData clientData, + void *clientData, TCL_UNUSED(Tcl_Interp *)) { HistoryObjs *histObjsPtr = (HistoryObjs *)clientData; TclDecrRefCount(histObjsPtr->historyObj); TclDecrRefCount(histObjsPtr->addObj); - ckfree(histObjsPtr); + Tcl_Free(histObjsPtr); } /* diff --git a/generic/tclIO.c b/generic/tclIO.c index 3b36457..b480377 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -174,6 +174,8 @@ static int CloseWrite(Tcl_Interp *interp, Channel *chanPtr); static void CommonGetsCleanup(Channel *chanPtr); static int CopyData(CopyState *csPtr, int mask); static void DeleteTimerHandler(ChannelState *statePtr); +int Lossless(ChannelState *inStatePtr, + ChannelState *outStatePtr, long long toRead); static int MoveBytes(CopyState *csPtr); static void MBCallback(CopyState *csPtr, Tcl_Obj *errObj); @@ -203,7 +205,7 @@ static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr, int calledFromAsyncFlush); static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr); static Tcl_Encoding GetBinaryEncoding(void); -static Tcl_ExitProc FreeBinaryEncoding; +static void FreeBinaryEncoding(void); static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp); static int GetInput(Channel *chanPtr); static void PeekAhead(Channel *chanPtr, char **dstEndPtr, @@ -334,9 +336,13 @@ static const Tcl_ObjType chanObjType = { FreeChannelInternalRep, /* freeIntRepProc */ DupChannelInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; +#define GetIso88591() \ + (binaryEncoding ? Tcl_GetEncoding(NULL, "iso8859-1") : binaryEncoding) + #define ChanSetInternalRep(objPtr, resPtr) \ do { \ Tcl_ObjInternalRep ir; \ @@ -376,11 +382,6 @@ ChanClose( Channel *chanPtr, Tcl_Interp *interp) { -#ifndef TCL_NO_DEPRECATED - if ((chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) && (chanPtr->typePtr->closeProc != NULL)) { - return chanPtr->typePtr->closeProc(chanPtr->instanceData, interp); - } -#endif return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, 0); } @@ -432,7 +433,7 @@ ChanRead( } ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; - if (WillRead(chanPtr) < 0) { + if (WillRead(chanPtr) == -1) { return -1; } @@ -448,7 +449,7 @@ ChanRead( } ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; - if (bytesRead < 0) { + if (bytesRead == -1) { if ((result == EWOULDBLOCK) || (result == EAGAIN)) { SetFlag(chanPtr->state, CHANNEL_BLOCKED); result = EAGAIN; @@ -485,18 +486,8 @@ ChanSeek( */ if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) { -#ifndef TCL_NO_DEPRECATED - if (offset<LONG_MIN || offset>LONG_MAX) { - *errnoPtr = EOVERFLOW; - return TCL_INDEX_NONE; - } - - return Tcl_ChannelSeekProc(chanPtr->typePtr)(chanPtr->instanceData, - offset, mode, errnoPtr); -#else *errnoPtr = EINVAL; return TCL_INDEX_NONE; -#endif } return Tcl_ChannelWideSeekProc(chanPtr->typePtr)(chanPtr->instanceData, @@ -675,7 +666,7 @@ TclFinalizeIOSubsystem(void) * interpreter will close the channel when it gets destroyed. */ - (void) Tcl_Close(NULL, (Tcl_Channel) chanPtr); + (void) Tcl_CloseEx(NULL, (Tcl_Channel) chanPtr, 0); } else { /* * The refcount is greater than zero, so flush the channel. @@ -704,6 +695,7 @@ TclFinalizeIOSubsystem(void) } } + FreeBinaryEncoding(); TclpFinalizeSockets(); TclpFinalizePipes(); } @@ -745,6 +737,10 @@ Tcl_SetStdChannel( case TCL_STDERR: tsdPtr->stderrInitialized = init; tsdPtr->stderrChannel = channel; + if (channel) { + ENCODING_PROFILE_SET(((Channel *)channel)->state->inputEncodingFlags, TCL_ENCODING_PROFILE_REPLACE); + ENCODING_PROFILE_SET(((Channel *)channel)->state->outputEncodingFlags, TCL_ENCODING_PROFILE_REPLACE); + } break; } } @@ -815,6 +811,8 @@ Tcl_GetStdChannel( tsdPtr->stderrInitialized = -1; tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); if (tsdPtr->stderrChannel != NULL) { + ENCODING_PROFILE_SET(((Channel *)tsdPtr->stderrChannel)->state->inputEncodingFlags, TCL_ENCODING_PROFILE_REPLACE); + ENCODING_PROFILE_SET(((Channel *)tsdPtr->stderrChannel)->state->outputEncodingFlags, TCL_ENCODING_PROFILE_REPLACE); tsdPtr->stderrInitialized = 1; Tcl_RegisterChannel(NULL, tsdPtr->stderrChannel); } @@ -855,7 +853,7 @@ Tcl_CreateCloseHandler( ChannelState *statePtr = ((Channel *) chan)->state; CloseCallback *cbPtr; - cbPtr = (CloseCallback *)ckalloc(sizeof(CloseCallback)); + cbPtr = (CloseCallback *)Tcl_Alloc(sizeof(CloseCallback)); cbPtr->proc = proc; cbPtr->clientData = clientData; @@ -901,7 +899,7 @@ Tcl_DeleteCloseHandler( } else { cbPrevPtr->nextPtr = cbPtr->nextPtr; } - ckfree(cbPtr); + Tcl_Free(cbPtr); break; } cbPrevPtr = cbPtr; @@ -936,7 +934,7 @@ GetChannelTable( hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL); if (hTblPtr == NULL) { - hTblPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + hTblPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); Tcl_SetAssocData(interp, "tclIO", (Tcl_InterpDeleteProc *) DeleteChannelTable, hTblPtr); @@ -1028,7 +1026,7 @@ DeleteChannelTable( TclChannelEventScriptInvoker, sPtr); TclDecrRefCount(sPtr->scriptPtr); - ckfree(sPtr); + Tcl_Free(sPtr); } else { prevPtr = sPtr; } @@ -1045,13 +1043,13 @@ DeleteChannelTable( statePtr->epoch++; if (statePtr->refCount-- <= 1) { if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { - (void) Tcl_Close(interp, (Tcl_Channel) chanPtr); + (void) Tcl_CloseEx(interp, (Tcl_Channel) chanPtr, 0); } } } Tcl_DeleteHashTable(hTblPtr); - ckfree(hTblPtr); + Tcl_Free(hTblPtr); } /* @@ -1268,11 +1266,11 @@ Tcl_UnregisterChannel( Tcl_Preserve(statePtr); if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { /* - * We don't want to re-enter Tcl_Close(). + * We don't want to re-enter Tcl_CloseEx(). */ if (!GotFlag(statePtr, CHANNEL_CLOSED)) { - if (Tcl_Close(interp, chan) != TCL_OK) { + if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { SetFlag(statePtr, CHANNEL_CLOSED); Tcl_Release(statePtr); return TCL_ERROR; @@ -1558,15 +1556,15 @@ TclGetChannelFromObj( * Re-use the ResolvedCmdName struct. */ - Tcl_Release((void *) resPtr->statePtr); + Tcl_Release(resPtr->statePtr); } else { - resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName)); + resPtr = (ResolvedChanName *) Tcl_Alloc(sizeof(ResolvedChanName)); resPtr->refCount = 0; ChanSetInternalRep(objPtr, resPtr); /* Overwrites, if needed */ } statePtr = ((Channel *)chan)->state; resPtr->statePtr = statePtr; - Tcl_Preserve((void *) statePtr); + Tcl_Preserve(statePtr); resPtr->interp = interp; resPtr->epoch = statePtr->epoch; @@ -1623,18 +1621,12 @@ Tcl_CreateChannel( assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc *)); assert(typePtr->typeName != NULL); -#ifndef TCL_NO_DEPRECATED - if (((NULL == typePtr->closeProc) || (TCL_CLOSE2PROC == typePtr->closeProc)) && (typePtr->close2Proc == NULL)) { - Tcl_Panic("channel type %s must define closeProc or close2Proc", typePtr->typeName); - } -#else - if (Tcl_ChannelVersion(typePtr) < TCL_CHANNEL_VERSION_5) { + if (Tcl_ChannelVersion(typePtr) != TCL_CHANNEL_VERSION_5) { Tcl_Panic("channel type %s must be version TCL_CHANNEL_VERSION_5", typePtr->typeName); } if (typePtr->close2Proc == NULL) { Tcl_Panic("channel type %s must define close2Proc", typePtr->typeName); } -#endif if ((TCL_READABLE & mask) && (NULL == typePtr->inputProc)) { Tcl_Panic("channel type %s must define inputProc when used for reader channel", typePtr->typeName); } @@ -1644,19 +1636,14 @@ Tcl_CreateChannel( if (NULL == typePtr->watchProc) { Tcl_Panic("channel type %s must define watchProc", typePtr->typeName); } -#ifndef TCL_NO_DEPRECATED - if ((NULL != typePtr->wideSeekProc) && (NULL == typePtr->seekProc)) { - Tcl_Panic("channel type %s must define seekProc if defining wideSeekProc", typePtr->typeName); - } -#endif /* * JH: We could subsequently memset these to 0 to avoid the numerous * assignments to 0/NULL below. */ - chanPtr = (Channel *)ckalloc(sizeof(Channel)); - statePtr = (ChannelState *)ckalloc(sizeof(ChannelState)); + chanPtr = (Channel *)Tcl_Alloc(sizeof(Channel)); + statePtr = (ChannelState *)Tcl_Alloc(sizeof(ChannelState)); chanPtr->state = statePtr; chanPtr->instanceData = instanceData; @@ -1675,10 +1662,10 @@ Tcl_CreateChannel( * later. */ - tmp = (char *)ckalloc((len < 7) ? 7 : len); + tmp = (char *)Tcl_Alloc((len < 7) ? 7 : len); strcpy(tmp, chanName); } else { - tmp = (char *)ckalloc(7); + tmp = (char *)Tcl_Alloc(7); tmp[0] = '\0'; } statePtr->channelName = tmp; @@ -1695,19 +1682,12 @@ Tcl_CreateChannel( * interpretation that Tcl_Channels give to the "-encoding binary" option. */ - statePtr->encoding = NULL; name = Tcl_GetEncodingName(NULL); - if (strcmp(name, "binary") != 0) { - statePtr->encoding = Tcl_GetEncoding(NULL, name); - } + statePtr->encoding = Tcl_GetEncoding(NULL, name); statePtr->inputEncodingState = NULL; statePtr->inputEncodingFlags = TCL_ENCODING_START; - ENCODING_PROFILE_SET(statePtr->inputEncodingFlags, - TCL_ENCODING_PROFILE_TCL8); statePtr->outputEncodingState = NULL; statePtr->outputEncodingFlags = TCL_ENCODING_START; - ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, - TCL_ENCODING_PROFILE_TCL8); /* * Set the channel up initially in AUTO input translation mode to accept @@ -1720,7 +1700,6 @@ Tcl_CreateChannel( statePtr->inputTranslation = TCL_TRANSLATE_AUTO; statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; statePtr->inEofChar = 0; - statePtr->outEofChar = 0; statePtr->unreportedError = 0; statePtr->refCount = 0; @@ -1957,7 +1936,7 @@ Tcl_StackChannel( statePtr->inQueueTail = NULL; } - chanPtr = (Channel *)ckalloc(sizeof(Channel)); + chanPtr = (Channel *)Tcl_Alloc(sizeof(Channel)); /* * Save some of the current state into the new structure, reinitialize the @@ -2019,7 +1998,7 @@ TclChannelRelease( return; } if (chanPtr->typePtr == NULL) { - ckfree(chanPtr); + Tcl_Free(chanPtr); } } @@ -2028,7 +2007,7 @@ ChannelFree( Channel *chanPtr) { if (chanPtr->refCount == 0) { - ckfree(chanPtr); + Tcl_Free(chanPtr); return; } chanPtr->typePtr = NULL; @@ -2203,7 +2182,7 @@ Tcl_UnstackChannel( */ if (statePtr->refCount <= 0) { - if (Tcl_Close(interp, chan) != TCL_OK) { + if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { /* * TIP #219, Tcl Channel Reflection API. * "TclChanCaughtErrorBypass" is not required here, it was @@ -2537,7 +2516,7 @@ AllocChannelBuffer( Tcl_Size n; n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING; - bufPtr = (ChannelBuffer *)ckalloc(n); + bufPtr = (ChannelBuffer *)Tcl_Alloc(n); bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextRemoved = BUFFER_PADDING; bufPtr->bufLength = length + BUFFER_PADDING; @@ -2563,7 +2542,7 @@ ReleaseChannelBuffer( if (--bufPtr->refCount) { return; } - ckfree(bufPtr); + Tcl_Free(bufPtr); } static int @@ -3110,18 +3089,6 @@ CloseChannel( } /* - * If the EOF character is set in the channel, append that to the output - * device. - */ - - if ((statePtr->outEofChar != 0) && GotFlag(statePtr, TCL_WRITABLE)) { - int dummy; - char c = (char) statePtr->outEofChar; - - (void) ChanWrite(chanPtr, &c, 1, &dummy); - } - - /* * TIP #219, Tcl Channel Reflection API. * Move a leftover error message in the channel bypass into the * interpreter bypass. Just clear it if there is no interpreter. @@ -3155,7 +3122,7 @@ CloseChannel( if (chanPtr == statePtr->bottomChanPtr) { if (statePtr->channelName != NULL) { - ckfree(statePtr->channelName); + Tcl_Free(statePtr->channelName); statePtr->channelName = NULL; } @@ -3212,7 +3179,7 @@ CloseChannel( ChannelFree(chanPtr); - return Tcl_Close(interp, (Tcl_Channel) downChanPtr); + return Tcl_CloseEx(interp, (Tcl_Channel) downChanPtr, 0); } /* @@ -3456,7 +3423,7 @@ Tcl_SpliceChannel( */ int -Tcl_Close( +TclClose( Tcl_Interp *interp, /* Interpreter for errors. */ Tcl_Channel chan) /* The channel being closed. Must not be * referenced in any interpreter. May be NULL, @@ -3513,7 +3480,8 @@ Tcl_Close( stickyError = 0; - if (GotFlag(statePtr, TCL_WRITABLE) && (statePtr->encoding != NULL) + if (GotFlag(statePtr, TCL_WRITABLE) + && (statePtr->encoding != GetBinaryEncoding()) && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)) { int code = CheckChannelErrors(statePtr, TCL_WRITABLE); @@ -3557,7 +3525,7 @@ Tcl_Close( cbPtr = statePtr->closeCbPtr; statePtr->closeCbPtr = cbPtr->nextPtr; cbPtr->proc(cbPtr->clientData); - ckfree(cbPtr); + Tcl_Free(cbPtr); } ResetFlag(statePtr, CHANNEL_INCLOSE); @@ -3567,20 +3535,10 @@ Tcl_Close( * it anymore and this will help avoid deadlocks on some channel types. */ -#ifndef TCL_NO_DEPRECATED - if ((chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) || (chanPtr->typePtr->closeProc == NULL)) { - /* If this half-close gives a EINVAL or ENOTCONN, just continue the full close */ - result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ); - if ((result == EINVAL) || result == ENOTCONN) { - result = 0; - } - } -#else result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ); if ((result == EINVAL) || result == ENOTCONN) { result = 0; } -#endif /* * The call to FlushChannel will flush any queued output and invoke the @@ -3628,7 +3586,7 @@ Tcl_Close( result = flushcode; } if ((result != 0) && (result != TCL_ERROR) && (interp != NULL) - && 0 == TclGetCharLength(Tcl_GetObjResult(interp))) { + && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) { Tcl_SetErrno(result); Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp), -1)); @@ -3677,7 +3635,7 @@ Tcl_CloseEx( statePtr = chanPtr->state; if ((flags & (TCL_READABLE | TCL_WRITABLE)) == 0) { - return Tcl_Close(interp, chan); + return TclClose(interp, chan); } if ((flags & (TCL_READABLE | TCL_WRITABLE)) == (TCL_READABLE | TCL_WRITABLE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3896,18 +3854,6 @@ CloseChannelPart( } /* - * If the EOF character is set in the channel, append that to the - * output device. - */ - - if ((statePtr->outEofChar != 0) && GotFlag(statePtr, TCL_WRITABLE)) { - int dummy; - char c = (char) statePtr->outEofChar; - - (void) ChanWrite(chanPtr, &c, 1, &dummy); - } - - /* * TIP #219, Tcl Channel Reflection API. * Move a leftover error message in the channel bypass into the * interpreter bypass. Just clear it if there is no interpreter. @@ -4043,7 +3989,7 @@ Tcl_ClearChannelHandlers( for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chNext) { chNext = chPtr->nextPtr; - ckfree(chPtr); + Tcl_Free(chPtr); } statePtr->chPtr = NULL; @@ -4070,7 +4016,7 @@ Tcl_ClearChannelHandlers( for (ePtr = statePtr->scriptRecordPtr; ePtr != NULL; ePtr = eNextPtr) { eNextPtr = ePtr->nextPtr; TclDecrRefCount(ePtr->scriptPtr); - ckfree(ePtr); + Tcl_Free(ePtr); } statePtr->scriptRecordPtr = NULL; } @@ -4103,7 +4049,7 @@ Tcl_Size Tcl_Write( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* Data to queue in output buffer. */ - Tcl_Size srcLen) /* Length of data in bytes, or < 0 for + Tcl_Size srcLen) /* Length of data in bytes, or TCL_INDEX_NONE for * strlen(). */ { /* @@ -4120,10 +4066,10 @@ Tcl_Write( return TCL_INDEX_NONE; } - if (srcLen < 0) { + if (srcLen == TCL_INDEX_NONE) { srcLen = strlen(src); } - if (WriteBytes(chanPtr, src, srcLen) < 0) { + if (WriteBytes(chanPtr, src, srcLen) == -1) { return TCL_INDEX_NONE; } return srcLen; @@ -4170,7 +4116,7 @@ Tcl_WriteRaw( return TCL_INDEX_NONE; } - if (srcLen < 0) { + if (srcLen == TCL_INDEX_NONE) { srcLen = strlen(src); } @@ -4180,7 +4126,7 @@ Tcl_WriteRaw( */ written = ChanWrite(chanPtr, src, srcLen, &errorCode); - if (written < 0) { + if (written == TCL_INDEX_NONE) { Tcl_SetErrno(errorCode); } @@ -4229,7 +4175,7 @@ Tcl_WriteChars( chanPtr = statePtr->topChanPtr; - if (len < 0) { + if (len == TCL_INDEX_NONE) { len = strlen(src); } if (statePtr->encoding) { @@ -4248,8 +4194,13 @@ Tcl_WriteChars( } objPtr = Tcl_NewStringObj(src, len); - src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); - result = WriteBytes(chanPtr, src, len); + src = (char *) Tcl_GetBytesFromObj(NULL, objPtr, &len); + if (src == NULL) { + Tcl_SetErrno(EILSEQ); + result = TCL_INDEX_NONE; + } else { + result = WriteBytes(chanPtr, src, len); + } TclDecrRefCount(objPtr); return result; } @@ -4291,7 +4242,7 @@ Tcl_WriteObj( Channel *chanPtr; ChannelState *statePtr; /* State info for channel */ const char *src; - Tcl_Size srcLen; + Tcl_Size srcLen = 0; statePtr = ((Channel *) chan)->state; chanPtr = statePtr->topChanPtr; @@ -4300,10 +4251,18 @@ Tcl_WriteObj( return TCL_INDEX_NONE; } if (statePtr->encoding == NULL) { - src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen); - return WriteBytes(chanPtr, src, srcLen); + Tcl_Size result; + + src = (char *) Tcl_GetBytesFromObj(NULL, objPtr, &srcLen); + if (src == NULL) { + Tcl_SetErrno(EILSEQ); + result = TCL_INDEX_NONE; + } else { + result = WriteBytes(chanPtr, src, srcLen); + } + return result; } else { - src = TclGetStringFromObj(objPtr, &srcLen); + src = Tcl_GetStringFromObj(objPtr, &srcLen); return WriteChars(chanPtr, src, srcLen); } } @@ -4315,9 +4274,6 @@ WillWrite( int inputBuffered; if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) -#ifndef TCL_NO_DEPRECATED - || (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL) -#endif ) && ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){ int ignore; @@ -4340,9 +4296,6 @@ WillRead( return -1; } if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) -#ifndef TCL_NO_DEPRECATED - || (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL) -#endif ) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { /* * CAVEAT - The assumption here is that FlushChannel() will push out @@ -4393,7 +4346,7 @@ Write( /* State info for channel */ char *nextNewLine = NULL; int endEncoding, needNlFlush = 0; - int saved = 0, total = 0, flushed = 0; + Tcl_Size saved = 0, total = 0, flushed = 0; char safe[BUFFER_PADDING]; int encodingError = 0; @@ -4459,16 +4412,14 @@ Write( * current output encoding and strict encoding is active. */ - if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) { - encodingError = 1; - result = TCL_OK; - } - - if ((result != TCL_OK) && (srcRead + dstWrote == 0)) { + if ( + (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) + || /* * We're reading from invalid/incomplete UTF-8. */ - + ((result != TCL_OK) && (srcRead + dstWrote == 0)) + ) { encodingError = 1; result = TCL_OK; } @@ -4686,9 +4637,10 @@ Tcl_GetsObj( * done on objPtr. */ - if ((statePtr->encoding == NULL) + if (statePtr->encoding == GetBinaryEncoding() && ((statePtr->inputTranslation == TCL_TRANSLATE_LF) - || (statePtr->inputTranslation == TCL_TRANSLATE_CR))) { + || (statePtr->inputTranslation == TCL_TRANSLATE_CR)) + && Tcl_GetBytesFromObj(NULL, objPtr, (Tcl_Size *)NULL) != NULL) { return TclGetsObjBinary(chan, objPtr); } @@ -4707,7 +4659,7 @@ Tcl_GetsObj( * newline in the available input. */ - TclGetStringFromObj(objPtr, &oldLength); + (void)Tcl_GetStringFromObj(objPtr, &oldLength); oldFlags = statePtr->inputEncodingFlags; oldState = statePtr->inputEncodingState; oldRemoved = BUFFER_PADDING; @@ -4716,15 +4668,6 @@ Tcl_GetsObj( } /* - * If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't - * produce ByteArray objects. - */ - - if (encoding == NULL) { - encoding = GetBinaryEncoding(); - } - - /* * Object used by FilterInputBytes to keep track of how much data has been * consumed from the channel buffers. */ @@ -5108,7 +5051,7 @@ TclGetsObjBinary( /* State info for channel */ ChannelBuffer *bufPtr; int inEofChar, skip, copiedTotal, oldFlags, oldRemoved; - Tcl_Size rawLen, byteLen, oldLength; + Tcl_Size rawLen, byteLen = 0, oldLength; int eolChar; unsigned char *dst, *dstEnd, *eol, *eof, *byteArray; @@ -5126,7 +5069,11 @@ TclGetsObjBinary( * newline in the available input. */ - byteArray = Tcl_GetByteArrayFromObj(objPtr, &byteLen); + byteArray = Tcl_GetBytesFromObj(NULL, objPtr, &byteLen); + if (byteArray == NULL) { + Tcl_SetErrno(EILSEQ); + return -1; + } oldFlags = statePtr->inputEncodingFlags; oldRemoved = BUFFER_PADDING; oldLength = byteLen; @@ -5282,7 +5229,7 @@ TclGetsObjBinary( * XXX - unimplemented. */ - if (statePtr->encoding != NULL) { + if (statePtr->encoding != GetBinaryEncoding()) { } /* @@ -5360,8 +5307,7 @@ TclGetsObjBinary( */ static void -FreeBinaryEncoding( - TCL_UNUSED(void *)) +FreeBinaryEncoding(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -5378,7 +5324,6 @@ GetBinaryEncoding(void) if (tsdPtr->binaryEncoding == NULL) { tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); - Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL); } if (tsdPtr->binaryEncoding == NULL) { Tcl_Panic("binary encoding is not available"); @@ -5577,7 +5522,7 @@ FilterInputBytes( } extra = rawLen - gsPtr->rawRead; memcpy(nextPtr->buf + (BUFFER_PADDING - extra), - raw + gsPtr->rawRead, (size_t) extra); + raw + gsPtr->rawRead, extra); nextPtr->nextRemoved -= extra; bufPtr->nextAdded -= extra; } @@ -5825,8 +5770,8 @@ Tcl_ReadRaw( while (chanPtr->inQueueHead && bytesToRead > 0) { ChannelBuffer *bufPtr = chanPtr->inQueueHead; int bytesInBuffer = BytesLeft(bufPtr); - int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer - : bytesToRead; + int toCopy = (bytesInBuffer < (int)bytesToRead) ? bytesInBuffer + : (int)bytesToRead; /* * Copy the current chunk into the read buffer. @@ -5869,7 +5814,7 @@ Tcl_ReadRaw( if (bytesToRead > 0) { int nread = ChanRead(chanPtr, readBuf, bytesToRead); - if (nread < 0) { + if (nread == -1) { /* * An error signaled. If CHANNEL_BLOCKED, then the error is not * real, but an indication of blocked state. In that case, retain @@ -6044,12 +5989,12 @@ DoReadChars( chanPtr = statePtr->topChanPtr; TclChannelPreserve((Tcl_Channel)chanPtr); - binaryMode = (encoding == NULL) + binaryMode = (encoding == GetBinaryEncoding()) && (statePtr->inputTranslation == TCL_TRANSLATE_LF) && (statePtr->inEofChar == '\0'); if (appendFlag) { - if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, NULL))) { + if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, (Tcl_Size *)NULL))) { binaryMode = 0; } } else { @@ -6057,16 +6002,6 @@ DoReadChars( Tcl_SetByteArrayLength(objPtr, 0); } else { Tcl_SetObjLength(objPtr, 0); - - /* - * We're going to access objPtr->bytes directly, so we must ensure - * that this is actually a string object (otherwise it might have - * been pure Unicode). - * - * Probably not needed anymore. - */ - - TclGetString(objPtr); } } @@ -6139,7 +6074,9 @@ DoReadChars( } } else { copied += copiedNow; - toRead -= copiedNow; + if (toRead != TCL_INDEX_NONE) { + toRead -= copiedNow; /* Only decr if not reading whole file */ + } } } @@ -6294,8 +6231,7 @@ ReadChars( * UTF-8. On output, contains another guess * based on the data seen so far. */ { - Tcl_Encoding encoding = statePtr->encoding? statePtr->encoding - : GetBinaryEncoding(); + Tcl_Encoding encoding = statePtr->encoding; Tcl_EncodingState savedState = statePtr->inputEncodingState; ChannelBuffer *bufPtr = statePtr->inQueueHead; int savedIEFlags = statePtr->inputEncodingFlags; @@ -6322,13 +6258,13 @@ ReadChars( int factor = *factorPtr; int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; - (void) TclGetStringFromObj(objPtr, &numBytes); + (void) Tcl_GetStringFromObj(objPtr, &numBytes); Tcl_AppendToObj(objPtr, NULL, dstLimit); if (toRead == srcLen) { - unsigned int size; + Tcl_Size size; dst = TclGetStringStorage(objPtr, &size) + numBytes; - dstLimit = size - numBytes; + dstLimit = (size - numBytes) > INT_MAX ? INT_MAX : (size - numBytes); } else { dst = TclGetString(objPtr) + numBytes; } @@ -6563,7 +6499,7 @@ ReadChars( * bytes demanded by the Tcl_ExternalToUtf() call! */ - dstLimit = TclUtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1); + dstLimit = Tcl_UtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1); statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; @@ -7134,7 +7070,7 @@ GetInput( bufPtr->nextPtr = NULL; toRead = SpaceLeft(bufPtr); - assert(toRead == statePtr->bufSize); + assert((Tcl_Size)toRead == statePtr->bufSize); if (statePtr->inQueueTail == NULL) { statePtr->inQueueHead = bufPtr; @@ -7225,9 +7161,6 @@ Tcl_Seek( */ if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) -#ifndef TCL_NO_DEPRECATED - && (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL) -#endif ) { Tcl_SetErrno(EINVAL); return -1; @@ -7393,9 +7326,6 @@ Tcl_Tell( */ if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) -#ifndef TCL_NO_DEPRECATED - && (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL) -#endif ) { Tcl_SetErrno(EINVAL); return -1; @@ -7482,7 +7412,7 @@ Tcl_TruncateChannel( WillWrite(chanPtr); - if (WillRead(chanPtr) < 0) { + if (WillRead(chanPtr) == -1) { return TCL_ERROR; } @@ -7940,7 +7870,7 @@ Tcl_BadChannelOption( Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]); Tcl_SetObjResult(interp, errObj); Tcl_DStringFree(&ds); - ckfree(argv); + Tcl_Free((void *)argv); } Tcl_SetErrno(EINVAL); return TCL_ERROR; @@ -8059,60 +7989,25 @@ Tcl_GetChannelOption( if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-encoding"); } - if (statePtr->encoding == NULL) { - Tcl_DStringAppendElement(dsPtr, "binary"); - } else { - Tcl_DStringAppendElement(dsPtr, - Tcl_GetEncodingName(statePtr->encoding)); - } + Tcl_DStringAppendElement(dsPtr, + Tcl_GetEncodingName(statePtr->encoding)); if (len > 0) { return TCL_OK; } } if (len == 0 || HaveOpt(2, "-eofchar")) { + char buf[4] = ""; if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-eofchar"); } - if (((flags & (TCL_READABLE|TCL_WRITABLE)) == - (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { - Tcl_DStringStartSublist(dsPtr); - } - if (flags & TCL_READABLE) { - if (statePtr->inEofChar == 0) { - Tcl_DStringAppendElement(dsPtr, ""); - } else { - char buf[2]; - - buf[1] = '\0'; - buf[0] = statePtr->inEofChar; - Tcl_DStringAppendElement(dsPtr, buf); - } - } - if (flags & TCL_WRITABLE) { - if (statePtr->outEofChar == 0) { - Tcl_DStringAppendElement(dsPtr, ""); - } else { - char buf[2]; - - buf[1] = '\0'; - buf[0] = statePtr->outEofChar; - Tcl_DStringAppendElement(dsPtr, buf); - } - } - if (!(flags & (TCL_READABLE|TCL_WRITABLE))) { - /* - * Not readable or writable (e.g. server socket) - */ - - Tcl_DStringAppendElement(dsPtr, ""); - } - if (((flags & (TCL_READABLE|TCL_WRITABLE)) == - (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { - Tcl_DStringEndSublist(dsPtr); + if ((flags & TCL_READABLE) && (statePtr->inEofChar != 0)) { + snprintf(buf, sizeof(buf), "%c", statePtr->inEofChar); } if (len > 0) { + Tcl_DStringAppend(dsPtr, buf, -1); return TCL_OK; } + Tcl_DStringAppendElement(dsPtr, buf); } if (len == 0 || HaveOpt(1, "-profile")) { int profile; @@ -8293,9 +8188,19 @@ Tcl_SetChannelOption( } return TCL_OK; } else if (HaveOpt(7, "-buffersize")) { - int newBufferSize; + Tcl_WideInt newBufferSize; + Tcl_Obj obj; + int code; + + obj.refCount = 1; + obj.bytes = (char *)newValue; + obj.length = strlen(newValue); + obj.typePtr = NULL; - if (Tcl_GetInt(interp, newValue, &newBufferSize) == TCL_ERROR) { + code = Tcl_GetWideIntFromObj(interp, &obj, &newBufferSize); + TclFreeInternalRep(&obj); + + if (code == TCL_ERROR) { return TCL_ERROR; } Tcl_SetChannelBufferSize(chan, newBufferSize); @@ -8305,7 +8210,7 @@ Tcl_SetChannelOption( int profile; if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) { - encoding = NULL; + encoding = Tcl_GetEncoding(NULL, "iso8859-1"); } else { encoding = Tcl_GetEncoding(interp, newValue); if (encoding == NULL) { @@ -8318,7 +8223,7 @@ Tcl_SetChannelOption( * iso2022, the terminated escape sequence must write to the buffer. */ - if ((statePtr->encoding != NULL) + if ((statePtr->encoding != GetBinaryEncoding()) && !(statePtr->outputEncodingFlags & TCL_ENCODING_START) && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; @@ -8337,46 +8242,25 @@ Tcl_SetChannelOption( UpdateInterest(chanPtr); return TCL_OK; } else if (HaveOpt(2, "-eofchar")) { - if (!newValue[0] || (!(newValue[0] & 0x80) && !newValue[1])) { + if (!newValue[0] || (!(newValue[0] & 0x80) && (!newValue[1] +#ifndef TCL_NO_DEPRECATED + || !strcmp(newValue+1, " {}") +#endif + ))) { if (GotFlag(statePtr, TCL_READABLE)) { statePtr->inEofChar = newValue[0]; } - statePtr->outEofChar = 0; - } else if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { - return TCL_ERROR; - } else if (argc == 0) { - statePtr->inEofChar = 0; - statePtr->outEofChar = 0; - } else if (argc == 1 || argc == 2) { - int inValue = (int) argv[0][0]; - int outValue = (argc == 2) ? (int) argv[1][0] : 0; - - if (inValue & 0x80 || outValue & 0x80) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -eofchar: must be non-NUL ASCII" - " character", TCL_INDEX_NONE)); - } - ckfree(argv); - return TCL_ERROR; - } - if (GotFlag(statePtr, TCL_READABLE)) { - statePtr->inEofChar = inValue; - } - if (GotFlag(statePtr, TCL_WRITABLE)) { - statePtr->outEofChar = outValue; - } } else { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -eofchar: should be a list of zero," - " one, or two elements", TCL_INDEX_NONE)); + "bad value for -eofchar: must be non-NUL ASCII" + " character", TCL_INDEX_NONE)); } - ckfree(argv); + Tcl_Free((void *)argv); return TCL_ERROR; } if (argv != NULL) { - ckfree(argv); + Tcl_Free((void *)argv); } /* @@ -8419,7 +8303,7 @@ Tcl_SetChannelOption( "bad value for -translation: must be a one or two" " element list", -1)); } - ckfree(argv); + Tcl_Free((void *)argv); return TCL_ERROR; } @@ -8434,7 +8318,7 @@ Tcl_SetChannelOption( translation = TCL_TRANSLATE_LF; statePtr->inEofChar = 0; Tcl_FreeEncoding(statePtr->encoding); - statePtr->encoding = NULL; + statePtr->encoding = Tcl_GetEncoding(NULL, "iso8859-1"); } else if (strcmp(readMode, "lf") == 0) { translation = TCL_TRANSLATE_LF; } else if (strcmp(readMode, "cr") == 0) { @@ -8449,7 +8333,7 @@ Tcl_SetChannelOption( "bad value for -translation: must be one of " "auto, binary, cr, lf, crlf, or platform", -1)); } - ckfree(argv); + Tcl_Free((void *)argv); return TCL_ERROR; } @@ -8481,10 +8365,9 @@ Tcl_SetChannelOption( statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; } } else if (strcmp(writeMode, "binary") == 0) { - statePtr->outEofChar = 0; statePtr->outputTranslation = TCL_TRANSLATE_LF; Tcl_FreeEncoding(statePtr->encoding); - statePtr->encoding = NULL; + statePtr->encoding = Tcl_GetEncoding(NULL, "iso8859-1"); } else if (strcmp(writeMode, "lf") == 0) { statePtr->outputTranslation = TCL_TRANSLATE_LF; } else if (strcmp(writeMode, "cr") == 0) { @@ -8499,11 +8382,11 @@ Tcl_SetChannelOption( "bad value for -translation: must be one of " "auto, binary, cr, lf, crlf, or platform", -1)); } - ckfree(argv); + Tcl_Free((void *)argv); return TCL_ERROR; } } - ckfree(argv); + Tcl_Free((void *)argv); return TCL_OK; } else if (chanPtr->typePtr->setOptionProc != NULL) { return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp, @@ -8562,7 +8445,7 @@ CleanupChannelHandlers( TclChannelEventScriptInvoker, sPtr); TclDecrRefCount(sPtr->scriptPtr); - ckfree(sPtr); + Tcl_Free(sPtr); } else { prevPtr = sPtr; } @@ -8986,7 +8869,7 @@ Tcl_CreateChannelHandler( } } if (chPtr == NULL) { - chPtr = (ChannelHandler *)ckalloc(sizeof(ChannelHandler)); + chPtr = (ChannelHandler *)Tcl_Alloc(sizeof(ChannelHandler)); chPtr->mask = 0; chPtr->proc = proc; chPtr->clientData = clientData; @@ -9090,7 +8973,7 @@ Tcl_DeleteChannelHandler( } else { prevChPtr->nextPtr = chPtr->nextPtr; } - ckfree(chPtr); + Tcl_Free(chPtr); /* * Recompute the interest list for the channel, so that infinite loops @@ -9149,7 +9032,7 @@ DeleteScriptRecord( TclChannelEventScriptInvoker, esPtr); TclDecrRefCount(esPtr->scriptPtr); - ckfree(esPtr); + Tcl_Free(esPtr); break; } @@ -9198,7 +9081,7 @@ CreateScriptRecord( makeCH = (esPtr == NULL); if (makeCH) { - esPtr = (EventScriptRecord *)ckalloc(sizeof(EventScriptRecord)); + esPtr = (EventScriptRecord *)Tcl_Alloc(sizeof(EventScriptRecord)); } /* @@ -9435,20 +9318,6 @@ ZeroTransferTimerProc( *---------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) -int -TclCopyChannelOld( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Channel inChan, /* Channel to read from. */ - Tcl_Channel outChan, /* Channel to write to. */ - int toRead, /* Amount of data to copy, or -1 for all. */ - Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */ -{ - return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead, - cmdPtr); -} -#endif - int TclCopyChannel( Tcl_Interp *interp, /* Current interpreter. */ @@ -9514,18 +9383,7 @@ TclCopyChannel( ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED); SetFlag(outStatePtr, CHANNEL_UNBUFFERED); - /* - * Test for conditions where we know we can just move bytes from input - * channel to output channel with no transformation or even examination - * of the bytes themselves. - */ - - moveBytes = inStatePtr->inEofChar == '\0' /* No eofChar to stop input */ - && inStatePtr->inputTranslation == TCL_TRANSLATE_LF - && outStatePtr->outputTranslation == TCL_TRANSLATE_LF - && inStatePtr->encoding == outStatePtr->encoding - && ENCODING_PROFILE_GET(inStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8 - && ENCODING_PROFILE_GET(outStatePtr->outputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8; + moveBytes = Lossless(inStatePtr, outStatePtr, toRead); /* * Allocate a new CopyState to maintain info about the current copy in @@ -9533,7 +9391,7 @@ TclCopyChannel( * completed. */ - csPtr = (CopyState *)ckalloc(offsetof(CopyState, buffer) + 1U + !moveBytes * inStatePtr->bufSize); + csPtr = (CopyState *)Tcl_Alloc(offsetof(CopyState, buffer) + 1U + !moveBytes * inStatePtr->bufSize); csPtr->bufSize = !moveBytes * inStatePtr->bufSize; csPtr->readPtr = inPtr; csPtr->writePtr = outPtr; @@ -9831,10 +9689,9 @@ CopyData( Tcl_Size sizeb; Tcl_Size sizePart; Tcl_WideInt total; - int size; + Tcl_WideInt size; const char *buffer; - int inBinary, outBinary, sameEncoding; - /* Encoding control */ + int moveBytes; int underflow; /* Input underflow */ inChan = (Tcl_Channel) csPtr->readPtr; @@ -9852,13 +9709,9 @@ CopyData( * the bottom of the stack. */ - inBinary = (inStatePtr->encoding == NULL); - outBinary = (outStatePtr->encoding == NULL); - sameEncoding = inStatePtr->encoding == outStatePtr->encoding - && ENCODING_PROFILE_GET(inStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8 - && ENCODING_PROFILE_GET(outStatePtr->outputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8; + moveBytes = Lossless(inStatePtr, outStatePtr, csPtr->toRead); - if (!(inBinary || sameEncoding)) { + if (!moveBytes) { TclNewObj(bufObj); Tcl_IncrRefCount(bufObj); } @@ -9899,17 +9752,17 @@ CopyData( underflow = 1; } else { /* - * Read up to bufSize bytes. + * Read up to bufSize characters. */ if ((csPtr->toRead == (Tcl_WideInt) -1) || (csPtr->toRead > (Tcl_WideInt) csPtr->bufSize)) { sizeb = csPtr->bufSize; } else { - sizeb = (int) csPtr->toRead; + sizeb = csPtr->toRead; } - if (inBinary || sameEncoding) { + if (moveBytes) { size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb, !GotFlag(inStatePtr, CHANNEL_NONBLOCKING)); } else { @@ -9993,25 +9846,20 @@ CopyData( * Now write the buffer out. */ - if (inBinary || sameEncoding) { + if (moveBytes) { buffer = csPtr->buffer; - sizeb = size; - } else { - buffer = TclGetStringFromObj(bufObj, &sizeb); - } - - if (outBinary || sameEncoding) { - sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, sizeb); + sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, size); } else { + buffer = Tcl_GetStringFromObj(bufObj, &sizeb); sizeb = WriteChars(outStatePtr->topChanPtr, buffer, sizeb); } /* * [Bug 2895565]. At this point 'size' still contains the number of - * bytes or characters which have been read. We keep this to later to + * characters which have been read. We keep this to later to * update the totals and toRead information, see marker (UP) below. We * must not overwrite it with 'sizeb', which is the number of written - * bytes or characters, and both EOL translation and encoding + * characters, and both EOL translation and encoding * conversion may have changed this number unpredictably in relation * to 'size' (It can be smaller or larger, in the latter case able to * drive toRead below -1, causing infinite looping). Completely @@ -10038,10 +9886,10 @@ CopyData( } /* - * Update the current byte count. Do it now so the count is valid + * Update the current character count. Do it now so the count is valid * before a return or break takes us out of the loop. The invariant at * the top of the loop should be that csPtr->toRead holds the number - * of bytes left to copy. + * of characters left to copy. */ if (csPtr->toRead != -1) { @@ -10108,8 +9956,8 @@ CopyData( } /* - * Make the callback or return the number of bytes transferred. The local - * total is used because StopCopy frees csPtr. + * Make the callback or return the number of characters transferred. The + * local total is used because StopCopy frees csPtr. */ total = csPtr->total; @@ -10192,8 +10040,6 @@ DoRead( ChannelState *statePtr = chanPtr->state; char *p = dst; - assert(bytesToRead >= 0); - /* * Early out when we know a read will get the eofchar. * @@ -10252,7 +10098,7 @@ DoRead( while (!bufPtr || /* We got no buffer! OR */ (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ - (BytesLeft(bufPtr) < bytesToRead))) { + ((Tcl_Size) BytesLeft(bufPtr) < bytesToRead))) { /* Not enough bytes in it yet * to fill the dst */ int code; @@ -10402,7 +10248,7 @@ DoRead( == (CHANNEL_EOF|CHANNEL_BLOCKED))); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); - return (int)(p - dst); + return (Tcl_Size)(p - dst); } /* @@ -10434,6 +10280,46 @@ CopyEventProc( /* *---------------------------------------------------------------------- * + * Lossless -- + * + * Determines whether copying characters between two channel states would + * be lossless, i.e. whether one byte corresponds to one character, every + * character appears in the Unicode character set, there are no + * translations to be performed, and no inline signals to respond to. + * + * Result: + * True if copying would be lossless. + * + *---------------------------------------------------------------------- + */ +int +Lossless( + ChannelState *inStatePtr, + ChannelState *outStatePtr, + long long toRead) +{ + return inStatePtr->inEofChar == '\0' /* No eofChar to stop input */ + && inStatePtr->inputTranslation == TCL_TRANSLATE_LF + && outStatePtr->outputTranslation == TCL_TRANSLATE_LF + && ( + ( + inStatePtr->encoding == GetBinaryEncoding() + && + outStatePtr->encoding == GetBinaryEncoding() + ) + || + ( + toRead == -1 + && inStatePtr->encoding == outStatePtr->encoding + && ENCODING_PROFILE_GET(inStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8 + && ENCODING_PROFILE_GET(outStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8 + ) + ); +} + +/* + *---------------------------------------------------------------------- + * * StopCopy -- * * This routine halts a copy that is in progress. @@ -10497,7 +10383,7 @@ StopCopy( } inStatePtr->csPtrR = NULL; outStatePtr->csPtrW = NULL; - ckfree(csPtr); + Tcl_Free(csPtr); } /* @@ -10895,16 +10781,6 @@ Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { -#ifndef TCL_NO_DEPRECATED - if ((chanTypePtr->version < TCL_CHANNEL_VERSION_2) - || (chanTypePtr->version > TCL_CHANNEL_VERSION_5)) { - /* - * In <v2 channel versions, the version field is occupied by the - * Tcl_DriverBlockModeProc - */ - return TCL_CHANNEL_VERSION_1; - } -#endif return chanTypePtr->version; } @@ -10928,46 +10804,12 @@ Tcl_ChannelBlockModeProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { -#ifndef TCL_NO_DEPRECATED - if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) { - /* - * The v1 structure had the blockModeProc in a different place. - */ - return (Tcl_DriverBlockModeProc *) chanTypePtr->version; - } -#endif return chanTypePtr->blockModeProc; } /* *---------------------------------------------------------------------- * - * Tcl_ChannelCloseProc -- - * - * Return the Tcl_DriverCloseProc of the channel type. - * - * Results: - * A pointer to the proc. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -Tcl_DriverCloseProc * -Tcl_ChannelCloseProc( - const Tcl_ChannelType *chanTypePtr) - /* Pointer to channel type. */ -{ - return chanTypePtr->closeProc; -} -#endif - -/* - *---------------------------------------------------------------------- - * * Tcl_ChannelClose2Proc -- * * Return the Tcl_DriverClose2Proc of the channel type. @@ -11040,32 +10882,6 @@ Tcl_ChannelOutputProc( /* *---------------------------------------------------------------------- * - * Tcl_ChannelSeekProc -- - * - * Return the Tcl_DriverSeekProc of the channel type. - * - * Results: - * A pointer to the proc. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -Tcl_DriverSeekProc * -Tcl_ChannelSeekProc( - const Tcl_ChannelType *chanTypePtr) - /* Pointer to channel type. */ -{ - return chanTypePtr->seekProc; -} -#endif - -/* - *---------------------------------------------------------------------- - * * Tcl_ChannelSetOptionProc -- * * Return the Tcl_DriverSetOptionProc of the channel type. @@ -11180,11 +10996,6 @@ Tcl_ChannelFlushProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { -#ifndef TCL_NO_DEPRECATED - if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) { - return NULL; - } -#endif return chanTypePtr->flushProc; } @@ -11209,11 +11020,6 @@ Tcl_ChannelHandlerProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { -#ifndef TCL_NO_DEPRECATED - if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) { - return NULL; - } -#endif return chanTypePtr->handlerProc; } @@ -11238,11 +11044,6 @@ Tcl_ChannelWideSeekProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { -#ifndef TCL_NO_DEPRECATED - if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_3) { - return NULL; - } -#endif return chanTypePtr->wideSeekProc; } @@ -11268,11 +11069,6 @@ Tcl_ChannelThreadActionProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { -#ifndef TCL_NO_DEPRECATED - if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_4) { - return NULL; - } -#endif return chanTypePtr->threadActionProc; } @@ -11455,7 +11251,7 @@ FixLevelCode( lcn += 2; } - lvn = (Tcl_Obj **)ckalloc(lcn * sizeof(Tcl_Obj *)); + lvn = (Tcl_Obj **)Tcl_Alloc(lcn * sizeof(Tcl_Obj *)); /* * New level/code information is spliced into the first occurrence of @@ -11508,7 +11304,7 @@ FixLevelCode( msg = Tcl_NewListObj(j, lvn); - ckfree(lvn); + Tcl_Free(lvn); return msg; } @@ -11590,9 +11386,6 @@ Tcl_ChannelTruncateProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_5) { - return NULL; - } return chanTypePtr->truncateProc; } @@ -11656,7 +11449,7 @@ FreeChannelInternalRep( return; } Tcl_Release(resPtr->statePtr); - ckfree(resPtr); + Tcl_Free(resPtr); } #if 0 diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 808ce97..92a84b2 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -10,6 +10,7 @@ */ #include "tclInt.h" +#include "tclTomMath.h" /* * Callback structure for accept callback in a TCP server. @@ -132,19 +133,6 @@ Tcl_PutsObjCmd( chanObjPtr = objv[2]; string = objv[3]; break; -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) { - /* - * The code below provides backwards compatibility with an old - * form of the command that is no longer recommended or - * documented. See also [Bug #3151675]. Will be removed in Tcl 9, - * maybe even earlier. - */ - - chanObjPtr = objv[1]; - string = objv[2]; - break; -#endif } /* Fall through */ default: /* [puts] or @@ -380,7 +368,7 @@ Tcl_ReadObjCmd( { Tcl_Channel chan; /* The channel to read from. */ int newline, i; /* Discard newline at end? */ - int toRead; /* How many bytes to read? */ + Tcl_WideInt toRead; /* How many bytes to read? */ Tcl_Size charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *resultPtr, *chanObjPtr; @@ -431,27 +419,13 @@ Tcl_ReadObjCmd( toRead = -1; if (i < objc) { - if ((TclGetIntFromObj(NULL, objv[i], &toRead) != TCL_OK) + if ((TclGetWideIntFromObj(NULL, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { -#if !defined(TCL_NO_DEPRECATED) - /* - * The code below provides backwards compatibility with an old - * form of the command that is no longer recommended or - * documented. See also [Bug #3151675]. Will be removed in Tcl 9, - * maybe even earlier. - */ - - if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { -#endif Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected non-negative integer but got \"%s\"", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (void *)NULL); return TCL_ERROR; -#if !defined(TCL_NO_DEPRECATED) - } - newline = 1; -#endif } } @@ -494,7 +468,7 @@ Tcl_ReadObjCmd( const char *result; Tcl_Size length; - result = TclGetStringFromObj(resultPtr, &length); + result = Tcl_GetStringFromObj(resultPtr, &length); if (result[length - 1] == '\n') { Tcl_SetObjLength(resultPtr, length - 1); } @@ -546,7 +520,7 @@ Tcl_SeekObjCmd( if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) { return TCL_ERROR; } mode = SEEK_SET; @@ -740,7 +714,7 @@ Tcl_CloseObjCmd( resultPtr = Tcl_DuplicateObj(resultPtr); Tcl_SetObjResult(interp, resultPtr); } - string = TclGetStringFromObj(resultPtr, &len); + string = Tcl_GetStringFromObj(resultPtr, &len); if ((len > 0) && (string[len - 1] == '\n')) { Tcl_SetObjLength(resultPtr, len - 1); } @@ -972,6 +946,11 @@ Tcl_ExecObjCmd( return TCL_ERROR; } + /* Bug [0f1ddc0df7] - encoding errors - use replace profile */ + if (Tcl_SetChannelOption(NULL, chan, "-profile", "replace") != TCL_OK) { + return TCL_ERROR; + } + if (background) { /* * Store the list of PIDs from the pipeline in interp's result and @@ -979,7 +958,7 @@ Tcl_ExecObjCmd( */ TclGetAndDetachPids(interp, chan); - if (Tcl_Close(interp, chan) != TCL_OK) { + if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { return TCL_ERROR; } return TCL_OK; @@ -1011,7 +990,7 @@ Tcl_ExecObjCmd( * string. */ - result = Tcl_Close(interp, chan); + result = Tcl_CloseEx(interp, chan, 0); Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); /* @@ -1020,7 +999,7 @@ Tcl_ExecObjCmd( */ if (keepNewline == 0) { - string = TclGetStringFromObj(resultPtr, &length); + string = Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && (string[length - 1] == '\n')) { Tcl_SetObjLength(resultPtr, length - 1); } @@ -1187,7 +1166,7 @@ Tcl_OpenObjCmd( Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } - ckfree(cmdArgv); + Tcl_Free((void *)cmdArgv); } if (chan == NULL) { return TCL_ERROR; @@ -1235,7 +1214,7 @@ TcpAcceptCallbacksDeleteProc( acceptCallbackPtr->interp = NULL; } Tcl_DeleteHashTable(hTblPtr); - ckfree(hTblPtr); + Tcl_Free(hTblPtr); } /* @@ -1275,7 +1254,7 @@ RegisterTcpServerInterpCleanup( hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); if (hTblPtr == NULL) { - hTblPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + hTblPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", TcpAcceptCallbacksDeleteProc, hTblPtr); @@ -1323,7 +1302,7 @@ UnregisterTcpServerInterpCleanupProc( return; } - hPtr = Tcl_FindHashEntry(hTblPtr, (char *)acceptCallbackPtr); + hPtr = Tcl_FindHashEntry(hTblPtr, acceptCallbackPtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } @@ -1412,7 +1391,7 @@ AcceptCallbackProc( * the client socket - just close it. */ - Tcl_Close(NULL, chan); + Tcl_CloseEx(NULL, chan, 0); } } @@ -1450,7 +1429,7 @@ TcpServerCloseProc( acceptCallbackPtr); } Tcl_DecrRefCount(acceptCallbackPtr->script); - ckfree(acceptCallbackPtr); + Tcl_Free(acceptCallbackPtr); } /* @@ -1484,8 +1463,8 @@ Tcl_SocketObjCmd( enum socketOptionsEnum { SKT_ASYNC, SKT_BACKLOG, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, SKT_SERVER - }; - int a, server = 0, myport = 0, async = 0, reusep = -1, optionIndex, + } optionIndex; + int a, server = 0, myport = 0, async = 0, reusep = -1, reusea = -1, backlog = -1; unsigned int flags = 0; const char *host, *port, *myaddr = NULL; @@ -1504,7 +1483,7 @@ Tcl_SocketObjCmd( TCL_EXACT, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum socketOptionsEnum) optionIndex) { + switch (optionIndex) { case SKT_ASYNC: if (server == 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -1655,7 +1634,7 @@ Tcl_SocketObjCmd( port = TclGetString(objv[a]); if (server) { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *)ckalloc(sizeof(AcceptCallback)); + AcceptCallback *acceptCallbackPtr = (AcceptCallback *)Tcl_Alloc(sizeof(AcceptCallback)); Tcl_IncrRefCount(script); acceptCallbackPtr->script = script; @@ -1665,7 +1644,7 @@ Tcl_SocketObjCmd( AcceptCallbackProc, acceptCallbackPtr); if (chan == NULL) { Tcl_DecrRefCount(script); - ckfree(acceptCallbackPtr); + Tcl_Free(acceptCallbackPtr); return TCL_ERROR; } @@ -1774,7 +1753,7 @@ Tcl_FcopyObjCmd( } switch (index) { case FcopySize: - if (Tcl_GetWideIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { return TCL_ERROR; } if (toRead < 0) { @@ -1825,8 +1804,8 @@ ChanPendingObjCmd( { Tcl_Channel chan; static const char *const options[] = {"input", "output", NULL}; - enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT}; - int mode, index; + enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT} index; + int mode; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); @@ -1842,7 +1821,7 @@ ChanPendingObjCmd( return TCL_ERROR; } - switch ((enum pendingOptionsEnum) index) { + switch (index) { case PENDING_INPUT: if (!(mode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); @@ -1901,7 +1880,7 @@ ChanTruncateObjCmd( * User is supplying an explicit length. */ - if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[2], &length) != TCL_OK) { return TCL_ERROR; } if (length < 0) { diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 93442a1..4ef4bb0 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -19,29 +19,25 @@ * the transformation. */ -static int TransformBlockModeProc(ClientData instanceData, +static int TransformBlockModeProc(void *instanceData, int mode); -static int TransformCloseProc(ClientData instanceData, +static int TransformCloseProc(void *instanceData, Tcl_Interp *interp, int flags); -static int TransformInputProc(ClientData instanceData, char *buf, +static int TransformInputProc(void *instanceData, char *buf, int toRead, int *errorCodePtr); -static int TransformOutputProc(ClientData instanceData, +static int TransformOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCodePtr); -#ifndef TCL_NO_DEPRECATED -static int TransformSeekProc(ClientData instanceData, long offset, - int mode, int *errorCodePtr); -#endif -static int TransformSetOptionProc(ClientData instanceData, +static int TransformSetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, const char *value); -static int TransformGetOptionProc(ClientData instanceData, +static int TransformGetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); -static void TransformWatchProc(ClientData instanceData, int mask); -static int TransformGetFileHandleProc(ClientData instanceData, - int direction, ClientData *handlePtr); -static int TransformNotifyProc(ClientData instanceData, int mask); -static long long TransformWideSeekProc(ClientData instanceData, +static void TransformWatchProc(void *instanceData, int mask); +static int TransformGetFileHandleProc(void *instanceData, + int direction, void **handlePtr); +static int TransformNotifyProc(void *instanceData, int mask); +static long long TransformWideSeekProc(void *instanceData, long long offset, int mode, int *errorCodePtr); /* @@ -49,7 +45,7 @@ static long long TransformWideSeekProc(ClientData instanceData, * handling and generating fileeevents. */ -static void TransformChannelHandlerTimer(ClientData clientData); +static void TransformChannelHandlerTimer(void *clientData); /* * Forward declarations of internal procedures. Third, helper procedures @@ -121,14 +117,10 @@ static inline void ResultAdd(ResultBuffer *r, unsigned char *buf, static const Tcl_ChannelType transformChannelType = { "transform", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - TCL_CLOSE2PROC, /* Close proc. */ + NULL, /* Close proc. */ TransformInputProc, /* Input proc. */ TransformOutputProc, /* Output proc. */ -#ifndef TCL_NO_DEPRECATED - TransformSeekProc, /* Seek proc. */ -#else NULL, /* Seek proc. */ -#endif TransformSetOptionProc, /* Set option proc. */ TransformGetOptionProc, /* Get option proc. */ TransformWatchProc, /* Initialize notifier. */ @@ -236,7 +228,7 @@ ReleaseData( } ResultClear(&dataPtr->result); Tcl_DecrRefCount(dataPtr->command); - ckfree(dataPtr); + Tcl_Free(dataPtr); } /* @@ -292,7 +284,7 @@ TclChannelTransform( * regime of the underlying channel and to use the same for us too. */ - dataPtr = (TransformChannelData *)ckalloc(sizeof(TransformChannelData)); + dataPtr = (TransformChannelData *)Tcl_Alloc(sizeof(TransformChannelData)); dataPtr->refCount = 1; Tcl_DStringInit(&ds); @@ -383,7 +375,7 @@ ExecuteCallback( * interpreters. */ { Tcl_Obj *resObj; /* See below, switch (transmit). */ - Tcl_Size resLen; + Tcl_Size resLen = 0; unsigned char *resBuf; Tcl_InterpState state = NULL; int res = TCL_OK; @@ -405,7 +397,12 @@ ExecuteCallback( } Tcl_IncrRefCount(command); - Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1)); + res = Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1)); + if (res != TCL_OK) { + Tcl_DecrRefCount(command); + Tcl_Release(eval); + return res; + } /* * Use a byte-array to prevent the misinterpretation of binary data coming @@ -448,25 +445,38 @@ ExecuteCallback( break; } resObj = Tcl_GetObjResult(eval); - resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); - Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf, - resLen); - break; + resBuf = Tcl_GetBytesFromObj(NULL, resObj, &resLen); + if (resBuf) { + Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), + (char *) resBuf, resLen); + break; + } + goto nonBytes; case TRANSMIT_SELF: if (dataPtr->self == NULL) { break; } resObj = Tcl_GetObjResult(eval); - resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); - Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); - break; + resBuf = Tcl_GetBytesFromObj(NULL, resObj, &resLen); + if (resBuf) { + Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); + break; + } + goto nonBytes; case TRANSMIT_IBUF: resObj = Tcl_GetObjResult(eval); - resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); - ResultAdd(&dataPtr->result, resBuf, resLen); - break; + resBuf = Tcl_GetBytesFromObj(NULL, resObj, &resLen); + if (resBuf) { + ResultAdd(&dataPtr->result, resBuf, resLen); + break; + } + nonBytes: + Tcl_AppendResult(interp, "chan transform callback received non-bytes", + (void *)NULL); + Tcl_Release(eval); + return TCL_ERROR; case TRANSMIT_NUM: /* @@ -505,7 +515,7 @@ ExecuteCallback( static int TransformBlockModeProc( - ClientData instanceData, /* State of transformation. */ + void *instanceData, /* State of transformation. */ int mode) /* New blocking mode. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; @@ -537,7 +547,7 @@ TransformBlockModeProc( static int TransformCloseProc( - ClientData instanceData, + void *instanceData, Tcl_Interp *interp, int flags) { @@ -621,7 +631,7 @@ TransformCloseProc( static int TransformInputProc( - ClientData instanceData, + void *instanceData, char *buf, int toRead, int *errorCodePtr) @@ -788,7 +798,7 @@ TransformInputProc( static int TransformOutputProc( - ClientData instanceData, + void *instanceData, const char *buf, int toWrite, int *errorCodePtr) @@ -821,75 +831,6 @@ TransformOutputProc( /* *---------------------------------------------------------------------- * - * TransformSeekProc -- - * - * This procedure is called by the generic IO level to move the access - * point in a channel. - * - * Side effects: - * Moves the location at which the channel will be accessed in future - * operations. Flushes all transformation buffers, then forwards it to - * the underlying channel. - * - * Result: - * -1 if failed, the new position if successful. An output argument - * contains the POSIX error code if an error occurred, or zero. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -static int -TransformSeekProc( - ClientData instanceData, /* The channel to manipulate. */ - long offset, /* Size of movement. */ - int mode, /* How to move. */ - int *errorCodePtr) /* Location of error flag. */ -{ - TransformChannelData *dataPtr = (TransformChannelData *)instanceData; - Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); - const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); - Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType); - - if ((offset == 0) && (mode == SEEK_CUR)) { - /* - * This is no seek but a request to tell the caller the current - * location. Simply pass the request down. - */ - - return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, - mode, errorCodePtr); - } - - /* - * It is a real request to change the position. Flush all data waiting for - * output and discard everything in the input buffers. Then pass the - * request down, unchanged. - */ - - PreserveData(dataPtr); - if (dataPtr->mode & TCL_WRITABLE) { - ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, - P_NO_PRESERVE); - } - - if (dataPtr->mode & TCL_READABLE) { - ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT, - P_NO_PRESERVE); - ResultClear(&dataPtr->result); - dataPtr->readIsFlushed = 0; - dataPtr->eofPending = 0; - } - ReleaseData(dataPtr); - - return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode, - errorCodePtr); -} -#endif - -/* - *---------------------------------------------------------------------- - * * TransformWideSeekProc -- * * This procedure is called by the generic IO level to move the access @@ -909,7 +850,7 @@ TransformSeekProc( static long long TransformWideSeekProc( - ClientData instanceData, /* The channel to manipulate. */ + void *instanceData, /* The channel to manipulate. */ long long offset, /* Size of movement. */ int mode, /* How to move. */ int *errorCodePtr) /* Location of error flag. */ @@ -917,9 +858,6 @@ TransformWideSeekProc( TransformChannelData *dataPtr = (TransformChannelData *)instanceData; Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); -#ifndef TCL_NO_DEPRECATED - Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType); -#endif Tcl_DriverWideSeekProc *parentWideSeekProc = Tcl_ChannelWideSeekProc(parentType); void *parentData = Tcl_GetChannelInstanceData(parent); @@ -932,10 +870,6 @@ TransformWideSeekProc( if (parentWideSeekProc != NULL) { return parentWideSeekProc(parentData, offset, mode, errorCodePtr); -#ifndef TCL_NO_DEPRECATED - } else if (parentSeekProc) { - return parentSeekProc(parentData, 0, mode, errorCodePtr); -#endif } else { *errorCodePtr = EINVAL; return -1; @@ -968,26 +902,8 @@ TransformWideSeekProc( */ if (parentWideSeekProc == NULL) { - /* - * We're transferring to narrow seeks at this point; this is a bit complex - * because we have to check whether the seek is possible first (i.e. - * whether we are losing information in truncating the bits of the - * offset). Luckily, there's a defined error for what happens when trying - * to go out of the representable range. - */ - -#ifndef TCL_NO_DEPRECATED - if (offset<LONG_MIN || offset>LONG_MAX) { - *errorCodePtr = EOVERFLOW; - return -1; - } - - return parentSeekProc(parentData, offset, - mode, errorCodePtr); -#else *errorCodePtr = EINVAL; return -1; -#endif } return parentWideSeekProc(parentData, offset, mode, errorCodePtr); } @@ -1012,7 +928,7 @@ TransformWideSeekProc( static int TransformSetOptionProc( - ClientData instanceData, + void *instanceData, Tcl_Interp *interp, const char *optionName, const char *value) @@ -1050,7 +966,7 @@ TransformSetOptionProc( static int TransformGetOptionProc( - ClientData instanceData, + void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr) @@ -1097,7 +1013,7 @@ TransformGetOptionProc( static void TransformWatchProc( - ClientData instanceData, /* Channel to watch. */ + void *instanceData, /* Channel to watch. */ int mask) /* Events of interest. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; @@ -1175,9 +1091,9 @@ TransformWatchProc( static int TransformGetFileHandleProc( - ClientData instanceData, /* Channel to query. */ + void *instanceData, /* Channel to query. */ int direction, /* Direction of interest. */ - ClientData *handlePtr) /* Place to store the handle into. */ + void **handlePtr) /* Place to store the handle into. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; @@ -1209,7 +1125,7 @@ TransformGetFileHandleProc( static int TransformNotifyProc( - ClientData clientData, /* The state of the notified + void *clientData, /* The state of the notified * transformation. */ int mask) /* The mask of occurring events. */ { @@ -1254,7 +1170,7 @@ TransformNotifyProc( static void TransformChannelHandlerTimer( - ClientData clientData) /* Transformation to query. */ + void *clientData) /* Transformation to query. */ { TransformChannelData *dataPtr = (TransformChannelData *)clientData; @@ -1294,7 +1210,7 @@ ResultClear( r->used = 0; if (r->allocated) { - ckfree(r->buf); + Tcl_Free(r->buf); r->buf = NULL; r->allocated = 0; } @@ -1438,10 +1354,10 @@ ResultAdd( if (r->allocated == 0) { r->allocated = toWrite + INCREMENT; - r->buf = (unsigned char *)ckalloc(r->allocated); + r->buf = (unsigned char *)Tcl_Alloc(r->allocated); } else { r->allocated += toWrite + INCREMENT; - r->buf = (unsigned char *)ckrealloc(r->buf, r->allocated); + r->buf = (unsigned char *)Tcl_Realloc(r->buf, r->allocated); } } diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 41e9e88..e8ce5f1 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -46,10 +46,6 @@ static int ReflectEventDelete(Tcl_Event *ev, void *cd); #endif static long long ReflectSeekWide(void *clientData, long long offset, int mode, int *errorCodePtr); -#ifndef TCL_NO_DEPRECATED -static int ReflectSeek(void *clientData, long offset, - int mode, int *errorCodePtr); -#endif static int ReflectGetOption(void *clientData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); @@ -68,14 +64,10 @@ static void TimerRunWrite(void *clientData); static const Tcl_ChannelType tclRChannelType = { "tclrchannel", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - TCL_CLOSE2PROC, /* Close channel, clean instance data */ + NULL, /* Close channel, clean instance data */ ReflectInput, /* Handle read request */ ReflectOutput, /* Handle write request */ -#ifndef TCL_NO_DEPRECATED - ReflectSeek, /* Move location of access point. NULL'able */ -#else NULL, -#endif ReflectSetOption, /* Set options. NULL'able */ ReflectGetOption, /* Get options. NULL'able */ ReflectWatch, /* Initialize notifier */ @@ -412,7 +404,7 @@ static void SrcExitProc(void *clientData); #define FreeReceivedError(p) \ if ((p)->base.mustFree) { \ - ckfree((p)->base.msgStr); \ + Tcl_Free((p)->base.msgStr); \ } #define PassReceivedErrorInterp(i,p) \ if ((i) != NULL) { \ @@ -474,6 +466,7 @@ static void MarkDead(ReflectedChannel *rcPtr); */ static const char *msg_read_toomuch = "{read delivered more than requested}"; +static const char *msg_read_nonbyte = "{read delivered nonbyte result}"; static const char *msg_write_toomuch = "{write wrote more than requested}"; static const char *msg_write_nothing = "{write wrote nothing}"; static const char *msg_seek_beforestart = "{Tried to seek before origin}"; @@ -699,7 +692,7 @@ TclChanCreateObjCmd( * as the actual channel type. */ - Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)ckalloc(sizeof(Tcl_ChannelType)); + Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)Tcl_Alloc(sizeof(Tcl_ChannelType)); memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType)); @@ -714,9 +707,6 @@ TclChanCreateObjCmd( clonePtr->blockModeProc = NULL; } if (!(methods & FLAG(METH_SEEK))) { -#ifndef TCL_NO_DEPRECATED - clonePtr->seekProc = NULL; -#endif clonePtr->wideSeekProc = NULL; } if (!(methods & FLAG(METH_TRUNCATE))) { @@ -759,7 +749,7 @@ TclChanCreateObjCmd( Tcl_DecrRefCount(rcPtr->name); Tcl_DecrRefCount(rcPtr->methods); Tcl_DecrRefCount(rcPtr->cmd); - ckfree(rcPtr); + Tcl_Free(rcPtr); return TCL_ERROR; #undef MODE @@ -973,7 +963,7 @@ TclChanPostEventObjCmd( } #if TCL_THREADS } else { - ReflectEvent *ev = (ReflectEvent *)ckalloc(sizeof(ReflectEvent)); + ReflectEvent *ev = (ReflectEvent *)Tcl_Alloc(sizeof(ReflectEvent)); ev->header.proc = ReflectEventRun; ev->events = events; @@ -1231,7 +1221,7 @@ ReflectClose( tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - ckfree(tctPtr); + Tcl_Free((void *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } if (rcPtr->readTimer != NULL) { @@ -1306,7 +1296,7 @@ ReflectClose( #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - ckfree(tctPtr); + Tcl_Free((void *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } if (rcPtr->readTimer != NULL) { @@ -1344,7 +1334,7 @@ ReflectInput( { ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; Tcl_Obj *toReadObj; - Tcl_Size bytec; /* Number of returned bytes */ + Tcl_Size bytec = 0; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ Tcl_Obj *resObj; /* Result data for 'read' */ @@ -1401,9 +1391,12 @@ ReflectInput( goto invalid; } - bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); - if (toRead < bytec) { + if (bytev == NULL) { + SetChannelErrorStr(rcPtr->chan, msg_read_nonbyte); + goto invalid; + } else if (toRead < bytec) { SetChannelErrorStr(rcPtr->chan, msg_read_toomuch); goto invalid; } @@ -1624,7 +1617,7 @@ ReflectSeekWide( goto invalid; } - if (Tcl_GetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) { + if (TclGetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp)); goto invalid; } @@ -1646,26 +1639,6 @@ ReflectSeekWide( newLoc = -1; goto stop; } - -#ifndef TCL_NO_DEPRECATED -static int -ReflectSeek( - void *clientData, - long offset, - int seekMode, - int *errorCodePtr) -{ - /* - * This function can be invoked from a transformation which is based on - * standard seeking, i.e. non-wide. Because of this we have to implement - * it, a dummy is not enough. We simply delegate the call to the wide - * routine. - */ - - return ReflectSeekWide(clientData, offset, seekMode, - errorCodePtr); -} -#endif /* *---------------------------------------------------------------------- @@ -2046,7 +2019,7 @@ ReflectGetOption( goto error; } else { Tcl_Size len; - const char *str = TclGetStringFromObj(resObj, &len); + const char *str = Tcl_GetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(dsPtr, " "); @@ -2273,7 +2246,7 @@ NewReflectedChannel( ReflectedChannel *rcPtr; int mn = 0; - rcPtr = (ReflectedChannel *)ckalloc(sizeof(ReflectedChannel)); + rcPtr = (ReflectedChannel *)Tcl_Alloc(sizeof(ReflectedChannel)); /* rcPtr->chan: Assigned by caller. Dummy data here. */ @@ -2345,7 +2318,7 @@ NextHandle(void) static void FreeReflectedChannel( - char *blockPtr) + void *blockPtr) { ReflectedChannel *rcPtr = (ReflectedChannel *) blockPtr; Channel *chanPtr = (Channel *) rcPtr->chan; @@ -2360,7 +2333,7 @@ FreeReflectedChannel( if (rcPtr->cmd) { Tcl_DecrRefCount(rcPtr->cmd); } - ckfree(rcPtr); + Tcl_Free(rcPtr); } /* @@ -2481,7 +2454,7 @@ InvokeTclMethod( if (result != TCL_ERROR) { Tcl_Size cmdLen; - const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); + const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rcPtr->interp); @@ -2595,7 +2568,7 @@ GetReflectedChannelMap( ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)Tcl_GetAssocData(interp, RCMKEY, NULL); if (rcmPtr == NULL) { - rcmPtr = (ReflectedChannelMap *)ckalloc(sizeof(ReflectedChannelMap)); + rcmPtr = (ReflectedChannelMap *)Tcl_Alloc(sizeof(ReflectedChannelMap)); Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS); Tcl_SetAssocData(interp, RCMKEY, DeleteReflectedChannelMap, rcmPtr); } @@ -2683,7 +2656,7 @@ DeleteReflectedChannelMap( Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rcmPtr->map); - ckfree(&rcmPtr->map); + Tcl_Free(&rcmPtr->map); #if TCL_THREADS /* @@ -2797,7 +2770,7 @@ GetThreadReflectedChannelMap(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->rcmPtr) { - tsdPtr->rcmPtr = (ReflectedChannelMap *)ckalloc(sizeof(ReflectedChannelMap)); + tsdPtr->rcmPtr = (ReflectedChannelMap *)Tcl_Alloc(sizeof(ReflectedChannelMap)); Tcl_InitHashTable(&tsdPtr->rcmPtr->map, TCL_STRING_KEYS); Tcl_CreateThreadExitHandler(DeleteThreadReflectedChannelMap, NULL); } @@ -2922,7 +2895,7 @@ DeleteThreadReflectedChannelMap( MarkDead(rcPtr); Tcl_DeleteHashEntry(hPtr); } - ckfree(rcmPtr); + Tcl_Free(rcmPtr); } static void @@ -2962,8 +2935,8 @@ ForwardOpToHandlerThread( * Create and initialize the event and data structures. */ - evPtr = (ForwardingEvent *)ckalloc(sizeof(ForwardingEvent)); - resultPtr = (ForwardingResult *)ckalloc(sizeof(ForwardingResult)); + evPtr = (ForwardingEvent *)Tcl_Alloc(sizeof(ForwardingEvent)); + resultPtr = (ForwardingResult *)Tcl_Alloc(sizeof(ForwardingResult)); evPtr->event.proc = ForwardProc; evPtr->resultPtr = resultPtr; @@ -3045,7 +3018,7 @@ ForwardOpToHandlerThread( Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr); - ckfree(resultPtr); + Tcl_Free(resultPtr); } static int @@ -3153,12 +3126,15 @@ ForwardProc( * Process a regular result. */ - Tcl_Size bytec; /* Number of returned bytes */ + Tcl_Size bytec = 0; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); - if (paramPtr->input.toRead < bytec) { + if (bytev == NULL) { + ForwardSetStaticError(paramPtr, msg_read_nonbyte); + paramPtr->input.toRead = -1; + } else if (paramPtr->input.toRead < bytec) { ForwardSetStaticError(paramPtr, msg_read_toomuch); paramPtr->input.toRead = TCL_IO_FAILURE; } else { @@ -3236,7 +3212,7 @@ ForwardProc( Tcl_WideInt newLoc; - if (Tcl_GetWideIntFromObj(interp, resObj, &newLoc) == TCL_OK) { + if (TclGetWideIntFromObj(interp, resObj, &newLoc) == TCL_OK) { if (newLoc < 0) { ForwardSetStaticError(paramPtr, msg_seek_beforestart); paramPtr->seek.offset = -1; @@ -3345,7 +3321,7 @@ ForwardProc( * Odd number of elements is wrong. [x]. */ - char *buf = (char *)ckalloc(200); + char *buf = (char *)Tcl_Alloc(200); snprintf(buf, 200, "{Expected list with even number of elements, got %" TCL_SIZE_MODIFIER "d %s instead}", listc, (listc == 1 ? "element" : "elements")); @@ -3353,7 +3329,7 @@ ForwardProc( ForwardSetDynamicError(paramPtr, buf); } else { Tcl_Size len; - const char *str = TclGetStringFromObj(resObj, &len); + const char *str = Tcl_GetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(paramPtr->getOpt.value, " "); @@ -3465,10 +3441,10 @@ ForwardSetObjError( Tcl_Obj *obj) { Tcl_Size len; - const char *msgStr = TclGetStringFromObj(obj, &len); + const char *msgStr = Tcl_GetStringFromObj(obj, &len); len++; - ForwardSetDynamicError(paramPtr, ckalloc(len)); + ForwardSetDynamicError(paramPtr, Tcl_Alloc(len)); memcpy(paramPtr->base.msgStr, msgStr, len); } #endif diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 75e2f96..a7bef43 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -41,10 +41,6 @@ static void ReflectWatch(void *clientData, int mask); static int ReflectBlock(void *clientData, int mode); static long long ReflectSeekWide(void *clientData, long long offset, int mode, int *errorCodePtr); -#ifndef TCL_NO_DEPRECATED -static int ReflectSeek(void *clientData, long offset, - int mode, int *errorCodePtr); -#endif static int ReflectGetOption(void *clientData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); @@ -62,14 +58,10 @@ static int ReflectNotify(void *clientData, int mask); static const Tcl_ChannelType tclRTransformType = { "tclrtransform", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel. */ - TCL_CLOSE2PROC, /* Close channel, clean instance data. */ + NULL, /* Close channel, clean instance data. */ ReflectInput, /* Handle read request. */ ReflectOutput, /* Handle write request. */ -#ifndef TCL_NO_DEPRECATED - ReflectSeek, /* Move location of access point. */ -#else NULL, /* Move location of access point. */ -#endif ReflectSetOption, /* Set options. */ ReflectGetOption, /* Get options. */ ReflectWatch, /* Initialize notifier. */ @@ -272,7 +264,7 @@ struct ForwardParamTransform { ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ char *buf; /* I: Bytes to transform, * O: Bytes in transform result */ - int size; /* I: #bytes to transform, + Tcl_Size size; /* I: #bytes to transform, * O: #bytes in the transform result */ }; struct ForwardParamLimit { @@ -368,7 +360,7 @@ static void SrcExitProc(void *clientData); #define FreeReceivedError(p) \ do { \ if ((p)->base.mustFree) { \ - ckfree((p)->base.msgStr); \ + Tcl_Free((p)->base.msgStr); \ } \ } while (0) #define PassReceivedErrorInterp(i,p) \ @@ -519,7 +511,7 @@ TclChanPushObjCmd( Tcl_Obj *cmdNameObj; /* Command name */ Tcl_Obj *rtId; /* Handle of the new transform (channel) */ Tcl_Obj *modeObj; /* mode in obj form for method call */ - int listc; /* Result of 'initialize', and of */ + Tcl_Size listc; /* Result of 'initialize', and of */ Tcl_Obj **listv; /* its sublist in the 2nd element */ int methIndex; /* Encoded method name */ int result; /* Result code for 'initialize' */ @@ -622,7 +614,7 @@ TclChanPushObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned %s", TclGetString(cmdObj), - Tcl_GetString(Tcl_GetObjResult(interp)))); + Tcl_GetStringResult(interp))); Tcl_DecrRefCount(resObj); goto error; } @@ -828,10 +820,10 @@ UnmarshallErrorResult( Tcl_Interp *interp, Tcl_Obj *msgObj) { - int lc; + Tcl_Size lc; Tcl_Obj **lv; int explicitResult; - int numOptions; + Tcl_Size numOptions; /* * Process the caught message. @@ -1021,7 +1013,7 @@ ReflectClose( if (!rtPtr->dead) { rtmPtr = GetReflectedTransformMap(rtPtr->interp); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } @@ -1382,19 +1374,8 @@ ReflectSeekWide( */ if (Tcl_ChannelWideSeekProc(parent->typePtr) == NULL) { -#ifndef TCL_NO_DEPRECATED - if (offset < LONG_MIN || offset > LONG_MAX) { - *errorCodePtr = EOVERFLOW; - curPos = -1; - } else { - curPos = Tcl_ChannelSeekProc(parent->typePtr)( - parent->instanceData, offset, seekMode, - errorCodePtr); - } -#else *errorCodePtr = EINVAL; curPos = -1; -#endif } else { curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset, seekMode, errorCodePtr); @@ -1407,26 +1388,6 @@ ReflectSeekWide( Tcl_Release(rtPtr); return curPos; } - -#ifndef TCL_NO_DEPRECATED -static int -ReflectSeek( - void *clientData, - long offset, - int seekMode, - int *errorCodePtr) -{ - /* - * This function can be invoked from a transformation which is based on - * standard seeking, i.e. non-wide. Because of this we have to implement - * it, a dummy is not enough. We simply delegate the call to the wide - * routine. - */ - - return ReflectSeekWide(clientData, offset, seekMode, - errorCodePtr); -} -#endif /* *---------------------------------------------------------------------- @@ -1758,11 +1719,10 @@ NewReflectedTransform( Tcl_Channel parentChan) { ReflectedTransform *rtPtr; - int listc; + Tcl_Size i, listc; Tcl_Obj **listv; - int i; - rtPtr = (ReflectedTransform *)ckalloc(sizeof(ReflectedTransform)); + rtPtr = (ReflectedTransform *)Tcl_Alloc(sizeof(ReflectedTransform)); /* rtPtr->chan: Assigned by caller. Dummy data here. */ /* rtPtr->methods: Assigned by caller. Dummy data here. */ @@ -1809,7 +1769,7 @@ NewReflectedTransform( */ rtPtr->argc = listc + 2; - rtPtr->argv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (listc+4)); + rtPtr->argv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * (listc+4)); /* * Duplicate object references. @@ -1910,7 +1870,7 @@ FreeReflectedTransformArgs( static void FreeReflectedTransform( - char *blockPtr) + void *blockPtr) { ReflectedTransform *rtPtr = (ReflectedTransform *) blockPtr; TimerKill(rtPtr); @@ -1918,8 +1878,8 @@ FreeReflectedTransform( FreeReflectedTransformArgs(rtPtr); - ckfree(rtPtr->argv); - ckfree(rtPtr); + Tcl_Free(rtPtr->argv); + Tcl_Free(rtPtr); } /* @@ -2045,8 +2005,8 @@ InvokeTclMethod( */ if (result != TCL_ERROR) { Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv); - int cmdLen; - const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); + Tcl_Size cmdLen; + const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rtPtr->interp); @@ -2118,7 +2078,7 @@ GetReflectedTransformMap( ReflectedTransformMap *rtmPtr = (ReflectedTransformMap *)Tcl_GetAssocData(interp, RTMKEY, NULL); if (rtmPtr == NULL) { - rtmPtr = (ReflectedTransformMap *)ckalloc(sizeof(ReflectedTransformMap)); + rtmPtr = (ReflectedTransformMap *)Tcl_Alloc(sizeof(ReflectedTransformMap)); Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS); Tcl_SetAssocData(interp, RTMKEY, (Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr); @@ -2185,7 +2145,7 @@ DeleteReflectedTransformMap( Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rtmPtr->map); - ckfree(&rtmPtr->map); + Tcl_Free(&rtmPtr->map); #if TCL_THREADS /* @@ -2283,7 +2243,7 @@ GetThreadReflectedTransformMap(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->rtmPtr) { - tsdPtr->rtmPtr = (ReflectedTransformMap *)ckalloc(sizeof(ReflectedTransformMap)); + tsdPtr->rtmPtr = (ReflectedTransformMap *)Tcl_Alloc(sizeof(ReflectedTransformMap)); Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS); Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL); } @@ -2341,7 +2301,7 @@ DeleteThreadReflectedTransformMap( FreeReflectedTransformArgs(rtPtr); Tcl_DeleteHashEntry(hPtr); } - ckfree(rtmPtr); + Tcl_Free(rtmPtr); /* * Go through the list of pending results and cancel all whose events were @@ -2418,8 +2378,8 @@ ForwardOpToOwnerThread( * Create and initialize the event and data structures. */ - evPtr = (ForwardingEvent *)ckalloc(sizeof(ForwardingEvent)); - resultPtr = (ForwardingResult *)ckalloc(sizeof(ForwardingResult)); + evPtr = (ForwardingEvent *)Tcl_Alloc(sizeof(ForwardingEvent)); + resultPtr = (ForwardingResult *)Tcl_Alloc(sizeof(ForwardingResult)); evPtr->event.proc = ForwardProc; evPtr->resultPtr = resultPtr; @@ -2499,7 +2459,7 @@ ForwardOpToOwnerThread( Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr); - ckfree(resultPtr); + Tcl_Free(resultPtr); } static int @@ -2596,23 +2556,23 @@ ForwardProc( if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = -1; + paramPtr->transform.size = TCL_INDEX_NONE; } else { /* * Process a regular return. Contains the transformation result. * Sent it back to the request originator. */ - int bytec; /* Number of returned bytes */ + Tcl_Size bytec = 0; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); paramPtr->transform.size = bytec; if (bytec > 0) { - paramPtr->transform.buf = (char *)ckalloc(bytec); + paramPtr->transform.buf = (char *)Tcl_Alloc(bytec); memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; @@ -2630,23 +2590,23 @@ ForwardProc( if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = -1; + paramPtr->transform.size = TCL_INDEX_NONE; } else { /* * Process a regular return. Contains the transformation result. * Sent it back to the request originator. */ - int bytec; /* Number of returned bytes */ + Tcl_Size bytec = 0; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); paramPtr->transform.size = bytec; if (bytec > 0) { - paramPtr->transform.buf = (char *)ckalloc(bytec); + paramPtr->transform.buf = (char *)Tcl_Alloc(bytec); memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; @@ -2660,22 +2620,22 @@ ForwardProc( case ForwardedDrain: if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = -1; + paramPtr->transform.size = TCL_INDEX_NONE; } else { /* * Process a regular return. Contains the transformation result. * Sent it back to the request originator. */ - int bytec; /* Number of returned bytes */ + Tcl_Size bytec = 0; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); paramPtr->transform.size = bytec; if (bytec > 0) { - paramPtr->transform.buf = (char *)ckalloc(bytec); + paramPtr->transform.buf = (char *)Tcl_Alloc(bytec); memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; @@ -2686,23 +2646,23 @@ ForwardProc( case ForwardedFlush: if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = -1; + paramPtr->transform.size = TCL_INDEX_NONE; } else { /* * Process a regular return. Contains the transformation result. * Sent it back to the request originator. */ - int bytec; /* Number of returned bytes */ + Tcl_Size bytec = 0; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); paramPtr->transform.size = bytec; if (bytec > 0) { - paramPtr->transform.buf = (char *)ckalloc(bytec); + paramPtr->transform.buf = (char *)Tcl_Alloc(bytec); memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; @@ -2811,11 +2771,11 @@ ForwardSetObjError( ForwardParam *paramPtr, Tcl_Obj *obj) { - int len; - const char *msgStr = TclGetStringFromObj(obj, &len); + Tcl_Size len; + const char *msgStr = Tcl_GetStringFromObj(obj, &len); len++; - ForwardSetDynamicError(paramPtr, ckalloc(len)); + ForwardSetDynamicError(paramPtr, Tcl_Alloc(len)); memcpy(paramPtr->base.msgStr, msgStr, len); } #endif /* TCL_THREADS */ @@ -2960,7 +2920,7 @@ ResultClear( return; } - ckfree(rPtr->buf); + Tcl_Free(rPtr->buf); rPtr->buf = NULL; rPtr->allocated = 0; } @@ -2995,10 +2955,10 @@ ResultAdd( if (rPtr->allocated == 0) { rPtr->allocated = toWrite + RB_INCREMENT; - rPtr->buf = UCHARP(ckalloc(rPtr->allocated)); + rPtr->buf = UCHARP(Tcl_Alloc(rPtr->allocated)); } else { rPtr->allocated += toWrite + RB_INCREMENT; - rPtr->buf = UCHARP(ckrealloc((char *) rPtr->buf, + rPtr->buf = UCHARP(Tcl_Realloc((char *) rPtr->buf, rPtr->allocated)); } } @@ -3043,7 +3003,7 @@ ResultCopy( */ copied = 0; - } else if (rPtr->used == toRead) { + } else if (rPtr->used == (size_t)toRead) { /* * We have just enough. Copy everything to the caller. */ @@ -3051,7 +3011,7 @@ ResultCopy( memcpy(buf, rPtr->buf, toRead); rPtr->used = 0; copied = toRead; - } else if (rPtr->used > toRead) { + } else if (rPtr->used > (size_t)toRead) { /* * The internal buffer contains more than requested. Copy the * requested subset to the caller, and shift the remaining bytes down. @@ -3086,7 +3046,7 @@ TransformRead( Tcl_Obj *bufObj) { Tcl_Obj *resObj; - int bytec; /* Number of returned bytes */ + Tcl_Size bytec = 0; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ /* @@ -3097,7 +3057,7 @@ TransformRead( if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; - p.transform.buf = (char *) Tcl_GetByteArrayFromObj(bufObj, + p.transform.buf = (char *) Tcl_GetBytesFromObj(NULL, bufObj, &(p.transform.size)); ForwardOpToOwnerThread(rtPtr, ForwardedInput, &p); @@ -3110,7 +3070,7 @@ TransformRead( *errorCodePtr = EOK; ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size); - ckfree(p.transform.buf); + Tcl_Free(p.transform.buf); return 1; } #endif /* TCL_THREADS */ @@ -3125,7 +3085,7 @@ TransformRead( return 0; } - bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); ResultAdd(&rtPtr->result, bytev, bytec); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ @@ -3141,7 +3101,7 @@ TransformWrite( { Tcl_Obj *bufObj; Tcl_Obj *resObj; - int bytec; /* Number of returned bytes */ + Tcl_Size bytec = 0; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ int res; @@ -3167,7 +3127,7 @@ TransformWrite( *errorCodePtr = EOK; res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf, p.transform.size); - ckfree(p.transform.buf); + Tcl_Free(p.transform.buf); } else #endif /* TCL_THREADS */ { @@ -3187,7 +3147,7 @@ TransformWrite( *errorCodePtr = EOK; - bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); res = Tcl_WriteRaw(rtPtr->parent, (char *) bytev, bytec); Tcl_DecrRefCount(bufObj); @@ -3208,7 +3168,7 @@ TransformDrain( int *errorCodePtr) { Tcl_Obj *resObj; - int bytec; /* Number of returned bytes */ + Tcl_Size bytec = 0; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ /* @@ -3229,7 +3189,7 @@ TransformDrain( *errorCodePtr = EOK; ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size); - ckfree(p.transform.buf); + Tcl_Free(p.transform.buf); } else #endif /* TCL_THREADS */ { @@ -3240,7 +3200,7 @@ TransformDrain( return 0; } - bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); ResultAdd(&rtPtr->result, bytev, bytec); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ @@ -3257,7 +3217,7 @@ TransformFlush( int op) { Tcl_Obj *resObj; - int bytec; /* Number of returned bytes */ + Tcl_Size bytec = 0; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ int res; @@ -3284,7 +3244,7 @@ TransformFlush( } else { res = 0; } - ckfree(p.transform.buf); + Tcl_Free(p.transform.buf); } else #endif /* TCL_THREADS */ { @@ -3296,7 +3256,7 @@ TransformFlush( } if (op == FLUSH_WRITE) { - bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); res = Tcl_WriteRaw(rtPtr->parent, (char *) bytev, bytec); } else { res = 0; diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index eaa9cc8..47fde36 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -75,7 +75,11 @@ TclSockGetPort( * Don't bother translating 'proto' to native. */ - native = Tcl_UtfToExternalDString(NULL, string, -1, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, string, -1, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + native = Tcl_DStringValue(&ds); sp = getservbyname(native, proto); /* INTL: Native. */ Tcl_DStringFree(&ds); if (sp != NULL) { @@ -117,11 +121,15 @@ TclSockGetPort( int TclSockMinimumBuffers( void *sock, /* Socket file descriptor */ - int size) /* Minimum buffer size */ + Tcl_Size size1) /* Minimum buffer size */ { int current; socklen_t len; + int size = size1; + if (size != size1) { + return TCL_ERROR; + } len = sizeof(int); getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, (char *) ¤t, &len); @@ -180,7 +188,11 @@ TclCreateSocketAddress( int result; if (host != NULL) { - native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, host, -1, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return 0; + } + native = Tcl_DStringValue(&ds); } /* @@ -224,7 +236,7 @@ TclCreateSocketAddress( * using AI_ADDRCONFIG is probably low even in situations where it works, * we'll leave it out for now. After all, it is just an optimisation. * - * Missing on: OpenBSD, NetBSD. + * Missing on NetBSD. * Causes failure when used on AIX 5.1 and HP-UX */ @@ -313,7 +325,7 @@ Tcl_OpenTcpServer( int port, const char *host, Tcl_TcpAcceptProc *acceptProc, - ClientData callbackData) + void *callbackData) { char portbuf[TCL_INTEGER_SPACE]; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 7719f35..921d79e 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -34,7 +34,7 @@ */ typedef struct FilesystemRecord { - ClientData clientData; /* Client-specific data for the filesystem + void *clientData; /* Client-specific data for the filesystem * (can be NULL) */ const Tcl_Filesystem *fsPtr;/* Pointer to filesystem dispatch table. */ struct FilesystemRecord *nextPtr; @@ -58,7 +58,7 @@ typedef struct { * the value is accessed and cwdPathEpoch has * changed. */ - ClientData cwdClientData; + void *cwdClientData; FilesystemRecord *filesystemList; size_t claims; } ThreadSpecificData; @@ -69,12 +69,12 @@ typedef struct { static Tcl_NRPostProc EvalFileCallback; static FilesystemRecord*FsGetFirstFilesystem(void); -static void FsThrExitProc(ClientData cd); +static void FsThrExitProc(void *cd); static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern); static void FsAddMountsToGlobResult(Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); -static void FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData); +static void FsUpdateCwd(Tcl_Obj *cwdObj, void *clientData); static void FsRecacheFilesystemList(void); static void Claim(void); static void Disclaim(void); @@ -212,7 +212,7 @@ TCL_DECLARE_MUTEX(filesystemMutex) static Tcl_Obj *cwdPathPtr = NULL; static size_t cwdPathEpoch = 0; /* The pathname of the current directory */ -static ClientData cwdClientData = NULL; +static void *cwdClientData = NULL; TCL_DECLARE_MUTEX(cwdMutex) static Tcl_ThreadDataKey fsDataKey; @@ -230,7 +230,7 @@ typedef struct { Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; const Tcl_Filesystem *divertedFilesystem; - ClientData divertedFileNativeRep; + void *divertedFileNativeRep; } FsDivertLoad; /* @@ -414,7 +414,7 @@ Tcl_EvalFile( static void FsThrExitProc( - ClientData cd) + void *cd) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *)cd; FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL; @@ -439,7 +439,7 @@ FsThrExitProc( while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr->nextPtr; fsRecPtr->fsPtr = NULL; - ckfree(fsRecPtr); + Tcl_Free(fsRecPtr); fsRecPtr = tmpFsRecPtr; } tsdPtr->filesystemList = NULL; @@ -521,11 +521,11 @@ TclFSCwdPointerEquals( if (tsdPtr->cwdPathPtr == *pathPtrPtr) { return 1; } else { - int len1, len2; + Tcl_Size len1, len2; const char *str1, *str2; - str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = TclGetStringFromObj(*pathPtrPtr, &len2); + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); if ((len1 == len2) && !memcmp(str1, str2, len1)) { /* * The values are equal but the objects are different. Cache the @@ -578,7 +578,7 @@ FsRecacheFilesystemList(void) list = NULL; fsRecPtr = tmpFsRecPtr; while (fsRecPtr != NULL) { - tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord)); + tmpFsRecPtr = (FilesystemRecord *)Tcl_Alloc(sizeof(FilesystemRecord)); *tmpFsRecPtr = *fsRecPtr; tmpFsRecPtr->nextPtr = list; tmpFsRecPtr->prevPtr = NULL; @@ -593,7 +593,7 @@ FsRecacheFilesystemList(void) FilesystemRecord *next = toFree->nextPtr; toFree->fsPtr = NULL; - ckfree(toFree); + Tcl_Free(toFree); toFree = next; } @@ -661,14 +661,14 @@ TclFSEpoch(void) static void FsUpdateCwd( Tcl_Obj *cwdObj, - ClientData clientData) + void *clientData) { - int len; + Tcl_Size len = 0; const char *str = NULL; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { - str = TclGetStringFromObj(cwdObj, &len); + str = Tcl_GetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); @@ -771,7 +771,7 @@ TclFinalizeFilesystem(void) */ if (fsRecPtr != &nativeFilesystemRecord) { - ckfree(fsRecPtr); + Tcl_Free(fsRecPtr); } fsRecPtr = tmpFsRecPtr; } @@ -844,7 +844,7 @@ TclResetFilesystem(void) int Tcl_FSRegister( - ClientData clientData, /* Client-specific data for this filesystem. */ + void *clientData, /* Client-specific data for this filesystem. */ const Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */ { FilesystemRecord *newFilesystemPtr; @@ -853,7 +853,7 @@ Tcl_FSRegister( return TCL_ERROR; } - newFilesystemPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord)); + newFilesystemPtr = (FilesystemRecord *)Tcl_Alloc(sizeof(FilesystemRecord)); newFilesystemPtr->clientData = clientData; newFilesystemPtr->fsPtr = fsPtr; @@ -939,7 +939,7 @@ Tcl_FSUnregister( ++theFilesystemEpoch; } - ckfree(fsRecPtr); + Tcl_Free(fsRecPtr); retVal = TCL_OK; } else { @@ -990,7 +990,8 @@ Tcl_FSMatchInDirectory( { const Tcl_Filesystem *fsPtr; Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr; - int resLength, i, ret = -1; + Tcl_Size resLength, i; + int ret = -1; if (types != NULL && (types->type & TCL_GLOB_TYPE_MOUNT)) { /* @@ -1106,7 +1107,7 @@ FsAddMountsToGlobResult( * directory flag is particularly significant. */ { - int mLength, gLength, i; + Tcl_Size mLength, gLength, i; int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR)); Tcl_Obj *mounts = FsListMounts(pathPtr, pattern); @@ -1122,7 +1123,7 @@ FsAddMountsToGlobResult( } for (i=0 ; i<mLength ; i++) { Tcl_Obj *mElt; - int j; + Tcl_Size j; int found = 0; Tcl_ListObjIndex(NULL, mounts, i, &mElt); @@ -1146,7 +1147,7 @@ FsAddMountsToGlobResult( } if (!found && dir) { Tcl_Obj *norm; - int len, mlen; + Tcl_Size len, mlen; /* * mElt is normalized and lies inside pathPtr so @@ -1158,8 +1159,8 @@ FsAddMountsToGlobResult( if (norm != NULL) { const char *path, *mount; - mount = TclGetStringFromObj(mElt, &mlen); - path = TclGetStringFromObj(norm, &len); + mount = Tcl_GetStringFromObj(mElt, &mlen); + path = Tcl_GetStringFromObj(norm, &len); if (path[len-1] == '/') { /* * Deal with the root of the volume. @@ -1213,9 +1214,7 @@ FsAddMountsToGlobResult( * native file system; see note below). * * (4) The mapping from a string representation of a file to a full, - * normalized pathname changes. For example, if 'env(HOME)' is modified, - * then any pathname containing '~' maps to a different item, possibly in - * a different filesystem. + * normalized pathname changes. * * Tcl has no control over (2) and (3), so each registered filesystem must * call Tcl_FSMountsChnaged in each of those circumstances. @@ -1264,12 +1263,12 @@ Tcl_FSMountsChanged( *---------------------------------------------------------------------- */ -ClientData +void * Tcl_FSData( const Tcl_Filesystem *fsPtr) /* The filesystem to find in the list of * registered filesystems. */ { - ClientData retVal = NULL; + void *retVal = NULL; FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); /* @@ -1326,7 +1325,7 @@ TclFSNormalizeToUniquePath( { FilesystemRecord *fsRecPtr, *firstFsRecPtr; - int i; + Tcl_Size i; int isVfsPath = 0; const char *path; @@ -1339,7 +1338,7 @@ TclFSNormalizeToUniquePath( * We check these first to avoid useless calls to the native filesystem's * normalizePathProc. */ - path = TclGetStringFromObj(pathPtr, &i); + path = Tcl_GetStringFromObj(pathPtr, &i); if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/') || (path[0] == '\\' && path[1] == '\\') ) ) { @@ -1476,7 +1475,8 @@ TclGetOpenModeEx( * configure the channel for binary * operations after opening the file. */ { - int mode, modeArgc, c, i, gotRW; + int mode, c, gotRW; + Tcl_Size modeArgc, i; const char **modeArgv, *flag; #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) @@ -1598,7 +1598,7 @@ TclGetOpenModeEx( "access mode \"%s\" not supported by this system", flag)); } - ckfree(modeArgv); + Tcl_Free((void *)modeArgv); return -1; #endif @@ -1611,7 +1611,7 @@ TclGetOpenModeEx( "access mode \"%s\" not supported by this system", flag)); } - ckfree(modeArgv); + Tcl_Free((void *)modeArgv); return -1; #endif @@ -1627,12 +1627,12 @@ TclGetOpenModeEx( "RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK," " or TRUNC", flag)); } - ckfree(modeArgv); + Tcl_Free((void *)modeArgv); return -1; } } - ckfree(modeArgv); + Tcl_Free((void *)modeArgv); if (!gotRW) { if (interp != NULL) { @@ -1687,7 +1687,8 @@ Tcl_FSEvalFileEx( const char *encodingName) /* Either the name of an encoding or NULL to use the utf-8 encoding. */ { - int length, result = TCL_ERROR; + Tcl_Size length; + int result = TCL_ERROR; Tcl_StatBuf statBuf; Tcl_Obj *oldScriptFile; Interp *iPtr; @@ -1703,23 +1704,23 @@ Tcl_FSEvalFileEx( Tcl_SetErrno(errno); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); return result; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); return result; } /* - * The eof character is \32 (^Z). This is standard on Windows, and Tcl - * uses it on every platform to allow for scripted documents. [Bug: 2040] + * The eof character is \x1A (^Z). Tcl uses it on every platform to allow + * for scripted documents. [Bug: 2040] */ - Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}"); + Tcl_SetChannelOption(interp, chan, "-eofchar", "\x1A"); /* * If the encoding is specified, set the channel to that encoding. @@ -1731,7 +1732,7 @@ Tcl_FSEvalFileEx( } if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) != TCL_OK) { - Tcl_Close(interp,chan); + Tcl_CloseEx(interp,chan,0); return result; } @@ -1743,29 +1744,29 @@ Tcl_FSEvalFileEx( */ if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { - Tcl_Close(interp, chan); + Tcl_CloseEx(interp, chan, 0); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); goto end; } - string = Tcl_GetString(objPtr); + string = TclGetString(objPtr); /* * If first character is not a BOM, append the remaining characters. * Otherwise, replace them. [Bug 3466099] */ - if (Tcl_ReadChars(chan, objPtr, -1, + if (Tcl_ReadChars(chan, objPtr, TCL_INDEX_NONE, memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) { - Tcl_Close(interp, chan); + Tcl_CloseEx(interp, chan, 0); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); goto end; } - if (Tcl_Close(interp, chan) != TCL_OK) { + if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { goto end; } @@ -1773,7 +1774,7 @@ Tcl_FSEvalFileEx( oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); - string = TclGetStringFromObj(objPtr, &length); + string = Tcl_GetStringFromObj(objPtr, &length); /* * TIP #280: Open a frame for the evaluated script. @@ -1800,13 +1801,13 @@ Tcl_FSEvalFileEx( * Record information about where the error occurred. */ - const char *pathString = TclGetStringFromObj(pathPtr, &length); - int limit = 150; - int overflow = (length > limit); + const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + unsigned limit = 150; + int overflow = ((unsigned)length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", - (overflow ? limit : length), pathString, + (overflow ? limit : (unsigned)length), pathString, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } @@ -1838,24 +1839,24 @@ TclNREvalFile( Tcl_SetErrno(errno); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } - TclPkgFileSeen(interp, Tcl_GetString(pathPtr)); + TclPkgFileSeen(interp, TclGetString(pathPtr)); /* - * The eof character is \32 (^Z). This is standard on Windows, and Tcl - * uses it on every platform to allow for scripted documents. [Bug: 2040] + * The eof character is \x1A (^Z). Tcl uses it on every platform to allow + * for scripted documents. [Bug: 2040] */ - Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}"); + Tcl_SetChannelOption(interp, chan, "-eofchar", "\x1A"); /* * If the encoding is specified, set the channel to that encoding. @@ -1867,7 +1868,7 @@ TclNREvalFile( } if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) != TCL_OK) { - Tcl_Close(interp, chan); + Tcl_CloseEx(interp, chan, 0); return TCL_ERROR; } @@ -1879,31 +1880,31 @@ TclNREvalFile( */ if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { - Tcl_Close(interp, chan); + Tcl_CloseEx(interp, chan, 0); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } - string = Tcl_GetString(objPtr); + string = TclGetString(objPtr); /* * If first character is not a BOM, append the remaining characters. * Otherwise, replace them. [Bug 3466099] */ - if (Tcl_ReadChars(chan, objPtr, -1, + if (Tcl_ReadChars(chan, objPtr, TCL_INDEX_NONE, memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) { - Tcl_Close(interp, chan); + Tcl_CloseEx(interp, chan, 0); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } - if (Tcl_Close(interp, chan) != TCL_OK) { + if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -1925,7 +1926,7 @@ TclNREvalFile( static int EvalFileCallback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -1952,14 +1953,14 @@ EvalFileCallback( * Record information about where the error occurred. */ - int length; - const char *pathString = TclGetStringFromObj(pathPtr, &length); - const int limit = 150; - int overflow = (length > limit); + Tcl_Size length; + const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + const unsigned limit = 150; + int overflow = ((unsigned)length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", - (overflow ? limit : length), pathString, + (overflow ? limit : (unsigned)length), pathString, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } @@ -2232,9 +2233,9 @@ Tcl_FSOpenFileChannel( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not seek to end of file while opening \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); } - Tcl_Close(NULL, retVal); + Tcl_CloseEx(NULL, retVal, 0); return NULL; } if (binary) { @@ -2251,7 +2252,7 @@ Tcl_FSOpenFileChannel( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -2479,7 +2480,7 @@ TclFSFileAttrIndex( * It's a non-constant attribute list, so do a literal search. */ - int i, objc; + Tcl_Size i, objc; Tcl_Obj **objv; if (TclListObjGetElementsM(NULL, listObj, &objc, &objv) != TCL_OK) { @@ -2626,7 +2627,7 @@ Tcl_FSGetCwd( Claim(); for (; (retVal == NULL) && (fsRecPtr != NULL); fsRecPtr = fsRecPtr->nextPtr) { - ClientData retCd; + void *retCd; TclFSGetCwdProc2 *proc2; if (fsRecPtr->fsPtr->getCwdProc == NULL) { @@ -2727,7 +2728,7 @@ Tcl_FSGetCwd( const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); - ClientData retCd = NULL; + void *retCd = NULL; Tcl_Obj *retVal, *norm; if (fsPtr == NULL || fsPtr->getCwdProc == NULL) { @@ -2800,11 +2801,11 @@ Tcl_FSGetCwd( * infinite loop bug when trying to normalize tsdPtr->cwdPathPtr. */ - int len1, len2; + Tcl_Size len1, len2; const char *str1, *str2; - str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = TclGetStringFromObj(norm, &len2); + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = Tcl_GetStringFromObj(norm, &len2); if ((len1 == len2) && (strcmp(str1, str2) == 0)) { /* * The pathname values are equal so retain the old pathname @@ -2929,8 +2930,8 @@ Tcl_FSChdir( } if (fsPtr == &tclNativeFilesystem) { - ClientData cd; - ClientData oldcd = tsdPtr->cwdClientData; + void *cd; + void *oldcd = tsdPtr->cwdClientData; /* * Assume that the native filesystem has a getCwdProc and that it @@ -3140,7 +3141,7 @@ skipUnlink( */ #define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's') #endif /* AUFS_SUPER_MAGIC */ - if ((statfs(Tcl_GetString(shlibFile), &fs) == 0) + if ((statfs(TclGetString(shlibFile), &fs) == 0) && (fs.f_type == AUFS_SUPER_MAGIC)) { return 1; } @@ -3216,7 +3217,7 @@ Tcl_LoadFile( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't load library \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + TclGetString(pathPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -3253,11 +3254,11 @@ Tcl_LoadFile( } buffer = TclpLoadMemoryGetBuffer(interp, size); if (!buffer) { - Tcl_Close(interp, data); + Tcl_CloseEx(interp, data, 0); goto mustCopyToTempAnyway; } ret = Tcl_Read(data, (char *)buffer, size); - Tcl_Close(interp, data); + Tcl_CloseEx(interp, data, 0); ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, &unloadProcPtr, flags); if (ret == TCL_OK && *handlePtr != NULL) { @@ -3371,7 +3372,7 @@ Tcl_LoadFile( * Divert the unloading in order to unload and cleanup the temporary file. */ - tvdlPtr = (FsDivertLoad *)ckalloc(sizeof(FsDivertLoad)); + tvdlPtr = (FsDivertLoad *)Tcl_Alloc(sizeof(FsDivertLoad)); /* * Remember three pieces of information in order to clean up the diverted @@ -3412,7 +3413,7 @@ Tcl_LoadFile( copyToPtr = NULL; - divertedLoadHandle = (Tcl_LoadHandle)ckalloc(sizeof(struct Tcl_LoadHandle_)); + divertedLoadHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(struct Tcl_LoadHandle_)); divertedLoadHandle->clientData = tvdlPtr; divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol; divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile; @@ -3550,8 +3551,8 @@ DivertUnloadFile( Tcl_DecrRefCount(tvdlPtr->divertedFile); } - ckfree(tvdlPtr); - ckfree(loadHandle); + Tcl_Free(tvdlPtr); + Tcl_Free(loadHandle); } /* @@ -3801,13 +3802,13 @@ FsListMounts( Tcl_Obj * Tcl_FSSplitPath( Tcl_Obj *pathPtr, /* The pathname to split. */ - int *lenPtr) /* A place to hold the number of pathname + Tcl_Size *lenPtr) /* A place to hold the number of pathname * elements. */ { Tcl_Obj *result = NULL; /* Just to squelch gcc warnings. */ const Tcl_Filesystem *fsPtr; char separator = '/'; - int driveNameLength; + Tcl_Size driveNameLength; const char *p; /* @@ -3830,7 +3831,7 @@ Tcl_FSSplitPath( if (sep != NULL) { Tcl_IncrRefCount(sep); - separator = Tcl_GetString(sep)[0]; + separator = TclGetString(sep)[0]; Tcl_DecrRefCount(sep); } } @@ -3842,7 +3843,7 @@ Tcl_FSSplitPath( */ TclNewObj(result); - p = Tcl_GetString(pathPtr); + p = TclGetString(pathPtr); Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(p, driveNameLength)); p += driveNameLength; @@ -3853,7 +3854,7 @@ Tcl_FSSplitPath( for (;;) { const char *elementStart = p; - int length; + Tcl_Size length; while ((*p != '\0') && (*p != separator)) { p++; @@ -3861,14 +3862,8 @@ Tcl_FSSplitPath( length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; - - if (elementStart[0] == '~') { - TclNewLiteralStringObj(nextElt, "./"); - Tcl_AppendToObj(nextElt, elementStart, length); - } else { - nextElt = Tcl_NewStringObj(elementStart, length); - } - Tcl_ListObjAppendElement(NULL, result, nextElt); + nextElt = Tcl_NewStringObj(elementStart, length); + Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*p++ == '\0') { break; @@ -3904,15 +3899,15 @@ TclGetPathType( /* If not NULL, a place in which to store a * pointer to the filesystem for this pathname * if it is absolute. */ - int *driveNameLengthPtr, /* If not NULL, a place in which to store the + Tcl_Size *driveNameLengthPtr, /* If not NULL, a place in which to store the * length of the volume name. */ Tcl_Obj **driveNameRef) /* If not NULL, for an absolute pathname, a * place to store a pointer to an object with a * refCount of 1, and whose value is the name * of the volume. */ { - int pathLen; - const char *path = TclGetStringFromObj(pathPtr, &pathLen); + Tcl_Size pathLen; + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); Tcl_PathType type; type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, @@ -3953,12 +3948,12 @@ TclGetPathType( Tcl_PathType TclFSNonnativePathType( const char *path, /* Pathname to determine the type of. */ - int pathLen, /* Length of the pathname. */ + Tcl_Size pathLen, /* Length of the pathname. */ const Tcl_Filesystem **filesystemPtrPtr, /* If not NULL, a place to store a pointer to * the filesystem for this pathname when it is * an absolute pathname. */ - int *driveNameLengthPtr, /* If not NULL, a place to store the length of + Tcl_Size *driveNameLengthPtr,/* If not NULL, a place to store the length of * the volume name if the pathname is absolute. */ Tcl_Obj **driveNameRef) /* If not NULL, a place to store a pointer to @@ -3995,7 +3990,7 @@ TclFSNonnativePathType( if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (fsRecPtr->fsPtr->listVolumesProc != NULL)) { - int numVolumes; + Tcl_Size numVolumes; Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc(); if (thisFsVolumes != NULL) { @@ -4010,16 +4005,16 @@ TclFSNonnativePathType( * Tcl_Panic seems a bit excessive. */ - numVolumes = -1; + numVolumes = TCL_INDEX_NONE; } while (numVolumes > 0) { Tcl_Obj *vol; - int len; + Tcl_Size len; const char *strVol; numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); - strVol = TclGetStringFromObj(vol,&len); + strVol = Tcl_GetStringFromObj(vol,&len); if (pathLen < len) { continue; } @@ -4180,7 +4175,7 @@ TclCrossFilesystemCopy( * Could not open an input channel. Why didn't the caller check this? */ - Tcl_Close(interp, out); + Tcl_CloseEx(interp, out, 0); goto done; } @@ -4197,8 +4192,8 @@ TclCrossFilesystemCopy( * If the copy failed, assume that copy channel left an error message. */ - Tcl_Close(interp, in); - Tcl_Close(interp, out); + Tcl_CloseEx(interp, in, 0); + Tcl_CloseEx(interp, out, 0); /* * Set modification date of copied file. @@ -4377,14 +4372,14 @@ Tcl_FSRemoveDirectory( Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); if (cwdPtr != NULL) { const char *cwdStr, *normPathStr; - int cwdLen, normLen; + Tcl_Size cwdLen, normLen; Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPath != NULL) { - normPathStr = TclGetStringFromObj(normPath, &normLen); - cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen); + normPathStr = Tcl_GetStringFromObj(normPath, &normLen); + cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, - (size_t) normLen) == 0)) { + normLen) == 0)) { /* * The cwd is inside the directory to be removed. Change * the cwd to [file dirname $path]. @@ -4465,7 +4460,7 @@ Tcl_FSGetFileSystemForPath( * corresponding filesystem is found. */ for (; fsRecPtr!=NULL ; fsRecPtr=fsRecPtr->nextPtr) { - ClientData clientData = NULL; + void *clientData = NULL; if (fsRecPtr->fsPtr->pathInFilesystemProc == NULL) { continue; @@ -4522,9 +4517,9 @@ Tcl_FSGetNativePath( static void NativeFreeInternalRep( - ClientData clientData) + void *clientData) { - ckfree(clientData); + Tcl_Free(clientData); } /* diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 01d3c94..a60093a 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -41,7 +41,8 @@ const Tcl_ObjType tclIndexType = { FreeIndex, /* freeIntRepProc */ DupIndex, /* dupIntRepProc */ UpdateStringOfIndex, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -67,76 +68,7 @@ typedef struct { #define NEXT_ENTRY(table, offset) \ (&(STRING_AT(table, offset))) #define EXPAND_OF(indexRep) \ - (((indexRep)->index >= 0) ? STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) : "") - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetIndexFromObj -- - * - * This function looks up an object's value in a table of strings and - * returns the index of the matching string, if any. - * - * Results: - * If the value of objPtr is identical to or a unique abbreviation for - * one of the entries in tablePtr, then the return value is TCL_OK and the - * index of the matching entry is stored at *indexPtr. If there isn't a - * proper match, then TCL_ERROR is returned and an error message is left - * in interp's result (unless interp is NULL). The msg argument is used - * in the error message; for example, if msg has the value "option" then - * the error message will say something flag 'bad option "foo": must be - * ...' - * - * Side effects: - * The result of the lookup is cached as the internal rep of objPtr, so - * that repeated lookups can be done quickly. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_GetIndexFromObj -int -Tcl_GetIndexFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* Object containing the string to lookup. */ - const char *const *tablePtr, /* Array of strings to compare against the - * value of objPtr; last entry must be NULL - * and there must not be duplicate entries. */ - const char *msg, /* Identifying word to use in error - * messages. */ - int flags, /* 0 or TCL_EXACT */ - int *indexPtr) /* Place to store resulting integer index. */ -{ - if (!(flags & TCL_INDEX_TEMP_TABLE)) { - - /* - * See if there is a valid cached result from a previous lookup (doing the - * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in - * the common case where the result is cached). - */ - - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclIndexType); - - if (irPtr) { - IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; - - /* - * Here's hoping we don't get hit by unfortunate packing constraints - * on odd platforms like a Cray PVP... - */ - - if (indexRep->tablePtr == (void *)tablePtr - && indexRep->offset == sizeof(char *)) { - *indexPtr = indexRep->index; - return TCL_OK; - } - } - } - return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), - msg, flags, indexPtr); -} -#endif /* TCL_NO_DEPRECATED */ + (((indexRep)->index != TCL_INDEX_NONE) ? STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) : "") /* *---------------------------------------------------------------------- @@ -194,14 +126,14 @@ GetIndexFromObjList( * Build a string table from the list. */ - tablePtr = (const char **)ckalloc((objc + 1) * sizeof(char *)); + tablePtr = (const char **)Tcl_Alloc((objc + 1) * sizeof(char *)); for (t = 0; t < objc; t++) { if (objv[t] == objPtr) { /* * An exact match is always chosen, so we can stop here. */ - ckfree(tablePtr); + Tcl_Free(tablePtr); *indexPtr = t; return TCL_OK; } @@ -213,7 +145,7 @@ GetIndexFromObjList( result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), msg, flags | TCL_INDEX_TEMP_TABLE, indexPtr); - ckfree(tablePtr); + Tcl_Free(tablePtr); return result; } @@ -269,9 +201,13 @@ Tcl_GetIndexFromObjStruct( IndexRep *indexRep; const Tcl_ObjInternalRep *irPtr; - /* Protect against invalid values, like -1 or 0. */ if (offset < (Tcl_Size)sizeof(char *)) { - offset = (Tcl_Size)sizeof(char *); + if (interp) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Invalid %s value %" TCL_SIZE_MODIFIER "d.", + "struct offset", offset)); + } + return TCL_ERROR; } /* * See if there is a valid cached result from a previous lookup. @@ -283,7 +219,7 @@ Tcl_GetIndexFromObjStruct( indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; if ((indexRep->tablePtr == tablePtr) && (indexRep->offset == offset) - && (indexRep->index >= 0)) { + && (indexRep->index != TCL_INDEX_NONE)) { index = indexRep->index; goto uncachedDone; } @@ -346,14 +282,14 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (objPtr && (index >= 0) && !(flags & TCL_INDEX_TEMP_TABLE)) { + if (objPtr && (index != TCL_INDEX_NONE) && !(flags & TCL_INDEX_TEMP_TABLE)) { irPtr = TclFetchInternalRep(objPtr, &tclIndexType); if (irPtr) { indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; } else { Tcl_ObjInternalRep ir; - indexRep = (IndexRep*)ckalloc(sizeof(IndexRep)); + indexRep = (IndexRep*)Tcl_Alloc(sizeof(IndexRep)); ir.twoPtrValue.ptr1 = indexRep; Tcl_StoreInternalRep(objPtr, &tclIndexType, &ir); } @@ -480,7 +416,7 @@ DupIndex( Tcl_Obj *dupPtr) { Tcl_ObjInternalRep ir; - IndexRep *dupIndexRep = (IndexRep *)ckalloc(sizeof(IndexRep)); + IndexRep *dupIndexRep = (IndexRep *)Tcl_Alloc(sizeof(IndexRep)); memcpy(dupIndexRep, TclFetchInternalRep(srcPtr, &tclIndexType)->twoPtrValue.ptr1, sizeof(IndexRep)); @@ -510,7 +446,7 @@ static void FreeIndex( Tcl_Obj *objPtr) { - ckfree(TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1); + Tcl_Free(TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1); objPtr->typePtr = NULL; } @@ -572,7 +508,7 @@ PrefixMatchObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int flags = 0, result, index; + int flags = 0, result; Tcl_Size errorLength, i; Tcl_Obj *errorPtr = NULL; const char *message = "option"; @@ -582,7 +518,7 @@ PrefixMatchObjCmd( }; enum matchOptionsEnum { PRFMATCH_ERROR, PRFMATCH_EXACT, PRFMATCH_MESSAGE - }; + } index; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? table string"); @@ -594,7 +530,7 @@ PrefixMatchObjCmd( sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum matchOptionsEnum) index) { + switch (index) { case PRFMATCH_EXACT: flags |= TCL_EXACT; break; @@ -711,10 +647,10 @@ PrefixAllObjCmd( return result; } resultPtr = Tcl_NewListObj(0, NULL); - string = TclGetStringFromObj(objv[2], &length); + string = Tcl_GetStringFromObj(objv[2], &length); for (t = 0; t < tableObjc; t++) { - elemString = TclGetStringFromObj(tableObjv[t], &elemLength); + elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); /* * A prefix cannot match if it is longest. @@ -768,13 +704,13 @@ PrefixLongestObjCmd( if (result != TCL_OK) { return result; } - string = TclGetStringFromObj(objv[2], &length); + string = Tcl_GetStringFromObj(objv[2], &length); resultString = NULL; resultLength = 0; for (t = 0; t < tableObjc; t++) { - elemString = TclGetStringFromObj(tableObjv[t], &elemLength); + elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); /* * First check if the prefix string matches the element. A prefix @@ -883,29 +819,6 @@ Tcl_WrongNumArgs( Interp *iPtr = (Interp *)interp; const char *elementStr; - /* - * [incr Tcl] does something fairly horrific when generating error - * messages for its ensembles; it passes the whole set of ensemble - * arguments as a list in the first argument. This means that this code - * causes a problem in iTcl if it attempts to correctly quote all - * arguments, which would be the correct thing to do. We work around this - * nasty behaviour for now, and hope that we can remove it all in the - * future... - */ - -#ifndef AVOID_HACKS_FOR_ITCL - int isFirst = 1; /* Special flag used to inhibit the treating - * of the first word as a list element so the - * hacky way Itcl generates error messages for - * its ensembles will still work. [Bug - * 1066837] */ -# define MAY_QUOTE_WORD (!isFirst) -# define AFTER_FIRST_WORD (isFirst = 0) -#else /* !AVOID_HACKS_FOR_ITCL */ -# define MAY_QUOTE_WORD 1 -# define AFTER_FIRST_WORD (void) 0 -#endif /* AVOID_HACKS_FOR_ITCL */ - TclNewObj(objPtr); if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) { iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; @@ -959,12 +872,12 @@ Tcl_WrongNumArgs( elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); } else { - elementStr = TclGetStringFromObj(origObjv[i], &elemLen); + elementStr = Tcl_GetStringFromObj(origObjv[i], &elemLen); } flags = 0; len = TclScanElement(elementStr, elemLen, &flags); - if (MAY_QUOTE_WORD && len != elemLen) { + if (len != elemLen) { char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1); len = TclConvertElement(elementStr, elemLen, @@ -975,8 +888,6 @@ Tcl_WrongNumArgs( Tcl_AppendToObj(objPtr, elementStr, elemLen); } - AFTER_FIRST_WORD; - /* * Add a space if the word is not the last one (which has a * moderately complex condition here). @@ -1011,11 +922,11 @@ Tcl_WrongNumArgs( * Quote the argument if it contains spaces (Bug 942757). */ - elementStr = TclGetStringFromObj(objv[i], &elemLen); + elementStr = Tcl_GetStringFromObj(objv[i], &elemLen); flags = 0; len = TclScanElement(elementStr, elemLen, &flags); - if (MAY_QUOTE_WORD && len != elemLen) { + if (len != elemLen) { char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1); len = TclConvertElement(elementStr, elemLen, @@ -1027,8 +938,6 @@ Tcl_WrongNumArgs( } } - AFTER_FIRST_WORD; - /* * Append a space character (" ") if there is more text to follow * (either another element from objv, or the message string). @@ -1051,8 +960,6 @@ Tcl_WrongNumArgs( Tcl_AppendStringsToObj(objPtr, "\"", (char *)NULL); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL); Tcl_SetObjResult(interp, objPtr); -#undef MAY_QUOTE_WORD -#undef AFTER_FIRST_WORD } /* @@ -1123,7 +1030,7 @@ Tcl_ParseArgsObjv( */ nrem = 1; - leftovers = (Tcl_Obj **)ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); + leftovers = (Tcl_Obj **)Tcl_Alloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); leftovers[0] = objv[0]; } else { nrem = 0; @@ -1141,7 +1048,7 @@ Tcl_ParseArgsObjv( curArg = objv[srcIndex]; srcIndex++; objc--; - str = TclGetStringFromObj(curArg, &length); + str = Tcl_GetStringFromObj(curArg, &length); if (length > 0) { c = str[1]; } else { @@ -1265,10 +1172,16 @@ Tcl_ParseArgsObjv( break; } case TCL_ARGV_GENFUNC: { + + if (objc > INT_MAX) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "too many (%" TCL_SIZE_MODIFIER "d) arguments for TCL_ARGV_GENFUNC", objc)); + goto error; + } Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *) infoPtr->srcPtr; - objc = handlerProc(infoPtr->clientData, interp, objc, + objc = handlerProc(infoPtr->clientData, interp, (int)objc, &objv[srcIndex], infoPtr->dstPtr); if (objc < 0) { goto error; @@ -1307,7 +1220,7 @@ Tcl_ParseArgsObjv( } leftovers[nrem] = NULL; *objcPtr = nrem++; - *remObjv = (Tcl_Obj **)ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *)); + *remObjv = (Tcl_Obj **)Tcl_Realloc(leftovers, nrem * sizeof(Tcl_Obj *)); return TCL_OK; /* @@ -1320,7 +1233,7 @@ Tcl_ParseArgsObjv( "\"%s\" option requires an additional argument", str)); error: if (leftovers != NULL) { - ckfree(leftovers); + Tcl_Free(leftovers); } return TCL_ERROR; } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index e6e06d8..ad37a0f 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -37,11 +37,11 @@ declare 6 { declare 7 { Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src, char *dst) } -declare 8 {deprecated {}} { - int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, - Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) -} - +# Removed in 9.0: +#declare 8 { +# int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, +# Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) +#} # TclCreatePipeline unofficially exported for use by BLT. declare 9 { Tcl_Size TclCreatePipeline(Tcl_Interp *interp, Tcl_Size argc, const char **argv, @@ -90,13 +90,14 @@ declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } -declare 34 {deprecated {Use Tcl_GetIntForIndex}} { - int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, - int endValue, int *indexPtr) -} -declare 37 {deprecated {}} { - int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName) -} +# Removed in 9.0: +#declare 34 { +# int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, +# int endValue, int *indexPtr) +#} +#declare 37 { +# int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName) +#} declare 38 { int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, @@ -115,30 +116,36 @@ declare 41 { declare 42 { const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } -declare 44 {deprecated {}} { - int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr) +declare 43 { + Tcl_ObjCmdProc2 *TclGetObjInterpProc2(void) } +# Removed in 9.0: +#declare 44 { +# int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr) +#} declare 45 { int TclHideUnsafeCommands(Tcl_Interp *interp) } declare 46 { int TclInExit(void) } -declare 50 {deprecated {}} { - void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, - Namespace *nsPtr) -} +# Removed in 9.0: +#declare 50 { +# void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, +# Namespace *nsPtr) +#} declare 51 { int TclInterpInit(Tcl_Interp *interp) } -declare 53 {deprecated {}} { - int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp, - Tcl_Size argc, const char **argv) -} -declare 54 {deprecated {}} { - int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp, - Tcl_Size 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) } @@ -156,10 +163,11 @@ declare 61 { declare 62 { int TclObjCommandComplete(Tcl_Obj *cmdPtr) } -declare 63 {deprecated {}} { - int TclObjInterpProc(void *clientData, Tcl_Interp *interp, - Tcl_Size 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, Tcl_Size objc, Tcl_Obj *const objv[], int flags) @@ -171,21 +179,23 @@ declare 74 { void TclpFree(void *ptr) } declare 75 { - unsigned long TclpGetClicks(void) + unsigned long long TclpGetClicks(void) } declare 76 { - unsigned long TclpGetSeconds(void) -} -declare 77 {deprecated {}} { - void TclpGetTime(Tcl_Time *time) + unsigned long long TclpGetSeconds(void) } +# Removed in 9.0: +#declare 77 { +# void TclpGetTime(Tcl_Time *time) +#} declare 81 { void *TclpRealloc(void *ptr, TCL_HASH_TYPE size) } -declare 88 {deprecated {}} { - char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp, - const char *name1, const char *name2, int flags) -} +# Removed in 9.0: +#declare 88 { +# char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp, +# const char *name1, const char *name2, int flags) +#} declare 89 { int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd) @@ -211,9 +221,10 @@ declare 97 { declare 98 { int TclServiceIdle(void) } -declare 101 {deprecated {Use Tcl_SetPreInitScript}} { - const char *TclSetPreInitScript(const char *string) -} +# Removed in 9.0: +#declare 101 { +# const char *TclSetPreInitScript(const char *string) +#} declare 102 { void TclSetupEnv(Tcl_Interp *interp) } @@ -221,9 +232,10 @@ declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -declare 104 {deprecated {}} { - int TclSockMinimumBuffersOld(int sock, int size) -} +# Removed in 9.0: +#declare 104 { +# int TclSockMinimumBuffersOld(int sock, int size) +#} declare 108 { void TclTeardownNamespace(Namespace *nsPtr) } @@ -242,29 +254,30 @@ declare 111 { Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } -declare 112 {deprecated {Use Tcl_AppendExportList}} { - int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - Tcl_Obj *objPtr) -} -declare 113 {deprecated {Use Tcl_CreateNamespace}} { - Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name, - void *clientData, Tcl_NamespaceDeleteProc *deleteProc) -} -declare 114 {deprecated {Use Tcl_DeleteNamespace}} { - void TclDeleteNamespace(Tcl_Namespace *nsPtr) -} -declare 115 {deprecated {Use Tcl_Export}} { - int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *pattern, int resetListFirst) -} -declare 116 {deprecated {Use Tcl_FindCommand}} { - Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, - Tcl_Namespace *contextNsPtr, int flags) -} -declare 117 {deprecated {Use Tcl_FindNamespace}} { - Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name, - Tcl_Namespace *contextNsPtr, int flags) -} +# Removed in 9.0: +#declare 112 { +# int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +# Tcl_Obj *objPtr) +#} +#declare 113 { +# Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name, +# void *clientData, Tcl_NamespaceDeleteProc *deleteProc) +#} +#declare 114 { +# void TclDeleteNamespace(Tcl_Namespace *nsPtr) +#} +#declare 115 { +# int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +# const char *pattern, int resetListFirst) +#} +#declare 116 { +# Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, +# Tcl_Namespace *contextNsPtr, int flags) +#} +#declare 117 { +# Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name, +# Tcl_Namespace *contextNsPtr, int flags) +#} declare 118 { int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo) @@ -277,31 +290,33 @@ declare 120 { Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } -declare 121 {deprecated {Use Tcl_ForgetImport}} { - int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *pattern) -} -declare 122 {deprecated {Use Tcl_GetCommandFromObj}} { - Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -} -declare 123 {deprecated {Use Tcl_GetCommandFullName}} { - void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, - Tcl_Obj *objPtr) -} -declare 124 {deprecated {Use Tcl_GetCurrentNamespace}} { - Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp) -} -declare 125 {deprecated {Use Tcl_GetGlobalNamespace}} { - Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp) -} +# Removed in 9.0: +#declare 121 { +# int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +# const char *pattern) +#} +#declare 122 { +# Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +#} +#declare 123 { +# void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, +# Tcl_Obj *objPtr) +#} +#declare 124 { +# Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp) +#} +#declare 125 { +# Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp) +#} declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } -declare 127 {deprecated {Use }} { - int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *pattern, int allowOverwrite) -} +# Removed in 9.0: +#declare 127 { +# int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +# const char *pattern, int allowOverwrite) +#} declare 128 { void Tcl_PopCallFrame(Tcl_Interp *interp) } @@ -317,12 +332,14 @@ declare 131 { Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } -declare 132 {deprecated {}} { - int TclpHasSockets(Tcl_Interp *interp) -} -declare 133 {deprecated {}} { - struct tm *TclpGetDate(const time_t *time, int useGMT) -} +# Removed in 9.0: +#declare 132 { +# int TclpHasSockets(Tcl_Interp *interp) +#} +# Removed in 9.0: +#declare 133 { +# struct tm *TclpGetDate(const time_t *time, int useGMT) +#} declare 138 { const char *TclGetEnv(const char *name, Tcl_DString *valuePtr) } @@ -364,12 +381,6 @@ declare 151 { void TclRegExpRangeUniChar(Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr) } -declare 152 { - void TclSetLibraryPath(Tcl_Obj *pathPtr) -} -declare 153 { - Tcl_Obj *TclGetLibraryPath(void) -} declare 156 { void TclRegError(Tcl_Interp *interp, const char *msg, int status) @@ -377,12 +388,13 @@ declare 156 { declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -declare 158 {deprecated {use public Tcl_SetStartupScript()}} { - void TclSetStartupScriptFileName(const char *filename) -} -declare 159 {deprecated {use public Tcl_GetStartupScript()}} { - const char *TclGetStartupScriptFileName(void) -} +# Removed in 9.0: +#declare 158 { +# void TclSetStartupScriptFileName(const char *filename) +#} +#declare 159 { +# const char *TclGetStartupScriptFileName(void) +#} declare 161 { int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, @@ -420,15 +432,16 @@ declare 166 { Tcl_Size index, Tcl_Obj *valuePtr) } -declare 167 {deprecated {use public Tcl_SetStartupScript()}} { - void TclSetStartupScriptPath(Tcl_Obj *pathPtr) -} -declare 168 {deprecated {use public Tcl_GetStartupScript()}} { - Tcl_Obj *TclGetStartupScriptPath(void) -} +# Removed in 9.0: +#declare 167 { +# void TclSetStartupScriptPath(Tcl_Obj *pathPtr) +#} +#declare 168 { +# Tcl_Obj *TclGetStartupScriptPath(void) +#} # variant of Tcl_UtfNcmp that takes n as bytes, not chars declare 169 { - int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n) + int TclpUtfNcmp2(const void *s1, const void *s2, size_t n) } declare 170 { int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, @@ -458,18 +471,19 @@ declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -declare 178 {deprecated {}} { - void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) -} -declare 179 {deprecated {}} { - Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr) -} -declare 182 {deprecated {}} { - struct tm *TclpLocaltime(const time_t *clock) -} -declare 183 {deprecated {}} { - struct tm *TclpGmtime(const time_t *clock) -} +# Removed in 9.0: +#declare 178 { +# void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) +#} +#declare 179 { +# Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr) +#} +#declare 182 { +# struct tm *TclpLocaltime(const time_t *clock) +#} +#declare 183 { +# struct tm *TclpGmtime(const time_t *clock) +#} # For the new "Thread Storage" subsystem. @@ -595,9 +609,10 @@ declare 234 { declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } -declare 236 {deprecated {use Tcl_BackgroundException}} { - void TclBackgroundException(Tcl_Interp *interp, int code) -} +# Removed in 9.0: +#declare 236 { +# void TclBackgroundException(Tcl_Interp *interp, int code) +#} # TIP #285: Script cancellation support. declare 237 { @@ -709,198 +724,68 @@ declare 261 { interface tclIntPlat ################################ -# Windows specific functions +# Platform specific functions -declare 0 win { - void TclWinConvertError(DWORD errCode) -} -declare 1 win { - void TclWinConvertWSAError(DWORD errCode) -} -declare 2 win { - struct servent *TclWinGetServByName(const char *nm, - const char *proto) -} -declare 3 win { - int TclWinGetSockOpt(SOCKET s, int level, int optname, - char *optval, int *optlen) -} -declare 4 win { - HINSTANCE TclWinGetTclInstance(void) -} -declare 5 win { - int TclUnixWaitForFile(int fd, int mask, int timeout) -} -declare 6 win { - unsigned short TclWinNToHS(unsigned short ns) -} -declare 7 win { - int TclWinSetSockOpt(SOCKET s, int level, int optname, - const char *optval, int optlen) -} -declare 8 win { - Tcl_Size TclpGetPid(Tcl_Pid pid) -} -declare 9 win { - int TclWinGetPlatformId(void) -} -declare 10 win { - Tcl_DirEntry *TclpReaddir(TclDIR *dir) -} - -# Pipe channel functions - -declare 11 win { - void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) -} -declare 12 win { +# Removed in 9.0 +#declare 0 {unix win} { +# void TclWinConvertError(unsigned errCode) +#} +declare 1 { int TclpCloseFile(TclFile file) } -declare 13 win { +declare 2 { Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) + TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr) } -declare 14 win { +declare 3 { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } -declare 15 win { - int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, TclFile outputFile, - TclFile errorFile, Tcl_Pid *pidPtr) -} -declare 16 win { - int TclpIsAtty(int fd) +declare 4 { + void *TclWinGetTclInstance(void) } -declare 17 win { - int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, int dontCopyAtts) +declare 5 { + int TclUnixWaitForFile(int fd, int mask, int timeout) } -declare 18 win { +declare 6 { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } -declare 19 win { +declare 7 { TclFile TclpOpenFile(const char *fname, int mode) } -declare 20 win { - void TclWinAddProcess(void *hProcess, Tcl_Size id) -} -declare 21 win { - char *TclpInetNtoa(struct in_addr addr) +declare 8 { + Tcl_Size TclpGetPid(Tcl_Pid pid) } -declare 22 win { +declare 9 { TclFile TclpCreateTempFile(const char *contents) } -declare 24 win { - char *TclWinNoBackslash(char *path) -} -declare 26 win { - void TclWinSetInterfaces(int wide) -} -declare 27 win { - void TclWinFlushDirtyChannels(void) -} -declare 28 win { - void TclWinResetInterfaces(void) -} - -################################ -# Unix specific functions - -# Pipe channel functions - -declare 0 unix { +declare 11 { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } -declare 1 unix { - int TclpCloseFile(TclFile file) -} -declare 2 unix { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) -} -declare 3 unix { - int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) -} -declare 4 unix { - int TclpCreateProcess(Tcl_Interp *interp, int argc, +declare 15 { + int TclpCreateProcess(Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } -declare 5 unix { - int TclUnixWaitForFile_(int fd, int mask, int timeout) -} -declare 6 unix { - TclFile TclpMakeFile(Tcl_Channel channel, int direction) -} -declare 7 unix { - TclFile TclpOpenFile(const char *fname, int mode) -} -declare 8 unix { - int TclUnixWaitForFile(int fd, int mask, int timeout) -} - -# Added in 8.1: - -declare 9 unix { - TclFile TclpCreateTempFile(const char *contents) -} - -# Added in 8.4: - -declare 10 unix { - Tcl_DirEntry *TclpReaddir(TclDIR *dir) -} -# Slots 11 and 12 are forwarders for functions that were promoted to -# generic Stubs -declare 11 unix { - struct tm *TclpLocaltime_unix(const time_t *clock) -} -declare 12 unix { - struct tm *TclpGmtime_unix(const time_t *clock) -} -declare 13 unix { - char *TclpInetNtoa(struct in_addr addr) +declare 16 { + int TclpIsAtty(int fd) } - -# Added in 8.5: - -declare 14 unix { +declare 17 { int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts) } - -################################ -# Mac OS X specific functions - -declare 15 {unix macosx} { - int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr) -} -declare 16 {unix macosx} { - int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj *attributePtr) -} -declare 17 {unix macosx} { - int TclMacOSXCopyFileAttributes(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr) -} -declare 18 {unix macosx} { - int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, - const char *fileName, Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types) +declare 20 { + void TclWinAddProcess(void *hProcess, Tcl_Size id) } -declare 19 {unix macosx} { - void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) +declare 24 { + char *TclWinNoBackslash(char *path) } -declare 22 {unix macosx} { - TclFile TclpCreateTempFile_(const char *contents) +declare 27 { + void TclWinFlushDirtyChannels(void) } - -declare 29 {win unix} { +declare 29 { int TclWinCPUID(int index, int *regs) } -# Added in 8.6; core of TclpOpenTemporaryFile -declare 30 {win unix} { +declare 30 { int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) } diff --git a/generic/tclInt.h b/generic/tclInt.h index d29ea37..77eebb8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -26,20 +26,6 @@ #undef ACCEPT_NAN /* - * In Tcl 8.7, stop supporting special hacks for legacy Itcl 3. - * Itcl 4 doesn't need them. Itcl 3 can be updated to not need them - * using the Tcl(Init|Reset)RewriteEnsemble() routines in all Tcl 8.6+ - * releases. Perhaps Tcl 8.7 will add even better public interfaces - * supporting all the re-invocation mechanisms extensions like Itcl 3 - * need. As an absolute last resort, folks who must make Itcl 3 work - * unchanged with Tcl 8.7 can remove this line to regain the migration - * support. Tcl 9 will no longer offer even that option. - */ - -#define AVOID_HACKS_FOR_ITCL 1 - - -/* * Used to tag functions that are only to be visible within the module being * built and not outside it (where this is supported by the linker). * Also used in the platform-specific *Port.h files. @@ -79,6 +65,7 @@ #include <stdio.h> #include <ctype.h> +#include <stdarg.h> #include <stdlib.h> #include <stdint.h> #ifdef NO_STRING_H @@ -212,9 +199,6 @@ typedef struct Tcl_ResolverInfo { * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path * - Bug #631741 - do not use special namespace or interp resolvers - * - * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag - * (Bug #835020) */ #define TCL_AVOID_RESOLVERS 0x40000 @@ -229,15 +213,18 @@ typedef struct Tcl_Ensemble Tcl_Ensemble; typedef struct NamespacePathEntry NamespacePathEntry; /* - * Special hashtable for variables: This is just a Tcl_HashTable with a nsPtr - * field added at the end, so that variables can find their namespace - * without having to copy a pointer in their struct by accessing them via - * their hPtr->tablePtr. + * Special hashtable for variables: This is just a Tcl_HashTable with nsPtr + * and arrayPtr fields added at the end so that variables can find their + * namespace and possibly containing array without having to copy a pointer in + * their struct by accessing them via their hPtr->tablePtr. */ typedef struct TclVarHashTable { Tcl_HashTable table; struct Namespace *nsPtr; +#if TCL_MAJOR_VERSION > 8 + struct Var *arrayPtr; +#endif /* TCL_MAJOR_VERSION > 8 */ } TclVarHashTable; /* @@ -287,7 +274,11 @@ typedef struct Namespace { * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif - unsigned long nsId; /* Unique id for the namespace. */ +#if TCL_MAJOR_VERSION > 8 + size_t nsId; /* Unique id for the namespace. */ +#else + unsigned long nsId; +#endif Tcl_Interp *interp; /* The interpreter containing this * namespace. */ int flags; /* OR-ed combination of the namespace status @@ -629,7 +620,7 @@ typedef struct Var { TclVarHashTable *tablePtr;/* For array variables, this points to * information about the hash table used to * implement the associative array. Points to - * ckalloc-ed data. */ + * Tcl_Alloc-ed data. */ struct Var *linkPtr; /* If this is a global variable being referred * to in a procedure, or a variable created by * "upvar", this field points to the @@ -670,6 +661,11 @@ typedef struct VarInHash { * through "upvar" and "global" commands, or * through references to variables in enclosing * namespaces. + * VAR_CONSTANT - 1 means this is a constant "variable", and + * cannot be written to by ordinary commands. + * Structurally, it's the same as a scalar when + * being read, but writes are rejected. Constants + * are not supported inside arrays. * * Flags that indicate the type and status of storage; none is set for * compiled local variables (Var structs). @@ -734,6 +730,7 @@ typedef struct VarInHash { /* Type of value (0 is scalar) */ #define VAR_ARRAY 0x1 #define VAR_LINK 0x2 +#define VAR_CONSTANT 0x10000 /* Type of storage (0 is compiled local) */ #define VAR_IN_HASHTABLE 0x4 @@ -768,13 +765,14 @@ typedef struct VarInHash { * MODULE_SCOPE void TclSetVarScalar(Var *varPtr); * MODULE_SCOPE void TclSetVarArray(Var *varPtr); * MODULE_SCOPE void TclSetVarLink(Var *varPtr); + * MODULE_SCOPE void TclSetVarConstant(Var *varPtr); * MODULE_SCOPE void TclSetVarArrayElement(Var *varPtr); * MODULE_SCOPE void TclSetVarUndefined(Var *varPtr); * MODULE_SCOPE void TclClearVarUndefined(Var *varPtr); */ #define TclSetVarScalar(varPtr) \ - (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK) + (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK|VAR_CONSTANT) #define TclSetVarArray(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_LINK) | VAR_ARRAY @@ -782,11 +780,14 @@ typedef struct VarInHash { #define TclSetVarLink(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_LINK +#define TclSetVarConstant(varPtr) \ + (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_CONSTANT + #define TclSetVarArrayElement(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT #define TclSetVarUndefined(varPtr) \ - (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK);\ + (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK|VAR_CONSTANT);\ (varPtr)->value.objPtr = NULL #define TclClearVarUndefined(varPtr) @@ -818,6 +819,7 @@ typedef struct VarInHash { * The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE int TclIsVarScalar(Var *varPtr); + * MODULE_SCOPE int TclIsVarConstant(Var *varPtr); * MODULE_SCOPE int TclIsVarLink(Var *varPtr); * MODULE_SCOPE int TclIsVarArray(Var *varPtr); * MODULE_SCOPE int TclIsVarUndefined(Var *varPtr); @@ -827,6 +829,14 @@ typedef struct VarInHash { * MODULE_SCOPE int TclIsVarResolved(Var *varPtr); */ +#define TclVarFindHiddenArray(varPtr,arrayPtr) \ + do { \ + if ((arrayPtr == NULL) && TclIsVarInHash(varPtr) && \ + (TclVarParentArray(varPtr) != NULL)) { \ + arrayPtr = TclVarParentArray(varPtr); \ + } \ + } while(0) + #define TclIsVarScalar(varPtr) \ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK)) @@ -836,6 +846,10 @@ typedef struct VarInHash { #define TclIsVarArray(varPtr) \ ((varPtr)->flags & VAR_ARRAY) +/* Implies scalar as well. */ +#define TclIsVarConstant(varPtr) \ + ((varPtr)->flags & VAR_CONSTANT) + #define TclIsVarUndefined(varPtr) \ ((varPtr)->value.objPtr == NULL) @@ -871,6 +885,9 @@ typedef struct VarInHash { ? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \ : NULL) +#define TclVarParentArray(varPtr) \ + ((TclVarHashTable *) ((VarInHash *) (varPtr))->entry.tablePtr)->arrayPtr + #define VarHashRefCount(varPtr) \ ((VarInHash *) (varPtr))->refCount @@ -882,20 +899,23 @@ typedef struct VarInHash { */ #define TclIsVarTricky(varPtr,trickyFlags) \ - ((varPtr)->flags & (VAR_ARRAY|VAR_LINK|trickyFlags)) + ( ((varPtr)->flags & (VAR_ARRAY|VAR_LINK|trickyFlags)) \ + || (TclIsVarInHash(varPtr) \ + && (TclVarParentArray(varPtr) != NULL) \ + && (TclVarParentArray(varPtr)->flags & (trickyFlags)))) #define TclIsVarDirectReadable(varPtr) \ ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ)) \ && (varPtr)->value.objPtr) #define TclIsVarDirectWritable(varPtr) \ - (!TclIsVarTricky(varPtr,VAR_TRACED_WRITE|VAR_DEAD_HASH)) + (!TclIsVarTricky(varPtr,VAR_TRACED_WRITE|VAR_DEAD_HASH|VAR_CONSTANT)) #define TclIsVarDirectUnsettable(varPtr) \ - (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH)) + (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH|VAR_CONSTANT)) #define TclIsVarDirectModifyable(varPtr) \ - ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE)) \ + ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_CONSTANT)) \ && (varPtr)->value.objPtr) #define TclIsVarDirectReadable2(varPtr, arrayPtr) \ @@ -954,10 +974,9 @@ typedef struct CompiledLocal { * Among others used to speed up var lookups. */ Tcl_Size frameIndex; /* Index in the array of compiler-assigned * variables in the procedure call frame. */ - int flags; /* Flag bits for the local variable. Same as - * the flags for the Var structure above, - * although only VAR_ARGUMENT, VAR_TEMPORARY, - * and VAR_RESOLVED make sense. */ +#if TCL_MAJOR_VERSION < 9 + int flags; +#endif Tcl_Obj *defValuePtr; /* Pointer to the default value of an * argument, if any. NULL if not an argument * or, if an argument, no default value. */ @@ -968,6 +987,12 @@ typedef struct CompiledLocal { * is marked by a unique tag during * compilation, and that same tag is used to * find the variable at runtime. */ +#if TCL_MAJOR_VERSION > 8 + int flags; /* Flag bits for the local variable. Same as + * the flags for the Var structure above, + * although only VAR_ARGUMENT, VAR_TEMPORARY, + * and VAR_RESOLVED make sense. */ +#endif char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If * the name is NULL, this will just be '\0'. * The actual size of this field will be large @@ -1025,7 +1050,11 @@ typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); typedef struct Trace { Tcl_Size level; /* Only trace commands at nesting level less * than or equal to this. */ +#if TCL_MAJOR_VERSION > 8 + Tcl_CmdObjTraceProc2 *proc; /* Procedure to call to trace command. */ +#else Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ +#endif void *clientData; /* Arbitrary value to pass to proc. */ struct Trace *nextPtr; /* Next in list of traces for this interp. */ int flags; /* Flags governing the trace - see @@ -1069,19 +1098,101 @@ typedef struct ActiveInterpTrace { #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 -MODULE_SCOPE Tcl_Obj *TclArithSeriesObjIndex(Tcl_Interp *, Tcl_Obj *, - Tcl_Size index); -MODULE_SCOPE Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp, - Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp, - Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, - Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); -MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp, - Tcl_Obj **arithSeriesObj, int useDoubles, - Tcl_Obj *startObj, Tcl_Obj *endObj, - Tcl_Obj *stepObj, Tcl_Obj *lenObj); +#if TCL_MAJOR_VERSION > 8 +#define TclObjTypeHasProc(objPtr, proc) (((objPtr)->typePtr \ + && ((offsetof(Tcl_ObjType, proc) < offsetof(Tcl_ObjType, version)) \ + || (offsetof(Tcl_ObjType, proc) < (objPtr)->typePtr->version))) ? \ + ((objPtr)->typePtr)->proc : NULL) + +MODULE_SCOPE Tcl_Size TclLengthOne(Tcl_Obj *); + + +/* + * Abstract List + * + * This structure provides the functions used in List operations to emulate a + * List for AbstractList types. + */ + + +static inline Tcl_Size +TclObjTypeLength(Tcl_Obj *objPtr) +{ + Tcl_ObjTypeLengthProc *proc = TclObjTypeHasProc(objPtr, lengthProc); + return proc(objPtr); +} +static inline int +TclObjTypeIndex( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Size index, + Tcl_Obj **elemObjPtr) +{ + Tcl_ObjTypeIndexProc *proc = TclObjTypeHasProc(objPtr, indexProc); + return proc(interp, objPtr, index, elemObjPtr); +} +static inline int +TclObjTypeSlice( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Size fromIdx, + Tcl_Size toIdx, + Tcl_Obj **newObjPtr) +{ + Tcl_ObjTypeSliceProc *proc = TclObjTypeHasProc(objPtr, sliceProc); + return proc(interp, objPtr, fromIdx, toIdx, newObjPtr); +} +static inline int +TclObjTypeReverse( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Obj **newObjPtr) +{ + Tcl_ObjTypeReverseProc *proc = TclObjTypeHasProc(objPtr, reverseProc); + return proc(interp, objPtr, newObjPtr); +} +static inline int +TclObjTypeGetElements( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Size *objCPtr, + Tcl_Obj ***objVPtr) +{ + Tcl_ObjTypeGetElements *proc = TclObjTypeHasProc(objPtr, getElementsProc); + return proc(interp, objPtr, objCPtr, objVPtr); +} +static inline Tcl_Obj* +TclObjTypeSetElement( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Size indexCount, + Tcl_Obj *const indexArray[], + Tcl_Obj *valueObj) +{ + Tcl_ObjTypeSetElement *proc = TclObjTypeHasProc(objPtr, setElementProc); + return proc(interp, objPtr, indexCount, indexArray, valueObj); +} +static inline int +TclObjTypeReplace( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Size first, + Tcl_Size numToDelete, + Tcl_Size numToInsert, + Tcl_Obj *const insertObjs[]) +{ + Tcl_ObjTypeReplaceProc *proc = TclObjTypeHasProc(objPtr, replaceProc); + return proc(interp, objPtr, first, numToDelete, numToInsert, insertObjs); +} +static inline int +TclObjTypeInOperator(Tcl_Interp *interp, struct Tcl_Obj *valueObj, + struct Tcl_Obj *listObj, int *boolResult) +{ + Tcl_ObjTypeInOperatorProc *proc = TclObjTypeHasProc(listObj, inOperProc); + return proc(interp, valueObj, listObj, boolResult); +} +#endif /* TCL_MAJOR_VERSION > 8 */ + /* * The structure below defines an entry in the assocData hash table which is @@ -1442,14 +1553,8 @@ struct CompileEnv; * reporting is deferred until the actual runtime, * because by then changes in the interp state may allow * the command to be successfully evaluated. - * TCL_OUT_LINE_COMPILE A source-compatible alias for TCL_ERROR, kept for the - * sake of old code only. */ -#ifndef TCL_NO_DEPRECATED -# define TCL_OUT_LINE_COMPILE TCL_ERROR -#endif - typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct Command *cmdPtr, struct CompileEnv *compEnvPtr); @@ -1750,9 +1855,6 @@ typedef struct Command { */ #define CMD_DYING 0x01 -#ifndef TCL_NO_DEPRECATED -# define CMD_IS_DELETED 0x01 /* Same as CMD_DYING */ -#endif #define CMD_TRACE_ACTIVE 0x02 #define CMD_HAS_EXEC_TRACES 0x04 #define CMD_COMPILES_EXPANDED 0x08 @@ -1836,41 +1938,31 @@ typedef struct AllocCache { typedef struct Interp { /* - * Note: the first three fields must match exactly the fields in a - * Tcl_Interp struct (see tcl.h). If you change one, be sure to change the - * other. - * - * The interpreter's result is held in both the string and the - * objResultPtr fields. These fields hold, respectively, the result's - * string or object value. The interpreter's result is always in the - * result field if that is non-empty, otherwise it is in objResultPtr. - * The two fields are kept consistent unless some C code sets - * interp->result directly. Programs should not access result and - * objResultPtr directly; instead, they should always get and set the - * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and - * Tcl_GetStringResult. See the SetResult man page for details. + * The first two fields were named "result" and "freeProc" in earlier + * versions of Tcl. They are no longer used within Tcl, and are no + * longer available to be accessed by extensions. However, they cannot + * be removed. Why? There is a deployed base of stub-enabled extensions + * that query the value of iPtr->stubTable. For them to continue to work, + * the location of the field "stubTable" within the Interp struct cannot + * change. The most robust way to assure that is to leave all fields up to + * that one undisturbed. */ - char *result; /* If the last command returned a string - * result, this points to it. Should not be - * accessed directly; see comment above. */ - Tcl_FreeProc *freeProc; /* Zero means a string result is statically - * allocated. TCL_DYNAMIC means string result - * was allocated with ckalloc and should be - * freed with ckfree. Other values give - * address of procedure to invoke to free the - * string result. Tcl_Eval must free it before - * executing next command. */ + const char *legacyResult; + void (*legacyFreeProc) (void); int errorLine; /* When TCL_ERROR is returned, this gives the * line number in the command where the error * occurred (1 means first line). */ const struct TclStubs *stubTable; - /* Pointer to the exported Tcl stub table. On - * previous versions of Tcl this is a pointer - * to the objResultPtr or a pointer to a - * buckets array in a hash table. We therefore - * have to do some careful checking before we - * can use this. */ + /* Pointer to the exported Tcl stub table. In + * ancient pre-8.1 versions of Tcl this was a + * pointer to the objResultPtr or a pointer to a + * buckets array in a hash table. Deployed stubs + * enabled extensions check for a NULL pointer value + * and for a TCL_STUBS_MAGIC value to verify they + * are not [load]ing into one of those pre-stubs + * interps. + */ TclHandle handle; /* Handle used to keep track of when this * interp is deleted. */ @@ -1883,6 +1975,9 @@ typedef struct Interp { void *interpInfo; /* Information used by tclInterp.c to keep * track of parent/child interps on a * per-interp basis. */ +#if TCL_MAJOR_VERSION > 8 + void (*optimizer)(void *envPtr); +#else union { void (*optimizer)(void *envPtr); Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The @@ -1891,6 +1986,7 @@ typedef struct Interp { * contains one optimizer, which can be * selectively overridden by extensions. */ } extra; +#endif /* * Information related to procedures and variables. See tclProc.c and * tclVar.c for usage. @@ -1919,20 +2015,7 @@ typedef struct Interp { Namespace *lookupNsPtr; /* Namespace to use ONLY on the next * TCL_EVAL_INVOKE call to Tcl_EvalObjv. */ - /* - * Information used by Tcl_AppendResult to keep track of partial results. - * See Tcl_AppendResult code for details. - */ - -#if !defined(TCL_NO_DEPRECATED) - char *appendResult; /* Storage space for results generated by - * Tcl_AppendResult. Ckalloc-ed. NULL means - * not yet allocated. */ - int appendAvl; /* Total amount of space available at - * partialResult. */ - int appendUsed; /* Number of non-null bytes currently stored - * at partialResult. */ -#else +#if TCL_MAJOR_VERSION < 9 char *appendResultDontUse; int appendAvlDontUse; int appendUsedDontUse; @@ -1960,7 +2043,9 @@ typedef struct Interp { * Normally zero, but may be set before * calling Tcl_Eval. See below for valid * values. */ +#if TCL_MAJOR_VERSION < 9 int unused1; /* No longer used (was termOffset) */ +#endif LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl * objects holding literals of scripts * compiled by the interpreter. Indexed by the @@ -1998,10 +2083,7 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ -#if !defined(TCL_NO_DEPRECATED) - char resultSpace[TCL_DSTRING_STATIC_SIZE+1]; - /* Static space holding small results. */ -#else +#if TCL_MAJOR_VERSION < 9 char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1]; #endif Tcl_Obj *objResultPtr; /* If the last command returned an object @@ -2660,12 +2742,20 @@ typedef struct ListRep { * WARNING: these macros eval their args more than once. */ +#if TCL_MAJOR_VERSION > 8 +#define TclGetBooleanFromObj(interp, objPtr, intPtr) \ + (((objPtr)->typePtr == &tclIntType \ + || (objPtr)->typePtr == &tclBooleanType) \ + ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ + : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) +#else #define TclGetBooleanFromObj(interp, objPtr, intPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : ((objPtr)->typePtr == &tclBooleanType) \ ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) +#endif #ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ @@ -2689,8 +2779,8 @@ typedef struct ListRep { : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) #define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ ((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \ - && ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (Tcl_WideUInt)(endValue + 1))) \ - ? ((*(idxPtr) = (Tcl_Size)(objPtr)->internalRep.wideValue), TCL_OK) \ + && ((objPtr)->internalRep.wideValue <= endValue)) \ + ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) /* @@ -2777,18 +2867,6 @@ typedef struct TclFileAttrProcs { typedef struct TclFile_ *TclFile; -/* - * The "globParameters" argument of the function TclGlob is an or'ed - * combination of the following values: - */ - -#ifndef TCL_NO_DEPRECATED -# define TCL_GLOBMODE_NO_COMPLAIN 1 -# define TCL_GLOBMODE_JOIN 2 -# define TCL_GLOBMODE_DIR 4 -# define TCL_GLOBMODE_TAILS 8 -#endif - typedef enum Tcl_PathPart { TCL_PATH_DIRNAME, TCL_PATH_TAIL, @@ -2809,17 +2887,6 @@ typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp, /* *---------------------------------------------------------------- - * Data structures related to procedures - *---------------------------------------------------------------- - */ - -#if !defined(TCL_NO_DEPRECATED) -typedef Tcl_CmdProc *TclCmdProcType; -typedef Tcl_ObjCmdProc *TclObjCmdProcType; -#endif - -/* - *---------------------------------------------------------------- * Data structures for process-global values. *---------------------------------------------------------------- */ @@ -2827,6 +2894,12 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType; typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); +#ifdef _WIN32 +# define TCLFSENCODING tclUtf8Encoding /* On Windows, all Unicode (except surrogates) are valid */ +#else +# define TCLFSENCODING NULL /* On Non-Windows, use the system encoding for validation checks */ +#endif + /* * A ProcessGlobalValue struct exists for each internal value in Tcl that is * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of @@ -2886,16 +2959,83 @@ typedef struct ProcessGlobalValue { */ #define ENCODING_PROFILE_MASK 0xFF000000 -#define ENCODING_PROFILE_GET(flags_) (((flags_) & TCL_ENCODING_PROFILE_STRICT) ? \ - TCL_ENCODING_PROFILE_STRICT : (((flags_) & ENCODING_PROFILE_MASK) ? \ - ((flags_) & ENCODING_PROFILE_MASK) : TCL_ENCODING_PROFILE_TCL8)) -#define ENCODING_PROFILE_SET(flags_, profile_) \ - do { \ - (flags_) &= ~(ENCODING_PROFILE_MASK|TCL_ENCODING_PROFILE_STRICT); \ - (flags_) |= (profile_) & (ENCODING_PROFILE_MASK|TCL_ENCODING_PROFILE_STRICT); \ +#define ENCODING_PROFILE_GET(flags_) ((flags_) & ENCODING_PROFILE_MASK) +#define ENCODING_PROFILE_SET(flags_, profile_) \ + do { \ + (flags_) &= ~ENCODING_PROFILE_MASK; \ + (flags_) |= ((profile_) & ENCODING_PROFILE_MASK);\ } while (0) /* + *---------------------------------------------------------------------- + * Common functions for calculating overallocation. Trivial but allows for + * experimenting with growth factors without having to change code in + * multiple places. See TclAttemptAllocElemsEx and similar for usage + * examples. Best to use those functions. Direct use of TclUpsizeAlloc / + * TclResizeAlloc is needed in special cases such as when total size of + * memory block is limited to less than TCL_SIZE_MAX. + * + *---------------------------------------------------------------------- + */ +static inline Tcl_Size +TclUpsizeAlloc(TCL_UNUSED(Tcl_Size) /* oldSize. For future experiments with + * some growth algorithms that use this + * information. */, + Tcl_Size needed, + Tcl_Size limit) +{ + /* assert (oldCapacity < needed <= limit) */ + if (needed < (limit - needed/2)) { + return needed + needed / 2; + } + else { + return limit; + } +} +static inline Tcl_Size TclUpsizeRetry(Tcl_Size needed, Tcl_Size lastAttempt) { + /* assert (needed < lastAttempt) */ + if (needed < lastAttempt - 1) { + /* (needed+lastAttempt)/2 but that formula may overflow Tcl_Size */ + return needed + (lastAttempt - needed) / 2; + } else { + return needed; + } +} +MODULE_SCOPE void *TclAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize, + Tcl_Size leadSize, Tcl_Size *capacityPtr); +MODULE_SCOPE void *TclReallocElemsEx(void *oldPtr, Tcl_Size elemCount, + Tcl_Size elemSize, Tcl_Size leadSize, + Tcl_Size *capacityPtr); +MODULE_SCOPE void *TclAttemptReallocElemsEx(void *oldPtr, + Tcl_Size elemCount, Tcl_Size elemSize, + Tcl_Size leadSize, Tcl_Size *capacityPtr); +/* Alloc elemCount elements of size elemSize with leadSize header + * returning actual capacity (in elements) in *capacityPtr. */ +static inline void *TclAttemptAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize, + Tcl_Size leadSize, Tcl_Size *capacityPtr) { + return TclAttemptReallocElemsEx( + NULL, elemCount, elemSize, leadSize, capacityPtr); +} +/* Alloc numByte bytes, returning actual capacity in *capacityPtr. */ +static inline void *TclAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr) { + return TclAllocElemsEx(numBytes, 1, 0, capacityPtr); +} +/* Alloc numByte bytes, returning actual capacity in *capacityPtr. */ +static inline void * +TclAttemptAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr) +{ + return TclAttemptAllocElemsEx(numBytes, 1, 0, capacityPtr); +} +/* Realloc numByte bytes, returning actual capacity in *capacityPtr. */ +static inline void *TclReallocEx(void *oldPtr, Tcl_Size numBytes, Tcl_Size *capacityPtr) { + return TclReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr); +} +/* Realloc numByte bytes, returning actual capacity in *capacityPtr. */ +static inline void *TclAttemptReallocEx(void *oldPtr, Tcl_Size numBytes, Tcl_Size *capacityPtr) { + return TclAttemptReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr); +} + +/* *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. *---------------------------------------------------------------- @@ -2935,17 +3075,14 @@ MODULE_SCOPE void *tclTimeClientData; MODULE_SCOPE const Tcl_ObjType tclBignumType; MODULE_SCOPE const Tcl_ObjType tclBooleanType; -MODULE_SCOPE const Tcl_ObjType tclByteArrayType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclIndexType; MODULE_SCOPE const Tcl_ObjType tclListType; -MODULE_SCOPE const Tcl_ObjType tclArithSeriesType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; -MODULE_SCOPE const Tcl_ObjType tclUniCharStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; @@ -3085,6 +3222,7 @@ struct Tcl_LoadHandle_ { *---------------------------------------------------------------- */ +#if TCL_MAJOR_VERSION > 8 MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, const unsigned char *bytes, Tcl_Size len); MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next, @@ -3115,8 +3253,6 @@ MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); MODULE_SCOPE int TclChannelGetBlockingMode(Tcl_Channel chan); MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *name, int index); -MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, - const char *value); MODULE_SCOPE int TclCheckEmptyString(Tcl_Obj *objPtr); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); @@ -3142,6 +3278,7 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); +MODULE_SCOPE Tcl_Size TclDictGetSize(Tcl_Obj *dictPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, Tcl_Size dictLength, const char **elementPtr, const char **nextPtr, @@ -3223,7 +3360,7 @@ MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, - TCL_HASH_TYPE *sizePtr); + Tcl_Size *sizePtr); MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *packageName); @@ -3239,6 +3376,8 @@ MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); MODULE_SCOPE Tcl_ObjCmdProc TclInfoGlobalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoLocalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoVarsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoConstsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoConstantCmd; MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); @@ -3264,6 +3403,7 @@ MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size indexCount, Tcl_Obj *const indexArray[]); +MODULE_SCOPE Tcl_Obj * TclListObjGetElement(Tcl_Obj *listObj, Tcl_Size index); /* TIP #280 */ MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, Tcl_Size line, Tcl_Size n, Tcl_Size *lines, Tcl_Obj *const *elems); @@ -3280,7 +3420,6 @@ MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); -MODULE_SCOPE int TclMakeSafe(Tcl_Interp *interp); MODULE_SCOPE Tcl_Size TclMaxListLength(const char *bytes, Tcl_Size numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, @@ -3308,10 +3447,14 @@ MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, MODULE_SCOPE Tcl_Size TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); +MODULE_SCOPE void TclUndoRefCount(Tcl_Obj *objPtr); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); +MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp, Tcl_Obj **arithSeriesPtr, + int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, + Tcl_Obj *stepObj, Tcl_Obj *lenObj); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, Tcl_Size len); MODULE_SCOPE void TclpAlertNotifier(void *clientData); @@ -3388,7 +3531,7 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, Tcl_Size reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); -MODULE_SCOPE TCL_HASH_TYPE TclScanElement(const char *string, Tcl_Size length, +MODULE_SCOPE Tcl_Size TclScanElement(const char *string, Tcl_Size length, char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); @@ -3432,6 +3575,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); @@ -3481,18 +3627,6 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); MODULE_SCOPE int TclIsZipfsPath(const char *path); MODULE_SCOPE void TclZipfsFinalize(void); -MODULE_SCOPE int *TclGetUnicodeFromObj(Tcl_Obj *, int *); -MODULE_SCOPE Tcl_Obj *TclNewUnicodeObj(const int *, int); -MODULE_SCOPE void TclAppendUnicodeToObj(Tcl_Obj *, const int *, int); -MODULE_SCOPE int TclUniCharNcasecmp(const int *, const int *, size_t); -MODULE_SCOPE int TclUniCharNcasememcmp(const void *, const void *, size_t); -MODULE_SCOPE int TclUniCharCaseMatch(const int *, const int *, int); -MODULE_SCOPE int TclUniCharNcmp(const int *, const int *, size_t); -MODULE_SCOPE int TclUniCharNmemcmp(const void *, const void *, size_t); -MODULE_SCOPE int TclUtfNcasememcmp(const void *s1, const void *s2, size_t n); -MODULE_SCOPE int TclUtfNmemcmp(const void *s1, const void *s2, size_t n); - - /* * Many parsing tasks need a common definition of whitespace. * Use this routine and macro to achieve that and place @@ -3515,9 +3649,6 @@ MODULE_SCOPE Tcl_ObjCmdProc Tcl_ApplyObjCmd; MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc Tcl_BreakObjCmd; -#if !defined(TCL_NO_DEPRECATED) -MODULE_SCOPE Tcl_ObjCmdProc Tcl_CaseObjCmd; -#endif MODULE_SCOPE Tcl_ObjCmdProc Tcl_CatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CdObjCmd; MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp); @@ -3529,6 +3660,7 @@ MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclClockOldscanObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CloseObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConcatObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ContinueObjCmd; MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, @@ -3642,6 +3774,7 @@ MODULE_SCOPE CompileProc TclCompileCatchCmd; MODULE_SCOPE CompileProc TclCompileClockClicksCmd; MODULE_SCOPE CompileProc TclCompileClockReadingCmd; MODULE_SCOPE CompileProc TclCompileConcatCmd; +MODULE_SCOPE CompileProc TclCompileConstCmd; MODULE_SCOPE CompileProc TclCompileContinueCmd; MODULE_SCOPE CompileProc TclCompileDictAppendCmd; MODULE_SCOPE CompileProc TclCompileDictCreateCmd; @@ -3868,6 +4001,19 @@ MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* + * TIP #542 + */ + +MODULE_SCOPE size_t TclUniCharLen(const Tcl_UniChar *uniStr); +MODULE_SCOPE int TclUniCharNcmp(const Tcl_UniChar *ucs, + const Tcl_UniChar *uct, size_t numChars); +MODULE_SCOPE int TclUniCharNcasecmp(const Tcl_UniChar *ucs, + const Tcl_UniChar *uct, size_t numChars); +MODULE_SCOPE int TclUniCharCaseMatch(const Tcl_UniChar *uniStr, + const Tcl_UniChar *uniPattern, int nocase); + + +/* * Just for the purposes of command-type registration. */ @@ -3903,6 +4049,7 @@ MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, int *codePtr, Tcl_Obj **msgObjPtr, Tcl_Obj **errorObjPtr); +MODULE_SCOPE int TclClose(Tcl_Interp *, Tcl_Channel chan); /* * TIP #508: [array default] @@ -3920,6 +4067,13 @@ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, int before, int after, int *indexPtr); MODULE_SCOPE Tcl_Size TclIndexDecode(int encoded, Tcl_Size endValue); +/* + * Error message utility functions + */ +MODULE_SCOPE int TclCommandWordLimitError(Tcl_Interp *interp, Tcl_Size count); + +#endif /* TCL_MAJOR_VERSION > 8 */ + /* Constants used in index value encoding routines. */ #define TCL_INDEX_END ((Tcl_Size)-2) #define TCL_INDEX_START ((Tcl_Size)0) @@ -4030,7 +4184,7 @@ TclScaleTime( TCL_DTRACE_OBJ_FREE(objPtr); \ if ((objPtr)->bytes \ && ((objPtr)->bytes != &tclEmptyString)) { \ - ckfree((objPtr)->bytes); \ + Tcl_Free((objPtr)->bytes); \ } \ (objPtr)->length = TCL_INDEX_NONE; \ TclFreeObjStorage(objPtr); \ @@ -4054,10 +4208,10 @@ TclScaleTime( */ # define TclAllocObjStorageEx(interp, objPtr) \ - (objPtr) = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj)) + (objPtr) = (Tcl_Obj *)Tcl_Alloc(sizeof(Tcl_Obj)) # define TclFreeObjStorageEx(interp, objPtr) \ - ckfree(objPtr) + Tcl_Free(objPtr) #undef USE_THREAD_ALLOC #undef USE_TCLALLOC @@ -4206,7 +4360,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, if ((len) == 0) { \ TclInitEmptyStringRep(objPtr); \ } else { \ - (objPtr)->bytes = (char *)ckalloc((len) + 1U); \ + (objPtr)->bytes = (char *)Tcl_Alloc((len) + 1U); \ memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ @@ -4216,7 +4370,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, ((((len) == 0) ? ( \ TclInitEmptyStringRep(objPtr) \ ) : ( \ - (objPtr)->bytes = (char *)attemptckalloc((len) + 1U), \ + (objPtr)->bytes = (char *)Tcl_AttemptAlloc((len) + 1U), \ (objPtr)->length = ((objPtr)->bytes) ? \ (memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)), \ (objPtr)->bytes[len] = '\0', (len)) : (-1) \ @@ -4237,11 +4391,6 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TclGetString(objPtr) \ ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr)) -#define TclGetStringFromObj(objPtr, lenPtr) \ - ((objPtr)->bytes \ - ? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \ - : (Tcl_GetStringFromObj)((objPtr), (lenPtr))) - /* *---------------------------------------------------------------- * Macro used by the Tcl core to clean out an object's internal @@ -4260,10 +4409,6 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->typePtr = NULL; \ } -#if !defined(TCL_NO_DEPRECATED) -# define TclFreeIntRep(objPtr) TclFreeInternalRep(objPtr) -#endif - /* *---------------------------------------------------------------- * Macro used by the Tcl core to clean out an object's string representation. @@ -4278,7 +4423,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, Tcl_Obj *_isobjPtr = (Tcl_Obj *)(objPtr); \ if (_isobjPtr->bytes != NULL) { \ if (_isobjPtr->bytes != &tclEmptyString) { \ - ckfree((char *)_isobjPtr->bytes); \ + Tcl_Free((char *)_isobjPtr->bytes); \ } \ _isobjPtr->bytes = NULL; \ } \ @@ -4366,32 +4511,22 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; #define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token) #endif -#define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token)) +/* TODO - code below does not check for integer overflow */ #define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \ do { \ - int _needed = (used) + (append); \ - if (_needed > TCL_MAX_TOKENS) { \ - Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded", \ - TCL_MAX_TOKENS); \ - } \ + Tcl_Size _needed = (used) + (append); \ if (_needed > (available)) { \ - int allocated = 2 * _needed; \ + Tcl_Size allocated = 2 * _needed; \ Tcl_Token *oldPtr = (tokenPtr); \ Tcl_Token *newPtr; \ if (oldPtr == (staticPtr)) { \ oldPtr = NULL; \ } \ - if (allocated > TCL_MAX_TOKENS) { \ - allocated = TCL_MAX_TOKENS; \ - } \ - newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \ + newPtr = (Tcl_Token *)Tcl_AttemptRealloc((char *) oldPtr, \ allocated * sizeof(Tcl_Token)); \ if (newPtr == NULL) { \ allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \ - if (allocated > TCL_MAX_TOKENS) { \ - allocated = TCL_MAX_TOKENS; \ - } \ - newPtr = (Tcl_Token *) ckrealloc((char *) oldPtr, \ + newPtr = (Tcl_Token *)Tcl_Realloc((char *) oldPtr, \ allocated * sizeof(Tcl_Token)); \ } \ (available) = allocated; \ @@ -4420,10 +4555,17 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; *---------------------------------------------------------------- */ +#if TCL_UTF_MAX > 3 #define TclUtfToUniChar(str, chPtr) \ (((UCHAR(*(str))) < 0x80) ? \ ((*(chPtr) = UCHAR(*(str))), 1) \ : Tcl_UtfToUniChar(str, chPtr)) +#else +#define TclUtfToUniChar(str, chPtr) \ + (((UCHAR(*(str))) < 0x80) ? \ + ((*(chPtr) = UCHAR(*(str))), 1) \ + : Tcl_UtfToChar16(str, chPtr)) +#endif /* *---------------------------------------------------------------- @@ -4440,12 +4582,12 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; #define TclNumUtfCharsM(numChars, bytes, numBytes) \ do { \ - Tcl_Size _count, _i = (numBytes); \ + Tcl_Size _count = 0, _i = (numBytes); \ unsigned char *_str = (unsigned char *) (bytes); \ while (_i > 0 && (*_str < 0xC0)) { _i--; _str++; } \ _count = (numBytes) - _i; \ if (_i) { \ - _count += TclNumUtfChars((bytes) + _count, _i); \ + _count += Tcl_NumUtfChars((bytes) + _count, _i); \ } \ (numChars) = _count; \ } while (0); @@ -4516,6 +4658,7 @@ MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init; MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; +MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init; /* @@ -4681,33 +4824,6 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; /* *---------------------------------------------------------------- - * Macros used by the Tcl core to test for some special double values. - * (deprecated) The ANSI C "prototypes" for these macros are: - * - * MODULE_SCOPE int TclIsInfinite(double d); - * MODULE_SCOPE int TclIsNaN(double d); - */ - -#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl) -# define TclIsInfinite(d) isinf(d) -# define TclIsNaN(d) isnan(d) -#endif - -/* - * Macro to use to find the offset of a field in astructure. - * Computes number of bytes from beginning of structure to a given field. - */ - -#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl) -# define TclOffset(type, field) ((int) offsetof(type, field)) -#endif -/* Workaround for platforms missing offsetof(), e.g. VC++ 6.0 */ -#ifndef offsetof -# define offsetof(type, field) ((size_t) ((char *) &((type *) 0)->field)) -#endif - -/* - *---------------------------------------------------------------- * Inline version of Tcl_GetCurrentNamespace and Tcl_GetGlobalNamespace. */ @@ -4726,7 +4842,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; #define TclCleanupCommandMacro(cmdPtr) \ do { \ if ((cmdPtr)->refCount-- <= 1) { \ - ckfree(cmdPtr); \ + Tcl_Free(cmdPtr); \ } \ } while (0) @@ -4739,7 +4855,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; (cmdPtr)->refCount++; \ if ((location) != NULL \ && (location--) <= 1) { \ - ckfree(((location))); \ + Tcl_Free(((location))); \ } \ (location) = (cmdPtr); \ } while (0) @@ -4902,8 +5018,8 @@ typedef struct NRE_callback { #define TCLNR_FREE(interp, ptr) TclSmallFreeEx((interp), (ptr)) #else #define TCLNR_ALLOC(interp, ptr) \ - ((ptr) = (void *)ckalloc(sizeof(NRE_callback))) -#define TCLNR_FREE(interp, ptr) ckfree(ptr) + ((ptr) = Tcl_Alloc(sizeof(NRE_callback))) +#define TCLNR_FREE(interp, ptr) Tcl_Free(ptr) #endif #if NRE_ENABLE_ASSERTS diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 3ebe2eb..9a64529 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -27,23 +27,6 @@ # endif #endif -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) -# define tclGetIntForIndex tcl_GetIntForIndex -/* Those macro's are especially for Itcl 3.4 compatibility */ -# define tclCreateNamespace tcl_CreateNamespace -# define tclDeleteNamespace tcl_DeleteNamespace -# define tclAppendExportList tcl_AppendExportList -# define tclExport tcl_Export -# define tclImport tcl_Import -# define tclForgetImport tcl_ForgetImport -# define tclGetCurrentNamespace_ tcl_GetCurrentNamespace -# define tclGetGlobalNamespace_ tcl_GetGlobalNamespace -# define tclFindNamespace tcl_FindNamespace -# define tclFindCommand tcl_FindCommand -# define tclGetCommandFromObj tcl_GetCommandFromObj -# define tclGetCommandFullName tcl_GetCommandFullName -#endif /* !defined(TCL_NO_DEPRECATED) */ - /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made @@ -75,11 +58,7 @@ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ EXTERN Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src, char *dst); -/* 8 */ -TCL_DEPRECATED("") -int TclCopyChannelOld(Tcl_Interp *interp, - Tcl_Channel inChan, Tcl_Channel outChan, - int toRead, Tcl_Obj *cmdPtr); +/* Slot 8 is reserved */ /* 9 */ EXTERN Tcl_Size TclCreatePipeline(Tcl_Interp *interp, Tcl_Size argc, const char **argv, Tcl_Pid **pidArrayPtr, @@ -130,16 +109,10 @@ EXTERN const char * TclGetExtension(const char *name); EXTERN int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* Slot 33 is reserved */ -/* 34 */ -TCL_DEPRECATED("Use Tcl_GetIntForIndex") -int TclGetIntForIndex(Tcl_Interp *interp, - Tcl_Obj *objPtr, int endValue, int *indexPtr); +/* Slot 34 is reserved */ /* Slot 35 is reserved */ /* Slot 36 is reserved */ -/* 37 */ -TCL_DEPRECATED("") -int TclGetLoadedPackages(Tcl_Interp *interp, - const char *targetName); +/* Slot 37 is reserved */ /* 38 */ EXTERN int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, @@ -157,11 +130,9 @@ EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command); /* 42 */ EXTERN const char * TclpGetUserHome(const char *name, Tcl_DString *bufferPtr); -/* Slot 43 is reserved */ -/* 44 */ -TCL_DEPRECATED("") -int TclGuessPackageName(const char *fileName, - Tcl_DString *bufPtr); +/* 43 */ +EXTERN Tcl_ObjCmdProc2 * TclGetObjInterpProc2(void); +/* Slot 44 is reserved */ /* 45 */ EXTERN int TclHideUnsafeCommands(Tcl_Interp *interp); /* 46 */ @@ -169,23 +140,12 @@ EXTERN int TclInExit(void); /* Slot 47 is reserved */ /* Slot 48 is reserved */ /* Slot 49 is reserved */ -/* 50 */ -TCL_DEPRECATED("") -void TclInitCompiledLocals(Tcl_Interp *interp, - CallFrame *framePtr, Namespace *nsPtr); +/* Slot 50 is reserved */ /* 51 */ EXTERN int TclInterpInit(Tcl_Interp *interp); /* Slot 52 is reserved */ -/* 53 */ -TCL_DEPRECATED("") -int TclInvokeObjectCommand(void *clientData, - Tcl_Interp *interp, Tcl_Size argc, - const char **argv); -/* 54 */ -TCL_DEPRECATED("") -int TclInvokeStringCommand(void *clientData, - Tcl_Interp *interp, Tcl_Size objc, - Tcl_Obj *const objv[]); +/* Slot 53 is reserved */ +/* Slot 54 is reserved */ /* 55 */ EXTERN Proc * TclIsProc(Command *cmdPtr); /* Slot 56 is reserved */ @@ -202,11 +162,7 @@ EXTERN int TclNeedSpace(const char *start, const char *end); EXTERN Tcl_Obj * TclNewProcBodyObj(Proc *procPtr); /* 62 */ EXTERN int TclObjCommandComplete(Tcl_Obj *cmdPtr); -/* 63 */ -TCL_DEPRECATED("") -int TclObjInterpProc(void *clientData, - Tcl_Interp *interp, Tcl_Size objc, - Tcl_Obj *const objv[]); +/* Slot 63 is reserved */ /* 64 */ EXTERN int TclObjInvoke(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); @@ -223,12 +179,10 @@ EXTERN void * TclpAlloc(TCL_HASH_TYPE size); /* 74 */ EXTERN void TclpFree(void *ptr); /* 75 */ -EXTERN unsigned long TclpGetClicks(void); +EXTERN unsigned long long TclpGetClicks(void); /* 76 */ -EXTERN unsigned long TclpGetSeconds(void); -/* 77 */ -TCL_DEPRECATED("") -void TclpGetTime(Tcl_Time *time); +EXTERN unsigned long long TclpGetSeconds(void); +/* Slot 77 is reserved */ /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ @@ -240,11 +194,7 @@ EXTERN void * TclpRealloc(void *ptr, TCL_HASH_TYPE size); /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ -/* 88 */ -TCL_DEPRECATED("") -char * TclPrecTraceProc(void *clientData, - Tcl_Interp *interp, const char *name1, - const char *name2, int flags); +/* Slot 88 is reserved */ /* 89 */ EXTERN int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); @@ -270,17 +220,13 @@ EXTERN void TclResetShadowedCmdRefs(Tcl_Interp *interp, EXTERN int TclServiceIdle(void); /* Slot 99 is reserved */ /* Slot 100 is reserved */ -/* 101 */ -TCL_DEPRECATED("Use Tcl_SetPreInitScript") -const char * TclSetPreInitScript(const char *string); +/* Slot 101 is reserved */ /* 102 */ EXTERN void TclSetupEnv(Tcl_Interp *interp); /* 103 */ EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); -/* 104 */ -TCL_DEPRECATED("") -int TclSockMinimumBuffersOld(int sock, int size); +/* Slot 104 is reserved */ /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -296,31 +242,12 @@ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); -/* 112 */ -TCL_DEPRECATED("Use Tcl_AppendExportList") -int TclAppendExportList(Tcl_Interp *interp, - Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); -/* 113 */ -TCL_DEPRECATED("Use Tcl_CreateNamespace") -Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp, - const char *name, void *clientData, - Tcl_NamespaceDeleteProc *deleteProc); -/* 114 */ -TCL_DEPRECATED("Use Tcl_DeleteNamespace") -void TclDeleteNamespace(Tcl_Namespace *nsPtr); -/* 115 */ -TCL_DEPRECATED("Use Tcl_Export") -int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *pattern, int resetListFirst); -/* 116 */ -TCL_DEPRECATED("Use Tcl_FindCommand") -Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, - Tcl_Namespace *contextNsPtr, int flags); -/* 117 */ -TCL_DEPRECATED("Use Tcl_FindNamespace") -Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp, - const char *name, - Tcl_Namespace *contextNsPtr, int flags); +/* Slot 112 is reserved */ +/* Slot 113 is reserved */ +/* Slot 114 is reserved */ +/* Slot 115 is reserved */ +/* Slot 116 is reserved */ +/* Slot 117 is reserved */ /* 118 */ EXTERN int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); @@ -332,31 +259,15 @@ EXTERN int Tcl_GetNamespaceResolvers( EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); -/* 121 */ -TCL_DEPRECATED("Use Tcl_ForgetImport") -int TclForgetImport(Tcl_Interp *interp, - Tcl_Namespace *nsPtr, const char *pattern); -/* 122 */ -TCL_DEPRECATED("Use Tcl_GetCommandFromObj") -Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); -/* 123 */ -TCL_DEPRECATED("Use Tcl_GetCommandFullName") -void TclGetCommandFullName(Tcl_Interp *interp, - Tcl_Command command, Tcl_Obj *objPtr); -/* 124 */ -TCL_DEPRECATED("Use Tcl_GetCurrentNamespace") -Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp); -/* 125 */ -TCL_DEPRECATED("Use Tcl_GetGlobalNamespace") -Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp); +/* Slot 121 is reserved */ +/* Slot 122 is reserved */ +/* Slot 123 is reserved */ +/* Slot 124 is reserved */ +/* Slot 125 is reserved */ /* 126 */ EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); -/* 127 */ -TCL_DEPRECATED("Use ") -int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *pattern, int allowOverwrite); +/* Slot 127 is reserved */ /* 128 */ EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp); /* 129 */ @@ -372,12 +283,8 @@ EXTERN void Tcl_SetNamespaceResolvers( Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); -/* 132 */ -TCL_DEPRECATED("") -int TclpHasSockets(Tcl_Interp *interp); -/* 133 */ -TCL_DEPRECATED("") -struct tm * TclpGetDate(const time_t *time, int useGMT); +/* Slot 132 is reserved */ +/* Slot 133 is reserved */ /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ @@ -413,10 +320,8 @@ EXTERN int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re); /* 151 */ EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr); -/* 152 */ -EXTERN void TclSetLibraryPath(Tcl_Obj *pathPtr); -/* 153 */ -EXTERN Tcl_Obj * TclGetLibraryPath(void); +/* Slot 152 is reserved */ +/* Slot 153 is reserved */ /* Slot 154 is reserved */ /* Slot 155 is reserved */ /* 156 */ @@ -425,12 +330,8 @@ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg, /* 157 */ EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); -/* 158 */ -TCL_DEPRECATED("use public Tcl_SetStartupScript()") -void TclSetStartupScriptFileName(const char *filename); -/* 159 */ -TCL_DEPRECATED("use public Tcl_GetStartupScript()") -const char * TclGetStartupScriptFileName(void); +/* Slot 158 is reserved */ +/* Slot 159 is reserved */ /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform(Tcl_Interp *interp, @@ -448,15 +349,11 @@ EXTERN void TclpSetInitialEncodings(void); EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj *valuePtr); -/* 167 */ -TCL_DEPRECATED("use public Tcl_SetStartupScript()") -void TclSetStartupScriptPath(Tcl_Obj *pathPtr); -/* 168 */ -TCL_DEPRECATED("use public Tcl_GetStartupScript()") -Tcl_Obj * TclGetStartupScriptPath(void); +/* Slot 167 is reserved */ +/* Slot 168 is reserved */ /* 169 */ -EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, - unsigned long n); +EXTERN int TclpUtfNcmp2(const void *s1, const void *s2, + size_t n); /* 170 */ EXTERN int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, Tcl_Size numChars, @@ -485,21 +382,12 @@ EXTERN void TclCleanupVar(Var *varPtr, Var *arrayPtr); EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); -/* 178 */ -TCL_DEPRECATED("") -void TclSetStartupScript(Tcl_Obj *pathPtr, - const char *encodingName); -/* 179 */ -TCL_DEPRECATED("") -Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr); +/* Slot 178 is reserved */ +/* Slot 179 is reserved */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ -/* 182 */ -TCL_DEPRECATED("") -struct tm * TclpLocaltime(const time_t *clock); -/* 183 */ -TCL_DEPRECATED("") -struct tm * TclpGmtime(const time_t *clock); +/* Slot 182 is reserved */ +/* Slot 183 is reserved */ /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ @@ -609,9 +497,7 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); -/* 236 */ -TCL_DEPRECATED("use Tcl_BackgroundException") -void TclBackgroundException(Tcl_Interp *interp, int code); +/* Slot 236 is reserved */ /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ @@ -702,7 +588,7 @@ typedef struct TclIntStubs { int (*tclCleanupChildren) (Tcl_Interp *interp, Tcl_Size numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ Tcl_Size (*tclCopyAndCollapse) (Tcl_Size count, const char *src, char *dst); /* 7 */ - TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ + void (*reserved8)(void); Tcl_Size (*tclCreatePipeline) (Tcl_Interp *interp, Tcl_Size argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ @@ -728,27 +614,27 @@ typedef struct TclIntStubs { const char * (*tclGetExtension) (const char *name); /* 31 */ int (*tclGetFrame) (Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* 32 */ void (*reserved33)(void); - TCL_DEPRECATED_API("Use Tcl_GetIntForIndex") int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */ + void (*reserved34)(void); void (*reserved35)(void); void (*reserved36)(void); - TCL_DEPRECATED_API("") int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */ + void (*reserved37)(void); int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */ Tcl_ObjCmdProc * (*tclGetObjInterpProc) (void); /* 39 */ int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */ Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */ const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ - void (*reserved43)(void); - TCL_DEPRECATED_API("") int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */ + Tcl_ObjCmdProc2 * (*tclGetObjInterpProc2) (void); /* 43 */ + void (*reserved44)(void); int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */ int (*tclInExit) (void); /* 46 */ void (*reserved47)(void); void (*reserved48)(void); void (*reserved49)(void); - TCL_DEPRECATED_API("") void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */ + void (*reserved50)(void); int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */ void (*reserved52)(void); - TCL_DEPRECATED_API("") int (*tclInvokeObjectCommand) (void *clientData, Tcl_Interp *interp, Tcl_Size argc, const char **argv); /* 53 */ - TCL_DEPRECATED_API("") int (*tclInvokeStringCommand) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* 54 */ + void (*reserved53)(void); + void (*reserved54)(void); Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */ void (*reserved56)(void); void (*reserved57)(void); @@ -757,7 +643,7 @@ typedef struct TclIntStubs { int (*tclNeedSpace) (const char *start, const char *end); /* 60 */ Tcl_Obj * (*tclNewProcBodyObj) (Proc *procPtr); /* 61 */ int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */ - TCL_DEPRECATED_API("") int (*tclObjInterpProc) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* 63 */ + void (*reserved63)(void); int (*tclObjInvoke) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 64 */ void (*reserved65)(void); void (*reserved66)(void); @@ -769,9 +655,9 @@ typedef struct TclIntStubs { void (*reserved72)(void); void (*reserved73)(void); void (*tclpFree) (void *ptr); /* 74 */ - unsigned long (*tclpGetClicks) (void); /* 75 */ - unsigned long (*tclpGetSeconds) (void); /* 76 */ - TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */ + unsigned long long (*tclpGetClicks) (void); /* 75 */ + unsigned long long (*tclpGetSeconds) (void); /* 76 */ + void (*reserved77)(void); void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); @@ -782,7 +668,7 @@ typedef struct TclIntStubs { void (*reserved85)(void); void (*reserved86)(void); void (*reserved87)(void); - TCL_DEPRECATED_API("") char * (*tclPrecTraceProc) (void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */ + void (*reserved88)(void); int (*tclPreventAliasLoop) (Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* 89 */ void (*reserved90)(void); void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */ @@ -795,10 +681,10 @@ typedef struct TclIntStubs { int (*tclServiceIdle) (void); /* 98 */ void (*reserved99)(void); void (*reserved100)(void); - TCL_DEPRECATED_API("Use Tcl_SetPreInitScript") const char * (*tclSetPreInitScript) (const char *string); /* 101 */ + void (*reserved101)(void); void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ + void (*reserved104)(void); void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); @@ -806,28 +692,28 @@ typedef struct TclIntStubs { int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ int (*tclSockMinimumBuffers) (void *sock, Tcl_Size size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ - TCL_DEPRECATED_API("Use Tcl_AppendExportList") int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ - TCL_DEPRECATED_API("Use Tcl_CreateNamespace") Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ - TCL_DEPRECATED_API("Use Tcl_DeleteNamespace") void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ - TCL_DEPRECATED_API("Use Tcl_Export") int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ - TCL_DEPRECATED_API("Use Tcl_FindCommand") Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ - TCL_DEPRECATED_API("Use Tcl_FindNamespace") Tcl_Namespace * (*tclFindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ + void (*reserved112)(void); + void (*reserved113)(void); + void (*reserved114)(void); + void (*reserved115)(void); + void (*reserved116)(void); + void (*reserved117)(void); int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */ int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */ Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */ - TCL_DEPRECATED_API("Use Tcl_ForgetImport") int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ - TCL_DEPRECATED_API("Use Tcl_GetCommandFromObj") Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ - TCL_DEPRECATED_API("Use Tcl_GetCommandFullName") void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ - TCL_DEPRECATED_API("Use Tcl_GetCurrentNamespace") Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */ - TCL_DEPRECATED_API("Use Tcl_GetGlobalNamespace") Tcl_Namespace * (*tclGetGlobalNamespace_) (Tcl_Interp *interp); /* 125 */ + void (*reserved121)(void); + void (*reserved122)(void); + void (*reserved123)(void); + void (*reserved124)(void); + void (*reserved125)(void); void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */ - TCL_DEPRECATED_API("Use ") int (*tclImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ + void (*reserved127)(void); void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */ int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ - TCL_DEPRECATED_API("") int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ - TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ + void (*reserved132)(void); + void (*reserved133)(void); void (*reserved134)(void); void (*reserved135)(void); void (*reserved136)(void); @@ -846,14 +732,14 @@ typedef struct TclIntStubs { void (*tclHandleRelease) (TclHandle handle); /* 149 */ int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */ void (*tclRegExpRangeUniChar) (Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr); /* 151 */ - void (*tclSetLibraryPath) (Tcl_Obj *pathPtr); /* 152 */ - Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */ + void (*reserved152)(void); + void (*reserved153)(void); void (*reserved154)(void); void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ - TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ - TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */ + void (*reserved158)(void); + void (*reserved159)(void); void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ void (*tclChannelEventScriptInvoker) (void *clientData, int flags); /* 162 */ @@ -861,9 +747,9 @@ typedef struct TclIntStubs { void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj *valuePtr); /* 166 */ - TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ - TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ - int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */ + void (*reserved167)(void); + void (*reserved168)(void); + int (*tclpUtfNcmp2) (const void *s1, const void *s2, size_t n); /* 169 */ int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, Tcl_Size objc, Tcl_Obj *const objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, Tcl_Size objc, Tcl_Obj *const objv[]); /* 171 */ int (*tclInThreadExit) (void); /* 172 */ @@ -872,12 +758,12 @@ typedef struct TclIntStubs { int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */ void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */ void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */ - TCL_DEPRECATED_API("") void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ - TCL_DEPRECATED_API("") Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */ + void (*reserved178)(void); + void (*reserved179)(void); void (*reserved180)(void); void (*reserved181)(void); - TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ - TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ + void (*reserved182)(void); + void (*reserved183)(void); void (*reserved184)(void); void (*reserved185)(void); void (*reserved186)(void); @@ -930,7 +816,7 @@ typedef struct TclIntStubs { void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ + void (*reserved236)(void); int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ 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 */ @@ -982,8 +868,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCleanupCommand) /* 6 */ #define TclCopyAndCollapse \ (tclIntStubsPtr->tclCopyAndCollapse) /* 7 */ -#define TclCopyChannelOld \ - (tclIntStubsPtr->tclCopyChannelOld) /* 8 */ +/* Slot 8 is reserved */ #define TclCreatePipeline \ (tclIntStubsPtr->tclCreatePipeline) /* 9 */ #define TclCreateProc \ @@ -1022,12 +907,10 @@ extern const TclIntStubs *tclIntStubsPtr; #define TclGetFrame \ (tclIntStubsPtr->tclGetFrame) /* 32 */ /* Slot 33 is reserved */ -#define TclGetIntForIndex \ - (tclIntStubsPtr->tclGetIntForIndex) /* 34 */ +/* Slot 34 is reserved */ /* Slot 35 is reserved */ /* Slot 36 is reserved */ -#define TclGetLoadedPackages \ - (tclIntStubsPtr->tclGetLoadedPackages) /* 37 */ +/* Slot 37 is reserved */ #define TclGetNamespaceForQualName \ (tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */ #define TclGetObjInterpProc \ @@ -1038,9 +921,9 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclGetOriginalCommand) /* 41 */ #define TclpGetUserHome \ (tclIntStubsPtr->tclpGetUserHome) /* 42 */ -/* Slot 43 is reserved */ -#define TclGuessPackageName \ - (tclIntStubsPtr->tclGuessPackageName) /* 44 */ +#define TclGetObjInterpProc2 \ + (tclIntStubsPtr->tclGetObjInterpProc2) /* 43 */ +/* Slot 44 is reserved */ #define TclHideUnsafeCommands \ (tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */ #define TclInExit \ @@ -1048,15 +931,12 @@ extern const TclIntStubs *tclIntStubsPtr; /* Slot 47 is reserved */ /* Slot 48 is reserved */ /* Slot 49 is reserved */ -#define TclInitCompiledLocals \ - (tclIntStubsPtr->tclInitCompiledLocals) /* 50 */ +/* Slot 50 is reserved */ #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 */ @@ -1070,8 +950,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 */ @@ -1090,8 +969,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclpGetClicks) /* 75 */ #define TclpGetSeconds \ (tclIntStubsPtr->tclpGetSeconds) /* 76 */ -#define TclpGetTime \ - (tclIntStubsPtr->tclpGetTime) /* 77 */ +/* Slot 77 is reserved */ /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ @@ -1103,8 +981,7 @@ extern const TclIntStubs *tclIntStubsPtr; /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ -#define TclPrecTraceProc \ - (tclIntStubsPtr->tclPrecTraceProc) /* 88 */ +/* Slot 88 is reserved */ #define TclPreventAliasLoop \ (tclIntStubsPtr->tclPreventAliasLoop) /* 89 */ /* Slot 90 is reserved */ @@ -1124,14 +1001,12 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclServiceIdle) /* 98 */ /* Slot 99 is reserved */ /* Slot 100 is reserved */ -#define TclSetPreInitScript \ - (tclIntStubsPtr->tclSetPreInitScript) /* 101 */ +/* Slot 101 is reserved */ #define TclSetupEnv \ (tclIntStubsPtr->tclSetupEnv) /* 102 */ #define TclSockGetPort \ (tclIntStubsPtr->tclSockGetPort) /* 103 */ -#define TclSockMinimumBuffersOld \ - (tclIntStubsPtr->tclSockMinimumBuffersOld) /* 104 */ +/* Slot 104 is reserved */ /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -1143,38 +1018,26 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ -#define TclAppendExportList \ - (tclIntStubsPtr->tclAppendExportList) /* 112 */ -#define TclCreateNamespace \ - (tclIntStubsPtr->tclCreateNamespace) /* 113 */ -#define TclDeleteNamespace \ - (tclIntStubsPtr->tclDeleteNamespace) /* 114 */ -#define TclExport \ - (tclIntStubsPtr->tclExport) /* 115 */ -#define TclFindCommand \ - (tclIntStubsPtr->tclFindCommand) /* 116 */ -#define TclFindNamespace \ - (tclIntStubsPtr->tclFindNamespace) /* 117 */ +/* Slot 112 is reserved */ +/* Slot 113 is reserved */ +/* Slot 114 is reserved */ +/* Slot 115 is reserved */ +/* Slot 116 is reserved */ +/* Slot 117 is reserved */ #define Tcl_GetInterpResolvers \ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ #define Tcl_GetNamespaceResolvers \ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ #define Tcl_FindNamespaceVar \ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ -#define TclForgetImport \ - (tclIntStubsPtr->tclForgetImport) /* 121 */ -#define TclGetCommandFromObj \ - (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */ -#define TclGetCommandFullName \ - (tclIntStubsPtr->tclGetCommandFullName) /* 123 */ -#define TclGetCurrentNamespace_ \ - (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */ -#define TclGetGlobalNamespace_ \ - (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */ +/* Slot 121 is reserved */ +/* Slot 122 is reserved */ +/* Slot 123 is reserved */ +/* Slot 124 is reserved */ +/* Slot 125 is reserved */ #define Tcl_GetVariableFullName \ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ -#define TclImport \ - (tclIntStubsPtr->tclImport) /* 127 */ +/* Slot 127 is reserved */ #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #define Tcl_PushCallFrame \ @@ -1183,10 +1046,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */ #define Tcl_SetNamespaceResolvers \ (tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */ -#define TclpHasSockets \ - (tclIntStubsPtr->tclpHasSockets) /* 132 */ -#define TclpGetDate \ - (tclIntStubsPtr->tclpGetDate) /* 133 */ +/* Slot 132 is reserved */ +/* Slot 133 is reserved */ /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ @@ -1217,20 +1078,16 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclRegAbout) /* 150 */ #define TclRegExpRangeUniChar \ (tclIntStubsPtr->tclRegExpRangeUniChar) /* 151 */ -#define TclSetLibraryPath \ - (tclIntStubsPtr->tclSetLibraryPath) /* 152 */ -#define TclGetLibraryPath \ - (tclIntStubsPtr->tclGetLibraryPath) /* 153 */ +/* Slot 152 is reserved */ +/* Slot 153 is reserved */ /* Slot 154 is reserved */ /* Slot 155 is reserved */ #define TclRegError \ (tclIntStubsPtr->tclRegError) /* 156 */ #define TclVarTraceExists \ (tclIntStubsPtr->tclVarTraceExists) /* 157 */ -#define TclSetStartupScriptFileName \ - (tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */ -#define TclGetStartupScriptFileName \ - (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */ +/* Slot 158 is reserved */ +/* Slot 159 is reserved */ /* Slot 160 is reserved */ #define TclChannelTransform \ (tclIntStubsPtr->tclChannelTransform) /* 161 */ @@ -1244,10 +1101,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */ #define TclListObjSetElement \ (tclIntStubsPtr->tclListObjSetElement) /* 166 */ -#define TclSetStartupScriptPath \ - (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */ -#define TclGetStartupScriptPath \ - (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */ +/* Slot 167 is reserved */ +/* Slot 168 is reserved */ #define TclpUtfNcmp2 \ (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */ #define TclCheckInterpTraces \ @@ -1265,16 +1120,12 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ -#define TclSetStartupScript \ - (tclIntStubsPtr->tclSetStartupScript) /* 178 */ -#define TclGetStartupScript \ - (tclIntStubsPtr->tclGetStartupScript) /* 179 */ +/* Slot 178 is reserved */ +/* Slot 179 is reserved */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ -#define TclpLocaltime \ - (tclIntStubsPtr->tclpLocaltime) /* 182 */ -#define TclpGmtime \ - (tclIntStubsPtr->tclpGmtime) /* 183 */ +/* Slot 182 is reserved */ +/* Slot 183 is reserved */ /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ @@ -1359,8 +1210,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ -#define TclBackgroundException \ - (tclIntStubsPtr->tclBackgroundException) /* 236 */ +/* Slot 236 is reserved */ #define TclResetCancellation \ (tclIntStubsPtr->tclResetCancellation) /* 237 */ #define TclNRInterpProc \ @@ -1413,46 +1263,28 @@ extern const TclIntStubs *tclIntStubsPtr; /* !END!: Do not edit above this line. */ -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLIMPORT - #if defined(USE_TCL_STUBS) -# undef TclGetStartupScriptFileName -# undef TclSetStartupScriptFileName -# undef TclGetStartupScriptPath -# undef TclSetStartupScriptPath -# undef TclBackgroundException -# undef TclSetStartupScript -# undef TclGetStartupScript -# undef TclGetIntForIndex -# undef TclCreateNamespace -# undef TclDeleteNamespace -# undef TclAppendExportList -# undef TclExport -# undef TclImport -# undef TclForgetImport -# undef TclGetCurrentNamespace_ -# undef TclGetGlobalNamespace_ -# undef TclFindNamespace -# undef TclFindCommand -# undef TclGetCommandFromObj -# undef TclGetCommandFullName -# undef TclCopyChannelOld -# undef TclSockMinimumBuffersOld -# undef Tcl_StaticLibrary -# define Tcl_StaticLibrary (tclIntStubsPtr->tclStaticLibrary) +#undef Tcl_StaticLibrary +#define Tcl_StaticLibrary \ + (tclIntStubsPtr->tclStaticLibrary) +#endif /* defined(USE_TCL_STUBS) */ + +#if (TCL_MAJOR_VERSION < 9) && defined(USE_TCL_STUBS) +#undef TclpGetClicks +#define TclpGetClicks() \ + ((unsigned long)tclIntStubsPtr->tclpGetClicks()) +#undef TclpGetSeconds +#define TclpGetSeconds() \ + ((unsigned long)tclIntStubsPtr->tclpGetSeconds()) +#undef TclGetObjInterpProc2 +#define TclGetObjInterpProc2 TclGetObjInterpProc #endif #undef TclUnusedStubEntry -#undef TclGuessPackageName -#undef TclSetPreInitScript -#undef TclObjInterpProc #define TclObjInterpProc TclGetObjInterpProc() -#define TclObjInterpProc2 TclObjInterpProc +#define TclObjInterpProc2 TclGetObjInterpProc2() -#ifndef TCL_NO_DEPRECATED -# define TclSetPreInitScript Tcl_SetPreInitScript -# define TclGuessPackageName(fileName, pkgName) ((void)fileName,(void)pkgName,0) -#endif +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLINTDECLS */ diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 1a43e15..aab3737 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -30,7 +30,7 @@ * in the generic/tclInt.decls script. */ -/* !BEGIN!: Do not edit below this line. */ +#if TCL_MAJOR_VERSION < 9 #ifdef __cplusplus extern "C" { @@ -57,8 +57,7 @@ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); -/* 5 */ -EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +/* Slot 5 is reserved */ /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ @@ -69,12 +68,9 @@ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); -/* 11 */ -EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); -/* 12 */ -EXTERN struct tm * TclpGmtime_unix(const time_t *clock); -/* 13 */ -EXTERN char * TclpInetNtoa(struct in_addr addr); +/* Slot 11 is reserved */ +/* Slot 12 is reserved */ +/* Slot 13 is reserved */ /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, @@ -101,8 +97,7 @@ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ -/* 22 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); +/* Slot 22 is reserved */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -117,31 +112,20 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *resultingNameObj); #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -/* 0 */ -EXTERN void TclWinConvertError(DWORD errCode); -/* 1 */ -EXTERN void TclWinConvertWSAError(DWORD errCode); -/* 2 */ -EXTERN struct servent * TclWinGetServByName(const char *nm, - const char *proto); -/* 3 */ -EXTERN int TclWinGetSockOpt(SOCKET s, int level, int optname, - char *optval, int *optlen); +/* Slot 0 is reserved */ +/* Slot 1 is reserved */ +/* Slot 2 is reserved */ +/* Slot 3 is reserved */ /* 4 */ -EXTERN HINSTANCE TclWinGetTclInstance(void); +EXTERN void * TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* 6 */ -EXTERN unsigned short TclWinNToHS(unsigned short ns); -/* 7 */ -EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname, - const char *optval, int optlen); +/* Slot 6 is reserved */ +/* Slot 7 is reserved */ /* 8 */ EXTERN Tcl_Size TclpGetPid(Tcl_Pid pid); -/* 9 */ -EXTERN int TclWinGetPlatformId(void); -/* 10 */ -EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); +/* Slot 9 is reserved */ +/* Slot 10 is reserved */ /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); @@ -170,20 +154,17 @@ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ EXTERN void TclWinAddProcess(void *hProcess, Tcl_Size id); -/* 21 */ -EXTERN char * TclpInetNtoa(struct in_addr addr); +/* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ -/* 26 */ -EXTERN void TclWinSetInterfaces(int wide); +/* Slot 26 is reserved */ /* 27 */ EXTERN void TclWinFlushDirtyChannels(void); -/* 28 */ -EXTERN void TclWinResetInterfaces(void); +/* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ @@ -208,8 +189,7 @@ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); -/* 5 */ -EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +/* Slot 5 is reserved */ /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ @@ -220,12 +200,7 @@ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); -/* 11 */ -EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); -/* 12 */ -EXTERN struct tm * TclpGmtime_unix(const time_t *clock); -/* 13 */ -EXTERN char * TclpInetNtoa(struct in_addr addr); +/* Slot 13 is reserved */ /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, @@ -252,8 +227,7 @@ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ -/* 22 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); +/* Slot 22 is reserved */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -284,9 +258,9 @@ typedef struct TclIntPlatStubs { int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ - struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */ - struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ - char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ + void (*reserved11)(void); + void (*reserved12)(void); + void (*reserved13)(void); int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ @@ -306,17 +280,17 @@ typedef struct TclIntPlatStubs { int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - void (*tclWinConvertError) (DWORD errCode); /* 0 */ - void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */ - struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */ - int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */ - HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ + void (*reserved0)(void); + void (*reserved1)(void); + void (*reserved2)(void); + void (*reserved3)(void); + void * (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ - unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */ - int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */ + void (*reserved6)(void); + void (*reserved7)(void); Tcl_Size (*tclpGetPid) (Tcl_Pid pid); /* 8 */ - int (*tclWinGetPlatformId) (void); /* 9 */ - Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ + void (*reserved9)(void); + void *(*tclpReaddir) (void *dir); /* 10 */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ int (*tclpCloseFile) (TclFile file); /* 12 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ @@ -327,14 +301,14 @@ typedef struct TclIntPlatStubs { TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */ void (*tclWinAddProcess) (void *hProcess, Tcl_Size id); /* 20 */ - char * (*tclpInetNtoa) (struct in_addr addr); /* 21 */ + void (*reserved21)(void); TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); - void (*tclWinSetInterfaces) (int wide); /* 26 */ + void (*reserved26)(void); void (*tclWinFlushDirtyChannels) (void); /* 27 */ - void (*tclWinResetInterfaces) (void); /* 28 */ + void (*reserved28)(void); int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ @@ -350,9 +324,9 @@ typedef struct TclIntPlatStubs { int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ - struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */ - struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ - char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ + void (*reserved11)(void); + void (*reserved12)(void); + void (*reserved13)(void); int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ @@ -396,8 +370,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -#define TclUnixWaitForFile_ \ - (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ +/* Slot 5 is reserved */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ @@ -408,12 +381,9 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ -#define TclpLocaltime_unix \ - (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ -#define TclpGmtime_unix \ - (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ -#define TclpInetNtoa \ - (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ +/* Slot 11 is reserved */ +/* Slot 12 is reserved */ +/* Slot 13 is reserved */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ @@ -428,8 +398,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ +/* Slot 22 is reserved */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -442,28 +411,20 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -#define TclWinConvertError \ - (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ -#define TclWinConvertWSAError \ - (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */ -#define TclWinGetServByName \ - (tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */ -#define TclWinGetSockOpt \ - (tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */ +/* Slot 0 is reserved */ +/* Slot 1 is reserved */ +/* Slot 2 is reserved */ +/* Slot 3 is reserved */ #define TclWinGetTclInstance \ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ -#define TclWinNToHS \ - (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */ -#define TclWinSetSockOpt \ - (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */ +/* Slot 6 is reserved */ +/* Slot 7 is reserved */ #define TclpGetPid \ (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ -#define TclWinGetPlatformId \ - (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */ -#define TclpReaddir \ - (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ +/* Slot 9 is reserved */ +/* Slot 10 is reserved */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ #define TclpCloseFile \ @@ -484,20 +445,17 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ #define TclWinAddProcess \ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ -#define TclpInetNtoa \ - (tclIntPlatStubsPtr->tclpInetNtoa) /* 21 */ +/* Slot 21 is reserved */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ /* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ -#define TclWinSetInterfaces \ - (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */ +/* Slot 26 is reserved */ #define TclWinFlushDirtyChannels \ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ -#define TclWinResetInterfaces \ - (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ +/* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ @@ -514,8 +472,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -#define TclUnixWaitForFile_ \ - (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ +/* Slot 5 is reserved */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ @@ -526,12 +483,9 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ -#define TclpLocaltime_unix \ - (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ -#define TclpGmtime_unix \ - (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ -#define TclpInetNtoa \ - (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ +/* Slot 11 is reserved */ +/* Slot 12 is reserved */ +/* Slot 13 is reserved */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ @@ -546,8 +500,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ +/* Slot 22 is reserved */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -562,25 +515,202 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #endif /* defined(USE_TCL_STUBS) */ +#else /* TCL_MAJOR_VERSION > 8 */ +/* !BEGIN!: Do not edit below this line. */ + +#ifdef __cplusplus +extern "C" { +#endif + +/* + * Exported function declarations: + */ + +/* Slot 0 is reserved */ +/* 1 */ +EXTERN int TclpCloseFile(TclFile file); +/* 2 */ +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, + size_t numPids, Tcl_Pid *pidPtr); +/* 3 */ +EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); +/* 4 */ +EXTERN void * TclWinGetTclInstance(void); +/* 5 */ +EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); +/* 6 */ +EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); +/* 7 */ +EXTERN TclFile TclpOpenFile(const char *fname, int mode); +/* 8 */ +EXTERN Tcl_Size TclpGetPid(Tcl_Pid pid); +/* 9 */ +EXTERN TclFile TclpCreateTempFile(const char *contents); +/* Slot 10 is reserved */ +/* 11 */ +EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, + Tcl_Channel chan); +/* Slot 12 is reserved */ +/* Slot 13 is reserved */ +/* Slot 14 is reserved */ +/* 15 */ +EXTERN int TclpCreateProcess(Tcl_Interp *interp, size_t argc, + const char **argv, TclFile inputFile, + TclFile outputFile, TclFile errorFile, + Tcl_Pid *pidPtr); +/* 16 */ +EXTERN int TclpIsAtty(int fd); +/* 17 */ +EXTERN int TclUnixCopyFile(const char *src, const char *dst, + const Tcl_StatBuf *statBufPtr, + int dontCopyAtts); +/* Slot 18 is reserved */ +/* Slot 19 is reserved */ +/* 20 */ +EXTERN void TclWinAddProcess(void *hProcess, Tcl_Size id); +/* Slot 21 is reserved */ +/* Slot 22 is reserved */ +/* Slot 23 is reserved */ +/* 24 */ +EXTERN char * TclWinNoBackslash(char *path); +/* Slot 25 is reserved */ +/* Slot 26 is reserved */ +/* 27 */ +EXTERN void TclWinFlushDirtyChannels(void); +/* Slot 28 is reserved */ +/* 29 */ +EXTERN int TclWinCPUID(int index, int *regs); +/* 30 */ +EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); + +typedef struct TclIntPlatStubs { + int magic; + void *hooks; + + void (*reserved0)(void); + int (*tclpCloseFile) (TclFile file); /* 1 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr); /* 2 */ + int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ + void * (*tclWinGetTclInstance) (void); /* 4 */ + int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ + TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ + TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ + Tcl_Size (*tclpGetPid) (Tcl_Pid pid); /* 8 */ + TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ + void (*reserved10)(void); + void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ + void (*reserved12)(void); + void (*reserved13)(void); + void (*reserved14)(void); + int (*tclpCreateProcess) (Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ + int (*tclpIsAtty) (int fd); /* 16 */ + int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ + void (*reserved18)(void); + void (*reserved19)(void); + void (*tclWinAddProcess) (void *hProcess, Tcl_Size id); /* 20 */ + void (*reserved21)(void); + void (*reserved22)(void); + void (*reserved23)(void); + char * (*tclWinNoBackslash) (char *path); /* 24 */ + void (*reserved25)(void); + void (*reserved26)(void); + void (*tclWinFlushDirtyChannels) (void); /* 27 */ + void (*reserved28)(void); + int (*tclWinCPUID) (int index, int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ +} TclIntPlatStubs; + +extern const TclIntPlatStubs *tclIntPlatStubsPtr; + +#ifdef __cplusplus +} +#endif + +#if defined(USE_TCL_STUBS) + +/* + * Inline function declarations: + */ + +/* Slot 0 is reserved */ +#define TclpCloseFile \ + (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ +#define TclpCreatePipe \ + (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ +#define TclWinGetTclInstance \ + (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ +#define TclUnixWaitForFile \ + (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ +#define TclpMakeFile \ + (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ +#define TclpOpenFile \ + (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ +#define TclpGetPid \ + (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ +/* Slot 10 is reserved */ +#define TclGetAndDetachPids \ + (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ +/* Slot 12 is reserved */ +/* Slot 13 is reserved */ +/* Slot 14 is reserved */ +#define TclpCreateProcess \ + (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ +#define TclpIsAtty \ + (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ +#define TclUnixCopyFile \ + (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ +/* Slot 18 is reserved */ +/* Slot 19 is reserved */ +#define TclWinAddProcess \ + (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ +/* Slot 21 is reserved */ +/* Slot 22 is reserved */ +/* Slot 23 is reserved */ +#define TclWinNoBackslash \ + (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ +/* Slot 25 is reserved */ +/* Slot 26 is reserved */ +#define TclWinFlushDirtyChannels \ + (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ +/* Slot 28 is reserved */ +#define TclWinCPUID \ + (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ + +#endif /* defined(USE_TCL_STUBS) */ + /* !END!: Do not edit above this line. */ +#endif /* TCL_MAJOR_VERSION */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#undef TclpLocaltime_unix -#undef TclpGmtime_unix -#undef TclWinConvertWSAError -#define TclWinConvertWSAError TclWinConvertError -#if !defined(TCL_USE_STUBS) && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -# undef TclWinConvertError -# define TclWinConvertError Tcl_WinConvertError -#endif -#undef TclpInetNtoa -#define TclpInetNtoa inet_ntoa - -#undef TclpCreateTempFile_ -#undef TclUnixWaitForFile_ -#ifndef MAC_OSX_TCL /* not accessible on Win32/UNIX */ +#ifdef MAC_OSX_TCL /* not accessible on Win32/UNIX */ +MODULE_SCOPE int TclMacOSXGetFileAttribute(Tcl_Interp *interp, + int objIndex, Tcl_Obj *fileName, + Tcl_Obj **attributePtrPtr); +/* 16 */ +MODULE_SCOPE int TclMacOSXSetFileAttribute(Tcl_Interp *interp, + int objIndex, Tcl_Obj *fileName, + Tcl_Obj *attributePtr); +/* 17 */ +MODULE_SCOPE int TclMacOSXCopyFileAttributes(const char *src, + const char *dst, + const Tcl_StatBuf *statBufPtr); +/* 18 */ +MODULE_SCOPE int TclMacOSXMatchType(Tcl_Interp *interp, + const char *pathName, const char *fileName, + Tcl_StatBuf *statBufPtr, + Tcl_GlobTypeData *types); +#else #undef TclMacOSXGetFileAttribute /* 15 */ #undef TclMacOSXSetFileAttribute /* 16 */ #undef TclMacOSXCopyFileAttributes /* 17 */ @@ -589,15 +719,11 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #endif #if defined(_WIN32) -# undef TclWinNToHS -# undef TclWinGetServByName -# undef TclWinGetSockOpt -# undef TclWinSetSockOpt -# undef TclWinGetPlatformId -# undef TclWinResetInterfaces -# undef TclWinSetInterfaces -# if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +# if !defined(TCL_NO_DEPRECATED) +# define TclWinConvertError Tcl_WinConvertError +# define TclWinConvertWSAError Tcl_WinConvertError # define TclWinNToHS ntohs +# define TclpInetNtoa inet_ntoa # define TclWinGetServByName getservbyname # define TclWinGetSockOpt getsockopt # define TclWinSetSockOpt setsockopt @@ -607,7 +733,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; # endif /* TCL_NO_DEPRECATED */ #else # undef TclpGetPid -# define TclpGetPid(pid) ((Tcl_Size)(size_t)(pid)) +# define TclpGetPid(pid) ((Tcl_Size)(pid)) #endif #endif /* _TCLINTPLATDECLS */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 3d2c009..fa6cf80 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -12,7 +12,6 @@ */ #include "tclInt.h" -#include <assert.h> /* * A pointer to a string that holds an initialization script that if non-NULL @@ -26,14 +25,14 @@ static const char *tclPreInitScript = NULL; struct Target; /* - * struct Alias: + * Alias: * * Stores information about an alias. Is stored in the child interpreter and * used by the source command to find the target command in the parent when * the source command is invoked. */ -typedef struct Alias { +typedef struct { Tcl_Obj *token; /* Token for the alias command in the child * interp. This used to be the command name in * the child when the alias was first @@ -67,14 +66,14 @@ typedef struct Alias { /* * - * struct Child: + * Child: * * Used by the "interp" command to record and find information about child * interpreters. Maps from a command name in the parent to information about a * child interpreter, e.g. what aliases are defined in it. */ -typedef struct Child { +typedef struct { Tcl_Interp *parentInterp; /* Parent interpreter for this child. */ Tcl_HashEntry *childEntryPtr; /* Hash entry in parents child table for this @@ -113,7 +112,7 @@ typedef struct Target { } Target; /* - * struct Parent: + * Parent: * * This record is used for two purposes: First, childTable (a hashtable) maps * from names of commands to child interpreters. This hashtable is used to @@ -128,7 +127,7 @@ typedef struct Target { * only load safe extensions. */ -typedef struct Parent { +typedef struct { Tcl_HashTable childTable; /* Hash table for child interpreters. Maps * from command names to Child records. */ Target *targetsPtr; /* The head of a doubly-linked list of all the @@ -145,7 +144,7 @@ typedef struct Parent { * on a per-interp basis. */ -typedef struct InterpInfo { +typedef struct { Parent parent; /* Keeps track of all interps for which this * interp is the Parent. */ Child child; /* Information necessary for this interp to @@ -159,7 +158,7 @@ typedef struct InterpInfo { * likely to work properly on 64-bit architectures. */ -typedef struct ScriptLimitCallback { +typedef struct { Tcl_Interp *interp; /* The interpreter in which to execute the * callback. */ Tcl_Obj *scriptObj; /* The script to execute to perform the @@ -172,7 +171,7 @@ typedef struct ScriptLimitCallback { * table. */ } ScriptLimitCallback; -typedef struct ScriptLimitCallbackKey { +typedef struct { Tcl_Interp *interp; /* The interpreter that the limit callback was * attached to. This is not the interpreter * that the callback runs in! */ @@ -249,7 +248,7 @@ static int ChildHidden(Tcl_Interp *interp, static int ChildInvokeHidden(Tcl_Interp *interp, Tcl_Interp *childInterp, const char *namespaceName, - Tcl_Size objc, Tcl_Obj *const objv[]); + int objc, Tcl_Obj *const objv[]); static int ChildMarkTrusted(Tcl_Interp *interp, Tcl_Interp *childInterp); static Tcl_CmdDeleteProc ChildObjCmdDeleteProc; @@ -269,6 +268,7 @@ static void SetScriptLimitCallback(Tcl_Interp *interp, int type, static void CallScriptLimitCallback(void *clientData, Tcl_Interp *interp); static void DeleteScriptLimitCallback(void *clientData); +static void MakeSafe(Tcl_Interp *interp); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(void *clientData); @@ -483,7 +483,7 @@ TclInterpInit( Parent *parentPtr; Child *childPtr; - interpInfoPtr = (InterpInfo *)ckalloc(sizeof(InterpInfo)); + interpInfoPtr = (InterpInfo *)Tcl_Alloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = interpInfoPtr; parentPtr = &interpInfoPtr->parent; @@ -580,7 +580,7 @@ InterpInfoDeleteProc( } Tcl_DeleteHashTable(&childPtr->aliasTable); - ckfree(interpInfoPtr); + Tcl_Free(interpInfoPtr); } /* @@ -618,15 +618,17 @@ NRInterpCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *childInterp; - int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", "children", "create", "debug", "delete", "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", - "share", "slaves", "target", "transfer", - NULL + "share", +#ifndef TCL_NO_DEPRECATED + "slaves", +#endif + "target", "transfer", NULL }; static const char *const optionsNoSlaves[] = { "alias", "aliases", "bgerror", "cancel", @@ -634,16 +636,20 @@ NRInterpCmd( "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", - "share", "target", "transfer", NULL + "share", "target", "transfer", + NULL }; enum interpOptionEnum { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL, OPT_CHILDREN, OPT_CREATE, OPT_DEBUG, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, - OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, - OPT_SHARE, OPT_SLAVES, OPT_TARGET, OPT_TRANSFER - }; + OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT, OPT_SHARE, +#ifndef TCL_NO_DEPRECATED + OPT_SLAVES, +#endif + OPT_TARGET, OPT_TRANSFER + } index; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); @@ -656,7 +662,7 @@ NRInterpCmd( "option", 0, &index); return TCL_ERROR; } - switch ((enum interpOptionEnum)index) { + switch (index) { case OPT_ALIAS: { Tcl_Interp *parentInterp; @@ -711,7 +717,7 @@ NRInterpCmd( }; enum optionCancelEnum { OPT_UNWIND, OPT_LAST - }; + } idx; flags = 0; @@ -720,11 +726,11 @@ NRInterpCmd( break; } if (Tcl_GetIndexFromObj(interp, objv[i], cancelOptions, "option", - 0, &index) != TCL_OK) { + 0, &idx) != TCL_OK) { return TCL_ERROR; } - switch ((enum optionCancelEnum) index) { + switch (idx) { case OPT_UNWIND: /* * The evaluation stack in the target interp is to be unwound. @@ -784,7 +790,7 @@ NRInterpCmd( }; enum option { OPT_SAFE, OPT_LAST - }; + } idx; safe = Tcl_IsSafe(interp); @@ -795,12 +801,12 @@ NRInterpCmd( childPtr = NULL; last = 0; for (i = 2; i < objc; i++) { - if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { + if ((last == 0) && (TclGetString(objv[i])[0] == '-')) { if (Tcl_GetIndexFromObj(interp, objv[i], createOptions, - "option", 0, &index) != TCL_OK) { + "option", 0, &idx) != TCL_OK) { return TCL_ERROR; } - if (index == OPT_SAFE) { + if (idx == OPT_SAFE) { safe = 1; continue; } @@ -943,7 +949,7 @@ NRInterpCmd( }; enum hiddenOption { OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST - }; + } idx; namespaceName = NULL; for (i = 3; i < objc; i++) { @@ -951,12 +957,12 @@ NRInterpCmd( break; } if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", - 0, &index) != TCL_OK) { + 0, &idx) != TCL_OK) { return TCL_ERROR; } - if (index == OPT_GLOBAL) { + if (idx == OPT_GLOBAL) { namespaceName = "::"; - } else if (index == OPT_NAMESPACE) { + } else if (idx == OPT_NAMESPACE) { if (++i == objc) { /* There must be more arguments. */ break; } else { @@ -985,8 +991,7 @@ NRInterpCmd( }; enum LimitTypes { LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME - }; - int limitType; + } limitType; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, @@ -1001,7 +1006,7 @@ NRInterpCmd( &limitType) != TCL_OK) { return TCL_ERROR; } - switch ((enum LimitTypes) limitType) { + switch (limitType) { case LIMIT_TYPE_COMMANDS: return ChildCommandLimitCmd(interp, childInterp, 4, objc,objv); case LIMIT_TYPE_TIME: @@ -1029,8 +1034,10 @@ NRInterpCmd( return TCL_ERROR; } return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3); - case OPT_CHILDREN: - case OPT_SLAVES: { +#ifndef TCL_NO_DEPRECATED + case OPT_SLAVES: +#endif + case OPT_CHILDREN: { InterpInfo *iiPtr; Tcl_Obj *resultPtr; Tcl_HashEntry *hPtr; @@ -1120,7 +1127,7 @@ NRInterpCmd( if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "target interpreter for alias \"%s\" in path \"%s\" is " - "not my descendant", aliasName, Tcl_GetString(objv[2]))); + "not my descendant", aliasName, TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "TARGETSHROUDED", (void *)NULL); return TCL_ERROR; @@ -1320,7 +1327,7 @@ Tcl_GetAlias( } if (argvPtr != NULL) { *argvPtr = (const char **) - ckalloc(sizeof(const char *) * (objc - 1)); + Tcl_Alloc(sizeof(const char *) * (objc - 1)); for (i = 1; i < objc; i++) { (*argvPtr)[i - 1] = TclGetString(objv[i]); } @@ -1526,7 +1533,7 @@ AliasCreate( Tcl_Obj **prefv; int isNew, i; - aliasPtr = (Alias *)ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); + aliasPtr = (Alias *)Tcl_Alloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); aliasPtr->targetInterp = parentInterp; @@ -1577,7 +1584,7 @@ AliasCreate( cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd); - ckfree(aliasPtr); + Tcl_Free(aliasPtr); /* * The result was already set by TclPreventAliasLoop. @@ -1634,7 +1641,7 @@ AliasCreate( * interp alias {} foo {} zop # Now recreate "foo"... */ - targetPtr = (Target *)ckalloc(sizeof(Target)); + targetPtr = (Target *)Tcl_Alloc(sizeof(Target)); targetPtr->childCmd = aliasPtr->childCmd; targetPtr->childInterp = childInterp; @@ -1736,7 +1743,7 @@ AliasDescribe( */ childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; - hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, Tcl_GetString(namePtr)); + hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { return TCL_OK; } @@ -2074,8 +2081,8 @@ AliasObjCmdDeleteProc( targetPtr->nextPtr->prevPtr = targetPtr->prevPtr; } - ckfree(targetPtr); - ckfree(aliasPtr); + Tcl_Free(targetPtr); + Tcl_Free(aliasPtr); } /* @@ -2275,7 +2282,7 @@ Tcl_GetInterpPath( InterpInfo *iiPtr; if (targetInterp == interp) { - Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_NewObj()); return TCL_OK; } if (targetInterp == NULL) { @@ -2475,9 +2482,7 @@ ChildCreate( ((Interp *) parentInterp)->maxNestingDepth; if (safe) { - if (TclMakeSafe(childInterp) == TCL_ERROR) { - goto error; - } + MakeSafe(childInterp); } else { if (Tcl_Init(childInterp) == TCL_ERROR) { goto error; @@ -2562,7 +2567,6 @@ NRChildCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *childInterp = (Tcl_Interp *)clientData; - int index; static const char *const options[] = { "alias", "aliases", "bgerror", "debug", "eval", "expose", "hide", "hidden", @@ -2574,7 +2578,7 @@ NRChildCmd( OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT - }; + } index; if (childInterp == NULL) { Tcl_Panic("TclChildObjCmd: interpreter has been deleted"); @@ -2589,7 +2593,7 @@ NRChildCmd( return TCL_ERROR; } - switch ((enum childCmdOptionsEnum) index) { + switch (index) { case OPT_ALIAS: if (objc > 2) { if (objc == 3) { @@ -2667,7 +2671,7 @@ NRChildCmd( }; enum hiddenOption { OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST - }; + } idx; namespaceName = NULL; for (i = 2; i < objc; i++) { @@ -2675,12 +2679,12 @@ NRChildCmd( break; } if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", - 0, &index) != TCL_OK) { + 0, &idx) != TCL_OK) { return TCL_ERROR; } - if (index == OPT_GLOBAL) { + if (idx == OPT_GLOBAL) { namespaceName = "::"; - } else if (index == OPT_NAMESPACE) { + } else if (idx == OPT_NAMESPACE) { if (++i == objc) { /* There must be more arguments. */ break; } else { @@ -2705,8 +2709,7 @@ NRChildCmd( }; enum LimitTypes { LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME - }; - int limitType; + } limitType; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "limitType ?-option value ...?"); @@ -2716,7 +2719,7 @@ NRChildCmd( &limitType) != TCL_OK) { return TCL_ERROR; } - switch ((enum LimitTypes) limitType) { + switch (limitType) { case LIMIT_TYPE_COMMANDS: return ChildCommandLimitCmd(interp, childInterp, 3, objc,objv); case LIMIT_TYPE_TIME: @@ -2992,7 +2995,7 @@ ChildRecursionLimit( Tcl_Obj *const objv[]) /* Argument strings. */ { Interp *iPtr; - int limit; + Tcl_WideInt limit; if (objc) { if (Tcl_IsSafe(interp)) { @@ -3002,7 +3005,7 @@ ChildRecursionLimit( (void *)NULL); return TCL_ERROR; } - if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { + if (TclGetWideIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { return TCL_ERROR; } if (limit <= 0) { @@ -3135,7 +3138,7 @@ ChildInvokeHidden( Tcl_Interp *childInterp, /* The child interpreter in which command will * be invoked. */ const char *namespaceName, /* The namespace to use, if any. */ - Tcl_Size objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int result; @@ -3260,7 +3263,7 @@ Tcl_IsSafe( /* *---------------------------------------------------------------------- * - * TclMakeSafe -- + * MakeSafe -- * * Makes its argument interpreter contain only functionality that is * defined to be part of Safe Tcl. Unsafe commands are hidden, the env @@ -3276,8 +3279,8 @@ Tcl_IsSafe( *---------------------------------------------------------------------- */ -int -TclMakeSafe( +void +MakeSafe( Tcl_Interp *interp) /* Interpreter to be made safe. */ { Tcl_Channel chan; /* Channel to remove from safe interpreter. */ @@ -3351,8 +3354,6 @@ TclMakeSafe( if (chan != NULL) { Tcl_UnregisterChannel(interp, chan); } - - return TCL_OK; } /* @@ -3578,7 +3579,7 @@ RunLimitHandlers( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree(handlerPtr); + Tcl_Free(handlerPtr); } } } @@ -3599,14 +3600,6 @@ RunLimitHandlers( *---------------------------------------------------------------------- */ -/* Bug 52dbc4b3f8: wrap Tcl_Free since it is not a Tcl_LimitHandlerDeleteProc. */ -static void -WrapFree( - void *ptr) -{ - ckfree(ptr); -} - void Tcl_LimitAddHandler( Tcl_Interp *interp, @@ -3622,15 +3615,15 @@ Tcl_LimitAddHandler( * Convert everything into a real deletion callback. */ - if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) { - deleteProc = WrapFree; + if (deleteProc == TCL_DYNAMIC) { + deleteProc = TclpFree; } /* * Allocate a handler record. */ - handlerPtr = (LimitHandler *)ckalloc(sizeof(LimitHandler)); + handlerPtr = (LimitHandler *)Tcl_Alloc(sizeof(LimitHandler)); handlerPtr->flags = 0; handlerPtr->handlerProc = handlerProc; handlerPtr->clientData = clientData; @@ -3749,7 +3742,7 @@ Tcl_LimitRemoveHandler( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree(handlerPtr); + Tcl_Free(handlerPtr); } return; } @@ -3809,7 +3802,7 @@ TclLimitRemoveAllHandlers( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree(handlerPtr); + Tcl_Free(handlerPtr); } } @@ -3842,7 +3835,7 @@ TclLimitRemoveAllHandlers( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree(handlerPtr); + Tcl_Free(handlerPtr); } } @@ -4237,7 +4230,7 @@ DeleteScriptLimitCallback( if (limitCBPtr->entryPtr != NULL) { Tcl_DeleteHashEntry(limitCBPtr->entryPtr); } - ckfree(limitCBPtr); + Tcl_Free(limitCBPtr); } /* @@ -4320,7 +4313,7 @@ SetScriptLimitCallback( key.type = type; if (scriptObj == NULL) { - hashPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); + hashPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key); if (hashPtr != NULL) { Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback, Tcl_GetHashValue(hashPtr)); @@ -4337,7 +4330,7 @@ SetScriptLimitCallback( limitCBPtr); } - limitCBPtr = (ScriptLimitCallback *)ckalloc(sizeof(ScriptLimitCallback)); + limitCBPtr = (ScriptLimitCallback *)Tcl_Alloc(sizeof(ScriptLimitCallback)); limitCBPtr->interp = interp; limitCBPtr->scriptObj = scriptObj; limitCBPtr->entryPtr = hashPtr; @@ -4497,9 +4490,8 @@ ChildCommandLimitCmd( }; enum Options { OPT_CMD, OPT_GRAN, OPT_VAL - }; + } index; Interp *iPtr = (Interp *) interp; - int index; ScriptLimitCallbackKey key; ScriptLimitCallback *limitCBPtr; Tcl_HashEntry *hPtr; @@ -4524,7 +4516,7 @@ ChildCommandLimitCmd( TclNewObj(dictPtr); key.interp = childInterp; key.type = TCL_LIMIT_COMMANDS; - hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); + hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key); if (hPtr != NULL) { limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { @@ -4562,11 +4554,11 @@ ChildCommandLimitCmd( 0, &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum Options) index) { + switch (index) { case OPT_CMD: key.interp = childInterp; key.type = TCL_LIMIT_COMMANDS; - hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); + hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key); if (hPtr != NULL) { limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { @@ -4600,10 +4592,10 @@ ChildCommandLimitCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum Options) index) { + switch (index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) TclGetStringFromObj(scriptObj, &scriptLen); + (void) Tcl_GetStringFromObj(scriptObj, &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4620,7 +4612,7 @@ ChildCommandLimitCmd( break; case OPT_VAL: limitObj = objv[i+1]; - (void) TclGetStringFromObj(objv[i+1], &limitLen); + (void) Tcl_GetStringFromObj(objv[i+1], &limitLen); if (limitLen == 0) { break; } @@ -4686,9 +4678,8 @@ ChildTimeLimitCmd( }; enum Options { OPT_CMD, OPT_GRAN, OPT_MILLI, OPT_SEC - }; + } index; Interp *iPtr = (Interp *) interp; - int index; ScriptLimitCallbackKey key; ScriptLimitCallback *limitCBPtr; Tcl_HashEntry *hPtr; @@ -4713,7 +4704,7 @@ ChildTimeLimitCmd( TclNewObj(dictPtr); key.interp = childInterp; key.type = TCL_LIMIT_TIME; - hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); + hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key); if (hPtr != NULL) { limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { @@ -4757,11 +4748,11 @@ ChildTimeLimitCmd( 0, &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum Options) index) { + switch (index) { case OPT_CMD: key.interp = childInterp; key.type = TCL_LIMIT_TIME; - hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); + hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, &key); if (hPtr != NULL) { limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { @@ -4810,10 +4801,10 @@ ChildTimeLimitCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum Options) index) { + switch (index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) TclGetStringFromObj(objv[i+1], &scriptLen); + (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4830,39 +4821,39 @@ ChildTimeLimitCmd( break; case OPT_MILLI: milliObj = objv[i+1]; - (void) TclGetStringFromObj(objv[i+1], &milliLen); + (void) Tcl_GetStringFromObj(objv[i+1], &milliLen); if (milliLen == 0) { break; } if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { return TCL_ERROR; } - if (tmp < 0 || tmp > LONG_MAX) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "milliseconds must be between 0 and %ld", LONG_MAX)); + if (tmp < 0) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "milliseconds must be non-negative", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", (void *)NULL); return TCL_ERROR; } - limitMoment.usec = ((long)tmp)*1000; + limitMoment.usec = tmp*1000; break; case OPT_SEC: secObj = objv[i+1]; - (void) TclGetStringFromObj(objv[i+1], &secLen); + (void) Tcl_GetStringFromObj(objv[i+1], &secLen); if (secLen == 0) { break; } if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { return TCL_ERROR; } - if (tmp < 0 || tmp > LONG_MAX) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "seconds must be between 0 and %ld", LONG_MAX)); + if (tmp < 0) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "seconds must be non-negative", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", (void *)NULL); return TCL_ERROR; } - limitMoment.sec = (long)tmp; + limitMoment.sec = (long long)tmp; break; } } diff --git a/generic/tclLink.c b/generic/tclLink.c index 9443db4..bb7b6ba 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -25,7 +25,7 @@ * variable. */ -typedef struct Link { +typedef struct { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ Namespace *nsPtr; /* Namespace containing Tcl variable */ Tcl_Obj *varName; /* Name of variable (must be global). This is @@ -33,10 +33,10 @@ typedef struct Link { * actual variable may be aliased at that time * via upvar. */ void *addr; /* Location of C variable. */ - int bytes; /* Size of C variable array. This is 0 when + Tcl_Size bytes; /* Size of C variable array. This is 0 when * single variables, and >0 used for array * variables. */ - int numElems; /* Number of elements in C variable array. + Tcl_Size numElems; /* Number of elements in C variable array. * Zero for single variables. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { @@ -114,7 +114,8 @@ static Tcl_ObjType invalidRealType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -171,21 +172,13 @@ Tcl_LinkVar( return TCL_ERROR; } - linkPtr = (Link *)ckalloc(sizeof(Link)); + linkPtr = (Link *)Tcl_Alloc(sizeof(Link)); linkPtr->interp = interp; linkPtr->nsPtr = NULL; linkPtr->varName = Tcl_NewStringObj(varName, -1); Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; linkPtr->type = type & ~TCL_LINK_READ_ONLY; -#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \ - || defined(_WIN32) || defined(__CYGWIN__)) - if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) { - linkPtr->type = TCL_LINK_LONG; - } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) { - linkPtr->type = TCL_LINK_ULONG; - } -#endif if (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; } else { @@ -245,7 +238,7 @@ Tcl_LinkArray( * interpreter result. */ int type, /* Type of C variable: TCL_LINK_INT, etc. Also * may have TCL_LINK_READ_ONLY OR'ed in. */ - int size) /* Size of C variable array, >1 if array */ + Tcl_Size size) /* Size of C variable array, >1 if array */ { Tcl_Obj *objPtr; Link *linkPtr; @@ -259,16 +252,8 @@ Tcl_LinkArray( return TCL_ERROR; } - linkPtr = (Link *)ckalloc(sizeof(Link)); + linkPtr = (Link *)Tcl_Alloc(sizeof(Link)); linkPtr->type = type & ~TCL_LINK_READ_ONLY; -#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \ - || defined(_WIN32) || defined(__CYGWIN__)) - if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) { - linkPtr->type = TCL_LINK_LONG; - } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) { - linkPtr->type = TCL_LINK_ULONG; - } -#endif linkPtr->numElems = size; if (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; @@ -305,14 +290,6 @@ Tcl_LinkArray( case TCL_LINK_UINT: linkPtr->bytes = size * sizeof(unsigned int); break; -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) - case TCL_LINK_LONG: - linkPtr->bytes = size * sizeof(long); - break; - case TCL_LINK_ULONG: - linkPtr->bytes = size * sizeof(unsigned long); - break; -#endif case TCL_LINK_FLOAT: linkPtr->bytes = size * sizeof(float); break; @@ -327,7 +304,7 @@ Tcl_LinkArray( */ if (addr == NULL) { - linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes); + linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes); linkPtr->flags |= LINK_ALLOC_LAST; addr = (char *) &linkPtr->lastValue.cPtr; } @@ -348,7 +325,7 @@ Tcl_LinkArray( */ if (addr == NULL) { - linkPtr->addr = ckalloc(linkPtr->bytes); + linkPtr->addr = Tcl_Alloc(linkPtr->bytes); linkPtr->flags |= LINK_ALLOC_ADDR; } else { linkPtr->addr = addr; @@ -359,7 +336,7 @@ Tcl_LinkArray( */ if (size > 1) { - linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes); + linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes); linkPtr->flags |= LINK_ALLOC_LAST; } @@ -510,7 +487,7 @@ GetWide( Tcl_Obj *objPtr, Tcl_WideInt *widePtr) { - if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) { + if (TclGetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) { int intValue; if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { @@ -591,9 +568,9 @@ SetInvalidRealFromAny( { const char *str; const char *endPtr; - int length; + Tcl_Size length; - str = TclGetStringFromObj(objPtr, &length); + str = Tcl_GetStringFromObj(objPtr, &length); if ((length == 1) && (str[0] == '.')) { objPtr->typePtr = &invalidRealType; objPtr->internalRep.doubleValue = 0.0; @@ -637,8 +614,8 @@ GetInvalidIntFromObj( Tcl_Obj *objPtr, int *intPtr) { - int length; - const char *str = TclGetStringFromObj(objPtr, &length); + Tcl_Size length; + const char *str = Tcl_GetStringFromObj(objPtr, &length); if ((length == 0) || ((length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) { @@ -714,7 +691,7 @@ LinkTraceProc( { Link *linkPtr = (Link *)clientData; int changed; - int valueLength; + Tcl_Size valueLength = 0; const char *value; char **pp; Tcl_Obj *valueObj; @@ -722,9 +699,8 @@ LinkTraceProc( Tcl_WideInt valueWide; Tcl_WideUInt valueUWide; double valueDouble; - int objc; + Tcl_Size objc, i; Tcl_Obj **objv; - int i; /* * If the variable is being unset, then just re-create it (with a trace) @@ -738,7 +714,7 @@ LinkTraceProc( } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL, + Tcl_TraceVar2(interp, TclGetString(linkPtr->varName), NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES |TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); } @@ -799,14 +775,6 @@ LinkTraceProc( case TCL_LINK_UINT: changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); break; -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) - case TCL_LINK_LONG: - changed = (LinkedVar(long) != linkPtr->lastValue.l); - break; - case TCL_LINK_ULONG: - changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); - break; -#endif case TCL_LINK_FLOAT: changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f); break; @@ -856,16 +824,15 @@ LinkTraceProc( switch (linkPtr->type) { case TCL_LINK_STRING: - value = TclGetStringFromObj(valueObj, &valueLength); - valueLength++; /* include end of string char */ + value = Tcl_GetStringFromObj(valueObj, &valueLength); pp = (char **) linkPtr->addr; - *pp = (char *)ckrealloc(*pp, valueLength); + *pp = (char *)Tcl_Realloc(*pp, ++valueLength); memcpy(*pp, value, valueLength); return NULL; case TCL_LINK_CHARS: - value = (char *) TclGetStringFromObj(valueObj, &valueLength); + value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength); valueLength++; /* include end of string char */ if (valueLength > linkPtr->bytes) { return (char *) "wrong size of char* value"; @@ -880,8 +847,10 @@ LinkTraceProc( return NULL; case TCL_LINK_BINARY: - value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength); - if (valueLength != linkPtr->bytes) { + value = (char *) Tcl_GetBytesFromObj(NULL, valueObj, &valueLength); + if (value == NULL) { + return (char *) "invalid binary value"; + } else if (valueLength != linkPtr->bytes) { return (char *) "wrong size of binary value"; } if (linkPtr->flags & LINK_ALLOC_LAST) { @@ -916,7 +885,7 @@ LinkTraceProc( switch (linkPtr->type) { case TCL_LINK_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { + for (i = 0; i < objc; i++) { int *varPtr = &linkPtr->lastValue.iPtr[i]; if (GetInt(objv[i], varPtr)) { @@ -1120,55 +1089,6 @@ LinkTraceProc( (unsigned int) valueWide; } break; - -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) - case TCL_LINK_LONG: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetWide(objv[i], &valueWide) - || !InRange(LONG_MIN, valueWide, LONG_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have long value"; - } - linkPtr->lastValue.lPtr[i] = (long) valueWide; - } - } else { - if (GetWide(valueObj, &valueWide) - || !InRange(LONG_MIN, valueWide, LONG_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have long value"; - } - LinkedVar(long) = linkPtr->lastValue.l = (long) valueWide; - } - break; - - case TCL_LINK_ULONG: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetUWide(objv[i], &valueUWide) - || (valueUWide > ULONG_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) - "variable array must have unsigned long value"; - } - linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide; - } - } else { - if (GetUWide(valueObj, &valueUWide) - || (valueUWide > ULONG_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned long value"; - } - LinkedVar(unsigned long) = linkPtr->lastValue.ul = - (unsigned long) valueUWide; - } - break; -#endif - case TCL_LINK_WIDE_UINT: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { @@ -1248,18 +1168,18 @@ ObjValue( { char *p; Tcl_Obj *resultObj, **objv; - int i; + Tcl_Size i; switch (linkPtr->type) { case TCL_LINK_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.iPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); + Tcl_Free(objv); return resultObj; } linkPtr->lastValue.i = LinkedVar(int); @@ -1267,12 +1187,12 @@ ObjValue( case TCL_LINK_WIDE_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.wPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); + Tcl_Free(objv); return resultObj; } linkPtr->lastValue.w = LinkedVar(Tcl_WideInt); @@ -1280,12 +1200,12 @@ ObjValue( case TCL_LINK_DOUBLE: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewDoubleObj(objv[i], linkPtr->lastValue.dPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); + Tcl_Free(objv); return resultObj; } linkPtr->lastValue.d = LinkedVar(double); @@ -1293,12 +1213,12 @@ ObjValue( case TCL_LINK_BOOLEAN: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.iPtr[i] != 0); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); + Tcl_Free(objv); return resultObj; } linkPtr->lastValue.i = LinkedVar(int); @@ -1306,12 +1226,12 @@ ObjValue( case TCL_LINK_CHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.cPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); + Tcl_Free(objv); return resultObj; } linkPtr->lastValue.c = LinkedVar(char); @@ -1319,12 +1239,12 @@ ObjValue( case TCL_LINK_UCHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.ucPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); + Tcl_Free(objv); return resultObj; } linkPtr->lastValue.uc = LinkedVar(unsigned char); @@ -1332,12 +1252,12 @@ ObjValue( case TCL_LINK_SHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.sPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); + Tcl_Free(objv); return resultObj; } linkPtr->lastValue.s = LinkedVar(short); @@ -1345,12 +1265,12 @@ ObjValue( case TCL_LINK_USHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.usPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); + Tcl_Free(objv); return resultObj; } linkPtr->lastValue.us = LinkedVar(unsigned short); @@ -1358,53 +1278,25 @@ ObjValue( case TCL_LINK_UINT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.uiPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); + Tcl_Free(objv); return resultObj; } linkPtr->lastValue.ui = LinkedVar(unsigned int); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui); -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) - case TCL_LINK_LONG: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], linkPtr->lastValue.lPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); - return resultObj; - } - linkPtr->lastValue.l = LinkedVar(long); - return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l); - case TCL_LINK_ULONG: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], linkPtr->lastValue.ulPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); - return resultObj; - } - linkPtr->lastValue.ul = LinkedVar(unsigned long); - return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); -#endif case TCL_LINK_FLOAT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewDoubleObj(objv[i], linkPtr->lastValue.fPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); + Tcl_Free(objv); return resultObj; } linkPtr->lastValue.f = LinkedVar(float); @@ -1412,12 +1304,12 @@ ObjValue( case TCL_LINK_WIDE_UINT: { if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewUIntObj(objv[i], linkPtr->lastValue.uwPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - ckfree(objv); + Tcl_Free(objv); return resultObj; } linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); @@ -1488,12 +1380,12 @@ LinkFree( TclNsDecrRefCount(linkPtr->nsPtr); } if (linkPtr->flags & LINK_ALLOC_ADDR) { - ckfree(linkPtr->addr); + Tcl_Free(linkPtr->addr); } if (linkPtr->flags & LINK_ALLOC_LAST) { - ckfree(linkPtr->lastValue.aryPtr); + Tcl_Free(linkPtr->lastValue.aryPtr); } - ckfree((char *) linkPtr); + Tcl_Free(linkPtr); } /* diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 94322f2..4b67f98 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -68,8 +68,7 @@ /* Checks for when caller should have already converted to internal list type */ #define LIST_ASSERT_TYPE(listObj_) \ - LIST_ASSERT((listObj_)->typePtr == &tclListType); - + LIST_ASSERT(TclHasInternalRep((listObj_), &tclListType)) /* * If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the @@ -142,6 +141,7 @@ static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfList(Tcl_Obj *listPtr); +static Tcl_Size ListLength(Tcl_Obj *listPtr); /* * The structure below defines the list Tcl object type by means of functions @@ -155,7 +155,8 @@ const Tcl_ObjType tclListType = { FreeListInternalRep, /* freeIntRepProc */ DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ - SetListFromAny /* setFromAnyProc */ + SetListFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V1(ListLength) }; /* Macros to manipulate the List internal rep */ @@ -240,7 +241,7 @@ ListSpanNew( Tcl_Size firstSlot, /* Starting slot index of the span */ Tcl_Size numSlots) /* Number of slots covered by the span */ { - ListSpan *spanPtr = (ListSpan *) ckalloc(sizeof(*spanPtr)); + ListSpan *spanPtr = (ListSpan *) Tcl_Alloc(sizeof(*spanPtr)); spanPtr->refCount = 0; spanPtr->spanStart = firstSlot; spanPtr->spanLength = numSlots; @@ -267,7 +268,7 @@ static inline void ListSpanDecrRefs(ListSpan *spanPtr) { if (spanPtr->refCount <= 1) { - ckfree(spanPtr); + Tcl_Free(spanPtr); } else { spanPtr->refCount -= 1; } @@ -300,12 +301,12 @@ ListSpanMerited( Tcl_Size allocatedStorageLength) /* Length of the currently allocation */ { /* - TODO - - heuristics thresholds need to be determined - - currently, information about the sharing (ref count) of existing - storage is not passed. Perhaps it should be. For example if the - existing storage has a "large" ref count, then it might make sense - to do even a small span. + * Possible optimizations for future consideration + * - heuristic LIST_SPAN_THRESHOLD + * - currently, information about the sharing (ref count) of existing + * storage is not passed. Perhaps it should be. For example if the + * existing storage has a "large" ref count, then it might make sense + * to do even a small span. */ if (length < LIST_SPAN_THRESHOLD) { @@ -324,30 +325,6 @@ ListSpanMerited( /* *------------------------------------------------------------------------ * - * ListStoreUpSize -- - * - * For reasons of efficiency, extra space is allocated for a ListStore - * compared to what was requested. This function calculates how many - * slots should actually be allocated for a given request size. - * - * Results: - * Number of slots to allocate. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------ - */ -static inline Tcl_Size -ListStoreUpSize(Tcl_Size numSlotsRequested) { - /* TODO -how much extra? May be double only for smaller requests? */ - return numSlotsRequested < (LIST_MAX / 2) ? 2 * numSlotsRequested - : LIST_MAX; -} - -/* - *------------------------------------------------------------------------ - * * ListRepFreeUnreferenced -- * * Inline wrapper for ListRepUnsharedFreeUnreferenced that does quick checks @@ -768,16 +745,15 @@ ListStoreNew( return NULL; } + storePtr = NULL; if (flags & LISTREP_SPACE_FLAGS) { - capacity = ListStoreUpSize(objc); + /* Caller requests extra space front, back or both */ + storePtr = (ListStore *)TclAttemptAllocElemsEx( + objc, sizeof(Tcl_Obj *), offsetof(ListStore, slots), &capacity); } else { + /* Exact allocation */ capacity = objc; - } - - storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity)); - if (storePtr == NULL && capacity != objc) { - capacity = objc; /* Try allocating exact size */ - storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity)); + storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity)); } if (storePtr == NULL) { if (flags & LISTREP_PANIC_ON_FAIL) { @@ -845,21 +821,20 @@ ListStore * ListStoreReallocate (ListStore *storePtr, Tcl_Size needed) { Tcl_Size capacity; - ListStore *newStorePtr; - - capacity = ListStoreUpSize(needed); - newStorePtr = - (ListStore *)attemptckrealloc(storePtr, LIST_SIZE(capacity)); - if (newStorePtr == NULL) { - capacity = needed; - newStorePtr = (ListStore *)attemptckrealloc(storePtr, - LIST_SIZE(capacity)); - if (newStorePtr == NULL) - return NULL; + + if (needed > LIST_MAX) { + return NULL; } + storePtr = (ListStore *)TclAttemptReallocElemsEx(storePtr, + needed, + sizeof(Tcl_Obj *), + offsetof(ListStore, slots), + &capacity); /* Only the capacity has changed, fix it in the header */ - newStorePtr->numAllocated = capacity; - return newStorePtr; + if (storePtr) { + storePtr->numAllocated = capacity; + } + return storePtr; } /* @@ -1371,6 +1346,9 @@ TclListObjCopy( Tcl_Obj *copyObj; if (!TclHasInternalRep(listObj, &tclListType)) { + if (TclObjTypeHasProc(listObj, lengthProc)) { + return Tcl_DuplicateObj(listObj); + } if (SetListFromAny(interp, listObj) != TCL_OK) { return NULL; } @@ -1475,7 +1453,6 @@ ListRepRange( ListRepElements(srcRepPtr, numSrcElems, srcElems); numAfterRangeEnd = numSrcElems - (rangeEnd + 1); /* Assert: Because numSrcElems > rangeEnd earlier */ - LIST_ASSERT(numAfterRangeEnd >= 0); if (numAfterRangeEnd != 0) { /* T:listrep-1.{8,9} */ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); @@ -1548,7 +1525,6 @@ ListRepRange( /* Ditto for trailing */ numAfterRangeEnd = numSrcElems - (rangeEnd + 1); /* Assert: Because numSrcElems > rangeEnd earlier */ - LIST_ASSERT(numAfterRangeEnd >= 0); if (numAfterRangeEnd != 0) { /* T:listrep-3.17 */ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); @@ -1627,6 +1603,29 @@ TclListObjRange( /* *---------------------------------------------------------------------- * + * TclListObjGetElement -- + * + * Returns a single element from the array of the elements in a list + * object, without doing doing any bounds checking. Caller must ensure + * that ObjPtr of of type 'tclListType' and that index is valid for the + * list. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclListObjGetElement( + Tcl_Obj *objPtr, /* List object for which an element array is + * to be returned. */ + Tcl_Size index +) +{ + return ListObjStorePtr(objPtr)->slots[ListObjStart(objPtr) + index]; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ListObjGetElements -- * * This function returns an (objc,objv) array of the elements in a list @@ -1667,12 +1666,12 @@ Tcl_ListObjGetElements( { ListRep listRep; - if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { - return TclArithSeriesGetElements(interp, objPtr, objcPtr, objvPtr); + if (TclObjTypeHasProc(objPtr, getElementsProc)) { + return TclObjTypeGetElements(interp, objPtr, objcPtr, objvPtr); + } + if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) { + return TCL_ERROR; } - - if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) - return TCL_ERROR; ListRepElements(&listRep, *objcPtr, *objvPtr); return TCL_OK; } @@ -1959,6 +1958,11 @@ Tcl_ListObjIndex( return TCL_OK; } + int hasAbstractList = TclObjTypeHasProc(listObj,indexProc) != 0; + if (hasAbstractList) { + return TclObjTypeIndex(interp, listObj, index, objPtrPtr); + } + if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs) != TCL_OK) { return TCL_ERROR; @@ -2009,8 +2013,8 @@ Tcl_ListObjLength( return TCL_OK; } - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - *lenPtr = TclArithSeriesObjLength(listObj); + if (TclObjTypeHasProc(listObj, lengthProc)) { + *lenPtr = TclObjTypeLength(listObj); return TCL_OK; } @@ -2021,6 +2025,15 @@ Tcl_ListObjLength( *lenPtr = ListRepLength(&listRep); return TCL_OK; } + +Tcl_Size +ListLength(Tcl_Obj *listPtr) +{ + ListRep listRep; + ListObjGetRep(listPtr, &listRep); + + return ListRepLength(&listRep); +} /* *---------------------------------------------------------------------- @@ -2083,6 +2096,11 @@ Tcl_ListObjReplace( Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } + if (TclObjTypeHasProc(listObj, replaceProc)) { + return TclObjTypeReplace(interp, listObj, first, + numToDelete, numToInsert, insertObjs); + } + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) return TCL_ERROR; /* Cannot be converted to a list */ @@ -2633,9 +2651,9 @@ TclLindexFlat( int status; Tcl_Size i; - /* Handle ArithSeries as special case */ - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - Tcl_Size listLen = TclArithSeriesObjLength(listObj); + /* Handle AbstractList as special case */ + if (TclObjTypeHasProc(listObj,indexProc)) { + Tcl_Size listLen = TclObjTypeLength(listObj); Tcl_Size index; Tcl_Obj *elemObj = NULL; for (i=0 ; i<indexCount && listObj ; i++) { @@ -2643,12 +2661,14 @@ TclLindexFlat( &index) == TCL_OK) { } if (i==0) { - elemObj = TclArithSeriesObjIndex(NULL, listObj, index); + if (TclObjTypeIndex(interp, listObj, index, &elemObj) != TCL_OK) { + return NULL; + } } else if (index > 0) { - /* ArithSeries cannot be a list of lists */ + // TODO: support nested lists + Tcl_Obj *e2Obj = TclLindexFlat(interp, elemObj, 1, &indexArray[i]); Tcl_DecrRefCount(elemObj); - TclNewObj(elemObj); - break; + elemObj = e2Obj; } } Tcl_IncrRefCount(elemObj); @@ -2768,9 +2788,16 @@ TclLsetList( && TclGetIntForIndexM(NULL, indexArgObj, TCL_SIZE_MAX - 1, &index) == TCL_OK) { - /* indexArgPtr designates a single index. */ - /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */ - retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); + if (TclObjTypeHasProc(listObj, setElementProc)) { + indices = &indexArgObj; + retValueObj = + TclObjTypeSetElement(interp, listObj, 1, indices, valueObj); + if (retValueObj) Tcl_IncrRefCount(retValueObj); + } else { + /* indexArgPtr designates a single index. */ + /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */ + retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); + } } else { @@ -2803,6 +2830,7 @@ TclLsetList( } } } + assert (retValueObj==NULL || retValueObj->typePtr || retValueObj->bytes); return retValueObj; } @@ -2896,7 +2924,7 @@ TclLsetFlat( if (indexCount > (int) (sizeof(pendingInvalidates) / sizeof(pendingInvalidates[0]))) { pendingInvalidatesPtr = - (Tcl_Obj **) ckalloc(indexCount * sizeof(*pendingInvalidatesPtr)); + (Tcl_Obj **) Tcl_Alloc(indexCount * sizeof(*pendingInvalidatesPtr)); } /* @@ -3049,7 +3077,7 @@ TclLsetFlat( } if (pendingInvalidatesPtr != pendingInvalidates) - ckfree(pendingInvalidatesPtr); + Tcl_Free(pendingInvalidatesPtr); if (result != TCL_OK) { /* @@ -3208,7 +3236,7 @@ FreeListInternalRep( ObjArrayDecrRefs( listRep.storePtr->slots, listRep.storePtr->firstUsed, listRep.storePtr->numUsed); - ckfree(listRep.storePtr); + Tcl_Free(listRep.storePtr); } if (listRep.spanPtr) { ListSpanDecrRefs(listRep.spanPtr); @@ -3315,38 +3343,35 @@ SetListFromAny( Tcl_IncrRefCount(valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } - } else if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { - /* - * Convertion from Arithmetic Series is a special case - * because it can be done an order of magnitude faster - * and may occur frequently. - */ - Tcl_Size j, size = TclArithSeriesObjLength(objPtr); + } else if (TclObjTypeHasProc(objPtr,indexProc)) { + Tcl_Size elemCount, i; - /* TODO - leave space in front and/or back? */ - if (ListRepInitAttempt( - interp, size > 0 ? size : 1, NULL, &listRep) - != TCL_OK) { + elemCount = TclObjTypeLength(objPtr); + + if (ListRepInitAttempt(interp, elemCount, NULL, &listRep) != TCL_OK) { return TCL_ERROR; } LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */ LIST_ASSERT(listRep.storePtr->firstUsed == 0); - LIST_ASSERT((listRep.storePtr->flags & LISTSTORE_CANONICAL) == 0); - listRep.storePtr->numUsed = size; elemPtrs = listRep.storePtr->slots; - for (j = 0; j < size; j++) { - elemPtrs[j] = TclArithSeriesObjIndex(interp, objPtr, j); - if (elemPtrs[j] == NULL) { + + /* Each iteration, store a list element */ + for (i = 0; i < elemCount; i++) { + if (TclObjTypeIndex(interp, objPtr, i, elemPtrs) != TCL_OK) { return TCL_ERROR; } - Tcl_IncrRefCount(elemPtrs[j]); + Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } + LIST_ASSERT((Tcl_Size)(elemPtrs - listRep.storePtr->slots) == elemCount); + + listRep.storePtr->numUsed = elemCount; + } else { Tcl_Size estCount, length; - const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); + const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length); /* * Allocate enough space to hold a (Tcl_Obj *) for each @@ -3381,7 +3406,7 @@ fail: while (--elemPtrs >= listRep.storePtr->slots) { Tcl_DecrRefCount(*elemPtrs); } - ckfree(listRep.storePtr); + Tcl_Free(listRep.storePtr); return TCL_ERROR; } if (elemStart == limit) { @@ -3455,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; @@ -3502,19 +3527,16 @@ UpdateStringOfList( flagPtr = localFlags; } else { /* We know numElems <= LIST_MAX, so this is safe. */ - flagPtr = (char *)ckalloc(numElems); + flagPtr = (char *)Tcl_Alloc(numElems); } for (i = 0; i < numElems; i++) { flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); - elem = TclGetStringFromObj(elemPtrs[i], &length); + elem = Tcl_GetStringFromObj(elemPtrs[i], &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); - if (bytesNeeded > INT_MAX) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + if (bytesNeeded > SIZE_MAX - numElems) { + Tcl_Panic("max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded", SIZE_MAX); } } - if (bytesNeeded + numElems > INT_MAX + 1U) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } bytesNeeded += numElems - 1; /* @@ -3525,7 +3547,7 @@ UpdateStringOfList( TclOOM(dst, bytesNeeded); for (i = 0; i < numElems; i++) { flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); - elem = TclGetStringFromObj(elemPtrs[i], &length); + elem = Tcl_GetStringFromObj(elemPtrs[i], &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; } @@ -3534,7 +3556,7 @@ UpdateStringOfList( (void) Tcl_InitStringRep(listObj, NULL, dst - 1 - start); if (flagPtr != localFlags) { - ckfree(flagPtr); + Tcl_Free(flagPtr); } } diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 3966901..9d89586 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -28,10 +28,10 @@ * Function prototypes for static functions in this file: */ -static int AddLocalLiteralEntry(CompileEnv *envPtr, +static size_t AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); -static unsigned HashString(const char *string, int length); +static size_t HashString(const char *string, size_t length); #ifdef TCL_COMPILE_DEBUG static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -133,7 +133,7 @@ TclDeleteLiteralTable( objPtr = entryPtr->objPtr; TclDecrRefCount(objPtr); nextPtr = entryPtr->nextPtr; - ckfree(entryPtr); + Tcl_Free(entryPtr); entryPtr = nextPtr; } } @@ -143,7 +143,7 @@ TclDeleteLiteralTable( */ if (tablePtr->buckets != tablePtr->staticBuckets) { - ckfree(tablePtr->buckets); + Tcl_Free(tablePtr->buckets); } } @@ -178,9 +178,9 @@ TclCreateLiteral( Interp *iPtr, const char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ - int length, /* Number of bytes in the string. */ - unsigned hash, /* The string's hash. If -1, it will be - * computed here. */ + Tcl_Size length, /* Number of bytes in the string. */ + size_t hash, /* The string's hash. If the value is + * TCL_INDEX_NONE, it will be computed here. */ int *newPtr, Namespace *nsPtr, int flags, @@ -188,14 +188,14 @@ TclCreateLiteral( { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; - unsigned int globalHash; + size_t globalHash; Tcl_Obj *objPtr; /* * Is it in the interpreter's global literal table? */ - if (hash == (unsigned) -1) { + if (hash == (size_t) TCL_INDEX_NONE) { hash = HashString(bytes, length); } globalHash = (hash & globalTablePtr->mask); @@ -210,8 +210,8 @@ TclCreateLiteral( * https://stackoverflow.com/q/54337750/301832 */ - int objLength; - const char *objBytes = TclGetStringFromObj(objPtr, &objLength); + Tcl_Size objLength; + const char *objBytes = Tcl_GetStringFromObj(objPtr, &objLength); if ((objLength == length) && ((length == 0) || ((objBytes[0] == bytes[0]) @@ -227,7 +227,7 @@ TclCreateLiteral( *globalPtrPtr = globalPtr; } if (flags & LITERAL_ON_HEAP) { - ckfree(bytes); + Tcl_Free((void *)bytes); } if (globalPtr->refCount != TCL_INDEX_NONE) { globalPtr->refCount++; @@ -238,7 +238,7 @@ TclCreateLiteral( } if (!newPtr) { if ((flags & LITERAL_ON_HEAP)) { - ckfree(bytes); + Tcl_Free((void *)bytes); } return NULL; } @@ -274,11 +274,11 @@ TclCreateLiteral( #ifdef TCL_COMPILE_DEBUG if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", - "TclRegisterLiteral", (length>60? 60 : length), bytes); + "TclRegisterLiteral", (length>60? 60 : (int)length), bytes); } #endif - globalPtr = (LiteralEntry *)ckalloc(sizeof(LiteralEntry)); + globalPtr = (LiteralEntry *)Tcl_Alloc(sizeof(LiteralEntry)); globalPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); globalPtr->refCount = 1; @@ -314,7 +314,7 @@ TclCreateLiteral( } if (!found) { Tcl_Panic("%s: literal \"%.*s\" wasn't global", - "TclRegisterLiteral", (length>60? 60 : length), bytes); + "TclRegisterLiteral", (length>60? 60 : (int)length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ @@ -351,10 +351,10 @@ Tcl_Obj * TclFetchLiteral( CompileEnv *envPtr, /* Points to the CompileEnv from which to * fetch the registered literal value. */ - unsigned int index) /* Index of the desired literal, as returned + Tcl_Size index) /* Index of the desired literal, as returned * by prior call to TclRegisterLiteral() */ { - if (index >= (unsigned int) envPtr->literalArrayNext) { + if (index >= envPtr->literalArrayNext) { return NULL; } return envPtr->literalArrayPtr[index].objPtr; @@ -387,14 +387,14 @@ TclFetchLiteral( *---------------------------------------------------------------------- */ -int +int /* Do NOT change this type. Should not be wider than TclEmitPush operand*/ TclRegisterLiteral( void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ const char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object * array. */ - int length, /* Number of bytes in the string. If < 0, the + Tcl_Size length, /* Number of bytes in the string. If -1, the * string consists of all bytes up to the * first null character. */ int flags) /* If LITERAL_ON_HEAP then the caller already @@ -408,9 +408,8 @@ TclRegisterLiteral( LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; - unsigned hash; - unsigned int localHash; - int objIndex, isNew; + size_t hash, localHash, objIndex; + int isNew; Namespace *nsPtr; if (length < 0) { @@ -431,13 +430,16 @@ TclRegisterLiteral( || ((objPtr->bytes[0] == bytes[0]) && (memcmp(objPtr->bytes, bytes, length) == 0)))) { if ((flags & LITERAL_ON_HEAP)) { - ckfree(bytes); + Tcl_Free((void *)bytes); } objIndex = (localPtr - envPtr->literalArrayPtr); #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(envPtr); #endif /*TCL_COMPILE_DEBUG*/ + if (objIndex > INT_MAX) { + Tcl_Panic("Literal table index too large. Cannot be handled by TclEmitPush"); + } return objIndex; } } @@ -469,13 +471,17 @@ TclRegisterLiteral( objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash); #ifdef TCL_COMPILE_DEBUG - if (globalPtr != NULL && globalPtr->refCount + 1 < 2) { - Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", - "TclRegisterLiteral", (length>60? 60 : length), bytes, + if (globalPtr != NULL && (globalPtr->refCount + 1 < 2)) { + Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u", + "TclRegisterLiteral", (length>60? 60 : (int)length), bytes, globalPtr->refCount); } TclVerifyLocalLiteralTable(envPtr); #endif /*TCL_COMPILE_DEBUG*/ + if (objIndex > INT_MAX) { + Tcl_Panic( + "Literal table index too large. Cannot be handled by TclEmitPush"); + } return objIndex; } @@ -509,9 +515,9 @@ LookupLiteralEntry( LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *entryPtr; const char *bytes; - int length, globalHash; + size_t globalHash, length; - bytes = TclGetStringFromObj(objPtr, &length); + bytes = Tcl_GetStringFromObj(objPtr, &length); globalHash = (HashString(bytes, length) & globalTablePtr->mask); for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL; entryPtr=entryPtr->nextPtr) { @@ -554,8 +560,8 @@ TclHideLiteral( { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; - unsigned int localHash; - int length; + size_t localHash; + Tcl_Size length; const char *bytes; Tcl_Obj *newObjPtr; @@ -573,7 +579,7 @@ TclHideLiteral( TclReleaseLiteral(interp, lPtr->objPtr); lPtr->objPtr = newObjPtr; - bytes = TclGetStringFromObj(newObjPtr, &length); + bytes = Tcl_GetStringFromObj(newObjPtr, &length); localHash = HashString(bytes, length) & localTablePtr->mask; nextPtrPtr = &localTablePtr->buckets[localHash]; @@ -619,13 +625,17 @@ TclAddLiteralObj( * NULL. */ { LiteralEntry *lPtr; - int objIndex; + size_t objIndex; if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) { ExpandLocalLiteralArray(envPtr); } objIndex = envPtr->literalArrayNext; envPtr->literalArrayNext++; + if (objIndex > INT_MAX) { + Tcl_Panic( + "Literal table index too large. Cannot be handled by TclEmitPush"); + } lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; @@ -658,7 +668,7 @@ TclAddLiteralObj( *---------------------------------------------------------------------- */ -static int +static size_t AddLocalLiteralEntry( CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ @@ -667,7 +677,7 @@ AddLocalLiteralEntry( { LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *localPtr; - int objIndex; + size_t objIndex; objIndex = TclAddLiteralObj(envPtr, objPtr, &localPtr); @@ -692,8 +702,8 @@ AddLocalLiteralEntry( TclVerifyLocalLiteralTable(envPtr); { char *bytes; - int length, found; - size_t i; + int found; + size_t length, i; found = 0; for (i=0 ; i<localTablePtr->numBuckets ; i++) { @@ -706,9 +716,9 @@ AddLocalLiteralEntry( } if (!found) { - bytes = TclGetStringFromObj(objPtr, &length); + bytes = Tcl_GetStringFromObj(objPtr, &length); Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", - "AddLocalLiteralEntry", (length>60? 60 : length), bytes); + "AddLocalLiteralEntry", (length>60? 60 : (int)length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ @@ -760,14 +770,14 @@ ExpandLocalLiteralArray( } if (envPtr->mallocedLiteralArray) { - newArrayPtr = (LiteralEntry *)ckrealloc(currArrayPtr, newSize); + newArrayPtr = (LiteralEntry *)Tcl_Realloc(currArrayPtr, newSize); } else { /* - * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must - * code a ckrealloc equivalent for ourselves. + * envPtr->literalArrayPtr isn't a Tcl_Alloc'd pointer, so we must + * code a Tcl_Realloc equivalent for ourselves. */ - newArrayPtr = (LiteralEntry *)ckalloc(newSize); + newArrayPtr = (LiteralEntry *)Tcl_Alloc(newSize); memcpy(newArrayPtr, currArrayPtr, currBytes); envPtr->mallocedLiteralArray = 1; } @@ -828,16 +838,16 @@ TclReleaseLiteral( LiteralTable *globalTablePtr; LiteralEntry *entryPtr, *prevPtr; const char *bytes; - int length; - unsigned int index; + size_t index; + Tcl_Size length; if (iPtr == NULL) { goto done; } globalTablePtr = &iPtr->literalTable; - bytes = TclGetStringFromObj(objPtr, &length); - index = (HashString(bytes, length) & globalTablePtr->mask); + bytes = Tcl_GetStringFromObj(objPtr, &length); + index = HashString(bytes, length) & globalTablePtr->mask; /* * Check to see if the object is in the global literal table and remove @@ -860,7 +870,7 @@ TclReleaseLiteral( } else { prevPtr->nextPtr = entryPtr->nextPtr; } - ckfree(entryPtr); + Tcl_Free(entryPtr); globalTablePtr->numEntries--; TclDecrRefCount(objPtr); @@ -898,12 +908,12 @@ TclReleaseLiteral( *---------------------------------------------------------------------- */ -static unsigned +static size_t HashString( const char *string, /* String for which to compute hash value. */ - int length) /* Number of bytes in the string. */ + size_t length) /* Number of bytes in the string. */ { - unsigned int result = 0; + size_t result = 0; /* * I tried a zillion different hash functions and asked many other people @@ -972,8 +982,8 @@ RebuildLiteralTable( LiteralEntry *entryPtr; LiteralEntry **bucketPtr; const char *bytes; - unsigned int oldSize, index; - int count, length; + size_t oldSize, count, index; + Tcl_Size length; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; @@ -994,7 +1004,7 @@ RebuildLiteralTable( } tablePtr->numBuckets *= 4; - tablePtr->buckets = (LiteralEntry **)ckalloc( + tablePtr->buckets = (LiteralEntry **)Tcl_Alloc( tablePtr->numBuckets * sizeof(LiteralEntry*)); for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets; count>0 ; count--, newChainPtr++) { @@ -1009,7 +1019,7 @@ RebuildLiteralTable( for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) { for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) { - bytes = TclGetStringFromObj(entryPtr->objPtr, &length); + bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length); index = (HashString(bytes, length) & tablePtr->mask); *oldChainPtr = entryPtr->nextPtr; @@ -1024,7 +1034,7 @@ RebuildLiteralTable( */ if (oldBuckets != tablePtr->staticBuckets) { - ckfree(oldBuckets); + Tcl_Free(oldBuckets); } } @@ -1061,7 +1071,7 @@ TclInvalidateCmdLiteral( { Interp *iPtr = (Interp *) interp; Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name, - strlen(name), -1, NULL, nsPtr, 0, NULL); + strlen(name), TCL_INDEX_NONE, NULL, nsPtr, 0, NULL); if (literalObjPtr != NULL) { if (TclHasInternalRep(literalObjPtr, &tclCmdNameType)) { @@ -1097,9 +1107,7 @@ TclLiteralStats( LiteralTable *tablePtr) /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 - size_t count[NUM_COUNTERS]; - int overflow; - size_t i, j; + size_t count[NUM_COUNTERS], overflow, i, j; double average, tmp; LiteralEntry *entryPtr; char *result, *p; @@ -1133,8 +1141,8 @@ TclLiteralStats( * Print out the histogram and a few other pieces of information. */ - result = (char *)ckalloc(NUM_COUNTERS*60 + 300); - snprintf(result, 60, "%d entries in table, %d buckets\n", + result = (char *)Tcl_Alloc(NUM_COUNTERS*60 + 300); + snprintf(result, 60, "%" TCL_Z_MODIFIER "u entries in table, %" TCL_Z_MODIFIER "u buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); for (i=0 ; i<NUM_COUNTERS ; i++) { @@ -1142,7 +1150,7 @@ TclLiteralStats( i, count[i]); p += strlen(p); } - snprintf(p, 60, "number of buckets with %d or more entries: %d\n", + snprintf(p, 60, "number of buckets with %d or more entries: %" TCL_Z_MODIFIER "u\n", NUM_COUNTERS, overflow); p += strlen(p); snprintf(p, 60, "average search distance for entry: %.1f", average); @@ -1175,19 +1183,17 @@ TclVerifyLocalLiteralTable( LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *localPtr; char *bytes; - size_t i, count; - int length; + size_t i, length, count = 0; - count = 0; for (i=0 ; i<localTablePtr->numBuckets ; i++) { for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL; localPtr=localPtr->nextPtr) { count++; if (localPtr->refCount != TCL_INDEX_NONE) { - bytes = TclGetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %u", + bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); + Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u", "TclVerifyLocalLiteralTable", - (length>60? 60 : length), bytes, localPtr->refCount); + (length>60? 60 : (int) length), bytes, localPtr->refCount); } if (localPtr->objPtr->bytes == NULL) { Tcl_Panic("%s: literal has NULL string rep", @@ -1196,7 +1202,7 @@ TclVerifyLocalLiteralTable( } } if (count != localTablePtr->numEntries) { - Tcl_Panic("%s: local literal table had %" TCL_Z_MODIFIER "u entries, should be %u", + Tcl_Panic("%s: local literal table had %" TCL_Z_MODIFIER "u entries, should be %" TCL_Z_MODIFIER "u", "TclVerifyLocalLiteralTable", count, localTablePtr->numEntries); } @@ -1226,19 +1232,17 @@ TclVerifyGlobalLiteralTable( LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; char *bytes; - size_t i, count; - int length; + size_t i, length, count = 0; - count = 0; for (i=0 ; i<globalTablePtr->numBuckets ; i++) { for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL; globalPtr=globalPtr->nextPtr) { count++; if (globalPtr->refCount + 1 < 2) { - bytes = TclGetStringFromObj(globalPtr->objPtr, &length); - Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", + bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); + Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u", "TclVerifyGlobalLiteralTable", - (length>60? 60 : length), bytes, globalPtr->refCount); + (length>60? 60 : (int)length), bytes, globalPtr->refCount); } if (globalPtr->objPtr->bytes == NULL) { Tcl_Panic("%s: literal has NULL string rep", @@ -1247,7 +1251,7 @@ TclVerifyGlobalLiteralTable( } } if (count != globalTablePtr->numEntries) { - Tcl_Panic("%s: global literal table had %" TCL_Z_MODIFIER "u entries, should be %u", + Tcl_Panic("%s: global literal table had %" TCL_Z_MODIFIER "u entries, should be %" TCL_Z_MODIFIER "u", "TclVerifyGlobalLiteralTable", count, globalTablePtr->numEntries); } diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 05883ba..a2d1919 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -17,18 +17,14 @@ * The following structure describes a library that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call * to Tcl_StaticLibrary). All such libraries are linked together into a - * single list for the process. Library are never unloaded, until the - * application exits, when TclFinalizeLoad is called, and these structures are - * freed. + * single list for the process. */ typedef struct LoadedLibrary { char *fileName; /* Name of the file from which the library was * loaded. An empty string means the library * is loaded statically. Malloc-ed. */ - char *prefix; /* Prefix for the library, - * properly capitalized (first letter UC, - * others LC), as in "Net". + char *prefix; /* Prefix for the library. * Malloc-ed. */ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be * passed to (*unLoadProcPtr)() when the file @@ -94,7 +90,7 @@ typedef struct InterpLibrary { * Prototypes for functions that are private to this file: */ -static void LoadCleanupProc(ClientData clientData, +static void LoadCleanupProc(void *clientData, Tcl_Interp *interp); static int IsStatic (LoadedLibrary *libraryPtr); static int UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target, @@ -144,15 +140,15 @@ Tcl_LoadObjCmd( const char *p, *fullFileName, *prefix; Tcl_LoadHandle loadHandle; Tcl_UniChar ch = 0; - unsigned len; - int index, flags = 0; + size_t len; + int flags = 0; Tcl_Obj *const *savedobjv = objv; static const char *const options[] = { "-global", "-lazy", "--", NULL }; enum loadOptionsEnum { LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST - }; + } index; while (objc > 2) { if (TclGetString(objv[1])[0] != '-') { @@ -163,9 +159,9 @@ Tcl_LoadObjCmd( return TCL_ERROR; } ++objv; --objc; - if (LOAD_GLOBAL == (enum loadOptionsEnum) index) { + if (LOAD_GLOBAL == index) { flags |= TCL_LOAD_GLOBAL; - } else if (LOAD_LAZY == (enum loadOptionsEnum) index) { + } else if (LOAD_LAZY == index) { flags |= TCL_LOAD_LAZY; } else { break; @@ -178,7 +174,7 @@ Tcl_LoadObjCmd( if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } - fullFileName = Tcl_GetString(objv[1]); + fullFileName = TclGetString(objv[1]); Tcl_DStringInit(&pfx); Tcl_DStringInit(&initName); @@ -189,7 +185,7 @@ Tcl_LoadObjCmd( prefix = NULL; if (objc >= 3) { - prefix = Tcl_GetString(objv[2]); + prefix = TclGetString(objv[2]); if (prefix[0] == '\0') { prefix = NULL; } @@ -209,7 +205,7 @@ Tcl_LoadObjCmd( target = interp; if (objc == 4) { - const char *childIntName = Tcl_GetString(objv[3]); + const char *childIntName = TclGetString(objv[3]); target = Tcl_GetChild(interp, childIntName); if (target == NULL) { @@ -239,8 +235,6 @@ Tcl_LoadObjCmd( Tcl_DStringAppend(&pfx, prefix, -1); TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pfx)); - Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pfx)) == 0) { namesMatch = 1; @@ -316,7 +310,7 @@ Tcl_LoadObjCmd( Tcl_DStringAppend(&pfx, prefix, -1); } else { Tcl_Obj *splitPtr, *pkgGuessPtr; - int pElements; + Tcl_Size pElements; const char *pkgGuess; /* @@ -326,14 +320,14 @@ Tcl_LoadObjCmd( /* * The platform-specific code couldn't figure out the prefix. * Make a guess by taking the last element of the file - * name, stripping off any leading "lib" and/or "tcl", and + * name, stripping off any leading "lib" and/or "tcl9", and * then using all of the alphabetic and underline characters * that follow that. */ splitPtr = Tcl_FSSplitPath(objv[1], &pElements); Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); - pkgGuess = Tcl_GetString(pkgGuessPtr); + pkgGuess = TclGetString(pkgGuessPtr); if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') && (pkgGuess[2] == 'b')) { pkgGuess += 3; @@ -349,14 +343,13 @@ Tcl_LoadObjCmd( || (pkgGuess[0] == 'T') #endif ) && (pkgGuess[1] == 'c') - && (pkgGuess[2] == 'l')) { - pkgGuess += 3; + && (pkgGuess[2] == 'l') && (pkgGuess[3] == '9')) { + pkgGuess += 4; } for (p = pkgGuess; *p != 0; p += offset) { offset = TclUtfToUniChar(p, &ch); - if ((ch > 0x100) - || !(isalpha(UCHAR(ch)) /* INTL: ISO only */ - || (UCHAR(ch) == '_'))) { + if (!Tcl_UniCharIsWordChar(UCHAR(ch)) + || Tcl_UniCharIsDigit(UCHAR(ch))) { break; } } @@ -372,16 +365,17 @@ Tcl_LoadObjCmd( } Tcl_DStringAppend(&pfx, pkgGuess, p - pkgGuess); Tcl_DecrRefCount(splitPtr); - } - /* - * Fix the capitalization in the prefix so that the first - * character is in caps (or title case) but the others are all - * lower-case. - */ + /* + * Fix the capitalization in the prefix so that the first + * character is in caps (or title case) but the others are all + * lower-case. + */ - Tcl_DStringSetLength(&pfx, - Tcl_UtfToTitle(Tcl_DStringValue(&pfx))); + Tcl_DStringSetLength(&pfx, + Tcl_UtfToTitle(Tcl_DStringValue(&pfx))); + + } /* * Compute the names of the two initialization functions, based on the @@ -417,12 +411,12 @@ Tcl_LoadObjCmd( * Create a new record to describe this library. */ - libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary)); + libraryPtr = (LoadedLibrary *)Tcl_Alloc(sizeof(LoadedLibrary)); len = strlen(fullFileName) + 1; - libraryPtr->fileName = (char *)ckalloc(len); + libraryPtr->fileName = (char *)Tcl_Alloc(len); memcpy(libraryPtr->fileName, fullFileName, len); len = Tcl_DStringLength(&pfx) + 1; - libraryPtr->prefix = (char *)ckalloc(len); + libraryPtr->prefix = (char *)Tcl_Alloc(len); memcpy(libraryPtr->prefix, Tcl_DStringValue(&pfx), len); libraryPtr->loadHandle = loadHandle; libraryPtr->initProc = initProc; @@ -486,19 +480,17 @@ Tcl_LoadObjCmd( */ if (code != TCL_OK) { -#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 Interp *iPtr = (Interp *) target; - if (iPtr->result && *(iPtr->result) && !iPtr->freeProc) { + if (iPtr->legacyResult && *(iPtr->legacyResult) && !iPtr->legacyFreeProc) { /* * A call to Tcl_InitStubs() determined the caller extension and * this interp are incompatible in their stubs mechanisms, and * recorded the error in the oldest legacy place we have to do so. */ - Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->result, -1)); - iPtr->result = &tclEmptyString; - iPtr->freeProc = NULL; + Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->legacyResult, -1)); + iPtr->legacyResult = NULL; + iPtr->legacyFreeProc = (void (*) (void))-1; } -#endif /* defined(TCL_NO_DEPRECATED) */ Tcl_TransferResult(target, code, interp); goto done; } @@ -524,7 +516,7 @@ Tcl_LoadObjCmd( */ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary)); + ipPtr = (InterpLibrary *)Tcl_Alloc(sizeof(InterpLibrary)); ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); @@ -567,7 +559,7 @@ Tcl_UnloadObjCmd( LoadedLibrary *libraryPtr; Tcl_DString pfx, tmp; InterpLibrary *ipFirstPtr, *ipPtr; - int i, index, code, complain = 1, keepLibrary = 0; + int i, code, complain = 1, keepLibrary = 0; const char *fullFileName = ""; const char *prefix; static const char *const options[] = { @@ -575,12 +567,12 @@ Tcl_UnloadObjCmd( }; enum unloadOptionsEnum { UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST - }; + } index; for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - fullFileName = Tcl_GetString(objv[i]); + fullFileName = TclGetString(objv[i]); if (fullFileName[0] == '-') { /* * It looks like the command contains an option so signal an @@ -598,7 +590,7 @@ Tcl_UnloadObjCmd( break; } } - switch ((enum unloadOptionsEnum)index) { + switch (index) { case UNLOAD_NOCOMPLAIN: /* -nocomplain */ complain = 0; break; @@ -620,13 +612,13 @@ Tcl_UnloadObjCmd( return TCL_ERROR; } - fullFileName = Tcl_GetString(objv[i]); + fullFileName = TclGetString(objv[i]); Tcl_DStringInit(&pfx); Tcl_DStringInit(&tmp); prefix = NULL; if (objc - i >= 2) { - prefix = Tcl_GetString(objv[i+1]); + prefix = TclGetString(objv[i+1]); if (prefix[0] == '\0') { prefix = NULL; } @@ -646,7 +638,7 @@ Tcl_UnloadObjCmd( target = interp; if (objc - i == 3) { - const char *childIntName = Tcl_GetString(objv[i + 2]); + const char *childIntName = TclGetString(objv[i + 2]); target = Tcl_GetChild(interp, childIntName); if (target == NULL) { @@ -676,8 +668,6 @@ Tcl_UnloadObjCmd( Tcl_DStringAppend(&pfx, prefix, -1); TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pfx)); - Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pfx)) == 0) { namesMatch = 1; @@ -892,7 +882,7 @@ UnloadLibrary( } } } - ckfree(ipPtr); + Tcl_Free(ipPtr); Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr); @@ -965,9 +955,9 @@ UnloadLibrary( } } - ckfree(iterLibraryPtr->fileName); - ckfree(iterLibraryPtr->prefix); - ckfree(iterLibraryPtr); + Tcl_Free(iterLibraryPtr->fileName); + Tcl_Free(iterLibraryPtr->prefix); + Tcl_Free(iterLibraryPtr); Tcl_MutexUnlock(&libraryMutex); } else { code = TCL_ERROR; @@ -1011,9 +1001,7 @@ Tcl_StaticLibrary( * already been loaded into the given * interpreter by calling the appropriate init * proc. */ - const char *prefix, /* Prefix (must be properly - * capitalized: first letter upper case, - * others lower case). */ + const char *prefix, /* Prefix. */ Tcl_LibraryInitProc *initProc, /* Function to call to incorporate this * library into a trusted interpreter. */ @@ -1048,10 +1036,10 @@ Tcl_StaticLibrary( */ if (libraryPtr == NULL) { - libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary)); - libraryPtr->fileName = (char *)ckalloc(1); + libraryPtr = (LoadedLibrary *)Tcl_Alloc(sizeof(LoadedLibrary)); + libraryPtr->fileName = (char *)Tcl_Alloc(1); libraryPtr->fileName[0] = 0; - libraryPtr->prefix = (char *)ckalloc(strlen(prefix) + 1); + libraryPtr->prefix = (char *)Tcl_Alloc(strlen(prefix) + 1); strcpy(libraryPtr->prefix, prefix); libraryPtr->loadHandle = NULL; libraryPtr->initProc = initProc; @@ -1083,7 +1071,7 @@ Tcl_StaticLibrary( * loaded. */ - ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary)); + ipPtr = (InterpLibrary *)Tcl_Alloc(sizeof(InterpLibrary)); ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); @@ -1206,7 +1194,7 @@ TclGetLoadedLibraries( static void LoadCleanupProc( - TCL_UNUSED(ClientData), /* Pointer to first InterpLibrary structure + TCL_UNUSED(void *), /* Pointer to first InterpLibrary structure * for interp. */ Tcl_Interp *interp) { @@ -1269,9 +1257,9 @@ TclFinalizeLoad(void) } #endif - ckfree(libraryPtr->fileName); - ckfree(libraryPtr->prefix); - ckfree(libraryPtr); + Tcl_Free(libraryPtr->fileName); + Tcl_Free(libraryPtr->prefix); + Tcl_Free(libraryPtr); } } diff --git a/generic/tclMain.c b/generic/tclMain.c index 906c197..e604d6f 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -54,7 +54,7 @@ NewNativeObj( Tcl_DStringInit(&ds); Tcl_WCharToUtfDString(string, -1, &ds); #else - Tcl_ExternalToUtfDString(NULL, (char *)string, -1, &ds); + (void)Tcl_ExternalToUtfDString(NULL, (char *)string, -1, &ds); #endif return Tcl_DStringToObj(&ds); } @@ -111,8 +111,8 @@ typedef struct { MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); -static void StdinProc(ClientData clientData, int mask); -static void FreeMainInterp(ClientData clientData); +static void StdinProc(void *clientData, int mask); +static void FreeMainInterp(void *clientData); #if !defined(_WIN32) || defined(UNICODE) && !defined(TCL_ASCII_MAIN) static Tcl_ThreadDataKey dataKey; @@ -195,7 +195,7 @@ Tcl_GetStartupScript( if (tsdPtr->encoding == NULL) { *encodingPtr = NULL; } else { - *encodingPtr = Tcl_GetString(tsdPtr->encoding); + *encodingPtr = TclGetString(tsdPtr->encoding); } } return tsdPtr->path; @@ -246,7 +246,7 @@ Tcl_SourceRCFile( c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != NULL) { - Tcl_Close(NULL, c); + Tcl_CloseEx(NULL, c, 0); if (Tcl_EvalFile(interp, fullName) != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { @@ -281,9 +281,9 @@ Tcl_SourceRCFile( *---------------------------------------------------------------------- */ -void +TCL_NORETURN void Tcl_MainEx( - int argc, /* Number of arguments. */ + Tcl_Size argc, /* Number of arguments. */ TCHAR **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc, /* Application-specific initialization @@ -291,7 +291,7 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { - int i=0; /* argv[i] index */ + Tcl_Size i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; int code, exitCode = 0; @@ -300,8 +300,8 @@ Tcl_MainEx( InteractiveState is; TclpSetInitialEncodings(); - if (0 < argc) { - --argc; /* "consume" argv[0] */ + if (argc > 0) { + --argc; /* consume argv[0] */ ++i; } TclpFindExecutable ((const char *)argv [0]); /* nb: this could be NULL @@ -333,7 +333,7 @@ Tcl_MainEx( && ('-' != argv[3][0])) { Tcl_Obj *value = NewNativeObj(argv[2]); Tcl_SetStartupScript(NewNativeObj(argv[3]), - Tcl_GetString(value)); + TclGetString(value)); Tcl_DecrRefCount(value); argc -= 3; i += 3; @@ -345,10 +345,12 @@ Tcl_MainEx( } path = Tcl_GetStartupScript(&encodingName); - if (path == NULL) { + if (path != NULL) { + appName = path; + } else if (argv[0]) { appName = NewNativeObj(argv[0]); } else { - appName = path; + appName = Tcl_NewStringObj("tclsh", -1); } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); @@ -459,7 +461,7 @@ Tcl_MainEx( while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) { mainLoopProc = TclGetMainLoop(); if (mainLoopProc == NULL) { - int length; + Tcl_Size length; if (is.tty) { Prompt(interp, &is); @@ -745,11 +747,11 @@ TclFullFinalizationRequested(void) static void StdinProc( - ClientData clientData, /* The state of interactive cmd line */ + void *clientData, /* The state of interactive cmd line */ TCL_UNUSED(int) /*mask*/) { int code; - int length; + Tcl_Size length; InteractiveState *isPtr = (InteractiveState *)clientData; Tcl_Channel chan = isPtr->input; Tcl_Obj *commandPtr = isPtr->commandPtr; @@ -927,7 +929,7 @@ Prompt( static void FreeMainInterp( - ClientData clientData) + void *clientData) { Tcl_Interp *interp = (Tcl_Interp *)clientData; diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 7a32fd9..a0668be 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -33,7 +33,7 @@ */ typedef struct { - unsigned long numNsCreated; /* Count of the number of namespaces created + size_t numNsCreated; /* Count of the number of namespaces created * within the thread. This value is used as a * unique id for each namespace. Cannot be * per-interp because the nsId is used to @@ -71,26 +71,26 @@ typedef struct { * Declarations for functions local to this file: */ -static void DeleteImportedCmd(ClientData clientData); +static void DeleteImportedCmd(void *clientData); static int DoImport(Tcl_Interp *interp, Namespace *nsPtr, Tcl_HashEntry *hPtr, const char *cmdName, const char *pattern, Namespace *importNsPtr, int allowOverwrite); static void DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr); -static char * ErrorCodeRead(ClientData clientData,Tcl_Interp *interp, +static char * ErrorCodeRead(void *clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); -static char * ErrorInfoRead(ClientData clientData,Tcl_Interp *interp, +static char * ErrorInfoRead(void *clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); -static char * EstablishErrorCodeTraces(ClientData clientData, +static char * EstablishErrorCodeTraces(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); -static char * EstablishErrorInfoTraces(ClientData clientData, +static char * EstablishErrorInfoTraces(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); -static int InvokeImportedNRCmd(ClientData clientData, +static int InvokeImportedNRCmd(void *clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static Tcl_ObjCmdProc NamespaceChildrenCmd; static Tcl_ObjCmdProc NamespaceCodeCmd; @@ -130,7 +130,8 @@ static const Tcl_ObjType nsNameType = { FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetNsNameFromAny /* setFromAnyProc */ + SetNsNameFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define NsNameSetInternalRep(objPtr, nnPtr) \ @@ -391,7 +392,7 @@ Tcl_PopCallFrame( if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); - ckfree(framePtr->varTablePtr); + Tcl_Free(framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { @@ -494,7 +495,7 @@ TclPopStackFrame( static char * EstablishErrorCodeTraces( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, TCL_UNUSED(const char *) /*name1*/, TCL_UNUSED(const char *) /*name2*/, @@ -526,7 +527,7 @@ EstablishErrorCodeTraces( static char * ErrorCodeRead( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, TCL_UNUSED(const char *) /*name1*/, TCL_UNUSED(const char *) /*name2*/, @@ -543,10 +544,8 @@ ErrorCodeRead( return NULL; } if (NULL == Tcl_ObjGetVar2(interp, iPtr->ecVar, NULL, TCL_GLOBAL_ONLY)) { - Tcl_Obj *objPtr; - TclNewObj(objPtr); Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, - objPtr, TCL_GLOBAL_ONLY); + Tcl_NewObj(), TCL_GLOBAL_ONLY); } return NULL; } @@ -570,7 +569,7 @@ ErrorCodeRead( static char * EstablishErrorInfoTraces( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, TCL_UNUSED(const char *) /*name1*/, TCL_UNUSED(const char *) /*name2*/, @@ -602,7 +601,7 @@ EstablishErrorInfoTraces( static char * ErrorInfoRead( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, TCL_UNUSED(const char *) /*name1*/, TCL_UNUSED(const char *) /*name2*/, @@ -619,10 +618,8 @@ ErrorInfoRead( return NULL; } if (NULL == Tcl_ObjGetVar2(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY)) { - Tcl_Obj *objPtr; - TclNewObj(objPtr); Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, - objPtr, TCL_GLOBAL_ONLY); + Tcl_NewObj(), TCL_GLOBAL_ONLY); } return NULL; } @@ -656,7 +653,7 @@ Tcl_CreateNamespace( const char *name, /* Name for the new namespace. May be a * qualified name with names of ancestor * namespaces separated by "::"s. */ - ClientData clientData, /* One-word value to store with namespace. */ + void *clientData, /* One-word value to store with namespace. */ Tcl_NamespaceDeleteProc *deleteProc) /* Function called to delete client data when * the namespace is deleted. NULL if no @@ -770,9 +767,9 @@ Tcl_CreateNamespace( */ doCreate: - nsPtr = (Namespace *)ckalloc(sizeof(Namespace)); + nsPtr = (Namespace *)Tcl_Alloc(sizeof(Namespace)); nameLen = strlen(simpleName) + 1; - nsPtr->name = (char *)ckalloc(nameLen); + nsPtr->name = (char *)Tcl_Alloc(nameLen); memcpy(nsPtr->name, simpleName, nameLen); nsPtr->fullName = NULL; /* Set below. */ nsPtr->clientData = clientData; @@ -860,7 +857,7 @@ Tcl_CreateNamespace( name = Tcl_DStringValue(namePtr); nameLen = Tcl_DStringLength(namePtr); - nsPtr->fullName = (char *)ckalloc(nameLen + 1); + nsPtr->fullName = (char *)Tcl_Alloc(nameLen + 1); memcpy(nsPtr->fullName, name, nameLen + 1); Tcl_DStringFree(&buffer1); @@ -1048,7 +1045,7 @@ Tcl_DeleteNamespace( #else if (nsPtr->childTablePtr != NULL) { Tcl_DeleteHashTable(nsPtr->childTablePtr); - ckfree(nsPtr->childTablePtr); + Tcl_Free(nsPtr->childTablePtr); } #endif Tcl_DeleteHashTable(&nsPtr->cmdTable); @@ -1274,9 +1271,9 @@ TclTeardownNamespace( if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { - ckfree(nsPtr->exportArrayPtr[i]); + Tcl_Free(nsPtr->exportArrayPtr[i]); } - ckfree(nsPtr->exportArrayPtr); + Tcl_Free(nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; @@ -1328,9 +1325,9 @@ NamespaceFree( * (for error messages), and the structure itself. */ - ckfree(nsPtr->name); - ckfree(nsPtr->fullName); - ckfree(nsPtr); + Tcl_Free(nsPtr->name); + Tcl_Free(nsPtr->fullName); + Tcl_Free(nsPtr); } /* @@ -1419,9 +1416,9 @@ Tcl_Export( if (resetListFirst) { if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { - ckfree(nsPtr->exportArrayPtr[i]); + Tcl_Free(nsPtr->exportArrayPtr[i]); } - ckfree(nsPtr->exportArrayPtr); + Tcl_Free(nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; TclInvalidateNsCmdLookup(nsPtr); nsPtr->numExportPatterns = 0; @@ -1468,7 +1465,7 @@ Tcl_Export( if (neededElems > nsPtr->maxExportPatterns) { nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ? 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS; - nsPtr->exportArrayPtr = (char **)ckrealloc(nsPtr->exportArrayPtr, + nsPtr->exportArrayPtr = (char **)Tcl_Realloc(nsPtr->exportArrayPtr, sizeof(char *) * nsPtr->maxExportPatterns); } @@ -1477,7 +1474,7 @@ Tcl_Export( */ len = strlen(pattern); - patternCpy = (char *)ckalloc(len + 1); + patternCpy = (char *)Tcl_Alloc(len + 1); memcpy(patternCpy, pattern, len + 1); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; @@ -1796,7 +1793,7 @@ DoImport( } } - dataPtr = (ImportedCmdData *)ckalloc(sizeof(ImportedCmdData)); + dataPtr = (ImportedCmdData *)Tcl_Alloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); @@ -1812,7 +1809,7 @@ DoImport( * and add it to the import ref list in the "real" command. */ - refPtr = (ImportRef *)ckalloc(sizeof(ImportRef)); + refPtr = (ImportRef *)Tcl_Alloc(sizeof(ImportRef)); refPtr->importedCmdPtr = (Command *) importedCmd; refPtr->nextPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = refPtr; @@ -2039,7 +2036,7 @@ TclGetOriginalCommand( static int InvokeImportedNRCmd( - ClientData clientData, /* Points to the imported command's + void *clientData, /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -2054,7 +2051,7 @@ InvokeImportedNRCmd( int TclInvokeImportedCmd( - ClientData clientData, /* Points to the imported command's + void *clientData, /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -2087,7 +2084,7 @@ TclInvokeImportedCmd( static void DeleteImportedCmd( - ClientData clientData) /* Points to the imported command's + void *clientData) /* Points to the imported command's * ImportedCmdData structure. */ { ImportedCmdData *dataPtr = (ImportedCmdData *)clientData; @@ -2109,9 +2106,9 @@ DeleteImportedCmd( } else { prevPtr->nextPtr = refPtr->nextPtr; } - ckfree(refPtr); + Tcl_Free(refPtr); TclCleanupCommandMacro(realCmdPtr); - ckfree(dataPtr); + Tcl_Free(dataPtr); return; } prevPtr = refPtr; @@ -3011,7 +3008,7 @@ TclInitNamespaceCmd( static int NamespaceChildrenCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3140,7 +3137,7 @@ NamespaceChildrenCmd( static int NamespaceCodeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3163,7 +3160,7 @@ NamespaceCodeCmd( " "namespace" command. [Bug 3202171]. */ - arg = TclGetStringFromObj(objv[1], &length); + arg = Tcl_GetStringFromObj(objv[1], &length); if (*arg==':' && length > 20 && strncmp(arg, "::namespace inscope ", 20) == 0) { Tcl_SetObjResult(interp, objv[1]); @@ -3221,7 +3218,7 @@ NamespaceCodeCmd( static int NamespaceCurrentCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3284,7 +3281,7 @@ NamespaceCurrentCmd( static int NamespaceDeleteCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3361,7 +3358,7 @@ NamespaceDeleteCmd( static int NamespaceEvalCmd( - ClientData clientData, /* Arbitrary value passed to cmd. */ + void *clientData, /* Arbitrary value passed to cmd. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3372,7 +3369,7 @@ NamespaceEvalCmd( static int NRNamespaceEvalCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3454,7 +3451,7 @@ NRNamespaceEvalCmd( static int NsEval_Callback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -3504,7 +3501,7 @@ NsEval_Callback( static int NamespaceExistsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3559,7 +3556,7 @@ NamespaceExistsCmd( static int NamespaceExportCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3590,7 +3587,7 @@ NamespaceExportCmd( */ firstArg = 1; - if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) { + if (strcmp("-clear", TclGetString(objv[firstArg])) == 0) { Tcl_Export(interp, NULL, "::", 1); Tcl_ResetResult(interp); firstArg++; @@ -3601,7 +3598,7 @@ NamespaceExportCmd( */ for (i = firstArg; i < objc; i++) { - int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0); + int result = Tcl_Export(interp, NULL, TclGetString(objv[i]), 0); if (result != TCL_OK) { return result; } @@ -3641,7 +3638,7 @@ NamespaceExportCmd( static int NamespaceForgetCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3706,7 +3703,7 @@ NamespaceForgetCmd( static int NamespaceImportCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3810,7 +3807,7 @@ NamespaceImportCmd( static int NamespaceInscopeCmd( - ClientData clientData, /* Arbitrary value passed to cmd. */ + void *clientData, /* Arbitrary value passed to cmd. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3821,7 +3818,7 @@ NamespaceInscopeCmd( static int NRNamespaceInscopeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3918,7 +3915,7 @@ NRNamespaceInscopeCmd( static int NamespaceOriginCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3978,7 +3975,7 @@ NamespaceOriginCmd( static int NamespaceParentCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4036,7 +4033,7 @@ NamespaceParentCmd( static int NamespacePathCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4131,7 +4128,7 @@ TclSetNsPath( { if (pathLength != 0) { NamespacePathEntry *tmpPathArray = - (NamespacePathEntry *)ckalloc(sizeof(NamespacePathEntry) * pathLength); + (NamespacePathEntry *)Tcl_Alloc(sizeof(NamespacePathEntry) * pathLength); Tcl_Size i; for (i=0 ; i<pathLength ; i++) { @@ -4199,7 +4196,7 @@ UnlinkNsPath( } } } - ckfree(nsPtr->commandPathArray); + Tcl_Free(nsPtr->commandPathArray); } /* @@ -4263,7 +4260,7 @@ TclInvalidateNsPath( static int NamespaceQualifiersCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4331,7 +4328,7 @@ NamespaceQualifiersCmd( static int NamespaceUnknownCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4518,7 +4515,7 @@ Tcl_SetNamespaceUnknownHandler( static int NamespaceTailCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4576,7 +4573,7 @@ NamespaceTailCmd( static int NamespaceUpvarCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4650,7 +4647,7 @@ NamespaceUpvarCmd( static int NamespaceWhichCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4747,7 +4744,7 @@ FreeNsNameInternalRep( */ TclNsDecrRefCount(resNamePtr->nsPtr); - ckfree(resNamePtr); + Tcl_Free(resNamePtr); } } @@ -4834,7 +4831,7 @@ SetNsNameFromAny( */ nsPtr->refCount++; - resNamePtr = (ResolvedNsName *)ckalloc(sizeof(ResolvedNsName)); + resNamePtr = (ResolvedNsName *)Tcl_Alloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; @@ -4894,7 +4891,7 @@ TclGetNamespaceChildTable( return &nPtr->childTable; #else if (nPtr->childTablePtr == NULL) { - nPtr->childTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + nPtr->childTablePtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS); } return nPtr->childTablePtr; @@ -4970,7 +4967,7 @@ TclLogCommandInfo( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) ? "while executing" : "invoked from within"), - (overflow ? limit : length), command, + (overflow ? limit : (int)length), command, (overflow ? "..." : ""))); varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, @@ -4983,7 +4980,7 @@ TclLogCommandInfo( return; } else { Tcl_HashEntry *hPtr - = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); + = Tcl_FindHashEntry(&iPtr->varTraces, varPtr); VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr); if (tracePtr->traceProc != EstablishErrorInfoTraces) { @@ -5054,7 +5051,7 @@ TclLogCommandInfo( Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewWideIntObj( - iPtr->framePtr->level - iPtr->varFramePtr->level)); + (int)(iPtr->framePtr->level - iPtr->varFramePtr->level))); } else if (iPtr->framePtr != iPtr->rootFramePtr) { /* * normal case, [lappend errorstack CALL [info level 0]] diff --git a/generic/tclNotify.c b/generic/tclNotify.c index e511fa1..3830192 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -35,7 +35,7 @@ static Tcl_NotifierProcs tclNotifierHooks = { typedef struct EventSource { Tcl_EventSetupProc *setupProc; Tcl_EventCheckProc *checkProc; - ClientData clientData; + void *clientData; struct EventSource *nextPtr; } EventSource; @@ -71,7 +71,7 @@ typedef struct ThreadSpecificData { /* Pointer to first event source in list of * event sources for this thread. */ Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */ - ClientData clientData; /* Opaque handle for platform specific + void *clientData; /* Opaque handle for platform specific * notifier. */ int initialized; /* 1 if notifier has been initialized. */ struct ThreadSpecificData *nextPtr; @@ -182,7 +182,7 @@ TclFinalizeNotifier(void) for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) { hold = evPtr; evPtr = evPtr->nextPtr; - ckfree(hold); + Tcl_Free(hold); } tsdPtr->firstEventPtr = NULL; tsdPtr->lastEventPtr = NULL; @@ -288,7 +288,7 @@ Tcl_SetNotifier( * Tcl_QueueEvent to queue any events that are ready. * * Each of these functions is passed two arguments, e.g. - * (*checkProc)(ClientData clientData, int flags)); + * (*checkProc)(void *clientData, int flags)); * ClientData is the same as the clientData argument here, and flags is a * combination of things like TCL_FILE_EVENTS that indicates what events * are of interest: setupProc and checkProc use flags to figure out @@ -305,11 +305,11 @@ Tcl_CreateEventSource( Tcl_EventCheckProc *checkProc, /* Function to call after waiting to see what * happened. */ - ClientData clientData) /* One-word argument to pass to setupProc and + void *clientData) /* One-word argument to pass to setupProc and * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - EventSource *sourcePtr = (EventSource *)ckalloc(sizeof(EventSource)); + EventSource *sourcePtr = (EventSource *)Tcl_Alloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; sourcePtr->checkProc = checkProc; @@ -344,7 +344,7 @@ Tcl_DeleteEventSource( Tcl_EventCheckProc *checkProc, /* Function to call after waiting to see what * happened. */ - ClientData clientData) /* One-word argument to pass to setupProc and + void *clientData) /* One-word argument to pass to setupProc and * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -363,7 +363,7 @@ Tcl_DeleteEventSource( } else { prevPtr->nextPtr = sourcePtr->nextPtr; } - ckfree(sourcePtr); + Tcl_Free(sourcePtr); return; } } @@ -388,7 +388,7 @@ void Tcl_QueueEvent( Tcl_Event *evPtr, /* Event to add to queue. The storage space * must have been allocated the caller with - * malloc (ckalloc), and it becomes the + * malloc (Tcl_Alloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, @@ -420,7 +420,7 @@ Tcl_ThreadQueueEvent( Tcl_ThreadId threadId, /* Identifier for thread to use. */ Tcl_Event *evPtr, /* Event to add to queue. The storage space * must have been allocated the caller with - * malloc (ckalloc), and it becomes the + * malloc (Tcl_Alloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, @@ -447,7 +447,7 @@ Tcl_ThreadQueueEvent( Tcl_AlertNotifier(tsdPtr->clientData); } } else { - ckfree(evPtr); + Tcl_Free(evPtr); } Tcl_MutexUnlock(&listLock); } @@ -480,7 +480,7 @@ QueueEvent( * which event queue to use. */ Tcl_Event *evPtr, /* Event to add to queue. The storage space * must have been allocated the caller with - * malloc (ckalloc), and it becomes the + * malloc (Tcl_Alloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, @@ -556,7 +556,7 @@ QueueEvent( void Tcl_DeleteEvents( Tcl_EventDeleteProc *proc, /* The function to call. */ - ClientData clientData) /* The type-specific data. */ + void *clientData) /* The type-specific data. */ { Tcl_Event *evPtr; /* Pointer to the event being examined */ Tcl_Event *prevPtr; /* Pointer to evPtr's predecessor, or NULL if @@ -603,7 +603,7 @@ Tcl_DeleteEvents( hold = evPtr; evPtr = evPtr->nextPtr; - ckfree(hold); + Tcl_Free(hold); } else { /* * Event is to be retained. @@ -742,7 +742,7 @@ Tcl_ServiceEvent( } } if (evPtr) { - ckfree(evPtr); + Tcl_Free(evPtr); } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); return 1; @@ -1189,7 +1189,7 @@ Tcl_ThreadAlert( *---------------------------------------------------------------------- */ -ClientData +void * Tcl_InitNotifier(void) { if (tclNotifierHooks.initNotifierProc) { @@ -1220,7 +1220,7 @@ Tcl_InitNotifier(void) void Tcl_FinalizeNotifier( - ClientData clientData) + void *clientData) { if (tclNotifierHooks.finalizeNotifierProc) { tclNotifierHooks.finalizeNotifierProc(clientData); @@ -1253,7 +1253,7 @@ Tcl_FinalizeNotifier( void Tcl_AlertNotifier( - ClientData clientData) /* Pointer to thread data. */ + void *clientData) /* Pointer to thread data. */ { if (tclNotifierHooks.alertNotifierProc) { tclNotifierHooks.alertNotifierProc(clientData); @@ -1380,7 +1380,7 @@ Tcl_CreateFileHandler( * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { if (tclNotifierHooks.createFileHandlerProc) { tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); diff --git a/generic/tclOO.c b/generic/tclOO.c index a65dc8f..1d72fb0 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -81,8 +81,8 @@ static Tcl_InterpDeleteProc KillFoundation; static void MyDeleted(void *clientData); static void ObjectNamespaceDeleted(void *clientData); static Tcl_CommandTraceProc ObjectRenamedTrace; -static inline void RemoveClass(Class **list, int num, int idx); -static inline void RemoveObject(Object **list, int num, int idx); +static inline void RemoveClass(Class **list, size_t num, size_t idx); +static inline void RemoveObject(Object **list, size_t num, size_t idx); static inline void SquelchCachedName(Object *oPtr); static int PublicNRObjectCmd(void *clientData, @@ -201,8 +201,8 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; static inline void RemoveClass( Class **list, - int num, - int idx) + size_t num, + size_t idx) { for (; idx + 1 < num; idx++) { list[idx] = list[idx + 1]; @@ -213,8 +213,8 @@ RemoveClass( static inline void RemoveObject( Object **list, - int num, - int idx) + size_t num, + size_t idx) { for (; idx + 1 < num; idx++) { list[idx] = list[idx + 1]; @@ -304,11 +304,11 @@ InitFoundation( static Tcl_ThreadDataKey tsdKey; ThreadLocalData *tsdPtr = (ThreadLocalData *)Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); - Foundation *fPtr = (Foundation *)ckalloc(sizeof(Foundation)); + Foundation *fPtr = (Foundation *)Tcl_Alloc(sizeof(Foundation)); Tcl_Obj *namePtr; Tcl_DString buffer; Command *cmdPtr; - int i; + size_t i; /* * Initialize the structure that holds the OO system core. This is @@ -328,7 +328,7 @@ InitFoundation( fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr, DeletedHelpersNamespace); Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL); - fPtr->epoch = 0; + fPtr->epoch = 1; fPtr->tsdPtr = tsdPtr; TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown"); TclNewLiteralStringObj(fPtr->constructorName, "<constructor>"); @@ -392,9 +392,9 @@ InitFoundation( */ TclNewLiteralStringObj(namePtr, "new"); - Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, + TclNewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, namePtr /* keeps ref */, 0 /* private */, NULL, NULL); - fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, + fPtr->classCls->constructorPtr = (Method *) TclNewMethod(interp, (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); /* @@ -471,7 +471,7 @@ InitClassSystemRoots( */ fPtr->objectCls->superclasses.num = 0; - ckfree(fPtr->objectCls->superclasses.list); + Tcl_Free(fPtr->objectCls->superclasses.list); fPtr->objectCls->superclasses.list = NULL; /* @@ -589,7 +589,7 @@ KillFoundation( TclOODecrRefCount(fPtr->objectCls->thisPtr); TclOODecrRefCount(fPtr->classCls->thisPtr); - ckfree(fPtr); + Tcl_Free(fPtr); } /* @@ -627,9 +627,9 @@ AllocObject( Object *oPtr; Command *cmdPtr; CommandTrace *tracePtr; - int creationEpoch; + size_t creationEpoch; - oPtr = (Object *)ckalloc(sizeof(Object)); + oPtr = (Object *)Tcl_Alloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); /* @@ -656,7 +656,7 @@ AllocObject( while (1) { char objName[10 + TCL_INTEGER_SPACE]; - snprintf(objName, sizeof(objName), "::oo::Obj%d", ++fPtr->tsdPtr->nsCount); + snprintf(objName, sizeof(objName), "::oo::Obj%" TCL_Z_MODIFIER "u", ++fPtr->tsdPtr->nsCount); oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = fPtr->tsdPtr->nsCount; @@ -740,7 +740,7 @@ AllocObject( cmdPtr = (Command *) oPtr->command; cmdPtr->nreProc = PublicNRObjectCmd; - cmdPtr->tracePtr = tracePtr = (CommandTrace *)ckalloc(sizeof(CommandTrace)); + cmdPtr->tracePtr = tracePtr = (CommandTrace *)Tcl_Alloc(sizeof(CommandTrace)); tracePtr->traceProc = ObjectRenamedTrace; tracePtr->clientData = oPtr; tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE; @@ -894,7 +894,7 @@ TclOODeleteDescendants( } } if (clsPtr->mixinSubs.size > 0) { - ckfree(clsPtr->mixinSubs.list); + Tcl_Free(clsPtr->mixinSubs.list); clsPtr->mixinSubs.size = 0; } @@ -914,7 +914,7 @@ TclOODeleteDescendants( } } if (clsPtr->subclasses.size > 0) { - ckfree(clsPtr->subclasses.list); + Tcl_Free(clsPtr->subclasses.list); clsPtr->subclasses.list = NULL; clsPtr->subclasses.size = 0; } @@ -939,7 +939,7 @@ TclOODeleteDescendants( } } if (clsPtr->instances.size > 0) { - ckfree(clsPtr->instances.list); + Tcl_Free(clsPtr->instances.list); clsPtr->instances.list = NULL; clsPtr->instances.size = 0; } @@ -1015,7 +1015,7 @@ TclOOReleaseClassContents( TclOODeleteChain(callPtr); } Tcl_DeleteHashTable(clsPtr->classChainCache); - ckfree(clsPtr->classChainCache); + Tcl_Free(clsPtr->classChainCache); clsPtr->classChainCache = NULL; } @@ -1033,13 +1033,13 @@ TclOOReleaseClassContents( FOREACH(propertyObj, clsPtr->properties.readable) { Tcl_DecrRefCount(propertyObj); } - ckfree(clsPtr->properties.readable.list); + Tcl_Free(clsPtr->properties.readable.list); } if (clsPtr->properties.writable.num) { FOREACH(propertyObj, clsPtr->properties.writable) { Tcl_DecrRefCount(propertyObj); } - ckfree(clsPtr->properties.writable.list); + Tcl_Free(clsPtr->properties.writable.list); } /* @@ -1052,7 +1052,7 @@ TclOOReleaseClassContents( FOREACH(filterObj, clsPtr->filters) { TclDecrRefCount(filterObj); } - ckfree(clsPtr->filters.list); + Tcl_Free(clsPtr->filters.list); clsPtr->filters.list = NULL; clsPtr->filters.num = 0; } @@ -1069,7 +1069,7 @@ TclOOReleaseClassContents( metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(clsPtr->metadataPtr); - ckfree(clsPtr->metadataPtr); + Tcl_Free(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } @@ -1078,7 +1078,7 @@ TclOOReleaseClassContents( TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr); TclOODecrRefCount(tmpClsPtr->thisPtr); } - ckfree(clsPtr->mixins.list); + Tcl_Free(clsPtr->mixins.list); clsPtr->mixins.list = NULL; clsPtr->mixins.num = 0; } @@ -1088,7 +1088,7 @@ TclOOReleaseClassContents( TclOORemoveFromSubclasses(clsPtr, tmpClsPtr); TclOODecrRefCount(tmpClsPtr->thisPtr); } - ckfree(clsPtr->superclasses.list); + Tcl_Free(clsPtr->superclasses.list); clsPtr->superclasses.num = 0; clsPtr->superclasses.list = NULL; } @@ -1104,7 +1104,7 @@ TclOOReleaseClassContents( TclDecrRefCount(variableObj); } if (i) { - ckfree(clsPtr->variables.list); + Tcl_Free(clsPtr->variables.list); } FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) { @@ -1112,7 +1112,7 @@ TclOOReleaseClassContents( TclDecrRefCount(privateVariable->fullNameObj); } if (i) { - ckfree(clsPtr->privateVariables.list); + Tcl_Free(clsPtr->privateVariables.list); } if (IsRootClass(oPtr) && !Destructing(fPtr->objectCls->thisPtr)) { @@ -1244,7 +1244,7 @@ ObjectNamespaceDeleted( TclOODecrRefCount(mixinPtr->thisPtr); } if (oPtr->mixins.list != NULL) { - ckfree(oPtr->mixins.list); + Tcl_Free(oPtr->mixins.list); } } @@ -1252,7 +1252,7 @@ ObjectNamespaceDeleted( TclDecrRefCount(filterObj); } if (i) { - ckfree(oPtr->filters.list); + Tcl_Free(oPtr->filters.list); } if (oPtr->methodsPtr) { @@ -1260,14 +1260,14 @@ ObjectNamespaceDeleted( TclOODelMethodRef(mPtr); } Tcl_DeleteHashTable(oPtr->methodsPtr); - ckfree(oPtr->methodsPtr); + Tcl_Free(oPtr->methodsPtr); } FOREACH(variableObj, oPtr->variables) { TclDecrRefCount(variableObj); } if (i) { - ckfree(oPtr->variables.list); + Tcl_Free(oPtr->variables.list); } FOREACH_STRUCT(privateVariable, oPtr->privateVariables) { @@ -1275,7 +1275,7 @@ ObjectNamespaceDeleted( TclDecrRefCount(privateVariable->fullNameObj); } if (i) { - ckfree(oPtr->privateVariables.list); + Tcl_Free(oPtr->privateVariables.list); } if (oPtr->chainCache) { @@ -1292,7 +1292,7 @@ ObjectNamespaceDeleted( metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(oPtr->metadataPtr); - ckfree(oPtr->metadataPtr); + Tcl_Free(oPtr->metadataPtr); oPtr->metadataPtr = NULL; } @@ -1310,13 +1310,13 @@ ObjectNamespaceDeleted( FOREACH(propertyObj, oPtr->properties.readable) { Tcl_DecrRefCount(propertyObj); } - ckfree(oPtr->properties.readable.list); + Tcl_Free(oPtr->properties.readable.list); } if (oPtr->properties.writable.num) { FOREACH(propertyObj, oPtr->properties.writable) { Tcl_DecrRefCount(propertyObj); } - ckfree(oPtr->properties.writable.list); + Tcl_Free(oPtr->properties.writable.list); } /* @@ -1371,9 +1371,9 @@ TclOODecrRefCount( if (oPtr->refCount-- <= 1) { if (oPtr->classPtr != NULL) { - ckfree(oPtr->classPtr); + Tcl_Free(oPtr->classPtr); } - ckfree(oPtr); + Tcl_Free(oPtr); return 1; } return 0; @@ -1446,9 +1446,9 @@ TclOOAddToInstances( if (clsPtr->instances.num >= clsPtr->instances.size) { clsPtr->instances.size += ALLOC_CHUNK; if (clsPtr->instances.size == ALLOC_CHUNK) { - clsPtr->instances.list = (Object **)ckalloc(sizeof(Object *) * ALLOC_CHUNK); + clsPtr->instances.list = (Object **)Tcl_Alloc(sizeof(Object *) * ALLOC_CHUNK); } else { - clsPtr->instances.list = (Object **)ckrealloc(clsPtr->instances.list, + clsPtr->instances.list = (Object **)Tcl_Realloc(clsPtr->instances.list, sizeof(Object *) * clsPtr->instances.size); } } @@ -1486,7 +1486,7 @@ TclOORemoveFromMixins( } } if (oPtr->mixins.num == 0) { - ckfree(oPtr->mixins.list); + Tcl_Free(oPtr->mixins.list); oPtr->mixins.list = NULL; } return res; @@ -1547,9 +1547,9 @@ TclOOAddToSubclasses( if (superPtr->subclasses.num >= superPtr->subclasses.size) { superPtr->subclasses.size += ALLOC_CHUNK; if (superPtr->subclasses.size == ALLOC_CHUNK) { - superPtr->subclasses.list = (Class **)ckalloc(sizeof(Class *) * ALLOC_CHUNK); + superPtr->subclasses.list = (Class **)Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK); } else { - superPtr->subclasses.list = (Class **)ckrealloc(superPtr->subclasses.list, + superPtr->subclasses.list = (Class **)Tcl_Realloc(superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); } } @@ -1613,9 +1613,9 @@ TclOOAddToMixinSubs( if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) { superPtr->mixinSubs.size += ALLOC_CHUNK; if (superPtr->mixinSubs.size == ALLOC_CHUNK) { - superPtr->mixinSubs.list = (Class **)ckalloc(sizeof(Class *) * ALLOC_CHUNK); + superPtr->mixinSubs.list = (Class **)Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK); } else { - superPtr->mixinSubs.list = (Class **)ckrealloc(superPtr->mixinSubs.list, + superPtr->mixinSubs.list = (Class **)Tcl_Realloc(superPtr->mixinSubs.list, sizeof(Class *) * superPtr->mixinSubs.size); } } @@ -1661,7 +1661,7 @@ TclOOAllocClass( * representation. */ { Foundation *fPtr = GetFoundation(interp); - Class *clsPtr = (Class *)ckalloc(sizeof(Class)); + Class *clsPtr = (Class *)Tcl_Alloc(sizeof(Class)); memset(clsPtr, 0, sizeof(Class)); clsPtr->thisPtr = useThisObj; @@ -1678,7 +1678,7 @@ TclOOAllocClass( */ clsPtr->superclasses.num = 1; - clsPtr->superclasses.list = (Class **)ckalloc(sizeof(Class *)); + clsPtr->superclasses.list = (Class **)Tcl_Alloc(sizeof(Class *)); clsPtr->superclasses.list[0] = fPtr->objectCls; AddRef(fPtr->objectCls->thisPtr); @@ -1735,7 +1735,7 @@ Tcl_NewObjectInstance( * used for object cloning only. */ - if (objc >= 0) { + if (objc != TCL_INDEX_NONE) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); @@ -1802,7 +1802,7 @@ TclNRNewObjectInstance( } /* - * Run constructors, except when objc < 0 (a special flag case used for + * Run constructors, except when objc == TCL_INDEX_NONE (a special flag case used for * object cloning only). If there aren't any constructors, we do nothing. */ @@ -2029,7 +2029,7 @@ Tcl_CopyObjectInstance( } TclOODecrRefCount(mixinPtr->thisPtr); } - ckfree(o2Ptr->mixins.list); + Tcl_Free(o2Ptr->mixins.list); } DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *); FOREACH(mixinPtr, o2Ptr->mixins) { @@ -2130,11 +2130,11 @@ Tcl_CopyObjectInstance( TclOODecrRefCount(superPtr->thisPtr); } if (cls2Ptr->superclasses.num) { - cls2Ptr->superclasses.list = (Class **)ckrealloc(cls2Ptr->superclasses.list, + cls2Ptr->superclasses.list = (Class **)Tcl_Realloc(cls2Ptr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); } else { cls2Ptr->superclasses.list = - (Class **)ckalloc(sizeof(Class *) * clsPtr->superclasses.num); + (Class **)Tcl_Alloc(sizeof(Class *) * clsPtr->superclasses.num); } memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); @@ -2185,7 +2185,7 @@ Tcl_CopyObjectInstance( TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - ckfree(clsPtr->mixins.list); + Tcl_Free(clsPtr->mixins.list); } DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); FOREACH(mixinPtr, cls2Ptr->mixins) { @@ -2299,7 +2299,7 @@ CloneObjectMethod( Tcl_Obj *namePtr) { if (mPtr->typePtr == NULL) { - Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); } else if (mPtr->typePtr->cloneProc) { void *newClientData; @@ -2308,10 +2308,10 @@ CloneObjectMethod( &newClientData) != TCL_OK) { return TCL_ERROR; } - Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData); } else { - Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData); } return TCL_OK; @@ -2328,7 +2328,7 @@ CloneClassMethod( Method *m2Ptr; if (mPtr->typePtr == NULL) { - m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, + m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); } else if (mPtr->typePtr->cloneProc) { void *newClientData; @@ -2337,11 +2337,11 @@ CloneClassMethod( &newClientData) != TCL_OK) { return TCL_ERROR; } - m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, + m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData); } else { - m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, + m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData); } @@ -2398,7 +2398,7 @@ Tcl_ClassGetMetadata( * There is a metadata store, so look in it for the given type. */ - hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr); + hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, typePtr); /* * Return the metadata value if we found it, otherwise NULL. @@ -2428,7 +2428,7 @@ Tcl_ClassSetMetadata( if (metadata == NULL) { return; } - clsPtr->metadataPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + clsPtr->metadataPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS); } @@ -2437,7 +2437,7 @@ Tcl_ClassSetMetadata( */ if (metadata == NULL) { - hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr); + hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, typePtr); if (hPtr != NULL) { typePtr->deleteProc(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); @@ -2450,7 +2450,7 @@ Tcl_ClassSetMetadata( * some metadata attached of this type, we delete that first. */ - hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew); + hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, typePtr, &isNew); if (!isNew) { typePtr->deleteProc(Tcl_GetHashValue(hPtr)); } @@ -2478,7 +2478,7 @@ Tcl_ObjectGetMetadata( * There is a metadata store, so look in it for the given type. */ - hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr); + hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, typePtr); /* * Return the metadata value if we found it, otherwise NULL. @@ -2508,7 +2508,7 @@ Tcl_ObjectSetMetadata( if (metadata == NULL) { return; } - oPtr->metadataPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + oPtr->metadataPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS); } @@ -2517,7 +2517,7 @@ Tcl_ObjectSetMetadata( */ if (metadata == NULL) { - hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr); + hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, typePtr); if (hPtr != NULL) { typePtr->deleteProc(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); @@ -2530,7 +2530,7 @@ Tcl_ObjectSetMetadata( * some metadata attached of this type, we delete that first. */ - hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew); + hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, typePtr, &isNew); if (!isNew) { typePtr->deleteProc(Tcl_GetHashValue(hPtr)); } @@ -2852,8 +2852,8 @@ Tcl_ObjectContextInvokeNext( Tcl_Size skip) { CallContext *contextPtr = (CallContext *) context; - int savedIndex = contextPtr->index; - int savedSkip = contextPtr->skip; + size_t savedIndex = contextPtr->index; + size_t savedSkip = contextPtr->skip; int result; if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) { diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 913d76c..2df34d0 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -135,8 +135,19 @@ declare 30 { declare 31 { Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object) } +declare 32 { + int Tcl_MethodIsType2(Tcl_Method method, const Tcl_MethodType2 *typePtr, + void **clientDataPtr) +} +declare 33 { + Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, Tcl_Object object, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, + void *clientData) +} declare 34 { - void TclOOUnusedStubEntry(void) + Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, + void *clientData) } ###################################################################### diff --git a/generic/tclOO.h b/generic/tclOO.h index 19d93f9..7cda876 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -62,7 +62,12 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext; typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); +#if TCL_MAJOR_VERSION > 8 +typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp, + Tcl_ObjectContext objectContext, Tcl_Size objc, Tcl_Obj *const *objv); +#else #define Tcl_MethodCallProc2 Tcl_MethodCallProc +#endif typedef void (Tcl_MethodDeleteProc)(void *clientData); typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData, void **newClientData); @@ -93,7 +98,26 @@ typedef struct { * be copied directly. */ } Tcl_MethodType; +#if TCL_MAJOR_VERSION > 8 +typedef struct { + int version; /* Structure version field. Always to be equal + * to TCL_OO_METHOD_VERSION_2 in + * declarations. */ + const char *name; /* Name of this type of method, mostly for + * debugging purposes. */ + Tcl_MethodCallProc2 *callProc; + /* How to invoke this method. */ + Tcl_MethodDeleteProc *deleteProc; + /* How to delete this method's type-specific + * data, or NULL if the type-specific data + * does not need deleting. */ + Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific + * data, or NULL if the type-specific data can + * be copied directly. */ +} Tcl_MethodType2; +#else #define Tcl_MethodType2 Tcl_MethodType +#endif /* * The correct value for the version field of the Tcl_MethodType structure. diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 82aad22..5a38dee 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -15,6 +15,7 @@ #endif #include "tclInt.h" #include "tclOOInt.h" +#include "tclTomMath.h" static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp); static Tcl_NRPostProc AfterNRDestructor; @@ -51,7 +52,7 @@ AddConstructionFinalizer( static int FinalizeConstruction( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -76,7 +77,7 @@ FinalizeConstruction( int TclOO_Class_Constructor( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -85,11 +86,12 @@ TclOO_Class_Constructor( Object *oPtr = (Object *) Tcl_ObjectContextObject(context); Tcl_Obj **invoke, *nameObj; - if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + size_t skip = Tcl_ObjectContextSkippedArgs(context); + if ((size_t)objc > skip + 1) { + Tcl_WrongNumArgs(interp, skip, objv, "?definitionScript?"); return TCL_ERROR; - } else if (objc == Tcl_ObjectContextSkippedArgs(context)) { + } else if ((size_t)objc == skip) { return TCL_OK; } @@ -108,7 +110,7 @@ TclOO_Class_Constructor( * Delegate to [oo::define] to do the work. */ - invoke = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *)); + invoke = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *)); invoke[0] = oPtr->fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); invoke[2] = objv[objc-1]; @@ -134,7 +136,7 @@ TclOO_Class_Constructor( static int DecrRefsPostClassConstructor( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -154,7 +156,7 @@ DecrRefsPostClassConstructor( code = Tcl_EvalObjv(interp, 2, invoke, 0); TclDecrRefCount(invoke[0]); TclDecrRefCount(invoke[1]); - ckfree(invoke); + Tcl_Free(invoke); if (code != TCL_OK) { Tcl_DiscardInterpState(saved); return code; @@ -174,7 +176,7 @@ DecrRefsPostClassConstructor( int TclOO_Class_Create( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -183,7 +185,7 @@ TclOO_Class_Create( { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); const char *objName; - int len; + Tcl_Size len; /* * Sanity check; should not be possible to invoke this method on a @@ -203,12 +205,12 @@ TclOO_Class_Create( * Check we have the right number of (sensible) arguments. */ - if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) { + if (objc < 1 + Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "objectName ?arg ...?"); return TCL_ERROR; } - objName = TclGetStringFromObj( + objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -239,7 +241,7 @@ TclOO_Class_Create( int TclOO_Class_CreateNs( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -248,7 +250,7 @@ TclOO_Class_CreateNs( { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); const char *objName, *nsName; - int len; + Tcl_Size len; /* * Sanity check; should not be possible to invoke this method on a @@ -268,12 +270,12 @@ TclOO_Class_CreateNs( * Check we have the right number of (sensible) arguments. */ - if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) { + if (objc + 1 < Tcl_ObjectContextSkippedArgs(context) + 3) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "objectName namespaceName ?arg ...?"); return TCL_ERROR; } - objName = TclGetStringFromObj( + objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -281,7 +283,7 @@ TclOO_Class_CreateNs( Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (void *)NULL); return TCL_ERROR; } - nsName = TclGetStringFromObj( + nsName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)+1], &len); if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -312,7 +314,7 @@ TclOO_Class_CreateNs( int TclOO_Class_New( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -356,7 +358,7 @@ TclOO_Class_New( int TclOO_Object_Destroy( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -366,7 +368,7 @@ TclOO_Object_Destroy( Object *oPtr = (Object *) Tcl_ObjectContextObject(context); CallContext *contextPtr; - if (objc != Tcl_ObjectContextSkippedArgs(context)) { + if (objc != (int)Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -392,7 +394,7 @@ TclOO_Object_Destroy( static int AfterNRDestructor( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -417,7 +419,7 @@ AfterNRDestructor( int TclOO_Object_Eval( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -426,12 +428,12 @@ TclOO_Object_Eval( { CallContext *contextPtr = (CallContext *) context; Tcl_Object object = Tcl_ObjectContextObject(context); - const int skip = Tcl_ObjectContextSkippedArgs(context); + size_t skip = Tcl_ObjectContextSkippedArgs(context); CallFrame *framePtr, **framePtrPtr = &framePtr; Tcl_Obj *scriptPtr; CmdFrame *invoker; - if (objc-1 < skip) { + if ((size_t)objc < skip + 1) { Tcl_WrongNumArgs(interp, skip, objv, "arg ?arg ...?"); return TCL_ERROR; } @@ -459,7 +461,7 @@ TclOO_Object_Eval( * object when it decrements its refcount after eval'ing it. */ - if (objc != skip+1) { + if ((size_t)objc != skip+1) { scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip); invoker = NULL; } else { @@ -478,7 +480,7 @@ TclOO_Object_Eval( static int FinalizeEval( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -518,7 +520,7 @@ FinalizeEval( int TclOO_Object_Unknown( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -530,7 +532,8 @@ TclOO_Object_Unknown( Class *callerCls = NULL; Object *oPtr = contextPtr->oPtr; const char **methodNames; - int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context); + int numMethodNames, i; + size_t skip = Tcl_ObjectContextSkippedArgs(context); CallFrame *framePtr = ((Interp *) interp)->varFramePtr; Tcl_Obj *errorMsg; @@ -540,7 +543,7 @@ TclOO_Object_Unknown( * name without an error). */ - if (objc < skip+1) { + if ((size_t)objc < skip+1) { Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?"); return TCL_ERROR; } @@ -605,7 +608,7 @@ TclOO_Object_Unknown( Tcl_AppendToObj(errorMsg, " or ", -1); } Tcl_AppendToObj(errorMsg, methodNames[i], -1); - ckfree(methodNames); + Tcl_Free((void *)methodNames); Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[skip]), (void *)NULL); @@ -624,7 +627,7 @@ TclOO_Object_Unknown( int TclOO_Object_LinkVar( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -634,9 +637,9 @@ TclOO_Object_LinkVar( Interp *iPtr = (Interp *) interp; Tcl_Object object = Tcl_ObjectContextObject(context); Namespace *savedNsPtr; - int i; + Tcl_Size i; - if (objc-Tcl_ObjectContextSkippedArgs(context) < 0) { + if (objc < Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "?varName ...?"); return TCL_ERROR; @@ -652,7 +655,7 @@ TclOO_Object_LinkVar( return TCL_OK; } - for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) { + for (i = Tcl_ObjectContextSkippedArgs(context) ; i < objc ; i++) { Var *varPtr, *aryPtr; const char *varName = TclGetString(objv[i]); @@ -726,7 +729,7 @@ TclOO_Object_LinkVar( int TclOO_Object_VarName( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -738,13 +741,13 @@ TclOO_Object_VarName( CallFrame *framePtr = ((Interp *) interp)->varFramePtr; const char *arg; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if ((int)Tcl_ObjectContextSkippedArgs(context)+1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "varName"); return TCL_ERROR; } argPtr = objv[objc-1]; - arg = Tcl_GetString(argPtr); + arg = TclGetString(argPtr); /* * Convert the variable name to fully-qualified form if it wasn't already. @@ -777,12 +780,12 @@ TclOO_Object_VarName( Method *mPtr = callerContext->callPtr->chain[ callerContext->index].mPtr; PrivateVariableMapping *pvPtr; - int i; + Tcl_Size i; if (mPtr->declaringObjectPtr == oPtr) { FOREACH_STRUCT(pvPtr, oPtr->privateVariables) { - if (!strcmp(Tcl_GetString(pvPtr->variableObj), - Tcl_GetString(argPtr))) { + if (!strcmp(TclGetString(pvPtr->variableObj), + TclGetString(argPtr))) { argPtr = pvPtr->fullNameObj; break; } @@ -803,8 +806,8 @@ TclOO_Object_VarName( } if (isInstance) { FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) { - if (!strcmp(Tcl_GetString(pvPtr->variableObj), - Tcl_GetString(argPtr))) { + if (!strcmp(TclGetString(pvPtr->variableObj), + TclGetString(argPtr))) { argPtr = pvPtr->fullNameObj; break; } @@ -864,7 +867,7 @@ TclOO_Object_VarName( int TclOONextObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -900,7 +903,7 @@ TclOONextObjCmd( int TclOONextToObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -909,7 +912,7 @@ TclOONextToObjCmd( CallFrame *framePtr = iPtr->varFramePtr; Class *classPtr; CallContext *contextPtr; - int i; + Tcl_Size i; Tcl_Object object; const char *methodType; @@ -985,7 +988,7 @@ TclOONextToObjCmd( methodType = "method"; } - for (i=contextPtr->index ; i>=0 ; i--) { + for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) { struct MInvoke *miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { @@ -1006,7 +1009,7 @@ TclOONextToObjCmd( static int NextRestoreFrame( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -1015,7 +1018,7 @@ NextRestoreFrame( iPtr->varFramePtr = (CallFrame *)data[0]; if (contextPtr != NULL) { - contextPtr->index = PTR2INT(data[2]); + contextPtr->index = PTR2UINT(data[2]); } return result; } @@ -1033,7 +1036,7 @@ NextRestoreFrame( int TclOOSelfObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1045,12 +1048,11 @@ TclOOSelfObjCmd( enum SelfCmds { SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT, SELF_OBJECT, SELF_TARGET - }; + } index; Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; Tcl_Obj *result[3]; - int index; #define CurrentlyInvoked(contextPtr) \ ((contextPtr)->callPtr->chain[(contextPtr)->index]) @@ -1084,13 +1086,13 @@ TclOOSelfObjCmd( return TCL_ERROR; } - switch ((enum SelfCmds) index) { + switch (index) { case SELF_OBJECT: Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr)); return TCL_OK; case SELF_NS: Tcl_SetObjResult(interp, Tcl_NewStringObj( - contextPtr->oPtr->namespacePtr->fullName,-1)); + contextPtr->oPtr->namespacePtr->fullName, -1)); return TCL_OK; case SELF_CLASS: { Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr; @@ -1218,7 +1220,7 @@ TclOOSelfObjCmd( } else { Method *mPtr; Object *declarerPtr; - int i; + Tcl_Size i; for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){ if (!contextPtr->callPtr->chain[i].isFilter) { @@ -1270,7 +1272,7 @@ TclOOSelfObjCmd( int TclOOCopyObjectCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 85ca995..7695483 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -25,7 +25,7 @@ struct ChainBuilder { CallChain *callChainPtr; /* The call chain being built. */ - int filterLength; /* Number of entries in the call chain that + size_t filterLength; /* Number of entries in the call chain that * are due to processing filters and not the * main call chain. */ Object *oPtr; /* The object that we are building the chain @@ -139,7 +139,7 @@ static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); static Tcl_NRPostProc ResetFilterFlags; static Tcl_NRPostProc SetFilterFlags; -static int SortMethodNames(Tcl_HashTable *namesPtr, int flags, +static size_t SortMethodNames(Tcl_HashTable *namesPtr, int flags, const char ***stringsPtr); static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); @@ -152,7 +152,8 @@ static const Tcl_ObjType methodNameType = { FreeMethodNameRep, DupMethodNameRep, NULL, - NULL + NULL, + TCL_OBJTYPE_V0 }; @@ -207,7 +208,7 @@ TclOODeleteChainCache( } } Tcl_DeleteHashTable(tablePtr); - ckfree(tablePtr); + Tcl_Free(tablePtr); } /* @@ -228,9 +229,9 @@ TclOODeleteChain( return; } if (callPtr->chain != callPtr->staticChain) { - ckfree(callPtr->chain); + Tcl_Free(callPtr->chain); } - ckfree(callPtr); + Tcl_Free(callPtr); } /* @@ -328,7 +329,7 @@ TclOOInvokeContext( */ if (contextPtr->index == 0) { - int i; + Tcl_Size i; for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { AddRef(contextPtr->callPtr->chain[i].mPtr); @@ -371,7 +372,11 @@ TclOOInvokeContext( * Run the method implementation. */ - return (mPtr->typePtr->callProc)(mPtr->clientData, interp, + if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) { + return (mPtr->typePtr->callProc)(mPtr->clientData, interp, + (Tcl_ObjectContext) contextPtr, objc, objv); + } + return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp, (Tcl_ObjectContext) contextPtr, objc, objv); } @@ -406,7 +411,7 @@ FinalizeMethodRefs( int result) { CallContext *contextPtr = (CallContext *)data[0]; - int i; + Tcl_Size i; for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr); @@ -447,7 +452,7 @@ TclOOGetSortedMethodList( * at. Is set-like in nature and keyed by * pointer to class. */ FOREACH_HASH_DECLS; - int i, numStrings; + Tcl_Size i, numStrings; Class *mixinPtr; Tcl_Obj *namePtr; Method *mPtr; @@ -523,7 +528,7 @@ TclOOGetSortedMethodList( return numStrings; } -int +size_t TclOOGetSortedClassMethodList( Class *clsPtr, /* The class to get the method names for. */ int flags, /* Whether we just want the public method @@ -537,7 +542,7 @@ TclOOGetSortedClassMethodList( /* Used to track what classes have been looked * at. Is set-like in nature and keyed by * pointer to class. */ - int numStrings; + size_t numStrings; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); @@ -582,7 +587,7 @@ TclOOGetSortedClassMethodList( * ---------------------------------------------------------------------- */ -static int +static size_t SortMethodNames( Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains * whether the names are wanted and under what @@ -591,13 +596,13 @@ SortMethodNames( * methods. Full private methods are handled * on insertion to the table. */ const char ***stringsPtr) /* Where to store the sorted list of strings - * that we produce. ckalloced() */ + * that we produce. Tcl_Alloced() */ { const char **strings; FOREACH_HASH_DECLS; Tcl_Obj *namePtr; void *isWanted; - int i = 0; + size_t i = 0; /* * See how many (visible) method names there are. If none, we do not (and @@ -615,7 +620,7 @@ SortMethodNames( * sorted when it is long enough to matter. */ - strings = (const char **)ckalloc(sizeof(char *) * namesPtr->numEntries); + strings = (const char **)Tcl_Alloc(sizeof(char *) * namesPtr->numEntries); FOREACH_HASH(namePtr, isWanted, namesPtr) { if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) { if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { @@ -637,7 +642,7 @@ SortMethodNames( } *stringsPtr = strings; } else { - ckfree(strings); + Tcl_Free((void *)strings); *stringsPtr = NULL; } return i; @@ -688,14 +693,14 @@ AddClassMethodNames( * pointers to the classes, and the values are * immaterial. */ { - int i; + Tcl_Size i; /* * If we've already started looking at this class, stop working on it now * to prevent repeated work. */ - if (Tcl_FindHashEntry(examinedClassesPtr, (char *) clsPtr)) { + if (Tcl_FindHashEntry(examinedClassesPtr, clsPtr)) { return; } @@ -712,7 +717,7 @@ AddClassMethodNames( Method *mPtr; int isNew; - (void) Tcl_CreateHashEntry(examinedClassesPtr, (char *) clsPtr, + (void) Tcl_CreateHashEntry(examinedClassesPtr, clsPtr, &isNew); if (!isNew) { break; @@ -771,7 +776,7 @@ AddPrivateMethodNames( if (IS_PRIVATE(mPtr)) { int isNew; - hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + hPtr = Tcl_CreateHashEntry(namesPtr, namePtr, &isNew); Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); } } @@ -787,7 +792,7 @@ AddStandardMethodName( if (!IS_PRIVATE(mPtr)) { int isNew; Tcl_HashEntry *hPtr = - Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + Tcl_CreateHashEntry(namesPtr, namePtr, &isNew); if (isNew) { int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr)) @@ -835,7 +840,7 @@ AddInstancePrivateToCallContext( int donePrivate = 0; if (oPtr->methodsPtr) { - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodName); if (hPtr != NULL) { mPtr = (Method *)Tcl_GetHashValue(hPtr); if (IS_PRIVATE(mPtr)) { @@ -879,12 +884,13 @@ AddSimpleChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i, foundPrivate = 0, blockedUnexported = 0; + Tcl_Size i; + int foundPrivate = 0, blockedUnexported = 0; Tcl_HashEntry *hPtr; Method *mPtr; if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj); if (hPtr != NULL) { mPtr = (Method *)Tcl_GetHashValue(hPtr); @@ -915,7 +921,7 @@ AddSimpleChainToCallContext( flags | TRAVERSED_MIXIN, filterDecl); } if (oPtr->methodsPtr && !blockedUnexported) { - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj); if (hPtr != NULL) { mPtr = (Method *)Tcl_GetHashValue(hPtr); if (!IS_PRIVATE(mPtr)) { @@ -971,7 +977,7 @@ AddMethodToCallChain( * not passed a mixin. */ { CallChain *callPtr = cbPtr->callChainPtr; - int i; + Tcl_Size i; /* * Return if this is just an entry used to record whether this is a public @@ -1039,11 +1045,11 @@ AddMethodToCallChain( if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) { callPtr->chain = - (struct MInvoke *)ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1)); + (struct MInvoke *)Tcl_Alloc(sizeof(struct MInvoke) * (callPtr->numChain + 1)); memcpy(callPtr->chain, callPtr->staticChain, sizeof(struct MInvoke) * callPtr->numChain); } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) { - callPtr->chain = (struct MInvoke *)ckrealloc(callPtr->chain, + callPtr->chain = (struct MInvoke *)Tcl_Realloc(callPtr->chain, sizeof(struct MInvoke) * (callPtr->numChain + 1)); } callPtr->chain[i].mPtr = mPtr; @@ -1151,7 +1157,7 @@ TclOOGetCallContext( CallContext *contextPtr; CallChain *callPtr; struct ChainBuilder cb; - int i, count; + Tcl_Size i, count; int doFilters, donePrivate = 0; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -1207,14 +1213,14 @@ TclOOGetCallContext( if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache != NULL) { hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache, - (char *) methodNameObj); + methodNameObj); } else { hPtr = NULL; } } else { if (oPtr->chainCache != NULL) { hPtr = Tcl_FindHashEntry(oPtr->chainCache, - (char *) methodNameObj); + methodNameObj); } else { hPtr = NULL; } @@ -1233,7 +1239,7 @@ TclOOGetCallContext( doFilters = 1; } - callPtr = (CallChain *)ckalloc(sizeof(CallChain)); + callPtr = (CallChain *)Tcl_Alloc(sizeof(CallChain)); InitCallChain(callPtr, oPtr, flags); cb.callChainPtr = callPtr; @@ -1251,7 +1257,7 @@ TclOOGetCallContext( AddSimpleChainToCallContext(oPtr, NULL, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; - callPtr->epoch = -1; + callPtr->epoch = 0; if (callPtr->numChain == 0) { TclOODeleteChain(callPtr); return NULL; @@ -1328,30 +1334,31 @@ TclOOGetCallContext( AddSimpleChainToCallContext(oPtr, NULL, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; - callPtr->epoch = -1; + callPtr->epoch = 0; if (count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } } else if (doFilters && !donePrivate) { if (hPtr == NULL) { + int isNew; if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache == NULL) { oPtr->selfCls->classChainCache = - (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->selfCls->classChainCache); } hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache, - (char *) methodNameObj, &i); + methodNameObj, &isNew); } else { if (oPtr->chainCache == NULL) { - oPtr->chainCache = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + oPtr->chainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->chainCache); } hPtr = Tcl_CreateHashEntry(oPtr->chainCache, - (char *) methodNameObj, &i); + methodNameObj, &isNew); } } callPtr->refCount++; @@ -1411,7 +1418,7 @@ TclOOGetStereotypeCallChain( { CallChain *callPtr; struct ChainBuilder cb; - int i, count; + Tcl_Size count; Foundation *fPtr = clsPtr->thisPtr->fPtr; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -1437,7 +1444,7 @@ TclOOGetStereotypeCallChain( if (clsPtr->classChainCache != NULL) { hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, - (char *) methodNameObj); + methodNameObj); if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); @@ -1453,7 +1460,7 @@ TclOOGetStereotypeCallChain( hPtr = NULL; } - callPtr = (CallChain *)ckalloc(sizeof(CallChain)); + callPtr = (CallChain *)Tcl_Alloc(sizeof(CallChain)); memset(callPtr, 0, sizeof(CallChain)); callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING); callPtr->epoch = fPtr->epoch; @@ -1500,19 +1507,20 @@ TclOOGetStereotypeCallChain( AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; - callPtr->epoch = -1; + callPtr->epoch = 0; if (count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } } else { if (hPtr == NULL) { + int isNew; if (clsPtr->classChainCache == NULL) { - clsPtr->classChainCache = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + clsPtr->classChainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(clsPtr->classChainCache); } hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache, - (char *) methodNameObj, &i); + methodNameObj, &isNew); } callPtr->refCount++; Tcl_SetHashValue(hPtr, callPtr); @@ -1545,7 +1553,7 @@ AddClassFiltersToCallContext( int flags) /* Whether we've gone along a mixin link * yet. */ { - int i; + Tcl_Size i; int clearedFlags = flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS); Class *superPtr, *mixinPtr; @@ -1576,8 +1584,7 @@ AddClassFiltersToCallContext( FOREACH(filterObj, clsPtr->filters) { int isNew; - (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, - &isNew); + (void) Tcl_CreateHashEntry(doneFilters, filterObj, &isNew); if (isNew) { AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); @@ -1635,7 +1642,7 @@ AddPrivatesFromClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + Tcl_Size i; Class *superPtr; /* @@ -1713,7 +1720,8 @@ AddSimpleClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i, privateDanger = 0; + Tcl_Size i; + int privateDanger = 0; Class *superPtr; /* @@ -1739,7 +1747,7 @@ AddSimpleClassChainToCallContext( filterDecl, flags); } else { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, - (char *) methodNameObj); + methodNameObj); if (classPtr->flags & HAS_PRIVATE_METHODS) { privateDanger |= 1; @@ -1798,7 +1806,7 @@ TclOORenderCallChain( Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral; Tcl_Obj *resultObj, *descObjs[4], **objv; Foundation *fPtr = TclOOGetFoundation(interp); - int i; + Tcl_Size i; /* * Allocate the literals (potentially) used in our description. @@ -1928,7 +1936,7 @@ TclOOGetDefineContextNamespace( Tcl_ResetResult(interp); } if (define.list != staticSpace) { - ckfree(define.list); + Tcl_Free(define.list); } return nsPtr; } @@ -1954,7 +1962,7 @@ AddSimpleDefineNamespaces( * building. */ { Class *mixinPtr; - int i; + Tcl_Size i; FOREACH(mixinPtr, oPtr->mixins) { AddSimpleClassDefineNamespaces(mixinPtr, definePtr, @@ -1983,7 +1991,7 @@ AddSimpleClassDefineNamespaces( int flags) /* What sort of define chain are we * building. */ { - int i; + Tcl_Size i; Class *superPtr; /* @@ -2093,11 +2101,11 @@ AddDefinitionNamespaceToChain( DefineEntry *staticList = definePtr->list; definePtr->list = - (DefineEntry *)ckalloc(sizeof(DefineEntry) * definePtr->size); + (DefineEntry *)Tcl_Alloc(sizeof(DefineEntry) * definePtr->size); memcpy(definePtr->list, staticList, sizeof(DefineEntry) * definePtr->num); } else { - definePtr->list = (DefineEntry *)ckrealloc(definePtr->list, + definePtr->list = (DefineEntry *)Tcl_Realloc(definePtr->list, sizeof(DefineEntry) * definePtr->size); } } diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 6126fe2..68c5b2b 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -123,10 +123,20 @@ TCLAPI Tcl_Class Tcl_GetClassOfObject(Tcl_Object object); /* 31 */ TCLAPI Tcl_Obj * Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object); -/* Slot 32 is reserved */ -/* Slot 33 is reserved */ +/* 32 */ +TCLAPI int Tcl_MethodIsType2(Tcl_Method method, + const Tcl_MethodType2 *typePtr, + void **clientDataPtr); +/* 33 */ +TCLAPI Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, + Tcl_Object object, Tcl_Obj *nameObj, + int flags, const Tcl_MethodType2 *typePtr, + void *clientData); /* 34 */ -TCLAPI void TclOOUnusedStubEntry(void); +TCLAPI Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls, + Tcl_Obj *nameObj, int flags, + const Tcl_MethodType2 *typePtr, + void *clientData); typedef struct { const struct TclOOIntStubs *tclOOIntStubs; @@ -168,9 +178,9 @@ typedef struct TclOOStubs { int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */ Tcl_Class (*tcl_GetClassOfObject) (Tcl_Object object); /* 30 */ Tcl_Obj * (*tcl_GetObjectClassName) (Tcl_Interp *interp, Tcl_Object object); /* 31 */ - void (*reserved32)(void); - void (*reserved33)(void); - void (*tclOOUnusedStubEntry) (void); /* 34 */ + int (*tcl_MethodIsType2) (Tcl_Method method, const Tcl_MethodType2 *typePtr, void **clientDataPtr); /* 32 */ + Tcl_Method (*tcl_NewInstanceMethod2) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 33 */ + Tcl_Method (*tcl_NewMethod2) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 34 */ } TclOOStubs; extern const TclOOStubs *tclOOStubsPtr; @@ -249,19 +259,25 @@ extern const TclOOStubs *tclOOStubsPtr; (tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */ #define Tcl_GetObjectClassName \ (tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */ -/* Slot 32 is reserved */ -/* Slot 33 is reserved */ -#define TclOOUnusedStubEntry \ - (tclOOStubsPtr->tclOOUnusedStubEntry) /* 34 */ +#define Tcl_MethodIsType2 \ + (tclOOStubsPtr->tcl_MethodIsType2) /* 32 */ +#define Tcl_NewInstanceMethod2 \ + (tclOOStubsPtr->tcl_NewInstanceMethod2) /* 33 */ +#define Tcl_NewMethod2 \ + (tclOOStubsPtr->tcl_NewMethod2) /* 34 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ -#undef TclOOUnusedStubEntry -#define Tcl_MethodIsType2 Tcl_MethodIsType -#define Tcl_NewInstanceMethod2 Tcl_NewInstanceMethod -#define Tcl_NewMethod2 Tcl_NewMethod - +#if TCL_MAJOR_VERSION < 9 + /* TIP #630 for 8.7 */ +# undef Tcl_MethodIsType2 +# define Tcl_MethodIsType2 Tcl_MethodIsType +# undef Tcl_NewInstanceMethod2 +# define Tcl_NewInstanceMethod2 Tcl_NewInstanceMethod +# undef Tcl_NewMethod2 +# define Tcl_NewMethod2 Tcl_NewMethod +#endif #endif /* _TCLOODECLS */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 5f10475..1a0bb43 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -79,18 +79,55 @@ static inline void RecomputeClassCacheFlag(Object *oPtr); static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, int useClass, Tcl_Obj *const fromPtr, Tcl_Obj *const toPtr); -static Tcl_MethodCallProc ClassFilterGet, ClassFilterSet; -static Tcl_MethodCallProc ClassMixinGet, ClassMixinSet; +static int ClassFilterGet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassFilterSet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassMixinGet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassMixinSet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassSuperGet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassSuperSet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassVarsGet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassVarsSet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); static Tcl_MethodCallProc ClassRPropsGet, ClassRPropsSet; -static Tcl_MethodCallProc ClassSuperGet, ClassSuperSet; -static Tcl_MethodCallProc ClassVarsGet, ClassVarsSet; static Tcl_MethodCallProc ClassWPropsGet, ClassWPropsSet; -static Tcl_MethodCallProc ObjFilterGet, ObjFilterSet; -static Tcl_MethodCallProc ObjMixinGet, ObjMixinSet; +static int ObjFilterGet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjFilterSet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjMixinGet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjMixinSet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjVarsGet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjVarsSet(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); static Tcl_MethodCallProc ObjRPropsGet, ObjRPropsSet; -static Tcl_MethodCallProc ObjVarsGet, ObjVarsSet; static Tcl_MethodCallProc ObjWPropsGet, ObjWPropsSet; -static Tcl_MethodCallProc ResolveClass; +static int ResolveClass(void *clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); /* * Now define the slots used in declarations. @@ -265,10 +302,10 @@ RecomputeClassCacheFlag( void TclOOObjectSetFilters( Object *oPtr, - int numFilters, + Tcl_Size numFilters, Tcl_Obj *const *filters) { - int i; + Tcl_Size i; if (oPtr->filters.num) { Tcl_Obj *filterObj; @@ -283,7 +320,7 @@ TclOOObjectSetFilters( * No list of filters was supplied, so we're deleting filters. */ - ckfree(oPtr->filters.list); + Tcl_Free(oPtr->filters.list); oPtr->filters.list = NULL; oPtr->filters.num = 0; RecomputeClassCacheFlag(oPtr); @@ -296,9 +333,9 @@ TclOOObjectSetFilters( int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ if (oPtr->filters.num == 0) { - filtersList = (Tcl_Obj **)ckalloc(size); + filtersList = (Tcl_Obj **)Tcl_Alloc(size); } else { - filtersList = (Tcl_Obj **)ckrealloc(oPtr->filters.list, size); + filtersList = (Tcl_Obj **)Tcl_Realloc(oPtr->filters.list, size); } for (i = 0 ; i < numFilters ; i++) { filtersList[i] = filters[i]; @@ -325,10 +362,10 @@ void TclOOClassSetFilters( Tcl_Interp *interp, Class *classPtr, - int numFilters, + Tcl_Size numFilters, Tcl_Obj *const *filters) { - int i; + Tcl_Size i; if (classPtr->filters.num) { Tcl_Obj *filterObj; @@ -343,7 +380,7 @@ TclOOClassSetFilters( * No list of filters was supplied, so we're deleting filters. */ - ckfree(classPtr->filters.list); + Tcl_Free(classPtr->filters.list); classPtr->filters.list = NULL; classPtr->filters.num = 0; } else { @@ -355,9 +392,9 @@ TclOOClassSetFilters( int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ if (classPtr->filters.num == 0) { - filtersList = (Tcl_Obj **)ckalloc(size); + filtersList = (Tcl_Obj **)Tcl_Alloc(size); } else { - filtersList = (Tcl_Obj **)ckrealloc(classPtr->filters.list, size); + filtersList = (Tcl_Obj **)Tcl_Realloc(classPtr->filters.list, size); } for (i = 0 ; i < numFilters ; i++) { filtersList[i] = filters[i]; @@ -387,11 +424,11 @@ TclOOClassSetFilters( void TclOOObjectSetMixins( Object *oPtr, - int numMixins, + Tcl_Size numMixins, Class *const *mixins) { Class *mixinPtr; - int i; + Tcl_Size i; if (numMixins == 0) { if (oPtr->mixins.num != 0) { @@ -399,7 +436,7 @@ TclOOObjectSetMixins( TclOORemoveFromInstances(oPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - ckfree(oPtr->mixins.list); + Tcl_Free(oPtr->mixins.list); oPtr->mixins.num = 0; } RecomputeClassCacheFlag(oPtr); @@ -411,10 +448,10 @@ TclOOObjectSetMixins( } TclOODecrRefCount(mixinPtr->thisPtr); } - oPtr->mixins.list = (Class **)ckrealloc(oPtr->mixins.list, + oPtr->mixins.list = (Class **)Tcl_Realloc(oPtr->mixins.list, sizeof(Class *) * numMixins); } else { - oPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins); + oPtr->mixins.list = (Class **)Tcl_Alloc(sizeof(Class *) * numMixins); oPtr->flags &= ~USE_CLASS_CACHE; } oPtr->mixins.num = numMixins; @@ -448,11 +485,11 @@ void TclOOClassSetMixins( Tcl_Interp *interp, Class *classPtr, - int numMixins, + Tcl_Size numMixins, Class *const *mixins) { Class *mixinPtr; - int i; + Tcl_Size i; if (numMixins == 0) { if (classPtr->mixins.num != 0) { @@ -460,7 +497,7 @@ TclOOClassSetMixins( TclOORemoveFromMixinSubs(classPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - ckfree(classPtr->mixins.list); + Tcl_Free(classPtr->mixins.list); classPtr->mixins.num = 0; } } else { @@ -469,10 +506,10 @@ TclOOClassSetMixins( TclOORemoveFromMixinSubs(classPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - classPtr->mixins.list = (Class **)ckrealloc(classPtr->mixins.list, + classPtr->mixins.list = (Class **)Tcl_Realloc(classPtr->mixins.list, sizeof(Class *) * numMixins); } else { - classPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins); + classPtr->mixins.list = (Class **)Tcl_Alloc(sizeof(Class *) * numMixins); } classPtr->mixins.num = numMixins; memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); @@ -502,11 +539,12 @@ TclOOClassSetMixins( static inline void InstallStandardVariableMapping( VariableNameList *vnlPtr, - int varc, + Tcl_Size varc, Tcl_Obj *const *varv) { Tcl_Obj *variableObj; - int i, n, created; + Tcl_Size i, n; + int created; Tcl_HashTable uniqueTable; for (i=0 ; i<varc ; i++) { @@ -517,11 +555,11 @@ InstallStandardVariableMapping( } if (i != varc) { if (varc == 0) { - ckfree(vnlPtr->list); + Tcl_Free(vnlPtr->list); } else if (i) { - vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc); + vnlPtr->list = (Tcl_Obj **)Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc); } else { - vnlPtr->list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * varc); + vnlPtr->list = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * varc); } } vnlPtr->num = 0; @@ -542,7 +580,7 @@ InstallStandardVariableMapping( */ if (n != varc) { - vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n); + vnlPtr->list = (Tcl_Obj **)Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * n); } Tcl_DeleteHashTable(&uniqueTable); } @@ -551,12 +589,13 @@ InstallStandardVariableMapping( static inline void InstallPrivateVariableMapping( PrivateVariableList *pvlPtr, - int varc, + Tcl_Size varc, Tcl_Obj *const *varv, int creationEpoch) { PrivateVariableMapping *privatePtr; - int i, n, created; + Tcl_Size i, n; + int created; Tcl_HashTable uniqueTable; for (i=0 ; i<varc ; i++) { @@ -568,12 +607,12 @@ InstallPrivateVariableMapping( } if (i != varc) { if (varc == 0) { - ckfree(pvlPtr->list); + Tcl_Free(pvlPtr->list); } else if (i) { - pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list, + pvlPtr->list = (PrivateVariableMapping *)Tcl_Realloc(pvlPtr->list, sizeof(PrivateVariableMapping) * varc); } else { - pvlPtr->list = (PrivateVariableMapping *)ckalloc(sizeof(PrivateVariableMapping) * varc); + pvlPtr->list = (PrivateVariableMapping *)Tcl_Alloc(sizeof(PrivateVariableMapping) * varc); } } @@ -587,7 +626,7 @@ InstallPrivateVariableMapping( privatePtr->variableObj = varv[i]; privatePtr->fullNameObj = Tcl_ObjPrintf( PRIVATE_VARIABLE_PATTERN, - creationEpoch, Tcl_GetString(varv[i])); + creationEpoch, TclGetString(varv[i])); Tcl_IncrRefCount(privatePtr->fullNameObj); } else { Tcl_DecrRefCount(varv[i]); @@ -600,7 +639,7 @@ InstallPrivateVariableMapping( */ if (n != varc) { - pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list, + pvlPtr->list = (PrivateVariableMapping *)Tcl_Realloc(pvlPtr->list, sizeof(PrivateVariableMapping) * n); } Tcl_DeleteHashTable(&uniqueTable); @@ -638,12 +677,12 @@ RenameDeleteMethod( TclGetString(fromPtr), (void *)NULL); return TCL_ERROR; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, fromPtr); if (hPtr == NULL) { goto noSuchMethod; } if (toPtr) { - newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) toPtr, + newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, toPtr, &isNew); if (hPtr == newHPtr) { renameToSelf: @@ -661,8 +700,7 @@ RenameDeleteMethod( } } } else { - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *) fromPtr); + hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, fromPtr); if (hPtr == NULL) { goto noSuchMethod; } @@ -712,7 +750,7 @@ RenameDeleteMethod( int TclOOUnknownDefinition( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -720,7 +758,7 @@ TclOOUnknownDefinition( Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_HashSearch search; Tcl_HashEntry *hPtr; - int soughtLen; + Tcl_Size soughtLen; const char *soughtStr, *matchedStr = NULL; if (objc < 2) { @@ -733,7 +771,7 @@ TclOOUnknownDefinition( return TCL_ERROR; } - soughtStr = TclGetStringFromObj(objv[1], &soughtLen); + soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen); if (soughtLen == 0) { goto noMatch; } @@ -794,8 +832,8 @@ FindCommand( Tcl_Obj *stringObj, Tcl_Namespace *const namespacePtr) { - int length; - const char *nameStr, *string = TclGetStringFromObj(stringObj, &length); + Tcl_Size length; + const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length); Namespace *const nsPtr = (Namespace *) namespacePtr; FOREACH_HASH_DECLS; Tcl_Command cmd, cmd2; @@ -1013,16 +1051,16 @@ GenerateErrorInfo( * an object, class or class-as-object that * was being configured. */ { - int length; + Tcl_Size length; Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) ? savedNameObj : TclOOObjectName(interp, oPtr); - const char *objName = TclGetStringFromObj(realNameObj, &length); + const char *objName = Tcl_GetStringFromObj(realNameObj, &length); int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; int overflow = (length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (in definition script for %s \"%.*s%s\" line %d)", - typeOfSubject, (overflow ? limit : length), objName, + typeOfSubject, (overflow ? limit : (int)length), objName, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } @@ -1049,7 +1087,8 @@ MagicDefinitionInvoke( { Tcl_Obj *objPtr, *obj2Ptr, **objs; Tcl_Command cmd; - int isRoot, dummy, result, offset = cmdIndex + 1; + int isRoot, result, offset = cmdIndex + 1; + Tcl_Size dummy; /* * More than one argument: fire them through the ensemble processing @@ -1109,7 +1148,7 @@ MagicDefinitionInvoke( int TclOODefineObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1185,7 +1224,7 @@ TclOODefineObjCmd( int TclOOObjDefObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1254,7 +1293,7 @@ TclOOObjDefObjCmd( int TclOODefineSelfObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1325,7 +1364,7 @@ TclOODefineSelfObjCmd( int TclOODefineObjSelfObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1359,7 +1398,7 @@ TclOODefineObjSelfObjCmd( int TclOODefinePrivateObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1432,7 +1471,7 @@ TclOODefinePrivateObjCmd( int TclOODefineClassObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1513,8 +1552,8 @@ TclOODefineClassObjCmd( TclOODeleteDescendants(interp, oPtr); oPtr->flags &= ~DONT_DELETE; TclOOReleaseClassContents(interp, oPtr); - ckfree(oPtr->classPtr); - oPtr->classPtr = NULL; + Tcl_Free(oPtr->classPtr); + oPtr->classPtr = NULL; } else if (!wasClass && willBeClass) { TclOOAllocClass(interp, oPtr); } @@ -1541,7 +1580,7 @@ TclOODefineClassObjCmd( int TclOODefineConstructorObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1549,7 +1588,7 @@ TclOODefineConstructorObjCmd( Object *oPtr; Class *clsPtr; Tcl_Method method; - int bodyLength; + Tcl_Size bodyLength; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arguments body"); @@ -1567,7 +1606,7 @@ TclOODefineConstructorObjCmd( } clsPtr = oPtr->classPtr; - TclGetStringFromObj(objv[2], &bodyLength); + (void)Tcl_GetStringFromObj(objv[2], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -1610,7 +1649,7 @@ TclOODefineConstructorObjCmd( int TclOODefineDefnNsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1655,7 +1694,7 @@ TclOODefineDefnNsObjCmd( &kind) != TCL_OK) { return TCL_ERROR; } - if (!Tcl_GetString(objv[objc - 1])[0]) { + if (!TclGetString(objv[objc - 1])[0]) { nsNamePtr = NULL; } else { nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]); @@ -1695,7 +1734,7 @@ TclOODefineDefnNsObjCmd( int TclOODefineDeleteMethodObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1752,7 +1791,7 @@ TclOODefineDeleteMethodObjCmd( int TclOODefineDestructorObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1760,7 +1799,7 @@ TclOODefineDestructorObjCmd( Object *oPtr; Class *clsPtr; Tcl_Method method; - int bodyLength; + Tcl_Size bodyLength; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "body"); @@ -1773,7 +1812,7 @@ TclOODefineDestructorObjCmd( } clsPtr = oPtr->classPtr; - TclGetStringFromObj(objv[1], &bodyLength); + (void)Tcl_GetStringFromObj(objv[1], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -1817,7 +1856,7 @@ TclOODefineDestructorObjCmd( int TclOODefineExportObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1858,19 +1897,19 @@ TclOODefineExportObjCmd( if (isInstanceExport) { if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], + hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], &isNew); } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], + hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], &isNew); } if (isNew) { - mPtr = (Method *)ckalloc(sizeof(Method)); + mPtr = (Method *)Tcl_Alloc(sizeof(Method)); memset(mPtr, 0, sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = objv[i]; @@ -1913,7 +1952,7 @@ TclOODefineExportObjCmd( int TclOODefineForwardObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1977,7 +2016,7 @@ TclOODefineForwardObjCmd( int TclOODefineMethodObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2073,7 +2112,7 @@ TclOODefineMethodObjCmd( int TclOODefineRenameMethodObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2130,7 +2169,7 @@ TclOODefineRenameMethodObjCmd( int TclOODefineUnexportObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2171,19 +2210,19 @@ TclOODefineUnexportObjCmd( if (isInstanceUnexport) { if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], + hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], &isNew); } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], + hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], &isNew); } if (isNew) { - mPtr = (Method *)ckalloc(sizeof(Method)); + mPtr = (Method *)Tcl_Alloc(sizeof(Method)); memset(mPtr, 0, sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = objv[i]; @@ -2289,7 +2328,7 @@ TclOODefineSlots( Class *slotCls; slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) - fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr; + fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0))->classPtr; if (slotCls == NULL) { return TCL_ERROR; } @@ -2298,17 +2337,17 @@ TclOODefineSlots( Tcl_IncrRefCount(resolveName); for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0); + (Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE, NULL, 0); if (slotObject == NULL) { continue; } - Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0, + TclNewInstanceMethod(fPtr->interp, slotObject, getName, 0, &slotInfoPtr->getterType, NULL); - Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, + TclNewInstanceMethod(fPtr->interp, slotObject, setName, 0, &slotInfoPtr->setterType, NULL); if (slotInfoPtr->resolverType.callProc) { - Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, + TclNewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, &slotInfoPtr->resolverType, NULL); } } @@ -2331,7 +2370,7 @@ TclOODefineSlots( static int ClassFilterGet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2339,7 +2378,7 @@ ClassFilterGet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj, *filterObj; - int i; + Tcl_Size i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2365,14 +2404,14 @@ ClassFilterGet( static int ClassFilterSet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int filterc; + Tcl_Size filterc; Tcl_Obj **filterv; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { @@ -2411,7 +2450,7 @@ ClassFilterSet( static int ClassMixinGet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2420,7 +2459,7 @@ ClassMixinGet( Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; Class *mixinPtr; - int i; + Tcl_Size i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2448,20 +2487,21 @@ ClassMixinGet( static int ClassMixinSet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int mixinc, i, isNew; + Tcl_Size mixinc, i; Tcl_Obj **mixinv; - Class **mixins;; /* The references to the classes to actually + Class **mixins; /* The references to the classes to actually * install. */ Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a * set of class references; it has no payload * values and keys are always pointers. */ + int isNew; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2531,7 +2571,7 @@ ClassMixinSet( static int ClassSuperGet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2540,7 +2580,7 @@ ClassSuperGet( Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; Class *superPtr; - int i; + Tcl_Size i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2567,14 +2607,15 @@ ClassSuperGet( static int ClassSuperSet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int superc, i, j; + Tcl_Size superc, j; + Tcl_Size i; Tcl_Obj **superv; Class **superclasses, *superPtr; @@ -2606,7 +2647,7 @@ ClassSuperSet( * Allocate some working space. */ - superclasses = (Class **) ckalloc(sizeof(Class *) * superc); + superclasses = (Class **) Tcl_Alloc(sizeof(Class *) * superc); /* * Parse the arguments to get the class to use as superclasses. @@ -2616,7 +2657,7 @@ ClassSuperSet( */ if (superc == 0) { - superclasses = (Class **)ckrealloc(superclasses, sizeof(Class *)); + superclasses = (Class **)Tcl_Realloc(superclasses, sizeof(Class *)); if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { superclasses[0] = oPtr->fPtr->classCls; } else { @@ -2648,7 +2689,7 @@ ClassSuperSet( for (; i-- > 0 ;) { TclOODecrRefCount(superclasses[i]->thisPtr); } - ckfree(superclasses); + Tcl_Free(superclasses); return TCL_ERROR; } @@ -2673,7 +2714,7 @@ ClassSuperSet( TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); TclOODecrRefCount(superPtr->thisPtr); } - ckfree(oPtr->classPtr->superclasses.list); + Tcl_Free(oPtr->classPtr->superclasses.list); } oPtr->classPtr->superclasses.list = superclasses; oPtr->classPtr->superclasses.num = superc; @@ -2698,7 +2739,7 @@ ClassSuperSet( static int ClassVarsGet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2706,7 +2747,7 @@ ClassVarsGet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; - int i; + Tcl_Size i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2742,16 +2783,16 @@ ClassVarsGet( static int ClassVarsSet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int varc; + Tcl_Size i; + Tcl_Size varc; Tcl_Obj **varv; - int i; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2813,7 +2854,7 @@ ClassVarsSet( static int ObjFilterGet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2821,7 +2862,7 @@ ObjFilterGet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj, *filterObj; - int i; + Tcl_Size i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2841,14 +2882,14 @@ ObjFilterGet( static int ObjFilterSet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int filterc; + Tcl_Size filterc; Tcl_Obj **filterv; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { @@ -2881,7 +2922,7 @@ ObjFilterSet( static int ObjMixinGet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2890,7 +2931,7 @@ ObjMixinGet( Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; Class *mixinPtr; - int i; + Tcl_Size i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2913,20 +2954,21 @@ ObjMixinGet( static int ObjMixinSet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int mixinc, i, isNew; + Tcl_Size mixinc, i; Tcl_Obj **mixinv; Class **mixins; /* The references to the classes to actually * install. */ Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a * set of class references; it has no payload * values and keys are always pointers. */ + int isNew; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2983,7 +3025,7 @@ ObjMixinSet( static int ObjVarsGet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2991,7 +3033,7 @@ ObjVarsGet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; - int i; + Tcl_Size i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -3021,14 +3063,14 @@ ObjVarsGet( static int ObjVarsSet( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int varc, i; + Tcl_Size varc, i; Tcl_Obj **varv; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { @@ -3086,7 +3128,7 @@ ObjVarsSet( static int ResolveClass( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -3160,12 +3202,12 @@ InstallReadableProps( } if (i != objc) { if (objc == 0) { - ckfree(props->readable.list); + Tcl_Free(props->readable.list); } else if (i) { - props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list, + props->readable.list = (Tcl_Obj **)Tcl_Realloc(props->readable.list, sizeof(Tcl_Obj *) * objc); } else { - props->readable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc); + props->readable.list = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * objc); } } props->readable.num = 0; @@ -3186,7 +3228,7 @@ InstallReadableProps( */ if (n != objc) { - props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list, + props->readable.list = (Tcl_Obj **)Tcl_Realloc(props->readable.list, sizeof(Tcl_Obj *) * n); } Tcl_DeleteHashTable(&uniqueTable); @@ -3357,12 +3399,12 @@ InstallWritableProps( } if (i != objc) { if (objc == 0) { - ckfree(props->writable.list); + Tcl_Free(props->writable.list); } else if (i) { - props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list, + props->writable.list = (Tcl_Obj **)Tcl_Realloc(props->writable.list, sizeof(Tcl_Obj *) * objc); } else { - props->writable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc); + props->writable.list = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * objc); } } props->writable.num = 0; @@ -3383,7 +3425,7 @@ InstallWritableProps( */ if (n != objc) { - props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list, + props->writable.list = (Tcl_Obj **)Tcl_Realloc(props->writable.list, sizeof(Tcl_Obj *) * n); } Tcl_DeleteHashTable(&uniqueTable); diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 6aa3214..eba658b 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -199,7 +199,7 @@ InfoObjectClassCmd( return TCL_OK; } else { Class *mixinPtr, *o2clsPtr; - int i; + Tcl_Size i; o2clsPtr = GetClassFromObj(interp, objv[2]); if (o2clsPtr == NULL) { @@ -257,7 +257,7 @@ InfoObjectDefnCmd( if (!oPtr->methodsPtr) { goto unknownMethod; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]); if (hPtr == NULL) { unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -312,7 +312,7 @@ InfoObjectFiltersCmd( int objc, Tcl_Obj *const objv[]) { - int i; + Tcl_Size i; Tcl_Obj *filterObj, *resultObj; Object *oPtr; @@ -368,7 +368,7 @@ InfoObjectForwardCmd( if (!oPtr->methodsPtr) { goto unknownMethod; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]); if (hPtr == NULL) { unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -413,9 +413,10 @@ InfoObjectIsACmd( }; enum IsACats { IsClass, IsMetaclass, IsMixin, IsObject, IsType - }; + } idx; Object *oPtr, *o2Ptr; - int idx, i, result = 0; + int result = 0; + Tcl_Size i; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?"); @@ -431,7 +432,7 @@ InfoObjectIsACmd( * number of arguments. */ - switch ((enum IsACats) idx) { + switch (idx) { case IsObject: case IsClass: case IsMetaclass: @@ -459,7 +460,7 @@ InfoObjectIsACmd( goto failPrecondition; } - switch ((enum IsACats) idx) { + switch (idx) { case IsObject: result = 1; break; @@ -537,7 +538,7 @@ InfoObjectMethodsCmd( }; enum Options { OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE - }; + } idx; static const char *const scopes[] = { "private", "public", "unexported" }; @@ -555,14 +556,14 @@ InfoObjectMethodsCmd( return TCL_ERROR; } if (objc != 2) { - int i, idx; + int i; for (i=2 ; i<objc ; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &idx) != TCL_OK) { return TCL_ERROR; } - switch ((enum Options) idx) { + switch (idx) { case OPT_ALL: recurse = 1; break; @@ -617,7 +618,7 @@ InfoObjectMethodsCmd( Tcl_NewStringObj(names[i], -1)); } if (numNames > 0) { - ckfree(names); + Tcl_Free((void *)names); } } else if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { @@ -664,7 +665,7 @@ InfoObjectMethodTypeCmd( if (!oPtr->methodsPtr) { goto unknownMethod; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]); if (hPtr == NULL) { unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -707,7 +708,7 @@ InfoObjectMixinsCmd( Class *mixinPtr; Object *oPtr; Tcl_Obj *resultObj; - int i; + Tcl_Size i; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "objName"); @@ -814,14 +815,15 @@ InfoObjectVariablesCmd( { Object *oPtr; Tcl_Obj *resultObj; - int i, isPrivate = 0; + Tcl_Size i; + int isPrivate = 0; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); return TCL_ERROR; } if (objc == 3) { - if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + if (strcmp("-private", TclGetString(objv[2])) != 0) { return TCL_ERROR; } isPrivate = 1; @@ -1002,7 +1004,7 @@ InfoClassDefnCmd( if (clsPtr == NULL) { return TCL_ERROR; } - hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); + hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); @@ -1150,7 +1152,7 @@ InfoClassFiltersCmd( int objc, Tcl_Obj *const objv[]) { - int i; + Tcl_Size i; Tcl_Obj *filterObj, *resultObj; Class *clsPtr; @@ -1200,7 +1202,7 @@ InfoClassForwardCmd( if (clsPtr == NULL) { return TCL_ERROR; } - hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); + hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); @@ -1241,7 +1243,7 @@ InfoClassInstancesCmd( { Object *oPtr; Class *clsPtr; - int i; + Tcl_Size i; const char *pattern = NULL; Tcl_Obj *resultObj; @@ -1296,7 +1298,7 @@ InfoClassMethodsCmd( }; enum Options { OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE - }; + } idx; static const char *const scopes[] = { "private", "public", "unexported" }; @@ -1313,14 +1315,14 @@ InfoClassMethodsCmd( return TCL_ERROR; } if (objc != 2) { - int i, idx; + int i; for (i=2 ; i<objc ; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &idx) != TCL_OK) { return TCL_ERROR; } - switch ((enum Options) idx) { + switch (idx) { case OPT_ALL: recurse = 1; break; @@ -1364,14 +1366,14 @@ InfoClassMethodsCmd( TclNewObj(resultObj); if (recurse) { const char **names; - int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names); + Tcl_Size i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names); for (i=0 ; i<numNames ; i++) { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(names[i], -1)); } if (numNames > 0) { - ckfree(names); + Tcl_Free((void *)names); } } else { FOREACH_HASH_DECLS; @@ -1416,7 +1418,7 @@ InfoClassMethodTypeCmd( return TCL_ERROR; } - hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); + hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]); if (hPtr == NULL) { unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1457,7 +1459,7 @@ InfoClassMixinsCmd( { Class *clsPtr, *mixinPtr; Tcl_Obj *resultObj; - int i; + Tcl_Size i; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); @@ -1499,7 +1501,7 @@ InfoClassSubsCmd( { Class *clsPtr, *subclassPtr; Tcl_Obj *resultObj; - int i; + Tcl_Size i; const char *pattern = NULL; if (objc != 2 && objc != 3) { @@ -1554,7 +1556,7 @@ InfoClassSupersCmd( { Class *clsPtr, *superPtr; Tcl_Obj *resultObj; - int i; + Tcl_Size i; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); @@ -1593,14 +1595,15 @@ InfoClassVariablesCmd( { Class *clsPtr; Tcl_Obj *resultObj; - int i, isPrivate = 0; + Tcl_Size i; + int isPrivate = 0; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?"); return TCL_ERROR; } if (objc == 3) { - if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + if (strcmp("-private", TclGetString(objv[2])) != 0) { return TCL_ERROR; } isPrivate = 1; diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 82422b9..031b910 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -518,6 +518,17 @@ MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr); MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp, Object *useThisObj); +MODULE_SCOPE int TclMethodIsType(Tcl_Method method, + const Tcl_MethodType *typePtr, + void **clientDataPtr); +MODULE_SCOPE Tcl_Method TclNewInstanceMethod(Tcl_Interp *interp, + Tcl_Object object, Tcl_Obj *nameObj, + int flags, const Tcl_MethodType *typePtr, + void *clientData); +MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls, + Tcl_Obj *nameObj, int flags, + const Tcl_MethodType *typePtr, + void *clientData); MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, Tcl_Size objc, @@ -552,7 +563,7 @@ MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr); -MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr, +MODULE_SCOPE size_t TclOOGetSortedClassMethodList(Class *clsPtr, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, Object *contextObj, Class *contextCls, int flags, @@ -597,7 +608,7 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); /* * A convenience macro for iterating through the lists used in the internal * memory management of objects. - * REQUIRES DECLARATION: int i; + * REQUIRES DECLARATION: Tcl_Size i; */ #define FOREACH(var,ary) \ @@ -643,7 +654,7 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); do { \ size_t len = sizeof(type) * ((target).num=(source).num);\ if (len != 0) { \ - memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \ + memcpy(((target).list=(type*)Tcl_Alloc(len)), (source).list, len); \ } else { \ (target).list = NULL; \ } \ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 893c05e..4711695 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -126,7 +126,7 @@ static const Tcl_MethodType fwdMethodType = { */ Tcl_Method -Tcl_NewInstanceMethod( +TclNewInstanceMethod( TCL_UNUSED(Tcl_Interp *), Tcl_Object object, /* The object that has the method attached to * it. */ @@ -147,19 +147,19 @@ Tcl_NewInstanceMethod( int isNew; if (nameObj == NULL) { - mPtr = (Method *)ckalloc(sizeof(Method)); + mPtr = (Method *)Tcl_Alloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew); + hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, nameObj, &isNew); if (isNew) { - mPtr = (Method *)ckalloc(sizeof(Method)); + mPtr = (Method *)Tcl_Alloc(sizeof(Method)); mPtr->namePtr = nameObj; mPtr->refCount = 1; Tcl_IncrRefCount(nameObj); @@ -187,6 +187,50 @@ Tcl_NewInstanceMethod( oPtr->epoch++; return (Tcl_Method) mPtr; } +Tcl_Method +Tcl_NewInstanceMethod( + TCL_UNUSED(Tcl_Interp *), + Tcl_Object object, /* The object that has the method attached to + * it. */ + Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so, + * up to caller to manage storage (e.g., when + * it is a constructor or destructor). */ + int flags, /* Whether this is a public method. */ + const Tcl_MethodType *typePtr, + /* The type of method this is, which defines + * how to invoke, delete and clone the + * method. */ + void *clientData) /* Some data associated with the particular + * method to be created. */ +{ + if (typePtr->version > TCL_OO_METHOD_VERSION_1) { + Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewInstanceMethod"); + } + return TclNewInstanceMethod(NULL, object, nameObj, flags, + (const Tcl_MethodType *)typePtr, clientData); +} +Tcl_Method +Tcl_NewInstanceMethod2( + TCL_UNUSED(Tcl_Interp *), + Tcl_Object object, /* The object that has the method attached to + * it. */ + Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so, + * up to caller to manage storage (e.g., when + * it is a constructor or destructor). */ + int flags, /* Whether this is a public method. */ + const Tcl_MethodType2 *typePtr, + /* The type of method this is, which defines + * how to invoke, delete and clone the + * method. */ + void *clientData) /* Some data associated with the particular + * method to be created. */ +{ + if (typePtr->version < TCL_OO_METHOD_VERSION_2) { + Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewInstanceMethod2"); + } + return TclNewInstanceMethod(NULL, object, nameObj, flags, + (const Tcl_MethodType *)typePtr, clientData); +} /* * ---------------------------------------------------------------------- @@ -199,7 +243,7 @@ Tcl_NewInstanceMethod( */ Tcl_Method -Tcl_NewMethod( +TclNewMethod( TCL_UNUSED(Tcl_Interp *), Tcl_Class cls, /* The class to attach the method to. */ Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g., @@ -219,14 +263,14 @@ Tcl_NewMethod( int isNew; if (nameObj == NULL) { - mPtr = (Method *)ckalloc(sizeof(Method)); + mPtr = (Method *)Tcl_Alloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew); + hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, nameObj,&isNew); if (isNew) { - mPtr = (Method *)ckalloc(sizeof(Method)); + mPtr = (Method *)Tcl_Alloc(sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = nameObj; Tcl_IncrRefCount(nameObj); @@ -255,6 +299,48 @@ Tcl_NewMethod( return (Tcl_Method) mPtr; } + +Tcl_Method +Tcl_NewMethod( + TCL_UNUSED(Tcl_Interp *), + Tcl_Class cls, /* The class to attach the method to. */ + Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g., + * for constructors or destructors); if so, up + * to caller to manage storage. */ + int flags, /* Whether this is a public method. */ + const Tcl_MethodType *typePtr, + /* The type of method this is, which defines + * how to invoke, delete and clone the + * method. */ + void *clientData) /* Some data associated with the particular + * method to be created. */ +{ + if (typePtr->version > TCL_OO_METHOD_VERSION_1) { + Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewMethod"); + } + return TclNewMethod(NULL, cls, nameObj, flags, typePtr, clientData); +} + +Tcl_Method +Tcl_NewMethod2( + TCL_UNUSED(Tcl_Interp *), + Tcl_Class cls, /* The class to attach the method to. */ + Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g., + * for constructors or destructors); if so, up + * to caller to manage storage. */ + int flags, /* Whether this is a public method. */ + const Tcl_MethodType2 *typePtr, + /* The type of method this is, which defines + * how to invoke, delete and clone the + * method. */ + void *clientData) /* Some data associated with the particular + * method to be created. */ +{ + if (typePtr->version < TCL_OO_METHOD_VERSION_2) { + Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewMethod2"); + } + return TclNewMethod(NULL, cls, nameObj, flags, (const Tcl_MethodType *)typePtr, clientData); +} /* * ---------------------------------------------------------------------- @@ -278,7 +364,7 @@ TclOODelMethodRef( Tcl_DecrRefCount(mPtr->namePtr); } - ckfree(mPtr); + Tcl_Free(mPtr); } } @@ -304,7 +390,7 @@ TclOONewBasicMethod( Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1); Tcl_IncrRefCount(namePtr); - Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr, + TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr, (dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL); Tcl_DecrRefCount(namePtr); } @@ -335,14 +421,14 @@ TclOONewProcInstanceMethod( * structure's contents. NULL if caller is not * interested. */ { - int argsLen; + Tcl_Size argsLen; ProcedureMethod *pmPtr; Tcl_Method method; if (TclListObjLengthM(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } - pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); + pmPtr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; @@ -351,7 +437,7 @@ TclOONewProcInstanceMethod( method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (method == NULL) { - ckfree(pmPtr); + Tcl_Free(pmPtr); } else if (pmPtrPtr != NULL) { *pmPtrPtr = pmPtr; } @@ -387,13 +473,13 @@ TclOONewProcMethod( * structure's contents. NULL if caller is not * interested. */ { - int argsLen; /* -1 => delete argsObj before exit */ + Tcl_Size argsLen; /* TCL_INDEX_NONE => delete argsObj before exit */ ProcedureMethod *pmPtr; const char *procName; Tcl_Method method; if (argsObj == NULL) { - argsLen = -1; + argsLen = TCL_INDEX_NONE; TclNewObj(argsObj); Tcl_IncrRefCount(argsObj); procName = "<destructor>"; @@ -403,7 +489,7 @@ TclOONewProcMethod( procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj)); } - pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); + pmPtr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; @@ -412,11 +498,11 @@ TclOONewProcMethod( method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); - if (argsLen == -1) { + if (argsLen == TCL_INDEX_NONE) { Tcl_DecrRefCount(argsObj); } if (method == NULL) { - ckfree(pmPtr); + Tcl_Free(pmPtr); } else if (pmPtrPtr != NULL) { *pmPtrPtr = pmPtr; } @@ -497,12 +583,12 @@ TclOOMakeProcInstanceMethod( if (context.line && (context.nline >= 4) && (context.line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = (int *)ckalloc(sizeof(int)); + cfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size)); cfPtr->line[0] = context.line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -515,7 +601,7 @@ TclOOMakeProcInstanceMethod( cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, - (char *) procPtr, &isNew); + procPtr, &isNew); Tcl_SetHashValue(hPtr, cfPtr); } @@ -529,7 +615,7 @@ TclOOMakeProcInstanceMethod( } } - return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, + return TclNewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, typePtr, clientData); } @@ -610,12 +696,12 @@ TclOOMakeProcMethod( if (context.line && (context.nline >= 4) && (context.line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = (int *)ckalloc(sizeof(int)); + cfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size)); cfPtr->line[0] = context.line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -628,7 +714,7 @@ TclOOMakeProcMethod( cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, - (char *) procPtr, &isNew); + procPtr, &isNew); Tcl_SetHashValue(hPtr, cfPtr); } @@ -642,7 +728,7 @@ TclOOMakeProcMethod( } } - return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr, + return TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr, clientData); } @@ -987,7 +1073,8 @@ ProcedureMethodCompiledVarConnect( Tcl_Obj *variableObj; PrivateVariableMapping *privateVar; Tcl_HashEntry *hPtr; - int i, isNew, cacheIt, varLen, len; + int isNew, cacheIt; + Tcl_Size i, varLen, len; const char *match, *varName; /* @@ -1016,12 +1103,12 @@ ProcedureMethodCompiledVarConnect( * either. */ - varName = TclGetStringFromObj(infoPtr->variableObj, &varLen); + varName = Tcl_GetStringFromObj(infoPtr->variableObj, &varLen); if (contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr != NULL) { FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr->privateVariables) { - match = TclGetStringFromObj(privateVar->variableObj, &len); + match = Tcl_GetStringFromObj(privateVar->variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { variableObj = privateVar->fullNameObj; cacheIt = 0; @@ -1030,7 +1117,7 @@ ProcedureMethodCompiledVarConnect( } FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr->variables) { - match = TclGetStringFromObj(variableObj, &len); + match = Tcl_GetStringFromObj(variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { cacheIt = 0; goto gotMatch; @@ -1038,7 +1125,7 @@ ProcedureMethodCompiledVarConnect( } } else { FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) { - match = TclGetStringFromObj(privateVar->variableObj, &len); + match = Tcl_GetStringFromObj(privateVar->variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { variableObj = privateVar->fullNameObj; cacheIt = 1; @@ -1046,7 +1133,7 @@ ProcedureMethodCompiledVarConnect( } } FOREACH(variableObj, contextPtr->oPtr->variables) { - match = TclGetStringFromObj(variableObj, &len); + match = Tcl_GetStringFromObj(variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { cacheIt = 1; goto gotMatch; @@ -1061,7 +1148,7 @@ ProcedureMethodCompiledVarConnect( gotMatch: hPtr = Tcl_CreateHashEntry(TclVarTable(contextPtr->oPtr->namespacePtr), - (char *) variableObj, &isNew); + variableObj, &isNew); if (isNew) { TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr)); } @@ -1094,14 +1181,14 @@ ProcedureMethodCompiledVarDelete( TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL); } Tcl_DecrRefCount(infoPtr->variableObj); - ckfree(infoPtr); + Tcl_Free(infoPtr); } static int ProcedureMethodCompiledVarResolver( TCL_UNUSED(Tcl_Interp *), const char *varName, - int length, + Tcl_Size length, TCL_UNUSED(Tcl_Namespace *), Tcl_ResolvedVarInfo **rPtrPtr) { @@ -1113,13 +1200,13 @@ ProcedureMethodCompiledVarResolver( * which look like array accesses. Both will lead us astray. */ - if (strstr(Tcl_GetString(variableObj), "::") != NULL || - Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) { + if (strstr(TclGetString(variableObj), "::") != NULL || + Tcl_StringMatch(TclGetString(variableObj), "*(*)")) { Tcl_DecrRefCount(variableObj); return TCL_CONTINUE; } - infoPtr = (OOResVarInfo *)ckalloc(sizeof(OOResVarInfo)); + infoPtr = (OOResVarInfo *)Tcl_Alloc(sizeof(OOResVarInfo)); infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect; infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete; infoPtr->cachedObjectVar = NULL; @@ -1174,7 +1261,7 @@ RenderDeclarerName( #define LIMIT 60 #define ELLIPSIFY(str,len) \ - ((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "") + ((len) > LIMIT ? LIMIT : (int)(len)), (str), ((len) > LIMIT ? "..." : "") static void MethodErrorHandler( @@ -1182,11 +1269,11 @@ MethodErrorHandler( TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/) /* We pull the method name out of context instead of from argument */ { - int nameLen, objectNameLen; + Tcl_Size nameLen, objectNameLen; CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; const char *objectName, *kindName, *methodName = - TclGetStringFromObj(mPtr->namePtr, &nameLen); + Tcl_GetStringFromObj(mPtr->namePtr, &nameLen); Object *declarerPtr; if (mPtr->declaringObjectPtr != NULL) { @@ -1200,7 +1287,7 @@ MethodErrorHandler( kindName = "class"; } - objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr), + objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr), &objectNameLen); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)", @@ -1218,7 +1305,7 @@ ConstructorErrorHandler( Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; - int objectNameLen; + Tcl_Size objectNameLen; if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; @@ -1231,7 +1318,7 @@ ConstructorErrorHandler( kindName = "class"; } - objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr), + objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr), &objectNameLen); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%s \"%.*s%s\" constructor line %d)", kindName, @@ -1248,7 +1335,7 @@ DestructorErrorHandler( Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; - int objectNameLen; + Tcl_Size objectNameLen; if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; @@ -1261,7 +1348,7 @@ DestructorErrorHandler( kindName = "class"; } - objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr), + objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr), &objectNameLen); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%s \"%.*s%s\" destructor line %d)", kindName, @@ -1286,7 +1373,7 @@ DeleteProcedureMethodRecord( if (pmPtr->deleteClientdataProc) { pmPtr->deleteClientdataProc(pmPtr->clientData); } - ckfree(pmPtr); + Tcl_Free(pmPtr); } static void @@ -1337,7 +1424,7 @@ CloneProcedureMethod( */ bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); - Tcl_GetString(bodyObj); + TclGetString(bodyObj); Tcl_StoreInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL); /* @@ -1345,7 +1432,7 @@ CloneProcedureMethod( * record. */ - pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); + pm2Ptr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; Tcl_IncrRefCount(argsObj); @@ -1354,7 +1441,7 @@ CloneProcedureMethod( &pm2Ptr->procPtr) != TCL_OK) { Tcl_DecrRefCount(argsObj); Tcl_DecrRefCount(bodyObj); - ckfree(pm2Ptr); + Tcl_Free(pm2Ptr); return TCL_ERROR; } Tcl_DecrRefCount(argsObj); @@ -1386,7 +1473,7 @@ TclOONewForwardInstanceMethod( Tcl_Obj *prefixObj) /* List of arguments that form the command * prefix to forward to. */ { - int prefixLen; + Tcl_Size prefixLen; ForwardMethod *fmPtr; if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) { @@ -1399,10 +1486,10 @@ TclOONewForwardInstanceMethod( return NULL; } - fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod)); + fmPtr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_IncrRefCount(prefixObj); - return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, + return (Method *) TclNewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, &fwdMethodType, fmPtr); } @@ -1425,7 +1512,7 @@ TclOONewForwardMethod( Tcl_Obj *prefixObj) /* List of arguments that form the command * prefix to forward to. */ { - int prefixLen; + Tcl_Size prefixLen; ForwardMethod *fmPtr; if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) { @@ -1438,10 +1525,10 @@ TclOONewForwardMethod( return NULL; } - fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod)); + fmPtr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_IncrRefCount(prefixObj); - return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, + return (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, &fwdMethodType, fmPtr); } @@ -1467,7 +1554,8 @@ InvokeForwardMethod( CallContext *contextPtr = (CallContext *) context; ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_Obj **argObjs, **prefixObjs; - int numPrefixes, len, skip = contextPtr->skip; + Tcl_Size numPrefixes, skip = contextPtr->skip; + int len; /* * Build the real list of arguments to use. Note that we know that the @@ -1519,7 +1607,7 @@ DeleteForwardMethod( ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_DecrRefCount(fmPtr->prefixObj); - ckfree(fmPtr); + Tcl_Free(fmPtr); } static int @@ -1529,7 +1617,7 @@ CloneForwardMethod( void **newClientData) { ForwardMethod *fmPtr = (ForwardMethod *)clientData; - ForwardMethod *fm2Ptr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod)); + ForwardMethod *fm2Ptr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; Tcl_IncrRefCount(fm2Ptr->prefixObj); @@ -1619,7 +1707,7 @@ InitEnsembleRewrite( int *lengthPtr) /* Where to write the resulting length of the * array of rewritten arguments. */ { - unsigned len = rewriteLength + objc - toRewrite; + size_t len = rewriteLength + objc - toRewrite; Tcl_Obj **argObjs = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * len); memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *)); @@ -1672,6 +1760,23 @@ Tcl_MethodName( } int +TclMethodIsType( + Tcl_Method method, + const Tcl_MethodType *typePtr, + void **clientDataPtr) +{ + Method *mPtr = (Method *) method; + + if (mPtr->typePtr == typePtr) { + if (clientDataPtr != NULL) { + *clientDataPtr = mPtr->clientData; + } + return 1; + } + return 0; +} + +int Tcl_MethodIsType( Tcl_Method method, const Tcl_MethodType *typePtr, @@ -1679,6 +1784,9 @@ Tcl_MethodIsType( { Method *mPtr = (Method *) method; + if (typePtr->version > TCL_OO_METHOD_VERSION_1) { + Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_MethodIsType"); + } if (mPtr->typePtr == typePtr) { if (clientDataPtr != NULL) { *clientDataPtr = mPtr->clientData; @@ -1689,6 +1797,26 @@ Tcl_MethodIsType( } int +Tcl_MethodIsType2( + Tcl_Method method, + const Tcl_MethodType2 *typePtr, + void **clientDataPtr) +{ + Method *mPtr = (Method *) method; + + if (typePtr->version < TCL_OO_METHOD_VERSION_2) { + Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_MethodIsType2"); + } + if (mPtr->typePtr == (const Tcl_MethodType *)typePtr) { + if (clientDataPtr != NULL) { + *clientDataPtr = mPtr->clientData; + } + return 1; + } + return 0; +} + +int Tcl_MethodIsPublic( Tcl_Method method) { diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index 1923037..7b653cb 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -14,8 +14,6 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #pragma GCC dependency "tclOO.decls" #endif -#define TclOOUnusedStubEntry 0 - /* !BEGIN!: Do not edit below this line. */ static const TclOOIntStubs tclOOIntStubs = { @@ -78,9 +76,9 @@ const TclOOStubs tclOOStubs = { Tcl_MethodIsPrivate, /* 29 */ Tcl_GetClassOfObject, /* 30 */ Tcl_GetObjectClassName, /* 31 */ - 0, /* 32 */ - 0, /* 33 */ - TclOOUnusedStubEntry, /* 34 */ + Tcl_MethodIsType2, /* 32 */ + Tcl_NewInstanceMethod2, /* 33 */ + Tcl_NewMethod2, /* 34 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 7f41765..b929592 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -178,14 +178,14 @@ static Tcl_ThreadDataKey pendingObjDataKey; #define PACK_BIGNUM(bignum, objPtr) \ if ((bignum).used > 0x7FFF) { \ - mp_int *temp = (mp_int *)ckalloc(sizeof(mp_int)); \ + mp_int *temp = (mp_int *)Tcl_Alloc(sizeof(mp_int)); \ *temp = bignum; \ (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ } else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(bignum).dp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \ - | ((bignum).alloc << 15) | ((bignum).used)); \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \ + | ((bignum).alloc << 15) | ((bignum).used)); \ } /* @@ -197,9 +197,6 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) -static void UpdateStringOfOldInt(Tcl_Obj *objPtr); -#endif static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void UpdateStringOfBignum(Tcl_Obj *objPtr); @@ -228,55 +225,37 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -static const Tcl_ObjType oldBooleanType = { +const Tcl_ObjType tclBooleanType= { "boolean", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - TclSetBooleanFromAny /* setFromAnyProc */ + TclSetBooleanFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V1(TclLengthOne) }; -#endif -const Tcl_ObjType tclBooleanType = { - "booleanString", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - TclSetBooleanFromAny /* setFromAnyProc */ -}; -const Tcl_ObjType tclDoubleType = { +const Tcl_ObjType tclDoubleType= { "double", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ - SetDoubleFromAny /* setFromAnyProc */ + SetDoubleFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V1(TclLengthOne) }; const Tcl_ObjType tclIntType = { -#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 || defined(TCL_WIDE_INT_IS_LONG) "int", /* name */ -#else - "wideInt", /* name, keeping maximum compatibility with Tcl 8.6 on 32-bit platforms*/ -#endif NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ -}; -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) -static const Tcl_ObjType oldIntType = { - "int", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfOldInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ + SetIntFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V1(TclLengthOne) }; -#endif const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V1(TclLengthOne) }; /* @@ -320,7 +299,8 @@ Tcl_ObjType tclCmdNameType = { FreeCmdNameInternalRep, /* freeIntRepProc */ DupCmdNameInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetCmdNameFromAny /* setFromAnyProc */ + SetCmdNameFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -336,7 +316,7 @@ typedef struct ResolvedCmdName { * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - unsigned long refNsId; /* refNsPtr's unique namespace id. Used to + size_t refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid (e.g., * it's possible that the cmd's containing * namespace was deleted and a new one created @@ -358,6 +338,18 @@ typedef struct ResolvedCmdName { * structure can be freed when refCount * becomes zero. */ } ResolvedCmdName; + +#ifdef TCL_MEM_DEBUG +/* + * Filler matches the value used for filling freed memory in tclCkalloc. + * On 32-bit systems, the ref counts do not cross 0x7fffffff. On 64-bit + * implementations, ref counts will never reach this value (unless explicitly + * incremented without actual references!) + */ +#define FREEDREFCOUNTFILLER \ + (Tcl_Size)(sizeof(objPtr->refCount) == 4 ? 0xe8e8e8e8 : 0xe8e8e8e8e8e8e8e8) +#endif + /* *------------------------------------------------------------------------- @@ -385,14 +377,8 @@ TclInitObjSubsystem(void) Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); - Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); -#if !defined(TCL_NO_DEPRECATED) Tcl_RegisterObjType(&tclStringType); - /* Only registered for 8.7, not for 9.0 any more. - * See [https://core.tcl-lang.org/tk/tktview/6b49149b4e] */ - Tcl_RegisterObjType(&tclUniCharStringType); -#endif Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); @@ -400,15 +386,6 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); - /* For backward compatibility only ... */ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - Tcl_RegisterObjType(&tclIntType); -#if !defined(TCL_WIDE_INT_IS_LONG) - Tcl_RegisterObjType(&oldIntType); -#endif - Tcl_RegisterObjType(&oldBooleanType); -#endif - #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; @@ -456,12 +433,12 @@ TclFinalizeThreadObjects(void) ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); if (objData != NULL) { - ckfree(objData); + Tcl_Free(objData); } } Tcl_DeleteHashTable(tablePtr); - ckfree(tablePtr); + Tcl_Free(tablePtr); tsdPtr->objThreadMap = NULL; } #endif @@ -537,7 +514,7 @@ TclGetContLineTable(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->lineCLPtr) { - tsdPtr->lineCLPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->lineCLPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); } @@ -566,13 +543,13 @@ ContLineLoc * TclContinuationsEnter( Tcl_Obj *objPtr, Tcl_Size num, - int *loc) + Tcl_Size *loc) { int newEntry; ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); - ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(int)); + ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_Alloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(Tcl_Size)); if (!newEntry) { /* @@ -596,11 +573,11 @@ TclContinuationsEnter( * doing. */ - ckfree(Tcl_GetHashValue(hPtr)); + Tcl_Free(Tcl_GetHashValue(hPtr)); } clLocPtr->num = num; - memcpy(&clLocPtr->loc, loc, num*sizeof(int)); + memcpy(&clLocPtr->loc, loc, num*sizeof(Tcl_Size)); clLocPtr->loc[num] = CLL_END; /* Sentinel */ Tcl_SetHashValue(hPtr, clLocPtr); @@ -629,12 +606,12 @@ TclContinuationsEnter( void TclContinuationsEnterDerived( Tcl_Obj *objPtr, - int start, - int *clNext) + Tcl_Size start, + Tcl_Size *clNext) { Tcl_Size length; - int end, num; - int *wordCLLast = clNext; + Tcl_Size end, num; + Tcl_Size *wordCLLast = clNext; /* * We have to handle invisible continuations lines here as well, despite @@ -660,7 +637,7 @@ TclContinuationsEnterDerived( * better way which doesn't shimmer?) */ - TclGetStringFromObj(objPtr, &length); + (void)Tcl_GetStringFromObj(objPtr, &length); end = start + length; /* First char after the word */ /* @@ -677,7 +654,7 @@ TclContinuationsEnterDerived( num = wordCLLast - clNext; if (num) { - int i; + Tcl_Size i; ContLineLoc *clLocPtr = TclContinuationsEnter(objPtr, num, clNext); /* @@ -801,11 +778,11 @@ TclThreadFinalizeContLines( for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - ckfree(Tcl_GetHashValue(hPtr)); + Tcl_Free(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(tsdPtr->lineCLPtr); - ckfree(tsdPtr->lineCLPtr); + Tcl_Free(tsdPtr->lineCLPtr); tsdPtr->lineCLPtr = NULL; } @@ -1081,7 +1058,7 @@ TclDbInitNewObj( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->objThreadMap == NULL) { - tsdPtr->objThreadMap = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + tsdPtr->objThreadMap = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); } tablePtr = tsdPtr->objThreadMap; @@ -1094,7 +1071,7 @@ TclDbInitNewObj( * Record the debugging information. */ - objData = (ObjData *)ckalloc(sizeof(ObjData)); + objData = (ObjData *)Tcl_Alloc(sizeof(ObjData)); objData->objPtr = objPtr; objData->file = file; objData->line = line; @@ -1219,7 +1196,7 @@ Tcl_DbNewObj( * TclAllocateFreeObjects -- * * Function to allocate a number of free Tcl_Objs. This is done using a - * single ckalloc to reduce the overhead for Tcl_Obj allocation. + * single Tcl_Alloc to reduce the overhead for Tcl_Obj allocation. * * Assumes mutex is held. * @@ -1248,12 +1225,12 @@ TclAllocateFreeObjects(void) * This has been noted by Purify to be a potential leak. The problem is * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually - * freeing the memory. TclFinalizeObjects() does not ckfree() this memory, + * freeing the memory. TclFinalizeObjects() does not Tcl_Free() this memory, * but leaves it to Tcl's memory subsystem finalization to release it. * Purify apparently can't figure that out, and fires a false alarm. */ - basePtr = (char *)ckalloc(bytesToAlloc); + basePtr = (char *)Tcl_Alloc(bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; @@ -1319,7 +1296,7 @@ TclFreeObj( if (!tablePtr) { Tcl_Panic("TclFreeObj: object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (hPtr) { /* * As the Tcl_Obj is going to be deleted we remove the entry. @@ -1328,7 +1305,7 @@ TclFreeObj( ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); if (objData != NULL) { - ckfree(objData); + Tcl_Free(objData); } Tcl_DeleteHashEntry(hPtr); @@ -1342,7 +1319,7 @@ TclFreeObj( * either from 1 to 0, or from 0 to -1. Falling from -1 to -2, though, * and so on, is always a sign of a botch in the caller. */ - if (objPtr->refCount < -1) { + if (objPtr->refCount == (Tcl_Size)-2) { Tcl_Panic("Reference count for %p was negative", objPtr); } /* @@ -1372,7 +1349,7 @@ TclFreeObj( } Tcl_MutexLock(&tclObjMutex); - ckfree(objPtr); + Tcl_Free(objPtr); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); ObjDeletionLock(context); @@ -1384,7 +1361,7 @@ TclFreeObj( TclFreeInternalRep(objToFree); Tcl_MutexLock(&tclObjMutex); - ckfree(objToFree); + Tcl_Free(objToFree); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); } @@ -1408,7 +1385,7 @@ TclFreeObj( if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - ckfree(Tcl_GetHashValue(hPtr)); + Tcl_Free(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } @@ -1499,7 +1476,7 @@ TclFreeObj( if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - ckfree(Tcl_GetHashValue(hPtr)); + Tcl_Free(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } @@ -1566,7 +1543,7 @@ TclObjBeingDeleted( const Tcl_ObjType *typePtr = (objPtr)->typePtr; \ const char *bytes = (objPtr)->bytes; \ if (bytes) { \ - (void)TclAttemptInitStringRep((dupPtr), bytes, (objPtr)->length); \ + TclInitStringRep((dupPtr), bytes, (objPtr)->length); \ } else { \ (dupPtr)->bytes = NULL; \ } \ @@ -1649,7 +1626,7 @@ Tcl_GetString( objPtr->typePtr->name); } objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length < 0 + if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE || objPtr->bytes[objPtr->length] != '\0') { Tcl_Panic("UpdateStringProc for type '%s' " "failed to create a valid string rep", @@ -1662,7 +1639,7 @@ Tcl_GetString( /* *---------------------------------------------------------------------- * - * Tcl_GetStringFromObj -- + * Tcl_GetStringFromObj/TclGetStringFromObj -- * * Returns the string representation's byte array pointer and length for * an object. @@ -1682,11 +1659,57 @@ Tcl_GetString( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) +char * +TclGetStringFromObj( + Tcl_Obj *objPtr, /* Object whose string rep byte pointer should + * be returned. */ + void *lengthPtr) /* If non-NULL, the location where the string + * rep's byte array length should * be stored. + * If NULL, no length is stored. */ +{ + if (objPtr->bytes == NULL) { + /* + * Note we do not check for objPtr->typePtr == NULL. An invariant + * of a properly maintained Tcl_Obj is that at least one of + * objPtr->bytes and objPtr->typePtr must not be NULL. If broken + * extensions fail to maintain that invariant, we can crash here. + */ + + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an + * updateStringProc must be written in such a way that + * (objPtr->bytes) never becomes NULL. + */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } + } + if (lengthPtr != NULL) { + if (objPtr->length > INT_MAX) { + Tcl_Panic("Tcl_GetStringFromObj with 'int' lengthPtr" + " cannot handle such long strings. Please use 'Tcl_Size'"); + } + *(int *)lengthPtr = (int)objPtr->length; + } + return objPtr->bytes; +} +#endif /* !defined(TCL_NO_DEPRECATED) */ + +#undef Tcl_GetStringFromObj char * Tcl_GetStringFromObj( Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - int *lengthPtr) /* If non-NULL, the location where the string + Tcl_Size *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { @@ -1708,7 +1731,7 @@ Tcl_GetStringFromObj( objPtr->typePtr->name); } objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length < 0 + if (objPtr->bytes == NULL || objPtr->bytes[objPtr->length] != '\0') { Tcl_Panic("UpdateStringProc for type '%s' " "failed to create a valid string rep", @@ -1720,6 +1743,7 @@ Tcl_GetStringFromObj( } return objPtr->bytes; } + /* *---------------------------------------------------------------------- @@ -1730,15 +1754,15 @@ Tcl_GetStringFromObj( * the tools needed to set an object's string representation. The * function is determined by the arguments. * - * (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0) + * (objPtr->bytes != NULL && bytes != NULL) || (numBytes == -1) * Invalid call -- panic! * - * objPtr->bytes == NULL && bytes == NULL && numBytes >= 0 + * objPtr->bytes == NULL && bytes == NULL && numBytes != -1 * Allocation only - allocate space for (numBytes+1) chars. * store in objPtr->bytes and return. Also sets * objPtr->length to 0 and objPtr->bytes[0] to NUL. * - * objPtr->bytes == NULL && bytes != NULL && numBytes >= 0 + * objPtr->bytes == NULL && bytes != NULL && numBytes != -1 * Allocate and copy. bytes is assumed to point to chars to * copy into the string rep. objPtr->length = numBytes. Allocate * array of (numBytes + 1) chars. store in objPtr->bytes. Copy @@ -1747,7 +1771,7 @@ Tcl_GetStringFromObj( * Caller must guarantee there are numBytes chars at bytes to * be copied. * - * objPtr->bytes != NULL && bytes == NULL && numBytes >= 0 + * objPtr->bytes != NULL && bytes == NULL && numBytes != -1 * Truncate. Set objPtr->length to numBytes and * objPr->bytes[numBytes] to NUL. Caller has to guarantee * that a prior allocating call allocated enough bytes for @@ -1769,23 +1793,19 @@ char * Tcl_InitStringRep( Tcl_Obj *objPtr, /* Object whose string rep is to be set */ const char *bytes, - unsigned int numBytes) + size_t numBytes) { assert(objPtr->bytes == NULL || bytes == NULL); - if (numBytes > INT_MAX) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - if (objPtr->bytes == NULL) { /* Start with no string rep */ if (numBytes == 0) { TclInitEmptyStringRep(objPtr); return objPtr->bytes; } else { - objPtr->bytes = (char *)attemptckalloc(numBytes + 1); + objPtr->bytes = (char *)Tcl_AttemptAlloc(numBytes + 1); if (objPtr->bytes) { - objPtr->length = (int) numBytes; + objPtr->length = numBytes; if (bytes) { memcpy(objPtr->bytes, bytes, numBytes); } @@ -1797,23 +1817,23 @@ Tcl_InitStringRep( if (numBytes == 0) { return objPtr->bytes; } else { - objPtr->bytes = (char *)attemptckalloc(numBytes + 1); + objPtr->bytes = (char *)Tcl_AttemptAlloc(numBytes + 1); if (objPtr->bytes) { - objPtr->length = (int) numBytes; + objPtr->length = numBytes; objPtr->bytes[objPtr->length] = '\0'; } } } else { /* Start with non-empty string rep (allocated) */ if (numBytes == 0) { - ckfree(objPtr->bytes); + Tcl_Free(objPtr->bytes); TclInitEmptyStringRep(objPtr); return objPtr->bytes; } else { - objPtr->bytes = (char *)attemptckrealloc(objPtr->bytes, + objPtr->bytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, numBytes + 1); if (objPtr->bytes) { - objPtr->length = (int) numBytes; + objPtr->length = numBytes; objPtr->bytes[objPtr->length] = '\0'; } } @@ -1962,145 +1982,6 @@ Tcl_FreeInternalRep( /* *---------------------------------------------------------------------- * - * Tcl_NewBooleanObj -- - * - * This function is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and - * initializes it from the argument boolean value. A nonzero "intValue" - * is coerced to 1. - * - * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewLongObj. - * - * Results: - * The newly created object is returned. This object will have an invalid - * string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_NewBooleanObj -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_NewBooleanObj( - int intValue) /* Boolean used to initialize new object. */ -{ - return Tcl_DbNewWideIntObj(intValue!=0, "unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewBooleanObj( - int intValue) /* Boolean used to initialize new object. */ -{ - Tcl_Obj *objPtr; - - TclNewIntObj(objPtr, intValue!=0); - return objPtr; -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbNewBooleanObj -- - * - * This function is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the - * same as the Tcl_NewBooleanObj function above except that it calls - * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when - * reporting objects that haven't been freed. - * - * When TCL_MEM_DEBUG is not defined, this function just returns the - * result of calling Tcl_NewBooleanObj. - * - * Results: - * The newly created object is returned. This object will have an invalid - * string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_DbNewBooleanObj -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_DbNewBooleanObj( - int intValue, /* Boolean used to initialize new object. */ - const char *file, /* The name of the source file calling this - * function; used for debugging. */ - int line) /* Line number in the source file; used for - * debugging. */ -{ - Tcl_Obj *objPtr; - - TclDbNewObj(objPtr, file, line); - /* Optimized TclInvalidateStringRep() */ - objPtr->bytes = NULL; - - objPtr->internalRep.wideValue = (intValue != 0); - objPtr->typePtr = &tclIntType; - return objPtr; -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_DbNewBooleanObj( - int intValue, /* Boolean used to initialize new object. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) -{ - return Tcl_NewBooleanObj(intValue); -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetBooleanObj -- - * - * Modify an object to be a boolean object and to have the specified - * boolean value. A nonzero "intValue" is coerced to 1. - * - * Results: - * None. - * - * Side effects: - * The object's old string rep, if any, is freed. Also, any old internal - * rep is freed. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_SetBooleanObj -void -Tcl_SetBooleanObj( - Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - int intValue) /* Boolean used to set object's value. */ -{ - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); - } - - TclSetIntObj(objPtr, intValue!=0); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_GetBoolFromObj, Tcl_GetBooleanFromObj -- * * Attempt to return a boolean from the Tcl object "objPtr". This @@ -2140,14 +2021,10 @@ Tcl_GetBoolFromObj( return TCL_ERROR; } do { - if (objPtr->typePtr == &tclIntType) { + if (objPtr->typePtr == &tclIntType || objPtr->typePtr == &tclBooleanType) { result = (objPtr->internalRep.wideValue != 0); goto boolEnd; } - if (objPtr->typePtr == &tclBooleanType) { - result = objPtr->internalRep.longValue != 0; - goto boolEnd; - } if (objPtr->typePtr == &tclDoubleType) { /* * Caution: Don't be tempted to check directly for the "double" @@ -2216,12 +2093,7 @@ Tcl_GetBooleanFromObj( * * Side effects: * If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal - * representation and the type of "objPtr" is set to boolean or int/wideInt. - * - * Warning: If the returned type is "wideInt" (32-bit platforms) and your - * platform is bigendian, you cannot use internalRep.longValue to distinguish - * between false and true. On Windows and most other platforms this still will - * work fine, but basically it is non-portable. + * representation and the type of "objPtr" is set to boolean or int. * *---------------------------------------------------------------------- */ @@ -2379,7 +2251,7 @@ ParseBoolean( goodBoolean: TclFreeInternalRep(objPtr); - objPtr->internalRep.longValue = newBool; + objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; @@ -2614,8 +2486,7 @@ SetDoubleFromAny( * UpdateStringOfDouble -- * * Update the string representation for a double-precision floating point - * object. This must obey the current tcl_precision value for - * double-to-string conversions. Note: This function does not free an + * object. Note: This function does not free an * existing old string rep so storage will be lost if this has not * already been done. * @@ -2635,7 +2506,7 @@ UpdateStringOfDouble( { char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE); - TclOOM(dst, TCL_DOUBLE_SPACE + 1); + TclOOM(dst, (size_t)TCL_DOUBLE_SPACE + 1); Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst); (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); @@ -2644,112 +2515,28 @@ UpdateStringOfDouble( /* *---------------------------------------------------------------------- * - * Tcl_NewIntObj -- - * - * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewIntObj to create a new integer object end up calling the - * debugging function Tcl_DbNewLongObj instead. - * - * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, - * calls to Tcl_NewIntObj result in a call to one of the two - * Tcl_NewIntObj implementations below. We provide two implementations so - * that the Tcl core can be compiled to do memory debugging of the core - * even if a client does not request it for itself. - * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by an - * int. - * - * Results: - * The newly created object is returned. This object will have an invalid - * string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_NewIntObj -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_NewIntObj( - int intValue) /* Int used to initialize the new object. */ -{ - return Tcl_DbNewWideIntObj(intValue, "unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewIntObj( - int intValue) /* Int used to initialize the new object. */ -{ - Tcl_Obj *objPtr; - - TclNewIntObj(objPtr, intValue); - return objPtr; -} -#endif /* if TCL_MEM_DEBUG */ -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetIntObj -- - * - * Modify an object to be an integer and to have the specified integer - * value. + * Tcl_GetIntFromObj -- * - * Results: - * None. + * Retrieve the integer value of 'objPtr'. * - * Side effects: - * The object's old string rep, if any, is freed. Also, any old internal - * rep is freed. + * Value * - *---------------------------------------------------------------------- - */ -#ifndef TCL_NO_DEPRECATED -#undef Tcl_SetIntObj -void -Tcl_SetIntObj( - Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - int intValue) /* Integer used to set object's value. */ -{ - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); - } - - TclSetIntObj(objPtr, intValue); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- + * TCL_OK * - * Tcl_GetIntFromObj -- + * Success. * - * Attempt to return an int from the Tcl object "objPtr". If the object - * is not already an int, an attempt will be made to convert it to one. + * TCL_ERROR * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by an - * int. + * An error occurred during conversion or the integral value can not + * be represented as an integer (it might be too large). An error + * message is left in the interpreter's result if 'interp' is not + * NULL. * - * Results: - * The return value is a standard Tcl object result. If an error occurs - * during conversion or if the long integer held by the object can not be - * represented by an int, an error message is left in the interpreter's - * result unless "interp" is NULL. + * Effect * - * Side effects: - * If the object is not already an int, the conversion will free any old - * internal representation. + * 'objPtr' is converted to an integer if necessary if it is not one + * already. The conversion frees any previously-existing internal + * representation. * *---------------------------------------------------------------------- */ @@ -2805,7 +2592,7 @@ SetIntFromAny( Tcl_Obj *objPtr) /* Pointer to the object to convert */ { Tcl_WideInt w; - return Tcl_GetWideIntFromObj(interp, objPtr, &w); + return TclGetWideIntFromObj(interp, objPtr, &w); } /* @@ -2833,184 +2620,10 @@ UpdateStringOfInt( { char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); - TclOOM(dst, TCL_INTEGER_SPACE + 1); + TclOOM(dst, (size_t)TCL_INTEGER_SPACE + 1); (void) Tcl_InitStringRep(objPtr, NULL, TclFormatInt(dst, objPtr->internalRep.wideValue)); } - -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) -static void -UpdateStringOfOldInt( - Tcl_Obj *objPtr) /* Int object whose string rep to update. */ -{ - char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); - - TclOOM(dst, TCL_INTEGER_SPACE + 1); - (void) Tcl_InitStringRep(objPtr, NULL, - TclFormatInt(dst, objPtr->internalRep.longValue)); -} -#endif - -/* - *---------------------------------------------------------------------- - * - * Tcl_NewLongObj -- - * - * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewLongObj to create a new long integer object end up calling the - * debugging function Tcl_DbNewLongObj instead. - * - * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, - * calls to Tcl_NewLongObj result in a call to one of the two - * Tcl_NewLongObj implementations below. We provide two implementations - * so that the Tcl core can be compiled to do memory debugging of the - * core even if a client does not request it for itself. - * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by an - * int. - * - * Results: - * The newly created object is returned. This object will have an invalid - * string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_NewLongObj -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_NewLongObj( - long longValue) /* Long integer used to initialize the - * new object. */ -{ - return Tcl_DbNewWideIntObj(longValue, "unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewLongObj( - long longValue) /* Long integer used to initialize the - * new object. */ -{ - Tcl_Obj *objPtr; - - TclNewIntObj(objPtr, longValue); - return objPtr; -} -#endif /* if TCL_MEM_DEBUG */ -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbNewLongObj -- - * - * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer - * objects end up calling the debugging function Tcl_DbNewLongObj - * instead. We provide two implementations of Tcl_DbNewLongObj so that - * whether the Tcl core is compiled to do memory debugging of the core is - * independent of whether a client requests debugging for itself. - * - * When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj - * calls Tcl_DbCkalloc directly with the file name and line number from - * its caller. This simplifies debugging since then the [memory active] - * command will report the caller's file name and line number when - * reporting objects that haven't been freed. - * - * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, - * this function just returns the result of calling Tcl_NewLongObj. - * - * Results: - * The newly created long integer object is returned. This object will - * have an invalid string representation. The returned object has ref - * count 0. - * - * Side effects: - * Allocates memory. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_DbNewLongObj -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_DbNewLongObj( - long longValue, /* Long integer used to initialize the new - * object. */ - const char *file, /* The name of the source file calling this - * function; used for debugging. */ - int line) /* Line number in the source file; used for - * debugging. */ -{ - Tcl_Obj *objPtr; - - TclDbNewObj(objPtr, file, line); - /* Optimized TclInvalidateStringRep */ - objPtr->bytes = NULL; - - objPtr->internalRep.wideValue = longValue; - objPtr->typePtr = &tclIntType; - return objPtr; -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_DbNewLongObj( - long longValue, /* Long integer used to initialize the new - * object. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) -{ - return Tcl_NewWideIntObj(longValue); -} -#endif /* TCL_MEM_DEBUG */ -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetLongObj -- - * - * Modify an object to be an integer object and to have the specified - * long integer value. - * - * Results: - * None. - * - * Side effects: - * The object's old string rep, if any, is freed. Also, any old internal - * rep is freed. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_SetLongObj -void -Tcl_SetLongObj( - Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - long longValue) /* Long integer used to initialize the - * object's value. */ -{ - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); - } - - TclSetIntObj(objPtr, longValue); -} -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -3515,6 +3128,40 @@ TclGetWideBitsFromObj( /* *---------------------------------------------------------------------- * + * Tcl_GetSizeIntFromObj -- + * + * Attempt to return a Tcl_Size from the Tcl object "objPtr". + * + * Results: + * TCL_OK - the converted Tcl_Size value is stored in *sizePtr + * TCL_ERROR - the error message is stored in interp + * + * Side effects: + * The function may free up any existing internal representation. + * + *---------------------------------------------------------------------- + */ +int +Tcl_GetSizeIntFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object from which to get a int. */ + Tcl_Size *sizePtr) /* Place to store resulting int. */ +{ + if (sizeof(Tcl_Size) == sizeof(int)) { + return TclGetIntFromObj(interp, objPtr, (int *)sizePtr); + } else { + Tcl_WideInt wide; + if (TclGetWideIntFromObj(interp, objPtr, &wide) != TCL_OK) { + return TCL_ERROR; + } + *sizePtr = (Tcl_Size)wide; + return TCL_OK; + } +} + +/* + *---------------------------------------------------------------------- + * * FreeBignum -- * * This function frees the internal rep of a bignum. @@ -3534,7 +3181,7 @@ FreeBignum( TclUnpackBignum(objPtr, toFree); mp_clear(&toFree); if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) { - ckfree(objPtr->internalRep.twoPtrValue.ptr1); + Tcl_Free(objPtr->internalRep.twoPtrValue.ptr1); } objPtr->typePtr = NULL; } @@ -4001,7 +3648,7 @@ int Tcl_GetNumber( Tcl_Interp *interp, const char *bytes, - int numBytes, + Tcl_Size numBytes, void **clientDataPtr, int *typePtr) { @@ -4016,7 +3663,15 @@ Tcl_GetNumber( numBytes = 0; } if (numBytes < 0) { - numBytes = (int)strlen(bytes); + numBytes = strlen(bytes); + } + 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", (void *)NULL); + } + return TCL_ERROR; } objPtr->bytes = (char *) bytes; @@ -4072,6 +3727,28 @@ Tcl_DecrRefCount( /* *---------------------------------------------------------------------- * + * TclUndoRefCount -- + * + * Decrement the refCount of objPtr without causing it to be freed if it + * drops from 1 to 0. This allows a function increment a refCount but + * then decrement it and still be able to pass return it to a caller, + * possibly with a refCount of 0. The caller must have previously + * incremented the refCount. + * + *---------------------------------------------------------------------- + */ +void +TclUndoRefCount( + Tcl_Obj *objPtr) /* The object we are releasing a reference to. */ +{ + if (objPtr->refCount > 0) { + --objPtr->refCount; + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_IsShared -- * * Tests if the object has a ref count greater than one. @@ -4121,7 +3798,7 @@ Tcl_DbIncrRefCount( int line) /* Line number in the source file; used for * debugging. */ { - if (objPtr->refCount == 0x61616161) { + if (objPtr->refCount == FREEDREFCOUNTFILLER) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("incrementing refCount of previously disposed object"); @@ -4194,7 +3871,7 @@ Tcl_DbDecrRefCount( int line) /* Line number in the source file; used for * debugging. */ { - if (objPtr->refCount == 0x61616161) { + if (objPtr->refCount == FREEDREFCOUNTFILLER) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("decrementing refCount of previously disposed object"); @@ -4276,7 +3953,7 @@ Tcl_DbIsShared( #endif { #ifdef TCL_MEM_DEBUG - if (objPtr->refCount == 0x61616161) { + if (objPtr->refCount == FREEDREFCOUNTFILLER) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("checking whether previously disposed object is shared"); @@ -4371,7 +4048,7 @@ AllocObjEntry( void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; - Tcl_HashEntry *hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry)); + Tcl_HashEntry *hPtr = (Tcl_HashEntry *)Tcl_Alloc(sizeof(Tcl_HashEntry)); hPtr->key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); @@ -4465,7 +4142,7 @@ TclFreeObjEntry( Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; Tcl_DecrRefCount(objPtr); - ckfree(hPtr); + Tcl_Free(hPtr); } /* @@ -4486,7 +4163,7 @@ TclFreeObjEntry( *---------------------------------------------------------------------- */ -TCL_HASH_TYPE +size_t TclHashObjKey( TCL_UNUSED(Tcl_HashTable *), void *keyPtr) /* Key from which to compute hash value. */ @@ -4494,7 +4171,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 @@ -4655,7 +4332,7 @@ SetCmdNameObj( if (resPtr) { fillPtr = resPtr; } else { - fillPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName)); + fillPtr = (ResolvedCmdName *)Tcl_Alloc(sizeof(ResolvedCmdName)); fillPtr->refCount = 1; } @@ -4758,7 +4435,7 @@ FreeCmdNameInternalRep( Command *cmdPtr = resPtr->cmdPtr; TclCleanupCommandMacro(cmdPtr); - ckfree(resPtr); + Tcl_Free(resPtr); } objPtr->typePtr = NULL; } @@ -4907,7 +4584,7 @@ Tcl_RepresentationCmd( * "1872361827361287" */ - descObj = Tcl_ObjPrintf("value is a %s with a refcount of %" TCL_SIZE_MODIFIER "d," + descObj = Tcl_ObjPrintf("value is a %s with a refcount of %" TCL_Z_MODIFIER "u," " object pointer at %p", objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", objv[1]->refCount, objv[1]); diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index de28b0c..7a4a962 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -28,7 +28,7 @@ static void TrimUnreachable(CompileEnv *envPtr); */ #define DefineTargetAddress(tablePtr, address) \ - ((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew)) + ((void) Tcl_CreateHashEntry((tablePtr), (address), &isNew)) #define IsTargetAddress(tablePtr, address) \ (Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL) #define AddrLength(address) \ @@ -54,7 +54,8 @@ LocateTargetAddresses( Tcl_HashTable *tablePtr) { unsigned char *currentInstPtr, *targetInstPtr; - int isNew, i; + int isNew; + Tcl_Size i; Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; @@ -133,7 +134,7 @@ LocateTargetAddresses( } else { targetInstPtr = envPtr->codeStart + rangePtr->breakOffset; DefineTargetAddress(tablePtr, targetInstPtr); - if (rangePtr->continueOffset >= 0) { + if (rangePtr->continueOffset != TCL_INDEX_NONE) { targetInstPtr = envPtr->codeStart + rangePtr->continueOffset; DefineTargetAddress(tablePtr, targetInstPtr); } @@ -231,9 +232,9 @@ ConvertZeroEffectToNOP( && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt1AtPtr(currentInstPtr + 1)); - int numBytes; + Tcl_Size numBytes; - (void) TclGetStringFromObj(litPtr, &numBytes); + (void) Tcl_GetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } @@ -246,9 +247,9 @@ ConvertZeroEffectToNOP( && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt4AtPtr(currentInstPtr + 1)); - int numBytes; + Tcl_Size numBytes; - (void) TclGetStringFromObj(litPtr, &numBytes); + (void) Tcl_GetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } @@ -287,8 +288,6 @@ ConvertZeroEffectToNOP( case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: - case INST_LOR: - case INST_LAND: case INST_EQ: case INST_NEQ: case INST_LT: diff --git a/generic/tclPanic.c b/generic/tclPanic.c index 1f5ef27..5a05c24 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -15,7 +15,7 @@ #include "tclInt.h" #if defined(_WIN32) || defined(__CYGWIN__) - MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...); + MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); #endif /* @@ -23,11 +23,7 @@ * procedure. */ -#if defined(__CYGWIN__) || (defined(_WIN32) && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8)) -static TCL_NORETURN1 Tcl_PanicProc *panicProc = tclWinDebugPanic; -#else static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; -#endif /* *---------------------------------------------------------------------- @@ -45,19 +41,10 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; *---------------------------------------------------------------------- */ -#undef Tcl_SetPanicProc const char * Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *proc) { -#if defined(_WIN32) - /* tclWinDebugPanic only installs if there is no panicProc yet. */ - if (((Tcl_PanicProc *)proc != tclWinDebugPanic) || (panicProc == NULL)) -#elif defined(__CYGWIN__) - if (proc == NULL) - panicProc = tclWinDebugPanic; - else -#endif panicProc = proc; return Tcl_InitSubsystems(); } @@ -65,7 +52,7 @@ Tcl_SetPanicProc( /* *---------------------------------------------------------------------- * - * Tcl_PanicVA -- + * Tcl_Panic -- * * Print an error message and kill the process. * @@ -78,16 +65,24 @@ Tcl_SetPanicProc( *---------------------------------------------------------------------- */ +/* + * The following comment is here so that Coverity's static analyzer knows that + * a Tcl_Panic() call can never return and avoids lots of false positives. + */ + +/* coverity[+kill] */ void -Tcl_PanicVA( - const char *format, /* Format string, suitable for passing to - * fprintf. */ - va_list argList) /* Variable argument list. */ +Tcl_Panic( + const char *format, + ...) { + va_list argList; char *arg1, *arg2, *arg3; /* Additional arguments (variable in number) * to pass to fprintf. */ char *arg4, *arg5, *arg6, *arg7, *arg8; + + va_start(argList, format); arg1 = va_arg(argList, char *); arg2 = va_arg(argList, char *); arg3 = va_arg(argList, char *); @@ -96,29 +91,28 @@ Tcl_PanicVA( arg6 = va_arg(argList, char *); arg7 = va_arg(argList, char *); arg8 = va_arg(argList, char *); + va_end (argList); if (panicProc != NULL) { panicProc(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); -#ifdef _WIN32 - } else if (IsDebuggerPresent()) { - tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); -#endif } else { +#if defined(_WIN32) || defined(__CYGWIN__) + tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +#else fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); fprintf(stderr, "\n"); fflush(stderr); -#if defined(_WIN32) || defined(__CYGWIN__) +#endif # if defined(__GNUC__) __builtin_trap(); # elif defined(_WIN64) __debugbreak(); # elif defined(_MSC_VER) && defined (_M_IX86) _asm {int 3} -# else +# elif defined(_WIN32) DebugBreak(); # endif -#endif #if defined(_WIN32) ExitProcess(1); #else @@ -128,40 +122,6 @@ Tcl_PanicVA( } /* - *---------------------------------------------------------------------- - * - * Tcl_Panic -- - * - * Print an error message and kill the process. - * - * Results: - * None. - * - * Side effects: - * The process dies, entering the debugger if possible. - * - *---------------------------------------------------------------------- - */ - -/* - * The following comment is here so that Coverity's static analyzer knows that - * a Tcl_Panic() call can never return and avoids lots of false positives. - */ - -/* coverity[+kill] */ -void -Tcl_Panic( - const char *format, - ...) -{ - va_list argList; - - va_start(argList, format); - Tcl_PanicVA(format, argList); - va_end (argList); -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclParse.c b/generic/tclParse.c index aab69f3..6417514 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -33,12 +33,13 @@ * meaning in ParseTokens: backslash, dollar sign, or * open bracket. * TYPE_QUOTE - Character is a double quote. + * TYPE_OPEN_PAREN - Character is a left parenthesis. * TYPE_CLOSE_PAREN - Character is a right parenthesis. * TYPE_CLOSE_BRACK - Character is a right square bracket. * TYPE_BRACE - Character is a curly brace (either left or right). */ -const char tclCharTypeTable[] = { +const unsigned char tclCharTypeTable[] = { /* * Positive character values, from 0-127: @@ -54,7 +55,7 @@ const char tclCharTypeTable[] = { TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_SPACE, TYPE_NORMAL, TYPE_QUOTE, TYPE_NORMAL, TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_CLOSE_PAREN, TYPE_NORMAL, TYPE_NORMAL, + TYPE_OPEN_PAREN, TYPE_CLOSE_PAREN, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, @@ -119,16 +120,16 @@ const char tclCharTypeTable[] = { * Prototypes for local functions defined in this file: */ -static int CommandComplete(const char *script, int numBytes); -static int ParseComment(const char *src, int numBytes, +static int CommandComplete(const char *script, Tcl_Size numBytes); +static Tcl_Size ParseComment(const char *src, Tcl_Size numBytes, Tcl_Parse *parsePtr); -static int ParseTokens(const char *src, int numBytes, int mask, +static int ParseTokens(const char *src, Tcl_Size numBytes, int mask, int flags, Tcl_Parse *parsePtr); -static int ParseWhiteSpace(const char *src, int numBytes, +static Tcl_Size ParseWhiteSpace(const char *src, Tcl_Size numBytes, int *incompletePtr, char *typePtr); -static int ParseAllWhiteSpace(const char *src, int numBytes, +static Tcl_Size ParseAllWhiteSpace(const char *src, Tcl_Size numBytes, int *incompletePtr); -static int ParseHex(const char *src, int numBytes, +static int ParseHex(const char *src, Tcl_Size numBytes, int *resultPtr); /* @@ -151,7 +152,7 @@ void TclParseInit( Tcl_Interp *interp, /* Interpreter to use for error reporting */ const char *start, /* Start of string to be parsed. */ - int numBytes, /* Total number of bytes in string. If < 0, + Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the script consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr) /* Points to struct to initialize */ @@ -197,7 +198,7 @@ Tcl_ParseCommand( * NULL, then no error message is provided. */ const char *start, /* First character of string containing one or * more Tcl commands. */ - int numBytes, /* Total number of bytes in string. If < 0, + Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the script consists of all bytes up to the * first null character. */ int nested, /* Non-zero means this is a nested command: @@ -209,16 +210,16 @@ Tcl_ParseCommand( * the parsed command; any previous * information in the structure is ignored. */ { - const char *src; /* Points to current character in the + const char *src; /* Points to current character in the * command. */ char type; /* Result returned by CHAR_TYPE(*src). */ Tcl_Token *tokenPtr; /* Pointer to token being filled in. */ - int wordIndex; /* Index of word token for current word. */ + Tcl_Size wordIndex; /* Index of word token for current word. */ int terminators; /* CHAR_TYPE bits that indicate the end of a * command. */ const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to * point to char after terminating one. */ - int scanned; + Tcl_Size scanned; if (numBytes < 0 && start) { numBytes = strlen(start); @@ -326,7 +327,7 @@ Tcl_ParseCommand( src = termPtr; numBytes = parsePtr->end - src; } else if (*src == '{') { - int expIdx = wordIndex + 1; + Tcl_Size expIdx = wordIndex + 1; Tcl_Token *expPtr; if (Tcl_ParseBraces(interp, src, numBytes, parsePtr, 1, @@ -344,9 +345,9 @@ Tcl_ParseCommand( expPtr = &parsePtr->tokenPtr[expIdx]; if ((0 == expandWord) /* Haven't seen prefix already */ - && (1 == parsePtr->numTokens - expIdx) + && (expIdx + 1 == parsePtr->numTokens) /* Only one token */ - && (((1 == (size_t) expPtr->size) + && (((1 == expPtr->size) /* Same length as prefix */ && (expPtr->start[0] == '*'))) /* Is the prefix */ @@ -381,7 +382,8 @@ Tcl_ParseCommand( tokenPtr->size = src - tokenPtr->start; tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1); if (expandWord) { - int i, isLiteral = 1; + Tcl_Size i; + int isLiteral = 1; /* * When a command includes a word that is an expanded literal; for @@ -405,7 +407,8 @@ Tcl_ParseCommand( } if (isLiteral) { - int elemCount = 0, code = TCL_OK, literal = 1; + Tcl_Size elemCount = 0; + int code = TCL_OK, literal = 1; const char *nextElem, *listEnd, *elemStart; /* @@ -427,7 +430,7 @@ Tcl_ParseCommand( */ while (nextElem < listEnd) { - int size; + Tcl_Size size; code = TclFindElement(NULL, nextElem, listEnd - nextElem, &elemStart, &nextElem, &size, &literal); @@ -469,7 +472,7 @@ Tcl_ParseCommand( */ const char *listStart; - int growthNeeded = wordIndex + 2*elemCount + Tcl_Size growthNeeded = wordIndex + 2*elemCount - parsePtr->numTokens; parsePtr->numWords += elemCount - 1; @@ -619,10 +622,10 @@ TclIsBareword( *---------------------------------------------------------------------- */ -static int +static Tcl_Size ParseWhiteSpace( const char *src, /* First character to parse. */ - int numBytes, /* Max number of bytes to scan. */ + Tcl_Size numBytes, /* Max number of bytes to scan. */ int *incompletePtr, /* Set this boolean memory to true if parsing * indicates an incomplete command. */ char *typePtr) /* Points to location to store character type @@ -673,17 +676,17 @@ ParseWhiteSpace( *---------------------------------------------------------------------- */ -static int +static Tcl_Size ParseAllWhiteSpace( const char *src, /* First character to parse. */ - int numBytes, /* Max number of byes to scan */ + Tcl_Size numBytes, /* Max number of byes to scan */ int *incompletePtr) /* Set true if parse is incomplete. */ { char type; const char *p = src; do { - int scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type); + Tcl_Size scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type); p += scanned; numBytes -= scanned; @@ -691,10 +694,10 @@ ParseAllWhiteSpace( return (p-src); } -int +Tcl_Size TclParseAllWhiteSpace( const char *src, /* First character to parse. */ - int numBytes) /* Max number of byes to scan */ + Tcl_Size numBytes) /* Max number of byes to scan */ { int dummy; return ParseAllWhiteSpace(src, numBytes, &dummy); @@ -725,8 +728,8 @@ TclParseAllWhiteSpace( int ParseHex( const char *src, /* First character to parse. */ - int numBytes, /* Max number of byes to scan */ - int *resultPtr) /* Points to storage provided by caller where + Tcl_Size numBytes, /* Max number of byes to scan */ + int *resultPtr) /* Points to storage provided by caller where * the character resulting from the * conversion is to be written. */ { @@ -781,8 +784,8 @@ int TclParseBackslash( const char *src, /* Points to the backslash character of a * backslash sequence. */ - int numBytes, /* Max number of bytes to scan. */ - int *readPtr, /* NULL, or points to storage where the number + Tcl_Size numBytes, /* Max number of bytes to scan. */ + Tcl_Size *readPtr, /* NULL, or points to storage where the number * of bytes scanned should be written. */ char *dst) /* NULL, or points to buffer where the UTF-8 * encoding of the backslash sequence is to be @@ -791,7 +794,7 @@ TclParseBackslash( const char *p = src+1; int unichar; int result; - int count; + Tcl_Size count; char buf[4] = ""; if (numBytes == 0) { @@ -868,16 +871,6 @@ TclParseBackslash( * No hexdigits -> This is just "u". */ result = 'u'; - } else if (((result & 0xFC00) == 0xD800) && (count == 6) - && (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) { - /* If high surrogate is immediately followed by a low surrogate - * escape, combine them into one character. */ - int low; - int count2 = ParseHex(p+7, 4, &low); - if ((count2 == 4) && ((low & 0xFC00) == 0xDC00)) { - result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000; - count += count2 + 2; - } } break; case 'U': @@ -887,9 +880,6 @@ TclParseBackslash( * No hexdigits -> This is just "U". */ result = 'U'; - } else if ((result | 0x7FF) == 0xDFFF) { - /* Upper or lower surrogate, not allowed in this syntax. */ - result = 0xFFFD; } break; case '\n': @@ -953,10 +943,6 @@ TclParseBackslash( *readPtr = count; } count = Tcl_UniCharToUtf(result, dst); - if ((result >= 0xD800) && (count < 3)) { - /* Special case for handling high surrogates. */ - count += Tcl_UniCharToUtf(-1, dst + count); - } return count; } @@ -978,10 +964,10 @@ TclParseBackslash( *---------------------------------------------------------------------- */ -static int +static Tcl_Size ParseComment( const char *src, /* First character to parse. */ - int numBytes, /* Max number of bytes to scan. */ + Tcl_Size numBytes, /* Max number of bytes to scan. */ Tcl_Parse *parsePtr) /* Information about parse in progress. * Updated if parsing indicates an incomplete * command. */ @@ -990,7 +976,7 @@ ParseComment( int incomplete = parsePtr->incomplete; while (numBytes) { - int scanned = ParseAllWhiteSpace(p, numBytes, &incomplete); + Tcl_Size scanned = ParseAllWhiteSpace(p, numBytes, &incomplete); p += scanned; numBytes -= scanned; @@ -1054,7 +1040,7 @@ ParseComment( static int ParseTokens( const char *src, /* First character to parse. */ - int numBytes, /* Max number of bytes to scan. */ + Tcl_Size numBytes, /* Max number of bytes to scan. */ int mask, /* Specifies when to stop parsing. The parse * stops at the first unquoted character whose * CHAR_TYPE contains any of the bits in @@ -1068,7 +1054,7 @@ ParseTokens( * termination information. */ { char type; - int originalTokens; + Tcl_Size originalTokens; int noSubstCmds = !(flags & TCL_SUBST_COMMANDS); int noSubstVars = !(flags & TCL_SUBST_VARIABLES); int noSubstBS = !(flags & TCL_SUBST_BACKSLASHES); @@ -1102,7 +1088,7 @@ ParseTokens( tokenPtr->size = src - tokenPtr->start; parsePtr->numTokens++; } else if (*src == '$') { - int varToken; + Tcl_Size varToken; if (noSubstVars) { tokenPtr->type = TCL_TOKEN_TEXT; @@ -1294,7 +1280,7 @@ Tcl_FreeParse( * call to Tcl_ParseCommand. */ { if (parsePtr->tokenPtr != parsePtr->staticTokens) { - ckfree(parsePtr->tokenPtr); + Tcl_Free(parsePtr->tokenPtr); parsePtr->tokenPtr = parsePtr->staticTokens; } } @@ -1332,7 +1318,7 @@ Tcl_ParseVarName( * NULL, then no error message is provided. */ const char *start, /* Start of variable substitution string. * First character must be "$". */ - int numBytes, /* Total number of bytes in string. If < 0, + Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr, /* Structure to fill in with information about @@ -1396,15 +1382,28 @@ Tcl_ParseVarName( */ if (*src == '{') { + char ch; int braceCount = 0; src++; numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; - while (numBytes && (*src != '}')) { + ch = *src; + while (numBytes && (braceCount>0 || ch != '}')) { + switch (ch) { + case '{': braceCount++; break; + case '}': braceCount--; break; + case '\\': + /* if 2 or more left, consume 2, else consume + just the \ and let it run into the end */ + if (numBytes > 1) { + src++; numBytes--; + } + } numBytes--; src++; + ch= *src; } if (numBytes == 0) { if (parsePtr->interp != NULL) { @@ -1460,11 +1459,11 @@ Tcl_ParseVarName( * any number of substitutions. */ - if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, + if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_BAD_ARRAY_INDEX, TCL_SUBST_ALL, parsePtr)) { goto error; } - if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){ + if (parsePtr->term == src+numBytes){ if (parsePtr->interp != NULL) { Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( "missing )", -1)); @@ -1473,6 +1472,14 @@ Tcl_ParseVarName( parsePtr->term = src; parsePtr->incomplete = 1; goto error; + } else if ((*parsePtr->term != ')')){ + if (parsePtr->interp != NULL) { + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "invalid character in array index", -1)); + } + parsePtr->errorType = TCL_PARSE_SYNTAX; + parsePtr->term = src; + goto error; } src = parsePtr->term + 1; } @@ -1534,7 +1541,7 @@ Tcl_ParseVar( int code; Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse)); - if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) { + if (Tcl_ParseVarName(interp, start, TCL_INDEX_NONE, parsePtr, 0) != TCL_OK) { TclStackFree(interp, parsePtr); return NULL; } @@ -1609,7 +1616,7 @@ Tcl_ParseBraces( * NULL, then no error message is provided. */ const char *start, /* Start of string enclosed in braces. The * first character must be {'. */ - int numBytes, /* Total number of bytes in string. If < 0, + Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr, @@ -1626,7 +1633,7 @@ Tcl_ParseBraces( { Tcl_Token *tokenPtr; const char *src; - int startIndex, level, length; + Tcl_Size length, startIndex, level; if (numBytes < 0 && start) { numBytes = strlen(start); @@ -1810,7 +1817,7 @@ Tcl_ParseQuotedString( * NULL, then no error message is provided. */ const char *start, /* Start of the quoted string. The first * character must be '"'. */ - int numBytes, /* Total number of bytes in string. If < 0, + Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr, @@ -1891,12 +1898,12 @@ void TclSubstParse( Tcl_Interp *interp, const char *bytes, - int numBytes, + Tcl_Size numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr) { - int length = numBytes; + Tcl_Size length = numBytes; const char *p = bytes; TclParseInit(interp, p, length, parsePtr); @@ -2090,13 +2097,13 @@ TclSubstTokens( * errors. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * evaluate and concatenate. */ - int count, /* Number of tokens to consider at tokenPtr. + Tcl_Size count, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ int *tokensLeftPtr, /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ - int line, /* The line the script starts on. */ - int *clNextOuter, /* Information about an outer context for */ + Tcl_Size line, /* The line the script starts on. */ + Tcl_Size *clNextOuter, /* Information about an outer context for */ const char *outerScript) /* continuation line data. This is set by * EvalEx() to properly handle [...]-nested * commands. The 'outerScript' refers to the @@ -2117,8 +2124,9 @@ TclSubstTokens( Tcl_Obj *result; int code = TCL_OK; #define NUM_STATIC_POS 20 - int isLiteral, maxNumCL, numCL, i, adjust; - int *clPosition = NULL; + int isLiteral; + Tcl_Size i, maxNumCL, numCL, adjust; + Tcl_Size *clPosition = NULL; Interp *iPtr = (Interp *) interp; int inFile = iPtr->evalFlags & TCL_EVAL_FILE; @@ -2153,7 +2161,7 @@ TclSubstTokens( if (isLiteral) { maxNumCL = NUM_STATIC_POS; - clPosition = (int *)ckalloc(maxNumCL * sizeof(int)); + clPosition = (Tcl_Size *)Tcl_Alloc(maxNumCL * sizeof(Tcl_Size)); } adjust = 0; @@ -2193,18 +2201,18 @@ TclSubstTokens( if ((appendByteLength == 1) && (utfCharBytes[0] == ' ') && (tokenPtr->start[1] == '\n')) { if (isLiteral) { - int clPos; + Tcl_Size clPos; if (result == 0) { clPos = 0; } else { - TclGetStringFromObj(result, &clPos); + (void)Tcl_GetStringFromObj(result, &clPos); } if (numCL >= maxNumCL) { maxNumCL *= 2; - clPosition = (int *)ckrealloc(clPosition, - maxNumCL * sizeof(int)); + clPosition = (Tcl_Size *)Tcl_Realloc(clPosition, + maxNumCL * sizeof(Tcl_Size)); } clPosition[numCL] = clPos; numCL++; @@ -2222,7 +2230,7 @@ TclSubstTokens( * Test cases: info-30.{6,8,9} */ - int theline; + Tcl_Size theline; TclAdvanceContinuations(&line, &clNextOuter, tokenPtr->start - outerScript); @@ -2361,7 +2369,7 @@ TclSubstTokens( */ if (maxNumCL) { - ckfree(clPosition); + Tcl_Free(clPosition); } } else { Tcl_ResetResult(interp); @@ -2399,7 +2407,7 @@ TclSubstTokens( static int CommandComplete( const char *script, /* Script to check. */ - int numBytes) /* Number of bytes in script. */ + Tcl_Size numBytes) /* Number of bytes in script. */ { Tcl_Parse parse; const char *p, *end; @@ -2447,7 +2455,7 @@ int Tcl_CommandComplete( const char *script) /* Script to check. */ { - return CommandComplete(script, (int) strlen(script)); + return CommandComplete(script, strlen(script)); } /* @@ -2473,8 +2481,8 @@ TclObjCommandComplete( Tcl_Obj *objPtr) /* Points to object holding script to * check. */ { - int length; - const char *script = TclGetStringFromObj(objPtr, &length); + Tcl_Size length; + const char *script = Tcl_GetStringFromObj(objPtr, &length); return CommandComplete(script, length); } diff --git a/generic/tclParse.h b/generic/tclParse.h index 5f75c9a..b28ac8c 100644 --- a/generic/tclParse.h +++ b/generic/tclParse.h @@ -11,7 +11,9 @@ #define TYPE_CLOSE_PAREN 0x10 #define TYPE_CLOSE_BRACK 0x20 #define TYPE_BRACE 0x40 +#define TYPE_OPEN_PAREN 0x80 +#define TYPE_BAD_ARRAY_INDEX (TYPE_OPEN_PAREN|TYPE_CLOSE_PAREN|TYPE_QUOTE|TYPE_BRACE) #define CHAR_TYPE(c) tclCharTypeTable[(unsigned char)(c)] -MODULE_SCOPE const char tclCharTypeTable[]; +MODULE_SCOPE const unsigned char tclCharTypeTable[]; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 7282709..fbd7879 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -25,7 +25,7 @@ static void DupFsPathInternalRep(Tcl_Obj *srcPtr, static void FreeFsPathInternalRep(Tcl_Obj *pathPtr); static void UpdateStringOfFsPath(Tcl_Obj *pathPtr); static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr); -static int FindSplitPos(const char *path, int separator); +static Tcl_Size FindSplitPos(const char *path, int separator); static int IsSeparatorOrNull(int ch); static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr); static int MakePathFromNormalized(Tcl_Interp *interp, @@ -44,7 +44,8 @@ static const Tcl_ObjType fsPathType = { FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ UpdateStringOfFsPath, /* updateStringProc */ - SetFsPathFromAny /* setFromAnyProc */ + SetFsPathFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -53,7 +54,7 @@ static const Tcl_ObjType fsPathType = { * Internal representation of a Tcl_Obj of fsPathType */ -typedef struct FsPath { +typedef struct { Tcl_Obj *translatedPathPtr; /* If the path has been normalized (flags == * 0), this is NULL. Otherwise it is a path * in which any ~user sequences have been @@ -67,9 +68,9 @@ typedef struct FsPath { * normPathPtr exists and is absolute. */ int flags; /* Flags to describe interpretation - see * below. */ - ClientData nativePathPtr; /* Native representation of this path, which + void *nativePathPtr; /* Native representation of this path, which * is filesystem dependent. */ - int filesystemEpoch; /* Used to ensure the path representation was + size_t filesystemEpoch; /* Used to ensure the path representation was * generated during the correct filesystem * epoch. The epoch changes when * filesystem-mounts are changed. */ @@ -216,14 +217,14 @@ TclFSNormalizeAbsolutePath( /* * Need to skip '.' in the path. */ - int curLen; + Tcl_Size curLen; if (retVal == NULL) { const char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - TclGetStringFromObj(retVal, &curLen); + (void)Tcl_GetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -236,7 +237,7 @@ TclFSNormalizeAbsolutePath( } if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) { Tcl_Obj *linkObj; - int curLen; + Tcl_Size curLen; char *linkStr; /* @@ -249,7 +250,7 @@ TclFSNormalizeAbsolutePath( retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - TclGetStringFromObj(retVal, &curLen); + (void)Tcl_GetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -284,9 +285,9 @@ TclFSNormalizeAbsolutePath( */ const char *path = - TclGetStringFromObj(retVal, &curLen); + Tcl_GetStringFromObj(retVal, &curLen); - while (--curLen >= 0) { + while (curLen-- > 0) { if (IsSeparatorOrNull(path[curLen])) { break; } @@ -299,7 +300,7 @@ TclFSNormalizeAbsolutePath( Tcl_SetObjLength(retVal, curLen+1); Tcl_AppendObjToObj(retVal, linkObj); TclDecrRefCount(linkObj); - linkStr = TclGetStringFromObj(retVal, &curLen); + linkStr = Tcl_GetStringFromObj(retVal, &curLen); } else { /* * Absolute link. @@ -312,14 +313,14 @@ TclFSNormalizeAbsolutePath( } else { retVal = linkObj; } - linkStr = TclGetStringFromObj(retVal, &curLen); + linkStr = Tcl_GetStringFromObj(retVal, &curLen); /* * Convert to forward-slashes on windows. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { - int i; + Tcl_Size i; for (i = 0; i < curLen; i++) { if (linkStr[i] == '\\') { @@ -329,7 +330,7 @@ TclFSNormalizeAbsolutePath( } } } else { - linkStr = TclGetStringFromObj(retVal, &curLen); + linkStr = Tcl_GetStringFromObj(retVal, &curLen); } /* @@ -402,8 +403,8 @@ TclFSNormalizeAbsolutePath( */ if (zipVolumeLen || (tclPlatform == TCL_PLATFORM_WINDOWS)) { int needTrailingSlash = 0; - int len; - const char *path = TclGetStringFromObj(retVal, &len); + Tcl_Size len; + const char *path = Tcl_GetStringFromObj(retVal, &len); if (zipVolumeLen) { if (len == (zipVolumeLen - 1)) needTrailingSlash = 1; @@ -501,7 +502,7 @@ Tcl_PathType TclFSGetPathType( Tcl_Obj *pathPtr, const Tcl_Filesystem **filesystemPtrPtr, - int *driveNameLengthPtr) + Tcl_Size *driveNameLengthPtr) { FsPath *fsPathPtr; @@ -565,7 +566,7 @@ TclFSGetPathType( Tcl_Obj * TclPathPart( - Tcl_Interp *interp, /* Used for error reporting */ + TCL_UNUSED(Tcl_Interp *), /* Used for error reporting */ Tcl_Obj *pathPtr, /* Path to take dirname of */ Tcl_PathPart portion) /* Requested portion of name */ { @@ -583,9 +584,8 @@ TclPathPart( * the standardPath code. */ - int numBytes; - const char *rest = - TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + Tcl_Size numBytes; + const char *rest = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -621,9 +621,8 @@ TclPathPart( * we don't, and instead just use the standardPath code. */ - int numBytes; - const char *rest = - TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + Tcl_Size numBytes; + const char *rest = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -650,9 +649,9 @@ TclPathPart( return GetExtension(fsPathPtr->normPathPtr); case TCL_PATH_ROOT: { const char *fileName, *extension; - int length; + Tcl_Size length; - fileName = TclGetStringFromObj(fsPathPtr->normPathPtr, + fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { @@ -673,7 +672,7 @@ TclPathPart( Tcl_Obj *resultPtr = TclNewFSPathObj(fsPathPtr->cwdPtr, fileName, - (int)(length - strlen(extension))); + length - strlen(extension)); Tcl_IncrRefCount(resultPtr); return resultPtr; @@ -693,7 +692,7 @@ TclPathPart( goto standardPath; } } else { - int splitElements; + Tcl_Size splitElements; Tcl_Obj *splitPtr, *resultPtr; standardPath: @@ -701,17 +700,17 @@ TclPathPart( if (portion == TCL_PATH_EXTENSION) { return GetExtension(pathPtr); } else if (portion == TCL_PATH_ROOT) { - int length; + Tcl_Size length; const char *fileName, *extension; - fileName = TclGetStringFromObj(pathPtr, &length); + fileName = Tcl_GetStringFromObj(pathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { Tcl_IncrRefCount(pathPtr); return pathPtr; } else { Tcl_Obj *root = Tcl_NewStringObj(fileName, - (int) (length - strlen(extension))); + length - strlen(extension)); Tcl_IncrRefCount(root); return root; @@ -726,18 +725,8 @@ TclPathPart( splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); - if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') { - Tcl_Obj *norm; - TclDecrRefCount(splitPtr); - norm = Tcl_FSGetNormalizedPath(interp, pathPtr); - if (norm == NULL) { - return NULL; - } - splitPtr = Tcl_FSSplitPath(norm, &splitElements); - Tcl_IncrRefCount(splitPtr); - } - if (portion == TCL_PATH_TAIL) { + if (portion == TCL_PATH_TAIL) { /* * Return the last component, unless it is the only component, and * it is the root of an absolute path. @@ -831,10 +820,10 @@ Tcl_Obj * Tcl_FSJoinPath( Tcl_Obj *listObj, /* Path elements to join, may have a zero * reference count. */ - int elements) /* Number of elements to use (-1 = all) */ + Tcl_Size elements) /* Number of elements to use (-1 = all) */ { Tcl_Obj *res; - int objc; + Tcl_Size objc; Tcl_Obj **objv; if (TclListObjLengthM(NULL, listObj, &objc) != TCL_OK) { @@ -849,17 +838,15 @@ Tcl_FSJoinPath( Tcl_Obj * TclJoinPath( - int elements, /* Number of elements to use (-1 = all) */ + Tcl_Size elements, /* Number of elements to use */ Tcl_Obj * const objv[], /* Path elements to join */ int forceRelative) /* If non-zero, assume all more paths are * relative (e.g. simple normalization) */ { Tcl_Obj *res = NULL; - int i; + Tcl_Size i; const Tcl_Filesystem *fsPtr = NULL; - assert ( elements >= 0 ); - if (elements == 0) { TclNewObj(res); return res; @@ -894,9 +881,9 @@ TclJoinPath( TclGetPathType(tailObj, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { const char *str; - int len; + Tcl_Size len; - str = TclGetStringFromObj(tailObj, &len); + str = Tcl_GetStringFromObj(tailObj, &len); if (len == 0) { /* * This happens if we try to handle the root volume '/'. @@ -925,7 +912,7 @@ TclJoinPath( */ if ((tclPlatform != TCL_PLATFORM_WINDOWS) - || (strchr(Tcl_GetString(elt), '\\') == NULL)) { + || (strchr(TclGetString(elt), '\\') == NULL)) { if (PATHFLAGS(elt)) { return TclNewFSPathObj(elt, str, len); @@ -961,13 +948,14 @@ TclJoinPath( assert ( res == NULL ); for (i = 0; i < elements; i++) { - int driveNameLength, strEltLen, length; + Tcl_Size driveNameLength; + Tcl_Size strEltLen, length; Tcl_PathType type; char *strElt, *ptr; Tcl_Obj *driveName = NULL; Tcl_Obj *elt = objv[i]; - strElt = TclGetStringFromObj(elt, &strEltLen); + strElt = Tcl_GetStringFromObj(elt, &strEltLen); driveNameLength = 0; /* if forceRelative - all paths excepting first one are relative */ type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE : @@ -1064,20 +1052,10 @@ TclJoinPath( if (res == NULL) { TclNewObj(res); } - ptr = TclGetStringFromObj(res, &length); - - /* - * Strip off any './' before a tilde, unless this is the beginning of - * the path. - */ - - if (length > 0 && strEltLen > 0 && (strElt[0] == '.') && - (strElt[1] == '/') && (strElt[2] == '~')) { - strElt += 2; - } + ptr = Tcl_GetStringFromObj(res, &length); - /* - * A NULL value for fsPtr at this stage basically means we're trying + /* + * A NULL value for fsPtr at this stage basically means we're trying * to join a relative path onto something which is also relative (or * empty). There's nothing particularly wrong with that. */ @@ -1109,9 +1087,9 @@ TclJoinPath( if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - TclGetStringFromObj(res, &length); + (void)Tcl_GetStringFromObj(res, &length); } - Tcl_SetObjLength(res, length + (int) strlen(strElt)); + Tcl_SetObjLength(res, length + strlen(strElt)); ptr = TclGetString(res) + length; for (; *strElt != '\0'; strElt++) { @@ -1213,7 +1191,7 @@ IsSeparatorOrNull( * of the end of the string. */ -static int +static Tcl_Size FindSplitPos( const char *path, int separator) @@ -1267,14 +1245,17 @@ Tcl_Obj * TclNewFSPathObj( Tcl_Obj *dirPtr, const char *addStrRep, - int len) + Tcl_Size len) { FsPath *fsPathPtr; Tcl_Obj *pathPtr; const char *p; int state = 0, count = 0; - /* [Bug 2806250] - this is only a partial solution of the problem. + /* + * This comment is kept from the days of tilde expansion because + * it is illustrative of a more general problem. + * [Bug 2806250] - this is only a partial solution of the problem. * The PATHFLAGS != 0 representation assumes in many places that * the "tail" part stored in the normPathPtr field is itself a * relative path. Strings that begin with "~" are not relative paths, @@ -1290,16 +1271,9 @@ TclNewFSPathObj( * that by mounting on path prefixes like foo:// which cannot be the * name of a file or directory read from a native [glob] operation. */ - if (addStrRep[0] == '~') { - Tcl_Obj *tail = Tcl_NewStringObj(addStrRep, len); - - pathPtr = AppendPath(dirPtr, tail); - Tcl_DecrRefCount(tail); - return pathPtr; - } TclNewObj(pathPtr); - fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath)); + fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); /* * Set up the path. @@ -1329,7 +1303,7 @@ TclNewFSPathObj( case 0: /* So far only "." since last dirsep or start */ switch (*p) { case '.': - count++; + count = 1; break; case '/': case '\\': @@ -1366,9 +1340,9 @@ AppendPath( Tcl_Obj *head, Tcl_Obj *tail) { - int numBytes; const char *bytes; Tcl_Obj *copy = Tcl_DuplicateObj(head); + Tcl_Size length; /* * This is likely buggy when dealing with virtual filesystem drivers @@ -1378,8 +1352,8 @@ AppendPath( * internalrep produce the same results; that is, bugward compatibility. If * we need to fix that bug here, it needs fixing in TclJoinPath() too. */ - bytes = TclGetStringFromObj(tail, &numBytes); - if (numBytes == 0) { + bytes = Tcl_GetStringFromObj(tail, &length); + if (length == 0) { Tcl_AppendToObj(copy, "/", 1); } else { TclpNativeJoinPath(copy, bytes); @@ -1415,7 +1389,7 @@ TclFSMakePathRelative( Tcl_Obj *pathPtr, /* The path we have. */ Tcl_Obj *cwdPtr) /* Make it relative to this. */ { - int cwdLen, len; + Tcl_Size cwdLen, len; const char *tempStr; Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(pathPtr, &fsPathType); @@ -1438,7 +1412,7 @@ TclFSMakePathRelative( * too little below, leading to wrong answers returned by glob. */ - tempStr = TclGetStringFromObj(cwdPtr, &cwdLen); + tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); /* * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the @@ -1458,7 +1432,7 @@ TclFSMakePathRelative( } break; } - tempStr = TclGetStringFromObj(pathPtr, &len); + tempStr = Tcl_GetStringFromObj(pathPtr, &len); return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); } @@ -1491,7 +1465,7 @@ MakePathFromNormalized( return TCL_OK; } - fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath)); + fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); /* * It's a pure normalized absolute path. @@ -1526,7 +1500,7 @@ MakePathFromNormalized( * Any memory which is allocated for 'clientData' should be retained * until clientData is passed to the filesystem's freeInternalRepProc * when it can be freed. The built in platform-specific filesystems use - * 'ckalloc' to allocate clientData, and ckfree to free it. + * 'Tcl_Alloc' to allocate clientData, and Tcl_Free to free it. * * Results: * NULL or a valid path object pointer, with refCount zero. @@ -1540,7 +1514,7 @@ MakePathFromNormalized( Tcl_Obj * Tcl_FSNewNativePath( const Tcl_Filesystem *fromFilesystem, - ClientData clientData) + void *clientData) { Tcl_Obj *pathPtr = NULL; FsPath *fsPathPtr; @@ -1559,7 +1533,7 @@ Tcl_FSNewNativePath( */ Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL); - fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath)); + fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; @@ -1683,9 +1657,9 @@ Tcl_FSGetTranslatedStringPath( Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (transPtr != NULL) { - int len; - const char *orig = TclGetStringFromObj(transPtr, &len); - char *result = (char *)ckalloc(len+1); + Tcl_Size len; + const char *orig = Tcl_GetStringFromObj(transPtr, &len); + char *result = (char *)Tcl_Alloc(len+1); memcpy(result, orig, len+1); TclDecrRefCount(transPtr); @@ -1733,7 +1707,8 @@ Tcl_FSGetNormalizedPath( */ Tcl_Obj *dir, *copy; - int tailLen, cwdLen, pathType; + Tcl_Size tailLen, cwdLen; + int pathType; pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); @@ -1743,7 +1718,7 @@ Tcl_FSGetNormalizedPath( /* TODO: Figure out why this is needed. */ TclGetString(pathPtr); - TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + (void)Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); if (tailLen) { copy = AppendPath(dir, fsPathPtr->normPathPtr); } else { @@ -1756,7 +1731,7 @@ Tcl_FSGetNormalizedPath( * We now own a reference on both 'dir' and 'copy' */ - (void) TclGetStringFromObj(dir, &cwdLen); + (void) Tcl_GetStringFromObj(dir, &cwdLen); /* Normalize the combined string. */ @@ -1834,13 +1809,13 @@ Tcl_FSGetNormalizedPath( } fsPathPtr = PATHOBJ(pathPtr); } else if (fsPathPtr->normPathPtr == NULL) { - int cwdLen; + Tcl_Size cwdLen; Tcl_Obj *copy; copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); - (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); - cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); + (void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); + cwdLen += (TclGetString(copy)[cwdLen] == '/'); /* * Normalize the combined string, but only starting after the end @@ -1977,7 +1952,7 @@ Tcl_FSGetNormalizedPath( *--------------------------------------------------------------------------- */ -ClientData +void * Tcl_FSGetInternalRep( Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr) @@ -2124,7 +2099,7 @@ void TclFSSetPathDetails( Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr, - ClientData clientData) + void *clientData) { FsPath *srcFsPathPtr; @@ -2167,7 +2142,8 @@ Tcl_FSEqualPaths( Tcl_Obj *secondPtr) { const char *firstStr, *secondStr; - int firstLen, secondLen, tempErrno; + Tcl_Size firstLen, secondLen; + int tempErrno; if (firstPtr == secondPtr) { return 1; @@ -2176,8 +2152,8 @@ Tcl_FSEqualPaths( if (firstPtr == NULL || secondPtr == NULL) { return 0; } - firstStr = TclGetStringFromObj(firstPtr, &firstLen); - secondStr = TclGetStringFromObj(secondPtr, &secondLen); + firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); + secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); if ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)) { return 1; } @@ -2196,8 +2172,8 @@ Tcl_FSEqualPaths( return 0; } - firstStr = TclGetStringFromObj(firstPtr, &firstLen); - secondStr = TclGetStringFromObj(secondPtr, &secondLen); + firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); + secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); return ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)); } @@ -2209,10 +2185,6 @@ Tcl_FSEqualPaths( * Attempt to convert the internal representation of pathPtr to * fsPathType. * - * A tilde ("~") character at the beginnig of the filename indicates the - * current user's home directory, and "~<user>" indicates a particular - * user's directory. - * * Results: * Standard Tcl error code. * @@ -2224,13 +2196,12 @@ Tcl_FSEqualPaths( static int SetFsPathFromAny( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr) /* The object to convert. */ { - int len; + Tcl_Size len; FsPath *fsPathPtr; Tcl_Obj *transPtr; - const char *name; if (TclHasInternalRep(pathPtr, &fsPathType)) { return TCL_OK; @@ -2250,137 +2221,23 @@ SetFsPathFromAny( * cmdAH.test exercise most of the code). */ - name = TclGetStringFromObj(pathPtr, &len); - - /* - * Handle tilde substitutions, if needed. - */ - - if (len && name[0] == '~') { - Tcl_DString temp; - int split; - char separator = '/'; - - /* - * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc. - * split becomes value 1 for '~/...' as well as for '~'. - */ - split = FindSplitPos(name, separator); - - /* - * Do some tilde substitution. - */ - - if (split == 1) { - /* - * We have just '~' (or '~/...') - */ - - const char *dir; - Tcl_DString dirString; - - dir = TclGetEnv("HOME", &dirString); - if (dir == NULL) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "couldn't find HOME environment variable to" - " expand path", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", - "HOMELESS", (void *)NULL); - } - return TCL_ERROR; - } - Tcl_DStringInit(&temp); - Tcl_JoinPath(1, &dir, &temp); - Tcl_DStringFree(&dirString); - } else { - /* - * There is a '~user' - */ - - const char *expandedUser; - Tcl_DString userName; - - Tcl_DStringInit(&userName); - Tcl_DStringAppend(&userName, name+1, split-1); - expandedUser = Tcl_DStringValue(&userName); - - Tcl_DStringInit(&temp); - if (TclpGetUserHome(expandedUser, &temp) == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "user \"%s\" doesn't exist", expandedUser)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", - (void *)NULL); - } - Tcl_DStringFree(&userName); - Tcl_DStringFree(&temp); - return TCL_ERROR; - } - Tcl_DStringFree(&userName); - } - - transPtr = Tcl_DStringToObj(&temp); - - if (split != len) { - /* - * Join up the tilde substitution with the rest. - */ - - if (name[split+1] == separator) { - /* - * Somewhat tricky case like ~//foo/bar. Make use of - * Split/Join machinery to get it right. Assumes all paths - * beginning with ~ are part of the native filesystem. - */ - - int objc; - Tcl_Obj **objv; - Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL); - - TclListObjGetElementsM(NULL, parts, &objc, &objv); - - /* - * Skip '~'. It's replaced by its expansion. - */ - - objc--; objv++; - while (objc--) { - TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++)); - } - TclDecrRefCount(parts); - } else { - Tcl_Obj *pair[2]; - - pair[0] = transPtr; - pair[1] = Tcl_NewStringObj(name+split+1, -1); - transPtr = TclJoinPath(2, pair, 1); - if (transPtr != pair[0]) { - Tcl_DecrRefCount(pair[0]); - } - if (transPtr != pair[1]) { - Tcl_DecrRefCount(pair[1]); - } - } - } - } else { - transPtr = TclJoinPath(1, &pathPtr, 1); - } + Tcl_GetStringFromObj(pathPtr, &len); /* TODO: Is this needed? */ + transPtr = TclJoinPath(1, &pathPtr, 1); /* * Now we have a translated filename in 'transPtr'. This will have forward * slashes on Windows, and will not contain any ~user sequences. */ - fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath)); + fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); if (transPtr == pathPtr) { - (void)TclGetString(pathPtr); + (void) Tcl_GetString(pathPtr); TclFreeInternalRep(pathPtr); - transPtr = Tcl_DuplicateObj(pathPtr); - fsPathPtr->filesystemEpoch = 0; + transPtr = Tcl_DuplicateObj(pathPtr); + fsPathPtr->filesystemEpoch = 0; } else { - fsPathPtr->filesystemEpoch = TclFSEpoch(); + fsPathPtr->filesystemEpoch = TclFSEpoch(); } Tcl_IncrRefCount(transPtr); fsPathPtr->translatedPathPtr = transPtr; @@ -2425,7 +2282,7 @@ FreeFsPathInternalRep( } } - ckfree(fsPathPtr); + Tcl_Free(fsPathPtr); } static void @@ -2434,7 +2291,7 @@ DupFsPathInternalRep( Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */ { FsPath *srcFsPathPtr = PATHOBJ(srcPtr); - FsPath *copyFsPathPtr = (FsPath *)ckalloc(sizeof(FsPath)); + FsPath *copyFsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); SETPATHOBJ(copyPtr, copyFsPathPtr); @@ -2494,21 +2351,26 @@ UpdateStringOfFsPath( Tcl_Obj *pathPtr) /* path obj with string rep to update. */ { FsPath *fsPathPtr = PATHOBJ(pathPtr); - int cwdLen; + Tcl_Size cwdLen; Tcl_Obj *copy; if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) { - Tcl_Panic("Called UpdateStringOfFsPath with invalid object"); + if (fsPathPtr->translatedPathPtr == NULL) { + Tcl_Panic("Called UpdateStringOfFsPath with invalid object"); + } else { + copy = Tcl_DuplicateObj(fsPathPtr->translatedPathPtr); + } + } else { + copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); } - copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); if (Tcl_IsShared(copy)) { copy = Tcl_DuplicateObj(copy); } Tcl_IncrRefCount(copy); /* Steal copy's string rep */ - pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen); + pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; TclInitEmptyStringRep(copy); TclDecrRefCount(copy); @@ -2538,7 +2400,7 @@ UpdateStringOfFsPath( int TclNativePathInFilesystem( Tcl_Obj *pathPtr, - TCL_UNUSED(ClientData *)) + TCL_UNUSED(void **)) { /* * A special case is required to handle the empty path "". This is a valid @@ -2566,9 +2428,9 @@ TclNativePathInFilesystem( * situation. */ - int len; + Tcl_Size len; - (void) TclGetStringFromObj(pathPtr, &len); + (void) Tcl_GetStringFromObj(pathPtr, &len); if (len == 0) { /* * We reject the empty path "". @@ -2712,11 +2574,11 @@ TclResolveTildePath( Tcl_Obj *pathObj) { const char *path; - int len; - int split; + Tcl_Size len; + Tcl_Size split; Tcl_DString resolvedPath; - path = TclGetStringFromObj(pathObj, &len); + path = Tcl_GetStringFromObj(pathObj, &len); if (path[0] != '~') { return pathObj; } @@ -2789,8 +2651,8 @@ TclResolveTildePathList( Tcl_Obj *pathsObj) { Tcl_Obj **objv; - int objc; - int i; + Tcl_Size objc; + Tcl_Size i; Tcl_Obj *resolvedPaths; const char *path; diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 8b6eb11..854ecd5 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -179,16 +179,16 @@ FileForRedirect( void Tcl_DetachPids( - int numPids, /* Number of pids to detach: gives size of + Tcl_Size numPids, /* Number of pids to detach: gives size of * array pointed to by pidPtr. */ Tcl_Pid *pidPtr) /* Array of pids to detach. */ { Detached *detPtr; - int i; + Tcl_Size i; Tcl_MutexLock(&pipeMutex); for (i = 0; i < numPids; i++) { - detPtr = (Detached *)ckalloc(sizeof(Detached)); + detPtr = (Detached *)Tcl_Alloc(sizeof(Detached)); detPtr->pid = pidPtr[i]; detPtr->nextPtr = detList; detList = detPtr; @@ -238,7 +238,7 @@ Tcl_ReapDetachedProcs(void) } else { prevPtr->nextPtr = detPtr->nextPtr; } - ckfree(detPtr); + Tcl_Free(detPtr); detPtr = nextPtr; } Tcl_MutexUnlock(&pipeMutex); @@ -269,16 +269,16 @@ Tcl_ReapDetachedProcs(void) int TclCleanupChildren( Tcl_Interp *interp, /* Used for error messages. */ - int numPids, /* Number of entries in pidPtr array. */ + Tcl_Size numPids, /* Number of entries in pidPtr array. */ Tcl_Pid *pidPtr, /* Array of process ids of children. */ Tcl_Channel errorChan) /* Channel for file containing stderr output * from pipeline. NULL means there isn't any * stderr output. */ { int result = TCL_OK; - int i, abnormalExit, anyErrorInfo; + int code, abnormalExit, anyErrorInfo; TclProcessWaitStatus waitStatus; - int code; + Tcl_Size i; Tcl_Obj *msg, *error; abnormalExit = 0; @@ -335,8 +335,8 @@ TclCleanupChildren( Tcl_Seek(errorChan, 0, SEEK_SET); TclNewObj(objPtr); - count = Tcl_ReadChars(errorChan, objPtr, -1, 0); - if (count < 0) { + count = Tcl_ReadChars(errorChan, objPtr, TCL_INDEX_NONE, 0); + if (count == -1) { result = TCL_ERROR; Tcl_DecrRefCount(objPtr); Tcl_ResetResult(interp); @@ -351,7 +351,7 @@ TclCleanupChildren( Tcl_DecrRefCount(objPtr); } } - Tcl_Close(NULL, errorChan); + Tcl_CloseEx(NULL, errorChan, 0); } /* @@ -378,7 +378,7 @@ TclCleanupChildren( * * Results: * The return value is a count of the number of new processes created, or - * -1 if an error occurred while creating the pipeline. *pidArrayPtr is + * TCL_INDEX_NONE if an error occurred while creating the pipeline. *pidArrayPtr is * filled in with the address of a dynamically allocated array giving the * ids of all of the processes. It is up to the caller to free this array * when it isn't needed anymore. If inPipePtr is non-NULL, *inPipePtr is @@ -395,10 +395,10 @@ TclCleanupChildren( *---------------------------------------------------------------------- */ -int +Tcl_Size TclCreatePipeline( Tcl_Interp *interp, /* Interpreter to use for error reporting. */ - int argc, /* Number of entries in argv. */ + Tcl_Size argc, /* Number of entries in argv. */ const char **argv, /* Array of strings describing commands in * pipeline plus I/O redirection with <, <<, * >, etc. Argv[argc] must be NULL. */ @@ -431,9 +431,9 @@ TclCreatePipeline( { Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all the * pids of child processes. */ - int numPids; /* Actual number of processes that exist at + Tcl_Size numPids; /* Actual number of processes that exist at * *pidPtr right now. */ - int cmdCount; /* Count of number of distinct commands found + Tcl_Size cmdCount; /* Count of number of distinct commands found * in argc/argv. */ const char *inputLiteral = NULL; /* If non-null, then this points to a string @@ -460,7 +460,8 @@ TclCreatePipeline( int errorRelease = 0; const char *p; const char *nextArg; - int skip, lastBar, lastArg, i, j, atOK, flags, needCmd, errorToOutput = 0; + int skip, atOK, flags, needCmd, errorToOutput = 0; + Tcl_Size i, j, lastArg, lastBar; Tcl_DString execBuffer; TclFile pipeIn; TclFile curInFile, curOutFile, curErrFile; @@ -824,7 +825,7 @@ TclCreatePipeline( */ Tcl_ReapDetachedProcs(); - pidPtr = (Tcl_Pid *)ckalloc(cmdCount * sizeof(Tcl_Pid)); + pidPtr = (Tcl_Pid *)Tcl_Alloc(cmdCount * sizeof(Tcl_Pid)); curInFile = inputFile; @@ -974,11 +975,11 @@ TclCreatePipeline( } if (pidPtr != NULL) { for (i = 0; i < numPids; i++) { - if (pidPtr[i] != (Tcl_Pid) -1) { + if (pidPtr[i] != (Tcl_Pid)-1) { Tcl_DetachPids(1, &pidPtr[i]); } } - ckfree(pidPtr); + Tcl_Free(pidPtr); } numPids = -1; goto cleanup; @@ -1020,15 +1021,15 @@ Tcl_Channel Tcl_OpenCommandChannel( Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be * NULL. */ - int argc, /* How many arguments. */ + Tcl_Size argc, /* How many arguments. */ const char **argv, /* Array of arguments for command pipe. */ int flags) /* Or'ed combination of TCL_STDIN, TCL_STDOUT, * TCL_STDERR, and TCL_ENFORCE_MODE. */ { TclFile *inPipePtr, *outPipePtr, *errFilePtr; TclFile inPipe, outPipe, errFile; - int numPids; - Tcl_Pid *pidPtr; + Tcl_Size numPids; + Tcl_Pid *pidPtr = NULL; Tcl_Channel channel; inPipe = outPipe = errFile = NULL; @@ -1080,9 +1081,9 @@ Tcl_OpenCommandChannel( return channel; error: - if (numPids > 0) { + if (pidPtr) { Tcl_DetachPids(numPids, pidPtr); - ckfree(pidPtr); + Tcl_Free(pidPtr); } if (inPipe != NULL) { TclpCloseFile(inPipe); diff --git a/generic/tclPkg.c b/generic/tclPkg.c index b5b5582..3b5580f 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -57,7 +57,7 @@ typedef struct PkgFiles { * "Tk" (no version number). */ -typedef struct Package { +typedef struct { Tcl_Obj *version; PkgAvail *availPtr; /* First in list of all available versions of * this package. */ @@ -96,22 +96,22 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result); -static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result); -static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result); -static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result); -static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result); -static int TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); -static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result); -static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result); -static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCore(void *data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreFinal(void *data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreCleanup(void *data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep1(void *data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep2(void *data[], Tcl_Interp *interp, int result); +static int TclNRPkgRequireProc(void *clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); +static int SelectPackage(void *data[], Tcl_Interp *interp, int result); +static int SelectPackageFinal(void *data[], Tcl_Interp *interp, int result); +static int TclNRPackageObjCmdCleanup(void *data[], Tcl_Interp *interp, int result); /* * Helper macros. */ #define DupBlock(v,s,len) \ - ((v) = (char *)ckalloc(len), memcpy((v),(s),(len))) + ((v) = (char *)Tcl_Alloc(len), memcpy((v),(s),(len))) #define DupString(v,s) \ do { \ size_t local__len = strlen(s) + 1; \ @@ -175,13 +175,13 @@ Tcl_PkgProvideEx( NULL) != TCL_OK) { return TCL_ERROR; } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) { - ckfree(pvi); + Tcl_Free(pvi); return TCL_ERROR; } res = CompareVersions(pvi, vi, NULL); - ckfree(pvi); - ckfree(vi); + Tcl_Free(pvi); + Tcl_Free(vi); if (res == 0) { if (clientData != NULL) { @@ -225,7 +225,7 @@ Tcl_PkgProvideEx( static void PkgFilesCleanupProc( - ClientData clientData, + void *clientData, TCL_UNUSED(Tcl_Interp *)) { PkgFiles *pkgFiles = (PkgFiles *) clientData; @@ -236,7 +236,7 @@ PkgFilesCleanupProc( PkgName *name = pkgFiles->names; pkgFiles->names = name->nextPtr; - ckfree(name); + Tcl_Free(name); } entry = Tcl_FirstHashEntry(&pkgFiles->table, &search); while (entry) { @@ -246,7 +246,7 @@ PkgFilesCleanupProc( entry = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(&pkgFiles->table); - ckfree(pkgFiles); + Tcl_Free(pkgFiles); return; } @@ -261,7 +261,7 @@ TclInitPkgFiles( PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL); if (!pkgFiles) { - pkgFiles = (PkgFiles *)ckalloc(sizeof(PkgFiles)); + pkgFiles = (PkgFiles *)Tcl_Alloc(sizeof(PkgFiles)); pkgFiles->names = NULL; Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS); Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles); @@ -399,7 +399,7 @@ Tcl_PkgRequireEx( if (version == NULL) { if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) { - result = Tcl_GetString(Tcl_GetObjResult(interp)); + result = Tcl_GetStringResult(interp); Tcl_ResetResult(interp); } } else { @@ -413,7 +413,7 @@ Tcl_PkgRequireEx( } Tcl_IncrRefCount(ov); if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { - result = Tcl_GetString(Tcl_GetObjResult(interp)); + result = Tcl_GetStringResult(interp); Tcl_ResetResult(interp); } TclDecrRefCount(ov); @@ -426,7 +426,7 @@ Tcl_PkgRequireProc( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ const char *name, /* Name of desired package. */ - int reqc, /* Requirements constraining the desired + Tcl_Size reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ @@ -442,7 +442,7 @@ Tcl_PkgRequireProc( static int TclNRPkgRequireProc( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]) @@ -457,12 +457,12 @@ TclNRPkgRequireProc( static int PkgRequireCore( - ClientData data[], + void *data[], Tcl_Interp *interp, TCL_UNUSED(int)) { const char *name = (const char *)data[0]; - int reqc = PTR2INT(data[1]); + int reqc = (int)PTR2INT(data[1]); Tcl_Obj **reqv = (Tcl_Obj **)data[2]; int code = CheckAllRequirements(interp, reqc, reqv); Require *reqPtr; @@ -470,7 +470,7 @@ PkgRequireCore( if (code != TCL_OK) { return code; } - reqPtr = (Require *)ckalloc(sizeof(Require)); + reqPtr = (Require *)Tcl_Alloc(sizeof(Require)); Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL); reqPtr->clientDataPtr = data[3]; reqPtr->name = name; @@ -488,14 +488,14 @@ PkgRequireCore( static int PkgRequireCoreStep1( - ClientData data[], + void *data[], Tcl_Interp *interp, TCL_UNUSED(int)) { Tcl_DString command; char *script; Require *reqPtr = (Require *)data[0]; - int reqc = PTR2INT(data[1]); + int reqc = (int)PTR2INT(data[1]); Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; const char *name = reqPtr->name /* Name of desired package. */; @@ -547,12 +547,12 @@ PkgRequireCoreStep1( static int PkgRequireCoreStep2( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { Require *reqPtr = (Require *)data[0]; - int reqc = PTR2INT(data[1]); + int reqc = (int)PTR2INT(data[1]); Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; const char *name = reqPtr->name; /* Name of desired package. */ @@ -582,12 +582,12 @@ PkgRequireCoreStep2( static int PkgRequireCoreFinal( - ClientData data[], + void *data[], Tcl_Interp *interp, TCL_UNUSED(int)) { Require *reqPtr = (Require *)data[0]; - int reqc = PTR2INT(data[1]), satisfies; + int reqc = (int)PTR2INT(data[1]), satisfies; Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; char *pkgVersionI; void *clientDataPtr = reqPtr->clientDataPtr; @@ -610,7 +610,7 @@ PkgRequireCoreFinal( &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); - ckfree(pkgVersionI); + Tcl_Free(pkgVersionI); if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -634,17 +634,17 @@ PkgRequireCoreFinal( static int PkgRequireCoreCleanup( - ClientData data[], + void *data[], TCL_UNUSED(Tcl_Interp *), int result) { - ckfree(data[0]); + Tcl_Free(data[0]); return result; } static int SelectPackage( - ClientData data[], + void *data[], Tcl_Interp *interp, TCL_UNUSED(int)) { @@ -653,7 +653,7 @@ SelectPackage( /* Internal rep. of versions */ int availStable, satisfies; Require *reqPtr = (Require *)data[0]; - int reqc = PTR2INT(data[1]); + int reqc = (int)PTR2INT(data[1]); Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; const char *name = reqPtr->name; Package *pkgPtr = reqPtr->pkgPtr; @@ -707,7 +707,7 @@ SelectPackage( if (reqc > 0) { satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { - ckfree(availVersion); + Tcl_Free(availVersion); availVersion = NULL; continue; } @@ -726,7 +726,7 @@ SelectPackage( * currently selected version. */ - ckfree(bestVersion); + Tcl_Free(bestVersion); bestVersion = NULL; goto newbest; } @@ -741,7 +741,7 @@ SelectPackage( } if (!availStable) { - ckfree(availVersion); + Tcl_Free(availVersion); availVersion = NULL; continue; } @@ -759,7 +759,7 @@ SelectPackage( * the currently selected stable version. */ - ckfree(bestStableVersion); + Tcl_Free(bestStableVersion); bestStableVersion = NULL; goto newstable; } @@ -775,7 +775,7 @@ SelectPackage( &bestStableVersion, NULL); } - ckfree(availVersion); + Tcl_Free(availVersion); availVersion = NULL; } /* end for */ @@ -784,12 +784,12 @@ SelectPackage( */ if (bestVersion != NULL) { - ckfree(bestVersion); + Tcl_Free(bestVersion); bestVersion = NULL; } if (bestStableVersion != NULL) { - ckfree(bestStableVersion); + Tcl_Free(bestStableVersion); bestStableVersion = NULL; } @@ -828,7 +828,7 @@ SelectPackage( * Push "ifneeded" package name in "tclPkgFiles" assocdata. */ - pkgName = (PkgName *)ckalloc(offsetof(PkgName, name) + 1 + strlen(name)); + pkgName = (PkgName *)Tcl_Alloc(offsetof(PkgName, name) + 1 + strlen(name)); pkgName->nextPtr = pkgFiles->names; strcpy(pkgName->name, name); pkgFiles->names = pkgName; @@ -847,12 +847,12 @@ SelectPackage( static int SelectPackageFinal( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { Require *reqPtr = (Require *)data[0]; - int reqc = PTR2INT(data[1]); + int reqc = (int)PTR2INT(data[1]); Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; const char *name = reqPtr->name; char *versionToProvide = reqPtr->versionToProvide; @@ -864,7 +864,7 @@ SelectPackageFinal( PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL); PkgName *pkgName = pkgFiles->names; pkgFiles->names = pkgName->nextPtr; - ckfree(pkgName); + Tcl_Free(pkgName); reqPtr->pkgPtr = FindPackage(interp, name); if (result == TCL_OK) { @@ -885,13 +885,13 @@ SelectPackageFinal( result = TCL_ERROR; } else if (CheckVersionAndConvert(interp, versionToProvide, &vi, NULL) != TCL_OK) { - ckfree(pvi); + Tcl_Free(pvi); result = TCL_ERROR; } else { int res = CompareVersions(pvi, vi, NULL); - ckfree(pvi); - ckfree(vi); + Tcl_Free(pvi); + Tcl_Free(vi); if (res != 0) { result = TCL_ERROR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1053,7 +1053,7 @@ Tcl_PkgPresentEx( */ int Tcl_PackageObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1063,7 +1063,7 @@ Tcl_PackageObjCmd( int TclNRPackageObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1077,9 +1077,10 @@ TclNRPackageObjCmd( PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, PKG_VSATISFIES - }; + } optionIndex; Interp *iPtr = (Interp *) interp; - int optionIndex, exact, i, newobjc, satisfies; + int exact, satisfies; + Tcl_Size i, newobjc; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; @@ -1099,7 +1100,7 @@ TclNRPackageObjCmd( &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum pkgOptionsEnum) optionIndex) { + switch (optionIndex) { case PKG_FILES: { PkgFiles *pkgFiles; @@ -1109,8 +1110,9 @@ TclNRPackageObjCmd( } pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); if (pkgFiles) { - Tcl_HashEntry *entry = - Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2])); + Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, + TclGetString(objv[2])); + if (entry) { Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); } @@ -1151,14 +1153,15 @@ TclNRPackageObjCmd( Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); availPtr->pkgIndex = NULL; } - ckfree(availPtr); + Tcl_Free(availPtr); } - ckfree(pkgPtr); + Tcl_Free(pkgPtr); } break; } case PKG_IFNEEDED: { - int length, res; + Tcl_Size length; + int res; char *argv3i, *avi; if ((objc != 4) && (objc != 5)) { @@ -1173,29 +1176,29 @@ TclNRPackageObjCmd( if (objc == 4) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr == NULL) { - ckfree(argv3i); + Tcl_Free(argv3i); return TCL_OK; } pkgPtr = (Package *)Tcl_GetHashValue(hPtr); } else { pkgPtr = FindPackage(interp, argv2); } - argv3 = TclGetStringFromObj(objv[3], &length); + argv3 = Tcl_GetStringFromObj(objv[3], &length); for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { if (CheckVersionAndConvert(interp, availPtr->version, &avi, NULL) != TCL_OK) { - ckfree(argv3i); + Tcl_Free(argv3i); return TCL_ERROR; } res = CompareVersions(avi, argv3i, NULL); - ckfree(avi); + Tcl_Free(avi); if (res == 0) { if (objc == 4) { - ckfree(argv3i); + Tcl_Free(argv3i); Tcl_SetObjResult(interp, Tcl_NewStringObj(availPtr->script, -1)); return TCL_OK; @@ -1208,13 +1211,13 @@ TclNRPackageObjCmd( break; } } - ckfree(argv3i); + Tcl_Free(argv3i); if (objc == 4) { return TCL_OK; } if (availPtr == NULL) { - availPtr = (PkgAvail *)ckalloc(sizeof(PkgAvail)); + availPtr = (PkgAvail *)Tcl_Alloc(sizeof(PkgAvail)); availPtr->pkgIndex = NULL; DupBlock(availPtr->version, argv3, length + 1); @@ -1227,10 +1230,10 @@ TclNRPackageObjCmd( } } if (iPtr->scriptFile) { - argv4 = TclGetStringFromObj(iPtr->scriptFile, &length); + argv4 = Tcl_GetStringFromObj(iPtr->scriptFile, &length); DupBlock(availPtr->pkgIndex, argv4, length + 1); } - argv4 = TclGetStringFromObj(objv[4], &length); + argv4 = Tcl_GetStringFromObj(objv[4], &length); DupBlock(availPtr->script, argv4, length + 1); break; } @@ -1396,7 +1399,7 @@ TclNRPackageObjCmd( } break; case PKG_UNKNOWN: { - int length; + Tcl_Size length; if (objc == 2) { if (iPtr->packageUnknown != NULL) { @@ -1405,9 +1408,9 @@ TclNRPackageObjCmd( } } else if (objc == 3) { if (iPtr->packageUnknown != NULL) { - ckfree(iPtr->packageUnknown); + Tcl_Free(iPtr->packageUnknown); } - argv2 = TclGetStringFromObj(objv[2], &length); + argv2 = Tcl_GetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { @@ -1466,7 +1469,7 @@ TclNRPackageObjCmd( if (CheckVersionAndConvert(interp, argv2, &iva, NULL) != TCL_OK || CheckVersionAndConvert(interp, argv3, &ivb, NULL) != TCL_OK) { if (iva != NULL) { - ckfree(iva); + Tcl_Free(iva); } /* @@ -1482,8 +1485,8 @@ TclNRPackageObjCmd( Tcl_SetObjResult(interp, Tcl_NewWideIntObj(CompareVersions(iva, ivb, NULL))); - ckfree(iva); - ckfree(ivb); + Tcl_Free(iva); + Tcl_Free(ivb); break; case PKG_VERSIONS: if (objc != 3) { @@ -1518,12 +1521,12 @@ TclNRPackageObjCmd( if (CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK) { return TCL_ERROR; } else if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { - ckfree(argv2i); + Tcl_Free(argv2i); return TCL_ERROR; } satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3); - ckfree(argv2i); + Tcl_Free(argv2i); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); break; @@ -1536,7 +1539,7 @@ TclNRPackageObjCmd( static int TclNRPackageObjCmdCleanup( - ClientData data[], + void *data[], TCL_UNUSED(Tcl_Interp *), int result) { @@ -1575,7 +1578,7 @@ FindPackage( hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew); if (isNew) { - pkgPtr = (Package *)ckalloc(sizeof(Package)); + pkgPtr = (Package *)Tcl_Alloc(sizeof(Package)); pkgPtr->version = NULL; pkgPtr->availPtr = NULL; pkgPtr->clientData = NULL; @@ -1627,13 +1630,13 @@ TclFreePackageInfo( Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); availPtr->pkgIndex = NULL; } - ckfree(availPtr); + Tcl_Free(availPtr); } - ckfree(pkgPtr); + Tcl_Free(pkgPtr); } Tcl_DeleteHashTable(&iPtr->packageTable); if (iPtr->packageUnknown != NULL) { - ckfree(iPtr->packageUnknown); + Tcl_Free(iPtr->packageUnknown); } } @@ -1673,7 +1676,7 @@ CheckVersionAndConvert( * 4* assuming that each char is a separator (a,b become ' -x '). * 4+ to have spce for an additional -2 at the end */ - char *ibuf = (char *)ckalloc(4 + 4*strlen(string)); + char *ibuf = (char *)Tcl_Alloc(4 + 4*strlen(string)); char *ip = ibuf; /* @@ -1741,7 +1744,7 @@ CheckVersionAndConvert( if (internal != NULL) { *internal = ibuf; } else { - ckfree(ibuf); + Tcl_Free(ibuf); } if (stable != NULL) { *stable = !hasunstable; @@ -1750,7 +1753,7 @@ CheckVersionAndConvert( } error: - ckfree(ibuf); + Tcl_Free(ibuf); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected version number but got \"%s\"", string)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", (void *)NULL); @@ -2024,7 +2027,7 @@ CheckRequirement( * Exactly one dash is present. Copy the string, split at the location of * dash and check that both parts are versions. Note that the max part can * be empty. Also note that the string allocated with strdup() must be - * freed with free() and not ckfree(). + * freed with free() and not Tcl_Free(). */ DupString(buf, string); @@ -2035,11 +2038,11 @@ CheckRequirement( if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) || ((*dash != '\0') && (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) { - ckfree(buf); + Tcl_Free(buf); return TCL_ERROR; } - ckfree(buf); + Tcl_Free(buf); return TCL_OK; } @@ -2068,10 +2071,11 @@ AddRequirementsToResult( * available. */ { Tcl_Obj *result = Tcl_GetObjResult(interp); - int i, length; + int i; + Tcl_Size length; for (i = 0; i < reqc; i++) { - const char *v = TclGetStringFromObj(reqv[i], &length); + const char *v = Tcl_GetStringFromObj(reqv[i], &length); if ((length & 0x1) && (v[length/2] == '-') && (strncmp(v, v+((length+1)/2), length/2) == 0)) { @@ -2204,7 +2208,7 @@ RequirementSatisfied( strcat(reqi, " -2"); res = CompareVersions(havei, reqi, &thisIsMajor); satisfied = (res == 0) || ((res == 1) && !thisIsMajor); - ckfree(reqi); + Tcl_Free(reqi); return satisfied; } @@ -2228,8 +2232,8 @@ RequirementSatisfied( CheckVersionAndConvert(NULL, buf, &min, NULL); strcat(min, " -2"); satisfied = (CompareVersions(havei, min, NULL) >= 0); - ckfree(min); - ckfree(buf); + Tcl_Free(min); + Tcl_Free(buf); return satisfied; } @@ -2251,9 +2255,9 @@ RequirementSatisfied( (CompareVersions(havei, max, NULL) < 0)); } - ckfree(min); - ckfree(max); - ckfree(buf); + Tcl_Free(min); + Tcl_Free(max); + Tcl_Free(buf); return satisfied; } @@ -2282,7 +2286,7 @@ Tcl_PkgInitStubsCheck( const char * version, int exact) { - const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); + const char *actualVersion = Tcl_PkgPresentEx(interp, "Tcl", version, 0, NULL); if ((exact&1) && actualVersion) { const char *p = version; @@ -2294,11 +2298,11 @@ Tcl_PkgInitStubsCheck( if (count == 1) { if (0 != strncmp(version, actualVersion, strlen(version))) { /* Construct error message */ - Tcl_PkgPresent(interp, "Tcl", version, 1); + Tcl_PkgPresentEx(interp, "Tcl", version, 1, NULL); return NULL; } } else { - return Tcl_PkgPresent(interp, "Tcl", version, 1); + return Tcl_PkgPresentEx(interp, "Tcl", version, 1, NULL); } } return actualVersion; diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index a0dae51..d84472c 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -93,7 +93,6 @@ #endif static Tcl_Config const cfg[] = { -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 {"debug", CFG_DEBUG}, {"threaded", CFG_THREADED}, {"profiled", CFG_PROFILED}, @@ -102,7 +101,6 @@ static Tcl_Config const cfg[] = { {"mem_debug", CFG_MEMDEBUG}, {"compile_debug", CFG_COMPILE_DEBUG}, {"compile_stats", CFG_COMPILE_STATS}, -#endif /* Runtime paths to various stuff */ diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 8d1eee1..b8243d2 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -48,7 +48,7 @@ # endif #endif -/* !BEGIN!: Do not edit below this line. */ +#if TCL_MAJOR_VERSION < 9 #ifdef __cplusplus extern "C" { @@ -134,8 +134,67 @@ extern const TclPlatStubs *tclPlatStubsPtr; #endif /* defined(USE_TCL_STUBS) */ +#else /* TCL_MAJOR_VERSION > 8 */ + +/* !BEGIN!: Do not edit below this line. */ + +#ifdef __cplusplus +extern "C" { +#endif + +/* + * Exported function declarations: + */ + +/* Slot 0 is reserved */ +/* 1 */ +EXTERN int Tcl_MacOSXOpenVersionedBundleResources( + Tcl_Interp *interp, const char *bundleName, + const char *bundleVersion, + int hasResourceFile, Tcl_Size maxPathLen, + char *libraryPath); +/* 2 */ +EXTERN void Tcl_MacOSXNotifierAddRunLoopMode( + const void *runLoopMode); +/* 3 */ +EXTERN void Tcl_WinConvertError(unsigned errCode); + +typedef struct TclPlatStubs { + int magic; + void *hooks; + + void (*reserved0)(void); + int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 1 */ + void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */ + void (*tcl_WinConvertError) (unsigned errCode); /* 3 */ +} TclPlatStubs; + +extern const TclPlatStubs *tclPlatStubsPtr; + +#ifdef __cplusplus +} +#endif + +#if defined(USE_TCL_STUBS) + +/* + * Inline function declarations: + */ + +/* Slot 0 is reserved */ +#define Tcl_MacOSXOpenVersionedBundleResources \ + (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ +#define Tcl_MacOSXNotifierAddRunLoopMode \ + (tclPlatStubsPtr->tcl_MacOSXNotifierAddRunLoopMode) /* 2 */ +#define Tcl_WinConvertError \ + (tclPlatStubsPtr->tcl_WinConvertError) /* 3 */ + +#endif /* defined(USE_TCL_STUBS) */ + /* !END!: Do not edit above this line. */ +#endif /* TCL_MAJOR_VERSION */ + #ifdef MAC_OSX_TCL /* MACOSX */ #undef Tcl_MacOSXOpenBundleResources #define Tcl_MacOSXOpenBundleResources(a,b,c,d,e) Tcl_MacOSXOpenVersionedBundleResources(a,b,NULL,c,d,e) @@ -144,6 +203,16 @@ extern const TclPlatStubs *tclPlatStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#ifdef _WIN32 +# undef Tcl_CreateFileHandler +# undef Tcl_DeleteFileHandler +# undef Tcl_GetOpenFile +#endif +#ifndef MAC_OSX_TCL +# undef Tcl_MacOSXOpenVersionedBundleResources +# undef Tcl_MacOSXNotifierAddRunLoopMode +#endif + #if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))\ && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8) #undef Tcl_WinUtfToTChar diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index b32dd63..36a9537 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -21,7 +21,7 @@ */ typedef struct { - ClientData clientData; /* Address of preserved block. */ + void *clientData; /* Address of preserved block. */ size_t refCount; /* Number of Tcl_Preserve calls in effect for * block. */ int mustFree; /* Non-zero means Tcl_EventuallyFree was @@ -37,9 +37,9 @@ typedef struct { */ static Reference *refArray = NULL; /* First in array of references. */ -static int spaceAvl = 0; /* Total number of structures available at +static size_t spaceAvl = 0; /* Total number of structures available at * *firstRefPtr. */ -static int inUse = 0; /* Count of structures currently in use in +static size_t inUse = 0; /* Count of structures currently in use in * refArray. */ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ @@ -53,7 +53,7 @@ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ * objects that we don't want to live any longer than necessary. */ -typedef struct HandleStruct { +typedef struct { void *ptr; /* Pointer to the memory block being tracked. * This field will become NULL when the memory * block is deleted. This field must be the @@ -88,7 +88,7 @@ TclFinalizePreserve(void) { Tcl_MutexLock(&preserveMutex); if (spaceAvl != 0) { - ckfree(refArray); + Tcl_Free(refArray); refArray = NULL; inUse = 0; spaceAvl = 0; @@ -117,10 +117,10 @@ TclFinalizePreserve(void) void Tcl_Preserve( - ClientData clientData) /* Pointer to malloc'ed block of memory. */ + void *clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; - int i; + size_t i; /* * See if there is already a reference for this pointer. If so, just @@ -143,7 +143,7 @@ Tcl_Preserve( if (inUse == spaceAvl) { spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE; - refArray = (Reference *)ckrealloc(refArray, spaceAvl * sizeof(Reference)); + refArray = (Reference *)Tcl_Realloc(refArray, spaceAvl * sizeof(Reference)); } /* @@ -180,10 +180,10 @@ Tcl_Preserve( void Tcl_Release( - ClientData clientData) /* Pointer to malloc'ed block of memory. */ + void *clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; - int i; + size_t i; Tcl_MutexLock(&preserveMutex); for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) { @@ -223,7 +223,7 @@ Tcl_Release( Tcl_MutexUnlock(&preserveMutex); if (mustFree) { if (freeProc == TCL_DYNAMIC) { - ckfree(clientData); + Tcl_Free(clientData); } else { freeProc((char *)clientData); } @@ -259,11 +259,11 @@ Tcl_Release( void Tcl_EventuallyFree( - ClientData clientData, /* Pointer to malloc'ed block of memory. */ + void *clientData, /* Pointer to malloc'ed block of memory. */ Tcl_FreeProc *freeProc) /* Function to actually do free. */ { Reference *refPtr; - int i; + size_t i; /* * See if there is a reference for this pointer. If so, set its "mustFree" @@ -290,9 +290,9 @@ Tcl_EventuallyFree( */ if (freeProc == TCL_DYNAMIC) { - ckfree(clientData); + Tcl_Free(clientData); } else { - freeProc((char *)clientData); + freeProc(clientData); } } @@ -326,7 +326,7 @@ TclHandleCreate( * be tracked for deletion. Must not be * NULL. */ { - HandleStruct *handlePtr = (HandleStruct *)ckalloc(sizeof(HandleStruct)); + HandleStruct *handlePtr = (HandleStruct *)Tcl_Alloc(sizeof(HandleStruct)); handlePtr->ptr = ptr; #ifdef TCL_MEM_DEBUG @@ -376,7 +376,7 @@ TclHandleFree( #endif handlePtr->ptr = NULL; if (handlePtr->refCount == 0) { - ckfree(handlePtr); + Tcl_Free(handlePtr); } } @@ -459,7 +459,7 @@ TclHandleRelease( } #endif if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) { - ckfree(handlePtr); + Tcl_Free(handlePtr); } } diff --git a/generic/tclProc.c b/generic/tclProc.c index 4ea10ad..01c7611 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -34,14 +34,14 @@ typedef struct { static void DupLambdaInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeLambdaInternalRep(Tcl_Obj *objPtr); -static int InitArgsAndLocals(Tcl_Interp *interp, Tcl_Size skip); +static int InitArgsAndLocals(Tcl_Interp *interp, int skip); static void InitResolvedLocals(Tcl_Interp *interp, ByteCode *codePtr, Var *defPtr, Namespace *nsPtr); static void InitLocalCache(Proc *procPtr); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); -static int ProcWrongNumArgs(Tcl_Interp *interp, Tcl_Size skip); +static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); static void MakeProcError(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void MakeLambdaError(Tcl_Interp *interp, @@ -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 @@ -63,8 +64,9 @@ const Tcl_ObjType tclProcBodyType = { NULL, /* UpdateString function; Tcl_GetString and * Tcl_GetStringFromObj should panic * instead. */ - NULL /* SetFromAny function; Tcl_ConvertToType + NULL, /* SetFromAny function; Tcl_ConvertToType * should panic instead. */ + TCL_OBJTYPE_V0 }; #define ProcSetInternalRep(objPtr, procPtr) \ @@ -93,7 +95,7 @@ const Tcl_ObjType tclProcBodyType = { static const Tcl_ObjType levelReferenceType = { "levelReference", - NULL, NULL, NULL, NULL + NULL, NULL, NULL, NULL, TCL_OBJTYPE_V0 }; /* @@ -110,7 +112,8 @@ static const Tcl_ObjType lambdaType = { FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetLambdaFromAny /* setFromAnyProc */ + SetLambdaFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define LambdaSetInternalRep(objPtr, procPtr, nsObjPtr) \ @@ -206,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 @@ -262,11 +265,11 @@ Tcl_ProcObjCmd( && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) { int isNew; Tcl_HashEntry *hePtr; - CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame)); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (Tcl_Size *)ckalloc(sizeof(Tcl_Size)); + cfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size)); cfPtr->line[0] = contextPtr->line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -294,9 +297,9 @@ Tcl_ProcObjCmd( Tcl_DecrRefCount(cfOldPtr->data.eval.path); cfOldPtr->data.eval.path = NULL; } - ckfree(cfOldPtr->line); + Tcl_Free(cfOldPtr->line); cfOldPtr->line = NULL; - ckfree(cfOldPtr); + Tcl_Free(cfOldPtr); } Tcl_SetHashValue(hePtr, cfPtr); } @@ -353,7 +356,7 @@ Tcl_ProcObjCmd( * The argument list is just "args"; check the body */ - procBody = TclGetStringFromObj(objv[3], &numBytes); + procBody = Tcl_GetStringFromObj(objv[3], &numBytes); if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { goto done; } @@ -448,7 +451,7 @@ TclCreateProc( Tcl_Size length; Tcl_Obj *sharedBodyPtr = bodyPtr; - bytes = TclGetStringFromObj(bodyPtr, &length); + bytes = Tcl_GetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); /* @@ -468,7 +471,7 @@ TclCreateProc( Tcl_IncrRefCount(bodyPtr); - procPtr = (Proc *)ckalloc(sizeof(Proc)); + procPtr = (Proc *)Tcl_Alloc(sizeof(Proc)); procPtr->iPtr = iPtr; procPtr->refCount = 1; procPtr->bodyPtr = bodyPtr; @@ -530,7 +533,7 @@ TclCreateProc( "FORMALARGUMENTFORMAT", (void *)NULL); goto procError; } - if ((fieldCount == 0) || (TclGetCharLength(fieldValues[0]) == 0)) { + if ((fieldCount == 0) || (Tcl_GetCharLength(fieldValues[0]) == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", @@ -538,7 +541,7 @@ TclCreateProc( goto procError; } - argname = TclGetStringFromObj(fieldValues[0], &nameLength); + argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength); /* * Check that the formal parameter name is a scalar. @@ -551,7 +554,7 @@ TclCreateProc( if (*argnamelast == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", - Tcl_GetString(fieldValues[0]))); + TclGetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", (void *)NULL); goto procError; @@ -601,8 +604,8 @@ TclCreateProc( if (localPtr->defValuePtr != NULL) { Tcl_Size tmpLength, valueLength; - const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength); - const char *value = TclGetStringFromObj(fieldValues[1], &valueLength); + const char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, &tmpLength); + const char *value = Tcl_GetStringFromObj(fieldValues[1], &valueLength); if ((valueLength != tmpLength) || memcmp(value, tmpPtr, tmpLength) != 0 @@ -632,7 +635,7 @@ TclCreateProc( * local variables for the argument. */ - localPtr = (CompiledLocal *)ckalloc( + localPtr = (CompiledLocal *)Tcl_Alloc( offsetof(CompiledLocal, name) + 1U + fieldValues[0]->length); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; @@ -678,9 +681,9 @@ TclCreateProc( Tcl_DecrRefCount(localPtr->defValuePtr); } - ckfree(localPtr); + Tcl_Free(localPtr); } - ckfree(procPtr); + Tcl_Free(procPtr); } return TCL_ERROR; } @@ -781,7 +784,7 @@ TclObjGetFrame( if (objPtr == NULL) { /* Do nothing */ } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) { - Tcl_GetWideIntFromObj(NULL, objPtr, &w); + TclGetWideIntFromObj(NULL, objPtr, &w); if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) { result = -1; } else { @@ -830,7 +833,7 @@ TclObjGetFrame( CallFrame *framePtr; for (framePtr = iPtr->varFramePtr; framePtr != NULL; framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { + if ((int)framePtr->level == level) { *framePtrPtr = framePtr; return result; } @@ -1061,7 +1064,7 @@ TclIsProc( static int ProcWrongNumArgs( Tcl_Interp *interp, - Tcl_Size skip) + int skip) { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; Proc *procPtr = framePtr->procPtr; @@ -1080,11 +1083,7 @@ ProcWrongNumArgs( if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); } else { -#ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = framePtr->objv[skip-1]; -#else - desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1); -#endif /* AVOID_HACKS_FOR_ITCL */ } Tcl_IncrRefCount(desiredObjs[0]); @@ -1123,56 +1122,6 @@ ProcWrongNumArgs( /* *---------------------------------------------------------------------- * - * TclInitCompiledLocals -- - * - * This routine is invoked in order to initialize the compiled locals - * table for a new call frame. - * - * DEPRECATED: functionality has been inlined elsewhere; this function - * remains to insure binary compatibility with Itcl. - * - * Results: - * None. - * - * Side effects: - * May invoke various name resolvers in order to determine which - * variables are being referenced at runtime. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -void -TclInitCompiledLocals( - Tcl_Interp *interp, /* Current interpreter. */ - CallFrame *framePtr, /* Call frame to initialize. */ - Namespace *nsPtr) /* Pointer to current namespace. */ -{ - Var *varPtr = framePtr->compiledLocals; - Tcl_Obj *bodyPtr; - ByteCode *codePtr; - - bodyPtr = framePtr->procPtr->bodyPtr; - ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr); - if (codePtr == NULL) { - Tcl_Panic("body object for proc attached to frame is not a byte code type"); - } - - if (framePtr->numCompiledLocals) { - if (!codePtr->localCachePtr) { - InitLocalCache(framePtr->procPtr) ; - } - framePtr->localCachePtr = codePtr->localCachePtr; - framePtr->localCachePtr->refCount++; - } - - InitResolvedLocals(interp, codePtr, varPtr, nsPtr); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * InitResolvedLocals -- * * This routine is invoked in order to initialize the compiled locals @@ -1226,7 +1175,7 @@ InitResolvedLocals( if (localPtr->resolveInfo->deleteProc) { localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); } else { - ckfree(localPtr->resolveInfo); + Tcl_Free(localPtr->resolveInfo); } localPtr->resolveInfo = NULL; } @@ -1312,7 +1261,7 @@ TclFreeLocalCache( TclReleaseLiteral(interp, objPtr); } } - ckfree(localCachePtr); + Tcl_Free(localCachePtr); } static void @@ -1338,7 +1287,7 @@ InitLocalCache( * for future calls. */ - localCachePtr = (LocalCache *)ckalloc(offsetof(LocalCache, varName0) + localCachePtr = (LocalCache *)Tcl_Alloc(offsetof(LocalCache, varName0) + localCt * sizeof(Tcl_Obj *) + numArgs * sizeof(Var)); @@ -1350,7 +1299,7 @@ InitLocalCache( *namePtr = NULL; } else { *namePtr = TclCreateLiteral(iPtr, localPtr->name, - localPtr->nameLength, /* hash */ (unsigned int) -1, + localPtr->nameLength, /* hash */ TCL_INDEX_NONE, &isNew, /* nsPtr */ NULL, 0, NULL); Tcl_IncrRefCount(*namePtr); } @@ -1393,7 +1342,7 @@ static int InitArgsAndLocals( Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ - Tcl_Size skip) /* Number of initial arguments to be skipped, + int skip) /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; @@ -1662,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 @@ -1671,7 +1620,26 @@ TclNRInterpProc( * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ - Tcl_Size 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. */ +{ + int result = TclPushProcCallFrame(clientData, interp, objc, objv, + /*isLambda*/ 0); + + if (result != TCL_OK) { + return TCL_ERROR; + } + return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); +} + +static int +NRInterpProc( + void *clientData, /* Record describing procedure to be + * interpreted. */ + Tcl_Interp *interp, /* Interpreter in which procedure was + * invoked. */ + int objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { @@ -1683,6 +1651,24 @@ TclNRInterpProc( } return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); } + +static int +ObjInterpProc2( + 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 + * procedure. */ + Tcl_Obj *const objv[]) /* Argument value objects. */ +{ + /* + * Not used much in the core; external interface for iTcl + */ + + return Tcl_NRCallObjProc2(interp, TclNRInterpProc, clientData, objc, objv); +} + /* *---------------------------------------------------------------------- @@ -1763,7 +1749,7 @@ TclNRInterpProcCore( } if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); - const char *a[6]; int i[2]; + const char *a[6]; Tcl_Size i[2]; TclDTraceInfo(info, a, i); TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); @@ -2029,10 +2015,10 @@ TclProcCompileProc( if (toFree->resolveInfo->deleteProc) { toFree->resolveInfo->deleteProc(toFree->resolveInfo); } else { - ckfree(toFree->resolveInfo); + Tcl_Free(toFree->resolveInfo); } } - ckfree(toFree); + Tcl_Free(toFree); } procPtr->numCompiledLocals = procPtr->numArgs; } @@ -2095,9 +2081,9 @@ MakeProcError( { int overflow, limit = 60; Tcl_Size nameLen; - const char *procName = TclGetStringFromObj(procNameObj, &nameLen); + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); - overflow = (nameLen > limit); + overflow = (nameLen > (Tcl_Size)limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (procedure \"%.*s%s\" line %d)", (overflow ? limit : (int)nameLen), procName, @@ -2182,7 +2168,7 @@ TclProcCleanupProc( if (resVarInfo->deleteProc) { resVarInfo->deleteProc(resVarInfo); } else { - ckfree(resVarInfo); + Tcl_Free(resVarInfo); } } @@ -2190,10 +2176,10 @@ TclProcCleanupProc( defPtr = localPtr->defValuePtr; Tcl_DecrRefCount(defPtr); } - ckfree(localPtr); + Tcl_Free(localPtr); localPtr = nextPtr; } - ckfree(procPtr); + Tcl_Free(procPtr); /* * TIP #280: Release the location data associated with this Proc @@ -2217,9 +2203,9 @@ TclProcCleanupProc( Tcl_DecrRefCount(cfPtr->data.eval.path); cfPtr->data.eval.path = NULL; } - ckfree(cfPtr->line); + Tcl_Free(cfPtr->line); cfPtr->line = NULL; - ckfree(cfPtr); + Tcl_Free(cfPtr); } Tcl_DeleteHashEntry(hePtr); } @@ -2275,15 +2261,15 @@ TclUpdateReturnInfo( /* *---------------------------------------------------------------------- * - * TclGetObjInterpProc -- + * TclGetObjInterpProc/TclGetObjInterpProc2 -- * - * Returns a pointer to the TclObjInterpProc function; + * Returns a pointer to the TclObjInterpProc/ObjInterpProc2 functions; * this is different from the value obtained from the TclObjInterpProc * reference on systems like Windows where import and export versions * of a function exported by a DLL exist. * * Results: - * Returns the internal address of the TclObjInterpProc + * Returns the internal address of the TclObjInterpProc/ObjInterpProc2 * functions. * * Side effects: @@ -2297,6 +2283,12 @@ TclGetObjInterpProc(void) { return TclObjInterpProc; } + +Tcl_ObjCmdProc2 * +TclGetObjInterpProc2(void) +{ + return ObjInterpProc2; +} /* *---------------------------------------------------------------------- @@ -2477,7 +2469,7 @@ SetLambdaFromAny( if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't interpret \"%s\" as a lambda expression", - Tcl_GetString(objPtr))); + TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (void *)NULL); return TCL_ERROR; } @@ -2563,12 +2555,12 @@ SetLambdaFromAny( * location (line of 2nd list element). */ - cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); + cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame)); TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (Tcl_Size *)ckalloc(sizeof(Tcl_Size)); + cfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size)); cfPtr->line[0] = buf[1]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -2783,9 +2775,9 @@ MakeLambdaError( { int overflow, limit = 60; Tcl_Size nameLen; - const char *procName = TclGetStringFromObj(procNameObj, &nameLen); + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); - overflow = (nameLen > limit); + overflow = (nameLen > (Tcl_Size)limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (lambda term \"%.*s%s\" line %d)", (overflow ? limit : (int)nameLen), procName, diff --git a/generic/tclProcess.c b/generic/tclProcess.c index d55a1fd..b16c73d 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -26,7 +26,7 @@ static int autopurge = 1; /* Autopurge flag. */ typedef struct ProcessInfo { Tcl_Pid pid; /* Process id. */ - Tcl_Size resolvedPid; /* Resolved process id. */ + int resolvedPid; /* Resolved process id. */ int purge; /* Purge eventualy. */ TclProcessWaitStatus status;/* Process status. */ int code; /* Error code, exit status or signal @@ -122,7 +122,7 @@ FreeProcessInfo( * Free allocated structure. */ - ckfree(info); + Tcl_Free(info); } /* @@ -185,7 +185,7 @@ RefreshProcessInfo( TclProcessWaitStatus WaitProcessStatus( Tcl_Pid pid, /* Process id. */ - Tcl_Size resolvedPid, /* Resolved process id. */ + Tcl_Size resolvedPid, /* Resolved process id. */ int options, /* Options passed to Tcl_WaitPid. */ int *codePtr, /* If non-NULL, will receive either: * - 0 for normal exit. @@ -355,9 +355,8 @@ BuildProcessStatusObj( /* * Process still running, return empty obj. */ - Tcl_Obj *obj; - TclNewObj(obj); - return obj; + + return Tcl_NewObj(); } if (info->status == TCL_PROCESS_EXITED && info->code == 0) { /* @@ -400,7 +399,7 @@ ProcessListObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *list, *elemPtr; + Tcl_Obj *list; Tcl_HashEntry *entry; Tcl_HashSearch search; ProcessInfo *info; @@ -419,8 +418,8 @@ ProcessListObjCmd( for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); - TclNewIntObj(elemPtr, info->resolvedPid); - Tcl_ListObjAppendElement(interp, list, elemPtr); + Tcl_ListObjAppendElement(interp, list, + Tcl_NewWideIntObj(info->resolvedPid)); } Tcl_MutexUnlock(&infoTablesMutex); Tcl_SetObjResult(interp, list); @@ -451,12 +450,12 @@ ProcessStatusObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *dict, *elemPtr; - int index, options = WNOHANG; + Tcl_Obj *dict; + int options = WNOHANG; Tcl_HashEntry *entry; Tcl_HashSearch search; ProcessInfo *info; - int i, numPids; + Tcl_Size i, numPids; Tcl_Obj **pidObjs; int result; int pid; @@ -466,7 +465,7 @@ ProcessStatusObjCmd( }; enum switchesEnum { STATUS_WAIT, STATUS_LAST - }; + } index; while (objc > 1) { if (TclGetString(objv[1])[0] != '-') { @@ -477,7 +476,7 @@ ProcessStatusObjCmd( return TCL_ERROR; } ++objv; --objc; - if (STATUS_WAIT == (enum switchesEnum) index) { + if (STATUS_WAIT == index) { options = 0; } else { break; @@ -515,8 +514,7 @@ ProcessStatusObjCmd( * Add to result. */ - TclNewIntObj(elemPtr, info->resolvedPid); - Tcl_DictObjPut(interp, dict, elemPtr, + Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid), BuildProcessStatusObj(info)); } } @@ -566,8 +564,7 @@ ProcessStatusObjCmd( * Add to result. */ - TclNewIntObj(elemPtr, info->resolvedPid); - Tcl_DictObjPut(interp, dict, elemPtr, + Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid), BuildProcessStatusObj(info)); } } @@ -605,8 +602,7 @@ ProcessPurgeObjCmd( ProcessInfo *info; Tcl_Size i, numPids; Tcl_Obj **pidObjs; - int result; - int pid; + int result, pid; if (objc != 1 && objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); @@ -827,7 +823,7 @@ TclProcessCreated( * Allocate and initialize info structure. */ - info = (ProcessInfo *)ckalloc(sizeof(ProcessInfo)); + info = (ProcessInfo *)Tcl_Alloc(sizeof(ProcessInfo)); InitProcessInfo(info, pid, resolvedPid); /* diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index a823af5..83cd415 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -13,6 +13,7 @@ #include "tclInt.h" #include "tclRegexp.h" +#include "tclTomMath.h" #include <assert.h> /* @@ -70,7 +71,7 @@ typedef struct { char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular * expression patterns. NULL means that this * slot isn't used. Malloc-ed. */ - int patLengths[NUM_REGEXPS];/* Number of non-null characters in + size_t patLengths[NUM_REGEXPS];/* Number of non-null characters in * corresponding entry in patterns. -1 means * entry isn't used. */ struct TclRegexp *regexps[NUM_REGEXPS]; @@ -85,15 +86,15 @@ static Tcl_ThreadDataKey dataKey; */ static TclRegexp * CompileRegexp(Tcl_Interp *interp, const char *pattern, - int length, int flags); + size_t length, int flags); static void DupRegexpInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -static void FinalizeRegexp(ClientData clientData); +static void FinalizeRegexp(void *clientData); static void FreeRegexp(TclRegexp *regexpPtr); static void FreeRegexpInternalRep(Tcl_Obj *objPtr); static int RegExpExecUniChar(Tcl_Interp *interp, Tcl_RegExp re, - const Tcl_UniChar *uniString, int numChars, - int nmatches, int flags); + const Tcl_UniChar *uniString, size_t numChars, + size_t nmatches, int flags); static int SetRegexpFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); /* @@ -106,7 +107,8 @@ const Tcl_ObjType tclRegexpType = { FreeRegexpInternalRep, /* freeIntRepProc */ DupRegexpInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetRegexpFromAny /* setFromAnyProc */ + SetRegexpFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define RegexpSetInternalRep(objPtr, rePtr) \ @@ -155,7 +157,7 @@ Tcl_RegExpCompile( const char *pattern) /* String for which to produce compiled * regular expression. */ { - return (Tcl_RegExp) CompileRegexp(interp, pattern, (int) strlen(pattern), + return (Tcl_RegExp) CompileRegexp(interp, pattern, strlen(pattern), REG_ADVANCED); } @@ -190,7 +192,8 @@ Tcl_RegExpExec( * identifies beginning of larger string, so * that "^" won't match. */ { - int flags, result, numChars; + int flags, result; + size_t numChars; TclRegexp *regexp = (TclRegexp *) re; Tcl_DString ds; const Tcl_UniChar *ustr; @@ -218,9 +221,9 @@ Tcl_RegExpExec( */ Tcl_DStringInit(&ds); - ustr = Tcl_UtfToUniCharDString(text, -1, &ds); + ustr = Tcl_UtfToUniCharDString(text, TCL_INDEX_NONE, &ds); numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar); - result = RegExpExecUniChar(interp, re, ustr, numChars, -1 /* nmatches */, + result = RegExpExecUniChar(interp, re, ustr, numChars, TCL_INDEX_NONE /* nmatches */, flags); Tcl_DStringFree(&ds); @@ -250,7 +253,7 @@ void Tcl_RegExpRange( Tcl_RegExp re, /* Compiled regular expression that has been * passed to Tcl_RegExpExec. */ - int index, /* 0 means give the range of the entire match, + Tcl_Size index, /* 0 means give the range of the entire match, * > 0 means give the range of a matching * subrange. */ const char **startPtr, /* Store address of first character in @@ -261,9 +264,9 @@ Tcl_RegExpRange( TclRegexp *regexpPtr = (TclRegexp *) re; const char *string; - if ((size_t) index > regexpPtr->re.re_nsub) { + if (index < 0 || (size_t) index > regexpPtr->re.re_nsub) { *startPtr = *endPtr = NULL; - } else if (regexpPtr->matches[index].rm_so == TCL_INDEX_NONE) { + } else if (regexpPtr->matches[index].rm_so == (size_t) -1) { *startPtr = *endPtr = NULL; } else { if (regexpPtr->objPtr) { @@ -271,8 +274,8 @@ Tcl_RegExpRange( } else { string = regexpPtr->string; } - *startPtr = TclUtfAtIndex(string, regexpPtr->matches[index].rm_so); - *endPtr = TclUtfAtIndex(string, regexpPtr->matches[index].rm_eo); + *startPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_so); + *endPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_eo); } } @@ -302,9 +305,8 @@ RegExpExecUniChar( Tcl_RegExp re, /* Compiled regular expression; returned by a * previous call to Tcl_GetRegExpFromObj */ const Tcl_UniChar *wString, /* String against which to match re. */ - int numChars, /* Length of Tcl_UniChar string (must be - * >=0). */ - int nmatches, /* How many subexpression matches (counting + size_t numChars, /* Length of Tcl_UniChar string. */ + size_t nm, /* How many subexpression matches (counting * the whole match as subexpression 0) are of * interest. -1 means "don't know". */ int flags) /* Regular expression flags. */ @@ -312,13 +314,12 @@ RegExpExecUniChar( int status; TclRegexp *regexpPtr = (TclRegexp *) re; size_t last = regexpPtr->re.re_nsub + 1; - size_t nm = last; - if (nmatches >= 0 && (size_t) nmatches < nm) { - nm = (size_t) nmatches; + if (nm >= last) { + nm = last; } - status = TclReExec(®expPtr->re, wString, (size_t) numChars, + status = TclReExec(®expPtr->re, wString, numChars, ®expPtr->details, nm, regexpPtr->matches, flags); /* @@ -362,23 +363,23 @@ void TclRegExpRangeUniChar( Tcl_RegExp re, /* Compiled regular expression that has been * passed to Tcl_RegExpExec. */ - int index, /* 0 means give the range of the entire match, + Tcl_Size index, /* 0 means give the range of the entire match, * > 0 means give the range of a matching - * subrange, TCL_INDEX_NONE means the range of the + * subrange, -1 means the range of the * rm_extend field. */ - int *startPtr, /* Store address of first character in + Tcl_Size *startPtr, /* Store address of first character in * (sub-)range here. */ - int *endPtr) /* Store address of character just after last + Tcl_Size *endPtr) /* Store address of character just after last * in (sub-)range here. */ { TclRegexp *regexpPtr = (TclRegexp *) re; - if ((regexpPtr->flags®_EXPECT) && (index == TCL_INDEX_NONE)) { + if ((regexpPtr->flags®_EXPECT) && (index == -1)) { *startPtr = regexpPtr->details.rm_extend.rm_so; *endPtr = regexpPtr->details.rm_extend.rm_eo; - } else if ((size_t) index > regexpPtr->re.re_nsub) { - *startPtr = TCL_INDEX_NONE; - *endPtr = TCL_INDEX_NONE; + } else if (index < 0 || (size_t) index > regexpPtr->re.re_nsub + 1) { + *startPtr = -1; + *endPtr = -1; } else { *startPtr = regexpPtr->matches[index].rm_so; *endPtr = regexpPtr->matches[index].rm_eo; @@ -442,16 +443,16 @@ Tcl_RegExpExecObj( * returned by previous call to * Tcl_GetRegExpFromObj. */ Tcl_Obj *textObj, /* Text against which to match re. */ - int offset, /* Character index that marks where matching + Tcl_Size offset, /* Character index that marks where matching * should begin. */ - int nmatches, /* How many subexpression matches (counting + Tcl_Size nmatches, /* How many subexpression matches (counting * the whole match as subexpression 0) are of * interest. -1 means all of them. */ int flags) /* Regular expression execution flags. */ { TclRegexp *regexpPtr = (TclRegexp *) re; Tcl_UniChar *udata; - int length; + Tcl_Size length; int reflags = regexpPtr->flags; #define TCL_REG_GLOBOK_FLAGS \ (TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE) @@ -482,7 +483,7 @@ Tcl_RegExpExecObj( regexpPtr->string = NULL; regexpPtr->objPtr = textObj; - udata = TclGetUnicodeFromObj(textObj, &length); + udata = Tcl_GetUnicodeFromObj(textObj, &length); if (offset > length) { offset = length; @@ -594,14 +595,14 @@ Tcl_GetRegExpFromObj( * expression. */ int flags) /* Regular expression compilation flags. */ { - int length; + Tcl_Size length; TclRegexp *regexpPtr; const char *pattern; RegexpGetInternalRep(objPtr, regexpPtr); if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) { - pattern = TclGetStringFromObj(objPtr, &length); + pattern = Tcl_GetStringFromObj(objPtr, &length); regexpPtr = CompileRegexp(interp, pattern, length, flags); if (regexpPtr == NULL) { @@ -858,7 +859,7 @@ static TclRegexp * CompileRegexp( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ const char *string, /* The regexp to compile (UTF-8). */ - int length, /* The length of the string in bytes. */ + size_t length, /* The length of the string in bytes. */ int flags) /* Compilation flags. */ { TclRegexp *regexpPtr; @@ -916,11 +917,11 @@ CompileRegexp( * This is a new expression, so compile it and add it to the cache. */ - regexpPtr = (TclRegexp*)ckalloc(sizeof(TclRegexp)); + regexpPtr = (TclRegexp*)Tcl_Alloc(sizeof(TclRegexp)); regexpPtr->objPtr = NULL; regexpPtr->string = NULL; - regexpPtr->details.rm_extend.rm_so = -1; - regexpPtr->details.rm_extend.rm_eo = -1; + regexpPtr->details.rm_extend.rm_so = TCL_INDEX_NONE; + regexpPtr->details.rm_extend.rm_eo = TCL_INDEX_NONE; /* * Get the up-to-date string representation and map to unicode. @@ -943,7 +944,7 @@ CompileRegexp( * Clean up and report errors in the interpreter, if possible. */ - ckfree(regexpPtr); + Tcl_Free(regexpPtr); if (interp) { TclRegError(interp, "couldn't compile regular expression pattern: ", status); @@ -971,7 +972,7 @@ CompileRegexp( */ regexpPtr->matches = - (regmatch_t*)ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); + (regmatch_t*)Tcl_Alloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); /* * Initialize the refcount to one initially, since it is in the cache. @@ -990,14 +991,14 @@ CompileRegexp( if (oldRegexpPtr->refCount-- <= 1) { FreeRegexp(oldRegexpPtr); } - ckfree(tsdPtr->patterns[NUM_REGEXPS-1]); + Tcl_Free(tsdPtr->patterns[NUM_REGEXPS-1]); } for (i = NUM_REGEXPS - 2; i >= 0; i--) { tsdPtr->patterns[i+1] = tsdPtr->patterns[i]; tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i]; tsdPtr->regexps[i+1] = tsdPtr->regexps[i]; } - tsdPtr->patterns[0] = (char *)ckalloc(length + 1); + tsdPtr->patterns[0] = (char *)Tcl_Alloc(length + 1); memcpy(tsdPtr->patterns[0], string, length + 1); tsdPtr->patLengths[0] = length; tsdPtr->regexps[0] = regexpPtr; @@ -1030,9 +1031,9 @@ FreeRegexp( TclDecrRefCount(regexpPtr->globObjPtr); } if (regexpPtr->matches) { - ckfree(regexpPtr->matches); + Tcl_Free(regexpPtr->matches); } - ckfree(regexpPtr); + Tcl_Free(regexpPtr); } /* @@ -1053,7 +1054,7 @@ FreeRegexp( static void FinalizeRegexp( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { int i; TclRegexp *regexpPtr; @@ -1064,7 +1065,7 @@ FinalizeRegexp( if (regexpPtr->refCount-- <= 1) { FreeRegexp(regexpPtr); } - ckfree(tsdPtr->patterns[i]); + Tcl_Free(tsdPtr->patterns[i]); tsdPtr->patterns[i] = NULL; } diff --git a/generic/tclResolve.c b/generic/tclResolve.c index ff88ffd..f321515 100644 --- a/generic/tclResolve.c +++ b/generic/tclResolve.c @@ -101,9 +101,9 @@ Tcl_AddInterpResolvers( * list, so that it overrides existing schemes. */ - resPtr = (ResolverScheme *)ckalloc(sizeof(ResolverScheme)); + resPtr = (ResolverScheme *)Tcl_Alloc(sizeof(ResolverScheme)); len = strlen(name) + 1; - resPtr->name = (char *)ckalloc(len); + resPtr->name = (char *)Tcl_Alloc(len); memcpy(resPtr->name, name, len); resPtr->cmdResProc = cmdProc; resPtr->varResProc = varProc; @@ -225,8 +225,8 @@ Tcl_RemoveInterpResolvers( } *prevPtrPtr = resPtr->nextPtr; - ckfree(resPtr->name); - ckfree(resPtr); + Tcl_Free(resPtr->name); + Tcl_Free(resPtr); return 1; } diff --git a/generic/tclResult.c b/generic/tclResult.c index 91ddc6e..8ab66ae 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -10,6 +10,7 @@ */ #include "tclInt.h" +#include <assert.h> /* * Indices of the standard return options dictionary keys. @@ -25,11 +26,8 @@ enum returnKeys { */ static Tcl_Obj ** GetKeys(void); -static void ReleaseKeys(ClientData clientData); +static void ReleaseKeys(void *clientData); static void ResetObjResult(Interp *iPtr); -#ifndef TCL_NO_DEPRECATED -static void SetupAppendBuffer(Interp *iPtr, int newSpace); -#endif /* !TCL_NO_DEPRECATED */ /* * This structure is used to take a snapshot of the interpreter state in @@ -77,7 +75,7 @@ Tcl_SaveInterpState( int status) /* status code for current operation */ { Interp *iPtr = (Interp *) interp; - InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState)); + InterpState *statePtr = (InterpState *)Tcl_Alloc(sizeof(InterpState)); statePtr->status = status; statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED; @@ -207,359 +205,43 @@ Tcl_DiscardInterpState( Tcl_DecrRefCount(statePtr->errorStack); } Tcl_DecrRefCount(statePtr->objResult); - ckfree(statePtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SaveResult -- - * - * Takes a snapshot of the current result state of the interpreter. The - * snapshot can be restored at any point by Tcl_RestoreResult. Note that - * this routine does not preserve the errorCode, errorInfo, or flags - * fields so it should not be used if an error is in progress. - * - * Once a snapshot is saved, it must be restored by calling - * Tcl_RestoreResult, or discarded by calling Tcl_DiscardResult. - * - * Results: - * None. - * - * Side effects: - * Resets the interpreter result. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_SaveResult -void -Tcl_SaveResult( - Tcl_Interp *interp, /* Interpreter to save. */ - Tcl_SavedResult *statePtr) /* Pointer to state structure. */ -{ - Interp *iPtr = (Interp *) interp; - - /* - * Move the result object into the save state. Note that we don't need to - * change its refcount because we're moving it, not adding a new - * reference. Put an empty object into the interpreter. - */ - - statePtr->objResultPtr = iPtr->objResultPtr; - TclNewObj(iPtr->objResultPtr); - Tcl_IncrRefCount(iPtr->objResultPtr); - - /* - * Save the string result. - */ - - statePtr->freeProc = iPtr->freeProc; - if (iPtr->result == iPtr->resultSpace) { - /* - * Copy the static string data out of the interp buffer. - */ - - statePtr->result = statePtr->resultSpace; - strcpy(statePtr->result, iPtr->result); - statePtr->appendResult = NULL; - } else if (iPtr->result == iPtr->appendResult) { - /* - * Move the append buffer out of the interp. - */ - - statePtr->appendResult = iPtr->appendResult; - statePtr->appendAvl = iPtr->appendAvl; - statePtr->appendUsed = iPtr->appendUsed; - statePtr->result = statePtr->appendResult; - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - iPtr->appendUsed = 0; - } else { - /* - * Move the dynamic or static string out of the interpreter. - */ - - statePtr->result = iPtr->result; - statePtr->appendResult = NULL; - } - - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; - iPtr->freeProc = 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RestoreResult -- - * - * Restores the state of the interpreter to a snapshot taken by - * Tcl_SaveResult. After this call, the token for the interpreter state - * is no longer valid. - * - * Results: - * None. - * - * Side effects: - * Restores the interpreter result. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_RestoreResult -void -Tcl_RestoreResult( - Tcl_Interp *interp, /* Interpreter being restored. */ - Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ -{ - Interp *iPtr = (Interp *) interp; - - Tcl_ResetResult(interp); - - /* - * Restore the string result. - */ - - iPtr->freeProc = statePtr->freeProc; - if (statePtr->result == statePtr->resultSpace) { - /* - * Copy the static string data into the interp buffer. - */ - - iPtr->result = iPtr->resultSpace; - strcpy(iPtr->result, statePtr->result); - } else if (statePtr->result == statePtr->appendResult) { - /* - * Move the append buffer back into the interp. - */ - - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - } - - iPtr->appendResult = statePtr->appendResult; - iPtr->appendAvl = statePtr->appendAvl; - iPtr->appendUsed = statePtr->appendUsed; - iPtr->result = iPtr->appendResult; - } else { - /* - * Move the dynamic or static string back into the interpreter. - */ - - iPtr->result = statePtr->result; - } - - /* - * Restore the object result. - */ - - Tcl_DecrRefCount(iPtr->objResultPtr); - iPtr->objResultPtr = statePtr->objResultPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DiscardResult -- - * - * Frees the memory associated with an interpreter snapshot taken by - * Tcl_SaveResult. If the snapshot is not restored, this function must be - * called to discard it, or the memory will be lost. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_DiscardResult -void -Tcl_DiscardResult( - Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ -{ - TclDecrRefCount(statePtr->objResultPtr); - - if (statePtr->result == statePtr->appendResult) { - ckfree(statePtr->appendResult); - } else if (statePtr->freeProc == TCL_DYNAMIC) { - ckfree(statePtr->result); - } else if (statePtr->freeProc) { - statePtr->freeProc(statePtr->result); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetResult -- - * - * Arrange for "result" to be the Tcl return value. - * - * Results: - * None. - * - * Side effects: - * interp->result is left pointing either to "result" or to a copy of it. - * Also, the object result is reset. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetResult( - Tcl_Interp *interp, /* Interpreter with which to associate the - * return value. */ - char *result, /* Value to be returned. If NULL, the result - * is set to an empty string. */ - Tcl_FreeProc *freeProc) /* Gives information about the string: - * TCL_STATIC, TCL_VOLATILE, or the address of - * a Tcl_FreeProc such as free. */ -{ - Interp *iPtr = (Interp *) interp; - Tcl_FreeProc *oldFreeProc = iPtr->freeProc; - char *oldResult = iPtr->result; - - if (result == NULL) { - iPtr->resultSpace[0] = 0; - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - } else if (freeProc == TCL_VOLATILE) { - int length = strlen(result); - - if (length > TCL_RESULT_SIZE) { - iPtr->result = (char *)ckalloc(length + 1); - iPtr->freeProc = TCL_DYNAMIC; - } else { - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - } - memcpy(iPtr->result, result, length+1); - } else { - iPtr->result = (char *) result; - iPtr->freeProc = freeProc; - } - - /* - * If the old result was dynamically-allocated, free it up. Do it here, - * rather than at the beginning, in case the new result value was part of - * the old result value. - */ - - if (oldFreeProc != 0) { - if (oldFreeProc == TCL_DYNAMIC) { - ckfree(oldResult); - } else { - oldFreeProc(oldResult); - } - } - - /* - * Reset the object result since we just set the string result. - */ - - ResetObjResult(iPtr); -} -#endif /* !TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetStringResult -- - * - * Returns an interpreter's result value as a string. - * - * Results: - * The interpreter's result as a string. - * - * Side effects: - * If the string result is empty, the object result is moved to the - * string result, then the object result is reset. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_GetStringResult -const char * -Tcl_GetStringResult( - Tcl_Interp *interp)/* Interpreter whose result to return. */ -{ -#ifndef TCL_NO_DEPRECATED - Interp *iPtr = (Interp *) interp; - /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. - */ - - if (*(iPtr->result) == 0) { - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); - } - return iPtr->result; -#else - return TclGetString(Tcl_GetObjResult(interp)); -#endif + Tcl_Free(statePtr); } /* *---------------------------------------------------------------------- * * Tcl_SetObjResult -- - * - * Arrange for objPtr to be an interpreter's result value. + * Makes objPtr the interpreter's result value. * * Results: * None. * * Side effects: - * interp->objResultPtr is left pointing to the object referenced by - * objPtr. The object's reference count is incremented since there is now - * a new reference to it. The reference count for any old objResultPtr - * value is decremented. Also, the string result is reset. + * Stores objPtr interp->objResultPtr, increments its reference count, and + * decrements the reference count of any existing interp->objResultPtr. + * + * The string result is reset. * *---------------------------------------------------------------------- */ void Tcl_SetObjResult( - Tcl_Interp *interp, /* Interpreter with which to associate the - * return object value. */ - Tcl_Obj *objPtr) /* Tcl object to be returned. If NULL, the obj - * result is made an empty string object. */ + Tcl_Interp *interp, /* Interpreter to set the result for. */ + Tcl_Obj *objPtr) /* The value to set as the result. */ { Interp *iPtr = (Interp *) interp; Tcl_Obj *oldObjResult = iPtr->objResultPtr; - - iPtr->objResultPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ - - /* - * We wait until the end to release the old object result, in case we are - * setting the result to itself. - */ - - TclDecrRefCount(oldObjResult); - -#ifndef TCL_NO_DEPRECATED - /* - * Reset the string result since we just set the result object. - */ - - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; + if (objPtr == oldObjResult) { + /* This should be impossible */ + assert(objPtr->refCount != 0); + return; + } else { + iPtr->objResultPtr = objPtr; + Tcl_IncrRefCount(objPtr); + TclDecrRefCount(oldObjResult); } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; -#endif } /* @@ -588,75 +270,13 @@ Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { Interp *iPtr = (Interp *) interp; -#ifndef TCL_NO_DEPRECATED - Tcl_Obj *objResultPtr; - int length; - - /* - * If the string result is non-empty, move the string result to the object - * result, then reset the string result. - */ - - if (iPtr->result[0] != 0) { - ResetObjResult(iPtr); - objResultPtr = iPtr->objResultPtr; - length = strlen(iPtr->result); - TclInitStringRep(objResultPtr, iPtr->result, length); - - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->result[0] = 0; - } -#endif /* !TCL_NO_DEPRECATED */ return iPtr->objResultPtr; } /* *---------------------------------------------------------------------- * - * Tcl_AppendResultVA -- - * - * Append a variable number of strings onto the interpreter's result. - * - * Results: - * None. - * - * Side effects: - * The result of the interpreter given by the first argument is extended - * by the strings in the va_list (up to a terminating NULL argument). - * - * If the string result is non-empty, the object result forced to be a - * duplicate of it first. There will be a string result afterwards. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AppendResultVA( - Tcl_Interp *interp, /* Interpreter with which to associate the - * return value. */ - va_list argList) /* Variable argument list. */ -{ - Tcl_Obj *objPtr = Tcl_GetObjResult(interp); - - if (Tcl_IsShared(objPtr)) { - objPtr = Tcl_DuplicateObj(objPtr); - } - Tcl_AppendStringsToObjVA(objPtr, argList); - Tcl_SetObjResult(interp, objPtr); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_AppendResult -- * * Append a variable number of strings onto the interpreter's result. @@ -680,9 +300,23 @@ Tcl_AppendResult( Tcl_Interp *interp, ...) { va_list argList; + Tcl_Obj *objPtr; va_start(argList, interp); - Tcl_AppendResultVA(interp, argList); + objPtr = Tcl_GetObjResult(interp); + + if (Tcl_IsShared(objPtr)) { + objPtr = Tcl_DuplicateObj(objPtr); + } + while (1) { + const char *bytes = va_arg(argList, char *); + + if (bytes == NULL) { + break; + } + Tcl_AppendToObj(objPtr, bytes, -1); + } + Tcl_SetObjResult(interp, objPtr); va_end(argList); } @@ -717,201 +351,25 @@ Tcl_AppendElement( * to result. */ { Interp *iPtr = (Interp *) interp; -#ifdef TCL_NO_DEPRECATED Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1); Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr); const char *bytes; + Tcl_Size length; if (Tcl_IsShared(iPtr->objResultPtr)) { Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); } - bytes = TclGetString(iPtr->objResultPtr); - if (TclNeedSpace(bytes, bytes+iPtr->objResultPtr->length)) { + bytes = Tcl_GetStringFromObj(iPtr->objResultPtr, &length); + if (TclNeedSpace(bytes, bytes + length)) { Tcl_AppendToObj(iPtr->objResultPtr, " ", 1); } Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); Tcl_DecrRefCount(listPtr); -#else - char *dst; - int size; - int flags; - int quoteHash = 1; - - /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - - /* - * See how much space is needed, and grow the append buffer if needed to - * accommodate the list element. - */ - - size = Tcl_ScanElement(element, &flags) + 1; - if ((iPtr->result != iPtr->appendResult) - || (iPtr->appendResult[iPtr->appendUsed] != 0) - || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { - SetupAppendBuffer(iPtr, size+iPtr->appendUsed); - } - - /* - * Convert the string into a list element and copy it to the buffer that's - * forming, with a space separator if needed. - */ - - dst = iPtr->appendResult + iPtr->appendUsed; - if (TclNeedSpace(iPtr->appendResult, dst)) { - iPtr->appendUsed++; - *dst = ' '; - dst++; - - /* - * If we need a space to separate this element from preceding stuff, - * then this element will not lead a list, and need not have it's - * leading '#' quoted. - */ - quoteHash = 0; - } else { - while ((--dst >= iPtr->appendResult) && TclIsSpaceProcM(*dst)) { - } - quoteHash = !TclNeedSpace(iPtr->appendResult, dst+1); - } - dst = iPtr->appendResult + iPtr->appendUsed; - if (!quoteHash) { - flags |= TCL_DONT_QUOTE_HASH; - } - - iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); -#endif /* !TCL_NO_DEPRECATED */ -} - -/* - *---------------------------------------------------------------------- - * - * SetupAppendBuffer -- - * - * This function makes sure that there is an append buffer properly - * initialized, if necessary, from the interpreter's result, and that it - * has at least enough room to accommodate newSpace new bytes of - * information. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -static void -SetupAppendBuffer( - Interp *iPtr, /* Interpreter whose result is being set up. */ - int newSpace) /* Make sure that at least this many bytes of - * new information may be added. */ -{ - int totalSpace; - - /* - * Make the append buffer larger, if that's necessary, then copy the - * result into the append buffer and make the append buffer the official - * Tcl result. - */ - - if (iPtr->result != iPtr->appendResult) { - /* - * If an oversized buffer was used recently, then free it up so we go - * back to a smaller buffer. This avoids tying up memory forever after - * a large operation. - */ - - if (iPtr->appendAvl > 500) { - ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - } - iPtr->appendUsed = strlen(iPtr->result); - } else if (iPtr->result[iPtr->appendUsed] != 0) { - /* - * Most likely someone has modified a result created by - * Tcl_AppendResult et al. so that it has a different size. Just - * recompute the size. - */ - - iPtr->appendUsed = strlen(iPtr->result); - } - - totalSpace = newSpace + iPtr->appendUsed; - if (totalSpace >= iPtr->appendAvl) { - char *newSpacePtr; - - if (totalSpace < 100) { - totalSpace = 200; - } else { - totalSpace *= 2; - } - newSpacePtr = (char *)ckalloc(totalSpace); - strcpy(newSpacePtr, iPtr->result); - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - } - iPtr->appendResult = newSpacePtr; - iPtr->appendAvl = totalSpace; - } else if (iPtr->result != iPtr->appendResult) { - strcpy(iPtr->appendResult, iPtr->result); - } - - Tcl_FreeResult((Tcl_Interp *) iPtr); - iPtr->result = iPtr->appendResult; } /* *---------------------------------------------------------------------- * - * Tcl_FreeResult -- - * - * This function frees up the memory associated with an interpreter's - * string result. It also resets the interpreter's result object. - * Tcl_FreeResult is most commonly used when a function is about to - * replace one result value with another. - * - * Results: - * None. - * - * Side effects: - * Frees the memory associated with interp's string result and sets - * interp->freeProc to zero, but does not change interp->result or clear - * error state. Resets interp's result object to an unshared empty - * object. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FreeResult( - Tcl_Interp *interp)/* Interpreter for which to free result. */ -{ - Interp *iPtr = (Interp *) interp; - - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - - ResetObjResult(iPtr); -} -#endif /* !TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_ResetResult -- * * This function resets both the interpreter's string and object results. @@ -935,18 +393,6 @@ Tcl_ResetResult( Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); -#ifndef TCL_NO_DEPRECATED - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; -#endif /* !TCL_NO_DEPRECATED */ if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { @@ -1008,7 +454,7 @@ ResetObjResult( } else { if (objResultPtr->bytes != &tclEmptyString) { if (objResultPtr->bytes) { - ckfree(objResultPtr->bytes); + Tcl_Free(objResultPtr->bytes); } objResultPtr->bytes = &tclEmptyString; objResultPtr->length = 0; @@ -1020,7 +466,7 @@ ResetObjResult( /* *---------------------------------------------------------------------- * - * Tcl_SetErrorCodeVA -- + * Tcl_SetErrorCode -- * * This function is called to record machine-readable information about * an error that is about to be returned. @@ -1037,10 +483,10 @@ ResetObjResult( */ void -Tcl_SetErrorCodeVA( - Tcl_Interp *interp, /* Interpreter in which to set errorCode */ - va_list argList) /* Variable argument list. */ +Tcl_SetErrorCode( + Tcl_Interp *interp, ...) { + va_list argList; Tcl_Obj *errorObj; /* @@ -1048,7 +494,14 @@ Tcl_SetErrorCodeVA( * errorCode field as list elements. */ + va_start(argList, interp); TclNewObj(errorObj); + + /* + * Scan through the arguments one at a time, appending them to the + * errorCode field as list elements. + */ + while (1) { char *elem = va_arg(argList, char *); @@ -1058,40 +511,6 @@ Tcl_SetErrorCodeVA( Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1)); } Tcl_SetObjErrorCode(interp, errorObj); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetErrorCode -- - * - * This function is called to record machine-readable information about - * an error that is about to be returned. - * - * Results: - * None. - * - * Side effects: - * The errorCode field of the interp is modified to hold all of the - * arguments to this function, in a list form with each argument becoming - * one element of the list. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetErrorCode( - Tcl_Interp *interp, ...) -{ - va_list argList; - - /* - * Scan through the arguments one at a time, appending them to the - * errorCode field as list elements. - */ - - va_start(argList, interp); - Tcl_SetErrorCodeVA(interp, argList); va_end(argList); } @@ -1137,7 +556,6 @@ Tcl_SetObjErrorCode( *---------------------------------------------------------------------- */ -#undef Tcl_GetErrorLine int Tcl_GetErrorLine( Tcl_Interp *interp) @@ -1155,7 +573,6 @@ Tcl_GetErrorLine( *---------------------------------------------------------------------- */ -#undef Tcl_SetErrorLine void Tcl_SetErrorLine( Tcl_Interp *interp, @@ -1239,7 +656,7 @@ GetKeys(void) static void ReleaseKeys( - ClientData clientData) + void *clientData) { Tcl_Obj **keys = (Tcl_Obj **)clientData; int i; @@ -1301,8 +718,10 @@ TclProcessReturn( Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { - (void) TclGetString(valuePtr); - if (valuePtr->length) { + Tcl_Size length; + + (void) Tcl_GetStringFromObj(valuePtr, &length); + if (length) { iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; @@ -1311,7 +730,7 @@ TclProcessReturn( Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], &valuePtr); if (valuePtr != NULL) { - int len, valueObjc; + Tcl_Size len, valueObjc; Tcl_Obj **valueObjv; if (Tcl_IsShared(iPtr->errorStack)) { @@ -1388,7 +807,7 @@ TclProcessReturn( int TclMergeReturnOptions( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[], /* Argument objects. */ Tcl_Obj **optionsPtrPtr, /* If not NULL, points to space for a (Tcl_Obj * *) where the pointer to the merged return @@ -1488,7 +907,7 @@ TclMergeReturnOptions( Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORCODE], &valuePtr); if (valuePtr != NULL) { - int length; + Tcl_Size length; if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length )) { /* @@ -1510,9 +929,9 @@ TclMergeReturnOptions( Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr); if (valuePtr != NULL) { - int length; + Tcl_Size length; - if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length )) { + if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length)) { /* * Value is not a list, which is illegal for -errorstack. */ @@ -1678,7 +1097,8 @@ Tcl_SetReturnOptions( Tcl_Interp *interp, Tcl_Obj *options) { - int objc, level, code; + Tcl_Size objc; + int level, code; Tcl_Obj **objv, *mergedOpts; Tcl_IncrRefCount(options); diff --git a/generic/tclScan.c b/generic/tclScan.c index 4c141ab..3dcc9ea 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -11,6 +11,7 @@ #include "tclInt.h" #include "tclTomMath.h" +#include <assert.h> /* * Flag values used by Tcl_ScanObjCmd. @@ -104,9 +105,9 @@ BuildCharSet( end += TclUtfToUniChar(end, &ch); } - cset->chars = (Tcl_UniChar *)ckalloc(sizeof(Tcl_UniChar) * (end - format - 1)); + cset->chars = (Tcl_UniChar *)Tcl_Alloc(sizeof(Tcl_UniChar) * (end - format - 1)); if (nranges > 0) { - cset->ranges = (Range *)ckalloc(sizeof(Range) * nranges); + cset->ranges = (Range *)Tcl_Alloc(sizeof(Range) * nranges); } else { cset->ranges = NULL; } @@ -226,9 +227,9 @@ static void ReleaseCharSet( CharSet *cset) { - ckfree(cset->chars); + Tcl_Free(cset->chars); if (cset->ranges) { - ckfree(cset->ranges); + Tcl_Free(cset->ranges); } } @@ -258,7 +259,7 @@ ValidateFormat( int *totalSubs) /* The number of variables that will be * required. */ { - int gotXpg, gotSequential, value, i, flags; + int gotXpg, gotSequential, i, flags; char *end; Tcl_UniChar ch = 0; int objIndex, xpgSize, nspace = numVars; @@ -306,7 +307,8 @@ ValidateFormat( * format string. */ - unsigned long ul = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ + /* assert(value is >= 0) because of the isdigit() check above */ + unsigned long long ull = strtoull(format-1, &end, 10); /* INTL: "C" locale. */ if (*end != '$') { goto notXpg; } @@ -316,20 +318,22 @@ ValidateFormat( if (gotSequential) { goto mixedXPG; } - if (ul == 0 || ul >= INT_MAX) { + /* >=INT_MAX because 9.0 does not support more than INT_MAX-1 args */ + if (ull == 0 || ull >= INT_MAX) { goto badIndex; } - objIndex = (int) ul - 1; + objIndex = (int) ull - 1; if (numVars && (objIndex >= numVars)) { goto badIndex; - } else if (numVars == 0) { + } + else if (numVars == 0) { /* * In the case where no vars are specified, the user can * specify %9999$ legally, so we have to consider special - * rules for growing the assign array. 'ul' is guaranteed + * rules for growing the assign array. 'ull' is guaranteed * to be > 0 and < INT_MAX as per checks above. */ - xpgSize = (xpgSize > (int)ul) ? xpgSize : (int)ul; + xpgSize = (xpgSize > (int)ull) ? xpgSize : (int)ull; } goto xpgCheckDone; } @@ -351,7 +355,22 @@ ValidateFormat( */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - value = strtoul(format-1, (char **) &format, 10); /* INTL: "C" locale. */ + /* Note ull >= 0 because of isdigit check above */ + unsigned long long ull; + ull = strtoull( + format - 1, (char **)&format, 10); /* INTL: "C" locale. */ + /* Note >=, not >, to leave room for a nul */ + if (ull >= TCL_SIZE_MAX) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("specified field width %" TCL_LL_MODIFIER + "u exceeds limit %" TCL_SIZE_MODIFIER "d.", + ull, + (Tcl_Size)TCL_SIZE_MAX-1)); + Tcl_SetErrorCode( + interp, "TCL", "FORMAT", "WIDTHLIMIT", (void *)NULL); + goto error; + } flags |= SCAN_WIDTH; format += TclUtfToUniChar(format, &ch); } @@ -476,7 +495,7 @@ ValidateFormat( * guaranteed to be at least one larger than objIndex. */ - value = nspace; + int nspaceOrig = nspace; if (xpgSize) { nspace = xpgSize; } else { @@ -484,7 +503,7 @@ ValidateFormat( } nassign = (int *)TclStackRealloc(interp, nassign, nspace * sizeof(int)); - for (i = value; i < nspace; i++) { + for (i = nspaceOrig; i < nspace; i++) { nassign[i] = 0; } } @@ -567,7 +586,7 @@ ValidateFormat( int Tcl_ScanObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -578,7 +597,8 @@ Tcl_ScanObjCmd( long value; const char *string, *end, *baseString; char op = 0; - int width, underflow = 0; + int underflow = 0; + Tcl_Size width; Tcl_WideInt wideValue; Tcl_UniChar ch = 0, sch = 0; Tcl_Obj **objs = NULL, *objPtr = NULL; @@ -590,7 +610,7 @@ Tcl_ScanObjCmd( return TCL_ERROR; } - format = Tcl_GetString(objv[2]); + format = TclGetString(objv[2]); numVars = objc-3; /* @@ -606,13 +626,13 @@ Tcl_ScanObjCmd( */ if (totalVars > 0) { - objs = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * totalVars); + objs = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * totalVars); for (i = 0; i < totalVars; i++) { objs[i] = NULL; } } - string = Tcl_GetString(objv[1]); + string = TclGetString(objv[1]); baseString = string; /* @@ -673,6 +693,7 @@ Tcl_ScanObjCmd( format += TclUtfToUniChar(format, &ch); } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ char *formatEnd; + /* Note currently XPG3 range limited to INT_MAX to match type of objc */ value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */ if (*formatEnd == '$') { format = formatEnd+1; @@ -686,7 +707,10 @@ Tcl_ScanObjCmd( */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - width = (int) strtoul(format-1, (char **) &format, 10);/* INTL: "C" locale. */ + unsigned long long ull; + ull = strtoull(format-1, (char **) &format, 10); /* INTL: "C" locale. */ + assert(ull <= TCL_SIZE_MAX); /* Else ValidateFormat should've error'ed */ + width = (Tcl_Size)ull; format += TclUtfToUniChar(format, &ch); } else { width = 0; @@ -918,7 +942,7 @@ Tcl_ScanObjCmd( break; } if (flags & SCAN_LONGER) { - if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { + if (TclGetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { if (TclGetString(objPtr)[0] == '-') { wideValue = WIDE_MIN; } else { @@ -952,7 +976,7 @@ Tcl_ScanObjCmd( if (res == TCL_ERROR) { if (objs != NULL) { - ckfree(objs); + Tcl_Free(objs); } Tcl_DecrRefCount(objPtr); Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -1070,27 +1094,40 @@ Tcl_ScanObjCmd( } else { /* * Here no vars were specified, we want a list returned (inline scan) + * We create an empty Tcl_Obj to fill missing values rather than + * allocating a new Tcl_Obj every time. See test scan-bigdata-XX. */ - + Tcl_Obj *emptyObj; + TclNewObj(emptyObj); + Tcl_IncrRefCount(emptyObj); TclNewObj(objPtr); - for (i = 0; i < totalVars; i++) { + for (i = 0; code == TCL_OK && i < totalVars; i++) { if (objs[i] != NULL) { - Tcl_ListObjAppendElement(NULL, objPtr, objs[i]); + code = Tcl_ListObjAppendElement(interp, objPtr, objs[i]); Tcl_DecrRefCount(objs[i]); } else { - Tcl_Obj *obj; /* * More %-specifiers than matching chars, so we just spit out * empty strings for these. */ - TclNewObj(obj); - Tcl_ListObjAppendElement(NULL, objPtr, obj); + code = Tcl_ListObjAppendElement(interp, objPtr, emptyObj); + } + } + Tcl_DecrRefCount(emptyObj); + if (code != TCL_OK) { + /* If error'ed out, free up remaining. i contains last index freed */ + while (++i < totalVars) { + if (objs[i] != NULL) { + Tcl_DecrRefCount(objs[i]); + } } + Tcl_DecrRefCount(objPtr); + objPtr = NULL; } } if (objs != NULL) { - ckfree(objs); + Tcl_Free(objs); } if (code == TCL_OK) { if (underflow && (nconversions == 0)) { diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index f23b23b..a3bc2d4 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -386,9 +386,9 @@ static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w); * the first byte to be scanned. If bytes is NULL, then objPtr must be * non-NULL, and the string representation of objPtr will be scanned * (generated first, if necessary). The numBytes argument determines the - * number of bytes to be scanned. If numBytes is negative, the first NUL - * byte encountered will terminate the scan. If numBytes is non-negative, - * then no more than numBytes bytes will be scanned. + * number of bytes to be scanned. If numBytes is TCL_INDEX_NONE, the first NUL + * byte encountered will terminate the scan. Otherwise, + * no more than numBytes bytes will be scanned. * * The argument flags is an input that controls the numeric formats * recognized by the parser. The flag bits are: @@ -484,7 +484,7 @@ TclParseNumber( * ("integer", "boolean value", etc.). */ const char *bytes, /* Pointer to the start of the string to * scan. */ - int numBytes, /* Maximum number of bytes to scan, see + Tcl_Size numBytes, /* Maximum number of bytes to scan, see * above. */ const char **endPtrPtr, /* Place to store pointer to the character * that terminated the scan. */ @@ -493,7 +493,7 @@ TclParseNumber( enum State { INITIAL, SIGNUM, ZERO, ZERO_X, ZERO_O, ZERO_B, ZERO_D, BINARY, - HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, + HEXADECIMAL, OCTAL, DECIMAL, LEADING_RADIX_POINT, FRACTION, EXPONENT_START, EXPONENT_SIGNUM, EXPONENT, sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY @@ -529,16 +529,15 @@ TclParseNumber( * number. */ long exponent = 0; /* Exponent of a floating point number. */ const char *p; /* Pointer to next character to scan. */ - size_t len; /* Number of characters remaining after p. */ + Tcl_Size len; /* Number of characters remaining after p. */ const char *acceptPoint; /* Pointer to position after last character in * an acceptable number. */ - size_t acceptLen; /* Number of characters following that + Tcl_Size acceptLen; /* Number of characters following that * point. */ int status = TCL_OK; /* Status to return to caller. */ char d = 0; /* Last hexadecimal digit scanned; initialized * to avoid a compiler warning. */ int shift = 0; /* Amount to shift when accumulating binary */ - int explicitOctal = 0; mp_err err = MP_OKAY; #define MOST_BITS (UWIDE_MAX >> 1) @@ -555,7 +554,7 @@ TclParseNumber( return TCL_ERROR; } if (TclHasInternalRep(objPtr, &tclListType)) { - int length; + Tcl_Size length; /* A list can only be a (single) number if its length == 1 */ TclListObjLengthM(NULL, objPtr, &length); if (length != 1) { @@ -751,7 +750,6 @@ TclParseNumber( goto zerob; } if (c == 'o' || c == 'O') { - explicitOctal = 1; state = ZERO_O; break; } @@ -759,10 +757,7 @@ TclParseNumber( state = ZERO_D; break; } -#ifdef TCL_NO_DEPRECATED goto decimal; -#endif - /* FALLTHROUGH */ case OCTAL: /* @@ -841,58 +836,6 @@ TclParseNumber( state = OCTAL; break; } - /* FALLTHROUGH */ - - case BAD_OCTAL: - if (explicitOctal) { - /* - * No forgiveness for bad digits in explicitly octal numbers. - */ - - goto endgame; - } - if (flags & TCL_PARSE_INTEGER_ONLY) { - /* - * No seeking floating point when parsing only integer. - */ - - goto endgame; - } -#ifndef TCL_NO_DEPRECATED - - /* - * Scanned a number with a leading zero that contains an 8, 9, - * radix point or E. This is an invalid octal number, but might - * still be floating point. - */ - - if (c == '0') { - numTrailZeros++; - state = BAD_OCTAL; - break; - } else if (isdigit(UCHAR(c))) { - if (objPtr != NULL) { - significandOverflow = AccumulateDecimalDigit( - (unsigned)(c-'0'), numTrailZeros, - &significandWide, &significandBig, - significandOverflow); - } - if (numSigDigs != 0) { - numSigDigs += (numTrailZeros + 1); - } else { - numSigDigs = 1; - } - numTrailZeros = 0; - state = BAD_OCTAL; - break; - } else if (c == '.') { - state = FRACTION; - break; - } else if (c == 'E' || c == 'e') { - state = EXPONENT_START; - break; - } -#endif goto endgame; /* @@ -1038,9 +981,7 @@ TclParseNumber( * digits. */ -#ifdef TCL_NO_DEPRECATED decimal: -#endif acceptState = state; acceptPoint = p; acceptLen = len; @@ -1312,7 +1253,7 @@ TclParseNumber( } } if (endPtrPtr == NULL) { - if ((len != 0) && ((numBytes > 0) || (*p != '\0'))) { + if ((len != 0) && ((numBytes + 1 > 1) || (*p != '\0'))) { status = TCL_ERROR; } } else { @@ -1328,7 +1269,6 @@ TclParseNumber( TclFreeInternalRep(objPtr); switch (acceptState) { case SIGNUM: - case BAD_OCTAL: case ZERO_X: case ZERO_O: case ZERO_B: @@ -1591,9 +1531,6 @@ TclParseNumber( Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, ""); Tcl_AppendToObj(msg, "\"", -1); - if (state == BAD_OCTAL) { - Tcl_AppendToObj(msg, " (looks like invalid octal number)", -1); - } Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (void *)NULL); } @@ -2479,7 +2416,7 @@ TakeAbsoluteValue( * * Results: * Returns one of the strings 'Infinity' and 'NaN'. The string returned - * must be freed by the caller using 'ckfree'. + * must be freed by the caller using 'Tcl_Free'. * * Side effects: * Stores 9999 in *decpt, and sets '*endPtr' to designate the terminating @@ -2498,13 +2435,13 @@ FormatInfAndNaN( *decpt = 9999; if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) { - retval = (char *)ckalloc(9); + retval = (char *)Tcl_Alloc(9); strcpy(retval, "Infinity"); if (endPtr) { *endPtr = retval + 8; } } else { - retval = (char *)ckalloc(4); + retval = (char *)Tcl_Alloc(4); strcpy(retval, "NaN"); if (endPtr) { *endPtr = retval + 3; @@ -2535,7 +2472,7 @@ FormatZero( int *decpt, /* Location of the decimal point. */ char **endPtr) /* Pointer to the end of the formatted data */ { - char *retval = (char *)ckalloc(2); + char *retval = (char *)Tcl_Alloc(2); strcpy(retval, "0"); if (endPtr) { @@ -3081,7 +3018,7 @@ QuickConversion( * Handle the peculiar case where the result has no significant digits. */ - retval = (char *)ckalloc(len + 1); + retval = (char *)Tcl_Alloc(len + 1); if (ilim == 0) { d = d - 5.; if (d > eps.d) { @@ -3092,7 +3029,7 @@ QuickConversion( *decpt = k; return retval; } else { - ckfree(retval); + Tcl_Free(retval); return NULL; } } @@ -3107,7 +3044,7 @@ QuickConversion( end = StrictQuickFormat(d, k, ilim, eps.d, retval, decpt); } if (end == NULL) { - ckfree(retval); + Tcl_Free(retval); return NULL; } *end = '\0'; @@ -3192,7 +3129,7 @@ ShorteningInt64Conversion( char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { - char *retval = (char *)ckalloc(len + 1); + char *retval = (char *)Tcl_Alloc(len + 1); /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; /* Numerator of the fraction being @@ -3355,7 +3292,7 @@ StrictInt64Conversion( char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { - char *retval = (char *)ckalloc(len + 1); + char *retval = (char *)Tcl_Alloc(len + 1); /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; /* Numerator of the fraction being @@ -3555,7 +3492,7 @@ ShorteningBignumConversionPowD( char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { - char *retval = (char *)ckalloc(len + 1); + char *retval = (char *)Tcl_Alloc(len + 1); /* Output buffer. */ mp_int b; /* Numerator of the fraction being * converted. */ @@ -3762,7 +3699,7 @@ StrictBignumConversionPowD( char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { - char *retval = (char *)ckalloc(len + 1); + char *retval = (char *)Tcl_Alloc(len + 1); /* Output buffer. */ mp_int b; /* Numerator of the fraction being * converted. */ @@ -3916,7 +3853,7 @@ ShouldBankerRoundUpToNext( } r = mp_cmp_mag(&temp, S); mp_clear(&temp); - switch(r) { + switch (r) { case MP_EQ: return isodd; case MP_GT: @@ -3958,7 +3895,7 @@ ShorteningBignumConversion( int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Pointer to the end of the number */ { - char *retval = (char *)ckalloc(len+1); + char *retval = (char *)Tcl_Alloc(len+1); /* Buffer of digits to return. */ char *s = retval; /* Cursor in the return value. */ mp_int b; /* Numerator of the result. */ @@ -4192,7 +4129,7 @@ StrictBignumConversion( int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Pointer to the end of the number */ { - char *retval = (char *)ckalloc(len+1); + char *retval = (char *)Tcl_Alloc(len+1); /* Buffer of digits to return. */ char *s = retval; /* Cursor in the return value. */ mp_int b; /* Numerator of the result. */ @@ -4358,15 +4295,14 @@ StrictBignumConversion( * This function is a service routine that produces the string of digits for * floating-point-to-decimal conversion. It can do a number of things * according to the 'flags' argument. Valid values for 'flags' include: - * TCL_DD_SHORTEST - This is the default for floating point conversion if - * ::tcl_precision is 0. It constructs the shortest string of + * TCL_DD_SHORTEST - This is the default for floating point conversion. + * It constructs the shortest string of * digits that will reconvert to the given number when scanned. * For floating point numbers that are exactly between two * decimal numbers, it resolves using the 'round to even' rule. * With this value, the 'ndigits' parameter is ignored. * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format - * conversion (or for default floating->string if tcl_precision - * is not 0). It constructs a string of at most 'ndigits' digits, + * conversion. It constructs a string of at most 'ndigits' digits, * choosing the one that is closest to the given number (and * resolving ties with 'round to even'). It is allowed to return * fewer than 'ndigits' if the number converts exactly; if the @@ -4702,7 +4638,7 @@ TclInitDoubleConversion(void) maxpow10_wide = (int) floor(sizeof(Tcl_WideUInt) * CHAR_BIT * log(2.) / log(10.)); pow10_wide = (Tcl_WideUInt *) - ckalloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt)); + Tcl_Alloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt)); u = 1; for (i = 0; i < maxpow10_wide; ++i) { pow10_wide[i] = u; @@ -4812,7 +4748,7 @@ TclFinalizeDoubleConversion(void) { int i; - ckfree(pow10_wide); + Tcl_Free(pow10_wide); for (i=0; i<9; ++i) { mp_clear(pow5 + i); } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 3afee99..0ab5c3a 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -8,7 +8,7 @@ * * Conceptually, a string is a sequence of Unicode code points. Internally * it may be stored in an encoding form such as a modified version of - * UTF-8 or UTF-16 (when TCL_UTF_MAX=3) or UTF-32. + * UTF-8 or UTF-32. * * The String object is optimized for the case where each UTF char * in a string is only one byte. In this case, we store the value of @@ -65,167 +65,24 @@ static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size numChars); static Tcl_Size UnicodeLength(const Tcl_UniChar *unicode); -#if !defined(TCL_NO_DEPRECATED) -static int UTF16Length(const unsigned short *unicode); -#endif static void UpdateStringOfString(Tcl_Obj *objPtr); -#if !defined(TCL_NO_DEPRECATED) -static void DupUTF16StringInternalRep(Tcl_Obj *objPtr, - Tcl_Obj *copyPtr); -static int SetUTF16StringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void UpdateStringOfUTF16String(Tcl_Obj *objPtr); -#endif #define ISCONTINUATION(bytes) (\ - ((((bytes)[0] & 0xC0) == 0x80) || (((bytes)[0] == '\xED') \ - && (((bytes)[1] & 0xF0) == 0xB0) && (((bytes)[2] & 0xC0) == 0x80)))) - -#define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800) -#define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800) -#define LOW_SURROGATE(c_) (((c_) & ~0x3FF) == 0xDC00) + ((bytes)[0] & 0xC0) == 0x80) /* * The structure below defines the string Tcl object type by means of * functions that can be invoked by generic object code. */ -#ifndef TCL_NO_DEPRECATED const Tcl_ObjType tclStringType = { "string", /* name */ FreeStringInternalRep, /* freeIntRepPro */ - DupUTF16StringInternalRep, /* dupIntRepProc */ - UpdateStringOfUTF16String, /* updateStringProc */ - SetUTF16StringFromAny /* setFromAnyProc */ -}; -#endif - -const Tcl_ObjType tclUniCharStringType = { - "utf32string", /* name */ - FreeStringInternalRep, /* freeIntRepPro */ DupStringInternalRep, /* dupIntRepProc */ UpdateStringOfString, /* updateStringProc */ - SetStringFromAny /* setFromAnyProc */ + SetStringFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; - -typedef struct { - int numChars; /* The number of chars in the string. -1 means - * this value has not been calculated. >= 0 - * means that there is a valid Unicode rep, or - * that the number of UTF bytes == the number - * of chars. */ - int allocated; /* The amount of space actually allocated for - * the UTF string (minus 1 byte for the - * termination char). */ - int maxChars; /* Max number of chars that can fit in the - * space allocated for the unicode array. */ - int hasUnicode; /* Boolean determining whether the string has - * a Unicode representation. */ - Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size - * of this field depends on the 'maxChars' - * field above. */ -} UniCharString; - -#define UNICHAR_STRING_MAXCHARS \ - (int)(((size_t)UINT_MAX - offsetof(UniCharString, unicode))/sizeof(Tcl_UniChar) - 1) -#define UNICHAR_STRING_SIZE(numChars) \ - (offsetof(UniCharString, unicode) + sizeof(Tcl_UniChar) + ((numChars) * sizeof(Tcl_UniChar))) -#define uniCharStringCheckLimits(numChars) \ - do { \ - if ((numChars) < 0 || (numChars) > UNICHAR_STRING_MAXCHARS) { \ - Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \ - UNICHAR_STRING_MAXCHARS); \ - } \ - } while (0) -#define uniCharStringAttemptAlloc(numChars) \ - (UniCharString *) attemptckalloc(UNICHAR_STRING_SIZE(numChars)) -#define uniCharStringAlloc(numChars) \ - (UniCharString *) ckalloc(UNICHAR_STRING_SIZE(numChars)) -#define uniCharStringRealloc(ptr, numChars) \ - (UniCharString *) ckrealloc((ptr), UNICHAR_STRING_SIZE(numChars)) -#define uniCharStringAttemptRealloc(ptr, numChars) \ - (UniCharString *) attemptckrealloc((ptr), UNICHAR_STRING_SIZE(numChars)) -#define GET_UNICHAR_STRING(objPtr) \ - ((UniCharString *) (objPtr)->internalRep.twoPtrValue.ptr1) -#define SET_UNICHAR_STRING(objPtr, stringPtr) \ - ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \ - ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) - - -#ifndef TCL_NO_DEPRECATED -static void -DupUTF16StringInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have - * an internal rep of type "String". */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not - * currently have an internal rep.*/ -{ - String *srcStringPtr = GET_STRING(srcPtr); - size_t size = offsetof(String, unicode) + (((srcStringPtr->allocated) + 1U) * sizeof(unsigned short)); - String *copyStringPtr = (String *)ckalloc(size); - memcpy(copyStringPtr, srcStringPtr, size); - - SET_STRING(copyPtr, copyStringPtr); - copyPtr->typePtr = &tclStringType; -} - -static int -SetUTF16StringFromAny( - TCL_UNUSED(Tcl_Interp *), - Tcl_Obj *objPtr) /* The object to convert. */ -{ - if (!TclHasInternalRep(objPtr, &tclStringType)) { - Tcl_DString ds; - - /* - * Convert whatever we have into an untyped value. Just A String. - */ - - (void) TclGetString(objPtr); - TclFreeInternalRep(objPtr); - - /* - * Create a basic String internalrep that just points to the UTF-8 string - * already in place at objPtr->bytes. - */ - - Tcl_DStringInit(&ds); - unsigned short *utf16string = Tcl_UtfToChar16DString(objPtr->bytes, objPtr->length, &ds); - int size = Tcl_DStringLength(&ds); - String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + sizeof(unsigned short)) + size); - - memcpy(stringPtr->unicode, utf16string, size); - Tcl_DStringFree(&ds); - size /= sizeof(unsigned short); - stringPtr->unicode[size] = 0; - - stringPtr->numChars = size; - stringPtr->allocated = size; - stringPtr->maxChars = size; - stringPtr->hasUnicode = 1; - SET_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclStringType; - } - return TCL_OK; -} - -static void -UpdateStringOfUTF16String( - Tcl_Obj *objPtr) /* Object with string rep to update. */ -{ - Tcl_DString ds; - String *stringPtr = GET_STRING(objPtr); - - Tcl_DStringInit(&ds); - const char *string = Tcl_Char16ToUtfDString(stringPtr->unicode, stringPtr->numChars, &ds); - - char *bytes = (char *)ckalloc(Tcl_DStringLength(&ds) + 1U); - memcpy(bytes, string, Tcl_DStringLength(&ds)); - bytes[Tcl_DStringLength(&ds)] = 0; - objPtr->bytes = bytes; - objPtr->length = Tcl_DStringLength(&ds); - Tcl_DStringFree(&ds); -} -#endif /* * TCL STRING GROWTH ALGORITHM @@ -277,43 +134,30 @@ GrowStringBuffer( * flag || objPtr->bytes != NULL */ - UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); - char *ptr = NULL; + String *stringPtr = GET_STRING(objPtr); + char *ptr; Tcl_Size capacity; + assert(needed <= TCL_SIZE_MAX - 1); + needed += 1; /* Include terminating nul */ + if (objPtr->bytes == &tclEmptyString) { objPtr->bytes = NULL; } + /* + * In code below, note 'capacity' and 'needed' include terminating nul, + * while stringPtr->allocated does not. + */ if (flag == 0 || stringPtr->allocated > 0) { - if (needed <= INT_MAX / 2) { - capacity = 2 * needed; - ptr = (char *)attemptckrealloc(objPtr->bytes, capacity + 1U); - } - if (ptr == NULL) { - /* - * Take care computing the amount of modest growth to avoid - * overflow into invalid argument values for capacity. - */ - - unsigned int limit = INT_MAX - needed; - unsigned int extra = needed - objPtr->length + TCL_MIN_GROWTH; - int growth = (int) ((extra > limit) ? limit : extra); - - capacity = needed + growth; - ptr = (char *)attemptckrealloc(objPtr->bytes, capacity + 1U); - } - } - if (ptr == NULL) { - /* - * First allocation - just big enough; or last chance fallback. - */ - + ptr = (char *)TclReallocEx(objPtr->bytes, needed, &capacity); + } else { + /* Allocate exact size */ + ptr = (char *)Tcl_Realloc(objPtr->bytes, needed); capacity = needed; - ptr = (char *)ckrealloc(objPtr->bytes, capacity + 1U); } + objPtr->bytes = ptr; - stringPtr->allocated = capacity; - memset(ptr + objPtr->length, 0, capacity + 1U - objPtr->length); + stringPtr->allocated = capacity - 1; /* Does not include slot for end nul */ } static void @@ -325,47 +169,35 @@ GrowUnicodeBuffer( * Preconditions: * objPtr->typePtr == &tclStringType * needed > stringPtr->maxChars - * needed < UNICHAR_STRING_MAXCHARS */ - UniCharString *ptr = NULL, *stringPtr = GET_UNICHAR_STRING(objPtr); - Tcl_Size capacity; - - if (stringPtr->maxChars > 0) { - /* - * Subsequent appends - apply the growth algorithm. - */ - - if (needed <= UNICHAR_STRING_MAXCHARS / 2) { - capacity = 2 * needed; - ptr = uniCharStringAttemptRealloc(stringPtr, capacity); - } - if (ptr == NULL) { - /* - * Take care computing the amount of modest growth to avoid - * overflow into invalid argument values for capacity. - */ - - unsigned int limit = UNICHAR_STRING_MAXCHARS - needed; - unsigned int extra = needed - stringPtr->numChars - + TCL_MIN_UNICHAR_GROWTH; - int growth = (int) ((extra > limit) ? limit : extra); + String *stringPtr = GET_STRING(objPtr); + Tcl_Size maxChars; - capacity = needed + growth; - ptr = uniCharStringAttemptRealloc(stringPtr, capacity); - } + /* Note STRING_MAXCHARS already takes into account space for nul */ + if (needed > STRING_MAXCHARS) { + Tcl_Panic("max size for a Tcl unicode rep (%" TCL_Z_MODIFIER "d bytes) exceeded", + STRING_MAXCHARS); } - if (ptr == NULL) { + if (stringPtr->maxChars > 0) { + /* Expansion - try allocating extra space */ + stringPtr = (String *)TclReallocElemsEx(stringPtr, + needed + 1, /* +1 for nul */ + sizeof(Tcl_UniChar), + offsetof(String, unicode), + &maxChars); + maxChars -= 1; /* End nul not included */ + } + else { /* - * First allocation - just big enough; or last chance fallback. + * First allocation - just big enough. Note needed does + * not include terminating nul but STRING_SIZE does */ - - capacity = needed; - ptr = uniCharStringRealloc(stringPtr, capacity); + stringPtr = (String *)Tcl_Realloc(stringPtr, STRING_SIZE(needed)); + maxChars = needed; } - stringPtr = ptr; - stringPtr->maxChars = capacity; - SET_UNICHAR_STRING(objPtr, stringPtr); + stringPtr->maxChars = maxChars; + SET_STRING(objPtr, stringPtr); } /* @@ -385,7 +217,7 @@ GrowUnicodeBuffer( * * Side effects: * The new object's internal string representation will be set to a copy - * of the length bytes starting at "bytes". If "length" is negative, use + * of the length bytes starting at "bytes". If "length" is TCL_INDEX_NONE, use * bytes up to the first NUL byte; i.e., assume "bytes" points to a * C-style NUL-terminated string. The object's type is set to NULL. An * extra NUL is added to the end of the new object's byte array. @@ -401,7 +233,7 @@ Tcl_NewStringObj( * used to initialize the new object. */ Tcl_Size length) /* The number of bytes to copy from "bytes" * when initializing the new object. If - * negative, use bytes up to the first NUL + * TCL_INDEX_NONE, use bytes up to the first NUL * byte. */ { return Tcl_DbNewStringObj(bytes, length, "unknown", 0); @@ -412,7 +244,7 @@ Tcl_NewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ Tcl_Size length) /* The number of bytes to copy from "bytes" - * when initializing the new object. If negative, + * when initializing the new object. If -1, * use bytes up to the first NUL byte. */ { Tcl_Obj *objPtr; @@ -446,7 +278,7 @@ Tcl_NewStringObj( * * Side effects: * The new object's internal string representation will be set to a copy - * of the length bytes starting at "bytes". If "length" is negative, use + * of the length bytes starting at "bytes". If "length" is TCL_INDEX_NONE, use * bytes up to the first NUL byte; i.e., assume "bytes" points to a * C-style NUL-terminated string. The object's type is set to NULL. An * extra NUL is added to the end of the new object's byte array. @@ -460,7 +292,7 @@ Tcl_DbNewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ Tcl_Size length, /* The number of bytes to copy from "bytes" - * when initializing the new object. If negative, + * when initializing the new object. If -1, * use bytes up to the first NUL byte. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -469,7 +301,7 @@ Tcl_DbNewStringObj( { Tcl_Obj *objPtr; - if (length < 0) { + if (length == TCL_INDEX_NONE) { length = (bytes? strlen(bytes) : 0); } TclDbNewObj(objPtr, file, line); @@ -482,9 +314,8 @@ Tcl_DbNewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ Tcl_Size length, /* The number of bytes to copy from "bytes" - * when initializing the new object. If - * negative, use bytes up to the first NUL - * byte. */ + * when initializing the new object. If -1, + * use bytes up to the first NUL byte. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { @@ -512,7 +343,7 @@ Tcl_DbNewStringObj( */ Tcl_Obj * -TclNewUnicodeObj( +Tcl_NewUnicodeObj( const Tcl_UniChar *unicode, /* The unicode string used to initialize the * new object. */ Tcl_Size numChars) /* Number of characters in the unicode @@ -525,39 +356,6 @@ TclNewUnicodeObj( return objPtr; } -#if !defined(TCL_NO_DEPRECATED) -Tcl_Obj * -Tcl_NewUnicodeObj( - const unsigned short *unicode, /* The unicode string used to initialize the - * new object. */ - int numChars) /* Number of characters in the unicode - * string. */ -{ - Tcl_Obj *objPtr; - - TclNewObj(objPtr); - TclInvalidateStringRep(objPtr); - - if (numChars < 0) { - numChars = UTF16Length(unicode); - } - - String *stringPtr = (String *)ckalloc((offsetof(String, unicode) - + sizeof(unsigned short)) + numChars * sizeof(unsigned short)); - memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned short)); - stringPtr->unicode[numChars] = 0; - - stringPtr->numChars = numChars; - stringPtr->allocated = numChars; - stringPtr->maxChars = numChars; - stringPtr->hasUnicode = 1; - SET_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclStringType; - - return objPtr; -} -#endif - /* *---------------------------------------------------------------------- * @@ -576,12 +374,12 @@ Tcl_NewUnicodeObj( */ Tcl_Size -TclGetCharLength( +Tcl_GetCharLength( Tcl_Obj *objPtr) /* The String object to get the num chars * of. */ { - UniCharString *stringPtr; - Tcl_Size numChars; + String *stringPtr; + Tcl_Size numChars = 0; /* * Quick, no-shimmer return for short string reps. @@ -604,7 +402,7 @@ TclGetCharLength( */ if (TclIsPureByteArray(objPtr)) { - (void) Tcl_GetByteArrayFromObj(objPtr, &numChars); + (void) Tcl_GetBytesFromObj(NULL, objPtr, &numChars); return numChars; } @@ -613,7 +411,7 @@ TclGetCharLength( */ SetStringFromAny(NULL, objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); numChars = stringPtr->numChars; /* @@ -627,10 +425,8 @@ TclGetCharLength( return numChars; } -#if !defined(TCL_NO_DEPRECATED) -#undef Tcl_GetCharLength Tcl_Size -Tcl_GetCharLength( +TclGetCharLength( Tcl_Obj *objPtr) /* The String object to get the num chars * of. */ { @@ -657,7 +453,7 @@ Tcl_GetCharLength( */ if (TclIsPureByteArray(objPtr)) { - (void) Tcl_GetByteArrayFromObj(objPtr, &numChars); + (void) Tcl_GetBytesFromObj(NULL, objPtr, &numChars); } else { Tcl_GetString(objPtr); numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); @@ -665,7 +461,6 @@ Tcl_GetCharLength( return numChars; } -#endif /* @@ -695,7 +490,7 @@ TclCheckEmptyString( } if (TclIsPureByteArray(objPtr) - && TclGetCharLength(objPtr) == 0) { + && Tcl_GetCharLength(objPtr) == 0) { return TCL_EMPTYSTRING_YES; } @@ -733,8 +528,6 @@ TclCheckEmptyString( *---------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) -#undef Tcl_GetUniChar int Tcl_GetUniChar( Tcl_Obj *objPtr, /* The object to get the Unicode charater @@ -754,8 +547,8 @@ Tcl_GetUniChar( */ if (TclIsPureByteArray(objPtr)) { - Tcl_Size length; - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + Tcl_Size length = 0; + unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length); if (index >= length) { return -1; } @@ -767,30 +560,33 @@ Tcl_GetUniChar( * OK, need to work with the object as a string. */ - SetUTF16StringFromAny(NULL, objPtr); + SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); + if (stringPtr->hasUnicode == 0) { + /* + * If numChars is unknown, compute it. + */ + + if (stringPtr->numChars == TCL_INDEX_NONE) { + TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); + } + if (index >= stringPtr->numChars) { + return -1; + } + if (stringPtr->numChars == objPtr->length) { + return (unsigned char) objPtr->bytes[index]; + } + FillUnicodeRep(objPtr); + stringPtr = GET_STRING(objPtr); + } + if (index >= stringPtr->numChars) { return -1; } ch = stringPtr->unicode[index]; - /* See: bug [11ae2be95dac9417] */ - if (SURROGATE(ch)) { - if (ch & 0x400) { - if ((index > 0) - && HIGH_SURROGATE(stringPtr->unicode[index-1])) { - ch = -1; /* low surrogate preceded by high surrogate */ - } - } else if ((++index < stringPtr->numChars) - && LOW_SURROGATE(stringPtr->unicode[index])) { - /* high surrogate followed by low surrogate */ - ch = (((ch & 0x3FF) << 10) | - (stringPtr->unicode[index] & 0x3FF)) + 0x10000; - } - } return ch; } -#endif int TclGetUniChar( @@ -798,21 +594,20 @@ TclGetUniChar( * from. */ Tcl_Size index) /* Get the index'th Unicode character. */ { - UniCharString *stringPtr; - int ch; + int ch = 0; if (index < 0) { return -1; } /* - * Optimize the case where we're really dealing with a ByteArray object - * we don't need to convert to a string to perform the indexing operation. + * Optimize the ByteArray case: N need need to convert to a string to + * perform the indexing operation. */ if (TclIsPureByteArray(objPtr)) { - Tcl_Size length; - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + Tcl_Size length = 0; + unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length); if (index >= length) { return -1; } @@ -820,71 +615,20 @@ TclGetUniChar( return bytes[index]; } - /* - * OK, need to work with the object as a string. - */ - - SetStringFromAny(NULL, objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); - - if (stringPtr->hasUnicode == 0) { - /* - * If numChars is unknown, compute it. - */ - - if (stringPtr->numChars == TCL_INDEX_NONE) { - TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); - } - if (index >= stringPtr->numChars) { - return -1; - } - if (stringPtr->numChars == objPtr->length) { - return (unsigned char) objPtr->bytes[index]; - } - FillUnicodeRep(objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); - } + Tcl_Size numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); - if (index >= stringPtr->numChars) { + if (index >= numChars) { return -1; } - ch = stringPtr->unicode[index]; + const char *begin = TclUtfAtIndex(objPtr->bytes, index); +#undef Tcl_UtfToUniChar + Tcl_UtfToUniChar(begin, &ch); return ch; } /* *---------------------------------------------------------------------- * - * Tcl_GetUnicode -- - * - * Get the Unicode form of the String object. If the object is not - * already a String object, it will be converted to one. If the String - * object does not have a Unicode rep, then one is created from the UTF - * string format. - * - * Results: - * Returns a pointer to the object's internal Unicode string. - * - * Side effects: - * Converts the object to have the String internal rep. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_GetUnicode -unsigned short * -Tcl_GetUnicode( - Tcl_Obj *objPtr) /* The object to find the Unicode string - * for. */ -{ - return Tcl_GetUnicodeFromObj(objPtr, NULL); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_GetUnicodeFromObj/TclGetUnicodeFromObj -- * * Get the Unicode form of the String object with length. If the object @@ -901,50 +645,60 @@ Tcl_GetUnicode( *---------------------------------------------------------------------- */ +#undef Tcl_GetUnicodeFromObj +#if !defined(TCL_NO_DEPRECATED) Tcl_UniChar * TclGetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the Unicode string * for. */ - int *lengthPtr) /* If non-NULL, the location where the string + void *lengthPtr) /* If non-NULL, the location where the string * rep's Tcl_UniChar length should be stored. If * NULL, no length is stored. */ { - UniCharString *stringPtr; + String *stringPtr; SetStringFromAny(NULL, objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode == 0) { FillUnicodeRep(objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); } if (lengthPtr != NULL) { - *lengthPtr = stringPtr->numChars; + if (stringPtr->numChars > INT_MAX) { + Tcl_Panic("Tcl_GetUnicodeFromObj with 'int' lengthPtr" + " cannot handle such long strings. Please use 'Tcl_Size'"); + } + *(int *)lengthPtr = (int)stringPtr->numChars; } return stringPtr->unicode; } +#endif /* !defined(TCL_NO_DEPRECATED) */ -#if !defined(TCL_NO_DEPRECATED) -unsigned short * +Tcl_UniChar * Tcl_GetUnicodeFromObj( - Tcl_Obj *objPtr, /* The object to find the Unicode string + Tcl_Obj *objPtr, /* The object to find the unicode string * for. */ Tcl_Size *lengthPtr) /* If non-NULL, the location where the string - * rep's Tcl_UniChar length should be stored. If + * rep's unichar length should be stored. If * NULL, no length is stored. */ { String *stringPtr; - SetUTF16StringFromAny(NULL, objPtr); + SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); + if (stringPtr->hasUnicode == 0) { + FillUnicodeRep(objPtr); + stringPtr = GET_STRING(objPtr); + } + if (lengthPtr != NULL) { *lengthPtr = stringPtr->numChars; } return stringPtr->unicode; } -#endif /* *---------------------------------------------------------------------- @@ -953,9 +707,9 @@ Tcl_GetUnicodeFromObj( * * Create a Tcl Object that contains the chars between first and last of * the object indicated by "objPtr". If the object is not already a - * String object, convert it to one. If first is negative, the + * String object, convert it to one. If first is TCL_INDEX_NONE, the * returned string start at the beginning of objPtr. If last is - * negative, the returned string ends at the end of objPtr. + * TCL_INDEX_NONE, the returned string ends at the end of objPtr. * * Results: * Returns a new Tcl Object of the String type. @@ -966,8 +720,6 @@ Tcl_GetUnicodeFromObj( *---------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) -#undef Tcl_GetRange Tcl_Obj * Tcl_GetRange( Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ @@ -975,54 +727,8 @@ Tcl_GetRange( Tcl_Size last) /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ - Tcl_Size length; - - if (first < 0) { - first = 0; - } - - /* - * Optimize the case where we're really dealing with a bytearray object - * we don't need to convert to a string to perform the substring operation. - */ - - if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); - - if (last < 0 || last >= length) { - last = length - 1; - } - if (last < first) { - TclNewObj(newObjPtr); - return newObjPtr; - } - return Tcl_NewByteArrayObj(bytes + first, last - first + 1); - } - - Tcl_Size numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); - - if (last < 0 || last >= numChars) { - last = numChars - 1; - } - if (last < first) { - TclNewObj(newObjPtr); - return newObjPtr; - } - const char *begin = Tcl_UtfAtIndex(objPtr->bytes, first); - const char *end = Tcl_UtfAtIndex(objPtr->bytes, last + 1); - return Tcl_NewStringObj(begin, end - begin); -} -#endif - -Tcl_Obj * -TclGetRange( - Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ - Tcl_Size first, /* First index of the range. */ - Tcl_Size last) /* Last index of the range. */ -{ - Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ - UniCharString *stringPtr; - Tcl_Size length; + String *stringPtr; + Tcl_Size length = 0; if (first < 0) { first = 0; @@ -1034,7 +740,7 @@ TclGetRange( */ if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length); if (last < 0 || last >= length) { last = length - 1; @@ -1051,7 +757,7 @@ TclGetRange( */ SetStringFromAny(NULL, objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode == 0) { /* @@ -1076,12 +782,12 @@ TclGetRange( */ SetStringFromAny(NULL, newObjPtr); - stringPtr = GET_UNICHAR_STRING(newObjPtr); + stringPtr = GET_STRING(newObjPtr); stringPtr->numChars = newObjPtr->length; return newObjPtr; } FillUnicodeRep(objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); } if (last < 0 || last >= stringPtr->numChars) { last = stringPtr->numChars - 1; @@ -1090,7 +796,52 @@ TclGetRange( TclNewObj(newObjPtr); return newObjPtr; } - return TclNewUnicodeObj(stringPtr->unicode + first, last - first + 1); + return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); +} + +Tcl_Obj * +TclGetRange( + Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ + Tcl_Size first, /* First index of the range. */ + Tcl_Size last) /* Last index of the range. */ +{ + Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ + Tcl_Size length = 0; + + if (first < 0) { + first = TCL_INDEX_START; + } + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the substring operation. + */ + + if (TclIsPureByteArray(objPtr)) { + unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length); + + if (last < 0 || last >= length) { + last = length - 1; + } + if (last < first) { + TclNewObj(newObjPtr); + return newObjPtr; + } + return Tcl_NewByteArrayObj(bytes + first, last - first + 1); + } + + Tcl_Size numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + + if (last < 0 || last >= numChars) { + last = numChars - 1; + } + if (last < first) { + TclNewObj(newObjPtr); + return newObjPtr; + } + const char *begin = TclUtfAtIndex(objPtr->bytes, first); + const char *end = TclUtfAtIndex(objPtr->bytes, last + 1); + return Tcl_NewStringObj(begin, end - begin); } /* @@ -1106,7 +857,7 @@ TclGetRange( * * Side effects: * The object's string representation will be set to a copy of the - * "length" bytes starting at "bytes". If "length" is negative, use bytes + * "length" bytes starting at "bytes". If "length" is TCL_INDEX_NONE, use bytes * up to the first NUL byte; i.e., assume "bytes" points to a C-style * NUL-terminated string. The object's old string and internal * representations are freed and the object's type is set NULL. @@ -1120,7 +871,7 @@ Tcl_SetStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the object. */ Tcl_Size length) /* The number of bytes to copy from "bytes" - * when initializing the object. If negative, + * when initializing the object. If -1, * use bytes up to the first NUL byte.*/ { if (Tcl_IsShared(objPtr)) { @@ -1139,7 +890,7 @@ Tcl_SetStringObj( */ TclInvalidateStringRep(objPtr); - if (length < 0) { + if (length == TCL_INDEX_NONE) { length = (bytes? strlen(bytes) : 0); } TclInitStringRep(objPtr, bytes, length); @@ -1175,7 +926,7 @@ Tcl_SetObjLength( * representation of object, not including * terminating null byte. */ { - UniCharString *stringPtr; + String *stringPtr; if (length < 0) { Tcl_Panic("Tcl_SetObjLength: length requested is negative: " @@ -1190,7 +941,7 @@ Tcl_SetObjLength( } SetStringFromAny(NULL, objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); if (objPtr->bytes != NULL) { /* @@ -1201,9 +952,9 @@ Tcl_SetObjLength( * Need to enlarge the buffer. */ if (objPtr->bytes == &tclEmptyString) { - objPtr->bytes = (char *)ckalloc(length + 1U); + objPtr->bytes = (char *)Tcl_Alloc(length + 1); } else { - objPtr->bytes = (char *)ckrealloc(objPtr->bytes, length + 1U); + objPtr->bytes = (char *)Tcl_Realloc(objPtr->bytes, length + 1); } stringPtr->allocated = length; } @@ -1218,14 +969,9 @@ Tcl_SetObjLength( stringPtr->numChars = TCL_INDEX_NONE; stringPtr->hasUnicode = 0; } else { - /* - * Changing length of pure unicode string. - */ - - uniCharStringCheckLimits(length); if (length > stringPtr->maxChars) { - stringPtr = uniCharStringRealloc(stringPtr, length); - SET_UNICHAR_STRING(objPtr, stringPtr); + stringPtr = stringRealloc(stringPtr, length); + SET_STRING(objPtr, stringPtr); stringPtr->maxChars = length; } @@ -1275,7 +1021,7 @@ Tcl_AttemptSetObjLength( * representation of object, not including * terminating null byte. */ { - UniCharString *stringPtr; + String *stringPtr; if (length < 0) { /* Negative lengths => most likely integer overflow */ @@ -1290,7 +1036,7 @@ Tcl_AttemptSetObjLength( } SetStringFromAny(NULL, objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); if (objPtr->bytes != NULL) { /* @@ -1304,9 +1050,9 @@ Tcl_AttemptSetObjLength( char *newBytes; if (objPtr->bytes == &tclEmptyString) { - newBytes = (char *)attemptckalloc(length + 1U); + newBytes = (char *)Tcl_AttemptAlloc(length + 1U); } else { - newBytes = (char *)attemptckrealloc(objPtr->bytes, length + 1U); + newBytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, length + 1U); } if (newBytes == NULL) { return 0; @@ -1329,15 +1075,12 @@ Tcl_AttemptSetObjLength( * Changing length of pure Unicode string. */ - if (length > UNICHAR_STRING_MAXCHARS) { - return 0; - } if (length > stringPtr->maxChars) { - stringPtr = uniCharStringAttemptRealloc(stringPtr, length); + stringPtr = stringAttemptRealloc(stringPtr, length); if (stringPtr == NULL) { return 0; } - SET_UNICHAR_STRING(objPtr, stringPtr); + SET_STRING(objPtr, stringPtr); stringPtr->maxChars = length; } @@ -1373,55 +1116,20 @@ Tcl_AttemptSetObjLength( *--------------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) void Tcl_SetUnicodeObj( Tcl_Obj *objPtr, /* The object to set the string of. */ - const unsigned short *unicode, /* The Unicode string used to initialize the + const Tcl_UniChar *unicode, /* The Unicode string used to initialize the * object. */ Tcl_Size numChars) /* Number of characters in the Unicode * string. */ { - String *stringPtr; - - if (numChars < 0) { - numChars = UTF16Length(unicode); - } - - /* - * Allocate enough space for the String structure + Unicode string. - */ - - stringCheckLimits(numChars); - stringPtr = stringAlloc(numChars); - SET_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclStringType; - - stringPtr->maxChars = numChars; - memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned char)); - stringPtr->unicode[numChars] = 0; - stringPtr->numChars = numChars; - stringPtr->hasUnicode = 1; - - TclInvalidateStringRep(objPtr); - stringPtr->allocated = numChars; -} - -static Tcl_Size -UTF16Length( - const unsigned short *ucs2Ptr) -{ - Tcl_Size numChars = 0; - - if (ucs2Ptr) { - while (numChars >= 0 && ucs2Ptr[numChars] != 0) { - numChars++; - } + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj"); } - stringCheckLimits(numChars); - return numChars; + TclFreeInternalRep(objPtr); + SetUnicodeObj(objPtr, unicode, numChars); } -#endif static Tcl_Size UnicodeLength( @@ -1430,11 +1138,11 @@ UnicodeLength( Tcl_Size numChars = 0; if (unicode) { + /* TODO - is this overflow check really necessary? */ while ((numChars >= 0) && (unicode[numChars] != 0)) { numChars++; } } - uniCharStringCheckLimits(numChars); return numChars; } @@ -1446,7 +1154,7 @@ SetUnicodeObj( Tcl_Size numChars) /* Number of characters in the Unicode * string. */ { - UniCharString *stringPtr; + String *stringPtr; if (numChars < 0) { numChars = UnicodeLength(unicode); @@ -1456,10 +1164,9 @@ SetUnicodeObj( * Allocate enough space for the String structure + Unicode string. */ - uniCharStringCheckLimits(numChars); - stringPtr = uniCharStringAlloc(numChars); - SET_UNICHAR_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclUniCharStringType; + stringPtr = stringAlloc(numChars); + SET_STRING(objPtr, stringPtr); + objPtr->typePtr = &tclStringType; stringPtr->maxChars = numChars; memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar)); @@ -1503,7 +1210,7 @@ Tcl_AppendLimitedToObj( * object to indicate not all available bytes * at "bytes" were appended. */ { - UniCharString *stringPtr; + String *stringPtr; Tcl_Size toCopy = 0; Tcl_Size eLen = 0; @@ -1542,15 +1249,15 @@ Tcl_AppendLimitedToObj( } SetStringFromAny(NULL, objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); /* If appended string starts with a continuation byte or a lower surrogate, * force objPtr to unicode representation. See [7f1162a867] */ if (bytes && ISCONTINUATION(bytes)) { - TclGetUnicodeFromObj(objPtr, NULL); - stringPtr = GET_UNICHAR_STRING(objPtr); + Tcl_GetUnicode(objPtr); + stringPtr = GET_STRING(objPtr); } - if (stringPtr->hasUnicode && stringPtr->numChars > 0) { + if (stringPtr->hasUnicode && (stringPtr->numChars) > 0) { AppendUtfToUnicodeRep(objPtr, bytes, toCopy); } else { AppendUtfToUtfRep(objPtr, bytes, toCopy); @@ -1560,8 +1267,8 @@ Tcl_AppendLimitedToObj( return; } - stringPtr = GET_UNICHAR_STRING(objPtr); - if (stringPtr->hasUnicode && stringPtr->numChars > 0) { + stringPtr = GET_STRING(objPtr); + if (stringPtr->hasUnicode && (stringPtr->numChars) > 0) { AppendUtfToUnicodeRep(objPtr, ellipsis, eLen); } else { AppendUtfToUtfRep(objPtr, ellipsis, eLen); @@ -1591,7 +1298,7 @@ Tcl_AppendToObj( const char *bytes, /* Points to the bytes to append to the * object. */ Tcl_Size length) /* The number of bytes to append from "bytes". - * If negative, then append all bytes up to NUL + * If TCL_INDEX_NONE, then append all bytes up to NUL * byte. */ { Tcl_AppendLimitedToObj(objPtr, bytes, length, TCL_SIZE_MAX, NULL); @@ -1615,14 +1322,14 @@ Tcl_AppendToObj( */ void -TclAppendUnicodeToObj( +Tcl_AppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* The Unicode string to append to the * object. */ Tcl_Size length) /* Number of chars in Unicode. Negative * lengths means nul terminated */ { - UniCharString *stringPtr; + String *stringPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj"); @@ -1633,7 +1340,7 @@ TclAppendUnicodeToObj( } SetStringFromAny(NULL, objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); /* * If objPtr has a valid Unicode rep, then append the "unicode" to the @@ -1648,35 +1355,6 @@ TclAppendUnicodeToObj( } } -#if !defined(TCL_NO_DEPRECATED) -void -Tcl_AppendUnicodeToObj( - Tcl_Obj *objPtr, /* Points to the object to append to. */ - const unsigned short *unicode, /* The unicode string to append to the - * object. */ - Tcl_Size length) /* Number of chars in Unicode. Negative - * lengths means nul terminated */ -{ - String *stringPtr; - - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj"); - } - - if (length == 0) { - return; - } - - SetUTF16StringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); - stringPtr = stringAttemptRealloc(stringPtr, stringPtr->numChars + length); - memcpy(&stringPtr->unicode[stringPtr->numChars], unicode, length); - stringPtr->maxChars = stringPtr->allocated = stringPtr->numChars += length; - stringPtr->unicode[stringPtr->numChars] = 0; - SET_STRING(objPtr, stringPtr); -} -#endif - /* *---------------------------------------------------------------------- * @@ -1702,33 +1380,33 @@ Tcl_AppendObjToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ Tcl_Obj *appendObjPtr) /* Object to append. */ { - UniCharString *stringPtr; - Tcl_Size length, numChars; + String *stringPtr; + Tcl_Size length = 0, numChars; Tcl_Size appendNumChars = TCL_INDEX_NONE; const char *bytes; - /* - * Special case: second object is standard-empty is fast case. We know - * that appending nothing to anything leaves that starting anything... - */ + if (TclCheckEmptyString(appendObjPtr) == TCL_EMPTYSTRING_YES) { + return; + } - if (appendObjPtr->bytes == &tclEmptyString) { + if (TclCheckEmptyString(objPtr) == TCL_EMPTYSTRING_YES) { + TclSetDuplicateObj(objPtr, appendObjPtr); return; } - /* - * Handle append of one ByteArray object to another as a special case. - * Note that we only do this when the objects are pure so that the - * bytearray faithfully represent the true value; Otherwise appending the - * byte arrays together could lose information; - */ + if ( + TclIsPureByteArray(appendObjPtr) + && (TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString) + ) { + /* + * Both bytearray objects are pure, so the second internal bytearray value + * can be appended to the first, with no need to modify the "bytes" field. + */ - if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString) - && TclIsPureByteArray(appendObjPtr)) { /* * One might expect the code here to be * - * bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length); + * bytes = Tcl_GetBytesFromObj(NULL, appendObjPtr, &length); * TclAppendBytesToByteArray(objPtr, bytes, length); * * and essentially all of the time that would be fine. However, it @@ -1744,10 +1422,10 @@ Tcl_AppendObjToObj( * First, get the lengths. */ - Tcl_Size lengthSrc; + Tcl_Size lengthSrc = 0; - (void) Tcl_GetByteArrayFromObj(objPtr, &length); - (void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc); + (void) Tcl_GetBytesFromObj(NULL, objPtr, &length); + (void) Tcl_GetBytesFromObj(NULL, appendObjPtr, &lengthSrc); /* * Grow buffer enough for the append. @@ -1767,7 +1445,7 @@ Tcl_AppendObjToObj( */ TclAppendBytesToByteArray(objPtr, - Tcl_GetByteArrayFromObj(appendObjPtr, (Tcl_Size *) NULL), lengthSrc); + Tcl_GetBytesFromObj(NULL, appendObjPtr, (Tcl_Size *) NULL), lengthSrc); return; } @@ -1776,14 +1454,14 @@ Tcl_AppendObjToObj( */ SetStringFromAny(NULL, objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); /* If appended string starts with a continuation byte or a lower surrogate, * force objPtr to unicode representation. See [7f1162a867] * This fixes append-3.4, append-3.7 and utf-1.18 testcases. */ if (ISCONTINUATION(TclGetString(appendObjPtr))) { - TclGetUnicodeFromObj(objPtr, NULL); - stringPtr = GET_UNICHAR_STRING(objPtr); + Tcl_GetUnicode(objPtr); + stringPtr = GET_STRING(objPtr); } /* * If objPtr has a valid Unicode rep, then get a Unicode string from @@ -1795,13 +1473,13 @@ Tcl_AppendObjToObj( * If appendObjPtr is not of the "String" type, don't convert it. */ - if (TclHasInternalRep(appendObjPtr, &tclUniCharStringType)) { + if (TclHasInternalRep(appendObjPtr, &tclStringType)) { Tcl_UniChar *unicode = - TclGetUnicodeFromObj(appendObjPtr, &numChars); + Tcl_GetUnicodeFromObj(appendObjPtr, &numChars); AppendUnicodeToUnicodeRep(objPtr, unicode, numChars); } else { - bytes = TclGetStringFromObj(appendObjPtr, &length); + bytes = Tcl_GetStringFromObj(appendObjPtr, &length); AppendUtfToUnicodeRep(objPtr, bytes, length); } return; @@ -1813,11 +1491,11 @@ Tcl_AppendObjToObj( * characters in the final (appended-to) object. */ - bytes = TclGetStringFromObj(appendObjPtr, &length); + bytes = Tcl_GetStringFromObj(appendObjPtr, &length); numChars = stringPtr->numChars; - if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclUniCharStringType)) { - UniCharString *appendStringPtr = GET_UNICHAR_STRING(appendObjPtr); + if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclStringType)) { + String *appendStringPtr = GET_STRING(appendObjPtr); appendNumChars = appendStringPtr->numChars; } @@ -1852,7 +1530,7 @@ AppendUnicodeToUnicodeRep( const Tcl_UniChar *unicode, /* String to append. */ Tcl_Size appendNumChars) /* Number of chars of "unicode" to append. */ { - UniCharString *stringPtr; + String *stringPtr; Tcl_Size numChars; if (appendNumChars < 0) { @@ -1863,7 +1541,7 @@ AppendUnicodeToUnicodeRep( } SetStringFromAny(NULL, objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); /* * If not enough space has been allocated for the Unicode rep, reallocate @@ -1874,10 +1552,9 @@ AppendUnicodeToUnicodeRep( */ numChars = stringPtr->numChars + appendNumChars; - uniCharStringCheckLimits(numChars); if (numChars > stringPtr->maxChars) { - Tcl_Size offset = TCL_INDEX_NONE; + Tcl_Size offset = -1; /* * Protect against case where Unicode points into the existing @@ -1891,7 +1568,7 @@ AppendUnicodeToUnicodeRep( } GrowUnicodeBuffer(objPtr, numChars); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); /* * Relocate Unicode if needed; see above. @@ -1941,7 +1618,7 @@ AppendUnicodeToUtfRep( const Tcl_UniChar *unicode, /* String to convert to UTF. */ Tcl_Size numChars) /* Number of chars of Unicode to convert. */ { - UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); + String *stringPtr = GET_STRING(objPtr); numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars); @@ -1974,7 +1651,7 @@ AppendUtfToUnicodeRep( const char *bytes, /* String to convert to Unicode. */ Tcl_Size numBytes) /* Number of bytes of "bytes" to convert. */ { - UniCharString *stringPtr; + String *stringPtr; if (numBytes == 0) { return; @@ -1982,7 +1659,7 @@ AppendUtfToUnicodeRep( ExtendUnicodeRepWithString(objPtr, bytes, numBytes, -1); TclInvalidateStringRep(objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); stringPtr->allocated = 0; } @@ -2010,7 +1687,7 @@ AppendUtfToUtfRep( const char *bytes, /* String to append. */ Tcl_Size numBytes) /* Number of bytes of "bytes" to append. */ { - UniCharString *stringPtr; + String *stringPtr; Tcl_Size newLength, oldLength; if (numBytes == 0) { @@ -2031,9 +1708,9 @@ AppendUtfToUtfRep( } newLength = numBytes + oldLength; - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); if (newLength > stringPtr->allocated) { - Tcl_Size offset = TCL_INDEX_NONE; + Tcl_Size offset = -1; /* * Protect against case where unicode points into the existing @@ -2079,7 +1756,7 @@ AppendUtfToUtfRep( /* *---------------------------------------------------------------------- * - * Tcl_AppendStringsToObjVA -- + * Tcl_AppendStringsToObj -- * * This function appends one or more null-terminated strings to an * object. @@ -2095,10 +1772,13 @@ AppendUtfToUtfRep( */ void -Tcl_AppendStringsToObjVA( - Tcl_Obj *objPtr, /* Points to the object to append to. */ - va_list argList) /* Variable argument list. */ +Tcl_AppendStringsToObj( + Tcl_Obj *objPtr, + ...) { + va_list argList; + + va_start(argList, objPtr); if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_AppendStringsToObj"); } @@ -2111,35 +1791,6 @@ Tcl_AppendStringsToObjVA( } Tcl_AppendToObj(objPtr, bytes, -1); } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendStringsToObj -- - * - * This function appends one or more null-terminated strings to an - * object. - * - * Results: - * None. - * - * Side effects: - * The contents of all the string arguments are appended to the string - * representation of objPtr. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AppendStringsToObj( - Tcl_Obj *objPtr, - ...) -{ - va_list argList; - - va_start(argList, objPtr); - Tcl_AppendStringsToObjVA(objPtr, argList); va_end(argList); } @@ -2186,7 +1837,7 @@ Tcl_AppendFormatToObj( if (Tcl_IsShared(appendObj)) { Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj"); } - TclGetStringFromObj(appendObj, &originalLength); + (void)Tcl_GetStringFromObj(appendObj, &originalLength); limit = TCL_SIZE_MAX - originalLength; /* @@ -2450,12 +2101,12 @@ Tcl_AppendFormatToObj( goto errorMsg; case 's': if (gotPrecision) { - numChars = TclGetCharLength(segment); + numChars = Tcl_GetCharLength(segment); if (precision < numChars) { if (precision < 1) { TclNewObj(segment); } else { - segment = TclGetRange(segment, 0, precision - 1); + segment = Tcl_GetRange(segment, 0, precision - 1); } numChars = precision; Tcl_IncrRefCount(segment); @@ -2474,10 +2125,6 @@ Tcl_AppendFormatToObj( code = 0xFFFD; } length = Tcl_UniCharToUtf(code, buf); - if ((code >= 0xD800) && (length < 3)) { - /* Special case for handling high surrogates. */ - length += Tcl_UniCharToUtf(-1, buf + length); - } segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; @@ -2606,7 +2253,7 @@ Tcl_AppendFormatToObj( TclNewIntObj(pure, l); } Tcl_IncrRefCount(pure); - bytes = TclGetStringFromObj(pure, &length); + bytes = Tcl_GetStringFromObj(pure, &length); /* * Already did the sign above. @@ -2635,7 +2282,7 @@ Tcl_AppendFormatToObj( gotZero = 0; } if (gotZero) { - length += TclGetCharLength(segment); + length += Tcl_GetCharLength(segment); if (length < width) { segmentLimit -= width - length; } @@ -2767,7 +2414,7 @@ Tcl_AppendFormatToObj( gotZero = 0; } if (gotZero) { - length += TclGetCharLength(segment); + length += Tcl_GetCharLength(segment); if (length < width) { segmentLimit -= width - length; } @@ -2878,7 +2525,7 @@ Tcl_AppendFormatToObj( } if (width>0 && numChars<0) { - numChars = TclGetCharLength(segment); + numChars = Tcl_GetCharLength(segment); } if (!gotMinus && width>0) { if (numChars < width) { @@ -2890,7 +2537,7 @@ Tcl_AppendFormatToObj( } } - TclGetStringFromObj(segment, &segmentNumBytes); + (void)Tcl_GetStringFromObj(segment, &segmentNumBytes); if (segmentNumBytes > limit) { if (allocSegment) { Tcl_DecrRefCount(segment); @@ -3036,7 +2683,7 @@ AppendPrintfToObjVA( */ q = Tcl_UtfPrev(end, bytes); - if (!Tcl_UtfCharComplete(q, end - q)) { + if (!Tcl_UtfCharComplete(q, (end - q))) { end = q; } @@ -3047,7 +2694,7 @@ AppendPrintfToObjVA( } Tcl_ListObjAppendElement(NULL, list, - Tcl_NewStringObj(bytes , end - bytes)); + Tcl_NewStringObj(bytes , (end - bytes))); break; } @@ -3161,7 +2808,7 @@ AppendPrintfToObjVA( if (code != TCL_OK) { Tcl_AppendPrintfToObj(objPtr, "Unable to format \"%s\" with supplied arguments: %s", - format, Tcl_GetString(list)); + format, TclGetString(list)); } Tcl_DecrRefCount(list); } @@ -3242,15 +2889,15 @@ Tcl_ObjPrintf( char * TclGetStringStorage( Tcl_Obj *objPtr, - unsigned int *sizePtr) + Tcl_Size *sizePtr) { - UniCharString *stringPtr; + String *stringPtr; - if (!TclHasInternalRep(objPtr, &tclUniCharStringType) || objPtr->bytes == NULL) { - return TclGetStringFromObj(objPtr, (Tcl_Size *)sizePtr); + if (!TclHasInternalRep(objPtr, &tclStringType) || objPtr->bytes == NULL) { + return Tcl_GetStringFromObj(objPtr, sizePtr); } - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); *sizePtr = stringPtr->allocated; return objPtr->bytes; } @@ -3285,6 +2932,7 @@ TclStringRepeat( int unichar = 0; Tcl_Size done = 1; int binary = TclIsPureByteArray(objPtr); + Tcl_Size maxCount; /* assert (count >= 2) */ @@ -3296,8 +2944,8 @@ TclStringRepeat( */ if (!binary) { - if (TclHasInternalRep(objPtr, &tclUniCharStringType)) { - UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); + if (TclHasInternalRep(objPtr, &tclStringType)) { + String *stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode) { unichar = 1; } @@ -3306,13 +2954,16 @@ TclStringRepeat( if (binary) { /* Result will be pure byte array. Pre-size it */ - Tcl_GetByteArrayFromObj(objPtr, &length); + (void)Tcl_GetBytesFromObj(NULL, objPtr, &length); + maxCount = TCL_SIZE_MAX; } else if (unichar) { /* Result will be pure Tcl_UniChar array. Pre-size it. */ - TclGetUnicodeFromObj(objPtr, &length); + (void)Tcl_GetUnicodeFromObj(objPtr, &length); + maxCount = TCL_SIZE_MAX/sizeof(Tcl_UniChar); } else { /* Result will be concat of string reps. Pre-size it. */ - TclGetStringFromObj(objPtr, &length); + (void)Tcl_GetStringFromObj(objPtr, &length); + maxCount = TCL_SIZE_MAX; } if (length == 0) { @@ -3320,11 +2971,14 @@ TclStringRepeat( return objPtr; } - if (count > INT_MAX/length) { + /* maxCount includes space for null */ + if (count > (maxCount-1)) { if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%" TCL_SIZE_MODIFIER - "d bytes) exceeded", TCL_SIZE_MAX)); + 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", (void *)NULL); } return NULL; @@ -3335,6 +2989,7 @@ TclStringRepeat( objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ? Tcl_DuplicateObj(objPtr) : objPtr; + /* Allocate count*length space */ Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */ Tcl_SetByteArrayLength(objResultPtr, length); while (count - done > done) { @@ -3342,7 +2997,7 @@ TclStringRepeat( done *= 2; } TclAppendBytesToByteArray(objResultPtr, - Tcl_GetByteArrayFromObj(objResultPtr, (Tcl_Size *) NULL), + Tcl_GetBytesFromObj(NULL, objResultPtr, (Tcl_Size *) NULL), (count - done) * length); } else if (unichar) { /* @@ -3350,18 +3005,19 @@ TclStringRepeat( */ if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = TclNewUnicodeObj(TclGetUnicodeFromObj(objPtr, NULL), length); + objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length); } else { TclInvalidateStringRep(objPtr); objResultPtr = objPtr; } + /* TODO - overflow check */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "string size overflow: unable to alloc %" - TCL_Z_MODIFIER "u bytes", - UNICHAR_STRING_SIZE(count*length))); + TCL_SIZE_MODIFIER "d bytes", + STRING_SIZE(count*length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return NULL; @@ -3371,7 +3027,7 @@ TclStringRepeat( Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } - TclAppendUnicodeToObj(objResultPtr, TclGetUnicodeFromObj(objResultPtr, NULL), + Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), (count - done) * length); } else { /* @@ -3379,11 +3035,12 @@ TclStringRepeat( */ if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length); + objResultPtr = Tcl_NewStringObj(TclGetString(objPtr), length); } else { TclFreeInternalRep(objPtr); objResultPtr = objPtr; } + /* TODO - overflow check */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3398,7 +3055,7 @@ TclStringRepeat( Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } - Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr), + Tcl_AppendToObj(objResultPtr, TclGetString(objResultPtr), (count - done) * length); } return objResultPtr; @@ -3434,7 +3091,7 @@ TclStringCat( int allowUniChar = 1, requestUniChar = 0, forceUniChar = 0; Tcl_Size first = objc - 1; /* Index of first value possibly not empty */ Tcl_Size last = 0; /* Index of last value possibly not empty */ - int inPlace = flags & TCL_STRING_IN_PLACE; + int inPlace = (flags & TCL_STRING_IN_PLACE) && !Tcl_IsShared(*objv); /* assert ( objc >= 0 ) */ @@ -3475,7 +3132,7 @@ TclStringCat( binary = 0; if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) { forceUniChar = 1; - } else if ((objPtr->typePtr) && (objPtr->typePtr != &tclUniCharStringType)) { + } else if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { /* Prevent shimmer of non-string types. */ allowUniChar = 0; } @@ -3483,7 +3140,7 @@ TclStringCat( } else { /* assert (objPtr->typePtr != NULL) -- stork! */ binary = 0; - if (TclHasInternalRep(objPtr, &tclUniCharStringType)) { + if (TclHasInternalRep(objPtr, &tclStringType)) { /* Have a pure Unicode value; ask to preserve it */ requestUniChar = 1; } else { @@ -3498,7 +3155,7 @@ TclStringCat( * Result will be pure byte array. Pre-size it */ - Tcl_Size numBytes; + Tcl_Size numBytes = 0; ov = objv; oc = objc; do { @@ -3511,7 +3168,7 @@ TclStringCat( */ if (TclIsPureByteArray(objPtr)) { - Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ + (void)Tcl_GetBytesFromObj(NULL, objPtr, &numBytes); /* PANIC? */ if (numBytes) { last = objc - oc; @@ -3538,12 +3195,13 @@ TclStringCat( if ((objPtr->bytes == NULL) || (objPtr->length)) { Tcl_Size numChars; - TclGetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ + (void)Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ if (numChars) { last = objc - oc; if (length == 0) { first = last; - } else if (length > TCL_SIZE_MAX - numChars) { + } + if (length > (Tcl_Size) ((TCL_SIZE_MAX/sizeof(Tcl_UniChar))-numChars)) { goto overflow; } length += numChars; @@ -3567,11 +3225,12 @@ TclStringCat( Tcl_Obj *objPtr = *ov++; - if (objPtr->bytes == NULL) { + if (objPtr->bytes == NULL + && TclCheckEmptyString(objPtr) != TCL_EMPTYSTRING_YES) { /* No string rep; Take the chance we can avoid making it */ pendingPtr = objPtr; } else { - TclGetStringFromObj(objPtr, &length); /* PANIC? */ + (void)Tcl_GetStringFromObj(objPtr, &length); /* PANIC? */ } } while (--oc && (length == 0) && (pendingPtr == NULL)); @@ -3597,20 +3256,20 @@ TclStringCat( do { Tcl_Obj *objPtr = *ov++; - TclGetStringFromObj(objPtr, &numBytes); /* PANIC? */ + (void)Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */ } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL); if (numBytes) { last = objc -oc -1; } if (oc || numBytes) { - TclGetStringFromObj(pendingPtr, &length); + (void)Tcl_GetStringFromObj(pendingPtr, &length); } if (length == 0) { if (numBytes) { first = last; } - } else if (numBytes > TCL_SIZE_MAX - length) { + } else if (numBytes > (TCL_SIZE_MAX - length)) { goto overflow; } length += numBytes; @@ -3623,10 +3282,11 @@ TclStringCat( /* assert ( length > 0 && pendingPtr == NULL ) */ - TclGetStringFromObj(objPtr, &numBytes); /* PANIC? */ + TclGetString(objPtr); /* PANIC? */ + numBytes = objPtr->length; if (numBytes) { last = objc - oc; - if (numBytes > TCL_SIZE_MAX - length) { + if (numBytes > (TCL_SIZE_MAX - length)) { goto overflow; } length += numBytes; @@ -3642,6 +3302,7 @@ TclStringCat( } objv += first; objc = (last - first + 1); + inPlace = (flags & TCL_STRING_IN_PLACE) && !Tcl_IsShared(*objv); if (binary) { /* Efficiently produce a pure byte array result */ @@ -3652,11 +3313,11 @@ TclStringCat( * failure to allocate enough space. Following stanza may panic. */ - if (inPlace && !Tcl_IsShared(*objv)) { - Tcl_Size start; + if (inPlace) { + Tcl_Size start = 0; objResultPtr = *objv++; objc--; - Tcl_GetByteArrayFromObj(objResultPtr, &start); + (void)Tcl_GetBytesFromObj(NULL, objResultPtr, &start); dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; } else { objResultPtr = Tcl_NewByteArrayObj(NULL, length); @@ -3672,8 +3333,8 @@ TclStringCat( */ if (TclIsPureByteArray(objPtr)) { - Tcl_Size more; - unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more); + Tcl_Size more = 0; + unsigned char *src = Tcl_GetBytesFromObj(NULL, objPtr, &more); memcpy(dst, src, more); dst += more; } @@ -3682,49 +3343,49 @@ TclStringCat( /* Efficiently produce a pure Tcl_UniChar array result */ Tcl_UniChar *dst; - if (inPlace && !Tcl_IsShared(*objv)) { + if (inPlace) { Tcl_Size start; objResultPtr = *objv++; objc--; /* Ugly interface! Force resize of the unicode array. */ - TclGetUnicodeFromObj(objResultPtr, &start); + (void)Tcl_GetUnicodeFromObj(objResultPtr, &start); Tcl_InvalidateStringRep(objResultPtr); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", - UNICHAR_STRING_SIZE(length))); + STRING_SIZE(length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return NULL; } - dst = TclGetUnicodeFromObj(objResultPtr, NULL) + start; + dst = Tcl_GetUnicode(objResultPtr) + start; } else { Tcl_UniChar ch = 0; /* Ugly interface! No scheme to init array size. */ - objResultPtr = TclNewUnicodeObj(&ch, 0); /* PANIC? */ + objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { Tcl_DecrRefCount(objResultPtr); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", - UNICHAR_STRING_SIZE(length))); + STRING_SIZE(length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return NULL; } - dst = TclGetUnicodeFromObj(objResultPtr, NULL); + dst = Tcl_GetUnicode(objResultPtr); } while (objc--) { Tcl_Obj *objPtr = *objv++; if ((objPtr->bytes == NULL) || (objPtr->length)) { Tcl_Size more; - Tcl_UniChar *src = TclGetUnicodeFromObj(objPtr, &more); + Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more); memcpy(dst, src, more * sizeof(Tcl_UniChar)); dst += more; } @@ -3733,12 +3394,12 @@ TclStringCat( /* Efficiently concatenate string reps */ char *dst; - if (inPlace && !Tcl_IsShared(*objv)) { + if (inPlace) { Tcl_Size start; objResultPtr = *objv++; objc--; - TclGetStringFromObj(objResultPtr, &start); + (void)Tcl_GetStringFromObj(objResultPtr, &start); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3748,7 +3409,7 @@ TclStringCat( } return NULL; } - dst = Tcl_GetString(objResultPtr) + start; + dst = TclGetString(objResultPtr) + start; /* assert ( length > start ) */ TclFreeInternalRep(objResultPtr); @@ -3764,14 +3425,14 @@ TclStringCat( } return NULL; } - dst = Tcl_GetString(objResultPtr); + dst = TclGetString(objResultPtr); } while (objc--) { Tcl_Obj *objPtr = *objv++; if ((objPtr->bytes == NULL) || (objPtr->length)) { Tcl_Size more; - char *src = TclGetStringFromObj(objPtr, &more); + char *src = Tcl_GetStringFromObj(objPtr, &more); memcpy(dst, src, more); dst += more; @@ -3807,36 +3468,116 @@ TclStringCat( *--------------------------------------------------------------------------- */ + +static int +UniCharNcasememcmp( + const void *ucsPtr, /* Unicode string to compare to uct. */ + const void *uctPtr, /* Unicode string ucs is compared to. */ + size_t numChars) /* Number of Unichars to compare. */ +{ + const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; + const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; + for ( ; numChars != 0; numChars--, ucs++, uct++) { + if (*ucs != *uct) { + Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); + Tcl_UniChar lct = Tcl_UniCharToLower(*uct); + + if (lcs != lct) { + return (lcs - lct); + } + } + } + return 0; +} + static int UtfNmemcmp( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ - size_t numBytes) /* Number of *bytes* to compare. */ + size_t numChars) /* Number of UTF chars to compare. */ { + Tcl_UniChar ch1 = 0, ch2 = 0; const char *cs = (const char *)csPtr; const char *ct = (const char *)ctPtr; + /* - * We can't simply call 'memcmp(cs, ct, numBytes);' because we need to - * check for Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes - * fine in the strcmp manner. + * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the + * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001 + * (the byte 0x01.) */ - int result = 0; + while (numChars-- > 0) { + /* + * n must be interpreted as chars, not bytes. This should be called + * only when both strings are of at least n chars long (no need for \0 + * check) + */ - for ( ; numBytes != 0; numBytes--, cs++, ct++) { - if (*cs != *ct) { - result = UCHAR(*cs) - UCHAR(*ct); - break; + cs += TclUtfToUniChar(cs, &ch1); + ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { + return (ch1 - ch2); } } - if (numBytes && ((UCHAR(*cs) == 0xC0) || (UCHAR(*ct) == 0xC0))) { - unsigned char c1, c2; + return 0; +} - c1 = ((UCHAR(*cs) == 0xC0) && (UCHAR(cs[1]) == 0x80)) ? 0 : UCHAR(*cs); - c2 = ((UCHAR(*ct) == 0xC0) && (UCHAR(ct[1]) == 0x80)) ? 0 : UCHAR(*ct); - result = (c1 - c2); +static int +UtfNcasememcmp( + const void *csPtr, /* UTF string to compare to ct. */ + const void *ctPtr, /* UTF string cs is compared to. */ + size_t numChars) /* Number of UTF chars to compare. */ +{ + Tcl_UniChar ch1 = 0, ch2 = 0; + const char *cs = (const char *)csPtr; + const char *ct = (const char *)ctPtr; + + while (numChars-- > 0) { + /* + * n must be interpreted as chars, not bytes. + * This should be called only when both strings are of + * at least n chars long (no need for \0 check) + */ + cs += TclUtfToUniChar(cs, &ch1); + ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { + ch1 = Tcl_UniCharToLower(ch1); + ch2 = Tcl_UniCharToLower(ch2); + if (ch1 != ch2) { + return (ch1 - ch2); + } + } + } + return 0; +} + +static int +UniCharNmemcmp( + const void *ucsPtr, /* Unicode string to compare to uct. */ + const void *uctPtr, /* Unicode string ucs is compared to. */ + size_t numChars) /* Number of unichars to compare. */ +{ + const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; + const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; +#if defined(WORDS_BIGENDIAN) + /* + * We are definitely on a big-endian machine; memcmp() is safe + */ + + return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); + +#else /* !WORDS_BIGENDIAN */ + /* + * We can't simply call memcmp() because that is not lexically correct. + */ + + for ( ; numChars != 0; ucs++, uct++, numChars--) { + if (*ucs != *uct) { + return (*ucs - *uct); + } } - return result; + return 0; +#endif /* WORDS_BIGENDIAN */ } int @@ -3846,11 +3587,11 @@ TclStringCmp( int checkEq, /* comparison is only for equality */ int nocase, /* comparison is not case sensitive */ Tcl_Size reqlength) /* requested length in characters; - * negative to compare whole strings */ + * TCL_INDEX_NONE to compare whole strings */ { const char *s1, *s2; int empty, match; - Tcl_Size length, s1len, s2len; + Tcl_Size length, s1len = 0, s2len = 0; memCmpFn_t memCmpFn; if ((reqlength == 0) || (value1Ptr == value2Ptr)) { @@ -3869,11 +3610,11 @@ TclStringCmp( * arrays anyway, and we have no memcasecmp() for some reason... :^) */ - s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len); - s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + s1 = (char *) Tcl_GetBytesFromObj(NULL, value1Ptr, &s1len); + s2 = (char *) Tcl_GetBytesFromObj(NULL, value2Ptr, &s2len); memCmpFn = memcmp; - } else if (TclHasInternalRep(value1Ptr, &tclUniCharStringType) - && TclHasInternalRep(value2Ptr, &tclUniCharStringType)) { + } else if (TclHasInternalRep(value1Ptr, &tclStringType) + && TclHasInternalRep(value2Ptr, &tclStringType)) { /* * Do a Unicode-specific comparison if both of the args are of String * type. If the char length == byte length, we can do a memcmp. In @@ -3882,12 +3623,12 @@ TclStringCmp( */ if (nocase) { - s1 = (char *) TclGetUnicodeFromObj(value1Ptr, &s1len); - s2 = (char *) TclGetUnicodeFromObj(value2Ptr, &s2len); - memCmpFn = TclUniCharNcasememcmp; + s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); + s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); + memCmpFn = UniCharNcasememcmp; } else { - s1len = TclGetCharLength(value1Ptr); - s2len = TclGetCharLength(value2Ptr); + s1len = Tcl_GetCharLength(value1Ptr); + s2len = Tcl_GetCharLength(value2Ptr); if ((s1len == value1Ptr->length) && (value1Ptr->bytes != NULL) && (s2len == value2Ptr->length) @@ -3899,8 +3640,8 @@ TclStringCmp( s2 = value2Ptr->bytes; memCmpFn = memcmp; } else { - s1 = (char *) TclGetUnicodeFromObj(value1Ptr, NULL); - s2 = (char *) TclGetUnicodeFromObj(value2Ptr, NULL); + s1 = (char *) Tcl_GetUnicode(value1Ptr); + s2 = (char *) Tcl_GetUnicode(value2Ptr); if ( #if defined(WORDS_BIGENDIAN) 1 @@ -3915,7 +3656,7 @@ TclStringCmp( reqlength *= sizeof(Tcl_UniChar); } } else { - memCmpFn = TclUniCharNmemcmp; + memCmpFn = UniCharNmemcmp; } } } @@ -3926,7 +3667,7 @@ TclStringCmp( case -1: s1 = 0; s1len = 0; - s2 = TclGetStringFromObj(value2Ptr, &s2len); + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); break; case 0: match = -1; @@ -3941,7 +3682,7 @@ TclStringCmp( case -1: s2 = 0; s2len = 0; - s1 = TclGetStringFromObj(value1Ptr, &s1len); + s1 = Tcl_GetStringFromObj(value1Ptr, &s1len); break; case 0: match = 1; @@ -3952,8 +3693,8 @@ TclStringCmp( goto matchdone; } } else { - s1 = TclGetStringFromObj(value1Ptr, &s1len); - s2 = TclGetStringFromObj(value2Ptr, &s2len); + s1 = Tcl_GetStringFromObj(value1Ptr, &s1len); + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); } if (!nocase && checkEq && reqlength < 0) { /* @@ -3973,11 +3714,11 @@ TclStringCmp( */ if ((reqlength < 0) && !nocase) { - memCmpFn = UtfNmemcmp; + memCmpFn = TclpUtfNcmp2; } else { - s1len = TclNumUtfChars(s1, s1len); - s2len = TclNumUtfChars(s2, s2len); - memCmpFn = nocase ? TclUtfNcasememcmp : TclUtfNmemcmp; + s1len = Tcl_NumUtfChars(s1, s1len); + s2len = Tcl_NumUtfChars(s2, s2len); + memCmpFn = nocase ? UtfNcasememcmp : UtfNmemcmp; } } } @@ -4041,8 +3782,8 @@ TclStringFirst( Tcl_Obj *haystack, Tcl_Size start) { - Tcl_Size lh, ln = TclGetCharLength(needle); - Tcl_Size value = TCL_INDEX_NONE; + Tcl_Size lh = 0, ln = Tcl_GetCharLength(needle); + Tcl_Size value = -1; Tcl_UniChar *checkStr, *endStr, *uh, *un; Tcl_Obj *obj; @@ -4058,10 +3799,10 @@ TclStringFirst( if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { unsigned char *end, *check, *bh; - unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); + unsigned char *bn = Tcl_GetBytesFromObj(NULL, needle, &ln); /* Find bytes in bytes */ - bh = Tcl_GetByteArrayFromObj(haystack, &lh); + bh = Tcl_GetBytesFromObj(NULL, haystack, &lh); if ((lh < ln) || (start > lh - ln)) { /* Don't start the loop if there cannot be a valid answer */ goto firstEnd; @@ -4104,8 +3845,8 @@ TclStringFirst( * do only the well-defined Tcl_UniChar array search. */ - un = TclGetUnicodeFromObj(needle, &ln); - uh = TclGetUnicodeFromObj(haystack, &lh); + un = Tcl_GetUnicodeFromObj(needle, &ln); + uh = Tcl_GetUnicodeFromObj(haystack, &lh); if ((lh < ln) || (start > lh - ln)) { /* Don't start the loop if there cannot be a valid answer */ goto firstEnd; @@ -4148,8 +3889,8 @@ TclStringLast( Tcl_Obj *haystack, Tcl_Size last) { - Tcl_Size lh, ln = TclGetCharLength(needle); - Tcl_Size value = TCL_INDEX_NONE; + Tcl_Size lh = 0, ln = Tcl_GetCharLength(needle); + Tcl_Size value = -1; Tcl_UniChar *checkStr, *uh, *un; Tcl_Obj *obj; @@ -4164,8 +3905,8 @@ TclStringLast( } if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { - unsigned char *check, *bh = Tcl_GetByteArrayFromObj(haystack, &lh); - unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); + unsigned char *check, *bh = Tcl_GetBytesFromObj(NULL, haystack, &lh); + unsigned char *bn = Tcl_GetBytesFromObj(NULL, needle, &ln); if (last >= lh) { last = lh - 1; @@ -4187,8 +3928,8 @@ TclStringLast( goto lastEnd; } - uh = TclGetUnicodeFromObj(haystack, &lh); - un = TclGetUnicodeFromObj(needle, &ln); + uh = Tcl_GetUnicodeFromObj(haystack, &lh); + un = Tcl_GetUnicodeFromObj(needle, &ln); if (last >= lh) { last = lh - 1; @@ -4258,27 +3999,27 @@ TclStringReverse( Tcl_Obj *objPtr, int flags) { - UniCharString *stringPtr; + String *stringPtr; Tcl_UniChar ch = 0; int inPlace = flags & TCL_STRING_IN_PLACE; if (TclIsPureByteArray(objPtr)) { - Tcl_Size numBytes; - unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes); + Tcl_Size numBytes = 0; + unsigned char *from = Tcl_GetBytesFromObj(NULL, objPtr, &numBytes); if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } - ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, (Tcl_Size *)NULL), from, numBytes); + ReverseBytes(Tcl_GetBytesFromObj(NULL, objPtr, (Tcl_Size *)NULL), from, numBytes); return objPtr; } SetStringFromAny(NULL, objPtr); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode) { - Tcl_UniChar *from = TclGetUnicodeFromObj(objPtr, NULL); - stringPtr = GET_UNICHAR_STRING(objPtr); + Tcl_UniChar *from = Tcl_GetUnicode(objPtr); + stringPtr = GET_STRING(objPtr); Tcl_UniChar *src = from + stringPtr->numChars; Tcl_UniChar *to; @@ -4288,10 +4029,10 @@ TclStringReverse( * Tcl_SetObjLength into growing the Unicode rep buffer. */ - objPtr = TclNewUnicodeObj(&ch, 1); + objPtr = Tcl_NewUnicodeObj(&ch, 1); Tcl_SetObjLength(objPtr, stringPtr->numChars); - to = TclGetUnicodeFromObj(objPtr, NULL); - stringPtr = GET_UNICHAR_STRING(objPtr); + to = Tcl_GetUnicode(objPtr); + stringPtr = GET_STRING(objPtr); while (--src >= from) { *to++ = *src; } @@ -4415,8 +4156,8 @@ TclStringReplace( */ if (TclIsPureByteArray(objPtr)) { - Tcl_Size numBytes; - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes); + Tcl_Size numBytes = 0; + unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &numBytes); if (insertPtr == NULL) { /* Replace something with nothing. */ @@ -4438,9 +4179,9 @@ TclStringReplace( } if (TclIsPureByteArray(insertPtr)) { - Tcl_Size newBytes; + Tcl_Size newBytes = 0; unsigned char *iBytes - = Tcl_GetByteArrayFromObj(insertPtr, &newBytes); + = Tcl_GetBytesFromObj(NULL, insertPtr, &newBytes); if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) { /* @@ -4484,16 +4225,16 @@ TclStringReplace( /* The traditional implementation... */ { Tcl_Size numChars; - Tcl_UniChar *ustring = TclGetUnicodeFromObj(objPtr, &numChars); + Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars); /* TODO: Is there an in-place option worth pursuing here? */ - result = TclNewUnicodeObj(ustring, first); + result = Tcl_NewUnicodeObj(ustring, first); if (insertPtr) { Tcl_AppendObjToObj(result, insertPtr); } if ((first + count) < numChars) { - TclAppendUnicodeToObj(result, ustring + first + count, + Tcl_AppendUnicodeToObj(result, ustring + first + count, numChars - first - count); } @@ -4523,7 +4264,7 @@ FillUnicodeRep( Tcl_Obj *objPtr) /* The object in which to fill the unicode * rep. */ { - UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); + String *stringPtr = GET_STRING(objPtr); ExtendUnicodeRepWithString(objPtr, objPtr->bytes, objPtr->length, stringPtr->numChars); @@ -4536,22 +4277,21 @@ ExtendUnicodeRepWithString( Tcl_Size numBytes, Tcl_Size numAppendChars) { - UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); + String *stringPtr = GET_STRING(objPtr); Tcl_Size needed, numOrigChars = 0; Tcl_UniChar *dst, unichar = 0; if (stringPtr->hasUnicode) { numOrigChars = stringPtr->numChars; } - if (numAppendChars < 0) { + if (numAppendChars == TCL_INDEX_NONE) { TclNumUtfCharsM(numAppendChars, bytes, numBytes); } needed = numOrigChars + numAppendChars; - uniCharStringCheckLimits(needed); if (needed > stringPtr->maxChars) { GrowUnicodeBuffer(objPtr, needed); - stringPtr = GET_UNICHAR_STRING(objPtr); + stringPtr = GET_STRING(objPtr); } stringPtr->hasUnicode = 1; @@ -4563,12 +4303,6 @@ ExtendUnicodeRepWithString( dst = stringPtr->unicode + numOrigChars; if (numAppendChars-- > 0) { bytes += TclUtfToUniChar(bytes, &unichar); - /* join upper/lower surrogate */ - if (bytes && (stringPtr->unicode[numOrigChars - 1] | 0x3FF) == 0xDBFF && (unichar | 0x3FF) == 0xDFFF) { - stringPtr->numChars--; - unichar = ((stringPtr->unicode[numOrigChars - 1] & 0x3FF) << 10) + (unichar & 0x3FF) + 0x10000; - dst--; - } *dst++ = unichar; while (numAppendChars-- > 0) { bytes += TclUtfToUniChar(bytes, &unichar); @@ -4603,8 +4337,8 @@ DupStringInternalRep( Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { - UniCharString *srcStringPtr = GET_UNICHAR_STRING(srcPtr); - UniCharString *copyStringPtr = NULL; + String *srcStringPtr = GET_STRING(srcPtr); + String *copyStringPtr = NULL; if (srcStringPtr->numChars == TCL_INDEX_NONE) { /* @@ -4623,17 +4357,17 @@ DupStringInternalRep( } else { copyMaxChars = srcStringPtr->maxChars; } - copyStringPtr = uniCharStringAttemptAlloc(copyMaxChars); + copyStringPtr = stringAttemptAlloc(copyMaxChars); if (copyStringPtr == NULL) { copyMaxChars = srcStringPtr->numChars; - copyStringPtr = uniCharStringAlloc(copyMaxChars); + copyStringPtr = stringAlloc(copyMaxChars); } copyStringPtr->maxChars = copyMaxChars; memcpy(copyStringPtr->unicode, srcStringPtr->unicode, srcStringPtr->numChars * sizeof(Tcl_UniChar)); copyStringPtr->unicode[srcStringPtr->numChars] = 0; } else { - copyStringPtr = uniCharStringAlloc(0); + copyStringPtr = stringAlloc(0); copyStringPtr->maxChars = 0; copyStringPtr->unicode[0] = 0; } @@ -4648,8 +4382,8 @@ DupStringInternalRep( copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0; - SET_UNICHAR_STRING(copyPtr, copyStringPtr); - copyPtr->typePtr = &tclUniCharStringType; + SET_STRING(copyPtr, copyStringPtr); + copyPtr->typePtr = &tclStringType; } /* @@ -4674,8 +4408,8 @@ SetStringFromAny( TCL_UNUSED(Tcl_Interp *), Tcl_Obj *objPtr) /* The object to convert. */ { - if (!TclHasInternalRep(objPtr, &tclUniCharStringType)) { - UniCharString *stringPtr = uniCharStringAlloc(0); + if (!TclHasInternalRep(objPtr, &tclStringType)) { + String *stringPtr = stringAlloc(0); /* * Convert whatever we have into an untyped value. Just A String. @@ -4693,8 +4427,8 @@ SetStringFromAny( stringPtr->allocated = objPtr->length; stringPtr->maxChars = 0; stringPtr->hasUnicode = 0; - SET_UNICHAR_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclUniCharStringType; + SET_STRING(objPtr, stringPtr); + objPtr->typePtr = &tclStringType; } return TCL_OK; } @@ -4721,7 +4455,7 @@ static void UpdateStringOfString( Tcl_Obj *objPtr) /* Object with string rep to update. */ { - UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); + String *stringPtr = GET_STRING(objPtr); /* * This routine is only called when we need to generate the @@ -4753,7 +4487,7 @@ ExtendStringRepWithUnicode( Tcl_Size i, origLength, size = 0; char *dst; - UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); + String *stringPtr = GET_STRING(objPtr); if (numChars < 0) { numChars = UnicodeLength(unicode); @@ -4778,6 +4512,7 @@ ExtendStringRepWithUnicode( } for (i = 0; i < numChars && size >= 0; i++) { + /* TODO - overflow check! I don't think check below at end suffices */ size += TclUtfCount(unicode[i]); } if (size < 0) { @@ -4795,13 +4530,7 @@ ExtendStringRepWithUnicode( copyBytes: dst = objPtr->bytes + origLength; for (i = 0; i < numChars; i++) { - if (LOW_SURROGATE(unicode[i]) && ((i == 0) || !HIGH_SURROGATE(unicode[i-1]))) { - *dst = 0; /* In case of lower surrogate, don't try to combine */ - } dst += Tcl_UniCharToUtf(unicode[i], dst); - if (HIGH_SURROGATE(unicode[i]) && ((i+1 >= numChars) || !LOW_SURROGATE(unicode[i+1]))) { - dst += Tcl_UniCharToUtf(-1, dst); - } } *dst = '\0'; objPtr->length = dst - objPtr->bytes; @@ -4813,7 +4542,7 @@ ExtendStringRepWithUnicode( * * FreeStringInternalRep -- * - * Deallocate the storage associated with a (UniChar)String data object's internal + * Deallocate the storage associated with a String data object's internal * representation. * * Results: @@ -4829,7 +4558,7 @@ static void FreeStringInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ckfree(GET_STRING(objPtr)); + Tcl_Free(GET_STRING(objPtr)); objPtr->typePtr = NULL; } diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index aee378d..4e38a64 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -6,7 +6,7 @@ * * Conceptually, a string is a sequence of Unicode code points. Internally * it may be stored in an encoding form such as a modified version of UTF-8 - * or UTF-16 (when TCL_UTF_MAX=3) or UTF-32. + * or UTF-32. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. @@ -42,31 +42,25 @@ typedef struct { * space allocated for the Unicode array. */ int hasUnicode; /* Boolean determining whether the string has * a Tcl_UniChar representation. */ - unsigned short unicode[TCLFLEXARRAY]; /* The array of Tcl_UniChar units. + Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Tcl_UniChar units. * The actual size of this field depends on * the maxChars field above. */ } String; /* Limit on string lengths. The -1 because limit does not include the nul */ #define STRING_MAXCHARS \ - (Tcl_Size)(((size_t)UINT_MAX - offsetof(String, unicode))/sizeof(unsigned short) - 1) + ((Tcl_Size)((TCL_SIZE_MAX - offsetof(String, unicode))/sizeof(Tcl_UniChar) - 1)) +/* Memory needed to hold a string of length numChars - including NUL */ #define STRING_SIZE(numChars) \ - (offsetof(String, unicode) + sizeof(unsigned short) + ((numChars) * sizeof(unsigned short))) -#define stringCheckLimits(numChars) \ - do { \ - if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ - Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \ - STRING_MAXCHARS); \ - } \ - } while (0) + (offsetof(String, unicode) + sizeof(Tcl_UniChar) + ((numChars) * sizeof(Tcl_UniChar))) #define stringAttemptAlloc(numChars) \ - (String *) attemptckalloc(STRING_SIZE(numChars)) + (String *) Tcl_AttemptAlloc(STRING_SIZE(numChars)) #define stringAlloc(numChars) \ - (String *) ckalloc(STRING_SIZE(numChars)) + (String *) Tcl_Alloc(STRING_SIZE(numChars)) #define stringRealloc(ptr, numChars) \ - (String *) ckrealloc((ptr), STRING_SIZE(numChars)) + (String *) Tcl_Realloc((ptr), STRING_SIZE(numChars)) #define stringAttemptRealloc(ptr, numChars) \ - (String *) attemptckrealloc((ptr), STRING_SIZE(numChars)) + (String *) Tcl_AttemptRealloc((ptr), STRING_SIZE(numChars)) #define GET_STRING(objPtr) \ ((String *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_STRING(objPtr, stringPtr) \ diff --git a/generic/tclStubCall.c b/generic/tclStubCall.c new file mode 100644 index 0000000..29af44c --- /dev/null +++ b/generic/tclStubCall.c @@ -0,0 +1,117 @@ +/* + * tclStubCall.c -- + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#ifndef _WIN32 +# include <dlfcn.h> +#else +# define dlopen(a,b) (void *)LoadLibraryW(JOIN(L,a)) +# define dlsym(a,b) (void *)GetProcAddress((HMODULE)(a),b) +# define dlerror() "" +#endif + +MODULE_SCOPE void *tclStubsHandle; + +/* + *---------------------------------------------------------------------- + * + * TclStubCall -- + * + * Load the Tcl core dynamically, version "9.0" (or higher, in future versions). + * + * Results: + * Returns a function from the Tcl dynamic library or a function + * returning NULL if that function cannot be found. See PROCNAME table. + * + * The functions Tcl_MainEx and Tcl_MainExW never return. + * Tcl_GetMemoryInfo and Tcl_StaticLibrary return (void), + * Tcl_SetExitProc returns its previous exitProc and + * Tcl_SetPreInitScript returns the previous script. This means that + * those 6 functions cannot be used to initialize the stub-table, + * only the first 4 functions in the table can do that. + * + *---------------------------------------------------------------------- + */ + +/* Table containing which function will be returned, depending on the "arg" */ +static const char PROCNAME[][24] = { + "_Tcl_SetPanicProc", /* Default, whenever "arg" <= 0 or "arg" > 9 */ + "_Tcl_InitSubsystems", /* "arg" == (void *)1 */ + "_Tcl_FindExecutable", /* "arg" == (void *)2 */ + "_TclZipfs_AppHook", /* "arg" == (void *)3 */ + "_Tcl_MainExW", /* "arg" == (void *)4 */ + "_Tcl_MainEx", /* "arg" == (void *)5 */ + "_Tcl_StaticLibrary", /* "arg" == (void *)6 */ + "_Tcl_SetExitProc", /* "arg" == (void *)7 */ + "_Tcl_GetMemoryInfo", /* "arg" == (void *)8 */ + "_Tcl_SetPreInitScript" /* "arg" == (void *)9 */ +}; + +MODULE_SCOPE const void *nullVersionProc(void) { + return NULL; +} + +static const char CANNOTCALL[] = "Cannot call %s from stubbed extension\n"; +static const char CANNOTFIND[] = "Cannot find %s: %s\n"; + +MODULE_SCOPE void * +TclStubCall(void *arg) +{ + static void *stubFn[] = {NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}; + size_t index = PTR2UINT(arg); + + if (index >= sizeof(PROCNAME)/sizeof(PROCNAME[0])) { + /* Any other value means Tcl_SetPanicProc() with non-null panicProc */ + index = 0; + } + if (tclStubsHandle == INT2PTR(-1)) { + if ((index == 0) && (arg != NULL)) { + ((Tcl_PanicProc *)arg)(CANNOTCALL, PROCNAME[index] + 1); + } else { + fprintf(stderr, CANNOTCALL, PROCNAME[index] + 1); + abort(); + } + } + if (!stubFn[index]) { + if (!tclStubsHandle) { + tclStubsHandle = dlopen(CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); + if (!tclStubsHandle) { +#if defined(_WIN32) + tclStubsHandle = dlopen(CFG_RUNTIME_BINDIR "\\" CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); +#elif defined(__CYGWIN__) + tclStubsHandle = dlopen(CFG_RUNTIME_BINDIR "/" CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); +#else + tclStubsHandle = dlopen(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); +#endif + } + if (!tclStubsHandle) { + if ((index == 0) && (arg != NULL)) { + ((Tcl_PanicProc *)arg)(CANNOTFIND, CFG_RUNTIME_DLLFILE, dlerror()); + } else { + fprintf(stderr, CANNOTFIND, CFG_RUNTIME_DLLFILE, dlerror()); + abort(); + } + } + } + stubFn[index] = dlsym(tclStubsHandle, PROCNAME[index] + 1); + if (!stubFn[index]) { + stubFn[index] = dlsym(tclStubsHandle, PROCNAME[index]); + if (!stubFn[index]) { + stubFn[index] = (void *)nullVersionProc; + } + } + } + return stubFn[index]; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 5cf3815..34e8c27 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -28,8 +28,6 @@ */ #undef Tcl_Alloc -#undef Tcl_AttemptAlloc -#undef Tcl_AttemptRealloc #undef Tcl_Free #undef Tcl_Realloc #undef Tcl_NewBooleanObj @@ -43,13 +41,8 @@ #undef Tcl_NewStringObj #undef Tcl_GetUnicode #undef Tcl_GetUnicodeFromObj -#undef Tcl_AppendUnicodeToObj #undef Tcl_NewUnicodeObj #undef Tcl_SetUnicodeObj -#undef Tcl_UniCharNcasecmp -#undef Tcl_UniCharCaseMatch -#undef Tcl_UniCharLen -#undef Tcl_UniCharNcmp #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef Tcl_FindHashEntry @@ -62,96 +55,169 @@ #undef TclSockMinimumBuffers #undef Tcl_SetIntObj #undef Tcl_SetLongObj -#undef TclpInetNtoa -#undef TclWinGetServByName -#undef TclWinGetSockOpt -#undef TclWinSetSockOpt -#undef TclWinNToHS +#undef Tcl_ListObjGetElements +#undef Tcl_ListObjLength +#undef Tcl_DictObjSize +#undef Tcl_SplitList +#undef Tcl_SplitPath +#undef Tcl_FSSplitPath +#undef Tcl_ParseArgsObjv #undef TclStaticLibrary -#undef Tcl_BackgroundError -#undef TclGuessPackageName -#undef TclGetLoadedPackages #define TclStaticLibrary Tcl_StaticLibrary #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar -#undef Tcl_MacOSXOpenBundleResources -#undef TclWinConvertWSAError -#undef TclWinConvertError +#undef Tcl_UniCharLen #undef TclObjInterpProc - -#if defined(_WIN32) || defined(__CYGWIN__) -#define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError -#define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError +#if !defined(_WIN32) && !defined(__CYGWIN__) +# undef Tcl_WinConvertError +# define Tcl_WinConvertError 0 #endif - - #if defined(TCL_NO_DEPRECATED) -static void uniCodePanic(void) { - Tcl_Panic("Tcl is compiled without the the UTF16 compatibility layer (-DTCL_NO_DEPRECATED)"); -} -# define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *))(void *)uniCodePanic -# define Tcl_GetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, int *))(void *)uniCodePanic -# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const unsigned short *, int))(void *)uniCodePanic -# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic -# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic -# define Tcl_UtfAtIndex (const char *(*)(const char *, int))(void *)uniCodePanic -# define Tcl_GetCharLength (int(*)(Tcl_Obj *))(void *)uniCodePanic -# define Tcl_UniCharNcmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic -# define Tcl_UniCharNcasecmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic -# define Tcl_UniCharCaseMatch (int(*)(const unsigned short *, const unsigned short *, int))(void *)uniCodePanic -# define Tcl_GetRange (Tcl_Obj *(*)(Tcl_Obj *, int, int))(void *)uniCodePanic -# define Tcl_GetUniChar (int(*)(Tcl_Obj *, int))(void *)uniCodePanic -# define Tcl_NumUtfChars (int(*)(const char *, int))(void *)uniCodePanic -# define Tcl_UtfNcmp (int(*)(const char *, const char *, unsigned long))(void *)uniCodePanic -# define Tcl_UtfNcasecmp (int(*)(const char *, const char *, unsigned long))(void *)uniCodePanic +# undef TclGetStringFromObj +# undef TclGetBytesFromObj +# undef TclGetUnicodeFromObj +# define TclGetStringFromObj 0 +# define TclGetBytesFromObj 0 +# define TclGetUnicodeFromObj 0 #endif +#undef Tcl_Close +#define Tcl_Close 0 +#undef Tcl_GetByteArrayFromObj +#define Tcl_GetByteArrayFromObj 0 +#define TclUnusedStubEntry 0 +#define TclUtfCharComplete Tcl_UtfCharComplete +#define TclUtfNext Tcl_UtfNext +#define TclUtfPrev Tcl_UtfPrev -#define TclUtfCharComplete UtfCharComplete -#define TclUtfNext UtfNext -#define TclUtfPrev UtfPrev - -static int TclUtfCharComplete(const char *src, int length) { - if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) { - return length < 3; +#if defined(TCL_NO_DEPRECATED) +# define TclListObjGetElements 0 +# define TclListObjLength 0 +# define TclDictObjSize 0 +# define TclSplitList 0 +# define TclSplitPath 0 +# define TclFSSplitPath 0 +# define TclParseArgsObjv 0 +#else /* !defined(TCL_NO_DEPRECATED) */ +int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, + void *objcPtr, Tcl_Obj ***objvPtr) { + Tcl_Size n = TCL_INDEX_NONE; + int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr); + 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", (void *)NULL); + } + return TCL_ERROR; + } + *(int *)objcPtr = (int)n; } - return Tcl_UtfCharComplete(src, length); + return result; } - -static const char *TclUtfNext(const char *src) { - if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) { - return src + 1; +int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, + void *lengthPtr) { + Tcl_Size n = TCL_INDEX_NONE; + int result = Tcl_ListObjLength(interp, listPtr, &n); + 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", (void *)NULL); + } + return TCL_ERROR; + } + *(int *)lengthPtr = (int)n; } - return Tcl_UtfNext(src); + return result; } - -static const char *TclUtfPrev(const char *src, const char *start) { - if ((src >= start + 3) && ((src[-1] & 0xC0) == 0x80) - && ((src[-2] & 0xC0) == 0x80) && ((src[-3] & 0xC0) == 0x80)) { - return src - 3; +int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, + void *sizePtr) { + Tcl_Size n = TCL_INDEX_NONE; + int result = Tcl_DictObjSize(interp, dictPtr, &n); + 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", (void *)NULL); + } + return TCL_ERROR; + } + *(int *)sizePtr = (int)n; + } + return result; +} +int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr, + const char ***argvPtr) { + Tcl_Size n = TCL_INDEX_NONE; + int result = Tcl_SplitList(interp, listStr, &n, argvPtr); + 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", (void *)NULL); + } + Tcl_Free((void *)*argvPtr); + return TCL_ERROR; + } + *(int *)argcPtr = (int)n; + } + return result; +} +void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr) { + Tcl_Size n = TCL_INDEX_NONE; + Tcl_SplitPath(path, &n, argvPtr); + if (argcPtr) { + if ((sizeof(int) != sizeof(size_t)) && (n > INT_MAX)) { + n = TCL_INDEX_NONE; /* No other way to return an error-situation */ + Tcl_Free((void *)*argvPtr); + *argvPtr = NULL; + } + *(int *)argcPtr = (int)n; + } +} +Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr) { + Tcl_Size n = TCL_INDEX_NONE; + Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n); + if (lenPtr) { + if ((sizeof(int) != sizeof(size_t)) && result && (n > INT_MAX)) { + Tcl_DecrRefCount(result); + return NULL; + } + *(int *)lenPtr = (int)n; } - return Tcl_UtfPrev(src, start); + return result; +} +int TclParseArgsObjv(Tcl_Interp *interp, + const Tcl_ArgvInfo *argTable, void *objcPtr, Tcl_Obj *const *objv, + Tcl_Obj ***remObjv) { + Tcl_Size n = (*(int *)objcPtr < 0) ? TCL_INDEX_NONE: (Tcl_Size)*(int *)objcPtr ; + int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv); + *(int *)objcPtr = (int)n; + return result; } +#endif /* !defined(TCL_NO_DEPRECATED) */ #define TclBN_mp_add mp_add +#define TclBN_mp_add_d mp_add_d #define TclBN_mp_and mp_and #define TclBN_mp_clamp mp_clamp #define TclBN_mp_clear mp_clear #define TclBN_mp_clear_multi mp_clear_multi #define TclBN_mp_cmp mp_cmp +#define TclBN_mp_cmp_d mp_cmp_d #define TclBN_mp_cmp_mag mp_cmp_mag #define TclBN_mp_cnt_lsb mp_cnt_lsb #define TclBN_mp_copy mp_copy #define TclBN_mp_count_bits mp_count_bits #define TclBN_mp_div mp_div +#define TclBN_mp_div_d mp_div_d #define TclBN_mp_div_2 mp_div_2 #define TclBN_mp_div_2d mp_div_2d #define TclBN_mp_exch mp_exch +#define TclBN_mp_expt_u32 mp_expt_u32 #define TclBN_mp_get_mag_u64 mp_get_mag_u64 #define TclBN_mp_grow mp_grow #define TclBN_mp_init mp_init #define TclBN_mp_init_copy mp_init_copy #define TclBN_mp_init_multi mp_init_multi +#define TclBN_mp_init_set mp_init_set #define TclBN_mp_init_size mp_init_size #define TclBN_mp_init_i64 mp_init_i64 #define TclBN_mp_init_u64 mp_init_u64 @@ -159,6 +225,7 @@ static const char *TclUtfPrev(const char *src, const char *start) { #define TclBN_mp_mod mp_mod #define TclBN_mp_mod_2d mp_mod_2d #define TclBN_mp_mul mp_mul +#define TclBN_mp_mul_d mp_mul_d #define TclBN_mp_mul_2 mp_mul_2 #define TclBN_mp_mul_2d mp_mul_2d #define TclBN_mp_neg mp_neg @@ -166,7 +233,6 @@ static const char *TclUtfPrev(const char *src, const char *start) { #define TclBN_mp_pack mp_pack #define TclBN_mp_pack_count mp_pack_count #define TclBN_mp_radix_size mp_radix_size -#define TclBN_mp_reverse mp_reverse #define TclBN_mp_read_radix mp_read_radix #define TclBN_mp_rshd mp_rshd #define TclBN_mp_set_i64 mp_set_i64 @@ -175,11 +241,8 @@ static const char *TclUtfPrev(const char *src, const char *start) { #define TclBN_mp_sqr mp_sqr #define TclBN_mp_sqrt mp_sqrt #define TclBN_mp_sub mp_sub +#define TclBN_mp_sub_d mp_sub_d #define TclBN_mp_signed_rsh mp_signed_rsh -#define TclBN_mp_tc_and TclBN_mp_and -#define TclBN_mp_tc_div_2d mp_signed_rsh -#define TclBN_mp_tc_or TclBN_mp_or -#define TclBN_mp_tc_xor TclBN_mp_xor #define TclBN_mp_to_radix mp_to_radix #define TclBN_mp_to_ubin mp_to_ubin #define TclBN_mp_ubin_size mp_ubin_size @@ -187,7 +250,7 @@ static const char *TclUtfPrev(const char *src, const char *start) { #define TclBN_mp_xor mp_xor #define TclBN_mp_zero mp_zero #define TclBN_s_mp_add s_mp_add -#define TclBN_s_mp_balance_mul s_mp_balance_mul +#define TclBN_mp_balance_mul s_mp_balance_mul #define TclBN_mp_karatsuba_mul s_mp_karatsuba_mul #define TclBN_mp_karatsuba_sqr s_mp_karatsuba_sqr #define TclBN_s_mp_mul_digs s_mp_mul_digs @@ -198,261 +261,17 @@ static const char *TclUtfPrev(const char *src, const char *start) { #define TclBN_s_mp_sub s_mp_sub #define TclBN_mp_toom_mul s_mp_toom_mul #define TclBN_mp_toom_sqr s_mp_toom_sqr -#define TclUnusedStubEntry 0 - -/* See bug 510001: TclSockMinimumBuffers needs plat imp */ -#if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 -# define TclSockMinimumBuffersOld 0 -#else -#define TclSockMinimumBuffersOld sockMinimumBuffersOld -static int TclSockMinimumBuffersOld(int sock, int size) -{ - return TclSockMinimumBuffers(INT2PTR(sock), size); -} -#endif - -mp_err TclBN_mp_set_int(mp_int *a, unsigned long i) -{ - TclBN_mp_set_u64(a, i); - return MP_OKAY; -} - -static mp_err TclBN_mp_set_long(mp_int *a, unsigned long i) -{ - TclBN_mp_set_u64(a, i); - return MP_OKAY; -} -#define TclBN_mp_set_ul (void (*)(mp_int *a, unsigned long i))(void *)TclBN_mp_set_long - -mp_err MP_WUR TclBN_mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) { - return mp_expt_u32(a, b, c); -} -mp_err TclBN_mp_add_d(const mp_int *a, unsigned int b, mp_int *c) { - return mp_add_d(a, b, c); -} -mp_err TclBN_mp_cmp_d(const mp_int *a, unsigned int b) { - return mp_cmp_d(a, b); -} -mp_err TclBN_mp_sub_d(const mp_int *a, unsigned int b, mp_int *c) { - return mp_sub_d(a, b, c); -} -mp_err TclBN_mp_div_d(const mp_int *a, unsigned int b, mp_int *c, unsigned int *d) { - mp_digit d2; - mp_err result = mp_div_d(a, b, c, (d ? &d2 : NULL)); - if (d) { - *d = d2; - } - return result; -} -mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *c, uint64_t *d) { - mp_err result; - mp_digit d2; - - if ((b | (mp_digit)-1) != (mp_digit)-1) { - return MP_VAL; - } - result = mp_div_d(a, (mp_digit)b, c, (d ? &d2 : NULL)); - if (d) { - *d = d2; - } - return result; -} -mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) { - return mp_init_set(a, b); -} -mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *c) { - return mp_mul_d(a, b, c); -} - -#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 -# define TclBN_mp_expt_d_ex 0 -# define TclBN_mp_to_unsigned_bin 0 -# define TclBN_mp_to_unsigned_bin_n 0 -# define TclBN_mp_toradix_n 0 -# undef TclBN_mp_sqr -# define TclBN_mp_sqr 0 -# undef TclBN_mp_div_3 -# define TclBN_mp_div_3 0 -# define TclBN_mp_init_l 0 -# define TclBN_mp_init_ul 0 -# define TclBN_mp_set 0 -# define TclSetStartupScriptPath 0 -# define TclGetStartupScriptPath 0 -# define TclSetStartupScriptFileName 0 -# define TclGetStartupScriptFileName 0 -# define TclPrecTraceProc 0 -# define TclpInetNtoa 0 -# define TclWinGetServByName 0 -# define TclWinGetSockOpt 0 -# define TclWinSetSockOpt 0 -# define TclWinNToHS 0 -# define TclWinGetPlatformId 0 -# define TclWinResetInterfaces 0 -# define TclWinSetInterfaces 0 -# define TclWinGetPlatformId 0 -# define Tcl_Backslash 0 -# define Tcl_GetDefaultEncodingDir 0 -# define Tcl_SetDefaultEncodingDir 0 -# define Tcl_EvalTokens 0 -# define Tcl_CreateMathFunc 0 -# define Tcl_GetMathFuncInfo 0 -# define Tcl_ListMathFuncs 0 -# define Tcl_SetIntObj 0 -# define Tcl_SetLongObj 0 -# define Tcl_NewIntObj 0 -# define Tcl_NewLongObj 0 -# define Tcl_DbNewLongObj 0 -# define Tcl_BackgroundError 0 -# define Tcl_FreeResult 0 -# define Tcl_ChannelSeekProc 0 -# define Tcl_ChannelCloseProc 0 -# define Tcl_Close 0 -# define Tcl_MacOSXOpenBundleResources 0 -# define TclGuessPackageName 0 -# define TclGetLoadedPackages 0 -# undef TclSetPreInitScript -# define TclSetPreInitScript 0 -# define TclInitCompiledLocals 0 -#else - -#define TclGuessPackageName guessPackageName -static int TclGuessPackageName( - TCL_UNUSED(const char *), - TCL_UNUSED(Tcl_DString *)) { - return 0; -} -#define TclGetLoadedPackages getLoadedPackages -static int TclGetLoadedPackages( - Tcl_Interp *interp, /* Interpreter in which to return information - * or error message. */ - const char *targetName) /* Name of target interpreter or NULL. If - * NULL, return info about all interps; - * otherwise, just return info about this - * interpreter. */ -{ - return TclGetLoadedLibraries(interp, targetName, NULL); -} - -mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) { - mp_digit d2; - mp_err result = mp_div_d(a, 3, c, &d2); - if (d) { - *d = d2; - } - return result; -} - -int TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c, - TCL_UNUSED(int) /*fast*/) -{ - return TclBN_mp_expt_u32(a, b, c); -} - -mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b) -{ - return TclBN_mp_to_ubin(a, b, INT_MAX, NULL); -} - -mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) -{ - size_t n = TclBN_mp_ubin_size(a); - if (*outlen < (unsigned long)n) { - return MP_VAL; - } - *outlen = (unsigned long)n; - return TclBN_mp_to_ubin(a, b, n, NULL); -} - -void TclBN_reverse(unsigned char *s, int len) -{ - if (len > 0) { - TclBN_s_mp_reverse(s, (size_t)len); - } -} - -mp_err TclBN_mp_init_ul(mp_int *a, unsigned long b) -{ - return TclBN_mp_init_u64(a,b); -} - -mp_err TclBN_mp_init_l(mp_int *a, long b) -{ - return TclBN_mp_init_i64(a,b); -} - -void TclBN_mp_set(mp_int *a, unsigned int b) { - TclBN_mp_set_u64(a, b); -} - -mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) -{ - if (maxlen < 0) { - return MP_VAL; - } - return TclBN_mp_to_radix(a, str, maxlen, NULL, radix); -} - -#define TclSetStartupScriptPath setStartupScriptPath -static void TclSetStartupScriptPath(Tcl_Obj *path) -{ - Tcl_SetStartupScript(path, NULL); -} -#define TclGetStartupScriptPath getStartupScriptPath -static Tcl_Obj *TclGetStartupScriptPath(void) -{ - return Tcl_GetStartupScript(NULL); -} -#define TclSetStartupScriptFileName setStartupScriptFileName -static void TclSetStartupScriptFileName( - const char *fileName) -{ - Tcl_SetStartupScript(Tcl_NewStringObj(fileName,-1), NULL); -} -#define TclGetStartupScriptFileName getStartupScriptFileName -static const char *TclGetStartupScriptFileName(void) -{ - Tcl_Obj *path = Tcl_GetStartupScript(NULL); - if (path == NULL) { - return NULL; - } - return Tcl_GetString(path); -} -#if defined(_WIN32) || defined(__CYGWIN__) -#undef TclWinNToHS -#undef TclWinGetPlatformId -#undef TclWinResetInterfaces -#undef TclWinSetInterfaces -static void -doNothing(void) -{ - /* dummy implementation, no need to do anything */ -} -#define TclWinNToHS winNToHS -static unsigned short TclWinNToHS(unsigned short ns) { - return ntohs(ns); -} -#define TclWinGetPlatformId winGetPlatformId -static int -TclWinGetPlatformId(void) -{ - return 2; /* VER_PLATFORM_WIN32_NT */; -} -#define TclWinResetInterfaces doNothing -#define TclWinSetInterfaces (void (*) (int)) doNothing +#ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ +# define Tcl_MacOSXOpenVersionedBundleResources 0 +# define Tcl_MacOSXNotifierAddRunLoopMode 0 #endif -#endif /* TCL_NO_DEPRECATED */ - -#define TclpCreateTempFile_ TclpCreateTempFile -#define TclUnixWaitForFile_ TclUnixWaitForFile -#ifdef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ -#define TclMacOSXNotifierAddRunLoopMode Tcl_MacOSXNotifierAddRunLoopMode +#ifdef _WIN32 +# define Tcl_CreateFileHandler 0 +# define Tcl_DeleteFileHandler 0 +# define Tcl_GetOpenFile 0 #else -#define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess -#define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty -#define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile -#define TclMacOSXMatchType (int (*)(Tcl_Interp *, const char *, const char *, Tcl_StatBuf *, Tcl_GlobTypeData *))(void *)TclpMakeFile -#define TclMacOSXNotifierAddRunLoopMode (void (*)(const void *))(void *)TclpOpenFile +# define TclpIsAtty isatty #endif #ifdef _WIN32 @@ -460,44 +279,18 @@ TclWinGetPlatformId(void) # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 # define TclpReaddir 0 +# undef TclpIsAtty # define TclpIsAtty 0 #elif defined(__CYGWIN__) # define TclpIsAtty isatty -#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 static void doNothing(void) { /* dummy implementation, no need to do anything */ } -#endif # define TclWinAddProcess (void (*) (void *, Tcl_Size)) doNothing # define TclWinFlushDirtyChannels doNothing -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -#define TclWinSetSockOpt winSetSockOpt -static int -TclWinSetSockOpt(SOCKET s, int level, int optname, - const char *optval, int optlen) -{ - return setsockopt((int) s, level, optname, optval, optlen); -} - -#define TclWinGetSockOpt winGetSockOpt -static int -TclWinGetSockOpt(SOCKET s, int level, int optname, - char *optval, int *optlen) -{ - return getsockopt((int) s, level, optname, optval, optlen); -} - -#define TclWinGetServByName winGetServByName -static struct servent * -TclWinGetServByName(const char *name, const char *proto) -{ - return getservbyname(name, proto); -} -#endif /* TCL_NO_DEPRECATED */ - #define TclWinNoBackslash winNoBackslash static char * TclWinNoBackslash(char *path) @@ -520,35 +313,12 @@ void *TclWinGetTclInstance() return hInstance; } -int +Tcl_Size TclpGetPid(Tcl_Pid pid) { - return (TCL_HASH_TYPE)(size_t)pid; + return (Tcl_Size)PTR2INT(pid); } -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -#undef Tcl_WinUtfToTChar -char * -Tcl_WinUtfToTChar( - const char *string, - int len, - Tcl_DString *dsPtr) -{ - Tcl_DStringInit(dsPtr); - return (char *)Tcl_UtfToChar16DString(string, len, dsPtr); -} -#undef Tcl_WinTCharToUtf -char * -Tcl_WinTCharToUtf( - const char *string, - int len, - Tcl_DString *dsPtr) -{ - Tcl_DStringInit(dsPtr); - return Tcl_Char16ToUtfDString((const unsigned short *)string, len >> 1, dsPtr); -} -#endif /* !defined(TCL_NO_DEPRECATED) */ - #if defined(TCL_WIDE_INT_IS_LONG) /* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore * we have to make sure that all stub entries on Cygwin64 follow the Win64 @@ -588,176 +358,14 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ return result; } #define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))(void *)exprIntObj -static int utfNcmp(const char *s1, const char *s2, unsigned int n){ - return Tcl_UtfNcmp(s1, s2, (unsigned long)n); -} -#define Tcl_UtfNcmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcmp -static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ - return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n); -} -#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcasecmp - #endif /* TCL_WIDE_INT_IS_LONG */ -#endif /* __CYGWIN__ */ - -#if defined(TCL_NO_DEPRECATED) -# define Tcl_SeekOld 0 -# define Tcl_TellOld 0 -# undef Tcl_SetBooleanObj -# define Tcl_SetBooleanObj 0 -# undef Tcl_PkgPresent -# define Tcl_PkgPresent 0 -# undef Tcl_PkgProvide -# define Tcl_PkgProvide 0 -# undef Tcl_PkgRequire -# define Tcl_PkgRequire 0 -# undef Tcl_GetIndexFromObj -# define Tcl_GetIndexFromObj 0 -# define Tcl_NewBooleanObj 0 -# undef Tcl_DbNewBooleanObj -# define Tcl_DbNewBooleanObj 0 -# undef Tcl_SetBooleanObj -# define Tcl_SetBooleanObj 0 -# undef Tcl_SetVar -# define Tcl_SetVar 0 -# undef Tcl_UnsetVar -# define Tcl_UnsetVar 0 -# undef Tcl_GetVar -# define Tcl_GetVar 0 -# undef Tcl_TraceVar -# define Tcl_TraceVar 0 -# undef Tcl_UntraceVar -# define Tcl_UntraceVar 0 -# undef Tcl_VarTraceInfo -# define Tcl_VarTraceInfo 0 -# undef Tcl_UpVar -# define Tcl_UpVar 0 -# undef Tcl_AddErrorInfo -# define Tcl_AddErrorInfo 0 -# undef Tcl_AddObjErrorInfo -# define Tcl_AddObjErrorInfo 0 -# undef Tcl_Eval -# define Tcl_Eval 0 -# undef Tcl_GlobalEval -# define Tcl_GlobalEval 0 -# undef Tcl_SaveResult -# define Tcl_SaveResult 0 -# undef Tcl_RestoreResult -# define Tcl_RestoreResult 0 -# undef Tcl_DiscardResult -# define Tcl_DiscardResult 0 -# undef Tcl_SetResult -# define Tcl_SetResult 0 -# undef Tcl_EvalObj -# define Tcl_EvalObj 0 -# undef Tcl_GlobalEvalObj -# define Tcl_GlobalEvalObj 0 -# define TclBackgroundException 0 -# undef TclpReaddir -# define TclpReaddir 0 -# define TclSetStartupScript 0 -# define TclGetStartupScript 0 -# define TclGetIntForIndex 0 -# define TclCreateNamespace 0 -# define TclDeleteNamespace 0 -# define TclAppendExportList 0 -# define TclExport 0 -# define TclImport 0 -# define TclForgetImport 0 -# define TclGetCurrentNamespace_ 0 -# define TclGetGlobalNamespace_ 0 -# define TclFindNamespace 0 -# define TclFindCommand 0 -# define TclGetCommandFromObj 0 -# define TclGetCommandFullName 0 -# define TclCopyChannelOld 0 -# define Tcl_AppendResultVA 0 -# define Tcl_AppendStringsToObjVA 0 -# define Tcl_SetErrorCodeVA 0 -# define Tcl_PanicVA 0 -# define Tcl_VarEvalVA 0 -# undef TclpGetDate -# define TclpGetDate 0 -# undef TclpLocaltime -# define TclpLocaltime 0 -# undef TclpGmtime -# define TclpGmtime 0 -# define TclpLocaltime_unix 0 -# define TclpGmtime_unix 0 -# define Tcl_SetExitProc 0 -# define Tcl_SetPanicProc 0 -# define Tcl_FindExecutable 0 -# undef Tcl_StringMatch -# define Tcl_StringMatch 0 -# define TclBN_reverse 0 -# undef TclBN_s_mp_mul_digs_fast -# define TclBN_s_mp_mul_digs_fast 0 -# undef TclBN_s_mp_sqr_fast -# define TclBN_s_mp_sqr_fast 0 -# undef TclBN_mp_karatsuba_mul -# define TclBN_mp_karatsuba_mul 0 -# undef TclBN_mp_karatsuba_sqr -# define TclBN_mp_karatsuba_sqr 0 -# undef TclBN_mp_toom_mul -# define TclBN_mp_toom_mul 0 -# undef TclBN_mp_toom_sqr -# define TclBN_mp_toom_sqr 0 -# undef TclBN_s_mp_add -# define TclBN_s_mp_add 0 -# undef TclBN_s_mp_mul_digs -# define TclBN_s_mp_mul_digs 0 -# undef TclBN_s_mp_sqr -# define TclBN_s_mp_sqr 0 -# undef TclBN_s_mp_sub -# define TclBN_s_mp_sub 0 -# define Tcl_MakeSafe 0 -# define TclpHasSockets 0 -#else /* TCL_NO_DEPRECATED */ -# define Tcl_SeekOld seekOld -# define Tcl_TellOld tellOld -# define TclBackgroundException Tcl_BackgroundException -# define TclSetStartupScript Tcl_SetStartupScript -# define TclGetStartupScript Tcl_GetStartupScript -# define TclGetIntForIndex Tcl_GetIntForIndex -# define TclCreateNamespace Tcl_CreateNamespace -# define TclDeleteNamespace Tcl_DeleteNamespace -# define TclAppendExportList Tcl_AppendExportList -# define TclExport Tcl_Export -# define TclImport Tcl_Import -# define TclForgetImport Tcl_ForgetImport -# define TclGetCurrentNamespace_ Tcl_GetCurrentNamespace -# define TclGetGlobalNamespace_ Tcl_GetGlobalNamespace -# define TclFindNamespace Tcl_FindNamespace -# define TclFindCommand Tcl_FindCommand -# define TclGetCommandFromObj Tcl_GetCommandFromObj -# define TclGetCommandFullName Tcl_GetCommandFullName -# define TclpLocaltime_unix TclpLocaltime -# define TclpGmtime_unix TclpGmtime -# define Tcl_MakeSafe TclMakeSafe - -int TclpHasSockets(TCL_UNUSED(Tcl_Interp *)) {return TCL_OK;} - -static int -seekOld( - Tcl_Channel chan, /* The channel on which to seek. */ - int offset, /* Offset to seek to. */ - int mode) /* Relative to which location to seek? */ -{ - return Tcl_Seek(chan, offset, mode); -} - -static int -tellOld( - Tcl_Channel chan) /* The channel to return pos for. */ -{ - return Tcl_Tell(chan); -} -#endif /* !TCL_NO_DEPRECATED */ - -#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 -#define Tcl_WinUtfToTChar 0 -#define Tcl_WinTCharToUtf 0 +#else /* __CYGWIN__ */ +# define TclWinGetTclInstance 0 +# define TclpGetPid 0 +# define TclWinFlushDirtyChannels 0 +# define TclWinNoBackslash 0 +# define TclWinAddProcess 0 #endif /* @@ -791,7 +399,7 @@ static const TclIntStubs tclIntStubs = { TclCleanupChildren, /* 5 */ TclCleanupCommand, /* 6 */ TclCopyAndCollapse, /* 7 */ - TclCopyChannelOld, /* 8 */ + 0, /* 8 */ TclCreatePipeline, /* 9 */ TclCreateProc, /* 10 */ TclDeleteCompiledLocalVars, /* 11 */ @@ -817,27 +425,27 @@ static const TclIntStubs tclIntStubs = { TclGetExtension, /* 31 */ TclGetFrame, /* 32 */ 0, /* 33 */ - TclGetIntForIndex, /* 34 */ + 0, /* 34 */ 0, /* 35 */ 0, /* 36 */ - TclGetLoadedPackages, /* 37 */ + 0, /* 37 */ TclGetNamespaceForQualName, /* 38 */ TclGetObjInterpProc, /* 39 */ TclGetOpenMode, /* 40 */ TclGetOriginalCommand, /* 41 */ TclpGetUserHome, /* 42 */ - 0, /* 43 */ - TclGuessPackageName, /* 44 */ + TclGetObjInterpProc2, /* 43 */ + 0, /* 44 */ TclHideUnsafeCommands, /* 45 */ TclInExit, /* 46 */ 0, /* 47 */ 0, /* 48 */ 0, /* 49 */ - TclInitCompiledLocals, /* 50 */ + 0, /* 50 */ TclInterpInit, /* 51 */ 0, /* 52 */ - TclInvokeObjectCommand, /* 53 */ - TclInvokeStringCommand, /* 54 */ + 0, /* 53 */ + 0, /* 54 */ TclIsProc, /* 55 */ 0, /* 56 */ 0, /* 57 */ @@ -846,7 +454,7 @@ static const TclIntStubs tclIntStubs = { TclNeedSpace, /* 60 */ TclNewProcBodyObj, /* 61 */ TclObjCommandComplete, /* 62 */ - TclObjInterpProc, /* 63 */ + 0, /* 63 */ TclObjInvoke, /* 64 */ 0, /* 65 */ 0, /* 66 */ @@ -860,7 +468,7 @@ static const TclIntStubs tclIntStubs = { TclpFree, /* 74 */ TclpGetClicks, /* 75 */ TclpGetSeconds, /* 76 */ - TclpGetTime, /* 77 */ + 0, /* 77 */ 0, /* 78 */ 0, /* 79 */ 0, /* 80 */ @@ -871,7 +479,7 @@ static const TclIntStubs tclIntStubs = { 0, /* 85 */ 0, /* 86 */ 0, /* 87 */ - TclPrecTraceProc, /* 88 */ + 0, /* 88 */ TclPreventAliasLoop, /* 89 */ 0, /* 90 */ TclProcCleanupProc, /* 91 */ @@ -884,10 +492,10 @@ static const TclIntStubs tclIntStubs = { TclServiceIdle, /* 98 */ 0, /* 99 */ 0, /* 100 */ - TclSetPreInitScript, /* 101 */ + 0, /* 101 */ TclSetupEnv, /* 102 */ TclSockGetPort, /* 103 */ - TclSockMinimumBuffersOld, /* 104 */ + 0, /* 104 */ 0, /* 105 */ 0, /* 106 */ 0, /* 107 */ @@ -895,28 +503,28 @@ static const TclIntStubs tclIntStubs = { TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ - TclAppendExportList, /* 112 */ - TclCreateNamespace, /* 113 */ - TclDeleteNamespace, /* 114 */ - TclExport, /* 115 */ - TclFindCommand, /* 116 */ - TclFindNamespace, /* 117 */ + 0, /* 112 */ + 0, /* 113 */ + 0, /* 114 */ + 0, /* 115 */ + 0, /* 116 */ + 0, /* 117 */ Tcl_GetInterpResolvers, /* 118 */ Tcl_GetNamespaceResolvers, /* 119 */ Tcl_FindNamespaceVar, /* 120 */ - TclForgetImport, /* 121 */ - TclGetCommandFromObj, /* 122 */ - TclGetCommandFullName, /* 123 */ - TclGetCurrentNamespace_, /* 124 */ - TclGetGlobalNamespace_, /* 125 */ + 0, /* 121 */ + 0, /* 122 */ + 0, /* 123 */ + 0, /* 124 */ + 0, /* 125 */ Tcl_GetVariableFullName, /* 126 */ - TclImport, /* 127 */ + 0, /* 127 */ Tcl_PopCallFrame, /* 128 */ Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ Tcl_SetNamespaceResolvers, /* 131 */ - TclpHasSockets, /* 132 */ - TclpGetDate, /* 133 */ + 0, /* 132 */ + 0, /* 133 */ 0, /* 134 */ 0, /* 135 */ 0, /* 136 */ @@ -935,14 +543,14 @@ static const TclIntStubs tclIntStubs = { TclHandleRelease, /* 149 */ TclRegAbout, /* 150 */ TclRegExpRangeUniChar, /* 151 */ - TclSetLibraryPath, /* 152 */ - TclGetLibraryPath, /* 153 */ + 0, /* 152 */ + 0, /* 153 */ 0, /* 154 */ 0, /* 155 */ TclRegError, /* 156 */ TclVarTraceExists, /* 157 */ - TclSetStartupScriptFileName, /* 158 */ - TclGetStartupScriptFileName, /* 159 */ + 0, /* 158 */ + 0, /* 159 */ 0, /* 160 */ TclChannelTransform, /* 161 */ TclChannelEventScriptInvoker, /* 162 */ @@ -950,8 +558,8 @@ static const TclIntStubs tclIntStubs = { TclExpandCodeArray, /* 164 */ TclpSetInitialEncodings, /* 165 */ TclListObjSetElement, /* 166 */ - TclSetStartupScriptPath, /* 167 */ - TclGetStartupScriptPath, /* 168 */ + 0, /* 167 */ + 0, /* 168 */ TclpUtfNcmp2, /* 169 */ TclCheckInterpTraces, /* 170 */ TclCheckExecutionTraces, /* 171 */ @@ -961,12 +569,12 @@ static const TclIntStubs tclIntStubs = { TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ - TclSetStartupScript, /* 178 */ - TclGetStartupScript, /* 179 */ + 0, /* 178 */ + 0, /* 179 */ 0, /* 180 */ 0, /* 181 */ - TclpLocaltime, /* 182 */ - TclpGmtime, /* 183 */ + 0, /* 182 */ + 0, /* 183 */ 0, /* 184 */ 0, /* 185 */ 0, /* 186 */ @@ -1019,7 +627,7 @@ static const TclIntStubs tclIntStubs = { TclGetSrcInfoForPc, /* 233 */ TclVarHashCreateVar, /* 234 */ TclInitVarHashTable, /* 235 */ - TclBackgroundException, /* 236 */ + 0, /* 236 */ TclResetCancellation, /* 237 */ TclNRInterpProc, /* 238 */ TclNRInterpProcCore, /* 239 */ @@ -1050,121 +658,46 @@ static const TclIntStubs tclIntStubs = { static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - TclGetAndDetachPids, /* 0 */ + 0, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ - TclpCreateProcess, /* 4 */ - TclUnixWaitForFile_, /* 5 */ - TclpMakeFile, /* 6 */ - TclpOpenFile, /* 7 */ - TclUnixWaitForFile, /* 8 */ - TclpCreateTempFile, /* 9 */ - TclpReaddir, /* 10 */ - TclpLocaltime_unix, /* 11 */ - TclpGmtime_unix, /* 12 */ - TclpInetNtoa, /* 13 */ - TclUnixCopyFile, /* 14 */ - TclMacOSXGetFileAttribute, /* 15 */ - TclMacOSXSetFileAttribute, /* 16 */ - TclMacOSXCopyFileAttributes, /* 17 */ - TclMacOSXMatchType, /* 18 */ - TclMacOSXNotifierAddRunLoopMode, /* 19 */ - 0, /* 20 */ - 0, /* 21 */ - TclpCreateTempFile_, /* 22 */ - 0, /* 23 */ - 0, /* 24 */ - 0, /* 25 */ - 0, /* 26 */ - 0, /* 27 */ - 0, /* 28 */ - TclWinCPUID, /* 29 */ - TclUnixOpenTemporaryFile, /* 30 */ -#endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - TclWinConvertError, /* 0 */ - TclWinConvertWSAError, /* 1 */ - TclWinGetServByName, /* 2 */ - TclWinGetSockOpt, /* 3 */ TclWinGetTclInstance, /* 4 */ TclUnixWaitForFile, /* 5 */ - TclWinNToHS, /* 6 */ - TclWinSetSockOpt, /* 7 */ + TclpMakeFile, /* 6 */ + TclpOpenFile, /* 7 */ TclpGetPid, /* 8 */ - TclWinGetPlatformId, /* 9 */ - TclpReaddir, /* 10 */ + TclpCreateTempFile, /* 9 */ + 0, /* 10 */ TclGetAndDetachPids, /* 11 */ - TclpCloseFile, /* 12 */ - TclpCreateCommandChannel, /* 13 */ - TclpCreatePipe, /* 14 */ + 0, /* 12 */ + 0, /* 13 */ + 0, /* 14 */ TclpCreateProcess, /* 15 */ TclpIsAtty, /* 16 */ TclUnixCopyFile, /* 17 */ - TclpMakeFile, /* 18 */ - TclpOpenFile, /* 19 */ + 0, /* 18 */ + 0, /* 19 */ TclWinAddProcess, /* 20 */ - TclpInetNtoa, /* 21 */ - TclpCreateTempFile, /* 22 */ - 0, /* 23 */ - TclWinNoBackslash, /* 24 */ - 0, /* 25 */ - TclWinSetInterfaces, /* 26 */ - TclWinFlushDirtyChannels, /* 27 */ - TclWinResetInterfaces, /* 28 */ - TclWinCPUID, /* 29 */ - TclUnixOpenTemporaryFile, /* 30 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ - TclGetAndDetachPids, /* 0 */ - TclpCloseFile, /* 1 */ - TclpCreateCommandChannel, /* 2 */ - TclpCreatePipe, /* 3 */ - TclpCreateProcess, /* 4 */ - TclUnixWaitForFile_, /* 5 */ - TclpMakeFile, /* 6 */ - TclpOpenFile, /* 7 */ - TclUnixWaitForFile, /* 8 */ - TclpCreateTempFile, /* 9 */ - TclpReaddir, /* 10 */ - TclpLocaltime_unix, /* 11 */ - TclpGmtime_unix, /* 12 */ - TclpInetNtoa, /* 13 */ - TclUnixCopyFile, /* 14 */ - TclMacOSXGetFileAttribute, /* 15 */ - TclMacOSXSetFileAttribute, /* 16 */ - TclMacOSXCopyFileAttributes, /* 17 */ - TclMacOSXMatchType, /* 18 */ - TclMacOSXNotifierAddRunLoopMode, /* 19 */ - 0, /* 20 */ 0, /* 21 */ - TclpCreateTempFile_, /* 22 */ + 0, /* 22 */ 0, /* 23 */ - 0, /* 24 */ + TclWinNoBackslash, /* 24 */ 0, /* 25 */ 0, /* 26 */ - 0, /* 27 */ + TclWinFlushDirtyChannels, /* 27 */ 0, /* 28 */ TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ -#endif /* MACOSX */ }; static const TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, 0, -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - Tcl_WinUtfToTChar, /* 0 */ - Tcl_WinTCharToUtf, /* 1 */ - 0, /* 2 */ - Tcl_WinConvertError, /* 3 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ - Tcl_MacOSXOpenBundleResources, /* 0 */ + 0, /* 0 */ Tcl_MacOSXOpenVersionedBundleResources, /* 1 */ Tcl_MacOSXNotifierAddRunLoopMode, /* 2 */ -#endif /* MACOSX */ + Tcl_WinConvertError, /* 3 */ }; const TclTomMathStubs tclTomMathStubs = { @@ -1187,7 +720,7 @@ const TclTomMathStubs tclTomMathStubs = { TclBN_mp_div_d, /* 14 */ TclBN_mp_div_2, /* 15 */ TclBN_mp_div_2d, /* 16 */ - TclBN_mp_div_3, /* 17 */ + 0, /* 17 */ TclBN_mp_exch, /* 18 */ TclBN_mp_expt_u32, /* 19 */ TclBN_mp_grow, /* 20 */ @@ -1209,47 +742,47 @@ const TclTomMathStubs tclTomMathStubs = { TclBN_mp_read_radix, /* 36 */ TclBN_mp_rshd, /* 37 */ TclBN_mp_shrink, /* 38 */ - TclBN_mp_set, /* 39 */ - TclBN_mp_sqr, /* 40 */ + 0, /* 39 */ + 0, /* 40 */ TclBN_mp_sqrt, /* 41 */ TclBN_mp_sub, /* 42 */ TclBN_mp_sub_d, /* 43 */ - TclBN_mp_to_unsigned_bin, /* 44 */ - TclBN_mp_to_unsigned_bin_n, /* 45 */ - TclBN_mp_toradix_n, /* 46 */ + 0, /* 44 */ + 0, /* 45 */ + 0, /* 46 */ TclBN_mp_ubin_size, /* 47 */ TclBN_mp_xor, /* 48 */ TclBN_mp_zero, /* 49 */ - TclBN_reverse, /* 50 */ - TclBN_s_mp_mul_digs_fast, /* 51 */ - TclBN_s_mp_sqr_fast, /* 52 */ - TclBN_mp_karatsuba_mul, /* 53 */ - TclBN_mp_karatsuba_sqr, /* 54 */ - TclBN_mp_toom_mul, /* 55 */ - TclBN_mp_toom_sqr, /* 56 */ - TclBN_s_mp_add, /* 57 */ - TclBN_s_mp_mul_digs, /* 58 */ - TclBN_s_mp_sqr, /* 59 */ - TclBN_s_mp_sub, /* 60 */ - TclBN_mp_init_ul, /* 61 */ - TclBN_mp_set_ul, /* 62 */ + 0, /* 50 */ + 0, /* 51 */ + 0, /* 52 */ + 0, /* 53 */ + 0, /* 54 */ + 0, /* 55 */ + 0, /* 56 */ + 0, /* 57 */ + 0, /* 58 */ + 0, /* 59 */ + 0, /* 60 */ + 0, /* 61 */ + 0, /* 62 */ TclBN_mp_cnt_lsb, /* 63 */ - TclBN_mp_init_l, /* 64 */ + 0, /* 64 */ TclBN_mp_init_i64, /* 65 */ TclBN_mp_init_u64, /* 66 */ - TclBN_mp_expt_d_ex, /* 67 */ + 0, /* 67 */ TclBN_mp_set_u64, /* 68 */ TclBN_mp_get_mag_u64, /* 69 */ TclBN_mp_set_i64, /* 70 */ TclBN_mp_unpack, /* 71 */ TclBN_mp_pack, /* 72 */ - TclBN_mp_tc_and, /* 73 */ - TclBN_mp_tc_or, /* 74 */ - TclBN_mp_tc_xor, /* 75 */ + 0, /* 73 */ + 0, /* 74 */ + 0, /* 75 */ TclBN_mp_signed_rsh, /* 76 */ TclBN_mp_pack_count, /* 77 */ TclBN_mp_to_ubin, /* 78 */ - TclBN_mp_div_ld, /* 79 */ + 0, /* 79 */ TclBN_mp_to_radix, /* 80 */ }; @@ -1271,24 +804,8 @@ const TclStubs tclStubs = { Tcl_DbCkalloc, /* 6 */ Tcl_DbCkfree, /* 7 */ Tcl_DbCkrealloc, /* 8 */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ - Tcl_CreateFileHandler, /* 9 */ -#endif /* UNIX */ -#if defined(_WIN32) /* WIN */ - 0, /* 9 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ Tcl_CreateFileHandler, /* 9 */ -#endif /* MACOSX */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ - Tcl_DeleteFileHandler, /* 10 */ -#endif /* UNIX */ -#if defined(_WIN32) /* WIN */ - 0, /* 10 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ Tcl_DeleteFileHandler, /* 10 */ -#endif /* MACOSX */ Tcl_SetTimer, /* 11 */ Tcl_Sleep, /* 12 */ Tcl_WaitForEvent, /* 13 */ @@ -1300,11 +817,11 @@ const TclStubs tclStubs = { Tcl_DbDecrRefCount, /* 19 */ Tcl_DbIncrRefCount, /* 20 */ Tcl_DbIsShared, /* 21 */ - Tcl_DbNewBooleanObj, /* 22 */ + 0, /* 22 */ Tcl_DbNewByteArrayObj, /* 23 */ Tcl_DbNewDoubleObj, /* 24 */ Tcl_DbNewListObj, /* 25 */ - Tcl_DbNewLongObj, /* 26 */ + 0, /* 26 */ Tcl_DbNewObj, /* 27 */ Tcl_DbNewStringObj, /* 28 */ Tcl_DuplicateObj, /* 29 */ @@ -1314,38 +831,38 @@ const TclStubs tclStubs = { Tcl_GetByteArrayFromObj, /* 33 */ Tcl_GetDouble, /* 34 */ Tcl_GetDoubleFromObj, /* 35 */ - Tcl_GetIndexFromObj, /* 36 */ + 0, /* 36 */ Tcl_GetInt, /* 37 */ Tcl_GetIntFromObj, /* 38 */ Tcl_GetLongFromObj, /* 39 */ Tcl_GetObjType, /* 40 */ - Tcl_GetStringFromObj, /* 41 */ + TclGetStringFromObj, /* 41 */ Tcl_InvalidateStringRep, /* 42 */ Tcl_ListObjAppendList, /* 43 */ Tcl_ListObjAppendElement, /* 44 */ - Tcl_ListObjGetElements, /* 45 */ + TclListObjGetElements, /* 45 */ Tcl_ListObjIndex, /* 46 */ - Tcl_ListObjLength, /* 47 */ + TclListObjLength, /* 47 */ Tcl_ListObjReplace, /* 48 */ - Tcl_NewBooleanObj, /* 49 */ + 0, /* 49 */ Tcl_NewByteArrayObj, /* 50 */ Tcl_NewDoubleObj, /* 51 */ - Tcl_NewIntObj, /* 52 */ + 0, /* 52 */ Tcl_NewListObj, /* 53 */ - Tcl_NewLongObj, /* 54 */ + 0, /* 54 */ Tcl_NewObj, /* 55 */ Tcl_NewStringObj, /* 56 */ - Tcl_SetBooleanObj, /* 57 */ + 0, /* 57 */ Tcl_SetByteArrayLength, /* 58 */ Tcl_SetByteArrayObj, /* 59 */ Tcl_SetDoubleObj, /* 60 */ - Tcl_SetIntObj, /* 61 */ + 0, /* 61 */ Tcl_SetListObj, /* 62 */ - Tcl_SetLongObj, /* 63 */ + 0, /* 63 */ Tcl_SetObjLength, /* 64 */ Tcl_SetStringObj, /* 65 */ - Tcl_AddErrorInfo, /* 66 */ - Tcl_AddObjErrorInfo, /* 67 */ + 0, /* 66 */ + 0, /* 67 */ Tcl_AllowExceptions, /* 68 */ Tcl_AppendElement, /* 69 */ Tcl_AppendResult, /* 70 */ @@ -1354,8 +871,8 @@ const TclStubs tclStubs = { Tcl_AsyncInvoke, /* 73 */ Tcl_AsyncMark, /* 74 */ Tcl_AsyncReady, /* 75 */ - Tcl_BackgroundError, /* 76 */ - Tcl_Backslash, /* 77 */ + 0, /* 76 */ + 0, /* 77 */ Tcl_BadChannelOption, /* 78 */ Tcl_CallWhenDeleted, /* 79 */ Tcl_CancelIdleCall, /* 80 */ @@ -1373,7 +890,7 @@ const TclStubs tclStubs = { Tcl_CreateEventSource, /* 92 */ Tcl_CreateExitHandler, /* 93 */ Tcl_CreateInterp, /* 94 */ - Tcl_CreateMathFunc, /* 95 */ + 0, /* 95 */ Tcl_CreateObjCommand, /* 96 */ Tcl_CreateChild, /* 97 */ Tcl_CreateTimerHandler, /* 98 */ @@ -1407,9 +924,9 @@ const TclStubs tclStubs = { Tcl_Eof, /* 126 */ Tcl_ErrnoId, /* 127 */ Tcl_ErrnoMsg, /* 128 */ - Tcl_Eval, /* 129 */ + 0, /* 129 */ Tcl_EvalFile, /* 130 */ - Tcl_EvalObj, /* 131 */ + 0, /* 131 */ Tcl_EventuallyFree, /* 132 */ Tcl_Exit, /* 133 */ Tcl_ExposeCommand, /* 134 */ @@ -1422,10 +939,10 @@ const TclStubs tclStubs = { Tcl_ExprObj, /* 141 */ Tcl_ExprString, /* 142 */ Tcl_Finalize, /* 143 */ - Tcl_FindExecutable, /* 144 */ + 0, /* 144 */ Tcl_FirstHashEntry, /* 145 */ Tcl_Flush, /* 146 */ - Tcl_FreeResult, /* 147 */ + 0, /* 147 */ Tcl_GetAlias, /* 148 */ Tcl_GetAliasObj, /* 149 */ Tcl_GetAssocData, /* 150 */ @@ -1445,26 +962,18 @@ const TclStubs tclStubs = { Tcl_GetParent, /* 164 */ Tcl_GetNameOfExecutable, /* 165 */ Tcl_GetObjResult, /* 166 */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_GetOpenFile, /* 167 */ -#endif /* UNIX */ -#if defined(_WIN32) /* WIN */ - 0, /* 167 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ - Tcl_GetOpenFile, /* 167 */ -#endif /* MACOSX */ Tcl_GetPathType, /* 168 */ Tcl_Gets, /* 169 */ Tcl_GetsObj, /* 170 */ Tcl_GetServiceMode, /* 171 */ Tcl_GetChild, /* 172 */ Tcl_GetStdChannel, /* 173 */ - Tcl_GetStringResult, /* 174 */ - Tcl_GetVar, /* 175 */ + 0, /* 174 */ + 0, /* 175 */ Tcl_GetVar2, /* 176 */ - Tcl_GlobalEval, /* 177 */ - Tcl_GlobalEvalObj, /* 178 */ + 0, /* 177 */ + 0, /* 178 */ Tcl_HideCommand, /* 179 */ Tcl_Init, /* 180 */ Tcl_InitHashTable, /* 181 */ @@ -1476,7 +985,7 @@ const TclStubs tclStubs = { Tcl_LinkVar, /* 187 */ 0, /* 188 */ Tcl_MakeFileChannel, /* 189 */ - Tcl_MakeSafe, /* 190 */ + 0, /* 190 */ Tcl_MakeTcpClientChannel, /* 191 */ Tcl_Merge, /* 192 */ Tcl_NextHashEntry, /* 193 */ @@ -1506,7 +1015,7 @@ const TclStubs tclStubs = { Tcl_ResetResult, /* 217 */ Tcl_ScanElement, /* 218 */ Tcl_ScanCountedElement, /* 219 */ - Tcl_SeekOld, /* 220 */ + 0, /* 220 */ Tcl_ServiceAll, /* 221 */ Tcl_ServiceEvent, /* 222 */ Tcl_SetAssocData, /* 223 */ @@ -1516,55 +1025,55 @@ const TclStubs tclStubs = { Tcl_SetErrno, /* 227 */ Tcl_SetErrorCode, /* 228 */ Tcl_SetMaxBlockTime, /* 229 */ - Tcl_SetPanicProc, /* 230 */ + 0, /* 230 */ Tcl_SetRecursionLimit, /* 231 */ - Tcl_SetResult, /* 232 */ + 0, /* 232 */ Tcl_SetServiceMode, /* 233 */ Tcl_SetObjErrorCode, /* 234 */ Tcl_SetObjResult, /* 235 */ Tcl_SetStdChannel, /* 236 */ - Tcl_SetVar, /* 237 */ + 0, /* 237 */ Tcl_SetVar2, /* 238 */ Tcl_SignalId, /* 239 */ Tcl_SignalMsg, /* 240 */ Tcl_SourceRCFile, /* 241 */ - Tcl_SplitList, /* 242 */ - Tcl_SplitPath, /* 243 */ - Tcl_StaticLibrary, /* 244 */ - Tcl_StringMatch, /* 245 */ - Tcl_TellOld, /* 246 */ - Tcl_TraceVar, /* 247 */ + TclSplitList, /* 242 */ + TclSplitPath, /* 243 */ + 0, /* 244 */ + 0, /* 245 */ + 0, /* 246 */ + 0, /* 247 */ Tcl_TraceVar2, /* 248 */ Tcl_TranslateFileName, /* 249 */ Tcl_Ungets, /* 250 */ Tcl_UnlinkVar, /* 251 */ Tcl_UnregisterChannel, /* 252 */ - Tcl_UnsetVar, /* 253 */ + 0, /* 253 */ Tcl_UnsetVar2, /* 254 */ - Tcl_UntraceVar, /* 255 */ + 0, /* 255 */ Tcl_UntraceVar2, /* 256 */ Tcl_UpdateLinkedVar, /* 257 */ - Tcl_UpVar, /* 258 */ + 0, /* 258 */ Tcl_UpVar2, /* 259 */ Tcl_VarEval, /* 260 */ - Tcl_VarTraceInfo, /* 261 */ + 0, /* 261 */ Tcl_VarTraceInfo2, /* 262 */ Tcl_Write, /* 263 */ Tcl_WrongNumArgs, /* 264 */ Tcl_DumpActiveMemory, /* 265 */ Tcl_ValidateAllMemory, /* 266 */ - Tcl_AppendResultVA, /* 267 */ - Tcl_AppendStringsToObjVA, /* 268 */ + 0, /* 267 */ + 0, /* 268 */ Tcl_HashStats, /* 269 */ Tcl_ParseVar, /* 270 */ - Tcl_PkgPresent, /* 271 */ + 0, /* 271 */ Tcl_PkgPresentEx, /* 272 */ - Tcl_PkgProvide, /* 273 */ - Tcl_PkgRequire, /* 274 */ - Tcl_SetErrorCodeVA, /* 275 */ - Tcl_VarEvalVA, /* 276 */ + 0, /* 273 */ + 0, /* 274 */ + 0, /* 275 */ + 0, /* 276 */ Tcl_WaitPid, /* 277 */ - Tcl_PanicVA, /* 278 */ + 0, /* 278 */ Tcl_GetVersion, /* 279 */ Tcl_InitMemory, /* 280 */ Tcl_StackChannel, /* 281 */ @@ -1576,7 +1085,7 @@ const TclStubs tclStubs = { Tcl_CreateEncoding, /* 287 */ Tcl_CreateThreadExitHandler, /* 288 */ Tcl_DeleteThreadExitHandler, /* 289 */ - Tcl_DiscardResult, /* 290 */ + 0, /* 290 */ Tcl_EvalEx, /* 291 */ Tcl_EvalObjv, /* 292 */ Tcl_EvalObjEx, /* 293 */ @@ -1598,10 +1107,10 @@ const TclStubs tclStubs = { Tcl_MutexUnlock, /* 309 */ Tcl_ConditionNotify, /* 310 */ Tcl_ConditionWait, /* 311 */ - Tcl_NumUtfChars, /* 312 */ + TclNumUtfChars, /* 312 */ Tcl_ReadChars, /* 313 */ - Tcl_RestoreResult, /* 314 */ - Tcl_SaveResult, /* 315 */ + 0, /* 314 */ + 0, /* 315 */ Tcl_SetSystemEncoding, /* 316 */ Tcl_SetVar2Ex, /* 317 */ Tcl_ThreadAlert, /* 318 */ @@ -1611,7 +1120,7 @@ const TclStubs tclStubs = { Tcl_UniCharToTitle, /* 322 */ Tcl_UniCharToUpper, /* 323 */ Tcl_UniCharToUtf, /* 324 */ - Tcl_UtfAtIndex, /* 325 */ + TclUtfAtIndex, /* 325 */ TclUtfCharComplete, /* 326 */ Tcl_UtfBackslash, /* 327 */ Tcl_UtfFindFirst, /* 328 */ @@ -1627,8 +1136,8 @@ const TclStubs tclStubs = { Tcl_WriteChars, /* 338 */ Tcl_WriteObj, /* 339 */ Tcl_GetString, /* 340 */ - Tcl_GetDefaultEncodingDir, /* 341 */ - Tcl_SetDefaultEncodingDir, /* 342 */ + 0, /* 341 */ + 0, /* 342 */ Tcl_AlertNotifier, /* 343 */ Tcl_ServiceModeHook, /* 344 */ Tcl_UniCharIsAlnum, /* 345 */ @@ -1639,11 +1148,11 @@ const TclStubs tclStubs = { Tcl_UniCharIsUpper, /* 350 */ Tcl_UniCharIsWordChar, /* 351 */ Tcl_Char16Len, /* 352 */ - Tcl_UniCharNcmp, /* 353 */ + 0, /* 353 */ Tcl_Char16ToUtfDString, /* 354 */ Tcl_UtfToChar16DString, /* 355 */ Tcl_GetRegExpFromObj, /* 356 */ - Tcl_EvalTokens, /* 357 */ + 0, /* 357 */ Tcl_FreeParse, /* 358 */ Tcl_LogCommandInfo, /* 359 */ Tcl_ParseBraces, /* 360 */ @@ -1655,8 +1164,8 @@ const TclStubs tclStubs = { Tcl_Chdir, /* 366 */ Tcl_Access, /* 367 */ Tcl_Stat, /* 368 */ - Tcl_UtfNcmp, /* 369 */ - Tcl_UtfNcasecmp, /* 370 */ + TclUtfNcmp, /* 369 */ + TclUtfNcasecmp, /* 370 */ Tcl_StringCaseMatch, /* 371 */ Tcl_UniCharIsControl, /* 372 */ Tcl_UniCharIsGraph, /* 373 */ @@ -1666,10 +1175,10 @@ const TclStubs tclStubs = { Tcl_RegExpGetInfo, /* 377 */ Tcl_NewUnicodeObj, /* 378 */ Tcl_SetUnicodeObj, /* 379 */ - Tcl_GetCharLength, /* 380 */ - Tcl_GetUniChar, /* 381 */ - Tcl_GetUnicode, /* 382 */ - Tcl_GetRange, /* 383 */ + TclGetCharLength, /* 380 */ + TclGetUniChar, /* 381 */ + 0, /* 382 */ + TclGetRange, /* 383 */ Tcl_AppendUnicodeToObj, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ @@ -1687,11 +1196,11 @@ const TclStubs tclStubs = { Tcl_ChannelName, /* 398 */ Tcl_ChannelVersion, /* 399 */ Tcl_ChannelBlockModeProc, /* 400 */ - Tcl_ChannelCloseProc, /* 401 */ + 0, /* 401 */ Tcl_ChannelClose2Proc, /* 402 */ Tcl_ChannelInputProc, /* 403 */ Tcl_ChannelOutputProc, /* 404 */ - Tcl_ChannelSeekProc, /* 405 */ + 0, /* 405 */ Tcl_ChannelSetOptionProc, /* 406 */ Tcl_ChannelGetOptionProc, /* 407 */ Tcl_ChannelWatchProc, /* 408 */ @@ -1705,10 +1214,10 @@ const TclStubs tclStubs = { Tcl_SpliceChannel, /* 416 */ Tcl_ClearChannelHandlers, /* 417 */ Tcl_IsChannelExisting, /* 418 */ - Tcl_UniCharNcasecmp, /* 419 */ - Tcl_UniCharCaseMatch, /* 420 */ - Tcl_FindHashEntry, /* 421 */ - Tcl_CreateHashEntry, /* 422 */ + 0, /* 419 */ + 0, /* 420 */ + 0, /* 421 */ + 0, /* 422 */ Tcl_InitCustomHashTable, /* 423 */ Tcl_InitObjHashTable, /* 424 */ Tcl_CommandTraceInfo, /* 425 */ @@ -1720,9 +1229,9 @@ const TclStubs tclStubs = { Tcl_AttemptDbCkrealloc, /* 431 */ Tcl_AttemptSetObjLength, /* 432 */ Tcl_GetChannelThread, /* 433 */ - Tcl_GetUnicodeFromObj, /* 434 */ - Tcl_GetMathFuncInfo, /* 435 */ - Tcl_ListMathFuncs, /* 436 */ + TclGetUnicodeFromObj, /* 434 */ + 0, /* 435 */ + 0, /* 436 */ Tcl_SubstObj, /* 437 */ Tcl_DetachChannel, /* 438 */ Tcl_IsStandardChannel, /* 439 */ @@ -1747,7 +1256,7 @@ const TclStubs tclStubs = { Tcl_FSChdir, /* 458 */ Tcl_FSConvertToPathType, /* 459 */ Tcl_FSJoinPath, /* 460 */ - Tcl_FSSplitPath, /* 461 */ + TclFSSplitPath, /* 461 */ Tcl_FSEqualPaths, /* 462 */ Tcl_FSGetNormalizedPath, /* 463 */ Tcl_FSJoinToPath, /* 464 */ @@ -1783,7 +1292,7 @@ const TclStubs tclStubs = { Tcl_DictObjPut, /* 494 */ Tcl_DictObjGet, /* 495 */ Tcl_DictObjRemove, /* 496 */ - Tcl_DictObjSize, /* 497 */ + TclDictObjSize, /* 497 */ Tcl_DictObjFirst, /* 498 */ Tcl_DictObjNext, /* 499 */ Tcl_DictObjDone, /* 500 */ @@ -1805,7 +1314,7 @@ const TclStubs tclStubs = { Tcl_GetCommandFromObj, /* 516 */ Tcl_GetCommandFullName, /* 517 */ Tcl_FSEvalFileEx, /* 518 */ - Tcl_SetExitProc, /* 519 */ + 0, /* 519 */ Tcl_LimitAddHandler, /* 520 */ Tcl_LimitRemoveHandler, /* 521 */ Tcl_LimitReady, /* 522 */ @@ -1890,7 +1399,7 @@ const TclStubs tclStubs = { Tcl_GetBlockSizeFromStat, /* 601 */ Tcl_SetEnsembleParameterList, /* 602 */ Tcl_GetEnsembleParameterList, /* 603 */ - Tcl_ParseArgsObjv, /* 604 */ + TclParseArgsObjv, /* 604 */ Tcl_GetErrorLine, /* 605 */ Tcl_SetErrorLine, /* 606 */ Tcl_TransferResult, /* 607 */ @@ -1935,11 +1444,11 @@ const TclStubs tclStubs = { Tcl_UtfToUniChar, /* 646 */ Tcl_UniCharToUtfDString, /* 647 */ Tcl_UtfToUniCharDString, /* 648 */ - Tcl_GetBytesFromObj, /* 649 */ - 0, /* 650 */ - 0, /* 651 */ - 0, /* 652 */ - 0, /* 653 */ + TclGetBytesFromObj, /* 649 */ + Tcl_GetBytesFromObj, /* 650 */ + Tcl_GetStringFromObj, /* 651 */ + Tcl_GetUnicodeFromObj, /* 652 */ + Tcl_GetSizeIntFromObj, /* 653 */ Tcl_UtfCharComplete, /* 654 */ Tcl_UtfNext, /* 655 */ Tcl_UtfPrev, /* 656 */ @@ -1947,33 +1456,33 @@ const TclStubs tclStubs = { Tcl_ExternalToUtfDStringEx, /* 658 */ Tcl_UtfToExternalDStringEx, /* 659 */ Tcl_AsyncMarkFromSignal, /* 660 */ - 0, /* 661 */ - 0, /* 662 */ - 0, /* 663 */ - 0, /* 664 */ - 0, /* 665 */ - 0, /* 666 */ - 0, /* 667 */ + Tcl_ListObjGetElements, /* 661 */ + Tcl_ListObjLength, /* 662 */ + Tcl_DictObjSize, /* 663 */ + Tcl_SplitList, /* 664 */ + Tcl_SplitPath, /* 665 */ + Tcl_FSSplitPath, /* 666 */ + Tcl_ParseArgsObjv, /* 667 */ Tcl_UniCharLen, /* 668 */ - TclNumUtfChars, /* 669 */ - TclGetCharLength, /* 670 */ - TclUtfAtIndex, /* 671 */ - TclGetRange, /* 672 */ - TclGetUniChar, /* 673 */ + Tcl_NumUtfChars, /* 669 */ + Tcl_GetCharLength, /* 670 */ + Tcl_UtfAtIndex, /* 671 */ + Tcl_GetRange, /* 672 */ + Tcl_GetUniChar, /* 673 */ Tcl_GetBool, /* 674 */ Tcl_GetBoolFromObj, /* 675 */ - 0, /* 676 */ - 0, /* 677 */ - 0, /* 678 */ - 0, /* 679 */ + Tcl_CreateObjCommand2, /* 676 */ + Tcl_CreateObjTrace2, /* 677 */ + Tcl_NRCreateCommand2, /* 678 */ + Tcl_NRCallObjProc2, /* 679 */ Tcl_GetNumberFromObj, /* 680 */ Tcl_GetNumber, /* 681 */ Tcl_RemoveChannelMode, /* 682 */ Tcl_GetEncodingNulLength, /* 683 */ Tcl_GetWideUIntFromObj, /* 684 */ Tcl_DStringToObj, /* 685 */ - TclUtfNcmp, /* 686 */ - TclUtfNcasecmp, /* 687 */ + Tcl_UtfNcmp, /* 686 */ + Tcl_UtfNcasecmp, /* 687 */ TclUnusedStubEntry, /* 688 */ }; diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index f06b2d1..55001cf 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -71,8 +71,8 @@ Tcl_InitStubs( */ if (!stubsPtr || (stubsPtr->magic != (((exact&0xFF00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { - iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism"; - iPtr->freeProc = 0; /* TCL_STATIC */ + iPtr->legacyResult = "interpreter uses an incompatible stubs mechanism"; + iPtr->legacyFreeProc = 0; /* TCL_STATIC */ return NULL; } diff --git a/generic/tclStubLibTbl.c b/generic/tclStubLibTbl.c index 0391502..ad34494 100644 --- a/generic/tclStubLibTbl.c +++ b/generic/tclStubLibTbl.c @@ -13,6 +13,8 @@ #include "tclInt.h" +MODULE_SCOPE void *tclStubsHandle; + /* *---------------------------------------------------------------------- * @@ -32,18 +34,26 @@ MODULE_SCOPE const char * TclInitStubTable( const char *version) /* points to the version field of a - TclStubInfoType structure variable. */ + structure variable. */ { - tclStubsPtr = ((const TclStubInfoType *) version)->stubs; + if (version) { + if (tclStubsHandle == NULL) { + /* This can only happen with -DBUILD_STATIC, so simulate + * that the loading of Tcl succeeded, although we didn't + * actually load it dynamically */ + tclStubsHandle = (void *)1; + } + tclStubsPtr = ((const TclStubs **) version)[-1]; - if (tclStubsPtr->hooks) { - tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; - tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; - tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; - } else { - tclPlatStubsPtr = NULL; - tclIntStubsPtr = NULL; - tclIntPlatStubsPtr = NULL; + if (tclStubsPtr->hooks) { + tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; + tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; + tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; + } else { + tclPlatStubsPtr = NULL; + tclIntStubsPtr = NULL; + tclIntPlatStubsPtr = NULL; + } } return version; diff --git a/generic/tclTest.c b/generic/tclTest.c index 02e1fac..6db99c9 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -15,18 +15,12 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#undef STATIC_BUILD +#define TCL_8_API #undef BUILD_tcl +#undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif -#undef TCL_UTF_MAX -#ifdef TCL_NO_DEPRECATED -# define TCL_UTF_MAX 4 -#else -# define TCL_NO_DEPRECATED -# define TCL_UTF_MAX 3 -#endif #include "tclInt.h" #ifdef TCL_WITH_EXTERNAL_TOMMATH # include "tommath.h" @@ -144,15 +138,6 @@ typedef struct { } TclEncoding; /* - * The counter below is used to determine if the TestsaveresultFree routine - * was called for a result. - */ - -#ifndef TCL_NO_DEPRECATED -static int freeCount; -#endif /* TCL_NO_DEPRECATED */ - -/* * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands. */ @@ -181,15 +166,6 @@ typedef struct TestChannel { static TestChannel *firstDetached; -#ifdef __GNUC__ -/* - * The rest of this file shouldn't warn about deprecated functions; they're - * there because we intend them to be so and know that this file is OK to - * touch those fields. - */ -#pragma GCC diagnostic ignored "-Wdeprecated-declarations" -#endif - /* * Forward declarations for procedures defined later in this file: */ @@ -236,7 +212,7 @@ static Tcl_ResolveCompiledVarProc InterpCompiledVarResolver; static void MainLoop(void); static Tcl_CmdProc NoopCmd; static Tcl_ObjCmdProc NoopObjCmd; -static Tcl_CmdObjTraceProc2 ObjTraceProc; +static Tcl_CmdObjTraceProc ObjTraceProc; static void ObjTraceDeleteProc(void *clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); static Tcl_FreeProc SpecialFree; @@ -247,7 +223,7 @@ static Tcl_ObjCmdProc TestbytestringObjCmd; static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd; static Tcl_ObjCmdProc TestpurebytesobjObjCmd; static Tcl_ObjCmdProc TeststringbytesObjCmd; -static Tcl_ObjCmdProc Testutf16stringObjCmd; +static Tcl_ObjCmdProc2 Testcmdobj2ObjCmd; static Tcl_ObjCmdProc TestcmdinfoObjCmd; static Tcl_CmdProc TestcmdtokenCmd; static Tcl_CmdProc TestcmdtraceCmd; @@ -299,10 +275,6 @@ static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, size_t length, int *cflagsPtr, int *eflagsPtr); -#ifndef TCL_NO_DEPRECATED -static Tcl_ObjCmdProc TestsaveresultCmd; -static Tcl_FreeProc TestsaveresultFree; -#endif /* TCL_NO_DEPRECATED */ static Tcl_CmdProc TestsetassocdataCmd; static Tcl_CmdProc TestsetCmd; static Tcl_CmdProc Testset2Cmd; @@ -361,6 +333,7 @@ static Tcl_ObjCmdProc TestFindFirstCmd; static Tcl_ObjCmdProc TestFindLastCmd; static Tcl_ObjCmdProc TestHashSystemHashCmd; static Tcl_ObjCmdProc TestGetIntForIndexCmd; +static Tcl_ObjCmdProc TestLutilCmd; static Tcl_NRPostProc NREUnwind_callback; static Tcl_ObjCmdProc TestNREUnwind; @@ -540,6 +513,9 @@ static const char version[] = TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) #ifdef STATIC_BUILD ".static" #endif +#if TCL_UTF_MAX < 4 + ".utf-16" +#endif ; int @@ -555,11 +531,11 @@ Tcltest_Init( "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL }; - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) { return TCL_ERROR; } #ifndef TCL_WITH_EXTERNAL_TOMMATH - if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) { + if (Tcl_TomMath_InitStubs(interp, "8.7-") == NULL) { return TCL_ERROR; } #endif @@ -592,7 +568,6 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testutf16string", Testutf16stringObjCmd, NULL, NULL); Tcl_CreateObjCommand2(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, @@ -610,6 +585,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, NULL, NULL); + Tcl_CreateObjCommand2(interp, "testcmdobj2", Testcmdobj2ObjCmd, + NULL, NULL); Tcl_CreateObjCommand(interp, "testcmdinfo", TestcmdinfoObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd, @@ -690,10 +667,6 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); -#ifndef TCL_NO_DEPRECATED - Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, - NULL, NULL); -#endif Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, @@ -749,6 +722,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testlutil", TestLutilCmd, + NULL, NULL); if (TclObjTest_Init(interp) != TCL_OK) { return TCL_ERROR; @@ -762,6 +737,10 @@ Tcltest_Init( } #endif + if (Tcl_ABSListTest_Init(interp) != TCL_OK) { + return TCL_ERROR; + } + /* * Check for special options used in ../tests/main.test */ @@ -827,7 +806,7 @@ Tcltest_SafeInit( { Tcl_CmdInfo info; - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) { return TCL_ERROR; } if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { @@ -883,8 +862,8 @@ TestasyncCmd( if (argc != 3) { goto wrongNumArgs; } - asyncPtr = (TestAsyncHandler *)ckalloc(sizeof(TestAsyncHandler)); - asyncPtr->command = (char *)ckalloc(strlen(argv[2]) + 1); + asyncPtr = (TestAsyncHandler *)Tcl_Alloc(sizeof(TestAsyncHandler)); + asyncPtr->command = (char *)Tcl_Alloc(strlen(argv[2]) + 1); strcpy(asyncPtr->command, argv[2]); Tcl_MutexLock(&asyncTestMutex); asyncPtr->id = nextId; @@ -902,8 +881,8 @@ TestasyncCmd( asyncPtr = firstHandler; firstHandler = asyncPtr->nextPtr; Tcl_AsyncDelete(asyncPtr->handler); - ckfree(asyncPtr->command); - ckfree(asyncPtr); + Tcl_Free(asyncPtr->command); + Tcl_Free(asyncPtr); } Tcl_MutexUnlock(&asyncTestMutex); return TCL_OK; @@ -926,8 +905,8 @@ TestasyncCmd( prevPtr->nextPtr = asyncPtr->nextPtr; } Tcl_AsyncDelete(asyncPtr->handler); - ckfree(asyncPtr->command); - ckfree(asyncPtr); + Tcl_Free(asyncPtr->command); + Tcl_Free(asyncPtr); break; } Tcl_MutexUnlock(&asyncTestMutex); @@ -1023,7 +1002,7 @@ AsyncHandlerProc( * invoked, it's possible. Better error checking is needed here. */ } - ckfree(cmd); + Tcl_Free(cmd); return code; } @@ -1085,6 +1064,40 @@ TestbumpinterpepochObjCmd( /* *---------------------------------------------------------------------- * + * Testcmdobj2 -- + * + * Mock up to test the Tcl_CreateCommandObj2 functionality + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Sets interpreter result to number of arguments, first arg, last arg. + * + *---------------------------------------------------------------------- + */ + +static int +Testcmdobj2ObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Size objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *resultObj; + resultObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewWideIntObj(objc)); + if (objc > 1) { + Tcl_ListObjAppendElement(interp, resultObj, objv[1]); + Tcl_ListObjAppendElement(interp, resultObj, objv[objc-1]); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestcmdinfoObjCmd -- * * This procedure implements the "testcmdinfo" command. It is used to @@ -1108,12 +1121,15 @@ TestcmdinfoObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const subcmds[] = { - "create", "delete", "get", "modify", NULL + "call", "call2", "create", "delete", "get", "modify", NULL }; enum options { - CMDINFO_CREATE, CMDINFO_DELETE, CMDINFO_GET, CMDINFO_MODIFY + CMDINFO_CALL, CMDINFO_CALL2, CMDINFO_CREATE, + CMDINFO_DELETE, CMDINFO_GET, CMDINFO_MODIFY } idx; Tcl_CmdInfo info; + Tcl_Obj **cmdObjv; + Tcl_Size cmdObjc; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "command arg"); @@ -1124,6 +1140,29 @@ TestcmdinfoObjCmd( return TCL_ERROR; } switch (idx) { + case CMDINFO_CALL: + case CMDINFO_CALL2: + if (Tcl_ListObjGetElements(interp, objv[2], &cmdObjc, &cmdObjv) != TCL_OK) { + return TCL_ERROR; + } + if (cmdObjc == 0) { + Tcl_AppendResult(interp, "No command name given", NULL); + return TCL_ERROR; + } + if (Tcl_GetCommandInfo(interp, Tcl_GetString(cmdObjv[0]), &info) == 0) { + return TCL_ERROR; + } + if (idx == CMDINFO_CALL) { + /* + * Note when calling through the old 32-bit API, it is the caller's + * responsibility to check that number of arguments is <= INT_MAX. + * We do not do that here just so we can test what happens if the + * caller mistakenly passes more arguments. + */ + return info.objProc(info.objClientData, interp, cmdObjc, cmdObjv); + } else { + return info.objProc2(info.objClientData2, interp, cmdObjc, cmdObjv); + } case CMDINFO_CREATE: Tcl_CreateCommand(interp, Tcl_GetString(objv[2]), CmdProc1, (void *)"original", CmdDelProc1); @@ -1243,7 +1282,7 @@ CmdDelProc0( } prevRefPtr = thisRefPtr; } - ckfree(refPtr); + Tcl_Free(refPtr); } static void @@ -1298,7 +1337,7 @@ TestcmdtokenCmd( return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { - refPtr = (TestCommandTokenRef *)ckalloc(sizeof(TestCommandTokenRef)); + refPtr = (TestCommandTokenRef *)Tcl_Alloc(sizeof(TestCommandTokenRef)); refPtr->token = Tcl_CreateCommand(interp, argv[2], CmdProc0, refPtr, CmdDelProc0); refPtr->id = nextCommandTokenRefId; @@ -1422,7 +1461,7 @@ TestcmdtraceCmd( static int deleteCalled; deleteCalled = 0; - cmdTrace = Tcl_CreateObjTrace2(interp, 50000, + cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, &deleteCalled, ObjTraceDeleteProc); result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); @@ -1505,10 +1544,10 @@ static int ObjTraceProc( TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ - TCL_UNUSED(Tcl_Size) /* level */, + TCL_UNUSED(int) /* level */, const char *command, TCL_UNUSED(Tcl_Command), - TCL_UNUSED(Tcl_Size) /*objc*/, + TCL_UNUSED(int) /* objc */, Tcl_Obj *const objv[]) /* Argument objects. */ { const char *word = Tcl_GetString(objv[0]); @@ -1732,9 +1771,9 @@ TestdelCmd( return TCL_ERROR; } - dPtr = (DelCmd *)ckalloc(sizeof(DelCmd)); + dPtr = (DelCmd *)Tcl_Alloc(sizeof(DelCmd)); dPtr->interp = interp; - dPtr->deleteCmd = (char *)ckalloc(strlen(argv[3]) + 1); + dPtr->deleteCmd = (char *)Tcl_Alloc(strlen(argv[3]) + 1); strcpy(dPtr->deleteCmd, argv[3]); Tcl_CreateCommand(child, argv[2], DelCmdProc, dPtr, @@ -1752,8 +1791,8 @@ DelCmdProc( DelCmd *dPtr = (DelCmd *) clientData; Tcl_AppendResult(interp, dPtr->deleteCmd, (void *)NULL); - ckfree(dPtr->deleteCmd); - ckfree(dPtr); + Tcl_Free(dPtr->deleteCmd); + Tcl_Free(dPtr); return TCL_OK; } @@ -1765,8 +1804,8 @@ DelDeleteProc( Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, TCL_INDEX_NONE, 0); Tcl_ResetResult(dPtr->interp); - ckfree(dPtr->deleteCmd); - ckfree(dPtr); + Tcl_Free(dPtr->deleteCmd); + Tcl_Free(dPtr); } /* @@ -1885,7 +1924,7 @@ TestdoubledigitsObjCmd( } str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr); strObj = Tcl_NewStringObj(str, endPtr-str); - ckfree(str); + Tcl_Free(str); retval = Tcl_NewListObj(1, &strObj); Tcl_ListObjAppendElement(NULL, retval, Tcl_NewWideIntObj(decpt)); strObj = Tcl_NewStringObj(signum ? "-" : "+", 1); @@ -1962,11 +2001,11 @@ TestdstringCmd( } 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", (void *)NULL); } else if (strcmp(argv[2], "free") == 0) { - char *s = (char *)ckalloc(100); + char *s = (char *)Tcl_Alloc(100); strcpy(s, "This is a malloc-ed string"); Tcl_SetResult(interp, s, TCL_DYNAMIC); } else if (strcmp(argv[2], "special") == 0) { - char *s = (char *)ckalloc(100) + 16; + char *s = (char *)Tcl_Alloc(100) + 16; strcpy(s, "This is a specially-allocated string"); Tcl_SetResult(interp, s, SpecialFree); } else { @@ -2026,7 +2065,7 @@ static void SpecialFree( char *blockPtr /* Block to free. */ #endif ) { - ckfree((char *)blockPtr - 16); + Tcl_Free(((char *)blockPtr) - 16); } /* @@ -2184,7 +2223,7 @@ static int UtfExtWrapper( } bufLen = dstLen + 4; /* 4 -> overflow detection */ - bufPtr = (unsigned char *) ckalloc(bufLen); + bufPtr = (unsigned char *) Tcl_Alloc(bufLen); memset(bufPtr, 0xFF, dstLen); /* Need to check nul terminator */ memmove(bufPtr + dstLen, "\xAB\xCD\xEF\xAB", 4); /* overflow detection */ bytes = Tcl_GetByteArrayFromObj(objv[3], &srcLen); /* Last! to avoid shimmering */ @@ -2254,7 +2293,7 @@ static int UtfExtWrapper( Tcl_SetObjResult(interp, Tcl_NewListObj(3, resultObjs)); } - ckfree(bufPtr); + Tcl_Free(bufPtr); Tcl_FreeEncoding(encoding); /* Free returned reference */ return result; } @@ -2292,8 +2331,7 @@ TestencodingObjCmd( }; enum options { ENC_CREATE, ENC_DELETE, ENC_NULLENGTH, ENC_EXTTOUTF, ENC_UTFTOEXT - }; - int index; + } index; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?args?"); @@ -2305,7 +2343,7 @@ TestencodingObjCmd( return TCL_ERROR; } - switch ((enum options) index) { + switch (index) { case ENC_CREATE: { Tcl_EncodingType type; @@ -2313,15 +2351,15 @@ TestencodingObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "name toutfcmd fromutfcmd"); return TCL_ERROR; } - encodingPtr = (TclEncoding *)ckalloc(sizeof(TclEncoding)); + encodingPtr = (TclEncoding *)Tcl_Alloc(sizeof(TclEncoding)); encodingPtr->interp = interp; string = Tcl_GetStringFromObj(objv[3], &length); - encodingPtr->toUtfCmd = (char *)ckalloc(length + 1); + encodingPtr->toUtfCmd = (char *)Tcl_Alloc(length + 1); memcpy(encodingPtr->toUtfCmd, string, length + 1); string = Tcl_GetStringFromObj(objv[4], &length); - encodingPtr->fromUtfCmd = (char *)ckalloc(length + 1); + encodingPtr->fromUtfCmd = (char *)Tcl_Alloc(length + 1); memcpy(encodingPtr->fromUtfCmd, string, length + 1); string = Tcl_GetStringFromObj(objv[2], &length); @@ -2440,9 +2478,9 @@ EncodingFreeProc( { TclEncoding *encodingPtr = (TclEncoding *)clientData; - ckfree(encodingPtr->toUtfCmd); - ckfree(encodingPtr->fromUtfCmd); - ckfree(encodingPtr); + Tcl_Free(encodingPtr->toUtfCmd); + Tcl_Free(encodingPtr->fromUtfCmd); + Tcl_Free(encodingPtr); } /* @@ -2598,7 +2636,7 @@ TesteventObjCmd( "position specifier", TCL_EXACT, &posIndex) != TCL_OK) { return TCL_ERROR; } - ev = (TestEvent *)ckalloc(sizeof(TestEvent)); + ev = (TestEvent *)Tcl_Alloc(sizeof(TestEvent)); ev->header.proc = TesteventProc; ev->header.nextPtr = NULL; ev->interp = interp; @@ -3466,12 +3504,12 @@ TestlinkCmd( } if (argv[5][0] != 0) { if (stringVar != NULL) { - ckfree(stringVar); + Tcl_Free(stringVar); } if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = (char *)ckalloc(strlen(argv[5]) + 1); + stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1); strcpy(stringVar, argv[5]); } } @@ -3573,12 +3611,12 @@ TestlinkCmd( } if (argv[5][0] != 0) { if (stringVar != NULL) { - ckfree(stringVar); + Tcl_Free(stringVar); } if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = (char *)ckalloc(strlen(argv[5]) + 1); + stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1); strcpy(stringVar, argv[5]); } Tcl_UpdateLinkedVar(interp, "string"); @@ -3695,7 +3733,7 @@ TestlinkarrayCmd( static const char *LinkOption[] = { "update", "remove", "create", NULL }; - enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE }; + enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE } optionIndex; static const char *LinkType[] = { "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", "wide", "uwide", "float", "double", "string", "char*", "binary", NULL @@ -3708,7 +3746,7 @@ TestlinkarrayCmd( TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, TCL_LINK_BINARY }; - int optionIndex, typeIndex, readonly, i, size; + int typeIndex, readonly, i, size; Tcl_Size length; char *name, *arg; Tcl_WideInt addr; @@ -3721,7 +3759,7 @@ TestlinkarrayCmd( &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum LinkOptionEnum) optionIndex) { + switch (optionIndex) { case LINK_UPDATE: for (i=2; i<objc; i++) { Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i])); @@ -4026,7 +4064,7 @@ CleanupTestSetassocdataTests( void *clientData, /* Data to be released. */ TCL_UNUSED(Tcl_Interp *)) { - ckfree(clientData); + Tcl_Free(clientData); } /* @@ -4453,8 +4491,7 @@ TestregexpObjCmd( REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL, REGEXP_XFLAGS, REGEXP_LAST - }; - int index; + } index; indices = 0; about = 0; @@ -4473,7 +4510,7 @@ TestregexpObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum optionsEnum) index) { + switch (index) { case REGEXP_INDICES: indices = 1; break; @@ -4554,7 +4591,7 @@ TestregexpObjCmd( varName = Tcl_GetString(objv[2]); TclRegExpRangeUniChar(regExpr, TCL_INDEX_NONE, &start, &end); - snprintf(resinfo, sizeof(resinfo), "%d %d", start, end-1); + snprintf(resinfo, sizeof(resinfo), "%" TCL_Z_MODIFIER "d %" TCL_Z_MODIFIER "d", start, end-1); value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", @@ -4568,7 +4605,7 @@ TestregexpObjCmd( Tcl_RegExpGetInfo(regExpr, &info); varName = Tcl_GetString(objv[2]); - snprintf(resinfo, sizeof(resinfo), "%ld", info.extendStart); + snprintf(resinfo, sizeof(resinfo), "%" TCL_Z_MODIFIER "d", info.extendStart); value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", @@ -4612,7 +4649,7 @@ TestregexpObjCmd( * instead of the first character after the match. */ - if (end >= 0) { + if (end != TCL_INDEX_NONE) { end--; } @@ -4623,11 +4660,11 @@ TestregexpObjCmd( } else { if (ii == TCL_INDEX_NONE) { TclRegExpRangeUniChar(regExpr, ii, &start, &end); - newPtr = TclGetRange(objPtr, start, end); + newPtr = Tcl_GetRange(objPtr, start, end); } else if (ii > info.nsubs || info.matches[ii].end <= 0) { newPtr = Tcl_NewObj(); } else { - newPtr = TclGetRange(objPtr, info.matches[ii].start, + newPtr = Tcl_GetRange(objPtr, info.matches[ii].start, info.matches[ii].end - 1); } } @@ -4797,7 +4834,7 @@ TestsetassocdataCmd( return TCL_ERROR; } - buf = (char *)ckalloc(strlen(argv[2]) + 1); + buf = (char *)Tcl_Alloc(strlen(argv[2]) + 1); strcpy(buf, argv[2]); /* @@ -4807,7 +4844,7 @@ TestsetassocdataCmd( oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr); if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) { - ckfree(oldData); + Tcl_Free(oldData); } Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, buf); @@ -5191,7 +5228,7 @@ TestpanicCmd( char *argString = Tcl_Merge(argc-1, argv+1); Tcl_Panic("%s", argString); - ckfree(argString); + Tcl_Free(argString); return TCL_OK; } @@ -5371,8 +5408,8 @@ GetTimesObjCmd( fprintf(stderr, "alloc & free 100000 6 word items\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - objPtr = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj)); - ckfree(objPtr); + objPtr = (Tcl_Obj *)Tcl_Alloc(sizeof(Tcl_Obj)); + Tcl_Free(objPtr); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -5380,10 +5417,10 @@ GetTimesObjCmd( /* alloc 5000 times */ fprintf(stderr, "alloc 5000 6 word items\n"); - objv = (Tcl_Obj **)ckalloc(5000 * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)Tcl_Alloc(5000 * sizeof(Tcl_Obj *)); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - objv[i] = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj)); + objv[i] = (Tcl_Obj *)Tcl_Alloc(sizeof(Tcl_Obj)); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -5393,7 +5430,7 @@ GetTimesObjCmd( fprintf(stderr, "free 5000 6 word items\n"); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - ckfree(objv[i]); + Tcl_Free(objv[i]); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -5419,7 +5456,7 @@ GetTimesObjCmd( Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000); - ckfree(objv); + Tcl_Free(objv); /* TclGetString 100000 times */ fprintf(stderr, "Tcl_GetStringFromObj of \"12345\" 100000 times\n"); @@ -5645,7 +5682,7 @@ TestpurebytesobjObjCmd( if (objc == 2) { const char *s = Tcl_GetString(objv[1]); objPtr->length = objv[1]->length; - objPtr->bytes = (char *)ckalloc(objPtr->length + 1); + objPtr->bytes = (char *)Tcl_Alloc(objPtr->length + 1); memcpy(objPtr->bytes, s, objPtr->length); objPtr->bytes[objPtr->length] = 0; } @@ -5727,7 +5764,11 @@ TestbytestringObjCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { struct { +#if !defined(TCL_NO_DEPRECATED) + int n; /* On purpose, not Tcl_Size, in order to demonstrate what happens */ +#else Tcl_Size n; +#endif int m; /* This variable should not be overwritten */ } x = {0, 1}; const char *p; @@ -5741,6 +5782,7 @@ TestbytestringObjCmd( if (p == NULL) { return TCL_ERROR; } + if (x.m != 1) { Tcl_AppendResult(interp, "Tcl_GetBytesFromObj() overwrites variable", (void *)NULL); return TCL_ERROR; @@ -5752,43 +5794,6 @@ TestbytestringObjCmd( /* *---------------------------------------------------------------------- * - * Testutf16stringObjCmd -- - * - * This specifically tests the Tcl_GetUnicode and Tcl_NewUnicodeObj - * C functions which broke in Tcl 8.7 and were undetected by the - * existing test suite. Bug [b79df322a9] - * - * Results: - * Returns the TCL_OK result code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -Testutf16stringObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - const unsigned short *p; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "string"); - return TCL_ERROR; - } - - p = Tcl_GetUnicode(objv[1]); - Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(p, TCL_INDEX_NONE)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TestsetCmd -- * * Implements the "testset{err,noerr}" cmds that are used when testing @@ -5871,143 +5876,6 @@ Testset2Cmd( /* *---------------------------------------------------------------------- * - * TestsaveresultCmd -- - * - * Implements the "testsaveresult" cmd that is used when testing the - * Tcl_SaveResult, Tcl_RestoreResult, and Tcl_DiscardResult interfaces. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -static int -TestsaveresultCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp,/* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - Interp* iPtr = (Interp*) interp; - int discard, result, index; - Tcl_SavedResult state; - Tcl_Obj *objPtr; - static const char *const optionStrings[] = { - "append", "dynamic", "free", "object", "small", NULL - }; - enum options { - RESULT_APPEND, RESULT_DYNAMIC, RESULT_FREE, RESULT_OBJECT, RESULT_SMALL - }; - - /* - * Parse arguments - */ - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "type script discard"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) { - return TCL_ERROR; - } - - freeCount = 0; - objPtr = NULL; - switch ((enum options) index) { - case RESULT_SMALL: - Tcl_AppendResult(interp, "small result", (void *)NULL); - break; - case RESULT_APPEND: - Tcl_AppendResult(interp, "append result", (void *)NULL); - break; - case RESULT_FREE: { - char *buf = (char *)ckalloc(200); - - strcpy(buf, "free result"); - Tcl_SetResult(interp, buf, TCL_DYNAMIC); - break; - } - case RESULT_DYNAMIC: - Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree); - break; - case RESULT_OBJECT: - objPtr = Tcl_NewStringObj("object result", TCL_INDEX_NONE); - Tcl_SetObjResult(interp, objPtr); - break; - } - - Tcl_SaveResult(interp, &state); - - if (((enum options) index) == RESULT_OBJECT) { - result = Tcl_EvalObjEx(interp, objv[2], 0); - } else { - result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0); - } - - if (discard) { - Tcl_DiscardResult(&state); - } else { - Tcl_RestoreResult(interp, &state); - result = TCL_OK; - } - - switch ((enum options) index) { - case RESULT_DYNAMIC: { - int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount; - - Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak"); - break; - } - case RESULT_OBJECT: - Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr - ? "same" : "different"); - break; - default: - break; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TestsaveresultFree -- - * - * Special purpose freeProc used by TestsaveresultCmd. - * - * Results: - * None. - * - * Side effects: - * Increments the freeCount. - * - *---------------------------------------------------------------------- - */ - -static void -TestsaveresultFree( -#if TCL_MAJOR_VERSION > 8 - TCL_UNUSED(void *)) -#else - TCL_UNUSED(char *)) -#endif -{ - freeCount++; -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * TestmainthreadCmd -- * * Implements the "testmainthread" cmd that is used to test the @@ -6186,7 +6054,7 @@ TestChannelCmd( *nextPtrPtr = curPtr->nextPtr; curPtr->nextPtr = NULL; chan = curPtr->chan; - ckfree(curPtr); + Tcl_Free(curPtr); break; } } @@ -6255,7 +6123,7 @@ TestChannelCmd( /* Remember the channel in the pool of detached channels */ - det = (TestChannel *)ckalloc(sizeof(TestChannel)); + det = (TestChannel *)Tcl_Alloc(sizeof(TestChannel)); det->chan = chan; det->nextPtr = firstDetached; firstDetached = det; @@ -6689,7 +6557,7 @@ TestChannelEventCmd( return TCL_ERROR; } - esPtr = (EventScriptRecord *)ckalloc(sizeof(EventScriptRecord)); + esPtr = (EventScriptRecord *)Tcl_Alloc(sizeof(EventScriptRecord)); esPtr->nextPtr = statePtr->scriptRecordPtr; statePtr->scriptRecordPtr = esPtr; @@ -6746,7 +6614,7 @@ TestChannelEventCmd( Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - ckfree(esPtr); + Tcl_Free(esPtr); return TCL_OK; } @@ -6787,7 +6655,7 @@ TestChannelEventCmd( Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - ckfree(esPtr); + Tcl_Free(esPtr); } statePtr->scriptRecordPtr = NULL; return TCL_OK; @@ -7713,7 +7581,7 @@ TestUtfPrevCmd( if (TCL_OK != Tcl_GetIntForIndex(interp, objv[2], numBytes, &offset)) { return TCL_ERROR; } - if (offset < 0) { + if (offset == TCL_INDEX_NONE) { offset = 0; } if (offset > numBytes) { @@ -8086,8 +7954,8 @@ TestNRELevels( TCL_UNUSED(Tcl_Obj *const *) /*objv*/) { Interp *iPtr = (Interp *) interp; - static ptrdiff_t *refDepth = NULL; - ptrdiff_t depth; + static Tcl_Size *refDepth = NULL; + Tcl_Size depth; Tcl_Obj *levels[6]; Tcl_Size i = 0; NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr; @@ -8449,7 +8317,7 @@ TestparseargsCmd( result[1] = Tcl_NewWideIntObj(count); result[2] = Tcl_NewListObj(count, remObjv); Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); - ckfree(remObjv); + Tcl_Free(remObjv); return TCL_OK; } @@ -8576,7 +8444,7 @@ HashVarFree( Tcl_Var var) { if (VarHashRefCount(var) < 2) { - ckfree(var); + Tcl_Free(var); } else { VarHashRefCount(var)--; } @@ -8592,7 +8460,7 @@ MyCompiledVarFree( if (resVarInfo->var) { HashVarFree(resVarInfo->var); } - ckfree(vInfoPtr); + Tcl_Free(vInfoPtr); } #define TclVarHashGetValue(hPtr) \ @@ -8626,7 +8494,7 @@ MyCompiledVarFetch( } hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable, - (char *)resVarInfo->nameObj, &isNewVar); + resVarInfo->nameObj, &isNewVar); if (hPtr) { var = (Tcl_Var) TclVarHashGetValue(hPtr); } else { @@ -8635,7 +8503,7 @@ MyCompiledVarFetch( resVarInfo->var = var; /* - * Increment the reference counter to avoid ckfree() of the variable in + * Increment the reference counter to avoid Tcl_Free() of the variable in * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree(); */ @@ -8652,7 +8520,7 @@ InterpCompiledVarResolver( Tcl_ResolvedVarInfo **rPtr) { if (*name == 'T') { - MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)ckalloc(sizeof(MyResolvedVarInfo)); + MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)Tcl_Alloc(sizeof(MyResolvedVarInfo)); resVarInfo->vInfo.fetchProc = MyCompiledVarFetch; resVarInfo->vInfo.deleteProc = MyCompiledVarFree; @@ -8787,6 +8655,102 @@ int TestApplyLambdaObjCmd ( } /* + *---------------------------------------------------------------------- + * + * TestLutilCmd -- + * + * This procedure implements the "testlequal" command. It is used to + * test compare two lists for equality using the string representation + * of each element. Implemented in C because script level loops are + * too slow for comparing large (GB count) lists. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestLutilCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Arguments. */ +{ + Tcl_Size nL1, nL2; + Tcl_Obj *l1Obj = NULL; + Tcl_Obj *l2Obj = NULL; + Tcl_Obj **l1Elems; + Tcl_Obj **l2Elems; + static const char *const subcmds[] = { + "equal", "diffindex", NULL + }; + enum options { + LUTIL_EQUAL, LUTIL_DIFFINDEX + } idx; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "list1 list2"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, + &idx) != TCL_OK) { + return TCL_ERROR; + } + + /* Protect against shimmering, just to be safe */ + l1Obj = Tcl_DuplicateObj(objv[2]); + l2Obj = Tcl_DuplicateObj(objv[3]); + + int ret = TCL_ERROR; + if (Tcl_ListObjGetElements(interp, l1Obj, &nL1, &l1Elems) != TCL_OK) { + goto vamoose; + } + if (Tcl_ListObjGetElements(interp, l2Obj, &nL2, &l2Elems) != TCL_OK) { + goto vamoose; + } + + Tcl_Size i, nCmp; + + ret = TCL_OK; + switch (idx) { + case LUTIL_EQUAL: + /* Avoid the loop below if lengths differ */ + if (nL1 != nL2) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + break; + } + /* FALLTHRU */ + case LUTIL_DIFFINDEX: + nCmp = nL1 <= nL2 ? nL1 : nL2; + for (i = 0; i < nCmp; ++i) { + if (strcmp(Tcl_GetString(l1Elems[i]), Tcl_GetString(l2Elems[i]))) { + break; + } + } + if (i == nCmp && nCmp == nL1 && nCmp == nL2) { + nCmp = idx == LUTIL_EQUAL ? 1 : -1; + } else { + nCmp = idx == LUTIL_EQUAL ? 0 : i; + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(nCmp)); + break; + } + +vamoose: + if (l1Obj) { + Tcl_DecrRefCount(l1Obj); + } + if (l2Obj) { + Tcl_DecrRefCount(l2Obj); + } + return ret; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c new file mode 100644 index 0000000..1278a93 --- /dev/null +++ b/generic/tclTestABSList.c @@ -0,0 +1,1256 @@ +// Tcl Abstract List test command: "lstring" + +#undef BUILD_tcl +#undef STATIC_BUILD +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif +#include <string.h> +#include <limits.h> +#include "tclInt.h" + +/* + * Forward references + */ + +Tcl_Obj *myNewLStringObj(Tcl_WideInt start, + Tcl_WideInt length); +static void freeRep(Tcl_Obj* alObj); +static Tcl_Obj* my_LStringObjSetElem(Tcl_Interp *interp, + Tcl_Obj *listPtr, + Tcl_Size numIndcies, + Tcl_Obj *const indicies[], + Tcl_Obj *valueObj); +static void DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static Tcl_Size my_LStringObjLength(Tcl_Obj *lstringObjPtr); +static int my_LStringObjIndex(Tcl_Interp *interp, + Tcl_Obj *lstringObj, + Tcl_Size index, + Tcl_Obj **charObjPtr); +static int my_LStringObjRange(Tcl_Interp *interp, Tcl_Obj *lstringObj, + Tcl_Size fromIdx, Tcl_Size toIdx, + Tcl_Obj **newObjPtr); +static int my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj, + Tcl_Obj **newObjPtr); +static int my_LStringReplace(Tcl_Interp *interp, + Tcl_Obj *listObj, + Tcl_Size first, + Tcl_Size numToDelete, + Tcl_Size numToInsert, + Tcl_Obj *const insertObjs[]); +static int my_LStringGetElements(Tcl_Interp *interp, + Tcl_Obj *listPtr, + Tcl_Size *objcptr, + Tcl_Obj ***objvptr); +static void lstringFreeElements(Tcl_Obj* lstringObj); +static void UpdateStringOfLString(Tcl_Obj *objPtr); + +/* + * Internal Representation of an lstring type value + */ + +typedef struct LString { + char *string; // NULL terminated utf-8 string + Tcl_Size strlen; // num bytes in string + Tcl_Size allocated; // num bytes allocated + Tcl_Obj**elements; // elements array, allocated when GetElements is + // called +} LString; + +/* + * AbstractList definition of an lstring type + */ +static const Tcl_ObjType lstringTypes[11] = { + {/*0*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V2( + my_LStringObjLength, /* Length */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* "in" operator */ + }, + {/*1*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V2( + NULL, /* Length */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* "in" operator */ + }, + {/*2*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V2( + my_LStringObjLength, /* Length */ + NULL, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* "in" operator */ + }, + {/*3*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V2( + my_LStringObjLength, /* Length */ + my_LStringObjIndex, /* Index */ + NULL, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* "in" operator */ + }, + {/*4*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V2( + my_LStringObjLength, /* Length */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + NULL, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* "in" operator */ + }, + {/*5*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V2( + my_LStringObjLength, /* Length */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + NULL, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* "in" operator */ + }, + {/*6*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V2( + my_LStringObjLength, /* Length */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + NULL, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* "in" operator */ + }, + {/*7*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V2( + my_LStringObjLength, /* Length */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + NULL, /* Replace */ + NULL) /* "in" operator */ + }, + {/*8*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V2( + my_LStringObjLength, /* Length */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* "in" operator */ + }, + {/*9*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V2( + my_LStringObjLength, /* Length */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* "in" operator */ + }, + {/*10*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V2( + my_LStringObjLength, /* Length */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* "in" operator */ + } +}; + + +/* + *---------------------------------------------------------------------- + * + * my_LStringObjIndex -- + * + * Implements the AbstractList Index function for the lstring type. The + * Index function returns the value at the index position given. Caller + * is resposible for freeing the Obj. + * + * Results: + * TCL_OK on success. Returns a new Obj, with a 0 refcount in the + * supplied charObjPtr location. Call has ownership of the Obj. + * + * Side effects: + * Obj allocated. + * + *---------------------------------------------------------------------- + */ + +static int +my_LStringObjIndex( + Tcl_Interp *interp, + Tcl_Obj *lstringObj, + Tcl_Size index, + Tcl_Obj **charObjPtr) +{ + LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; + + (void)interp; + + if (index < lstringRepPtr->strlen) { + char cchar[2]; + cchar[0] = lstringRepPtr->string[index]; + cchar[1] = 0; + *charObjPtr = Tcl_NewStringObj(cchar,1); + } else { + *charObjPtr = NULL; + } + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * my_LStringObjLength -- + * + * Implements the AbstractList Length function for the lstring type. + * The Length function returns the number of elements in the list. + * + * Results: + * WideInt number of elements in the list. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Size +my_LStringObjLength(Tcl_Obj *lstringObjPtr) +{ + LString *lstringRepPtr = (LString *)lstringObjPtr->internalRep.twoPtrValue.ptr1; + return lstringRepPtr->strlen; +} + + +/* + *---------------------------------------------------------------------- + * + * DupLStringRep -- + * + * Replicates the internal representation of the src value, and storing + * it in the copy + * + * Results: + * void + * + * Side effects: + * Modifies the rep of the copyObj. + * + *---------------------------------------------------------------------- + */ + +static void +DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) +{ + LString *srcLString = (LString*)srcPtr->internalRep.twoPtrValue.ptr1; + LString *copyLString = (LString*)Tcl_Alloc(sizeof(LString)); + + memcpy(copyLString, srcLString, sizeof(LString)); + copyLString->string = (char*)Tcl_Alloc(srcLString->allocated); + strncpy(copyLString->string, srcLString->string, srcLString->strlen); + copyLString->string[srcLString->strlen] = '\0'; + copyLString->elements = NULL; + Tcl_ObjInternalRep itr; + itr.twoPtrValue.ptr1 = copyLString; + itr.twoPtrValue.ptr2 = NULL; + Tcl_StoreInternalRep(copyPtr, srcPtr->typePtr, &itr); + + return; +} + +/* + *---------------------------------------------------------------------- + * + * my_LStringObjSetElem -- + * + * Replace the element value at the given (nested) index with the + * valueObj provided. If the lstring obj is shared, a new list is + * created conntaining the modifed element. + * + * Results: + * The modifed lstring is returned, either new or original. If the + * index is invalid, NULL is returned, and an error is added to the + * interp, if provided. + * + * Side effects: + * A new obj may be created. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj* +my_LStringObjSetElem( + Tcl_Interp *interp, + Tcl_Obj *lstringObj, + Tcl_Size numIndicies, + Tcl_Obj *const indicies[], + Tcl_Obj *valueObj) +{ + LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; + Tcl_Size index; + int status; + Tcl_Obj *returnObj; + + if (numIndicies > 1) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Multiple indicies not supported by lstring.")); + return NULL; + } + + status = Tcl_GetIntForIndex(interp, indicies[0], lstringRepPtr->strlen, &index); + if (status != TCL_OK) { + return NULL; + } + + returnObj = Tcl_IsShared(lstringObj) ? Tcl_DuplicateObj(lstringObj) : lstringObj; + lstringRepPtr = (LString*)returnObj->internalRep.twoPtrValue.ptr1; + + if (index >= lstringRepPtr->strlen) { + index = lstringRepPtr->strlen; + lstringRepPtr->strlen++; + lstringRepPtr->string = (char*)Tcl_Realloc(lstringRepPtr->string, lstringRepPtr->strlen+1); + } + + if (valueObj) { + const char newvalue = Tcl_GetString(valueObj)[0]; + lstringRepPtr->string[index] = newvalue; + } else if (index < lstringRepPtr->strlen) { + /* Remove the char by sliding the tail of the string down */ + char *sptr = &lstringRepPtr->string[index]; + /* This is an overlapping copy, by definition */ + lstringRepPtr->strlen--; + memmove(sptr, (sptr+1), (lstringRepPtr->strlen - index)); + } + // else do nothing + + Tcl_InvalidateStringRep(returnObj); + + return returnObj; +} + +/* + *---------------------------------------------------------------------- + * + * my_LStringObjRange -- + * + * Creates a new Obj with a slice of the src listPtr. + * + * Results: + * A new Obj is assigned to newObjPtr. Returns TCL_OK + * + * Side effects: + * A new Obj is created. + * + *---------------------------------------------------------------------- + */ + +static int my_LStringObjRange( + Tcl_Interp *interp, + Tcl_Obj *lstringObj, + Tcl_Size fromIdx, + Tcl_Size toIdx, + Tcl_Obj **newObjPtr) +{ + Tcl_Obj *rangeObj; + LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; + LString *rangeRep; + Tcl_WideInt len = toIdx - fromIdx + 1; + + if (lstringRepPtr->strlen < fromIdx || + lstringRepPtr->strlen < toIdx) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Range out of bounds ")); + return TCL_ERROR; + } + + if (len <= 0) { + // Return empty value; + *newObjPtr = Tcl_NewObj(); + } else { + rangeRep = (LString*)Tcl_Alloc(sizeof(LString)); + rangeRep->allocated = len+1; + rangeRep->strlen = len; + rangeRep->string = (char*)Tcl_Alloc(rangeRep->allocated); + strncpy(rangeRep->string,&lstringRepPtr->string[fromIdx],len); + rangeRep->string[len] = 0; + rangeRep->elements = NULL; + rangeObj = Tcl_NewObj(); + Tcl_ObjInternalRep itr; + itr.twoPtrValue.ptr1 = rangeRep; + itr.twoPtrValue.ptr2 = NULL; + Tcl_StoreInternalRep(rangeObj, lstringObj->typePtr, &itr); + if (rangeRep->strlen > 0) { + Tcl_InvalidateStringRep(rangeObj); + } else { + Tcl_InitStringRep(rangeObj, NULL, 0); + } + *newObjPtr = rangeObj; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * my_LStringObjReverse -- + * + * Creates a new Obj with the the order of the elements in the lstring + * value reversed, where first is last and last is first, etc. + * + * Results: + * A new Obj is assigned to newObjPtr. Returns TCL_OK + * + * Side effects: + * A new Obj is created. + * + *---------------------------------------------------------------------- + */ + +static int +my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj, Tcl_Obj **newObjPtr) +{ + LString *srcRep = (LString*)srcObj->internalRep.twoPtrValue.ptr1; + Tcl_Obj *revObj; + LString *revRep = (LString*)Tcl_Alloc(sizeof(LString)); + Tcl_ObjInternalRep itr; + Tcl_Size len; + char *srcp, *dstp, *endp; + (void)interp; + len = srcRep->strlen; + revRep->strlen = len; + revRep->allocated = len+1; + revRep->string = (char*)Tcl_Alloc(revRep->allocated); + revRep->elements = NULL; + srcp = srcRep->string; + endp = &srcRep->string[len]; + dstp = &revRep->string[len]; + *dstp-- = 0; + while (srcp < endp) { + *dstp-- = *srcp++; + } + revObj = Tcl_NewObj(); + itr.twoPtrValue.ptr1 = revRep; + itr.twoPtrValue.ptr2 = NULL; + Tcl_StoreInternalRep(revObj, srcObj->typePtr, &itr); + if (revRep->strlen > 0) { + Tcl_InvalidateStringRep(revObj); + } else { + Tcl_InitStringRep(revObj, NULL, 0); + } + *newObjPtr = revObj; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * my_LStringReplace -- + * + * Delete and/or Insert elements in the list, starting at index first. + * See more details in the comments below. This should not be called with + * a Shared Obj. + * + * Results: + * The value of the listObj is modified. + * + * Side effects: + * The string rep is invalidated. + * + *---------------------------------------------------------------------- + */ + +static int +my_LStringReplace( + Tcl_Interp *interp, + Tcl_Obj *listObj, + Tcl_Size first, + Tcl_Size numToDelete, + Tcl_Size numToInsert, + Tcl_Obj *const insertObjs[]) +{ + LString *lstringRep = (LString*)listObj->internalRep.twoPtrValue.ptr1; + Tcl_Size newLen; + Tcl_Size x, ix, kx; + char *newStr; + char *oldStr = lstringRep->string; + (void)interp; + + newLen = lstringRep->strlen - numToDelete + numToInsert; + + if (newLen >= lstringRep->allocated) { + lstringRep->allocated = newLen+1; + newStr = (char*)Tcl_Alloc(lstringRep->allocated); + newStr[newLen] = 0; + } else { + newStr = oldStr; + } + + /* Tcl_ListObjReplace replaces zero or more elements of the list + * referenced by listPtr with the objc values in the array referenced by + * objv. + * + * If listPtr does not point to a list value, Tcl_ListObjReplace + * will attempt to convert it to one; if the conversion fails, it returns + * TCL_ERROR and leaves an error message in the interpreter's result value + * if interp is not NULL. Otherwise, it returns TCL_OK after replacing the + * values. + * + * * If objv is NULL, no new elements are added. + * + * * If the argument first is zero or negative, it refers to the first + * element. + * + * * If first is greater than or equal to the number of elements in the + * list, then no elements are deleted; the new elements are appended + * to the list. count gives the number of elements to replace. + * + * * If count is zero or negative then no elements are deleted; the new + * elements are simply inserted before the one designated by first. + * Tcl_ListObjReplace invalidates listPtr's old string representation. + * + * * The reference counts of any elements inserted from objv are + * incremented since the resulting list now refers to them. Similarly, + * the reference counts for any replaced values are decremented. + */ + + // copy 0 to first-1 + if (newStr != oldStr) { + strncpy(newStr, oldStr, first); + } + + // move front elements to keep + for(x=0, kx=0; x<newLen && kx<first; kx++, x++) { + newStr[x] = oldStr[kx]; + } + // Insert new elements into new string + for(x=first, ix=0; ix<numToInsert; x++, ix++) { + char const *svalue = Tcl_GetString(insertObjs[ix]); + newStr[x] = svalue[0]; + } + // Move remaining elements + if ((first+numToDelete) < newLen) { + for(/*x,*/ kx=first+numToDelete; (kx <lstringRep->strlen && x<newLen); x++, kx++) { + newStr[x] = oldStr[kx]; + } + } + + // Terminate new string. + newStr[newLen] = 0; + + + if (oldStr != newStr) { + Tcl_Free(oldStr); + } + lstringRep->string = newStr; + lstringRep->strlen = newLen; + + /* Changes made to value, string rep and elements array no longer valid */ + Tcl_InvalidateStringRep(listObj); + lstringFreeElements(listObj); + + return TCL_OK; +} + +static const Tcl_ObjType * +my_SetAbstractProc(int ptype) +{ + const Tcl_ObjType *typePtr = &lstringTypes[0]; /* default value */ + if (4 <= ptype && ptype <= 11) { + /* Table has no entries for the slots upto setfromany */ + typePtr = &lstringTypes[(ptype-3)]; + } + return typePtr; +} + + +/* + *---------------------------------------------------------------------- + * + * my_NewLStringObj -- + * + * Creates a new lstring Obj using the string value of objv[0] + * + * Results: + * results + * + * Side effects: + * side effects + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +my_NewLStringObj( + Tcl_Interp *interp, + int objc, + Tcl_Obj * const objv[]) +{ + LString *lstringRepPtr; + Tcl_ObjInternalRep itr; + size_t repSize; + Tcl_Obj *lstringPtr; + const char *string; + static const char* procTypeNames[] = { + "FREEREP", "DUPREP", "UPDATESTRING", "SETFROMANY", + "LENGTH", "INDEX", "SLICE", "REVERSE", "GETELEMENTS", + "SETELEMENT", "REPLACE", NULL + }; + int i = 0; + int ptype; + const Tcl_ObjType *lstringTypePtr = &lstringTypes[10]; + + repSize = sizeof(LString); + lstringRepPtr = (LString*)Tcl_Alloc(repSize); + + while (i<objc) { + const char *s = Tcl_GetString(objv[i]); + if (strcmp(s, "-not")==0) { + i++; + if (Tcl_GetIndexFromObj(interp, objv[i], procTypeNames, "proctype", 0, &ptype)==TCL_OK) { + lstringTypePtr = my_SetAbstractProc(ptype); + } + } else if (strcmp(s, "--") == 0) { + // End of options + i++; + break; + } else { + break; + } + i++; + } + if (i != objc-1) { + Tcl_Free((char*)lstringRepPtr); + Tcl_WrongNumArgs(interp, 0, objv, "lstring string"); + return NULL; + } + string = Tcl_GetString(objv[i]); + + lstringRepPtr->strlen = strlen(string); + lstringRepPtr->allocated = lstringRepPtr->strlen + 1; + lstringRepPtr->string = (char*)Tcl_Alloc(lstringRepPtr->allocated); + strcpy(lstringRepPtr->string, string); + lstringRepPtr->elements = NULL; + lstringPtr = Tcl_NewObj(); + itr.twoPtrValue.ptr1 = lstringRepPtr; + itr.twoPtrValue.ptr2 = NULL; + Tcl_StoreInternalRep(lstringPtr, lstringTypePtr, &itr); + if (lstringRepPtr->strlen > 0) { + Tcl_InvalidateStringRep(lstringPtr); + } else { + Tcl_InitStringRep(lstringPtr, NULL, 0); + } + return lstringPtr; +} + +/* + *---------------------------------------------------------------------- + * + * freeElements -- + * + * Free the element array + * + */ + +static void +lstringFreeElements(Tcl_Obj* lstringObj) +{ + LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; + if (lstringRepPtr->elements) { + Tcl_Obj **objptr = lstringRepPtr->elements; + while (objptr < &lstringRepPtr->elements[lstringRepPtr->strlen]) { + Tcl_DecrRefCount(*objptr++); + } + Tcl_Free((char*)lstringRepPtr->elements); + lstringRepPtr->elements = NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * freeRep -- + * + * Free the value storage of the lstring Obj. + * + * Results: + * void + * + * Side effects: + * Memory free'd. + * + *---------------------------------------------------------------------- + */ + +static void +freeRep(Tcl_Obj* lstringObj) +{ + LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; + if (lstringRepPtr->string) { + Tcl_Free(lstringRepPtr->string); + } + lstringFreeElements(lstringObj); + Tcl_Free((char*)lstringRepPtr); + lstringObj->internalRep.twoPtrValue.ptr1 = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * my_LStringGetElements -- + * + * Get the elements of the list in an array. + * + * Results: + * objc, objv return values + * + * Side effects: + * A Tcl_Obj is stored for every element of the abstract list + * + *---------------------------------------------------------------------- + */ + +static int my_LStringGetElements(Tcl_Interp *interp, + Tcl_Obj *lstringObj, + Tcl_Size *objcptr, + Tcl_Obj ***objvptr) +{ + LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; + Tcl_Obj **objPtr; + char *cptr = lstringRepPtr->string; + (void)interp; + if (lstringRepPtr->strlen == 0) { + *objcptr = 0; + *objvptr = NULL; + return TCL_OK; + } + if (lstringRepPtr->elements == NULL) { + lstringRepPtr->elements = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * lstringRepPtr->strlen); + objPtr=lstringRepPtr->elements; + while (objPtr < &lstringRepPtr->elements[lstringRepPtr->strlen]) { + *objPtr = Tcl_NewStringObj(cptr++,1); + Tcl_IncrRefCount(*objPtr++); + } + } + *objvptr = lstringRepPtr->elements; + *objcptr = lstringRepPtr->strlen; + return TCL_OK; +} + +/* +** UpdateStringRep +*/ + +static void +UpdateStringOfLString(Tcl_Obj *objPtr) +{ +# define LOCAL_SIZE 64 + int localFlags[LOCAL_SIZE], *flagPtr = NULL; + Tcl_ObjType const *typePtr = objPtr->typePtr; + char *p; + int bytesNeeded = 0; + int llen, i; + + + /* + * Handle empty list case first, so rest of the routine is simpler. + */ + llen = typePtr->lengthProc(objPtr); + if (llen <= 0) { + Tcl_InitStringRep(objPtr, NULL, 0); + return; + } + + /* + * Pass 1: estimate space. + */ + if (llen <= LOCAL_SIZE) { + flagPtr = localFlags; + } else { + /* We know numElems <= LIST_MAX, so this is safe. */ + flagPtr = (int *) Tcl_Alloc(llen*sizeof(int)); + } + for (bytesNeeded = 0, i = 0; i < llen; i++) { + Tcl_Obj *elemObj; + const char *elemStr; + Tcl_Size elemLen; + flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); + typePtr->indexProc(NULL, objPtr, i, &elemObj); + Tcl_IncrRefCount(elemObj); + elemStr = Tcl_GetStringFromObj(elemObj, &elemLen); + /* Note TclScanElement updates flagPtr[i] */ + bytesNeeded += Tcl_ScanCountedElement(elemStr, elemLen, &flagPtr[i]); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + Tcl_DecrRefCount(elemObj); + } + if (bytesNeeded > INT_MAX - llen + 1) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + bytesNeeded += llen; /* Separating spaces and terminating nul */ + + /* + * Pass 2: generate the string repr. + */ + objPtr->bytes = (char *) Tcl_Alloc(bytesNeeded); + p = objPtr->bytes; + for (i = 0; i < llen; i++) { + Tcl_Obj *elemObj; + const char *elemStr; + Tcl_Size elemLen; + flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); + typePtr->indexProc(NULL, objPtr, i, &elemObj); + Tcl_IncrRefCount(elemObj); + elemStr = Tcl_GetStringFromObj(elemObj, &elemLen); + p += Tcl_ConvertCountedElement(elemStr, elemLen, p, flagPtr[i]); + *p++ = ' '; + Tcl_DecrRefCount(elemObj); + } + p[-1] = '\0'; /* Overwrite last space added */ + + /* Length of generated string */ + objPtr->length = p - 1 - objPtr->bytes; + + if (flagPtr != localFlags) { + Tcl_Free(flagPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * lLStringObjCmd -- + * + * Script level command that creats an lstring Obj value. + * + * Results: + * Returns and lstring Obj value in the interp results. + * + * Side effects: + * Interp results modified. + * + *---------------------------------------------------------------------- + */ + +static int +lLStringObjCmd( + void *clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj * const objv[]) +{ + Tcl_Obj *lstringObj; + + (void)clientData; + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; + } + + lstringObj = my_NewLStringObj(interp, objc-1, &objv[1]); + + if (lstringObj) { + Tcl_SetObjResult(interp, lstringObj); + return TCL_OK; + } + return TCL_ERROR; +} + +/* +** lgen - Derived from TIP 192 - Lazy Lists +** Generate a list using a command provided as argument(s). +** The command computes the value for a given index. +*/ + +/* + * Internal rep for the Generate Series + */ +typedef struct LgenSeries { + Tcl_Interp *interp; // used to evaluate gen script + Tcl_Size len; // list length + Tcl_Size nargs; // Number of arguments in genFn including "index" + Tcl_Obj *genFnObj; // The preformed command as a list. Index is set in + // the last element (last argument) +} LgenSeries; + +/* + * Evaluate the generation function. + * The provided funtion computes the value for a give index + */ +static Tcl_Obj* +lgen( + Tcl_Obj* objPtr, + Tcl_Size index) +{ + LgenSeries *lgenSeriesPtr = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *elemObj = NULL; + Tcl_Interp *intrp = lgenSeriesPtr->interp; + Tcl_Obj *genCmd = lgenSeriesPtr->genFnObj; + Tcl_Size endidx = lgenSeriesPtr->nargs-1; + + if (0 <= index && index < lgenSeriesPtr->len) { + Tcl_Obj *indexObj = Tcl_NewWideIntObj(index); + Tcl_ListObjReplace(intrp, genCmd, endidx, 1, 1, &indexObj); + // EVAL DIRECT to avoid interfering with bytecode compile which may be + // active on the stack + int flags = TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT; + int status = Tcl_EvalObjEx(intrp, genCmd, flags); + elemObj = Tcl_GetObjResult(intrp); + if (status != TCL_OK) { + Tcl_SetObjResult(intrp, Tcl_ObjPrintf( + "Error: %s\nwhile executing %s\n", + elemObj ? Tcl_GetString(elemObj) : "NULL", Tcl_GetString(genCmd))); + return NULL; + } + } + return elemObj; +} + +/* + * Abstract List Length function + */ +static Tcl_Size +lgenSeriesObjLength(Tcl_Obj *objPtr) +{ + LgenSeries *lgenSeriesRepPtr = (LgenSeries *)objPtr->internalRep.twoPtrValue.ptr1; + return lgenSeriesRepPtr->len; +} + +/* + * Abstract List Index function + */ +static int +lgenSeriesObjIndex( + Tcl_Interp *interp, + Tcl_Obj *lgenSeriesObjPtr, + Tcl_Size index, + Tcl_Obj **elemPtr) +{ + LgenSeries *lgenSeriesRepPtr; + Tcl_Obj *element; + + lgenSeriesRepPtr = (LgenSeries*)lgenSeriesObjPtr->internalRep.twoPtrValue.ptr1; + + if (index < 0 || index >= lgenSeriesRepPtr->len) { + *elemPtr = NULL; + return TCL_OK; + } + if (lgenSeriesRepPtr->interp == NULL && interp == NULL) { + return TCL_ERROR; + } + + lgenSeriesRepPtr->interp = interp; + + element = lgen(lgenSeriesObjPtr, index); + if (element) { + *elemPtr = element; + } else { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* +** UpdateStringRep +*/ + +static void +UpdateStringOfLgen(Tcl_Obj *objPtr) +{ + LgenSeries *lgenSeriesRepPtr; + Tcl_Obj *element; + Tcl_Size i; + size_t bytlen; + Tcl_Obj *tmpstr = Tcl_NewObj(); + + lgenSeriesRepPtr = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1; + + for (i=0, bytlen=0; i<lgenSeriesRepPtr->len; i++) { + element = lgen(objPtr, i); + if (element) { + if (i) { + Tcl_AppendToObj(tmpstr," ",1); + } + Tcl_AppendObjToObj(tmpstr,element); + } + } + + bytlen = Tcl_GetCharLength(tmpstr); + Tcl_InitStringRep(objPtr, Tcl_GetString(tmpstr), bytlen); + Tcl_DecrRefCount(tmpstr); + + return; +} + +/* + * ObjType Free Internal Rep function + */ +static void +FreeLgenInternalRep(Tcl_Obj *objPtr) +{ + LgenSeries *lgenSeries = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1; + if (lgenSeries->genFnObj) { + Tcl_DecrRefCount(lgenSeries->genFnObj); + } + lgenSeries->interp = NULL; + Tcl_Free(lgenSeries); + objPtr->internalRep.twoPtrValue.ptr1 = 0; +} + +static void DupLgenSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); + +/* + * Abstract List ObjType definition + */ + +static Tcl_ObjType lgenType = { + "lgenseries", + FreeLgenInternalRep, + DupLgenSeriesRep, + UpdateStringOfLgen, + NULL, /* SetFromAnyProc */ + TCL_OBJTYPE_V2( + lgenSeriesObjLength, + lgenSeriesObjIndex, + NULL, /* slice */ + NULL, /* reverse */ + NULL, /* get elements */ + NULL, /* set element */ + NULL, /* replace */ + NULL) /* "in" operator */ +}; + +/* + * ObjType Duplicate Internal Rep Function + */ +static void +DupLgenSeriesRep( + Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr) +{ + LgenSeries *srcLgenSeries = (LgenSeries*)srcPtr->internalRep.twoPtrValue.ptr1; + Tcl_Size repSize = sizeof(LgenSeries); + LgenSeries *copyLgenSeries = (LgenSeries*)Tcl_Alloc(repSize); + + copyLgenSeries->interp = srcLgenSeries->interp; + copyLgenSeries->nargs = srcLgenSeries->nargs; + copyLgenSeries->len = srcLgenSeries->len; + copyLgenSeries->genFnObj = Tcl_DuplicateObj(srcLgenSeries->genFnObj); + Tcl_IncrRefCount(copyLgenSeries->genFnObj); + copyPtr->typePtr = &lgenType; + copyPtr->internalRep.twoPtrValue.ptr1 = copyLgenSeries; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + return; +} + +/* + * Create a new lgen Tcl_Obj + */ +Tcl_Obj * +newLgenObj( + Tcl_Interp *interp, + int objc, + Tcl_Obj * const objv[]) +{ + Tcl_WideInt length; + LgenSeries *lGenSeriesRepPtr; + Tcl_Size repSize; + Tcl_Obj *lGenSeriesObj; + + if (objc < 2) { + return NULL; + } + + if (Tcl_GetWideIntFromObj(NULL, objv[0], &length) != TCL_OK + || length < 0) { + return NULL; + } + + lGenSeriesObj = Tcl_NewObj(); + repSize = sizeof(LgenSeries); + lGenSeriesRepPtr = (LgenSeries*)Tcl_Alloc(repSize); + lGenSeriesRepPtr->interp = interp; //Tcl_CreateInterp(); + lGenSeriesRepPtr->len = length; + + // Allocate array of *obj for cmd + index + args + // objv length cmd arg1 arg2 arg3 ... + // argsv 0 1 2 3 ... index + + lGenSeriesRepPtr->nargs = objc; + lGenSeriesRepPtr->genFnObj = Tcl_NewListObj(objc-1, objv+1); + // Addd 0 placeholder for index + Tcl_ListObjAppendElement(interp, lGenSeriesRepPtr->genFnObj, Tcl_NewIntObj(0)); + Tcl_IncrRefCount(lGenSeriesRepPtr->genFnObj); + lGenSeriesObj->internalRep.twoPtrValue.ptr1 = lGenSeriesRepPtr; + lGenSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; + lGenSeriesObj->typePtr = &lgenType; + + if (length > 0) { + Tcl_InvalidateStringRep(lGenSeriesObj); + } else { + Tcl_InitStringRep(lGenSeriesObj, NULL, 0); + } + return lGenSeriesObj; +} + +/* + * The [lgen] command + */ +static int +lGenObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj * const objv[]) +{ + Tcl_Obj *genObj = newLgenObj(interp, objc-1, &objv[1]); + if (genObj) { + Tcl_SetObjResult(interp, genObj); + return TCL_OK; + } + Tcl_WrongNumArgs(interp, 1, objv, "length cmd ?args?"); + return TCL_ERROR; +} + +/* + * lgen package init + */ +int Lgen_Init(Tcl_Interp *interp) { + if (Tcl_InitStubs(interp, "8.7", 0) == NULL) { + return TCL_ERROR; + } + Tcl_CreateObjCommand(interp, "lgen", lGenObjCmd, NULL, NULL); + Tcl_PkgProvide(interp, "lgen", "1.0"); + return TCL_OK; +} + + + +/* + *---------------------------------------------------------------------- + * + * ABSListTest_Init -- + * + * Provides Abstract List implemenations via new commands + * + * lstring command + * Usage: + * lstring /string/ + * + * Description: + * Creates a list where each character in the string is treated as an + * element. The string is kept as a string, not an actual list. Indexing + * is done by char. + * + * lgen command + * Usage: + * lgen /length/ /cmd/ ?args...? + * + * The /cmd/ should take the last argument as the index value, and return + * a value for that element. + * + * Results: + * The commands listed above are added to the interp. + * + * Side effects: + * New commands defined. + * + *---------------------------------------------------------------------- + */ + +int Tcl_ABSListTest_Init(Tcl_Interp *interp) { + if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) { + return TCL_ERROR; + } + Tcl_CreateObjCommand(interp, "lstring", lLStringObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "lgen", lGenObjCmd, NULL, NULL); + Tcl_PkgProvide(interp, "abstractlisttest", "1.0.0"); + return TCL_OK; +} diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 9f31cff..c94a0be 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -13,6 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ + #undef BUILD_tcl #ifndef USE_TCL_STUBS # define USE_TCL_STUBS @@ -25,14 +26,7 @@ #endif #include "tclStringRep.h" -#ifdef __GNUC__ -/* - * The rest of this file shouldn't warn about deprecated functions; they're - * there because we intend them to be so and know that this file is OK to - * touch those fields. - */ -#pragma GCC diagnostic ignored "-Wdeprecated-declarations" -#endif +#include <assert.h> /* * Forward declarations for functions defined later in this file: @@ -50,6 +44,7 @@ static Tcl_ObjCmdProc TestintobjCmd; static Tcl_ObjCmdProc TestlistobjCmd; static Tcl_ObjCmdProc TestobjCmd; static Tcl_ObjCmdProc TeststringobjCmd; +static Tcl_ObjCmdProc TestbigdataCmd; #define VARPTR_KEY "TCLOBJTEST_VARPTR" #define NUMBER_OF_OBJECT_VARS 20 @@ -61,7 +56,7 @@ static void VarPtrDeleteProc(void *clientData, TCL_UNUSED(Tcl_Interp *)) for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]); } - ckfree(varPtr); + Tcl_Free(varPtr); } static Tcl_Obj **GetVarPtr(Tcl_Interp *interp) @@ -101,7 +96,7 @@ TclObjTest_Init( */ Tcl_Obj **varPtr; - varPtr = (Tcl_Obj **)ckalloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0])); + varPtr = (Tcl_Obj **) Tcl_Alloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0])); if (!varPtr) { return TCL_ERROR; } @@ -125,6 +120,10 @@ TclObjTest_Init( Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd, NULL, NULL); + if (sizeof(Tcl_Size) == sizeof(Tcl_WideInt)) { + Tcl_CreateObjCommand(interp, "testbigdata", TestbigdataCmd, + NULL, NULL); + } return TCL_OK; } @@ -159,7 +158,7 @@ TestbignumobjCmd( enum options { BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN, BIGNUM_RADIXSIZE - }; + } idx; int index; Tcl_Size varIndex; const char *string; @@ -171,7 +170,7 @@ TestbignumobjCmd( return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, - &index) != TCL_OK) { + &idx) != TCL_OK) { return TCL_ERROR; } if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { @@ -179,7 +178,7 @@ TestbignumobjCmd( } varPtr = GetVarPtr(interp); - switch ((enum options)index) { + switch (idx) { case BIGNUM_SET: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "var value"); @@ -617,7 +616,7 @@ TestindexobjCmd( return TCL_ERROR; } - argv = (const char **)ckalloc((objc-3) * sizeof(char *)); + argv = (const char **)Tcl_Alloc((objc-3) * sizeof(char *)); for (i = 4; i < objc; i++) { argv[i-4] = Tcl_GetString(objv[i]); } @@ -626,7 +625,7 @@ TestindexobjCmd( result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], argv, "token", TCL_INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT), &index); - ckfree(argv); + Tcl_Free((void *)argv); if (result == TCL_OK) { Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index); } @@ -978,12 +977,13 @@ TestlistobjCmd( != TCL_OK) { return TCL_ERROR; } - if (objP->refCount <= 0) { + if (objP->refCount < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "Tcl_ListObjIndex returned object with ref count <= 0", + "Tcl_ListObjIndex returned object with ref count < 0", TCL_INDEX_NONE)); /* Keep looping since we are also looping for leaks */ } + Tcl_BounceRefCount(objP); } break; @@ -1051,6 +1051,33 @@ TestlistobjCmd( *---------------------------------------------------------------------- */ +static Tcl_Size V1TestListObjLength(TCL_UNUSED(Tcl_Obj *)) { + return 100; +} + +static int V1TestListObjIndex( + TCL_UNUSED(Tcl_Interp *), + TCL_UNUSED(Tcl_Obj *), + TCL_UNUSED(Tcl_Size), + Tcl_Obj **objPtr) +{ + *objPtr = Tcl_NewStringObj("This indexProc should never be accessed (bug: e58d7e19e9)", -1); + return TCL_OK; +} + +static const Tcl_ObjType v1TestListType = { + "testlist", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL, /* setFromAnyProc */ + offsetof(Tcl_ObjType, indexProc), /* This is a V1 objType, which doesn't have an indexProc */ + V1TestListObjLength, /* always return 100, doesn't really matter */ + V1TestListObjIndex, /* should never be accessed, because this objType = V1*/ + NULL, NULL, NULL, NULL, NULL, NULL +}; + + static int TestobjCmd( TCL_UNUSED(void *), @@ -1063,14 +1090,14 @@ TestobjCmd( const Tcl_ObjType *targetType; Tcl_Obj **varPtr; static const char *const subcommands[] = { - "freeallvars", "bug3598580", + "freeallvars", "bug3598580", "buge58d7e19e9", "types", "objtype", "newobj", "set", "assign", "convert", "duplicate", "invalidateStringRep", "refcount", "type", NULL }; enum testobjCmdIndex { - TESTOBJ_FREEALLVARS, TESTOBJ_BUG3598580, + TESTOBJ_FREEALLVARS, TESTOBJ_BUG3598580, TESTOBJ_BUGE58D7E19E9, TESTOBJ_TYPES, TESTOBJ_OBJTYPE, TESTOBJ_NEWOBJ, TESTOBJ_SET, TESTOBJ_ASSIGN, TESTOBJ_CONVERT, TESTOBJ_DUPLICATE, TESTOBJ_INVALIDATESTRINGREP, TESTOBJ_REFCOUNT, TESTOBJ_TYPE, @@ -1113,6 +1140,15 @@ TestobjCmd( Tcl_SetObjResult(interp, listObjPtr); } return TCL_OK; + case TESTOBJ_BUGE58D7E19E9: + if (objc != 3) { + goto wrongNumArgs; + } else { + Tcl_Obj *listObjPtr = Tcl_NewStringObj(Tcl_GetString(objv[2]), -1); + listObjPtr->typePtr = &v1TestListType; + Tcl_SetObjResult(interp, listObjPtr); + } + return TCL_OK; case TESTOBJ_TYPES: if (objc != 2) { goto wrongNumArgs; @@ -1279,7 +1315,7 @@ TeststringobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - unsigned short *unicode; + Tcl_UniChar *unicode; Tcl_Size size, varIndex; int option, i; Tcl_Size length; @@ -1382,25 +1418,21 @@ TeststringobjCmd( goto wrongNumArgs; } Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) - ? varPtr[varIndex]->length : -1); + ? (Tcl_WideInt)varPtr[varIndex]->length : (Tcl_WideInt)-1); break; case 5: /* length2 */ if (objc != 3) { goto wrongNumArgs; } if (varPtr[varIndex] != NULL) { - const Tcl_ObjType *objType = Tcl_GetObjType("string"); - if (objType != NULL) { - Tcl_ConvertToType(NULL, varPtr[varIndex], objType); - strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; - length = (int) strPtr->allocated; - } else { - length = TCL_INDEX_NONE; - } + Tcl_ConvertToType(NULL, varPtr[varIndex], + Tcl_GetObjType("string")); + strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; + length = strPtr->allocated; } else { length = TCL_INDEX_NONE; } - Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (Tcl_WideInt)((Tcl_WideUInt)(length + 1U)) - 1); break; case 6: /* set */ if (objc != 4) { @@ -1447,14 +1479,10 @@ TeststringobjCmd( goto wrongNumArgs; } if (varPtr[varIndex] != NULL) { - const Tcl_ObjType *objType = Tcl_GetObjType("string"); - if (objType != NULL) { - Tcl_ConvertToType(NULL, varPtr[varIndex],objType); - strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; - length = strPtr->maxChars; - } else { - length = TCL_INDEX_NONE; - } + Tcl_ConvertToType(NULL, varPtr[varIndex], + Tcl_GetObjType("string")); + strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; + length = strPtr->maxChars; } else { length = TCL_INDEX_NONE; } @@ -1535,21 +1563,21 @@ TeststringobjCmd( Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 13: /* newunicode*/ - unicode = (unsigned short *)ckalloc(((unsigned)objc - 3) * sizeof(unsigned short)); + unicode = (Tcl_UniChar *)Tcl_Alloc((objc - 3) * sizeof(Tcl_UniChar)); for (i = 0; i < (objc - 3); ++i) { int val; if (Tcl_GetIntFromObj(interp, objv[i + 3], &val) != TCL_OK) { break; } - unicode[i] = (unsigned short)val; + unicode[i] = (Tcl_UniChar)val; } if (i < (objc-3)) { - ckfree(unicode); + Tcl_Free(unicode); return TCL_ERROR; } SetVarToObj(varPtr, varIndex, Tcl_NewUnicodeObj(unicode, objc - 3)); Tcl_SetObjResult(interp, varPtr[varIndex]); - ckfree(unicode); + Tcl_Free(unicode); break; } @@ -1557,6 +1585,143 @@ TeststringobjCmd( } /* + *------------------------------------------------------------------------ + * + * TestbigdataCmd -- + * + * Implements the Tcl command testbigdata + * testbigdata string ?LEN? ?SPLIT? - returns 01234567890123... + * testbigdata bytearray ?LEN? ?SPLIT? - returns {0 1 2 3 4 5 6 7 8 9 0 1 ...} + * testbigdata dict ?SIZE? - returns dict mapping integers to themselves + * If no arguments given, returns the pattern used to generate strings. + * If SPLIT is specified, the character at that position is set to "X". + * + * Results: + * TCL_OK - Success. + * TCL_ERROR - Error. + * + * Side effects: + * Interpreter result holds result or error message. + * + *------------------------------------------------------------------------ + */ +static int +TestbigdataCmd ( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const subcmds[] = { + "string", "bytearray", "list", "dict", NULL + }; + enum options { + BIGDATA_STRING, BIGDATA_BYTEARRAY, BIGDATA_LIST, BIGDATA_DICT + } idx; + char *s; + unsigned char *p; + Tcl_Size i, len, split; + Tcl_DString ds; + Tcl_Obj *objPtr; +#define PATTERN_LEN 10 + Tcl_Obj *patternObjs[PATTERN_LEN]; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?len? ?split?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, + &idx) != TCL_OK) { + return TCL_ERROR; + } + split = -1; + if (objc == 2) { + len = PATTERN_LEN; + } else { + if (Tcl_GetSizeIntFromObj(interp, objv[2], &len) != TCL_OK) { + return TCL_ERROR; + } + if (objc == 4) { + if (Tcl_GetSizeIntFromObj(interp, objv[3], &split) != TCL_OK) { + return TCL_ERROR; + } + if (split >= len) { + split = len - 1; /* Last position */ + } + } + } + /* Need one byte for nul terminator */ + Tcl_Size limit = TCL_SIZE_MAX-1; + if (len < 0 || len > limit) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf( + "%s is greater than max permitted length %" TCL_SIZE_MODIFIER "d", + Tcl_GetString(objv[2]), + limit)); + return TCL_ERROR; + } + + switch (idx) { + case BIGDATA_STRING: + Tcl_DStringInit(&ds); + Tcl_DStringSetLength(&ds, len);/* Also stores \0 at index len+1 */ + s = Tcl_DStringValue(&ds); + for (i = 0; i < len; ++i) { + s[i] = '0' + (i % PATTERN_LEN); + } + if (split >= 0) { + assert(split < len); + s[split] = 'X'; + } + Tcl_DStringResult(interp, &ds); + break; + case BIGDATA_BYTEARRAY: + objPtr = Tcl_NewByteArrayObj(NULL, len); + p = Tcl_GetByteArrayFromObj(objPtr, &len); + for (i = 0; i < len; ++i) { + p[i] = '0' + (i % PATTERN_LEN); + } + if (split >= 0) { + assert(split < len); + p[split] = 'X'; + } + Tcl_SetObjResult(interp, objPtr); + break; + case BIGDATA_LIST: + for (i = 0; i < PATTERN_LEN; ++i) { + patternObjs[i] = Tcl_NewIntObj(i); + Tcl_IncrRefCount(patternObjs[i]); + } + objPtr = Tcl_NewListObj(len, NULL); + for (i = 0; i < len; ++i) { + Tcl_ListObjAppendElement( + interp, objPtr, patternObjs[i % PATTERN_LEN]); + } + if (split >= 0) { + assert(split < len); + Tcl_Obj *splitMarker = Tcl_NewStringObj("X", 1); + Tcl_ListObjReplace(interp, objPtr, split, 1, 1, &splitMarker); + } + for (i = 0; i < PATTERN_LEN; ++i) { + patternObjs[i] = Tcl_NewIntObj(i); + Tcl_DecrRefCount(patternObjs[i]); + } + Tcl_SetObjResult(interp, objPtr); + break; + case BIGDATA_DICT: + objPtr = Tcl_NewDictObj(); + for (i = 0; i < len; ++i) { + Tcl_Obj *objPtr2 = Tcl_NewWideIntObj(i); + Tcl_DictObjPut(interp, objPtr, objPtr2, objPtr2); + } + Tcl_SetObjResult(interp, objPtr); + break; + } + return TCL_OK; +} + +/* *---------------------------------------------------------------------- * * SetVarToObj -- diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 2139b81..7342af7 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -11,6 +11,8 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#undef BUILD_tcl +#undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif @@ -146,7 +148,7 @@ RegisterCommand( if (cmdTablePtr->exportIt) { snprintf(buf, sizeof(buf), "namespace eval %s { namespace export %s }", namesp, cmdTablePtr->cmdName); - if (Tcl_EvalEx(interp, buf, -1, 0) != TCL_OK) { + if (Tcl_EvalEx(interp, buf, TCL_INDEX_NONE, 0) != TCL_OK) { return TCL_ERROR; } } diff --git a/generic/tclThread.c b/generic/tclThread.c index de9fac9..b72de4a 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -61,7 +61,7 @@ static void RememberSyncObject(void *objPtr, void * Tcl_GetThreadData( Tcl_ThreadDataKey *keyPtr, /* Identifier for the data chunk */ - int size) /* Size of storage block */ + Tcl_Size size) /* Size of storage block */ { void *result; #if TCL_THREADS @@ -72,13 +72,13 @@ Tcl_GetThreadData( result = TclThreadStorageKeyGet(keyPtr); if (result == NULL) { - result = ckalloc(size); + result = Tcl_Alloc(size); memset(result, 0, size); TclThreadStorageKeySet(keyPtr, result); } #else /* TCL_THREADS */ if (*keyPtr == NULL) { - result = ckalloc(size); + result = Tcl_Alloc(size); memset(result, 0, size); *keyPtr = (Tcl_ThreadDataKey)result; RememberSyncObject(keyPtr, &keyRecord); @@ -164,14 +164,14 @@ RememberSyncObject( if (recPtr->num >= recPtr->max) { recPtr->max += 8; - newList = (void **)ckalloc(recPtr->max * sizeof(void *)); + newList = (void **)Tcl_Alloc(recPtr->max * sizeof(void *)); for (i=0,j=0 ; i<recPtr->num ; i++) { if (recPtr->list[i] != NULL) { newList[j++] = recPtr->list[i]; } } if (recPtr->list != NULL) { - ckfree(recPtr->list); + Tcl_Free(recPtr->list); } recPtr->list = newList; recPtr->num = j; @@ -394,9 +394,9 @@ TclFinalizeSynchronization(void) for (i=0 ; i<keyRecord.num ; i++) { keyPtr = (Tcl_ThreadDataKey *) keyRecord.list[i]; blockPtr = *keyPtr; - ckfree(blockPtr); + Tcl_Free(blockPtr); } - ckfree(keyRecord.list); + Tcl_Free(keyRecord.list); keyRecord.list = NULL; } keyRecord.max = 0; @@ -416,7 +416,7 @@ TclFinalizeSynchronization(void) } } if (mutexRecord.list != NULL) { - ckfree(mutexRecord.list); + Tcl_Free(mutexRecord.list); mutexRecord.list = NULL; } mutexRecord.max = 0; @@ -429,7 +429,7 @@ TclFinalizeSynchronization(void) } } if (condRecord.list != NULL) { - ckfree(condRecord.list); + Tcl_Free(condRecord.list); condRecord.list = NULL; } condRecord.max = 0; diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index df4d2e3..011d61b 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -210,7 +210,7 @@ GetCache(void) cachePtr = (Cache*)TclpGetAllocCache(); if (cachePtr == NULL) { - cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache), 0); + cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache)); if (cachePtr == NULL) { Tcl_Panic("alloc: could not allocate new cache"); } @@ -300,26 +300,13 @@ TclFreeAllocCache( void * TclpAlloc( - unsigned int reqSize) + size_t reqSize) { Cache *cachePtr; Block *blockPtr; int bucket; size_t size; -#ifndef __LP64__ - if (sizeof(int) >= sizeof(size_t)) { - /* An unsigned int overflow can also be a size_t overflow */ - const size_t zero = 0; - const size_t max = ~zero; - - if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) { - /* Requested allocation exceeds memory */ - return NULL; - } - } -#endif - GETCACHE(cachePtr); /* @@ -336,7 +323,7 @@ TclpAlloc( #endif if (size > MAXALLOC) { bucket = NBUCKETS; - blockPtr = (Block *)TclpSysAlloc(size, 0); + blockPtr = (Block *)TclpSysAlloc(size); if (blockPtr != NULL) { cachePtr->totalAssigned += reqSize; } @@ -437,7 +424,7 @@ TclpFree( void * TclpRealloc( void *ptr, - unsigned int reqSize) + size_t reqSize) { Cache *cachePtr; Block *blockPtr; @@ -449,19 +436,6 @@ TclpRealloc( return TclpAlloc(reqSize); } -#ifndef __LP64__ - if (sizeof(int) >= sizeof(size_t)) { - /* An unsigned int overflow can also be a size_t overflow */ - const size_t zero = 0; - const size_t max = ~zero; - - if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) { - /* Requested allocation exceeds memory */ - return NULL; - } - } -#endif - GETCACHE(cachePtr); /* @@ -562,7 +536,7 @@ TclThreadAllocObj(void) Tcl_Obj *newObjsPtr; cachePtr->numObjects = numMove = NOBJALLOC; - newObjsPtr = (Tcl_Obj *)TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0); + newObjsPtr = (Tcl_Obj *)TclpSysAlloc(sizeof(Tcl_Obj) * numMove); if (newObjsPtr == NULL) { Tcl_Panic("alloc: could not allocate %" TCL_Z_MODIFIER "u new objects", numMove); } @@ -1031,7 +1005,7 @@ GetBlocks( if (blockPtr == NULL) { size = MAXALLOC; - blockPtr = (Block*)TclpSysAlloc(size, 0); + blockPtr = (Block*)TclpSysAlloc(size); if (blockPtr == NULL) { return 0; } diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c index af4bc13..2af66e3 100644 --- a/generic/tclThreadJoin.c +++ b/generic/tclThreadJoin.c @@ -201,7 +201,7 @@ TclJoinThread( Tcl_ConditionFinalize(&threadPtr->cond); Tcl_MutexFinalize(&threadPtr->threadMutex); - ckfree(threadPtr); + Tcl_Free(threadPtr); return TCL_OK; } @@ -230,7 +230,7 @@ TclRememberJoinableThread( { JoinableThread *threadPtr; - threadPtr = (JoinableThread *)ckalloc(sizeof(JoinableThread)); + threadPtr = (JoinableThread *)Tcl_Alloc(sizeof(JoinableThread)); threadPtr->id = id; threadPtr->done = 0; threadPtr->waitedUpon = 0; diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index b2de9b4..22dd0c3 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -48,7 +48,7 @@ static struct { */ typedef struct { - ClientData *tablePtr; /* The table of Tcl TSDs. */ + void **tablePtr; /* The table of Tcl TSDs. */ sig_atomic_t allocated; /* The size of the table in the current * thread. */ } TSDTable; @@ -85,14 +85,14 @@ TSDTableCreate(void) TSDTable *tsdTablePtr; sig_atomic_t i; - tsdTablePtr = (TSDTable *)TclpSysAlloc(sizeof(TSDTable), 0); + tsdTablePtr = (TSDTable *)TclpSysAlloc(sizeof(TSDTable)); if (tsdTablePtr == NULL) { Tcl_Panic("unable to allocate TSDTable"); } tsdTablePtr->allocated = 8; tsdTablePtr->tablePtr = - (void **)TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated, 0); + (void **)TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated); if (tsdTablePtr->tablePtr == NULL) { Tcl_Panic("unable to allocate TSDTable"); } @@ -117,7 +117,7 @@ TSDTableDelete( * and must now be deallocated or they will leak. */ - ckfree(tsdTablePtr->tablePtr[i]); + Tcl_Free(tsdTablePtr->tablePtr[i]); } } @@ -190,7 +190,7 @@ TclThreadStorageKeyGet( Tcl_ThreadDataKey *dataKeyPtr) { TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key); - ClientData resultPtr = NULL; + void *resultPtr = NULL; TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr; sig_atomic_t offset = keyPtr->offset; diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index cd74071..b10465d 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -13,6 +13,8 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#undef BUILD_tcl +#undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif @@ -209,7 +211,6 @@ ThreadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - int option; static const char *const threadOptions[] = { "cancel", "create", "event", "exit", "id", "join", "names", "send", "wait", "errorproc", @@ -219,7 +220,7 @@ ThreadObjCmd( THREAD_CANCEL, THREAD_CREATE, THREAD_EVENT, THREAD_EXIT, THREAD_ID, THREAD_JOIN, THREAD_NAMES, THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC - }; + } option; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -242,7 +243,7 @@ ThreadObjCmd( Tcl_MutexUnlock(&threadMutex); } - switch ((enum options)option) { + switch (option) { case THREAD_CANCEL: { Tcl_WideInt id; const char *result; @@ -430,10 +431,10 @@ ThreadObjCmd( Tcl_MutexLock(&threadMutex); errorThreadId = Tcl_GetCurrentThread(); if (errorProcString) { - ckfree(errorProcString); + Tcl_Free(errorProcString); } proc = Tcl_GetString(objv[2]); - errorProcString = (char *)ckalloc(strlen(proc) + 1); + errorProcString = (char *)Tcl_Alloc(strlen(proc) + 1); strcpy(errorProcString, proc); Tcl_MutexUnlock(&threadMutex); return TCL_OK; @@ -592,7 +593,7 @@ NewTestThread( * eval'ing, for the case that we exit during evaluation */ - threadEvalScript = (char *)ckalloc(strlen(ctrlPtr->script) + 1); + threadEvalScript = (char *)Tcl_Alloc(strlen(ctrlPtr->script) + 1); strcpy(threadEvalScript, ctrlPtr->script); Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript); @@ -667,7 +668,7 @@ ThreadErrorProc( argv[2] = errorInfo; script = Tcl_Merge(3, argv); ThreadSend(interp, errorThreadId, script, 0); - ckfree(script); + Tcl_Free(script); } } @@ -837,13 +838,13 @@ ThreadSend( * Create the event for its event queue. */ - threadEventPtr = (ThreadEvent*)ckalloc(sizeof(ThreadEvent)); - threadEventPtr->script = (char *)ckalloc(strlen(script) + 1); + threadEventPtr = (ThreadEvent*)Tcl_Alloc(sizeof(ThreadEvent)); + threadEventPtr->script = (char *)Tcl_Alloc(strlen(script) + 1); strcpy(threadEventPtr->script, script); if (!wait) { resultPtr = threadEventPtr->resultPtr = NULL; } else { - resultPtr = (ThreadEventResult *)ckalloc(sizeof(ThreadEventResult)); + resultPtr = (ThreadEventResult *)Tcl_Alloc(sizeof(ThreadEventResult)); threadEventPtr->resultPtr = resultPtr; /* @@ -914,19 +915,19 @@ ThreadSend( if (resultPtr->code != TCL_OK) { if (resultPtr->errorCode) { Tcl_SetErrorCode(interp, resultPtr->errorCode, (void *)NULL); - ckfree(resultPtr->errorCode); + Tcl_Free(resultPtr->errorCode); } if (resultPtr->errorInfo) { Tcl_AddErrorInfo(interp, resultPtr->errorInfo); - ckfree(resultPtr->errorInfo); + Tcl_Free(resultPtr->errorInfo); } } Tcl_AppendResult(interp, resultPtr->result, (void *)NULL); Tcl_ConditionFinalize(&resultPtr->done); code = resultPtr->code; - ckfree(resultPtr->result); - ckfree(resultPtr); + Tcl_Free(resultPtr->result); + Tcl_Free(resultPtr); return code; } @@ -1034,18 +1035,18 @@ ThreadEventProc( } result = Tcl_GetStringResult(interp); } - ckfree(threadEventPtr->script); + Tcl_Free(threadEventPtr->script); if (resultPtr) { Tcl_MutexLock(&threadMutex); resultPtr->code = code; - resultPtr->result = (char *)ckalloc(strlen(result) + 1); + resultPtr->result = (char *)Tcl_Alloc(strlen(result) + 1); strcpy(resultPtr->result, result); if (errorCode != NULL) { - resultPtr->errorCode = (char *)ckalloc(strlen(errorCode) + 1); + resultPtr->errorCode = (char *)Tcl_Alloc(strlen(errorCode) + 1); strcpy(resultPtr->errorCode, errorCode); } if (errorInfo != NULL) { - resultPtr->errorInfo = (char *)ckalloc(strlen(errorInfo) + 1); + resultPtr->errorInfo = (char *)Tcl_Alloc(strlen(errorInfo) + 1); strcpy(resultPtr->errorInfo, errorInfo); } Tcl_ConditionNotify(&resultPtr->done); @@ -1079,7 +1080,7 @@ ThreadFreeProc( void *clientData) { if (clientData) { - ckfree(clientData); + Tcl_Free(clientData); } } @@ -1106,7 +1107,7 @@ ThreadDeleteEvent( TCL_UNUSED(void *)) { if (eventPtr->proc == ThreadEventProc) { - ckfree(((ThreadEvent *) eventPtr)->script); + Tcl_Free(((ThreadEvent *) eventPtr)->script); return 1; } @@ -1152,14 +1153,14 @@ ThreadExitProc( if (self == errorThreadId) { if (errorProcString) { /* Extra safety */ - ckfree(errorProcString); + Tcl_Free(errorProcString); errorProcString = NULL; } errorThreadId = 0; } if (threadEvalScript) { - ckfree(threadEvalScript); + Tcl_Free(threadEvalScript); threadEvalScript = NULL; } Tcl_DeleteEvents((Tcl_EventDeleteProc *) ThreadDeleteEvent, NULL); @@ -1182,7 +1183,7 @@ ThreadExitProc( } resultPtr->nextPtr = resultPtr->prevPtr = 0; resultPtr->eventPtr->resultPtr = NULL; - ckfree(resultPtr); + Tcl_Free(resultPtr); } else if (resultPtr->dstThreadId == self) { /* * Dang. The target is going away. Unblock the caller. The result @@ -1192,7 +1193,7 @@ ThreadExitProc( const char *msg = "target thread died"; - resultPtr->result = (char *)ckalloc(strlen(msg) + 1); + resultPtr->result = (char *)Tcl_Alloc(strlen(msg) + 1); strcpy(resultPtr->result, msg); resultPtr->code = TCL_ERROR; Tcl_ConditionNotify(&resultPtr->done); diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 954e38f..c1d4d7d 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -21,7 +21,7 @@ typedef struct TimerHandler { Tcl_Time time; /* When timer is to fire. */ Tcl_TimerProc *proc; /* Function to call. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ Tcl_TimerToken token; /* Identifies handler so it can be deleted. */ struct TimerHandler *nextPtr; /* Next event in queue, or NULL for end of @@ -73,7 +73,7 @@ typedef struct AfterAssocData { typedef struct IdleHandler { Tcl_IdleProc *proc; /* Function to call. */ - ClientData clientData; /* Value to pass to proc. */ + void *clientData; /* Value to pass to proc. */ int generation; /* Used to distinguish older handlers from * recently-created ones. */ struct IdleHandler *nextPtr;/* Next in list of active handlers. */ @@ -117,7 +117,7 @@ static Tcl_ThreadDataKey dataKey; * side-effect free. The "prototypes" for these macros are: * * static int TCL_TIME_BEFORE(Tcl_Time t1, Tcl_Time t2); - * static long TCL_TIME_DIFF_MS(Tcl_Time t1, Tcl_Time t2); + * static Tcl_WideInt TCL_TIME_DIFF_MS(Tcl_Time t1, Tcl_Time t2); */ #define TCL_TIME_BEFORE(t1, t2) \ @@ -125,11 +125,11 @@ static Tcl_ThreadDataKey dataKey; #define TCL_TIME_DIFF_MS(t1, t2) \ (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \ - ((long)(t1).usec - (long)(t2).usec)/1000) + ((t1).usec - (t2).usec)/1000) #define TCL_TIME_DIFF_MS_CEILING(t1, t2) \ (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \ - ((long)(t1).usec - (long)(t2).usec + 999)/1000) + ((t1).usec - (t2).usec + 999)/1000) /* * Sleeps under that number of milliseconds don't get double-checked @@ -150,18 +150,18 @@ static Tcl_ThreadDataKey dataKey; * Prototypes for functions referenced only in this file: */ -static void AfterCleanupProc(ClientData clientData, +static void AfterCleanupProc(void *clientData, Tcl_Interp *interp); static int AfterDelay(Tcl_Interp *interp, Tcl_WideInt ms); -static void AfterProc(ClientData clientData); +static void AfterProc(void *clientData); static void FreeAfterPtr(AfterInfo *afterPtr); static AfterInfo * GetAfterEvent(AfterAssocData *assocPtr, Tcl_Obj *commandPtr); static ThreadSpecificData *InitTimer(void); -static void TimerExitProc(ClientData clientData); +static void TimerExitProc(void *clientData); static int TimerHandlerEventProc(Tcl_Event *evPtr, int flags); -static void TimerCheckProc(ClientData clientData, int flags); -static void TimerSetupProc(ClientData clientData, int flags); +static void TimerCheckProc(void *clientData, int flags); +static void TimerSetupProc(void *clientData, int flags); /* *---------------------------------------------------------------------- @@ -211,7 +211,7 @@ InitTimer(void) static void TimerExitProc( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); @@ -222,7 +222,7 @@ TimerExitProc( timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; while (timerHandlerPtr != NULL) { tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; - ckfree(timerHandlerPtr); + Tcl_Free(timerHandlerPtr); timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; } } @@ -251,7 +251,7 @@ Tcl_CreateTimerHandler( int milliseconds, /* How many milliseconds to wait before * invoking proc. */ Tcl_TimerProc *proc, /* Function to invoke. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { Tcl_Time time; @@ -292,12 +292,12 @@ Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, - ClientData clientData) + void *clientData) { TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; ThreadSpecificData *tsdPtr = InitTimer(); - timerHandlerPtr = (TimerHandler *)ckalloc(sizeof(TimerHandler)); + timerHandlerPtr = (TimerHandler *)Tcl_Alloc(sizeof(TimerHandler)); /* * Fill in fields for the event. @@ -373,7 +373,7 @@ Tcl_DeleteTimerHandler( } else { prevPtr->nextPtr = timerHandlerPtr->nextPtr; } - ckfree(timerHandlerPtr); + Tcl_Free(timerHandlerPtr); return; } } @@ -398,7 +398,7 @@ Tcl_DeleteTimerHandler( static void TimerSetupProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { Tcl_Time blockTime; @@ -456,7 +456,7 @@ TimerSetupProc( static void TimerCheckProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { Tcl_Event *timerEvPtr; @@ -488,7 +488,7 @@ TimerCheckProc( if (blockTime.sec == 0 && blockTime.usec == 0 && !tsdPtr->timerPending) { tsdPtr->timerPending = 1; - timerEvPtr = (Tcl_Event *)ckalloc(sizeof(Tcl_Event)); + timerEvPtr = (Tcl_Event *)Tcl_Alloc(sizeof(Tcl_Event)); timerEvPtr->proc = TimerHandlerEventProc; Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL); } @@ -591,7 +591,7 @@ TimerHandlerEventProc( *nextPtrPtr = timerHandlerPtr->nextPtr; timerHandlerPtr->proc(timerHandlerPtr->clientData); - ckfree(timerHandlerPtr); + Tcl_Free(timerHandlerPtr); } TimerSetupProc(NULL, TCL_TIMER_EVENTS); return 1; @@ -619,13 +619,13 @@ TimerHandlerEventProc( void Tcl_DoWhenIdle( Tcl_IdleProc *proc, /* Function to invoke. */ - ClientData clientData) /* Arbitrary value to pass to proc. */ + void *clientData) /* Arbitrary value to pass to proc. */ { IdleHandler *idlePtr; Tcl_Time blockTime; ThreadSpecificData *tsdPtr = InitTimer(); - idlePtr = (IdleHandler *)ckalloc(sizeof(IdleHandler)); + idlePtr = (IdleHandler *)Tcl_Alloc(sizeof(IdleHandler)); idlePtr->proc = proc; idlePtr->clientData = clientData; idlePtr->generation = tsdPtr->idleGeneration; @@ -663,7 +663,7 @@ Tcl_DoWhenIdle( void Tcl_CancelIdleCall( Tcl_IdleProc *proc, /* Function that was previously registered. */ - ClientData clientData) /* Arbitrary value to pass to proc. */ + void *clientData) /* Arbitrary value to pass to proc. */ { IdleHandler *idlePtr, *prevPtr; IdleHandler *nextPtr; @@ -674,7 +674,7 @@ Tcl_CancelIdleCall( while ((idlePtr->proc == proc) && (idlePtr->clientData == clientData)) { nextPtr = idlePtr->nextPtr; - ckfree(idlePtr); + Tcl_Free(idlePtr); idlePtr = nextPtr; if (prevPtr == NULL) { tsdPtr->idleList = idlePtr; @@ -749,7 +749,7 @@ TclServiceIdle(void) tsdPtr->lastIdlePtr = NULL; } idlePtr->proc(idlePtr->clientData); - ckfree(idlePtr); + Tcl_Free(idlePtr); } if (tsdPtr->idleList) { blockTime.sec = 0; @@ -778,7 +778,7 @@ TclServiceIdle(void) int Tcl_AfterObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -787,7 +787,7 @@ Tcl_AfterObjCmd( Tcl_Time wakeup; AfterInfo *afterPtr; AfterAssocData *assocPtr; - int length; + Tcl_Size length; int index = -1; static const char *const afterSubCmds[] = { "cancel", "idle", "info", NULL @@ -807,7 +807,7 @@ Tcl_AfterObjCmd( assocPtr = (AfterAssocData *)Tcl_GetAssocData(interp, "tclAfter", NULL); if (assocPtr == NULL) { - assocPtr = (AfterAssocData *)ckalloc(sizeof(AfterAssocData)); + assocPtr = (AfterAssocData *)Tcl_Alloc(sizeof(AfterAssocData)); assocPtr->interp = interp; assocPtr->firstAfterPtr = NULL; Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr); @@ -817,10 +817,10 @@ Tcl_AfterObjCmd( * First lets see if the command was passed a number as the first argument. */ - if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { + if (TclGetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) != TCL_OK) { - const char *arg = Tcl_GetString(objv[1]); + const char *arg = TclGetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument \"%s\": must be" @@ -844,7 +844,7 @@ Tcl_AfterObjCmd( if (objc == 2) { return AfterDelay(interp, ms); } - afterPtr = (AfterInfo *)ckalloc(sizeof(AfterInfo)); + afterPtr = (AfterInfo *)Tcl_Alloc(sizeof(AfterInfo)); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; @@ -866,8 +866,8 @@ Tcl_AfterObjCmd( afterPtr->id = tsdPtr->afterId; tsdPtr->afterId += 1; Tcl_GetTime(&wakeup); - wakeup.sec += (long)(ms / 1000); - wakeup.usec += ((long)(ms % 1000)) * 1000; + wakeup.sec += ms / 1000; + wakeup.usec += ms % 1000 * 1000; if (wakeup.usec > 1000000) { wakeup.sec++; wakeup.usec -= 1000000; @@ -882,7 +882,7 @@ Tcl_AfterObjCmd( case AFTER_CANCEL: { Tcl_Obj *commandPtr; const char *command, *tempCommand; - int tempLength; + Tcl_Size tempLength; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "id|command"); @@ -893,10 +893,10 @@ Tcl_AfterObjCmd( } else { commandPtr = Tcl_ConcatObj(objc-2, objv+2); } - command = TclGetStringFromObj(commandPtr, &length); + command = Tcl_GetStringFromObj(commandPtr, &length); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { - tempCommand = TclGetStringFromObj(afterPtr->commandPtr, + tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, &tempLength); if ((length == tempLength) && !memcmp(command, tempCommand, length)) { @@ -924,7 +924,7 @@ Tcl_AfterObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?"); return TCL_ERROR; } - afterPtr = (AfterInfo *)ckalloc(sizeof(AfterInfo)); + afterPtr = (AfterInfo *)Tcl_Alloc(sizeof(AfterInfo)); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; @@ -1014,8 +1014,8 @@ AfterDelay( Tcl_GetTime(&now); endTime = now; - endTime.sec += (long)(ms / 1000); - endTime.usec += ((int)(ms % 1000)) * 1000; + endTime.sec += (ms / 1000); + endTime.usec += (ms % 1000) * 1000; if (endTime.usec >= 1000000) { endTime.sec++; endTime.usec -= 1000000; @@ -1047,7 +1047,7 @@ AfterDelay( diff = 1; } if (diff > 0) { - Tcl_Sleep((long) diff); + Tcl_Sleep((int) diff); if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { break; } @@ -1149,7 +1149,7 @@ GetAfterEvent( static void AfterProc( - ClientData clientData) /* Describes command to execute. */ + void *clientData) /* Describes command to execute. */ { AfterInfo *afterPtr = (AfterInfo *)clientData; AfterAssocData *assocPtr = afterPtr->assocPtr; @@ -1191,7 +1191,7 @@ AfterProc( */ Tcl_DecrRefCount(afterPtr->commandPtr); - ckfree(afterPtr); + Tcl_Free(afterPtr); } /* @@ -1229,7 +1229,7 @@ FreeAfterPtr( prevPtr->nextPtr = afterPtr->nextPtr; } Tcl_DecrRefCount(afterPtr->commandPtr); - ckfree(afterPtr); + Tcl_Free(afterPtr); } /* @@ -1251,7 +1251,7 @@ FreeAfterPtr( static void AfterCleanupProc( - ClientData clientData, /* Points to AfterAssocData for the + void *clientData, /* Points to AfterAssocData for the * interpreter. */ TCL_UNUSED(Tcl_Interp *)) { @@ -1267,9 +1267,9 @@ AfterCleanupProc( Tcl_CancelIdleCall(AfterProc, afterPtr); } Tcl_DecrRefCount(afterPtr->commandPtr); - ckfree(afterPtr); + Tcl_Free(afterPtr); } - ckfree(assocPtr); + Tcl_Free(assocPtr); } /* diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 27c4f98..da3f95d 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -32,7 +32,7 @@ declare 2 { mp_err MP_WUR TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c) } declare 3 { - mp_err MP_WUR TclBN_mp_add_d(const mp_int *a, unsigned int b, mp_int *c) + mp_err MP_WUR TclBN_mp_add_d(const mp_int *a, mp_digit b, mp_int *c) } declare 4 { mp_err MP_WUR TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c) @@ -50,7 +50,7 @@ declare 8 { mp_ord MP_WUR TclBN_mp_cmp(const mp_int *a, const mp_int *b) } declare 9 { - mp_ord MP_WUR TclBN_mp_cmp_d(const mp_int *a, unsigned int b) + mp_ord MP_WUR TclBN_mp_cmp_d(const mp_int *a, mp_digit b) } declare 10 { mp_ord MP_WUR TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b) @@ -65,7 +65,7 @@ declare 13 { mp_err MP_WUR TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) } declare 14 { - mp_err MP_WUR TclBN_mp_div_d(const mp_int *a, unsigned int b, mp_int *q, unsigned int *r) + mp_err MP_WUR TclBN_mp_div_d(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) } declare 15 { mp_err MP_WUR TclBN_mp_div_2(const mp_int *a, mp_int *q) @@ -73,14 +73,15 @@ declare 15 { declare 16 { mp_err MP_WUR TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r) } -declare 17 {deprecated {is private function in libtommath}} { - mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, unsigned int *r) -} +# Removed in 9.0 +#declare 17 { +# mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r) +#} declare 18 { void TclBN_mp_exch(mp_int *a, mp_int *b) } declare 19 { - mp_err MP_WUR TclBN_mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) + mp_err MP_WUR TclBN_mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c) } declare 20 { mp_err MP_WUR TclBN_mp_grow(mp_int *a, int size) @@ -95,7 +96,7 @@ declare 23 { mp_err MP_WUR TclBN_mp_init_multi(mp_int *a, ...) } declare 24 { - mp_err MP_WUR TclBN_mp_init_set(mp_int *a, unsigned int b) + mp_err MP_WUR TclBN_mp_init_set(mp_int *a, mp_digit b) } declare 25 { mp_err MP_WUR TclBN_mp_init_size(mp_int *a, int size) @@ -113,7 +114,7 @@ declare 29 { mp_err MP_WUR TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p) } declare 30 { - mp_err MP_WUR TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *p) + mp_err MP_WUR TclBN_mp_mul_d(const mp_int *a, mp_digit b, mp_int *p) } declare 31 { mp_err MP_WUR TclBN_mp_mul_2(const mp_int *a, mp_int *p) @@ -139,12 +140,14 @@ declare 37 { declare 38 { mp_err MP_WUR TclBN_mp_shrink(mp_int *a) } -declare 39 {deprecated {macro calling mp_set_u64}} { - void TclBN_mp_set(mp_int *a, unsigned int b) -} -declare 40 {nostub {is private function in libtommath}} { - mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b) -} +# Removed in 9.0 +#declare 39 { +# void TclBN_mp_set(mp_int *a, unsigned int b) +#} +# Removed in 9.0 +#declare 40 {nostub {is private function in libtommath}} { +# mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b) +#} declare 41 { mp_err MP_WUR TclBN_mp_sqrt(const mp_int *a, mp_int *b) } @@ -152,20 +155,23 @@ declare 42 { mp_err MP_WUR TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) } declare 43 { - mp_err MP_WUR TclBN_mp_sub_d(const mp_int *a, unsigned int b, mp_int *c) -} -declare 44 {deprecated {Use mp_to_ubin}} { - mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b) -} -declare 45 {deprecated {Use mp_to_ubin}} { - mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, - unsigned long *outlen) -} -declare 46 {deprecated {Use mp_to_radix}} { - mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) -} + mp_err MP_WUR TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) +} +# Removed in 9.0 +#declare 44 { +# mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b) +#} +# Removed in 9.0 +#declare 45 { +# mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, +# unsigned long *outlen) +#} +# Removed in 9.0 +#declare 46 { +# mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) +#} declare 47 { - size_t TclBN_mp_ubin_size(const mp_int *a) + size_t MP_WUR TclBN_mp_ubin_size(const mp_int *a) } declare 48 { mp_err MP_WUR TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c) @@ -173,55 +179,21 @@ declare 48 { declare 49 { void TclBN_mp_zero(mp_int *a) } - -# internal routines to libtommath - should not be called but must be -# exported to accommodate the "tommath" extension - -declare 50 {deprecated {is private function in libtommath}} { - void TclBN_reverse(unsigned char *s, int len) -} -declare 51 {deprecated {is private function in libtommath}} { - mp_err TclBN_s_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs) -} -declare 52 {deprecated {is private function in libtommath}} { - mp_err TclBN_s_mp_sqr_fast(const mp_int *a, mp_int *b) -} -declare 53 {deprecated {is private function in libtommath}} { - mp_err TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) -} -declare 54 {deprecated {is private function in libtommath}} { - mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b) -} -declare 55 {deprecated {is private function in libtommath}} { - mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) -} -declare 56 {deprecated {is private function in libtommath}} { - mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b) -} -declare 57 {deprecated {is private function in libtommath}} { - mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) -} -declare 58 {deprecated {is private function in libtommath}} { - mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) -} -declare 59 {deprecated {is private function in libtommath}} { - mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b) -} -declare 60 {deprecated {is private function in libtommath}} { - mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) -} -declare 61 {deprecated {macro calling mp_init_u64}} { - mp_err TclBN_mp_init_ul(mp_int *a, unsigned long i) -} -declare 62 {deprecated {macro calling mp_set_u64}} { - void TclBN_mp_set_ul(mp_int *a, unsigned long i) -} +# Removed in 9.0 +#declare 61 { +# mp_err TclBN_mp_init_ul(mp_int *a, unsigned long i) +#} +# Removed in 9.0 +#declare 62 { +# void TclBN_mp_set_ul(mp_int *a, unsigned long i) +#} declare 63 { int MP_WUR TclBN_mp_cnt_lsb(const mp_int *a) } -declare 64 {deprecated {macro calling mp_init_i64}} { - int TclBN_mp_init_l(mp_int *bignum, long initVal) -} +# Removed in 9.0 +#declare 64 { +# int TclBN_mp_init_l(mp_int *bignum, long initVal) +#} declare 65 { int MP_WUR TclBN_mp_init_i64(mp_int *bignum, int64_t initVal) } @@ -229,10 +201,10 @@ declare 66 { int MP_WUR TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal) } -# Added in libtommath 1.0 -declare 67 {deprecated {Use mp_expt_u32}} { - mp_err TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c, int fast) -} +# Removed in 9.0 +#declare 67 { +# mp_err TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) +#} # Added in libtommath 1.0.1 declare 68 { void TclBN_mp_set_u64(mp_int *a, uint64_t i) @@ -253,15 +225,18 @@ declare 72 { } # Added in libtommath 1.1.0 -declare 73 {deprecated {merged with mp_and}} { - mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) -} -declare 74 {deprecated {merged with mp_or}} { - mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) -} -declare 75 {deprecated {merged with mp_xor}} { - mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) -} +# No longer in use: replaced by mp_and() +#declare 73 { +# int TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) +#} +# No longer in use: replaced by mp_or() +#declare 74 { +# int TclBN_mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) +#} +# No longer in use: replaced by mp_xor() +#declare 75 { +# int TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) +#} declare 76 { mp_err MP_WUR TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c) } @@ -273,9 +248,10 @@ declare 77 { declare 78 { int MP_WUR TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) } -declare 79 { - mp_err MP_WUR TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *q, uint64_t *r) -} +# Removed in 9.0 +#declare 79 { +# mp_err MP_WUR TclBN_mp_div_ld(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) +#} declare 80 { int MP_WUR TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) } diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index b4ab607..35eb9f8 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -35,13 +35,13 @@ /* Define custom memory allocation for libtommath */ /* MODULE_SCOPE void* TclBNAlloc( size_t ); */ -#define TclBNAlloc(s) ((void*)attemptckalloc((size_t)(s))) +#define TclBNAlloc(s) Tcl_AttemptAlloc((size_t)(s)) /* MODULE_SCOPE void* TclBNCalloc( size_t, size_t ); */ -#define TclBNCalloc(m,s) memset(attemptckalloc((size_t)(m)*(size_t)(s)),0,(size_t)(m)*(size_t)(s)) +#define TclBNCalloc(m,s) memset(Tcl_AttemptAlloc((size_t)(m)*(size_t)(s)),0,(size_t)(m)*(size_t)(s)) /* MODULE_SCOPE void* TclBNRealloc( void*, size_t ); */ -#define TclBNRealloc(x,s) ((void*)attemptckrealloc((char*)(x),(size_t)(s))) +#define TclBNRealloc(x,s) Tcl_AttemptRealloc((x),(size_t)(s)) /* MODULE_SCOPE void TclBNFree( void* ); */ -#define TclBNFree(x) (ckfree((char*)(x))) +#define TclBNFree(x) Tcl_Free(x) #undef MP_MALLOC #undef MP_CALLOC @@ -63,17 +63,20 @@ #ifdef __cplusplus extern "C" { #endif -MODULE_SCOPE mp_err TclBN_s_mp_add_d(const mp_int *a, mp_digit b, mp_int *c); -MODULE_SCOPE mp_ord TclBN_s_mp_cmp_d(const mp_int *a, mp_digit b); -MODULE_SCOPE mp_err TclBN_s_mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d); -MODULE_SCOPE mp_err TclBN_s_mp_div_3(const mp_int *a, mp_int *c, mp_digit *b); -MODULE_SCOPE mp_err TclBN_s_mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c); -MODULE_SCOPE mp_err TclBN_s_mp_init_set(mp_int *a, mp_digit b); -MODULE_SCOPE mp_err TclBN_s_mp_mul_d(const mp_int *a, mp_digit b, mp_int *c); -MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len); -MODULE_SCOPE void TclBN_s_mp_set(mp_int *a, mp_digit b); -MODULE_SCOPE mp_err TclBN_s_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c); -MODULE_SCOPE mp_err TclBN_s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c); +MODULE_SCOPE mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b); +MODULE_SCOPE mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r); +MODULE_SCOPE mp_err TclBN_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c); +MODULE_SCOPE mp_err TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c); +MODULE_SCOPE mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b); +MODULE_SCOPE mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c); +MODULE_SCOPE mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b); +MODULE_SCOPE mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c); +MODULE_SCOPE mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs); +MODULE_SCOPE mp_err TclBN_s_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs); +MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len); +MODULE_SCOPE mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b); +MODULE_SCOPE mp_err TclBN_s_mp_sqr_fast(const mp_int *a, mp_int *b); +MODULE_SCOPE mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c); MODULE_SCOPE const char *const TclBN_mp_s_rmap; MODULE_SCOPE const uint8_t TclBN_mp_s_rmap_reverse[]; MODULE_SCOPE const size_t TclBN_mp_s_rmap_reverse_sz; @@ -87,40 +90,40 @@ MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #ifndef TCL_WITH_EXTERNAL_TOMMATH #define bn_reverse TclBN_reverse #define mp_add TclBN_mp_add -#define mp_add_d TclBN_s_mp_add_d +#define mp_add_d TclBN_mp_add_d #define mp_and TclBN_mp_and #define mp_clamp TclBN_mp_clamp #define mp_clear TclBN_mp_clear #define mp_clear_multi TclBN_mp_clear_multi #define mp_cmp TclBN_mp_cmp -#define mp_cmp_d TclBN_s_mp_cmp_d +#define mp_cmp_d TclBN_mp_cmp_d #define mp_cmp_mag TclBN_mp_cmp_mag #define mp_cnt_lsb TclBN_mp_cnt_lsb #define mp_copy TclBN_mp_copy #define mp_count_bits TclBN_mp_count_bits #define mp_div TclBN_mp_div -#define mp_div_d TclBN_s_mp_div_d +#define mp_div_d TclBN_mp_div_d #define mp_div_2 TclBN_mp_div_2 -#define mp_div_3 TclBN_s_mp_div_3 +#define mp_div_3 TclBN_mp_div_3 #define mp_div_2d TclBN_mp_div_2d #define mp_exch TclBN_mp_exch #define mp_expt_d TclBN_mp_expt_d #define mp_expt_d_ex TclBN_mp_expt_d_ex -#define mp_expt_u32 TclBN_s_mp_expt_u32 +#define mp_expt_u32 TclBN_mp_expt_u32 #define mp_get_mag_u64 TclBN_mp_get_mag_u64 #define mp_grow TclBN_mp_grow #define mp_init TclBN_mp_init #define mp_init_copy TclBN_mp_init_copy #define mp_init_i64 TclBN_mp_init_i64 #define mp_init_multi TclBN_mp_init_multi -#define mp_init_set TclBN_s_mp_init_set +#define mp_init_set TclBN_mp_init_set #define mp_init_size TclBN_mp_init_size #define mp_init_u64 TclBN_mp_init_u64 #define mp_lshd TclBN_mp_lshd #define mp_mod TclBN_mp_mod #define mp_mod_2d TclBN_mp_mod_2d #define mp_mul TclBN_mp_mul -#define mp_mul_d TclBN_s_mp_mul_d +#define mp_mul_d TclBN_mp_mul_d #define mp_mul_2 TclBN_mp_mul_2 #define mp_mul_2d TclBN_mp_mul_2d #define mp_neg TclBN_mp_neg @@ -140,7 +143,7 @@ MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #define mp_sqr TclBN_mp_sqr #define mp_sqrt TclBN_mp_sqrt #define mp_sub TclBN_mp_sub -#define mp_sub_d TclBN_s_mp_sub_d +#define mp_sub_d TclBN_mp_sub_d #define mp_signed_rsh TclBN_mp_signed_rsh #define mp_tc_and TclBN_mp_and #define mp_tc_div_2d TclBN_mp_signed_rsh @@ -156,7 +159,7 @@ MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #define mp_xor TclBN_mp_xor #define mp_zero TclBN_mp_zero #define s_mp_add TclBN_s_mp_add -#define s_mp_balance_mul TclBN_s_mp_balance_mul +#define s_mp_balance_mul TclBN_mp_balance_mul #define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul #define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr #define s_mp_mul_digs TclBN_s_mp_mul_digs @@ -169,12 +172,6 @@ MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #define s_mp_toom_sqr TclBN_mp_toom_sqr #endif /* !TCL_WITH_EXTERNAL_TOMMATH */ -#define mp_init_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_init_ul") mp_init_u64(a,(unsigned int)(b))) -#define mp_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (mp_set_u64((a),((unsigned int)(b))),MP_OKAY)) -#define mp_set_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (mp_set_u64((a),(long)(b)),MP_OKAY)) -#define mp_set_long_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_u64") (mp_set_u64((a),(b)),MP_OKAY)) -#define mp_unsigned_bin_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_ubin_size") (int)mp_ubin_size(mp)) - #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT @@ -210,7 +207,7 @@ EXTERN int TclBN_revision(void) MP_WUR; EXTERN mp_err TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 3 */ -EXTERN mp_err TclBN_mp_add_d(const mp_int *a, unsigned int b, +EXTERN mp_err TclBN_mp_add_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; /* 4 */ EXTERN mp_err TclBN_mp_and(const mp_int *a, const mp_int *b, @@ -224,7 +221,7 @@ EXTERN void TclBN_mp_clear_multi(mp_int *a, ...); /* 8 */ EXTERN mp_ord TclBN_mp_cmp(const mp_int *a, const mp_int *b) MP_WUR; /* 9 */ -EXTERN mp_ord TclBN_mp_cmp_d(const mp_int *a, unsigned int b) MP_WUR; +EXTERN mp_ord TclBN_mp_cmp_d(const mp_int *a, mp_digit b) MP_WUR; /* 10 */ EXTERN mp_ord TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR; /* 11 */ @@ -235,21 +232,18 @@ EXTERN int TclBN_mp_count_bits(const mp_int *a) MP_WUR; EXTERN mp_err TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) MP_WUR; /* 14 */ -EXTERN mp_err TclBN_mp_div_d(const mp_int *a, unsigned int b, - mp_int *q, unsigned int *r) MP_WUR; +EXTERN mp_err TclBN_mp_div_d(const mp_int *a, mp_digit b, + mp_int *q, mp_digit *r) MP_WUR; /* 15 */ EXTERN mp_err TclBN_mp_div_2(const mp_int *a, mp_int *q) MP_WUR; /* 16 */ EXTERN mp_err TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; -/* 17 */ -TCL_DEPRECATED("is private function in libtommath") -mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, - unsigned int *r); +/* Slot 17 is reserved */ /* 18 */ EXTERN void TclBN_mp_exch(mp_int *a, mp_int *b); /* 19 */ -EXTERN mp_err TclBN_mp_expt_u32(const mp_int *a, unsigned int b, +EXTERN mp_err TclBN_mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c) MP_WUR; /* 20 */ EXTERN mp_err TclBN_mp_grow(mp_int *a, int size) MP_WUR; @@ -260,7 +254,7 @@ EXTERN mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b) MP_WUR; /* 23 */ EXTERN mp_err TclBN_mp_init_multi(mp_int *a, ...) MP_WUR; /* 24 */ -EXTERN mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) MP_WUR; +EXTERN mp_err TclBN_mp_init_set(mp_int *a, mp_digit b) MP_WUR; /* 25 */ EXTERN mp_err TclBN_mp_init_size(mp_int *a, int size) MP_WUR; /* 26 */ @@ -274,7 +268,7 @@ EXTERN mp_err TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r) MP_WUR; EXTERN mp_err TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p) MP_WUR; /* 30 */ -EXTERN mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b, +EXTERN mp_err TclBN_mp_mul_d(const mp_int *a, mp_digit b, mp_int *p) MP_WUR; /* 31 */ EXTERN mp_err TclBN_mp_mul_2(const mp_int *a, mp_int *p) MP_WUR; @@ -295,96 +289,47 @@ EXTERN mp_err TclBN_mp_read_radix(mp_int *a, const char *str, EXTERN void TclBN_mp_rshd(mp_int *a, int shift); /* 38 */ EXTERN mp_err TclBN_mp_shrink(mp_int *a) MP_WUR; -/* 39 */ -TCL_DEPRECATED("macro calling mp_set_u64") -void TclBN_mp_set(mp_int *a, unsigned int b); -/* 40 */ -EXTERN mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b); +/* Slot 39 is reserved */ +/* Slot 40 is reserved */ /* 41 */ EXTERN mp_err TclBN_mp_sqrt(const mp_int *a, mp_int *b) MP_WUR; /* 42 */ EXTERN mp_err TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 43 */ -EXTERN mp_err TclBN_mp_sub_d(const mp_int *a, unsigned int b, +EXTERN mp_err TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR; -/* 44 */ -TCL_DEPRECATED("Use mp_to_ubin") -mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, - unsigned char *b); -/* 45 */ -TCL_DEPRECATED("Use mp_to_ubin") -mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, - unsigned char *b, unsigned long *outlen); -/* 46 */ -TCL_DEPRECATED("Use mp_to_radix") -mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, - int radix, int maxlen); +/* Slot 44 is reserved */ +/* Slot 45 is reserved */ +/* Slot 46 is reserved */ /* 47 */ -EXTERN size_t TclBN_mp_ubin_size(const mp_int *a); +EXTERN size_t TclBN_mp_ubin_size(const mp_int *a) MP_WUR; /* 48 */ EXTERN mp_err TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 49 */ EXTERN void TclBN_mp_zero(mp_int *a); -/* 50 */ -TCL_DEPRECATED("is private function in libtommath") -void TclBN_reverse(unsigned char *s, int len); -/* 51 */ -TCL_DEPRECATED("is private function in libtommath") -mp_err TclBN_s_mp_mul_digs_fast(const mp_int *a, - const mp_int *b, mp_int *c, int digs); -/* 52 */ -TCL_DEPRECATED("is private function in libtommath") -mp_err TclBN_s_mp_sqr_fast(const mp_int *a, mp_int *b); -/* 53 */ -TCL_DEPRECATED("is private function in libtommath") -mp_err TclBN_mp_karatsuba_mul(const mp_int *a, - const mp_int *b, mp_int *c); -/* 54 */ -TCL_DEPRECATED("is private function in libtommath") -mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b); -/* 55 */ -TCL_DEPRECATED("is private function in libtommath") -mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, - mp_int *c); -/* 56 */ -TCL_DEPRECATED("is private function in libtommath") -mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b); -/* 57 */ -TCL_DEPRECATED("is private function in libtommath") -mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b, - mp_int *c); -/* 58 */ -TCL_DEPRECATED("is private function in libtommath") -mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, - mp_int *c, int digs); -/* 59 */ -TCL_DEPRECATED("is private function in libtommath") -mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b); -/* 60 */ -TCL_DEPRECATED("is private function in libtommath") -mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b, - mp_int *c); -/* 61 */ -TCL_DEPRECATED("macro calling mp_init_u64") -mp_err TclBN_mp_init_ul(mp_int *a, unsigned long i); -/* 62 */ -TCL_DEPRECATED("macro calling mp_set_u64") -void TclBN_mp_set_ul(mp_int *a, unsigned long i); +/* Slot 50 is reserved */ +/* Slot 51 is reserved */ +/* Slot 52 is reserved */ +/* Slot 53 is reserved */ +/* Slot 54 is reserved */ +/* Slot 55 is reserved */ +/* Slot 56 is reserved */ +/* Slot 57 is reserved */ +/* Slot 58 is reserved */ +/* Slot 59 is reserved */ +/* Slot 60 is reserved */ +/* Slot 61 is reserved */ +/* Slot 62 is reserved */ /* 63 */ EXTERN int TclBN_mp_cnt_lsb(const mp_int *a) MP_WUR; -/* 64 */ -TCL_DEPRECATED("macro calling mp_init_i64") -int TclBN_mp_init_l(mp_int *bignum, long initVal); +/* Slot 64 is reserved */ /* 65 */ EXTERN int TclBN_mp_init_i64(mp_int *bignum, int64_t initVal) MP_WUR; /* 66 */ EXTERN int TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal) MP_WUR; -/* 67 */ -TCL_DEPRECATED("Use mp_expt_u32") -mp_err TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, - mp_int *c, int fast); +/* Slot 67 is reserved */ /* 68 */ EXTERN void TclBN_mp_set_u64(mp_int *a, uint64_t i); /* 69 */ @@ -401,18 +346,9 @@ EXTERN mp_err TclBN_mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, mp_endian endian, size_t nails, const mp_int *op) MP_WUR; -/* 73 */ -TCL_DEPRECATED("merged with mp_and") -mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b, - mp_int *c); -/* 74 */ -TCL_DEPRECATED("merged with mp_or") -mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b, - mp_int *c); -/* 75 */ -TCL_DEPRECATED("merged with mp_xor") -mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, - mp_int *c); +/* Slot 73 is reserved */ +/* Slot 74 is reserved */ +/* Slot 75 is reserved */ /* 76 */ EXTERN mp_err TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c) MP_WUR; @@ -422,9 +358,7 @@ EXTERN size_t TclBN_mp_pack_count(const mp_int *a, size_t nails, /* 78 */ EXTERN int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; -/* 79 */ -EXTERN mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b, - mp_int *q, uint64_t *r) MP_WUR; +/* Slot 79 is reserved */ /* 80 */ EXTERN int TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR; @@ -436,34 +370,34 @@ typedef struct TclTomMathStubs { int (*tclBN_epoch) (void) MP_WUR; /* 0 */ int (*tclBN_revision) (void) MP_WUR; /* 1 */ mp_err (*tclBN_mp_add) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 2 */ - mp_err (*tclBN_mp_add_d) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 3 */ + mp_err (*tclBN_mp_add_d) (const mp_int *a, mp_digit b, mp_int *c) MP_WUR; /* 3 */ mp_err (*tclBN_mp_and) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 4 */ void (*tclBN_mp_clamp) (mp_int *a); /* 5 */ void (*tclBN_mp_clear) (mp_int *a); /* 6 */ void (*tclBN_mp_clear_multi) (mp_int *a, ...); /* 7 */ mp_ord (*tclBN_mp_cmp) (const mp_int *a, const mp_int *b) MP_WUR; /* 8 */ - mp_ord (*tclBN_mp_cmp_d) (const mp_int *a, unsigned int b) MP_WUR; /* 9 */ + mp_ord (*tclBN_mp_cmp_d) (const mp_int *a, mp_digit b) MP_WUR; /* 9 */ mp_ord (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b) MP_WUR; /* 10 */ mp_err (*tclBN_mp_copy) (const mp_int *a, mp_int *b) MP_WUR; /* 11 */ int (*tclBN_mp_count_bits) (const mp_int *a) MP_WUR; /* 12 */ mp_err (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) MP_WUR; /* 13 */ - mp_err (*tclBN_mp_div_d) (const mp_int *a, unsigned int b, mp_int *q, unsigned int *r) MP_WUR; /* 14 */ + mp_err (*tclBN_mp_div_d) (const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) MP_WUR; /* 14 */ mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q) MP_WUR; /* 15 */ mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; /* 16 */ - TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, unsigned int *r); /* 17 */ + void (*reserved17)(void); void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */ - mp_err (*tclBN_mp_expt_u32) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 19 */ + mp_err (*tclBN_mp_expt_u32) (const mp_int *a, uint32_t b, mp_int *c) MP_WUR; /* 19 */ mp_err (*tclBN_mp_grow) (mp_int *a, int size) MP_WUR; /* 20 */ mp_err (*tclBN_mp_init) (mp_int *a) MP_WUR; /* 21 */ mp_err (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b) MP_WUR; /* 22 */ mp_err (*tclBN_mp_init_multi) (mp_int *a, ...) MP_WUR; /* 23 */ - mp_err (*tclBN_mp_init_set) (mp_int *a, unsigned int b) MP_WUR; /* 24 */ + mp_err (*tclBN_mp_init_set) (mp_int *a, mp_digit b) MP_WUR; /* 24 */ mp_err (*tclBN_mp_init_size) (mp_int *a, int size) MP_WUR; /* 25 */ mp_err (*tclBN_mp_lshd) (mp_int *a, int shift) MP_WUR; /* 26 */ mp_err (*tclBN_mp_mod) (const mp_int *a, const mp_int *b, mp_int *r) MP_WUR; /* 27 */ mp_err (*tclBN_mp_mod_2d) (const mp_int *a, int b, mp_int *r) MP_WUR; /* 28 */ mp_err (*tclBN_mp_mul) (const mp_int *a, const mp_int *b, mp_int *p) MP_WUR; /* 29 */ - mp_err (*tclBN_mp_mul_d) (const mp_int *a, unsigned int b, mp_int *p) MP_WUR; /* 30 */ + mp_err (*tclBN_mp_mul_d) (const mp_int *a, mp_digit b, mp_int *p) MP_WUR; /* 30 */ mp_err (*tclBN_mp_mul_2) (const mp_int *a, mp_int *p) MP_WUR; /* 31 */ mp_err (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p) MP_WUR; /* 32 */ mp_err (*tclBN_mp_neg) (const mp_int *a, mp_int *b) MP_WUR; /* 33 */ @@ -472,47 +406,47 @@ typedef struct TclTomMathStubs { mp_err (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix) MP_WUR; /* 36 */ void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */ mp_err (*tclBN_mp_shrink) (mp_int *a) MP_WUR; /* 38 */ - TCL_DEPRECATED_API("macro calling mp_set_u64") void (*tclBN_mp_set) (mp_int *a, unsigned int b); /* 39 */ - TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_sqr) (const mp_int *a, mp_int *b); /* 40 */ + void (*reserved39)(void); + void (*reserved40)(void); mp_err (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b) MP_WUR; /* 41 */ mp_err (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 42 */ - mp_err (*tclBN_mp_sub_d) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 43 */ - TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */ - TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */ - TCL_DEPRECATED_API("Use mp_to_radix") mp_err (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */ - size_t (*tclBN_mp_ubin_size) (const mp_int *a); /* 47 */ + mp_err (*tclBN_mp_sub_d) (const mp_int *a, mp_digit b, mp_int *c) MP_WUR; /* 43 */ + void (*reserved44)(void); + void (*reserved45)(void); + void (*reserved46)(void); + size_t (*tclBN_mp_ubin_size) (const mp_int *a) MP_WUR; /* 47 */ mp_err (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 48 */ void (*tclBN_mp_zero) (mp_int *a); /* 49 */ - TCL_DEPRECATED_API("is private function in libtommath") void (*tclBN_reverse) (unsigned char *s, int len); /* 50 */ - TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_mul_digs_fast) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 51 */ - TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sqr_fast) (const mp_int *a, mp_int *b); /* 52 */ - TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_karatsuba_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 53 */ - TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_karatsuba_sqr) (const mp_int *a, mp_int *b); /* 54 */ - TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_toom_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 55 */ - TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_toom_sqr) (const mp_int *a, mp_int *b); /* 56 */ - TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 57 */ - TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 58 */ - TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sqr) (const mp_int *a, mp_int *b); /* 59 */ - TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 60 */ - TCL_DEPRECATED_API("macro calling mp_init_u64") mp_err (*tclBN_mp_init_ul) (mp_int *a, unsigned long i); /* 61 */ - TCL_DEPRECATED_API("macro calling mp_set_u64") void (*tclBN_mp_set_ul) (mp_int *a, unsigned long i); /* 62 */ + void (*reserved50)(void); + void (*reserved51)(void); + void (*reserved52)(void); + void (*reserved53)(void); + void (*reserved54)(void); + void (*reserved55)(void); + void (*reserved56)(void); + void (*reserved57)(void); + void (*reserved58)(void); + void (*reserved59)(void); + void (*reserved60)(void); + void (*reserved61)(void); + void (*reserved62)(void); int (*tclBN_mp_cnt_lsb) (const mp_int *a) MP_WUR; /* 63 */ - TCL_DEPRECATED_API("macro calling mp_init_i64") int (*tclBN_mp_init_l) (mp_int *bignum, long initVal); /* 64 */ + void (*reserved64)(void); int (*tclBN_mp_init_i64) (mp_int *bignum, int64_t initVal) MP_WUR; /* 65 */ int (*tclBN_mp_init_u64) (mp_int *bignum, uint64_t initVal) MP_WUR; /* 66 */ - TCL_DEPRECATED_API("Use mp_expt_u32") mp_err (*tclBN_mp_expt_d_ex) (const mp_int *a, unsigned int b, mp_int *c, int fast); /* 67 */ + void (*reserved67)(void); void (*tclBN_mp_set_u64) (mp_int *a, uint64_t i); /* 68 */ uint64_t (*tclBN_mp_get_mag_u64) (const mp_int *a) MP_WUR; /* 69 */ void (*tclBN_mp_set_i64) (mp_int *a, int64_t i); /* 70 */ mp_err (*tclBN_mp_unpack) (mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op) MP_WUR; /* 71 */ mp_err (*tclBN_mp_pack) (void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, mp_endian endian, size_t nails, const mp_int *op) MP_WUR; /* 72 */ - TCL_DEPRECATED_API("merged with mp_and") mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */ - TCL_DEPRECATED_API("merged with mp_or") mp_err (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */ - TCL_DEPRECATED_API("merged with mp_xor") mp_err (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */ + void (*reserved73)(void); + void (*reserved74)(void); + void (*reserved75)(void); mp_err (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c) MP_WUR; /* 76 */ size_t (*tclBN_mp_pack_count) (const mp_int *a, size_t nails, size_t size) MP_WUR; /* 77 */ int (*tclBN_mp_to_ubin) (const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; /* 78 */ - mp_err (*tclBN_mp_div_ld) (const mp_int *a, uint64_t b, mp_int *q, uint64_t *r) MP_WUR; /* 79 */ + void (*reserved79)(void); int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR; /* 80 */ } TclTomMathStubs; @@ -562,8 +496,7 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_div_2) /* 15 */ #define TclBN_mp_div_2d \ (tclTomMathStubsPtr->tclBN_mp_div_2d) /* 16 */ -#define TclBN_mp_div_3 \ - (tclTomMathStubsPtr->tclBN_mp_div_3) /* 17 */ +/* Slot 17 is reserved */ #define TclBN_mp_exch \ (tclTomMathStubsPtr->tclBN_mp_exch) /* 18 */ #define TclBN_mp_expt_u32 \ @@ -606,64 +539,44 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_rshd) /* 37 */ #define TclBN_mp_shrink \ (tclTomMathStubsPtr->tclBN_mp_shrink) /* 38 */ -#define TclBN_mp_set \ - (tclTomMathStubsPtr->tclBN_mp_set) /* 39 */ -#define TclBN_mp_sqr \ - (tclTomMathStubsPtr->tclBN_mp_sqr) /* 40 */ +/* Slot 39 is reserved */ +/* Slot 40 is reserved */ #define TclBN_mp_sqrt \ (tclTomMathStubsPtr->tclBN_mp_sqrt) /* 41 */ #define TclBN_mp_sub \ (tclTomMathStubsPtr->tclBN_mp_sub) /* 42 */ #define TclBN_mp_sub_d \ (tclTomMathStubsPtr->tclBN_mp_sub_d) /* 43 */ -#define TclBN_mp_to_unsigned_bin \ - (tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin) /* 44 */ -#define TclBN_mp_to_unsigned_bin_n \ - (tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin_n) /* 45 */ -#define TclBN_mp_toradix_n \ - (tclTomMathStubsPtr->tclBN_mp_toradix_n) /* 46 */ +/* Slot 44 is reserved */ +/* Slot 45 is reserved */ +/* Slot 46 is reserved */ #define TclBN_mp_ubin_size \ (tclTomMathStubsPtr->tclBN_mp_ubin_size) /* 47 */ #define TclBN_mp_xor \ (tclTomMathStubsPtr->tclBN_mp_xor) /* 48 */ #define TclBN_mp_zero \ (tclTomMathStubsPtr->tclBN_mp_zero) /* 49 */ -#define TclBN_reverse \ - (tclTomMathStubsPtr->tclBN_reverse) /* 50 */ -#define TclBN_s_mp_mul_digs_fast \ - (tclTomMathStubsPtr->tclBN_s_mp_mul_digs_fast) /* 51 */ -#define TclBN_s_mp_sqr_fast \ - (tclTomMathStubsPtr->tclBN_s_mp_sqr_fast) /* 52 */ -#define TclBN_mp_karatsuba_mul \ - (tclTomMathStubsPtr->tclBN_mp_karatsuba_mul) /* 53 */ -#define TclBN_mp_karatsuba_sqr \ - (tclTomMathStubsPtr->tclBN_mp_karatsuba_sqr) /* 54 */ -#define TclBN_mp_toom_mul \ - (tclTomMathStubsPtr->tclBN_mp_toom_mul) /* 55 */ -#define TclBN_mp_toom_sqr \ - (tclTomMathStubsPtr->tclBN_mp_toom_sqr) /* 56 */ -#define TclBN_s_mp_add \ - (tclTomMathStubsPtr->tclBN_s_mp_add) /* 57 */ -#define TclBN_s_mp_mul_digs \ - (tclTomMathStubsPtr->tclBN_s_mp_mul_digs) /* 58 */ -#define TclBN_s_mp_sqr \ - (tclTomMathStubsPtr->tclBN_s_mp_sqr) /* 59 */ -#define TclBN_s_mp_sub \ - (tclTomMathStubsPtr->tclBN_s_mp_sub) /* 60 */ -#define TclBN_mp_init_ul \ - (tclTomMathStubsPtr->tclBN_mp_init_ul) /* 61 */ -#define TclBN_mp_set_ul \ - (tclTomMathStubsPtr->tclBN_mp_set_ul) /* 62 */ +/* Slot 50 is reserved */ +/* Slot 51 is reserved */ +/* Slot 52 is reserved */ +/* Slot 53 is reserved */ +/* Slot 54 is reserved */ +/* Slot 55 is reserved */ +/* Slot 56 is reserved */ +/* Slot 57 is reserved */ +/* Slot 58 is reserved */ +/* Slot 59 is reserved */ +/* Slot 60 is reserved */ +/* Slot 61 is reserved */ +/* Slot 62 is reserved */ #define TclBN_mp_cnt_lsb \ (tclTomMathStubsPtr->tclBN_mp_cnt_lsb) /* 63 */ -#define TclBN_mp_init_l \ - (tclTomMathStubsPtr->tclBN_mp_init_l) /* 64 */ +/* Slot 64 is reserved */ #define TclBN_mp_init_i64 \ (tclTomMathStubsPtr->tclBN_mp_init_i64) /* 65 */ #define TclBN_mp_init_u64 \ (tclTomMathStubsPtr->tclBN_mp_init_u64) /* 66 */ -#define TclBN_mp_expt_d_ex \ - (tclTomMathStubsPtr->tclBN_mp_expt_d_ex) /* 67 */ +/* Slot 67 is reserved */ #define TclBN_mp_set_u64 \ (tclTomMathStubsPtr->tclBN_mp_set_u64) /* 68 */ #define TclBN_mp_get_mag_u64 \ @@ -674,20 +587,16 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_unpack) /* 71 */ #define TclBN_mp_pack \ (tclTomMathStubsPtr->tclBN_mp_pack) /* 72 */ -#define TclBN_mp_tc_and \ - (tclTomMathStubsPtr->tclBN_mp_tc_and) /* 73 */ -#define TclBN_mp_tc_or \ - (tclTomMathStubsPtr->tclBN_mp_tc_or) /* 74 */ -#define TclBN_mp_tc_xor \ - (tclTomMathStubsPtr->tclBN_mp_tc_xor) /* 75 */ +/* Slot 73 is reserved */ +/* Slot 74 is reserved */ +/* Slot 75 is reserved */ #define TclBN_mp_signed_rsh \ (tclTomMathStubsPtr->tclBN_mp_signed_rsh) /* 76 */ #define TclBN_mp_pack_count \ (tclTomMathStubsPtr->tclBN_mp_pack_count) /* 77 */ #define TclBN_mp_to_ubin \ (tclTomMathStubsPtr->tclBN_mp_to_ubin) /* 78 */ -#define TclBN_mp_div_ld \ - (tclTomMathStubsPtr->tclBN_mp_div_ld) /* 79 */ +/* Slot 79 is reserved */ #define TclBN_mp_to_radix \ (tclTomMathStubsPtr->tclBN_mp_to_radix) /* 80 */ @@ -695,55 +604,6 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; /* !END!: Do not edit above this line. */ -#if defined(USE_TCL_STUBS) -#undef mp_add_d -#define mp_add_d TclBN_mp_add_d -#undef mp_cmp_d -#define mp_cmp_d TclBN_mp_cmp_d -#undef mp_div_d -#ifdef MP_64BIT -#define mp_div_d TclBN_mp_div_ld -#else -#define mp_div_d TclBN_mp_div_d -#endif -#undef mp_sub_d -#define mp_sub_d TclBN_mp_sub_d -#undef mp_init_set -#define mp_init_set TclBN_mp_init_set -#undef mp_mul_d -#define mp_mul_d TclBN_mp_mul_d -#undef mp_set -#define mp_set TclBN_mp_set -#undef mp_expt_u32 -#define mp_expt_u32 TclBN_mp_expt_u32 -#endif /* USE_TCL_STUBS */ - -#define TclBNInitBignumFromLong(a,b) \ - do { \ - (a)->dp = NULL; \ - (void)mp_init_i64((a),(b)); \ - if ((a)->dp == NULL) { \ - Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); \ - } \ - } while (0) -#undef TclBNInitBignumFromWideInt -#define TclBNInitBignumFromWideInt(a,b) \ - do { \ - (a)->dp = NULL; \ - (void)mp_init_i64((a),(b)); \ - if ((a)->dp == NULL) { \ - Tcl_Panic("initialization failure in TclBNInitBignumFromWideInt"); \ - } \ - } while (0) -#undef TclBNInitBignumFromWideUInt -#define TclBNInitBignumFromWideUInt(a,b) \ - do { \ - (a)->dp = NULL; \ - (void)mp_init_u64((a),(b)); \ - if ((a)->dp == NULL) { \ - Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); \ - } \ - } while (0) #undef mp_get_ll #define mp_get_ll(a) ((long long)mp_get_i64(a)) #undef mp_set_ll diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 6adc724..15da56e 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -92,12 +92,8 @@ typedef struct { * Forward declarations for functions defined in this file: */ -/* 'OLD' options are pre-Tcl-8.4 style */ enum traceOptionsEnum { TRACE_ADD, TRACE_INFO, TRACE_REMOVE -#ifndef TCL_NO_DEPRECATED - ,TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO -#endif }; typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, enum traceOptionsEnum optionIndex, Tcl_Size objc, Tcl_Obj *const objv[]); @@ -134,7 +130,7 @@ static char * TraceVarProc(void *clientData, Tcl_Interp *interp, static void TraceCommandProc(void *clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); -static Tcl_CmdObjTraceProc TraceExecutionProc; +static Tcl_CmdObjTraceProc2 TraceExecutionProc; static int StringTraceProc(void *clientData, Tcl_Interp *interp, Tcl_Size level, const char *command, Tcl_Command commandInfo, @@ -192,47 +188,26 @@ int Tcl_TraceObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { -#ifndef TCL_NO_DEPRECATED - const char *name; - const char *flagOps, *p; -#endif /* Main sub commands to 'trace' */ static const char *const traceOptions[] = { "add", "info", "remove", -#ifndef TCL_NO_DEPRECATED - "variable", "vdelete", "vinfo", -#endif NULL }; - int optionIndex; -#ifndef TCL_NO_DEPRECATED - static const char *const traceShortOptions[] = { - "add", "info", "remove", NULL - }; -#endif + enum traceOptionsEnum optionIndex; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } -#ifdef TCL_NO_DEPRECATED if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } -#else - if (Tcl_GetIndexFromObj(NULL, objv[1], traceOptions, "option", 0, - &optionIndex) != TCL_OK) { - Tcl_GetIndexFromObj(interp, objv[1], traceShortOptions, "option", 0, - &optionIndex); - return TCL_ERROR; - } -#endif - switch ((enum traceOptionsEnum) optionIndex) { + switch (optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { /* @@ -251,7 +226,7 @@ Tcl_TraceObjCmd( 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } - return traceSubCmds[typeIndex](interp, (enum traceOptionsEnum)optionIndex, objc, objv); + return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); } case TRACE_INFO: { /* @@ -274,119 +249,12 @@ Tcl_TraceObjCmd( 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } - return traceSubCmds[typeIndex](interp, (enum traceOptionsEnum)optionIndex, objc, objv); + return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); break; } -#ifndef TCL_NO_DEPRECATED - case TRACE_OLD_VARIABLE: - case TRACE_OLD_VDELETE: { - Tcl_Obj *copyObjv[6]; - Tcl_Obj *opsList; - int code, numFlags; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); - return TCL_ERROR; - } - - TclNewObj(opsList); - Tcl_IncrRefCount(opsList); - flagOps = TclGetStringFromObj(objv[3], &numFlags); - if (numFlags == 0) { - Tcl_DecrRefCount(opsList); - goto badVarOps; - } - for (p = flagOps; *p != 0; p++) { - Tcl_Obj *opObj; - - if (*p == 'r') { - TclNewLiteralStringObj(opObj, "read"); - } else if (*p == 'w') { - TclNewLiteralStringObj(opObj, "write"); - } else if (*p == 'u') { - TclNewLiteralStringObj(opObj, "unset"); - } else if (*p == 'a') { - TclNewLiteralStringObj(opObj, "array"); - } else { - Tcl_DecrRefCount(opsList); - goto badVarOps; - } - Tcl_ListObjAppendElement(NULL, opsList, opObj); - } - copyObjv[0] = NULL; - memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); - copyObjv[4] = opsList; - if (optionIndex == TRACE_OLD_VARIABLE) { - code = traceSubCmds[2](interp, TRACE_ADD, objc+1, copyObjv); - } else { - code = traceSubCmds[2](interp, TRACE_REMOVE, objc+1, copyObjv); - } - Tcl_DecrRefCount(opsList); - return code; - } - case TRACE_OLD_VINFO: { - void *clientData; - char ops[5]; - Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); - return TCL_ERROR; - } - TclNewObj(resultListPtr); - name = Tcl_GetString(objv[2]); - FOREACH_VAR_TRACE(interp, name, clientData) { - TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; - char *q = ops; - - pairObjPtr = Tcl_NewListObj(0, NULL); - if (tvarPtr->flags & TCL_TRACE_READS) { - *q = 'r'; - q++; - } - if (tvarPtr->flags & TCL_TRACE_WRITES) { - *q = 'w'; - q++; - } - if (tvarPtr->flags & TCL_TRACE_UNSETS) { - *q = 'u'; - q++; - } - if (tvarPtr->flags & TCL_TRACE_ARRAY) { - *q = 'a'; - q++; - } - *q = '\0'; - - /* - * Build a pair (2-item list) with the ops string as the first obj - * element and the tvarPtr->command string as the second obj - * element. Append the pair (as an element) to the end of the - * result object list. - */ - - elemObjPtr = Tcl_NewStringObj(ops, -1); - Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); - elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); - Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); - } - Tcl_SetObjResult(interp, resultListPtr); - break; - } -#endif /* TCL_NO_DEPRECATED */ } return TCL_OK; - -#ifndef TCL_NO_DEPRECATED - badVarOps: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad operations \"%s\": should be one or more of rwua", - flagOps)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", (void *)NULL); - return TCL_ERROR; -#endif } /* @@ -411,7 +279,7 @@ Tcl_TraceObjCmd( static int TraceExecutionObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - enum traceOptionsEnum optionIndex, /* Add, info or remove */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { @@ -423,8 +291,7 @@ TraceExecutionObjCmd( enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP - }; - int index; + } index; switch (optionIndex) { case TRACE_ADD: @@ -464,7 +331,7 @@ TraceExecutionObjCmd( "operation", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum operations) index) { + switch (index) { case TRACE_EXEC_ENTER: flags |= TCL_TRACE_ENTER_EXEC; break; @@ -479,9 +346,9 @@ TraceExecutionObjCmd( break; } } - command = TclGetStringFromObj(objv[5], &length); - if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc( + command = Tcl_GetStringFromObj(objv[5], &length); + if (optionIndex == TRACE_ADD) { + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc( offsetof(TraceCommandInfo, command) + 1 + length); tcmdPtr->flags = flags; @@ -496,10 +363,10 @@ TraceExecutionObjCmd( flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } memcpy(tcmdPtr->command, command, length+1); - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, tcmdPtr) != TCL_OK) { - ckfree(tcmdPtr); + Tcl_Free(tcmdPtr); return TCL_ERROR; } } else { @@ -515,7 +382,7 @@ TraceExecutionObjCmd( * First ensure the name given is valid. */ - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } @@ -549,7 +416,7 @@ TraceExecutionObjCmd( Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - ckfree(tcmdPtr->startCmd); + Tcl_Free(tcmdPtr->startCmd); } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* @@ -559,7 +426,7 @@ TraceExecutionObjCmd( tcmdPtr->flags = 0; } if (tcmdPtr->refCount-- <= 1) { - ckfree(tcmdPtr); + Tcl_Free(tcmdPtr); } break; } @@ -576,7 +443,7 @@ TraceExecutionObjCmd( return TCL_ERROR; } - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); /* * First ensure the name given is valid. @@ -633,10 +500,6 @@ TraceExecutionObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } -#ifndef TCL_NO_DEPRECATED - default: - break; -#endif } return TCL_OK; } @@ -670,8 +533,7 @@ TraceCommandObjCmd( const char *name, *command; Tcl_Size length; static const char *const opStrings[] = { "delete", "rename", NULL }; - enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; - int index; + enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME } index; switch (optionIndex) { case TRACE_ADD: @@ -711,7 +573,7 @@ TraceCommandObjCmd( "operation", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum operations) index) { + switch (index) { case TRACE_CMD_RENAME: flags |= TCL_TRACE_RENAME; break; @@ -721,9 +583,9 @@ TraceCommandObjCmd( } } - command = TclGetStringFromObj(objv[5], &length); - if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc( + command = Tcl_GetStringFromObj(objv[5], &length); + if (optionIndex == TRACE_ADD) { + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc( offsetof(TraceCommandInfo, command) + 1 + length); tcmdPtr->flags = flags; @@ -734,10 +596,10 @@ TraceCommandObjCmd( tcmdPtr->refCount = 1; flags |= TCL_TRACE_DELETE; memcpy(tcmdPtr->command, command, length+1); - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, tcmdPtr) != TCL_OK) { - ckfree(tcmdPtr); + Tcl_Free(tcmdPtr); return TCL_ERROR; } } else { @@ -753,7 +615,7 @@ TraceCommandObjCmd( * First ensure the name given is valid. */ - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } @@ -768,7 +630,7 @@ TraceCommandObjCmd( TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; if (tcmdPtr->refCount-- <= 1) { - ckfree(tcmdPtr); + Tcl_Free(tcmdPtr); } break; } @@ -789,7 +651,7 @@ TraceCommandObjCmd( * First ensure the name given is valid. */ - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } @@ -832,10 +694,6 @@ TraceCommandObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } -#ifndef TCL_NO_DEPRECATED - default: - break; -#endif } return TCL_OK; } @@ -862,7 +720,7 @@ TraceCommandObjCmd( static int TraceVariableObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - enum traceOptionsEnum optionIndex, /* Add, info or remove */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { @@ -874,10 +732,9 @@ TraceVariableObjCmd( }; enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE - }; - int index; + } index; - switch ((enum traceOptionsEnum) optionIndex) { + switch (optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { int flags = 0, result; @@ -915,7 +772,7 @@ TraceVariableObjCmd( "operation", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum operations) index) { + switch (index) { case TRACE_VAR_ARRAY: flags |= TCL_TRACE_ARRAY; break; @@ -930,28 +787,23 @@ TraceVariableObjCmd( break; } } - command = TclGetStringFromObj(objv[5], &length); - if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) { - CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)ckalloc( + command = Tcl_GetStringFromObj(objv[5], &length); + if (optionIndex == TRACE_ADD) { + CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)Tcl_Alloc( offsetof(CombinedTraceVarInfo, traceCmdInfo.command) + 1 + length); ctvarPtr->traceCmdInfo.flags = flags; -#ifndef TCL_NO_DEPRECATED - if (objv[0] == NULL) { - ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE; - } -#endif ctvarPtr->traceCmdInfo.length = length; flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; memcpy(ctvarPtr->traceCmdInfo.command, command, length+1); ctvarPtr->traceInfo.traceProc = TraceVarProc; ctvarPtr->traceInfo.clientData = &ctvarPtr->traceCmdInfo; ctvarPtr->traceInfo.flags = flags; - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr) != TCL_OK) { - ckfree(ctvarPtr); + Tcl_Free(ctvarPtr); return TCL_ERROR; } } else { @@ -961,16 +813,12 @@ TraceVariableObjCmd( * first one that matches. */ - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); FOREACH_VAR_TRACE(interp, name, clientData) { TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; if ((tvarPtr->length == length) - && ((tvarPtr->flags -#ifndef TCL_NO_DEPRECATED -& ~TCL_TRACE_OLD_STYLE -#endif - )==flags) + && ((tvarPtr->flags)==flags) && (strncmp(command, tvarPtr->command, length) == 0)) { Tcl_UntraceVar2(interp, name, NULL, @@ -991,7 +839,7 @@ TraceVariableObjCmd( } TclNewObj(resultListPtr); - name = Tcl_GetString(objv[3]); + name = TclGetString(objv[3]); FOREACH_VAR_TRACE(interp, name, clientData) { Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr; TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; @@ -1030,10 +878,6 @@ TraceVariableObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } -#ifndef TCL_NO_DEPRECATED - default: - break; -#endif } return TCL_OK; } @@ -1152,7 +996,7 @@ Tcl_TraceCommand( * Set up trace information. */ - tracePtr = (CommandTrace *)ckalloc(sizeof(CommandTrace)); + tracePtr = (CommandTrace *)Tcl_Alloc(sizeof(CommandTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags & @@ -1258,7 +1102,7 @@ Tcl_UntraceCommand( tracePtr->flags = 0; if (tracePtr->refCount-- <= 1) { - ckfree(tracePtr); + Tcl_Free(tracePtr); } if (hasExecTraces) { @@ -1371,7 +1215,7 @@ TraceCommandProc( if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - ckfree(tcmdPtr->startCmd); + Tcl_Free(tcmdPtr->startCmd); } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* @@ -1413,7 +1257,7 @@ TraceCommandProc( tcmdPtr->refCount--; } if (tcmdPtr->refCount-- <= 1) { - ckfree(tcmdPtr); + Tcl_Free(tcmdPtr); } } @@ -1504,7 +1348,7 @@ TclCheckExecutionTraces( traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel, command, (Tcl_Command) cmdPtr, objc, objv); if (tcmdPtr->refCount-- <= 1) { - ckfree(tcmdPtr); + Tcl_Free(tcmdPtr); } } } @@ -1751,7 +1595,7 @@ CommandObjTraceDeleted( TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; if (tcmdPtr->refCount-- <= 1) { - ckfree(tcmdPtr); + Tcl_Free(tcmdPtr); } } @@ -1833,7 +1677,7 @@ TraceExecutionProc( && (strcmp(command, tcmdPtr->startCmd) == 0)) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - ckfree(tcmdPtr->startCmd); + Tcl_Free(tcmdPtr->startCmd); } /* @@ -1854,7 +1698,7 @@ TraceExecutionProc( Tcl_DStringInit(&sub); for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(&sub, Tcl_GetString(objv[i])); + Tcl_DStringAppendElement(&sub, TclGetString(objv[i])); } Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); Tcl_DStringFree(&sub); @@ -1878,7 +1722,7 @@ TraceExecutionProc( */ TclNewIntObj(resultCode, code); - resultCodeStr = Tcl_GetString(resultCode); + resultCodeStr = TclGetString(resultCode); Tcl_DStringAppendElement(&cmd, resultCodeStr); Tcl_DecrRefCount(resultCode); @@ -1947,10 +1791,10 @@ TraceExecutionProc( unsigned len = strlen(command) + 1; tcmdPtr->startLevel = level; - tcmdPtr->startCmd = (char *)ckalloc(len); + tcmdPtr->startCmd = (char *)Tcl_Alloc(len); memcpy(tcmdPtr->startCmd, command, len); tcmdPtr->refCount++; - tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, + tcmdPtr->stepTrace = Tcl_CreateObjTrace2(interp, 0, (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, TraceExecutionProc, tcmdPtr, CommandObjTraceDeleted); } @@ -1959,12 +1803,12 @@ TraceExecutionProc( if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - ckfree(tcmdPtr->startCmd); + Tcl_Free(tcmdPtr->startCmd); } } if (call) { if (tcmdPtr->refCount-- <= 1) { - ckfree(tcmdPtr); + Tcl_Free(tcmdPtr); } } return traceCode; @@ -2024,19 +1868,6 @@ TraceVarProc( Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); -#ifndef TCL_NO_DEPRECATED - if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { - if (flags & TCL_TRACE_ARRAY) { - TclDStringAppendLiteral(&cmd, " a"); - } else if (flags & TCL_TRACE_READS) { - TclDStringAppendLiteral(&cmd, " r"); - } else if (flags & TCL_TRACE_WRITES) { - TclDStringAppendLiteral(&cmd, " w"); - } else if (flags & TCL_TRACE_UNSETS) { - TclDStringAppendLiteral(&cmd, " u"); - } - } else { -#endif if (flags & TCL_TRACE_ARRAY) { TclDStringAppendLiteral(&cmd, " array"); } else if (flags & TCL_TRACE_READS) { @@ -2046,9 +1877,6 @@ TraceVarProc( } else if (flags & TCL_TRACE_UNSETS) { TclDStringAppendLiteral(&cmd, " unset"); } -#ifndef TCL_NO_DEPRECATED - } -#endif /* * Execute the command. We discard any object result the command @@ -2151,6 +1979,38 @@ TraceVarProc( *---------------------------------------------------------------------- */ +typedef struct { + Tcl_CmdObjTraceProc *proc; + Tcl_CmdObjTraceDeleteProc *delProc; + void *clientData; +} TraceWrapperInfo; + +static int traceWrapperProc( + void *clientData, + Tcl_Interp *interp, + Tcl_Size level, + const char *command, + Tcl_Command commandInfo, + Tcl_Size objc, + Tcl_Obj *const objv[]) +{ + TraceWrapperInfo *info = (TraceWrapperInfo *)clientData; + if (objc > INT_MAX) { + objc = -1; /* Signal Tcl_CmdObjTraceProc that objc is out of range */ + } + return info->proc(info->clientData, interp, (int)level, command, commandInfo, objc, objv); +} + +static void traceWrapperDelProc(void *clientData) +{ + TraceWrapperInfo *info = (TraceWrapperInfo *)clientData; + clientData = info->clientData; + if (info->delProc) { + info->delProc(clientData); + } + Tcl_Free(info); +} + Tcl_Trace Tcl_CreateObjTrace( Tcl_Interp *interp, /* Tcl interpreter */ @@ -2161,6 +2021,25 @@ Tcl_CreateObjTrace( Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { + TraceWrapperInfo *info = (TraceWrapperInfo *)Tcl_Alloc(sizeof(TraceWrapperInfo)); + info->proc = proc; + info->delProc = delProc; + info->clientData = clientData; + return Tcl_CreateObjTrace2(interp, level, flags, + (proc ? traceWrapperProc : NULL), + info, traceWrapperDelProc); +} + +Tcl_Trace +Tcl_CreateObjTrace2( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_Size level, /* Maximum nesting level */ + int flags, /* Flags, see above */ + Tcl_CmdObjTraceProc2 *proc, /* Trace callback */ + void *clientData, /* Client data for the callback */ + Tcl_CmdObjTraceDeleteProc *delProc) + /* Function to call when trace is deleted */ +{ Trace *tracePtr; Interp *iPtr = (Interp *) interp; @@ -2186,7 +2065,7 @@ Tcl_CreateObjTrace( iPtr->tracesForbiddingInline++; } - tracePtr = (Trace *)ckalloc(sizeof(Trace)); + tracePtr = (Trace *)Tcl_Alloc(sizeof(Trace)); tracePtr->level = level; tracePtr->proc = proc; tracePtr->clientData = clientData; @@ -2249,11 +2128,11 @@ Tcl_CreateTrace( * command. */ void *clientData) /* Arbitrary value word to pass to proc. */ { - StringTraceData *data = (StringTraceData *)ckalloc(sizeof(StringTraceData)); + StringTraceData *data = (StringTraceData *)Tcl_Alloc(sizeof(StringTraceData)); data->clientData = clientData; data->proc = proc; - return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc, + return Tcl_CreateObjTrace2(interp, level, 0, StringTraceProc, data, StringTraceDeleteProc); } @@ -2296,7 +2175,7 @@ StringTraceProc( argv = (const char **) TclStackAlloc(interp, (objc + 1) * sizeof(const char *)); for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); + argv[i] = TclGetString(objv[i]); } argv[objc] = 0; @@ -2333,7 +2212,7 @@ static void StringTraceDeleteProc( void *clientData) { - ckfree(clientData); + Tcl_Free(clientData); } /* @@ -2584,9 +2463,6 @@ TclObjCallVarTraces( leaveErrMsg); } -#undef TCL_INTERP_DESTROYED -#define TCL_INTERP_DESTROYED 0x100 - int TclCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ @@ -2614,6 +2490,7 @@ TclCallVarTraces( Tcl_InterpState state = NULL; Tcl_HashEntry *hPtr; int traceflags = flags & VAR_ALL_TRACES; + const char *element; /* * If there are already similar trace functions active for the variable, @@ -2665,12 +2542,19 @@ TclCallVarTraces( } } - /* - * Ignore any caller-provided TCL_INTERP_DESTROYED flag. Only we can - * set it correctly. - */ - - flags &= ~TCL_INTERP_DESTROYED; + /* Keep the original pointer for possible use in an error message */ + element = part2; + if (part2 == NULL) { + if (TclIsVarArrayElement(varPtr)) { + Tcl_Obj *keyObj = VarHashGetKey(varPtr); + part2 = Tcl_GetString(keyObj); + } + } else if ((flags & VAR_TRACED_UNSET) && !(flags & VAR_ARRAY_ELEMENT)) { + /* On unset traces, part2 has already been set by the caller, and + * the VAR_ARRAY_ELEMENT flag indicates whether the accessed + * variable actually has a second part, or is a scalar */ + element = NULL; + } /* * Invoke traces on the array containing the variable, if relevant. @@ -2694,9 +2578,6 @@ TclCallVarTraces( if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, code); } - if (Tcl_InterpDeleted((Tcl_Interp *) iPtr)) { - flags |= TCL_INTERP_DESTROYED; - } result = tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { @@ -2738,9 +2619,6 @@ TclCallVarTraces( if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, code); } - if (Tcl_InterpDeleted((Tcl_Interp *) iPtr)) { - flags |= TCL_INTERP_DESTROYED; - } result = tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { @@ -2798,13 +2676,13 @@ TclCallVarTraces( Tcl_AppendObjToErrorInfo((Tcl_Interp *)iPtr, Tcl_ObjPrintf( "\n (%s trace on \"%s%s%s%s\")", type, part1, - (part2 ? "(" : ""), (part2 ? part2 : ""), - (part2 ? ")" : "") )); + (element ? "(" : ""), (element ? element : ""), + (element ? ")" : "") )); if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { - TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, - Tcl_GetString((Tcl_Obj *) result)); + TclVarErrMsg((Tcl_Interp *) iPtr, part1, element, verb, + TclGetString((Tcl_Obj *) result)); } else { - TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result); + TclVarErrMsg((Tcl_Interp *) iPtr, part1, element, verb, result); } iPtr->flags &= ~(ERR_ALREADY_LOGGED); Tcl_DiscardInterpState(state); @@ -2861,7 +2739,7 @@ DisposeTraceResult( * to be disposed. */ { if (flags & TCL_TRACE_RESULT_DYNAMIC) { - ckfree(result); + Tcl_Free(result); } else if (flags & TCL_TRACE_RESULT_OBJECT) { Tcl_DecrRefCount((Tcl_Obj *) result); } @@ -2870,41 +2748,6 @@ DisposeTraceResult( /* *---------------------------------------------------------------------- * - * Tcl_UntraceVar -- - * - * Remove a previously-created trace for a variable. - * - * Results: - * None. - * - * Side effects: - * If there exists a trace for the variable given by varName with the - * given flags, proc, and clientData, then that trace is removed. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_UntraceVar -void -Tcl_UntraceVar( - Tcl_Interp *interp, /* Interpreter containing variable. */ - const char *varName, /* Name of variable; may end with "(index)" to - * signify an array reference. */ - int flags, /* OR-ed collection of bits describing current - * trace, including any of TCL_TRACE_READS, - * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, - * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc, /* Function assocated with trace. */ - ClientData clientData) /* Arbitrary argument to pass to proc. */ -{ - Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_UntraceVar2 -- * * Remove a previously-created trace for a variable. @@ -2931,7 +2774,7 @@ Tcl_UntraceVar2( * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function associated with trace. */ - ClientData clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { VarTrace *tracePtr; VarTrace *prevPtr, *nextPtr; @@ -2960,9 +2803,6 @@ Tcl_UntraceVar2( flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; -#ifndef TCL_NO_DEPRECATED - flagMask |= TCL_TRACE_OLD_STYLE; -#endif flags &= flagMask; hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); @@ -3035,49 +2875,6 @@ Tcl_UntraceVar2( /* *---------------------------------------------------------------------- * - * Tcl_VarTraceInfo -- - * - * Return the clientData value associated with a trace on a variable. - * This function can also be used to step through all of the traces on a - * particular variable that have the same trace function. - * - * Results: - * The return value is the clientData value associated with a trace on - * the given variable. Information will only be returned for a trace with - * proc as trace function. If the clientData argument is NULL then the - * first such trace is returned; otherwise, the next relevant one after - * the one given by clientData will be returned. If the variable doesn't - * exist, or if there are no (more) traces for it, then NULL is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_VarTraceInfo -ClientData -Tcl_VarTraceInfo( - Tcl_Interp *interp, /* Interpreter containing variable. */ - const char *varName, /* Name of variable; may end with "(index)" to - * signify an array reference. */ - int flags, /* OR-ed combo or TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY (can be 0). */ - Tcl_VarTraceProc *proc, /* Function associated with trace. */ - ClientData prevClientData) /* If non-NULL, gives last value returned by - * this function, so this call will return the - * next trace after that one. If NULL, this - * call will return the first trace. */ -{ - return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, - prevClientData); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_VarTraceInfo2 -- * * Same as Tcl_VarTraceInfo, except takes name in two pieces instead of @@ -3092,7 +2889,7 @@ Tcl_VarTraceInfo( *---------------------------------------------------------------------- */ -ClientData +void * Tcl_VarTraceInfo2( Tcl_Interp *interp, /* Interpreter containing variable. */ const char *part1, /* Name of variable or array. */ @@ -3102,7 +2899,7 @@ Tcl_VarTraceInfo2( int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function associated with trace. */ - ClientData prevClientData) /* If non-NULL, gives last value returned by + void *prevClientData) /* If non-NULL, gives last value returned by * this function, so this call will return the * next trace after that one. If NULL, this * call will return the first trace. */ @@ -3148,47 +2945,6 @@ Tcl_VarTraceInfo2( /* *---------------------------------------------------------------------- * - * Tcl_TraceVar -- - * - * Arrange for reads and/or writes to a variable to cause a function to - * be invoked, which can monitor the operations and/or change their - * actions. - * - * Results: - * A standard Tcl return value. - * - * Side effects: - * A trace is set up on the variable given by varName, such that future - * references to the variable will be mediated by proc. See the - * manual entry for complete details on the calling sequence for proc. - * The variable's flags are updated. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_TraceVar -int -Tcl_TraceVar( - Tcl_Interp *interp, /* Interpreter in which variable is to be - * traced. */ - const char *varName, /* Name of variable; may end with "(index)" to - * signify an array reference. */ - int flags, /* OR-ed collection of bits, including any of - * TCL_TRACE_READS, TCL_TRACE_WRITES, - * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and - * TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc, /* Function to call when specified ops are - * invoked upon varName. */ - ClientData clientData) /* Arbitrary argument to pass to proc. */ -{ - return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_TraceVar2 -- * * Arrange for reads and/or writes to a variable to cause a function to @@ -3226,7 +2982,7 @@ Tcl_TraceVar2( VarTrace *tracePtr; int result; - tracePtr = (VarTrace *)ckalloc(sizeof(VarTrace)); + tracePtr = (VarTrace *)Tcl_Alloc(sizeof(VarTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags; @@ -3234,7 +2990,7 @@ Tcl_TraceVar2( result = TraceVarEx(interp, part1, part2, tracePtr); if (result != TCL_OK) { - ckfree(tracePtr); + Tcl_Free(tracePtr); } return result; } @@ -3270,7 +3026,7 @@ TraceVarEx( * as-a-whole. */ VarTrace *tracePtr)/* Structure containing flags, traceProc and * clientData fields. Others should be left - * blank. Will be ckfree()d (eventually) if + * blank. Will be Tcl_Free()d (eventually) if * this function returns TCL_OK, and up to * caller to free if this function returns * TCL_ERROR. */ @@ -3311,9 +3067,6 @@ TraceVarEx( flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; -#ifndef TCL_NO_DEPRECATED - flagMask |= TCL_TRACE_OLD_STYLE; -#endif tracePtr->flags = tracePtr->flags & flagMask; hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, varPtr, &isNew); diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 44a0a75..ca4a166 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -207,13 +207,18 @@ Invalid( Tcl_Size Tcl_UniCharToUtf( int ch, /* The Tcl_UniChar to be stored in the - * buffer. + * buffer. Can be or'ed with flag TCL_COMBINE. */ char *buf) /* Buffer in which the UTF-8 representation of * ch is stored. Must be large enough to hold the UTF-8 * character (at most 4 bytes). */ { + int flags = ch; + + if (ch >= TCL_COMBINE) { + ch &= (TCL_COMBINE - 1); + } if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { buf[0] = (char) ch; return 1; @@ -225,7 +230,8 @@ Tcl_UniCharToUtf( return 2; } if (ch <= 0xFFFF) { - if ((ch & 0xF800) == 0xD800) { + if ((flags & TCL_COMBINE) && + ((ch & 0xF800) == 0xD800)) { if (ch & 0x0400) { /* Low surrogate */ if ( (0x80 == (0xC0 & buf[0])) @@ -302,7 +308,6 @@ three: *--------------------------------------------------------------------------- */ -#undef Tcl_UniCharToUtfDString char * Tcl_UniCharToUtfDString( const int *uniStr, /* Unicode string to convert to UTF-8. */ @@ -386,7 +391,7 @@ Tcl_Char16ToUtfDString( /* Special case for handling high surrogates. */ p += Tcl_UniCharToUtf(-1, p); } - len = Tcl_UniCharToUtf(*w, p); + len = Tcl_UniCharToUtf(*w | TCL_COMBINE, p); p += len; if ((*w >= 0xD800) && (len < 3)) { len = 0; /* Indication that high surrogate was found */ @@ -417,15 +422,6 @@ Tcl_Char16ToUtfDString( * Tcl_UtfCharComplete() before calling this routine to ensure that * enough bytes remain in the string. * - * Special handling of Surrogate pairs is done: - * For any UTF-8 string containing a character outside of the BMP, the - * first call to this function will fill *chPtr with the high surrogate - * and generate a return value of 1. Calling Tcl_UtfToUniChar again - * will produce the low surrogate and a return value of 3. Because *chPtr - * is used to remember whether the high surrogate is already produced, it - * is recommended to initialize the variable it points to as 0 before - * the first call to Tcl_UtfToUniChar is done. - * * Results: * *chPtr is filled with the Tcl_UniChar, and the return value is the * number of bytes from the UTF-8 string that were consumed. @@ -443,7 +439,6 @@ static const unsigned short cp1252[32] = { 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 }; -#undef Tcl_UtfToUniChar Tcl_Size Tcl_UtfToUniChar( const char *src, /* The UTF-8 string. */ @@ -644,7 +639,6 @@ Tcl_UtfToChar16( *--------------------------------------------------------------------------- */ -#undef Tcl_UtfToUniCharDString int * Tcl_UtfToUniCharDString( const char *src, /* UTF-8 string to convert to Unicode. */ @@ -807,7 +801,7 @@ Tcl_UtfCharComplete( */ Tcl_Size -TclNumUtfChars( +Tcl_NumUtfChars( const char *src, /* The UTF-8 string to measure. */ Tcl_Size length) /* The length of the string in bytes, or * negative value for strlen(src). */ @@ -817,7 +811,7 @@ TclNumUtfChars( if (length < 0) { /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */ - while ((*src != '\0') && (i < INT_MAX)) { + while (*src != '\0') { src += TclUtfToUniChar(src, &ch); i++; } @@ -858,9 +852,8 @@ TclNumUtfChars( return i; } -#if !defined(TCL_NO_DEPRECATED) Tcl_Size -Tcl_NumUtfChars( +TclNumUtfChars( const char *src, /* The UTF-8 string to measure. */ Tcl_Size length) /* The length of the string in bytes, or * negative for strlen(src). */ @@ -870,7 +863,7 @@ Tcl_NumUtfChars( if (length < 0) { /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */ - while ((*src != '\0') && (i < INT_MAX)) { + while (*src != '\0') { src += Tcl_UtfToChar16(src, &ch); i++; } @@ -910,7 +903,6 @@ Tcl_NumUtfChars( } return i; } -#endif /* *--------------------------------------------------------------------------- @@ -1189,20 +1181,16 @@ Tcl_UniCharAtIndex( const char *src, /* The UTF-8 string to dereference. */ Tcl_Size index) /* The position of the desired character. */ { - unsigned short ch = 0; + Tcl_UniChar ch = 0; int i = 0; if (index < 0) { return -1; } - while (index-- > 0) { - i = Tcl_UtfToChar16(src, &ch); + while (index--) { + i = TclUtfToUniChar(src, &ch); src += i; } - if ((ch >= 0xD800) && (i < 3)) { - /* Index points at character following high Surrogate */ - return -1; - } Tcl_UtfToUniChar(src, &i); return i; } @@ -1225,21 +1213,20 @@ Tcl_UniCharAtIndex( */ const char * -TclUtfAtIndex( +Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ Tcl_Size index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; while (index-- > 0) { - src += TclUtfToUniChar(src, &ch); + src += Tcl_UtfToUniChar(src, &ch); } return src; } -#if !defined(TCL_NO_DEPRECATED) const char * -Tcl_UtfAtIndex( +TclUtfAtIndex( const char *src, /* The UTF-8 string. */ Tcl_Size index) /* The position of the desired character. */ { @@ -1257,7 +1244,6 @@ Tcl_UtfAtIndex( } return src; } -#endif /* *--------------------------------------------------------------------------- @@ -1353,7 +1339,7 @@ Tcl_UtfToUpper( * char to dst if its size is <= the original char. */ - if ((len < TclUtfCount(upChar)) || ((upChar & ~0x7FF) == 0xD800)) { + if (len < TclUtfCount(upChar)) { memmove(dst, src, len); dst += len; } else { @@ -1406,7 +1392,7 @@ Tcl_UtfToLower( * char to dst if its size is <= the original char. */ - if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) { + if (len < TclUtfCount(lowChar)) { memmove(dst, src, len); dst += len; } else { @@ -1456,7 +1442,7 @@ Tcl_UtfToTitle( len = Tcl_UtfToUniChar(src, &ch); titleChar = Tcl_UniCharToTitle(ch); - if ((len < TclUtfCount(titleChar)) || ((titleChar & ~0x7FF) == 0xD800)) { + if (len < TclUtfCount(titleChar)) { memmove(dst, src, len); dst += len; } else { @@ -1472,7 +1458,7 @@ Tcl_UtfToTitle( lowChar = Tcl_UniCharToLower(lowChar); } - if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) { + if (len < TclUtfCount(lowChar)) { memmove(dst, src, len); dst += len; } else { @@ -1503,10 +1489,12 @@ Tcl_UtfToTitle( int TclpUtfNcmp2( - const char *cs, /* UTF string to compare to ct. */ - const char *ct, /* UTF string cs is compared to. */ - unsigned long numBytes) /* Number of *bytes* to compare. */ + const void *csPtr, /* UTF string to compare to ct. */ + const void *ctPtr, /* UTF string cs is compared to. */ + size_t numBytes) /* Number of *bytes* to compare. */ { + const char *cs = (const char *)csPtr; + const char *ct = (const char *)ctPtr; /* * We can't simply call 'memcmp(cs, ct, numBytes);' because we need to * check for Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes @@ -1536,8 +1524,8 @@ TclpUtfNcmp2( * * Tcl_UtfNcmp -- * - * Compare at most numChars UTF-16 chars of string cs to string ct. Both cs - * and ct are assumed to be at least numChars UTF-16 chars long. + * Compare at most numChars chars (not bytes) of string cs to string ct. Both cs + * and ct are assumed to be at least numChars chars long. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. @@ -1548,12 +1536,11 @@ TclpUtfNcmp2( *---------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) int -Tcl_UtfNcmp( +TclUtfNcmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ - unsigned long numChars) /* Number of UTF-16 chars to compare. */ + size_t numChars) /* Number of UTF-16 chars to compare. */ { unsigned short ch1 = 0, ch2 = 0; @@ -1565,7 +1552,7 @@ Tcl_UtfNcmp( while (numChars-- > 0) { /* - * n must be interpreted as UTF-16 chars, not bytes. This should be called + * n must be interpreted as chars, not bytes. This should be called * only when both strings are of at least n UTF-16 chars long (no need for \0 * check) */ @@ -1586,10 +1573,9 @@ Tcl_UtfNcmp( } return 0; } -#endif /* TCL_NO_DEPRECATED */ int -TclUtfNcmp( +Tcl_UtfNcmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ size_t numChars) /* Number of chars to compare. */ @@ -1617,46 +1603,14 @@ TclUtfNcmp( } return 0; } - -int -TclUtfNmemcmp( - const void *csPtr, /* UTF string to compare to ct. */ - const void *ctPtr, /* UTF string cs is compared to. */ - size_t numChars) /* Number of chars to compare. */ -{ - Tcl_UniChar ch1 = 0, ch2 = 0; - const char *cs = (const char *)csPtr; - const char *ct = (const char *)ctPtr; - - /* - * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the - * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001 - * (the byte 0x01.) - */ - - while (numChars-- > 0) { - /* - * n must be interpreted as chars, not bytes. This should be called - * only when both strings are of at least n chars long (no need for \0 - * check) - */ - - cs += TclUtfToUniChar(cs, &ch1); - ct += TclUtfToUniChar(ct, &ch2); - if (ch1 != ch2) { - return (ch1 - ch2); - } - } - return 0; -} /* *---------------------------------------------------------------------- * * Tcl_UtfNcasecmp -- * - * Compare at most numChars UTF-16 chars of string cs to string ct case - * insensitive. Both cs and ct are assumed to be at least numChars UTF-16 + * Compare at most numChars chars (not bytes) of string cs to string ct case + * insensitive. Both cs and ct are assumed to be at least numChars UTF * chars long. * * Results: @@ -1668,12 +1622,11 @@ TclUtfNmemcmp( *---------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) int -Tcl_UtfNcasecmp( +TclUtfNcasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ - unsigned long numChars) /* Number of UTF-16 chars to compare. */ + size_t numChars) /* Number of UTF-16 chars to compare. */ { unsigned short ch1 = 0, ch2 = 0; @@ -1703,11 +1656,9 @@ Tcl_UtfNcasecmp( } return 0; } -#endif /* TCL_NO_DEPRECATED */ - int -TclUtfNcasecmp( +Tcl_UtfNcasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ size_t numChars) /* Number of chars to compare. */ @@ -1733,35 +1684,6 @@ TclUtfNcasecmp( return 0; } -int -TclUtfNcasememcmp( - const void *csPtr, /* UTF string to compare to ct. */ - const void *ctPtr, /* UTF string cs is compared to. */ - size_t numChars) /* Number of chars to compare. */ -{ - const char *cs = (const char *)csPtr; - const char *ct = (const char *)ctPtr; - Tcl_UniChar ch1 = 0, ch2 = 0; - - while (numChars-- > 0) { - /* - * n must be interpreted as chars, not bytes. - * This should be called only when both strings are of - * at least n chars long (no need for \0 check) - */ - cs += TclUtfToUniChar(cs, &ch1); - ct += TclUtfToUniChar(ct, &ch2); - if (ch1 != ch2) { - ch1 = Tcl_UniCharToLower(ch1); - ch2 = Tcl_UniCharToLower(ch2); - if (ch1 != ch2) { - return (ch1 - ch2); - } - } - } - return 0; -} - /* *---------------------------------------------------------------------- * @@ -1988,7 +1910,6 @@ Tcl_Char16Len( *---------------------------------------------------------------------- */ -#undef Tcl_UniCharLen Tcl_Size Tcl_UniCharLen( const int *uniStr) /* Unicode string to find length of. */ @@ -2005,7 +1926,7 @@ Tcl_UniCharLen( /* *---------------------------------------------------------------------- * - * Tcl_UniCharNcmp -- + * TclUniCharNcmp -- * * Compare at most numChars chars (not bytes) of string ucs to string uct. * Both ucs and uct are assumed to be at least numChars chars long. @@ -2046,73 +1967,10 @@ TclUniCharNcmp( #endif /* WORDS_BIGENDIAN */ } -int -TclUniCharNmemcmp( - const void *ucsPtr, /* Unicode string to compare to uct. */ - const void *uctPtr, /* Unicode string ucs is compared to. */ - size_t numChars) /* Number of chars (not bytes) to compare. */ -{ - const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; - const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; -#if defined(WORDS_BIGENDIAN) - /* - * We are definitely on a big-endian machine; memcmp() is safe - */ - - return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); - -#else /* !WORDS_BIGENDIAN */ - /* - * We can't simply call memcmp() because that is not lexically correct. - */ - - for ( ; numChars != 0; ucs++, uct++, numChars--) { - if (*ucs != *uct) { - return (*ucs - *uct); - } - } - return 0; -#endif /* WORDS_BIGENDIAN */ -} - -#if !defined(TCL_NO_DEPRECATED) -int -Tcl_UniCharNcmp( - const unsigned short *ucs, /* Unicode string to compare to uct. */ - const unsigned short *uct, /* Unicode string ucs is compared to. */ - unsigned long numChars) /* Number of chars (not bytes) to compare. */ -{ -#if defined(WORDS_BIGENDIAN) - /* - * We are definitely on a big-endian machine; memcmp() is safe - */ - - return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); - -#else /* !WORDS_BIGENDIAN */ - /* - * We can't simply call memcmp() because that is not lexically correct. - */ - - for ( ; numChars != 0; ucs++, uct++, numChars--) { - if (*ucs != *uct) { - /* special case for handling upper surrogates */ - if (((*ucs & 0xFC00) == 0xD800) && ((*uct & 0xFC00) != 0xD800)) { - return 1; - } else if (((*uct & 0xFC00) == 0xD800)) { - return -1; - } - return (*ucs - *uct); - } - } - return 0; -#endif /* WORDS_BIGENDIAN */ -} -#endif /* *---------------------------------------------------------------------- * - * Tcl_UniCharNcasecmp -- + * TclUniCharNcasecmp -- * * Compare at most numChars chars (not bytes) of string ucs to string uct case * insensitive. Both ucs and uct are assumed to be at least numChars @@ -2145,54 +2003,6 @@ TclUniCharNcasecmp( } return 0; } - -int -TclUniCharNcasememcmp( - const void *ucsPtr, /* Unicode string to compare to uct. */ - const void *uctPtr, /* Unicode string ucs is compared to. */ - size_t numChars) /* Number of chars (not bytes) to compare. */ -{ - const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; - const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; - for ( ; numChars != 0; numChars--, ucs++, uct++) { - if (*ucs != *uct) { - Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); - Tcl_UniChar lct = Tcl_UniCharToLower(*uct); - - if (lcs != lct) { - return (lcs - lct); - } - } - } - return 0; -} - -#if !defined(TCL_NO_DEPRECATED) -int -Tcl_UniCharNcasecmp( - const unsigned short *ucs, /* Unicode string to compare to uct. */ - const unsigned short *uct, /* Unicode string ucs is compared to. */ - unsigned long numChars) /* Number of chars (not bytes) to compare. */ -{ - for ( ; numChars != 0; numChars--, ucs++, uct++) { - if (*ucs != *uct) { - unsigned short lcs = Tcl_UniCharToLower(*ucs); - unsigned short lct = Tcl_UniCharToLower(*uct); - - if (lcs != lct) { - /* special case for handling upper surrogates */ - if (((lcs & 0xFC00) == 0xD800) && ((lct & 0xFC00) != 0xD800)) { - return 1; - } else if (((lct & 0xFC00) == 0xD800)) { - return -1; - } - return (lcs - lct); - } - } - } - return 0; -} -#endif /* *---------------------------------------------------------------------- @@ -2529,7 +2339,7 @@ Tcl_UniCharIsWordChar( /* *---------------------------------------------------------------------- * - * Tcl_UniCharCaseMatch -- + * TclUniCharCaseMatch -- * * See if a particular Unicode string matches a particular pattern. * Allows case insensitivity. This is the Unicode equivalent of the char* @@ -2715,175 +2525,6 @@ TclUniCharCaseMatch( uniPattern++; } } - -#if !defined(TCL_NO_DEPRECATED) -int -Tcl_UniCharCaseMatch( - const unsigned short *uniStr, /* Unicode String. */ - const unsigned short *uniPattern, - /* Pattern, which may contain special - * characters. */ - int nocase) /* 0 for case sensitive, 1 for insensitive */ -{ - unsigned short ch1 = 0, p; - - while (1) { - p = *uniPattern; - - /* - * See if we're at the end of both the pattern and the string. If so, - * we succeeded. If we're at the end of the pattern but not at the end - * of the string, we failed. - */ - - if (p == 0) { - return (*uniStr == 0); - } - if ((*uniStr == 0) && (p != '*')) { - return 0; - } - - /* - * Check for a "*" as the next pattern character. It matches any - * substring. We handle this by skipping all the characters up to the - * next matching one in the pattern, and then calling ourselves - * recursively for each postfix of string, until either we match or we - * reach the end of the string. - */ - - if (p == '*') { - /* - * Skip all successive *'s in the pattern - */ - - while (*(++uniPattern) == '*') { - /* empty body */ - } - p = *uniPattern; - if (p == 0) { - return 1; - } - if (nocase) { - p = Tcl_UniCharToLower(p); - } - while (1) { - /* - * Optimization for matching - cruise through the string - * quickly if the next char in the pattern isn't a special - * character - */ - - if ((p != '[') && (p != '?') && (p != '\\')) { - if (nocase) { - while (*uniStr && (p != *uniStr) - && (p != Tcl_UniCharToLower(*uniStr))) { - uniStr++; - } - } else { - while (*uniStr && (p != *uniStr)) { - uniStr++; - } - } - } - if (Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase)) { - return 1; - } - if (*uniStr == 0) { - return 0; - } - uniStr++; - } - } - - /* - * Check for a "?" as the next pattern character. It matches any - * single character. - */ - - if (p == '?') { - uniPattern++; - uniStr++; - continue; - } - - /* - * Check for a "[" as the next pattern character. It is followed by a - * list of characters that are acceptable, or by a range (two - * characters separated by "-"). - */ - - if (p == '[') { - unsigned short startChar, endChar; - - uniPattern++; - ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); - uniStr++; - while (1) { - if ((*uniPattern == ']') || (*uniPattern == 0)) { - return 0; - } - startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) - : *uniPattern); - uniPattern++; - if (*uniPattern == '-') { - uniPattern++; - if (*uniPattern == 0) { - return 0; - } - endChar = (nocase ? Tcl_UniCharToLower(*uniPattern) - : *uniPattern); - uniPattern++; - if (((startChar <= ch1) && (ch1 <= endChar)) - || ((endChar <= ch1) && (ch1 <= startChar))) { - /* - * Matches ranges of form [a-z] or [z-a]. - */ - break; - } - } else if (startChar == ch1) { - break; - } - } - while (*uniPattern != ']') { - if (*uniPattern == 0) { - uniPattern--; - break; - } - uniPattern++; - } - uniPattern++; - continue; - } - - /* - * If the next pattern character is '\', just strip off the '\' so we - * do exact matching on the character that follows. - */ - - if (p == '\\') { - if (*(++uniPattern) == '\0') { - return 0; - } - } - - /* - * There's no special character. Just make sure that the next bytes of - * each string match. - */ - - if (nocase) { - if (Tcl_UniCharToLower(*uniStr) != - Tcl_UniCharToLower(*uniPattern)) { - return 0; - } - } else if (*uniStr != *uniPattern) { - return 0; - } - uniStr++; - uniPattern++; - } -} -#endif /* *---------------------------------------------------------------------- @@ -2892,7 +2533,7 @@ Tcl_UniCharCaseMatch( * * See if a particular Unicode string matches a particular pattern. * Allows case insensitivity. This is the Unicode equivalent of the char* - * Tcl_StringCaseMatch. This variant of Tcl_UniCharCaseMatch uses counted + * Tcl_StringCaseMatch. This variant of TclUniCharCaseMatch uses counted * Strings, so embedded NULLs are allowed. * * Results: diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 30fb89d..05b0599 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -12,6 +12,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include <assert.h> #include "tclInt.h" #include "tclParse.h" #include "tclStringTrim.h" @@ -95,13 +96,6 @@ static ProcessGlobalValue executableName = { #define CONVERT_ANY 16 /* - * The following key is used by Tcl_PrintDouble and TclPrecTraceProc to - * access the precision to be used for double formatting. - */ - -static Tcl_ThreadDataKey precisionKey; - -/* * Prototypes for functions defined later in this file. */ @@ -134,9 +128,17 @@ static const Tcl_ObjType endOffsetType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V1(TclLengthOne) }; +Tcl_Size +TclLengthOne( + TCL_UNUSED(Tcl_Obj *)) +{ + return 1; +} + /* * * STRING REPRESENTATION OF LISTS * * * * @@ -877,7 +879,7 @@ Tcl_SplitList( size = TclMaxListLength(list, TCL_INDEX_NONE, &end) + 1; length = end - list; - argv = (const char **)ckalloc((size * sizeof(char *)) + length + 1); + argv = (const char **)Tcl_Alloc((size * sizeof(char *)) + length + 1); for (i = 0, p = ((char *) argv) + size*sizeof(char *); *list != 0; i++) { @@ -888,14 +890,14 @@ Tcl_SplitList( &elSize, &literal); length -= (list - prevList); if (result != TCL_OK) { - ckfree(argv); + Tcl_Free((void *)argv); return result; } if (*element == 0) { break; } if (i >= size) { - ckfree(argv); + Tcl_Free((void *)argv); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "internal error in Tcl_SplitList", -1)); @@ -1018,7 +1020,7 @@ Tcl_ScanCountedElement( *---------------------------------------------------------------------- */ -TCL_HASH_TYPE +Tcl_Size TclScanElement( const char *src, /* String to convert to Tcl list element. */ Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */ @@ -1034,7 +1036,7 @@ TclScanElement( Tcl_Size extra = 0; /* Count of number of extra bytes needed for * formatted element, assuming we use escape * sequences in formatting. */ - TCL_HASH_TYPE bytesNeeded; /* Buffer length computed to complete the + Tcl_Size bytesNeeded; /* Buffer length computed to complete the * element formatting in the selected mode. */ #if COMPAT int preferEscape = 0; /* Use preferences to track whether to use */ @@ -1176,7 +1178,7 @@ TclScanElement( } endOfString: - if (nestingLevel != 0) { + if (nestingLevel > 0) { /* * Unbalanced braces! Cannot format with brace quoting. */ @@ -1206,7 +1208,7 @@ TclScanElement( bytesNeeded++; } *flagPtr = CONVERT_ESCAPE; - goto overflowCheck; + return bytesNeeded; } if (*flagPtr & CONVERT_ANY) { /* @@ -1254,7 +1256,7 @@ TclScanElement( bytesNeeded += braceCount; } *flagPtr = CONVERT_MASK; - goto overflowCheck; + return bytesNeeded; } #endif /* COMPAT */ if (*flagPtr & TCL_DONT_USE_BRACES) { @@ -1280,7 +1282,7 @@ TclScanElement( bytesNeeded += 2; } *flagPtr = CONVERT_BRACE; - goto overflowCheck; + return bytesNeeded; } /* @@ -1295,11 +1297,6 @@ TclScanElement( bytesNeeded += 2; } *flagPtr = CONVERT_NONE; - - overflowCheck: - if (bytesNeeded > INT_MAX) { - Tcl_Panic("TclScanElement: string length overflow"); - } return bytesNeeded; } @@ -1576,7 +1573,7 @@ Tcl_Merge( #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; Tcl_Size i; - unsigned int bytesNeeded = 0; + size_t bytesNeeded = 0; char *result, *dst; /* @@ -1586,9 +1583,9 @@ Tcl_Merge( if (argc <= 0) { if (argc < 0) { - Tcl_Panic("Tcl_Merge called with negative argc (%d)", argc); + Tcl_Panic("Tcl_Merge called with negative argc (%" TCL_SIZE_MODIFIER "d)", argc); } - result = (char *)ckalloc(1); + result = (char *)Tcl_Alloc(1); result[0] = '\0'; return result; } @@ -1600,17 +1597,11 @@ Tcl_Merge( if (argc <= LOCAL_SIZE) { flagPtr = localFlags; } else { - flagPtr = (char *)ckalloc(argc); + flagPtr = (char *)Tcl_Alloc(argc); } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); bytesNeeded += TclScanElement(argv[i], TCL_INDEX_NONE, &flagPtr[i]); - if (bytesNeeded > INT_MAX) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - } - if (bytesNeeded + argc > INT_MAX + 1U) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += argc; @@ -1618,7 +1609,7 @@ Tcl_Merge( * Pass two: copy into the result area. */ - result = (char *)ckalloc(bytesNeeded); + result = (char *)Tcl_Alloc(bytesNeeded); dst = result; for (i = 0; i < argc; i++) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); @@ -1629,47 +1620,11 @@ Tcl_Merge( dst[-1] = 0; if (flagPtr != localFlags) { - ckfree(flagPtr); + Tcl_Free(flagPtr); } return result; } -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -/* - *---------------------------------------------------------------------- - * - * Tcl_Backslash -- - * - * Figure out how to handle a backslash sequence. - * - * Results: - * The return value is the character that should be substituted in place - * of the backslash sequence that starts at src. If readPtr isn't NULL - * then it is filled in with a count of the number of characters in the - * backslash sequence. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char -Tcl_Backslash( - const char *src, /* Points to the backslash character of a - * backslash sequence. */ - int *readPtr) /* Fill in with number of characters read from - * src, unless NULL. */ -{ - char buf[4] = ""; - Tcl_UniChar ch = 0; - - Tcl_UtfBackslash(src, readPtr, buf); - TclUtfToUniChar(buf, &ch); - return (char) ch; -} -#endif /* !TCL_NO_DEPRECATED */ - /* *---------------------------------------------------------------------- * @@ -1900,7 +1855,7 @@ TclTrim( */ /* The whitespace characters trimmed during [concat] operations */ -#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_TRIM_SET "") - 1) +#define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1) char * Tcl_Concat( @@ -1915,7 +1870,7 @@ Tcl_Concat( */ if (argc == 0) { - result = (char *) ckalloc(1); + result = (char *) Tcl_Alloc(1); result[0] = '\0'; return result; } @@ -1926,7 +1881,7 @@ Tcl_Concat( for (i = 0; i < argc; i++) { bytesNeeded += strlen(argv[i]); - if (bytesNeeded < 0) { + if (bytesNeeded < 0) { Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); } } @@ -1943,7 +1898,7 @@ Tcl_Concat( Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); } - result = (char *)ckalloc(bytesNeeded + argc); + result = (char *)Tcl_Alloc(bytesNeeded + argc); for (p = result, i = 0; i < argc; i++) { Tcl_Size triml, trimr, elemLength; @@ -2022,10 +1977,11 @@ Tcl_ConcatObj( Tcl_Size length; objPtr = objv[i]; - if (TclListObjIsCanonical(objPtr)) { + if (TclListObjIsCanonical(objPtr) || + TclObjTypeHasProc(objPtr,indexProc)) { continue; } - TclGetStringFromObj(objPtr, &length); + (void)Tcl_GetStringFromObj(objPtr, &length); if (length > 0) { break; } @@ -2034,7 +1990,8 @@ Tcl_ConcatObj( resPtr = NULL; for (i = 0; i < objc; i++) { objPtr = objv[i]; - if (!TclListObjIsCanonical(objPtr)) { + if (!TclListObjIsCanonical(objPtr) && + !TclObjTypeHasProc(objPtr,indexProc)) { continue; } if (resPtr) { @@ -2048,8 +2005,10 @@ Tcl_ConcatObj( != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) { /* Abandon ship! */ Tcl_DecrRefCount(resPtr); + Tcl_BounceRefCount(elemPtr); // could be an abstract list element goto slow; } + Tcl_BounceRefCount(elemPtr); // could be an an abstract list element } else { resPtr = TclListObjCopy(NULL, objPtr); } @@ -2069,11 +2028,11 @@ Tcl_ConcatObj( */ for (i = 0; i < objc; i++) { - element = TclGetStringFromObj(objv[i], &elemLength); - bytesNeeded += elemLength; - if (bytesNeeded < 0) { - break; + element = Tcl_GetStringFromObj(objv[i], &elemLength); + if (bytesNeeded > (TCL_SIZE_MAX - elemLength)) { + break; /* Overflow. Do not preallocate. See comment below. */ } + bytesNeeded += elemLength; } /* @@ -2089,7 +2048,7 @@ Tcl_ConcatObj( for (i = 0; i < objc; i++) { Tcl_Size triml, trimr; - element = TclGetStringFromObj(objv[i], &elemLength); + element = Tcl_GetStringFromObj(objv[i], &elemLength); /* Trim away the leading/trailing whitespace. */ triml = TclTrim(element, elemLength, CONCAT_TRIM_SET, @@ -2121,35 +2080,6 @@ Tcl_ConcatObj( return resPtr; } -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -/* - *---------------------------------------------------------------------- - * - * Tcl_StringMatch -- - * - * See if a particular string matches a particular pattern. - * - * Results: - * The return value is 1 if string matches pattern, and 0 otherwise. The - * matching operation permits the following special characters in the - * pattern: *?\[] (see the manual entry for details on what these mean). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_StringMatch -int -Tcl_StringMatch( - const char *str, /* String. */ - const char *pattern) /* Pattern, which may contain special - * characters. */ -{ - return Tcl_StringCaseMatch(str, pattern, 0); -} -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * @@ -2589,7 +2519,7 @@ TclStringMatchObj( * 0. */ { int match; - Tcl_Size length, plen; + Tcl_Size length = 0, plen = 0; /* * Promote based on the type of incoming object. @@ -2598,18 +2528,18 @@ TclStringMatchObj( trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj)); */ - if (TclHasInternalRep(strObj, &tclUniCharStringType) || (strObj->typePtr == NULL)) { + if (TclHasInternalRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; - udata = TclGetUnicodeFromObj(strObj, &length); - uptn = TclGetUnicodeFromObj(ptnObj, &plen); + udata = Tcl_GetUnicodeFromObj(strObj, &length); + uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); } else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj) && !flags) { unsigned char *data, *ptn; - data = Tcl_GetByteArrayFromObj(strObj, &length); - ptn = Tcl_GetByteArrayFromObj(ptnObj, &plen); + data = Tcl_GetBytesFromObj(NULL, strObj, &length); + ptn = Tcl_GetBytesFromObj(NULL, ptnObj, &plen); match = TclByteArrayMatch(data, length, ptn, plen, 0); } else { match = Tcl_StringCaseMatch(TclGetString(strObj), @@ -2668,9 +2598,9 @@ char * Tcl_DStringAppend( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ const char *bytes, /* String to append. If length is - * < 0 then this must be null-terminated. */ + * TCL_INDEX_NONE then this must be null-terminated. */ Tcl_Size length) /* Number of bytes from "bytes" to append. If - * < 0, then append all of bytes, up to null + * TCL_INDEX_NONE, then append all of bytes, up to null * at end. */ { Tcl_Size newSize; @@ -2678,19 +2608,20 @@ Tcl_DStringAppend( if (length < 0) { length = strlen(bytes); } - newSize = length + dsPtr->length; - /* - * Allocate a larger buffer for the string if the current one isn't large - * enough. Allocate extra space in the new buffer so that there will be - * room to grow before we have to allocate again. - */ + if (length > (TCL_SIZE_MAX - dsPtr->length - 1)) { + Tcl_Panic("max size for a Tcl value (%" TCL_SIZE_MODIFIER + "d bytes) exceeded", + TCL_SIZE_MAX); + return NULL; /* NOTREACHED */ + } + newSize = length + dsPtr->length + 1; - if (newSize >= dsPtr->spaceAvl) { - dsPtr->spaceAvl = newSize * 2; - if (dsPtr->string == dsPtr->staticSpace) { - char *newString = (char *)ckalloc(dsPtr->spaceAvl); + if (newSize > dsPtr->spaceAvl) { + if (dsPtr->string == dsPtr->staticSpace) { + char *newString; + newString = (char *) TclAllocEx(newSize, &dsPtr->spaceAvl); memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { @@ -2703,7 +2634,7 @@ Tcl_DStringAppend( offset = bytes - dsPtr->string; } dsPtr->string = - (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl); + (char *)TclReallocEx(dsPtr->string, newSize, &dsPtr->spaceAvl); if (offset >= 0) { bytes = dsPtr->string + offset; } @@ -2737,7 +2668,7 @@ TclDStringAppendObj( Tcl_Obj *objPtr) { Tcl_Size length; - const char *bytes = TclGetStringFromObj(objPtr, &length); + const char *bytes = Tcl_GetStringFromObj(objPtr, &length); return Tcl_DStringAppend(dsPtr, bytes, length); } @@ -2817,12 +2748,10 @@ Tcl_DStringAppendElement( * memcpy, not strcpy, to copy the string to a larger buffer, since there * may be embedded NULLs in the string in some cases. */ - - if (newSize >= dsPtr->spaceAvl) { - dsPtr->spaceAvl = newSize * 2; + newSize += 1; /* For terminating nul */ + if (newSize > dsPtr->spaceAvl) { if (dsPtr->string == dsPtr->staticSpace) { - char *newString = (char *)ckalloc(dsPtr->spaceAvl); - + char *newString = (char *) TclAllocEx(newSize, &dsPtr->spaceAvl); memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { @@ -2835,7 +2764,7 @@ Tcl_DStringAppendElement( offset = element - dsPtr->string; } dsPtr->string = - (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl); + (char *)TclReallocEx(dsPtr->string, newSize, &dsPtr->spaceAvl); if (offset >= 0) { element = dsPtr->string + offset; } @@ -2872,8 +2801,7 @@ Tcl_DStringAppendElement( * * Side effects: * The length of dsPtr is changed to length and a null byte is stored at - * that position in the string. If length is larger than the space - * allocated for dsPtr, then a panic occurs. + * that position in the string. * *---------------------------------------------------------------------- */ @@ -2895,25 +2823,28 @@ Tcl_DStringSetLength( * would be wasteful to overallocate that buffer, so we just allocate * enough for the requested size plus the trailing null byte. In the * second case, we are growing the buffer incrementally, so we need - * behavior similar to Tcl_DStringAppend. The requested length will - * usually be a small delta above the current spaceAvl, so we'll end - * up doubling the old size. This won't grow the buffer quite as - * quickly, but it should be close enough. + * behavior similar to Tcl_DStringAppend. + * TODO - the above makes no sense to me. How does the code below + * translate into distinguishing the two cases above? IMO, if caller + * specifically sets the length, there is no cause for overallocation. */ - newsize = dsPtr->spaceAvl * 2; + if (length >= TCL_SIZE_MAX) { + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); + } + newsize = TclUpsizeAlloc(dsPtr->spaceAvl, length + 1, TCL_SIZE_MAX); if (length < newsize) { dsPtr->spaceAvl = newsize; } else { dsPtr->spaceAvl = length + 1; } if (dsPtr->string == dsPtr->staticSpace) { - char *newString = (char *)ckalloc(dsPtr->spaceAvl); + char *newString = (char *)Tcl_Alloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl); + dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl); } } dsPtr->length = length; @@ -2943,7 +2874,7 @@ Tcl_DStringFree( Tcl_DString *dsPtr) /* Structure describing dynamic string. */ { if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); + Tcl_Free(dsPtr->string); } dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; @@ -3005,86 +2936,12 @@ Tcl_DStringGetResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { -#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 Tcl_Obj *obj = Tcl_GetObjResult(interp); const char *bytes = TclGetString(obj); Tcl_DStringFree(dsPtr); Tcl_DStringAppend(dsPtr, bytes, obj->length); Tcl_ResetResult(interp); -#else - Interp *iPtr = (Interp *) interp; - - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); - } - - /* - * Do more efficient transfer when we know the result is a Tcl_Obj. When - * there's no string result, we only have to deal with two cases: - * - * 1. When the string rep is the empty string, when we don't copy but - * instead use the staticSpace in the DString to hold an empty string. - - * 2. When the string rep is not there or there's a real string rep, when - * we use Tcl_GetString to fetch (or generate) the string rep - which - * we know to have been allocated with ckalloc() - and use it to - * populate the DString space. Then, we free the internal rep. and set - * the object's string representation back to the canonical empty - * string. - */ - - if (!iPtr->result[0] && iPtr->objResultPtr - && !Tcl_IsShared(iPtr->objResultPtr)) { - if (iPtr->objResultPtr->bytes == &tclEmptyString) { - dsPtr->string = dsPtr->staticSpace; - dsPtr->string[0] = 0; - dsPtr->length = 0; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - } else { - dsPtr->string = TclGetString(iPtr->objResultPtr); - dsPtr->length = iPtr->objResultPtr->length; - dsPtr->spaceAvl = dsPtr->length + 1; - TclFreeInternalRep(iPtr->objResultPtr); - iPtr->objResultPtr->bytes = &tclEmptyString; - iPtr->objResultPtr->length = 0; - } - return; - } - - /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - - dsPtr->length = strlen(iPtr->result); - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - dsPtr->string = iPtr->result; - dsPtr->spaceAvl = dsPtr->length+1; - } else { - dsPtr->string = (char *)ckalloc(dsPtr->length+1); - memcpy(dsPtr->string, iPtr->result, dsPtr->length+1); - iPtr->freeProc(iPtr->result); - } - dsPtr->spaceAvl = dsPtr->length+1; - iPtr->freeProc = NULL; - } else { - if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { - dsPtr->string = dsPtr->staticSpace; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - } else { - dsPtr->string = (char *)ckalloc(dsPtr->length+1); - dsPtr->spaceAvl = dsPtr->length + 1; - } - memcpy(dsPtr->string, iPtr->result, dsPtr->length+1); - } - - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; -#endif /* !TCL_NO_DEPRECATED */ } /* @@ -3210,10 +3067,9 @@ Tcl_DStringEndSublist( * string using. * * Results: - * The ASCII equivalent of "value" is written at "dst". It is written - * using the current precision, and it is guaranteed to contain a decimal - * point or exponent, so that it looks like a floating-point value and - * not an integer. + * The ASCII equivalent of "value" is written at "dst". It is guaranteed + * to contain a decimal point or exponent, so that it looks like a + * floating-point value and not an integer. * * Side effects: * None. @@ -3233,7 +3089,6 @@ Tcl_PrintDouble( int signum; char *digits; char *end; - int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int)); /* * Handle NaN. @@ -3265,53 +3120,8 @@ Tcl_PrintDouble( * Ordinary (normal and denormal) values. */ - if (*precisionPtr == 0) { - digits = TclDoubleDigits(value, TCL_INDEX_NONE, TCL_DD_SHORTEST, - &exponent, &signum, &end); - } else { - /* - * There are at least two possible interpretations for tcl_precision. - * - * The first is, "choose the decimal representation having - * $tcl_precision digits of significance that is nearest to the given - * number, breaking ties by rounding to even, and then trimming - * trailing zeros." This gives the greatest possible precision in the - * decimal string, but offers the anomaly that [expr 0.1] will be - * "0.10000000000000001". - * - * The second is "choose the decimal representation having at most - * $tcl_precision digits of significance that is nearest to the given - * number. If no such representation converts exactly to the given - * number, choose the one that is closest, breaking ties by rounding - * to even. If more than one such representation converts exactly to - * the given number, choose the shortest, breaking ties in favour of - * the nearest, breaking remaining ties in favour of the one ending in - * an even digit." - * - * Tcl 8.4 implements the first of these, which gives rise to - * anomalies in formatting: - * - * % expr 0.1 - * 0.10000000000000001 - * % expr 0.01 - * 0.01 - * % expr 1e-7 - * 9.9999999999999995e-08 - * - * For human readability, it appears better to choose the second rule, - * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer - * the first (the recommended zero value for tcl_precision avoids the - * problem entirely). - * - * Uncomment TCL_DD_SHORTEST in the next call to prefer the method - * that allows floating point values to be shortened if it can be done - * without loss of precision. - */ - - digits = TclDoubleDigits(value, *precisionPtr, - TCL_DD_E_FORMAT /* | TCL_DD_SHORTEST */, - &exponent, &signum, &end); - } + digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, + &exponent, &signum, &end); if (signum) { *dst++ = '-'; } @@ -3331,16 +3141,7 @@ Tcl_PrintDouble( } } - /* - * Tcl 8.4 appears to format with at least a two-digit exponent; - * preserve that behaviour when tcl_precision != 0 - */ - - if (*precisionPtr == 0) { - snprintf(dst, TCL_DOUBLE_SPACE, "e%+d", exponent); - } else { - snprintf(dst, TCL_DOUBLE_SPACE, "e%+03d", exponent); - } + snprintf(dst, TCL_DOUBLE_SPACE, "e%+d", exponent); } else { /* * F format for others. @@ -3372,87 +3173,8 @@ Tcl_PrintDouble( } *dst++ = '\0'; } - ckfree(digits); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrecTraceProc -- - * - * This function is invoked whenever the variable "tcl_precision" is - * written. - * - * Results: - * Returns NULL if all went well, or an error message if the new value - * for the variable doesn't make sense. - * - * Side effects: - * If the new value doesn't make sense then this function undoes the - * effect of the variable modification. Otherwise it modifies the format - * string that's used by Tcl_PrintDouble. - * - *---------------------------------------------------------------------- - */ - -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -char * -TclPrecTraceProc( - void *clientData, - Tcl_Interp *interp, /* Interpreter containing variable. */ - const char *name1, /* Name of variable. */ - const char *name2, /* Second part of variable name. */ - int flags) /* Information about what happened. */ -{ - Tcl_Obj *value; - Tcl_WideInt prec; - int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int)); - - /* - * If the variable is unset, then recreate the trace. - */ - - if (flags & TCL_TRACE_UNSETS) { - if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) { - Tcl_TraceVar2(interp, name1, name2, - TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES - |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); - } - return NULL; - } - - /* - * When the variable is read, reset its value from our shared value. This - * is needed in case the variable was modified in some other interpreter - * so that this interpreter's value is out of date. - */ - - - if (flags & TCL_TRACE_READS) { - Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewWideIntObj(*precisionPtr), - flags & TCL_GLOBAL_ONLY); - return NULL; - } - - /* - * The variable is being written. Check the new value and disallow it if - * it isn't reasonable or if this is a safe interpreter (we don't want - * safe interpreters messing up the precision of other interpreters). - */ - - if (Tcl_IsSafe(interp)) { - return (char *) "can't modify precision from a safe interpreter"; - } - value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); - if (value == NULL - || Tcl_GetWideIntFromObj(NULL, value, &prec) != TCL_OK - || prec < 0 || prec > TCL_MAX_PREC) { - return (char *) "improper value for precision"; - } - *precisionPtr = (int)prec; - return NULL; + Tcl_Free(digits); } -#endif /* !TCL_NO_DEPRECATED)*/ /* *---------------------------------------------------------------------- @@ -3656,7 +3378,7 @@ GetWideForIndex( if (numType == TCL_NUMBER_INT) { /* objPtr holds an integer in the signed wide range */ *widePtr = *(Tcl_WideInt *)cd; - if ((*widePtr < 0)) { + if ((*widePtr < 0)) { *widePtr = (endValue == -1) ? WIDE_MIN : -1; } return TCL_OK; @@ -3664,7 +3386,7 @@ GetWideForIndex( if (numType == TCL_NUMBER_BIG) { /* objPtr holds an integer outside the signed wide range */ /* Truncate to the signed wide range. */ - *widePtr = ((mp_isneg((mp_int *)cd)) ? ((endValue == -1) ? WIDE_MIN : -1) : WIDE_MAX); + *widePtr = ((mp_isneg((mp_int *)cd)) ? WIDE_MIN : WIDE_MAX); return TCL_OK; } } @@ -3686,12 +3408,14 @@ GetWideForIndex( * (0..TCL_SIZE_MAX) it is returned. Higher values are returned as * TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1). * + * Callers should pass reasonable values for endValue - one in the + * valid index range or TCL_INDEX_NONE (-1), for example for an empty + * list. * * Results: * TCL_OK * - * The index is stored at the address given by by 'indexPtr'. If - * 'objPtr' has the value "end", the value stored is 'endValue'. + * The index is stored at the address given by by 'indexPtr'. * * TCL_ERROR * @@ -3699,10 +3423,9 @@ GetWideForIndex( * 'interp' is non-NULL, an error message is left in the interpreter's * result object. * - * Effect + * Side effects: * - * The object referenced by 'objPtr' is converted, as needed, to an - * integer, wide integer, or end-based-index object. + * The internal representation contained within objPtr may shimmer. * *---------------------------------------------------------------------- */ @@ -3724,14 +3447,17 @@ Tcl_GetIntForIndex( return TCL_ERROR; } if (indexPtr != NULL) { - if ((wide < 0) && (endValue >= 0)) { - *indexPtr = TCL_INDEX_NONE; - } else if (wide > INT_MAX) { - *indexPtr = INT_MAX; - } else if (wide < INT_MIN) { - *indexPtr = INT_MIN; - } else { - *indexPtr = (int) wide; + /* Note: check against TCL_SIZE_MAX needed for 32-bit builds */ + if (wide >= 0 && wide <= TCL_SIZE_MAX) { + *indexPtr = (Tcl_Size)wide; /* A valid index */ + } else if (wide > TCL_SIZE_MAX) { + *indexPtr = TCL_SIZE_MAX; /* Beyond max possible index */ + } else if (wide < -1-TCL_SIZE_MAX) { + *indexPtr = -1-TCL_SIZE_MAX; /* Below most negative index */ + } else if ((wide < 0) && (endValue >= 0)) { + *indexPtr = TCL_INDEX_NONE; /* No clue why this special case */ + } else { + *indexPtr = (Tcl_Size) wide; } } return TCL_OK; @@ -3782,7 +3508,7 @@ GetEndOffsetFromObj( while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) { Tcl_ObjInternalRep ir; Tcl_Size length; - const char *bytes = TclGetStringFromObj(objPtr, &length); + const char *bytes = Tcl_GetStringFromObj(objPtr, &length); if (*bytes != 'e') { int numType; @@ -3971,17 +3697,27 @@ GetEndOffsetFromObj( offset = irPtr->wideValue; if (offset == WIDE_MAX) { + /* + * Encodes end+1. This is distinguished from end+n as noted + * in function header. + * NOTE: this may wrap around if the caller passes (as lset does) + * listLen-1 as endValue and and listLen is 0. The -1 will be + * interpreted as FF...FF and adding 1 will result in 0 which + * is what we want. Callers like lset which pass in listLen-1 == -1 + * as endValue will have to adjust accordingly. + */ *widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1; } else if (offset == WIDE_MIN) { + /* -1 - position before first */ *widePtr = -1; - } else if (endValue == -1) { - *widePtr = offset; } else if (offset < 0) { - /* Different signs, sum cannot overflow */ + /* end-(n-1) - Different signs, sum cannot overflow */ *widePtr = endValue + offset + 1; } else if (offset < WIDE_MAX) { + /* 0:WIDE_MAX-1 - plain old index. */ *widePtr = offset; } else { + /* Huh, what case remains here? */ *widePtr = WIDE_MAX; } return TCL_OK; @@ -3996,7 +3732,6 @@ GetEndOffsetFromObj( if (!strncmp(bytes, "end-", 4)) { bytes += 4; } - TclCheckBadOctal(interp, bytes); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", (void *)NULL); } @@ -4007,19 +3742,26 @@ GetEndOffsetFromObj( *---------------------------------------------------------------------- * * TclIndexEncode -- + * IMPORTANT: function only encodes indices in the range that fits within + * an "int" type. Do NOT change this as the byte code compiler and engine + * which call this function cannot handle wider index types. Indices + * outside the range will result in the function returning an error. * * Parse objPtr to determine if it is an index value. Two cases * are possible. The value objPtr might be parsed as an absolute - * index value in the C signed int range. Note that this includes + * index value in the Tcl_Size range. Note that this includes * index values that are integers as presented and it includes index - * arithmetic expressions. The absolute index values that can be + * arithmetic expressions. + * + * The largest string supported in Tcl 8 has byte length TCL_SIZE_MAX. + * This means the largest supported character length is also TCL_SIZE_MAX, + * and the index of the last character in a string of length TCL_SIZE_MAX + * is TCL_SIZE_MAX-1. Thus the absolute index values that can be * directly meaningful as an index into either a list or a string are - * those integer values >= TCL_INDEX_START (0) - * and < INT_MAX. - * The largest string supported in Tcl 8 has bytelength INT_MAX. - * This means the largest supported character length is also INT_MAX, - * and the index of the last character in a string of length INT_MAX - * is INT_MAX-1. + * integer values in the range 0 to TCL_SIZE_MAX - 1. + * + * This function however can only handle integer indices in the range + * 0 : INT_MAX-1. * * Any absolute index value parsed outside that range is encoded * using the before and after values passed in by the @@ -4045,7 +3787,8 @@ GetEndOffsetFromObj( * they can be encoded with the before value. * * Returns: - * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. + * TCL_OK if parsing succeeded, and TCL_ERROR if it failed or the + * index does not fit in an int type. * * Side effects: * When TCL_OK is returned, the encoded index value is written @@ -4058,41 +3801,133 @@ int TclIndexEncode( Tcl_Interp *interp, /* For error reporting, may be NULL */ Tcl_Obj *objPtr, /* Index value to parse */ - Tcl_Size before, /* Value to return for index before beginning */ - Tcl_Size after, /* Value to return for index after end */ + int before, /* Value to return for index before beginning */ + int after, /* Value to return for index after end */ int *indexPtr) /* Where to write the encoded answer, not NULL */ { Tcl_WideInt wide; int idx; + const Tcl_WideInt ENDVALUE = 2 * (Tcl_WideInt) INT_MAX; + + assert(ENDVALUE < WIDE_MAX); + if (TCL_OK != GetWideForIndex(interp, objPtr, ENDVALUE, &wide)) { + return TCL_ERROR; + } + /* + * We passed 2*INT_MAX as the "end value" to GetWideForIndex. The computed + * index will be in one of the following ranges that need to be + * distinguished for encoding purposes in the following code. + * (1) 0:INT_MAX when + * (a) objPtr was a pure non-negative numeric value in that range + * (b) objPtr was a numeric computation M+/-N with a result in that range + * (c) objPtr was of the form end-N where N was in range INT_MAX:2*INT_MAX + * (2) INT_MAX+1:2*INT_MAX when + * (a,b) as above + * (c) objPtr was of the form end-N where N was in range 0:INT_MAX-1 + * (3) 2*INT_MAX:WIDE_MAX when + * (a,b) as above + * (c) objPtr was of the form end+N + * (4) (2*INT_MAX)-TCL_SIZE_MAX : -1 when + * (a,b) as above + * (c) objPtr was of the form end-N where N was in the range 0:TCL_SIZE_MAX + * (5) WIDE_MIN:(2*INT_MAX)-TCL_SIZE_MAX + * (a,b) as above + * (c) objPtr was of the form end-N where N was > TCL_SIZE_MAX + * + * For all cases (b) and (c), the internal representation of objPtr + * will be shimmered to endOffsetType. That allows us to distinguish between + * (for example) 1a (encodable) and 1c (not encodable) though the computed + * index value is the same. + * + * Further note, the values TCL_SIZE_MAX < N < WIDE_MAX come into play + * only in the 32-bit builds as TCL_SIZE_MAX == WIDE_MAX for 64-bits. + */ + + const Tcl_ObjInternalRep *irPtr = + TclFetchInternalRep(objPtr, &endOffsetType); + + if (irPtr && irPtr->wideValue >= 0) { + /* + * "int[+-]int" syntax, works the same here as "int". + * Note same does not hold for negative integers. + * Distinguishes 1b and 1c where wide will be in 0:INT_MAX for + * both but irPtr->wideValue will be negative for 1c. + */ + irPtr = NULL; + } + + if (irPtr == NULL) { + /* objPtr can be treated as a purely numeric value. */ - if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &endOffsetType); - if (irPtr && irPtr->wideValue >= 0) { - /* "int[+-]int" syntax, works the same here as "int" */ - irPtr = NULL; + /* + * On 64-bit systems, indices in the range INT_MAX:TCL_SIZE_MAX are + * valid indices but are not in the encodable range. Thus an + * error is raised. On 32-bit systems, indices in that range indicate + * the position after the end and so do not raise an error. + */ + if ((sizeof(int) != sizeof(Tcl_Size)) && + (wide > INT_MAX) && (wide < WIDE_MAX-1)) { + /* 2(a,b) on 64-bit systems*/ + goto rangeerror; + } + if (wide > INT_MAX) { + /* + * 3(a,b) on 64-bit systems and 2(a,b), 3(a,b) on 32-bit systems + * Because of the check above, this case holds for indices + * greater than INT_MAX on 32-bit systems and > TCL_SIZE_MAX + * on 64-bit systems. Always maps to the element after the end. + */ + idx = after; + } else if (wide < 0) { + /* 4(a,b) (32-bit systems), 5(a,b) - before the beginning */ + idx = before; + } else { + /* 1(a,b) Encodable range */ + idx = (int)wide; } + } else { + /* objPtr is not purely numeric (end etc.) */ + /* - * We parsed an end+offset index value. - * wide holds the offset value in the range WIDE_MIN...WIDE_MAX. + * On 64-bit systems, indices in the range end-LIST_MAX:end-INT_MAX + * are valid indices (with max size strings/lists) but are not in + * the encodable range. Thus an error is raised. On 32-bit systems, + * indices in that range indicate the position before the beginning + * and so do not raise an error. */ - if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) { + if ((sizeof(int) != sizeof(Tcl_Size)) && + (wide > (ENDVALUE - LIST_MAX)) && (wide <= INT_MAX)) { + /* 1(c), 4(a,b) on 64-bit systems */ + goto rangeerror; + } + if (wide > ENDVALUE) { /* - * All end+postive or end-negative expressions + * 2(c) (32-bit systems), 3(c) + * All end+positive or end-negative expressions * always indicate "after the end". + * Note we will not reach here for a pure numeric value in this + * range because irPtr will be NULL in that case. */ idx = after; - } else if (wide <= (irPtr ? INT_MAX : TCL_INDEX_NONE)) { - /* These indices always indicate "before the beginning" */ + } else if (wide <= INT_MAX) { + /* 1(c) (32-bit systems), 4(c) (32-bit systems), 5(c) */ idx = before; } else { - /* Encoded end-positive (or end+negative) are offset */ + /* 2(c) Encodable end-positive (or end+negative) */ idx = (int)wide; } - } else { - return TCL_ERROR; } *indexPtr = idx; return TCL_OK; + +rangeerror: + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("index \"%s\" out of range", TclGetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", (void *)NULL); + } + return TCL_ERROR; } /* @@ -4126,70 +3961,43 @@ TclIndexDecode( } /* - *---------------------------------------------------------------------- + *------------------------------------------------------------------------ * - * TclCheckBadOctal -- + * TclCommandWordLimitErrpr -- * - * This function checks for a bad octal value and appends a meaningful - * error to the interp's result. + * Generates an error message limit on number of command words exceeded. * * Results: - * 1 if the argument was a bad octal, else 0. + * Always return TCL_ERROR. * * Side effects: - * The interpreter's result is modified. + * If interp is not-NULL, an error message is stored in it. * - *---------------------------------------------------------------------- + *------------------------------------------------------------------------ */ - int -TclCheckBadOctal( - Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, then no error message is left after - * errors. */ - const char *value) /* String to check. */ +TclCommandWordLimitError ( + Tcl_Interp *interp, /* May be NULL */ + Tcl_Size count) /* If <= 0, "unknown" */ { - const char *p = value; - - /* - * A frequent mistake is invalid octal values due to an unwanted leading - * zero. Try to generate a meaningful error message. - */ - - while (TclIsSpaceProcM(*p)) { - p++; - } - if (*p == '+' || *p == '-') { - p++; - } - if (*p == '0') { - if ((p[1] == 'o') || p[1] == 'O') { - p += 2; - } - while (isdigit(UCHAR(*p))) { /* INTL: digit. */ - p++; - } - while (TclIsSpaceProcM(*p)) { - p++; + if (interp) { + if (count > 0) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("Number of words (%" TCL_SIZE_MODIFIER + "d) in command exceeds limit %" TCL_SIZE_MODIFIER + "d.", + count, + (Tcl_Size)INT_MAX)); } - if (*p == '\0') { - /* - * Reached end of string. - */ - - if (interp != NULL) { - /* - * Don't reset the result here because we want this result to - * be added to an existing error message as extra info. - */ - - Tcl_AppendToObj(Tcl_GetObjResult(interp), - " (looks like invalid octal number)", TCL_INDEX_NONE); - } - return 1; + else { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Number of words in command exceeds " + "limit %" TCL_SIZE_MODIFIER "d.", + (Tcl_Size)INT_MAX)); } } - return 0; + return TCL_ERROR; /* Always */ } /* @@ -4244,7 +4052,7 @@ GetThreadHash( (Tcl_HashTable **)Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *)); if (NULL == *tablePtrPtr) { - *tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + *tablePtrPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr); Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS); } @@ -4273,7 +4081,7 @@ FreeThreadHash( ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); - ckfree(tablePtr); + Tcl_Free(tablePtr); } /* @@ -4295,7 +4103,7 @@ FreeProcessGlobalValue( pgvPtr->epoch++; pgvPtr->numBytes = 0; - ckfree(pgvPtr->value); + Tcl_Free(pgvPtr->value); pgvPtr->value = NULL; if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); @@ -4334,13 +4142,13 @@ TclSetProcessGlobalValue( pgvPtr->epoch++; if (NULL != pgvPtr->value) { - ckfree(pgvPtr->value); + Tcl_Free(pgvPtr->value); } else { Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } bytes = TclGetString(newValue); pgvPtr->numBytes = newValue->length; - pgvPtr->value = (char *)ckalloc(pgvPtr->numBytes + 1); + pgvPtr->value = (char *)Tcl_Alloc(pgvPtr->numBytes + 1); memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); @@ -4398,13 +4206,14 @@ TclGetProcessGlobalValue( Tcl_MutexLock(&pgvPtr->mutex); epoch = ++pgvPtr->epoch; - Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, - pgvPtr->numBytes, &native); - Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), - Tcl_DStringLength(&native), &newValue); + Tcl_UtfToExternalDStringEx(NULL, pgvPtr->encoding, pgvPtr->value, + pgvPtr->numBytes, TCL_ENCODING_PROFILE_TCL8, &native, NULL); + Tcl_ExternalToUtfDStringEx(NULL, current, Tcl_DStringValue(&native), + Tcl_DStringLength(&native), TCL_ENCODING_PROFILE_TCL8, + &newValue, NULL); Tcl_DStringFree(&native); - ckfree(pgvPtr->value); - pgvPtr->value = (char *)ckalloc(Tcl_DStringLength(&newValue) + 1); + Tcl_Free(pgvPtr->value); + pgvPtr->value = (char *)Tcl_Alloc(Tcl_DStringLength(&newValue) + 1); memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); @@ -4544,31 +4353,6 @@ Tcl_GetNameOfExecutable(void) /* *---------------------------------------------------------------------- * - * TclpGetTime -- - * - * Deprecated synonym for Tcl_GetTime. This function is provided for the - * benefit of extensions written before Tcl_GetTime was exported from the - * library. - * - * Results: - * None. - * - * Side effects: - * Stores current time in the buffer designated by "timePtr" - * - *---------------------------------------------------------------------- - */ - -void -TclpGetTime( - Tcl_Time *timePtr) -{ - Tcl_GetTime(timePtr); -} - -/* - *---------------------------------------------------------------------- - * * TclGetPlatform -- * * This is a kludge that allows the test library to get access the diff --git a/generic/tclVar.c b/generic/tclVar.c index 3007296..125091a 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -128,6 +128,8 @@ static const char BADNAMESPACE[] = "parent namespace doesn't exist"; static const char MISSINGNAME[] = "missing variable name"; static const char ISARRAYELEMENT[] = "name refers to an element in an array"; +static const char ISCONST[] = "variable is a constant"; +static const char EXISTS[] = "variable already exists"; /* * A test to see if we are in a call frame that has local variables. This is @@ -178,7 +180,8 @@ typedef struct ArrayVarHashTable { */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Obj *patternPtr, int includeLinks); + Tcl_Obj *patternPtr, int includeLinks, + int justConstants); static void ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr); @@ -245,7 +248,8 @@ static Tcl_DupInternalRepProc DupParsedVarName; static const Tcl_ObjType localVarNameType = { "localVarName", - FreeLocalVarName, DupLocalVarName, NULL, NULL + FreeLocalVarName, DupLocalVarName, NULL, NULL, + TCL_OBJTYPE_V0 }; #define LocalSetInternalRep(objPtr, index, namePtr) \ @@ -268,7 +272,8 @@ static const Tcl_ObjType localVarNameType = { static const Tcl_ObjType parsedVarNameType = { "parsedVarName", - FreeParsedVarName, DupParsedVarName, NULL, NULL + FreeParsedVarName, DupParsedVarName, NULL, NULL, + TCL_OBJTYPE_V0 }; #define ParsedSetInternalRep(objPtr, arrayPtr, elem) \ @@ -337,7 +342,7 @@ NotArrayError( Tcl_Interp *interp, Tcl_Obj *name) { - const char *nameStr = Tcl_GetString(name); + const char *nameStr = TclGetString(name); Tcl_SetObjResult(interp, Tcl_ObjPrintf("\"%s\" isn't an array", nameStr)); @@ -379,7 +384,7 @@ CleanupVar( && (VarHashRefCount(varPtr) == (Tcl_Size) !TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { - ckfree(varPtr); + Tcl_Free(varPtr); } else { VarHashDeleteEntry(varPtr); } @@ -389,7 +394,7 @@ CleanupVar( (VarHashRefCount(arrayPtr) == (Tcl_Size) !TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { - ckfree(arrayPtr); + Tcl_Free(arrayPtr); } else { VarHashDeleteEntry(arrayPtr); } @@ -660,7 +665,7 @@ TclObjLookupVarEx( */ Tcl_Size len; - const char *part1 = TclGetStringFromObj(part1Ptr, &len); + const char *part1 = Tcl_GetStringFromObj(part1Ptr, &len); if ((len > 1) && (part1[len - 1] == ')')) { const char *part2 = strchr(part1, '('); @@ -843,7 +848,7 @@ TclLookupSimpleVar( ResolverScheme *resPtr; int isNew, result; Tcl_Size i, varLen; - const char *varName = TclGetStringFromObj(varNamePtr, &varLen); + const char *varName = Tcl_GetStringFromObj(varNamePtr, &varLen); varPtr = NULL; varNsPtr = NULL; /* Set non-NULL if a nonlocal variable. */ @@ -915,12 +920,8 @@ TclLookupSimpleVar( *indexPtr = -1; flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; } else { - if (flags & TCL_AVOID_RESOLVERS) { - flags = (flags | TCL_NAMESPACE_ONLY); - } - if (flags & TCL_NAMESPACE_ONLY) { - *indexPtr = -2; - } + flags = (flags | TCL_NAMESPACE_ONLY); + *indexPtr = -2; } /* @@ -982,7 +983,7 @@ TclLookupSimpleVar( Tcl_Obj *objPtr = *objPtrPtr; if (objPtr) { - localNameStr = TclGetStringFromObj(objPtr, &localLen); + localNameStr = Tcl_GetStringFromObj(objPtr, &localLen); if ((varLen == localLen) && (varName[0] == localNameStr[0]) && !memcmp(varName, localNameStr, varLen)) { @@ -995,8 +996,9 @@ TclLookupSimpleVar( tablePtr = varFramePtr->varTablePtr; if (create) { if (tablePtr == NULL) { - tablePtr = (TclVarHashTable *)ckalloc(sizeof(TclVarHashTable)); + tablePtr = (TclVarHashTable *)Tcl_Alloc(sizeof(TclVarHashTable)); TclInitVarHashTable(tablePtr, NULL); + tablePtr->arrayPtr = varPtr; varFramePtr->varTablePtr = tablePtr; } varPtr = VarHashCreateVar(tablePtr, varNamePtr, &isNew); @@ -1143,51 +1145,6 @@ TclLookupArrayElement( /* *---------------------------------------------------------------------- * - * Tcl_GetVar -- - * - * Return the value of a Tcl variable as a string. - * - * Results: - * The return value points to the current value of varName as a string. - * If the variable is not defined or can't be read because of a clash in - * array usage then a NULL pointer is returned and an error message is - * left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set. - * Note: the return value is only valid up until the next change to the - * variable; if you depend on the value lasting longer than that, then - * make yourself a private copy. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_GetVar -const char * -Tcl_GetVar( - Tcl_Interp *interp, /* Command interpreter in which varName is to - * be looked up. */ - const char *varName, /* Name of a variable in interp. */ - int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG - * bits. */ -{ - Tcl_Obj *varNamePtr = Tcl_NewStringObj(varName, -1); - Tcl_Obj *resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags); - - TclDecrRefCount(varNamePtr); - - if (resultPtr == NULL) { - return NULL; - } - return TclGetString(resultPtr); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_GetVar2 -- * * Return the value of a Tcl variable as a string, given a two-part name @@ -1433,6 +1390,9 @@ TclPtrGetVarIdx( { Interp *iPtr = (Interp *) interp; const char *msg; + Var *initialArrayPtr = arrayPtr; + + TclVarFindHiddenArray(varPtr, arrayPtr); /* * Invoke any read traces that have been set for the variable. @@ -1479,8 +1439,8 @@ TclPtrGetVarIdx( } if (flags & TCL_LEAVE_ERR_MSG) { - if (TclIsVarUndefined(varPtr) && arrayPtr - && !TclIsVarUndefined(arrayPtr)) { + if (TclIsVarUndefined(varPtr) && initialArrayPtr + && !TclIsVarUndefined(initialArrayPtr)) { msg = NOSUCHELEMENT; } else if (TclIsVarArray(varPtr)) { msg = ISARRAY; @@ -1553,53 +1513,6 @@ Tcl_SetObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_SetVar -- - * - * Change the value of a variable. - * - * Results: - * Returns a pointer to the malloc'ed string which is the character - * representation of the variable's new value. The caller must not modify - * this string. If the write operation was disallowed then NULL is - * returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory - * message will be left in the interp's result. Note that the returned - * string may not be the same as newValue; this is because variable - * traces may modify the variable's value. - * - * Side effects: - * If varName is defined as a local or global variable in interp, its - * value is changed to newValue. If varName isn't currently defined, then - * a new global variable by that name is created. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_SetVar -const char * -Tcl_SetVar( - Tcl_Interp *interp, /* Command interpreter in which varName is to - * be looked up. */ - const char *varName, /* Name of a variable in interp. */ - const char *newValue, /* New value for varName. */ - int flags) /* Various flags that tell how to set value: - * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, - * TCL_LEAVE_ERR_MSG. */ -{ - Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, varName, NULL, - Tcl_NewStringObj(newValue, -1), flags); - - if (varValuePtr == NULL) { - return NULL; - } - return TclGetString(varValuePtr); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_SetVar2 -- * * Given a two-part variable name, which may refer either to a scalar @@ -2032,6 +1945,17 @@ TclPtrSetVarIdx( } /* + * It's an error to try to set a constant. + */ + if (TclIsVarConstant(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISCONST,index); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "CONST", (void *)NULL); + } + goto earlyError; + } + + /* * It's an error to try to set an array variable itself. */ @@ -2043,6 +1967,8 @@ TclPtrSetVarIdx( goto earlyError; } + TclVarFindHiddenArray(varPtr, arrayPtr); + /* * Invoke any read traces that have been set for the variable if it is * requested. This was done for INST_LAPPEND_* but that was inconsistent @@ -2309,6 +2235,17 @@ TclPtrIncrObjVarIdx( { Tcl_Obj *varValuePtr; + /* + * It's an error to try to increment a constant. + */ + if (TclIsVarConstant(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "incr", ISCONST,index); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "CONST", (void *)NULL); + } + return NULL; + } + if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)++; } @@ -2352,57 +2289,6 @@ TclPtrIncrObjVarIdx( /* *---------------------------------------------------------------------- * - * Tcl_UnsetVar -- - * - * Delete a variable, so that it may not be accessed anymore. - * - * Results: - * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if - * the variable can't be unset. In the event of an error, if the - * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the - * interp's result. - * - * Side effects: - * If varName is defined as a local or global variable in interp, it is - * deleted. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_UnsetVar -int -Tcl_UnsetVar( - Tcl_Interp *interp, /* Command interpreter in which varName is to - * be looked up. */ - const char *varName, /* Name of a variable in interp. May be either - * a scalar name or an array name or an - * element in an array. */ - int flags) /* OR-ed combination of any of - * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or - * TCL_LEAVE_ERR_MSG. */ -{ - int result; - Tcl_Obj *varNamePtr; - - varNamePtr = Tcl_NewStringObj(varName, -1); - Tcl_IncrRefCount(varNamePtr); - - /* - * Filter to pass through only the flags this interface supports. - */ - - flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); - result = TclObjUnsetVar2(interp, varNamePtr, NULL, flags); - - Tcl_DecrRefCount(varNamePtr); - return result; -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_UnsetVar2 -- * * Delete a variable, given a 2-part name. @@ -2568,14 +2454,14 @@ int TclPtrUnsetVarIdx( Tcl_Interp *interp, /* Command interpreter in which varName is to * be looked up. */ - Var *varPtr, /* The variable to be unset. */ + Var *varPtr, /* The variable to be unset. */ Var *arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - int flags, /* OR-ed combination of any of + int flags, /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ int index) /* Index into the local variable table of the @@ -2584,6 +2470,18 @@ TclPtrUnsetVarIdx( { Interp *iPtr = (Interp *) interp; int result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); + Var *initialArrayPtr = arrayPtr; + + /* + * It's an error to try to unset a constant. + */ + if (TclIsVarConstant(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", ISCONST,index); + Tcl_SetErrorCode(interp, "TCL", "UNSET", "CONST", (void *)NULL); + } + return TCL_ERROR; + } /* * Keep the variable alive until we're done with it. We used to @@ -2596,6 +2494,8 @@ TclPtrUnsetVarIdx( VarHashRefCount(varPtr)++; } + TclVarFindHiddenArray(varPtr, arrayPtr); + UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags, index); /* @@ -2605,7 +2505,7 @@ TclPtrUnsetVarIdx( if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", - ((arrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); + ((initialArrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", (void *)NULL); } } @@ -2713,9 +2613,23 @@ UnsetVarStruct( if ((dummyVar.flags & VAR_TRACED_UNSET) || (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) { + + /* + * Pass the array element name to TclObjCallVarTraces(), because + * it cannot be determined from dummyVar. Alternatively, indicate + * via flags whether the variable involved in the code that caused + * the trace to be triggered was an array element, for the correct + * formatting of error messages. + */ + if (part2Ptr) { + flags |= VAR_ARRAY_ELEMENT; + } else if (TclIsVarArrayElement(varPtr)) { + part2Ptr = VarHashGetKey(varPtr); + } + dummyVar.flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT)) | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0, index); @@ -3213,7 +3127,7 @@ ArrayForNRCmd( * Make a new array search, put it on the stack. */ - searchPtr = (ArraySearch *)ckalloc(sizeof(ArraySearch)); + searchPtr = (ArraySearch *)Tcl_Alloc(sizeof(ArraySearch)); ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr); /* @@ -3221,8 +3135,7 @@ ArrayForNRCmd( * loop) don't vanish. */ - /* Do not use TclListObjCopy here - shimmers arithseries to list */ - varListObj = Tcl_DuplicateObj(objv[1]); + varListObj = TclListObjCopy(NULL, objv[1]); if (!varListObj) { return TCL_ERROR; } @@ -3342,7 +3255,7 @@ ArrayForLoopCallback( ArrayDoneSearch(iPtr, varPtr, searchPtr); Tcl_DecrRefCount(searchPtr->name); - ckfree(searchPtr); + Tcl_Free(searchPtr); } TclDecrRefCount(varListObj); @@ -3428,7 +3341,7 @@ ArrayStartSearchCmd( * Make a new array search with a free name. */ - searchPtr = (ArraySearch *)ckalloc(sizeof(ArraySearch)); + searchPtr = (ArraySearch *)Tcl_Alloc(sizeof(ArraySearch)); ArrayPopulateSearch(interp, objv[1], varPtr, searchPtr); Tcl_SetObjResult(interp, searchPtr->name); return TCL_OK; @@ -3692,7 +3605,7 @@ ArrayDoneSearchCmd( ArrayDoneSearch(iPtr, varPtr, searchPtr); Tcl_DecrRefCount(searchPtr->name); - ckfree(searchPtr); + Tcl_Free(searchPtr); return TCL_OK; } @@ -3923,12 +3836,12 @@ ArrayNamesCmd( static const char *const options[] = { "-exact", "-glob", "-regexp", NULL }; - enum arrayNamesOptionsEnum { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; + enum arrayNamesOptionsEnum {OPT_EXACT, OPT_GLOB, OPT_REGEXP} mode = OPT_GLOB; Var *varPtr, *varPtr2; Tcl_Obj *nameObj, *resultObj, *patternObj; Tcl_HashSearch search; const char *pattern = NULL; - int isArray, mode = OPT_GLOB; + int isArray; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); @@ -3991,7 +3904,7 @@ ArrayNamesCmd( const char *name = TclGetString(nameObj); int matched = 0; - switch ((enum arrayNamesOptionsEnum) mode) { + switch (mode) { case OPT_EXACT: Tcl_Panic("exact matching shouldn't get here"); case OPT_GLOB: @@ -4058,7 +3971,7 @@ TclFindArrayPtrElements( continue; } nameObj = VarHashGetKey(varPtr); - hPtr = Tcl_CreateHashEntry(tablePtr, (char *) nameObj, &dummy); + hPtr = Tcl_CreateHashEntry(tablePtr, nameObj, &dummy); Tcl_SetHashValue(hPtr, nameObj); } } @@ -4125,11 +4038,12 @@ ArraySetCmd( Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done; + Tcl_Size size; - if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { + if (Tcl_DictObjSize(interp, arrayElemObj, &size) != TCL_OK) { return TCL_ERROR; } - if (done == 0) { + if (size == 0) { /* * Empty, so we'll just force the array to be properly existing * instead. @@ -4355,7 +4269,7 @@ ArrayStatsCmd( return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); - ckfree(stats); + Tcl_Free(stats); return TCL_OK; } @@ -4813,63 +4727,6 @@ TclPtrObjMakeUpvarIdx( /* *---------------------------------------------------------------------- * - * Tcl_UpVar -- - * - * This function links one variable to another, just like the "upvar" - * command. - * - * Results: - * A standard Tcl completion code. If an error occurs then an error - * message is left in the interp's result. - * - * Side effects: - * The variable in frameName whose name is given by varName becomes - * accessible under the name localNameStr, so that references to - * localNameStr are redirected to the other variable like a symbolic - * link. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef Tcl_UpVar -int -Tcl_UpVar( - Tcl_Interp *interp, /* Command interpreter in which varName is to - * be looked up. */ - const char *frameName, /* Name of the frame containing the source - * variable, such as "1" or "#0". */ - const char *varName, /* Name of a variable in interp to link to. - * May be either a scalar name or an element - * in an array. */ - const char *localNameStr, /* Name of link variable. */ - int flags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: - * indicates scope of localNameStr. */ -{ - int result; - CallFrame *framePtr; - Tcl_Obj *varNamePtr, *localNamePtr; - - if (TclGetFrame(interp, frameName, &framePtr) == -1) { - return TCL_ERROR; - } - - varNamePtr = Tcl_NewStringObj(varName, -1); - Tcl_IncrRefCount(varNamePtr); - localNamePtr = Tcl_NewStringObj(localNameStr, -1); - Tcl_IncrRefCount(localNamePtr); - - result = ObjMakeUpvar(interp, framePtr, varNamePtr, NULL, 0, - localNamePtr, flags, -1); - Tcl_DecrRefCount(varNamePtr); - Tcl_DecrRefCount(localNamePtr); - return result; -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_UpVar2 -- * * This function links one variable to another, just like the "upvar" @@ -4977,7 +4834,7 @@ Tcl_GetVariableFullName( } else if (iPtr->varFramePtr->procPtr) { Tcl_Size index = varPtr - iPtr->varFramePtr->compiledLocals; - if (index >= 0 && index < iPtr->varFramePtr->numCompiledLocals) { + if (index < iPtr->varFramePtr->numCompiledLocals) { namePtr = localName(iPtr->varFramePtr, index); Tcl_AppendObjToObj(objPtr, namePtr); } @@ -4987,6 +4844,81 @@ Tcl_GetVariableFullName( /* *---------------------------------------------------------------------- * + * Tcl_ConstObjCmd -- + * + * This function is invoked to process the "const" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ConstObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Var *varPtr, *arrayPtr; + Tcl_Obj *part1Ptr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "varName value"); + return TCL_ERROR; + } + + part1Ptr = objv[1]; + varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, + "const", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (TclIsVarArray(varPtr)) { + TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", ISARRAY, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); + return TCL_ERROR; + } + if (TclIsVarArrayElement(varPtr)) { + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, arrayPtr); + } + TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", ISARRAYELEMENT, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); + return TCL_ERROR; + } + + /* + * If already exists, either a constant (no problem) or an error. + */ + if (!TclIsVarUndefined(varPtr)) { + if (TclIsVarConstant(varPtr)) { + return TCL_OK; + } + TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", EXISTS, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); + return TCL_ERROR; + } + + /* + * Make the variable and flag it as a constant. + */ + if (TclPtrSetVar(interp, (Tcl_Var) varPtr, NULL, objv[1], NULL, + objv[2], TCL_LEAVE_ERR_MSG) == NULL) { + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, arrayPtr); + } + return TCL_ERROR; + }; + TclSetVarConstant(varPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GlobalObjCmd -- * * This object-based function is invoked to process the "global" Tcl @@ -5417,7 +5349,7 @@ DeleteSearches( searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; Tcl_DecrRefCount(searchPtr->name); - ckfree(searchPtr); + Tcl_Free(searchPtr); } arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE; Tcl_DeleteHashEntry(sPtr); @@ -5994,6 +5926,10 @@ ObjFindNamespaceVar( * Find the namespace(s) that contain the variable. */ + if (!(flags & TCL_GLOBAL_ONLY)) { + flags |= TCL_NAMESPACE_ONLY; + } + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); @@ -6210,7 +6146,7 @@ TclInfoVarsCmd( } } } else if (iPtr->varFramePtr->procPtr != NULL) { - AppendLocals(interp, listPtr, simplePatternPtr, 1); + AppendLocals(interp, listPtr, simplePatternPtr, 1, 0); } if (simplePatternPtr) { @@ -6364,7 +6300,201 @@ TclInfoLocalsCmd( */ listPtr = Tcl_NewListObj(0, NULL); - AppendLocals(interp, listPtr, patternPtr, 0); + AppendLocals(interp, listPtr, patternPtr, 0, 0); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclInfoConstsCmd -- + * + * Called to implement the "info consts" command that returns the list of + * constants in the interpreter that match an optional pattern. The + * pattern, if any, consists of an optional sequence of namespace names + * separated by "::" qualifiers, which is followed by a glob-style + * pattern that restricts which variables are returned. Handles the + * following syntax: + * + * info consts ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +int +TclInfoConstsCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + const char *varName, *pattern, *simplePattern; + Tcl_HashSearch search; + Var *varPtr; + Namespace *nsPtr; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Tcl_Obj *listPtr, *elemObjPtr, *varNamePtr; + int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ + Tcl_Obj *simplePatternPtr = NULL; + + /* + * Get the pattern and find the "effective namespace" in which to list + * variables. We only use this effective namespace if there's no active + * Tcl procedure frame. + */ + + if (objc == 1) { + simplePattern = NULL; + nsPtr = currNsPtr; + specificNsInPattern = 0; + } else if (objc == 2) { + /* + * From the pattern, get the effective namespace and the simple + * pattern (no namespace qualifiers or ::'s) at the end. If an error + * was found while parsing the pattern, return it. Otherwise, if the + * namespace wasn't found, just leave nsPtr NULL: we will return an + * empty list since no variables there can be found. + */ + + Namespace *dummy1NsPtr, *dummy2NsPtr; + + pattern = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0, + &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + + if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ + specificNsInPattern = (strcmp(simplePattern, pattern) != 0); + if (simplePattern == pattern) { + simplePatternPtr = objv[1]; + } else { + simplePatternPtr = Tcl_NewStringObj(simplePattern, -1); + } + Tcl_IncrRefCount(simplePatternPtr); + } + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + + /* + * If the namespace specified in the pattern wasn't found, just return. + */ + + if (nsPtr == NULL) { + return TCL_OK; + } + + listPtr = Tcl_NewListObj(0, NULL); + + if (!HasLocalVars(iPtr->varFramePtr) || specificNsInPattern) { + /* + * There is no frame pointer, the frame pointer was pushed only to + * activate a namespace, or we are in a procedure call frame but a + * specific namespace was specified. Create a list containing only the + * variables in the effective namespace's variable table. + */ + + if (simplePattern && TclMatchIsTrivial(simplePattern)) { + /* + * If we can just do hash lookups, that simplifies things a lot. + */ + + varPtr = VarHashFindVar(&nsPtr->varTable, simplePatternPtr); + if (varPtr && TclIsVarConstant(varPtr)) { + if (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr)) { + if (specificNsInPattern) { + TclNewObj(elemObjPtr); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, + elemObjPtr); + } else { + elemObjPtr = VarHashGetKey(varPtr); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + varPtr = VarHashFindVar(&globalNsPtr->varTable, + simplePatternPtr); + if (varPtr && TclIsVarConstant(varPtr)) { + if (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr)) { + Tcl_ListObjAppendElement(interp, listPtr, + VarHashGetKey(varPtr)); + } + } + } + } else { + /* + * Have to scan the tables of variables. + */ + + varPtr = VarHashFirstVar(&nsPtr->varTable, &search); + while (varPtr) { + if (TclIsVarConstant(varPtr) && (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr))) { + varNamePtr = VarHashGetKey(varPtr); + varName = TclGetString(varNamePtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(varName, simplePattern)) { + if (specificNsInPattern) { + TclNewObj(elemObjPtr); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, + elemObjPtr); + } else { + elemObjPtr = varNamePtr; + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } + varPtr = VarHashNextVar(&search); + } + + /* + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern (i.e., the + * pattern only specifies variable names), then add in all global + * :: variables that match the simple pattern. Of course, add in + * only those variables that aren't hidden by a variable in the + * effective namespace. + */ + + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); + while (varPtr) { + if (TclIsVarConstant(varPtr) && (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr))) { + varNamePtr = VarHashGetKey(varPtr); + varName = TclGetString(varNamePtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(varName, simplePattern)) { + if (VarHashFindVar(&nsPtr->varTable, + varNamePtr) == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, + varNamePtr); + } + } + } + varPtr = VarHashNextVar(&search); + } + } + } + } else if (iPtr->varFramePtr->procPtr != NULL) { + AppendLocals(interp, listPtr, simplePatternPtr, 1, 1); + } + + if (simplePatternPtr) { + Tcl_DecrRefCount(simplePatternPtr); + } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -6386,12 +6516,31 @@ TclInfoLocalsCmd( *---------------------------------------------------------------------- */ +static int +ContextObjectContainsConstant( + Tcl_ObjectContext context, + Tcl_Obj *varNamePtr) +{ + /* + * Helper for AppendLocals to check if an object contains a variable + * that is a constant. It's too complicated without factoring this + * check out! + */ + + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + Namespace *nsPtr = (Namespace *) oPtr->namespacePtr; + Var *varPtr = VarHashFindVar(&nsPtr->varTable, varNamePtr); + + return !TclIsVarUndefined(varPtr) && TclIsVarConstant(varPtr); +} + static void AppendLocals( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *listPtr, /* List object to append names to. */ Tcl_Obj *patternPtr, /* Pattern to match against. */ - int includeLinks) /* 1 if upvars should be included, else 0. */ + int includeLinks, /* 1 if upvars should be included, else 0. */ + int justConstants) /* 1 if just constants should be included. */ { Interp *iPtr = (Interp *) interp; Var *varPtr; @@ -6420,10 +6569,12 @@ AppendLocals( */ if (*varNamePtr && !TclIsVarUndefined(varPtr) - && (includeLinks || !TclIsVarLink(varPtr))) { + && (includeLinks || !TclIsVarLink(varPtr))) { varName = TclGetString(*varNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); + if (!justConstants || TclIsVarConstant(varPtr)) { + Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); + } if (includeLinks) { Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); } @@ -6450,8 +6601,10 @@ AppendLocals( if (varPtr != NULL) { if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { - Tcl_ListObjAppendElement(interp, listPtr, - VarHashGetKey(varPtr)); + if ((!justConstants || TclIsVarConstant(varPtr))) { + Tcl_ListObjAppendElement(interp, listPtr, + VarHashGetKey(varPtr)); + } if (includeLinks) { Tcl_CreateHashEntry(&addedTable, VarHashGetKey(varPtr), &added); @@ -6473,7 +6626,9 @@ AppendLocals( objNamePtr = VarHashGetKey(varPtr); varName = TclGetString(objNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + if (!justConstants || TclIsVarConstant(varPtr)) { + Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + } if (includeLinks) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); } @@ -6487,8 +6642,9 @@ AppendLocals( } if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { - Method *mPtr = (Method *) - Tcl_ObjectContextMethod((Tcl_ObjectContext)iPtr->varFramePtr->clientData); + Tcl_ObjectContext context = (Tcl_ObjectContext) + iPtr->varFramePtr->clientData; + Method *mPtr = (Method *) Tcl_ObjectContextMethod(context); PrivateVariableMapping *privatePtr; if (mPtr->declaringObjectPtr) { @@ -6496,6 +6652,10 @@ AppendLocals( FOREACH(objNamePtr, oPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + if (justConstants && !ContextObjectContainsConstant(context, + objNamePtr)) { + continue; + } if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); @@ -6504,6 +6664,10 @@ AppendLocals( FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, &added); + if (justConstants && !ContextObjectContainsConstant(context, + privatePtr->fullNameObj)) { + continue; + } if (added && (!pattern || Tcl_StringMatch(TclGetString(privatePtr->variableObj), pattern))) { @@ -6516,6 +6680,10 @@ AppendLocals( FOREACH(objNamePtr, clsPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + if (justConstants && !ContextObjectContainsConstant(context, + objNamePtr)) { + continue; + } if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); @@ -6524,6 +6692,10 @@ AppendLocals( FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, &added); + if (justConstants && !ContextObjectContainsConstant(context, + privatePtr->fullNameObj)) { + continue; + } if (added && (!pattern || Tcl_StringMatch(TclGetString(privatePtr->variableObj), pattern))) { @@ -6537,6 +6709,47 @@ AppendLocals( } /* + *---------------------------------------------------------------------- + * + * TclInfoConstantCmd -- + * + * Called to implement the "info constant" command that wests whether a + * specific variable is a constant. Handles the following syntax: + * + * info constant varName + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +int +TclInfoConstantCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Var *varPtr, *arrayPtr; + int result; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName"); + return TCL_ERROR; + } + varPtr = TclObjLookupVar(interp, objv[1], NULL, 0, "lookup", 0, 0, + &arrayPtr); + result = (varPtr && TclIsVarConstant(varPtr)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +/* * Hash table implementation - first, just copy and adapt the obj key stuff */ @@ -6548,6 +6761,7 @@ TclInitVarHashTable( Tcl_InitCustomHashTable(&tablePtr->table, TCL_CUSTOM_TYPE_KEYS, &tclVarHashKeyType); tablePtr->nsPtr = nsPtr; + tablePtr->arrayPtr = NULL; } static Tcl_HashEntry * @@ -6559,7 +6773,7 @@ AllocVarEntry( Tcl_HashEntry *hPtr; Var *varPtr; - varPtr = (Var *)ckalloc(sizeof(VarInHash)); + varPtr = (Var *)Tcl_Alloc(sizeof(VarInHash)); varPtr->flags = VAR_IN_HASHTABLE; varPtr->value.objPtr = NULL; VarHashRefCount(varPtr) = 1; @@ -6581,7 +6795,7 @@ FreeVarEntry( if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr) && (VarHashRefCount(varPtr) == 1)) { - ckfree(varPtr); + Tcl_Free(varPtr); } else { VarHashInvalidateEntry(varPtr); TclSetVarUndefined(varPtr); @@ -6598,7 +6812,7 @@ CompareVarKeys( Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr; Tcl_Obj *objPtr2 = hPtr->key.objPtr; const char *p1, *p2; - Tcl_Size l1, l2; + size_t l1, l2; /* * If the object pointers are the same then they match. @@ -6612,8 +6826,10 @@ CompareVarKeys( * register. */ - p1 = TclGetStringFromObj(objPtr1, &l1); - p2 = TclGetStringFromObj(objPtr2, &l2); + p1 = TclGetString(objPtr1); + l1 = objPtr1->length; + p2 = TclGetString(objPtr2); + l2 = objPtr2->length; /* * Only compare string representations of the same length. @@ -6648,10 +6864,10 @@ ArrayDefaultCmd( static const char *const options[] = { "get", "set", "exists", "unset", NULL }; - enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET }; + enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET } option; Tcl_Obj *arrayNameObj, *defaultValueObj; Var *varPtr, *arrayPtr; - int isArray, option; + int isArray; /* * Parse arguments. @@ -6672,7 +6888,7 @@ ArrayDefaultCmd( return TCL_ERROR; } - switch ((enum arrayDefaultOptionsEnum)option) { + switch (option) { case OPT_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); @@ -6786,7 +7002,7 @@ void TclInitArrayVar( Var *arrayPtr) { - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)ckalloc(sizeof(ArrayVarHashTable)); + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)Tcl_Alloc(sizeof(ArrayVarHashTable)); /* * Mark the variable as an array. @@ -6800,6 +7016,7 @@ TclInitArrayVar( arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr; TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr)); + arrayPtr->value.tablePtr->arrayPtr = arrayPtr; /* * Default value initialization. @@ -6830,7 +7047,7 @@ DeleteArrayVar( */ VarHashDeleteTable(arrayPtr->value.tablePtr); - ckfree(tablePtr); + Tcl_Free(tablePtr); } /* diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 6f014eb..8f91703 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -381,10 +381,6 @@ static int ZipChannelClose(void *instanceData, static Tcl_DriverGetHandleProc ZipChannelGetFile; static int ZipChannelRead(void *instanceData, char *buf, int toRead, int *errloc); -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) -static int ZipChannelSeek(void *instanceData, long offset, - int mode, int *errloc); -#endif static long long ZipChannelWideSeek(void *instanceData, long long offset, int mode, int *errloc); static void ZipChannelWatchChannel(void *instanceData, @@ -437,14 +433,10 @@ static const Tcl_Filesystem zipfsFilesystem = { static Tcl_ChannelType ZipChannelType = { "zip", /* Type name. */ TCL_CHANNEL_VERSION_5, - TCL_CLOSE2PROC, /* Close channel, clean instance data */ + NULL, /* Close channel, clean instance data */ ZipChannelRead, /* Handle read request */ ZipChannelWrite, /* Handle write request */ -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) - ZipChannelSeek, /* Move location of access point, NULL'able */ -#else NULL, /* Move location of access point, NULL'able */ -#endif NULL, /* Set options, NULL'able */ NULL, /* Get options, NULL'able */ ZipChannelWatchChannel, /* Initialize notifier */ @@ -460,12 +452,6 @@ static Tcl_ChannelType ZipChannelType = { }; /* - * Miscellaneous constants. - */ - -#define ERROR_LENGTH ((size_t) -1) - -/* *------------------------------------------------------------------------ * * TclIsZipfsPath -- @@ -738,11 +724,11 @@ ToDosDate( *------------------------------------------------------------------------- */ -static inline int +static inline size_t CountSlashes( const char *string) { - int count = 0; + size_t count = 0; const char *p = string; while (*p != '\0') { @@ -905,8 +891,7 @@ DecodeZipEntryText( src = (const char *) inputBytes; dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; - flags = TCL_ENCODING_START | TCL_ENCODING_END | - TCL_ENCODING_PROFILE_STRICT; /* Special flag! */ + flags = TCL_ENCODING_START | TCL_ENCODING_END; /* Special flag! */ while (1) { int srcRead, dstWrote; @@ -1109,7 +1094,7 @@ MapPathToZipfs(Tcl_Interp *interp, Tcl_DStringFree(&dsJoin); partsPtr[0] = mountPath; (void)Tcl_JoinPath(numParts, partsPtr, &dsJoin); - ckfree(partsPtr); + Tcl_Free(partsPtr); } unnormalizedObj = Tcl_DStringToObj(&dsJoin); /* Also resets dsJoin */ Tcl_IncrRefCount(unnormalizedObj); @@ -1286,7 +1271,7 @@ AllocateZipFile( size_t mountPointNameLength) { size_t size = sizeof(ZipFile) + mountPointNameLength + 1; - ZipFile *zf = (ZipFile *) attemptckalloc(size); + ZipFile *zf = (ZipFile *) Tcl_AttemptAlloc(size); if (!zf) { ZIPFS_MEM_ERROR(interp); @@ -1299,7 +1284,7 @@ AllocateZipFile( static inline ZipEntry * AllocateZipEntry(void) { - ZipEntry *z = (ZipEntry *) ckalloc(sizeof(ZipEntry)); + ZipEntry *z = (ZipEntry *) Tcl_Alloc(sizeof(ZipEntry)); memset(z, 0, sizeof(ZipEntry)); return z; } @@ -1308,7 +1293,7 @@ static inline ZipChannel * AllocateZipChannel( Tcl_Interp *interp) { - ZipChannel *zc = (ZipChannel *) attemptckalloc(sizeof(ZipChannel)); + ZipChannel *zc = (ZipChannel *) Tcl_AttemptAlloc(sizeof(ZipChannel)); if (!zc) { ZIPFS_MEM_ERROR(interp); @@ -1341,12 +1326,12 @@ ZipFSCloseArchive( ZipFile *zf) { if (zf->nameLength) { - ckfree(zf->name); + Tcl_Free(zf->name); } if (zf->isMemBuffer) { /* Pointer to memory */ if (zf->ptrToFree) { - ckfree(zf->ptrToFree); + Tcl_Free(zf->ptrToFree); zf->ptrToFree = NULL; } zf->data = NULL; @@ -1373,7 +1358,7 @@ ZipFSCloseArchive( #endif /* _WIN32 */ if (zf->ptrToFree) { - ckfree(zf->ptrToFree); + Tcl_Free(zf->ptrToFree); zf->ptrToFree = NULL; } if (zf->chan) { @@ -1659,7 +1644,7 @@ ZipFSOpenArchive( */ zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); - if (zf->length == ERROR_LENGTH) { + if (zf->length == (size_t) TCL_INDEX_NONE) { ZIPFS_POSIX_ERROR(interp, "seek error"); goto error; } @@ -1675,7 +1660,7 @@ ZipFSOpenArchive( ZIPFS_POSIX_ERROR(interp, "seek error"); goto error; } - zf->ptrToFree = zf->data = (unsigned char *) attemptckalloc(zf->length); + zf->ptrToFree = zf->data = (unsigned char *) Tcl_AttemptAlloc(zf->length); if (!zf->ptrToFree) { ZIPFS_MEM_ERROR(interp); goto error; @@ -1774,7 +1759,7 @@ ZipMapArchive( */ zf->length = lseek(fd, 0, SEEK_END); - if (zf->length == ERROR_LENGTH) { + if (zf->length == (size_t)-1) { ZIPFS_POSIX_ERROR(interp, "failed to retrieve file size"); return TCL_ERROR; } @@ -1813,7 +1798,7 @@ static inline int IsPasswordValid( Tcl_Interp *interp, const char *passwd, - int pwlen) + size_t pwlen) { if ((pwlen > 255) || strchr(passwd, 0xff)) { ZIPFS_ERROR(interp, "illegal password"); @@ -1850,8 +1835,8 @@ ZipFSCatalogFilesystem( * the ZIP is unprotected. */ const char *zipname) /* Path to ZIP file to build a catalog of. */ { - int pwlen, isNew; - size_t i; + int isNew; + size_t i, pwlen; ZipFile *zf0; ZipEntry *z; Tcl_HashEntry *hPtr; @@ -1871,7 +1856,7 @@ ZipFSCatalogFilesystem( pwlen = strlen(passwd); if (IsPasswordValid(interp, passwd, pwlen) != TCL_OK) { ZipFSCloseArchive(interp, zf); - ckfree(zf); + Tcl_Free(zf); return TCL_ERROR; } } @@ -1885,7 +1870,7 @@ ZipFSCatalogFilesystem( ZIPFS_ERROR(interp, "bad zip data"); ZIPFS_ERROR_CODE(interp, "BAD_ZIP"); ZipFSCloseArchive(interp, zf); - ckfree(zf); + Tcl_Free(zf); return TCL_ERROR; } @@ -1902,7 +1887,7 @@ ZipFSCatalogFilesystem( Unlock(); ZipFSCloseArchive(interp, zf); Tcl_DStringFree(&ds); - ckfree(zf); + Tcl_Free(zf); return TCL_ERROR; } @@ -1914,7 +1899,7 @@ ZipFSCatalogFilesystem( zf->mountPointLen = strlen(zf->mountPoint); zf->nameLength = strlen(zipname); - zf->name = (char *) ckalloc(zf->nameLength + 1); + zf->name = (char *) Tcl_Alloc(zf->nameLength + 1); memcpy(zf->name, zipname, zf->nameLength + 1); Tcl_SetHashValue(hPtr, zf); @@ -2062,7 +2047,7 @@ ZipFSCatalogFilesystem( hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew); if (!isNew) { /* should not happen but skip it anyway */ - ckfree(z); + Tcl_Free(z); goto nextent; } @@ -2160,7 +2145,7 @@ ZipfsSetup(void) ZipFS.idCount = 1; ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE; ZipFS.fallbackEntryEncoding = (char *) - ckalloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1); + Tcl_Alloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1); strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING); ZipFS.initialized = 1; } @@ -2244,9 +2229,9 @@ CleanupMount(ZipFile *zf) /* Mount point */ Tcl_DeleteHashEntry(hPtr); } if (z->data) { - ckfree(z->data); + Tcl_Free(z->data); } - ckfree(z); + Tcl_Free(z); } zf->entries = NULL; } @@ -2377,7 +2362,7 @@ TclZipfs_Mount( else { ret = ZipFSOpenArchive(interp, normPath, 1, zf); if (ret != TCL_OK) { - ckfree(zf); + Tcl_Free(zf); } else { ret = ZipFSCatalogFilesystem( @@ -2469,10 +2454,10 @@ TclZipfs_MountBuffer( zf->length = datalen; if (copy) { - zf->data = (unsigned char *)attemptckalloc(datalen); + zf->data = (unsigned char *)Tcl_AttemptAlloc(datalen); if (zf->data == NULL) { ZipFSCloseArchive(interp, zf); - ckfree(zf); + Tcl_Free(zf); ZIPFS_MEM_ERROR(interp); goto done; } @@ -2485,7 +2470,7 @@ TclZipfs_MountBuffer( } ret = ZipFSFindTOC(interp, 1, zf); if (ret != TCL_OK) { - ckfree(zf); + Tcl_Free(zf); } else { /* Note ZipFSCatalogFilesystem will free zf on error */ @@ -2567,7 +2552,7 @@ TclZipfs_Unmount( CleanupMount(zf); ZipFSCloseArchive(interp, zf); - ckfree(zf); + Tcl_Free(zf); unmounted = 1; done: @@ -2728,7 +2713,7 @@ ZipFSUnmountObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "mountpoint"); return TCL_ERROR; } - return TclZipfs_Unmount(interp, Tcl_GetString(objv[1])); + return TclZipfs_Unmount(interp, TclGetString(objv[1])); } /* @@ -2764,7 +2749,7 @@ ZipFSMkKeyObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "password"); return TCL_ERROR; } - pw = TclGetStringFromObj(objv[1], &len); + pw = Tcl_GetStringFromObj(objv[1], &len); if (len == 0) { return TCL_OK; } @@ -2773,7 +2758,7 @@ ZipFSMkKeyObjCmd( } passObj = Tcl_NewByteArrayObj(NULL, 264); - passBuf = Tcl_GetByteArrayFromObj(passObj, (Tcl_Size *)NULL); + passBuf = Tcl_GetBytesFromObj(NULL, passObj, (Tcl_Size *)NULL); while (len > 0) { int ch = pw[len - 1]; @@ -2880,7 +2865,8 @@ ZipAddFile( * UTF-8). */ const char *zpathTcl; /* Filename in Tcl's internal encoding. */ int crc, flush, zpathlen; - size_t nbyte, nbytecompr, len, olen, align = 0; + size_t nbyte, nbytecompr; + Tcl_Size len, olen, align = 0; long long headerStartOffset, dataStartOffset, dataEndOffset; int mtime = 0, isNew, compMeth; unsigned long keys[3], keys0[3]; @@ -2904,11 +2890,15 @@ ZipAddFile( * crazy enough to embed NULs in filenames, they deserve what they get! */ - zpathExt = Tcl_UtfToExternalDString(tclUtf8Encoding, zpathTcl, -1, &zpathDs); + if (Tcl_UtfToExternalDStringEx(interp, tclUtf8Encoding, zpathTcl, TCL_INDEX_NONE, 0, &zpathDs, NULL) != TCL_OK) { + Tcl_DStringFree(&zpathDs); + return TCL_ERROR; + } + zpathExt = Tcl_DStringValue(&zpathDs); zpathlen = strlen(zpathExt); if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "path too long for \"%s\"", Tcl_GetString(pathObj))); + "path too long for \"%s\"", TclGetString(pathObj))); ZIPFS_ERROR_CODE(interp, "PATH_LEN"); Tcl_DStringFree(&zpathDs); return TCL_ERROR; @@ -2942,7 +2932,7 @@ ZipAddFile( nbyte = nbytecompr = 0; while (1) { len = Tcl_Read(in, buf, bufsize); - if (len == ERROR_LENGTH) { + if (len < 0) { Tcl_DStringFree(&zpathDs); if (nbyte == 0 && errno == EISDIR) { Tcl_Close(interp, in); @@ -2950,7 +2940,7 @@ ZipAddFile( } readErrorWithChannelOpen: Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s", - Tcl_GetString(pathObj), Tcl_PosixError(interp))); + TclGetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); return TCL_ERROR; } @@ -2962,7 +2952,7 @@ ZipAddFile( } if (Tcl_Seek(in, 0, SEEK_SET) == -1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("seek error on \"%s\": %s", - Tcl_GetString(pathObj), Tcl_PosixError(interp))); + TclGetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); Tcl_DStringFree(&zpathDs); return TCL_ERROR; @@ -2983,11 +2973,11 @@ ZipAddFile( memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpathExt, zpathlen); len = zpathlen + ZIP_LOCAL_HEADER_LEN; - if ((size_t) Tcl_Write(out, buf, len) != len) { + if (Tcl_Write(out, buf, len) != len) { writeErrorWithChannelOpen: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error on \"%s\": %s", - Tcl_GetString(pathObj), Tcl_PosixError(interp))); + TclGetString(pathObj), Tcl_PosixError(interp))); Tcl_Close(interp, in); Tcl_DStringFree(&zpathDs); return TCL_ERROR; @@ -3007,7 +2997,7 @@ ZipAddFile( ZipWriteShort(astart, aend, abuf, 0xffff); ZipWriteShort(astart, aend, abuf + 2, align - 4); ZipWriteInt(astart, aend, abuf + 4, 0x03020100); - if ((size_t) Tcl_Write(out, (const char *) abuf, align) != align) { + if (Tcl_Write(out, (const char *) abuf, align) != align) { goto writeErrorWithChannelOpen; } } @@ -3063,7 +3053,7 @@ ZipAddFile( if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, Z_DEFAULT_STRATEGY) != Z_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "compression init error on \"%s\"", Tcl_GetString(pathObj))); + "compression init error on \"%s\"", TclGetString(pathObj))); ZIPFS_ERROR_CODE(interp, "DEFLATE_INIT"); Tcl_Close(interp, in); Tcl_DStringFree(&zpathDs); @@ -3072,7 +3062,7 @@ ZipAddFile( do { len = Tcl_Read(in, buf, bufsize); - if (len == ERROR_LENGTH) { + if (len < 0) { deflateEnd(&stream); goto readErrorWithChannelOpen; } @@ -3083,9 +3073,9 @@ ZipAddFile( stream.avail_out = sizeof(obuf); stream.next_out = (unsigned char *) obuf; len = deflate(&stream, flush); - if (len == (size_t) Z_STREAM_ERROR) { + if (len == Z_STREAM_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "deflate error on \"%s\"", Tcl_GetString(pathObj))); + "deflate error on \"%s\"", TclGetString(pathObj))); ZIPFS_ERROR_CODE(interp, "DEFLATE"); deflateEnd(&stream); Tcl_Close(interp, in); @@ -3094,14 +3084,14 @@ ZipAddFile( } olen = sizeof(obuf) - stream.avail_out; if (passwd) { - size_t i; + Tcl_Size i; int tmp; for (i = 0; i < olen; i++) { obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp); } } - if (olen && ((size_t) Tcl_Write(out, obuf, olen) != olen)) { + if (olen && (Tcl_Write(out, obuf, olen) != olen)) { deflateEnd(&stream); goto writeErrorWithChannelOpen; } @@ -3136,20 +3126,20 @@ ZipAddFile( nbytecompr = (passwd ? ZIP_CRYPT_HDR_LEN : 0); while (1) { len = Tcl_Read(in, buf, bufsize); - if (len == ERROR_LENGTH) { + if (len < 0) { goto readErrorWithChannelOpen; } else if (len == 0) { break; } if (passwd) { - size_t i; + Tcl_Size i; int tmp; for (i = 0; i < len; i++) { buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp); } } - if ((size_t) Tcl_Write(out, buf, len) != len) { + if (Tcl_Write(out, buf, len) != len) { goto writeErrorWithChannelOpen; } nbytecompr += len; @@ -3172,7 +3162,7 @@ ZipAddFile( hPtr = Tcl_CreateHashEntry(fileHash, zpathTcl, &isNew); if (!isNew) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "non-unique path name \"%s\"", Tcl_GetString(pathObj))); + "non-unique path name \"%s\"", TclGetString(pathObj))); ZIPFS_ERROR_CODE(interp, "DUPLICATE_PATH"); return TCL_ERROR; } @@ -3202,14 +3192,14 @@ ZipAddFile( zpathlen, align); if (Tcl_Seek(out, headerStartOffset, SEEK_SET) != headerStartOffset) { Tcl_DeleteHashEntry(hPtr); - ckfree(z); + Tcl_Free(z); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "seek error: %s", Tcl_PosixError(interp))); return TCL_ERROR; } if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) { Tcl_DeleteHashEntry(hPtr); - ckfree(z); + Tcl_Free(z); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error: %s", Tcl_PosixError(interp))); return TCL_ERROR; @@ -3217,7 +3207,7 @@ ZipAddFile( Tcl_Flush(out); if (Tcl_Seek(out, dataEndOffset, SEEK_SET) != dataEndOffset) { Tcl_DeleteHashEntry(hPtr); - ckfree(z); + Tcl_Free(z); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "seek error: %s", Tcl_PosixError(interp))); return TCL_ERROR; @@ -3289,9 +3279,9 @@ ComputeNameInArchive( Tcl_Size len; if (directNameObj) { - name = Tcl_GetString(directNameObj); + name = TclGetString(directNameObj); } else { - name = TclGetStringFromObj(pathObj, &len); + name = Tcl_GetStringFromObj(pathObj, &len); if (slen > 0) { if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { /* @@ -3354,11 +3344,12 @@ ZipFSMkZipOrImg( * there's no password protection. */ { Tcl_Channel out; - int pwlen = 0, slen = 0, count, ret = TCL_ERROR, lobjc; - size_t len, i = 0; + int count, ret = TCL_ERROR; + Tcl_Size pwlen = 0, slen = 0, len, i = 0; + Tcl_Size lobjc; long long directoryStartOffset; - /* The overall file offset of the start of the - * central directory. */ + /* The overall file offset of the start of the + * central directory. */ long long suffixStartOffset;/* The overall file offset of the start of the * suffix of the central directory (i.e., * where this data will be written). */ @@ -3377,13 +3368,12 @@ ZipFSMkZipOrImg( passBuf[0] = 0; if (passwordObj != NULL) { - pw = TclGetStringFromObj(passwordObj, &pwlen); + pw = Tcl_GetStringFromObj(passwordObj, &pwlen); if (IsPasswordValid(interp, pw, pwlen) != TCL_OK) { return TCL_ERROR; } - if (pwlen <= 0) { + if (pwlen == 0) { pw = NULL; - pwlen = 0; } } if (dirRoot != NULL) { @@ -3431,7 +3421,7 @@ ZipFSMkZipOrImg( const char *imgName; // TODO: normalize the origin file name - imgName = (originFile != NULL) ? Tcl_GetString(originFile) : + imgName = (originFile != NULL) ? TclGetString(originFile) : Tcl_GetNameOfExecutable(); if (pwlen) { i = 0; @@ -3537,12 +3527,12 @@ ZipFSMkZipOrImg( Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); if (mappingList == NULL && stripPrefix != NULL) { - strip = TclGetStringFromObj(stripPrefix, &slen); + strip = Tcl_GetStringFromObj(stripPrefix, &slen); if (!slen) { strip = NULL; } } - for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) { + for (i = 0; i < lobjc; i += (mappingList ? 2 : 1)) { Tcl_Obj *pathObj = lobjv[i]; const char *name = ComputeNameInArchive(pathObj, (mappingList ? lobjv[i + 1] : NULL), strip, slen); @@ -3562,7 +3552,7 @@ ZipFSMkZipOrImg( directoryStartOffset = Tcl_Tell(out); count = 0; - for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) { + for (i = 0; i < lobjc; i += (mappingList ? 2 : 1)) { const char *name = ComputeNameInArchive(lobjv[i], (mappingList ? lobjv[i + 1] : NULL), strip, slen); Tcl_DString ds; @@ -3573,13 +3563,17 @@ ZipFSMkZipOrImg( } z = (ZipEntry *) Tcl_GetHashValue(hPtr); - name = Tcl_UtfToExternalDString(tclUtf8Encoding, z->name, TCL_INDEX_NONE, &ds); + if (Tcl_UtfToExternalDStringEx(interp, tclUtf8Encoding, z->name, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + ret = TCL_ERROR; + goto done; + } + name = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); SerializeCentralDirectoryEntry(start, end, (unsigned char *) buf, z, len); if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN) - || ((size_t) Tcl_Write(out, name, len) != len)) { + || (Tcl_Write(out, name, len) != len)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error: %s", Tcl_PosixError(interp))); Tcl_DStringFree(&ds); @@ -3615,7 +3609,7 @@ ZipFSMkZipOrImg( for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { z = (ZipEntry *) Tcl_GetHashValue(hPtr); - ckfree(z); + Tcl_Free(z); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&fileHash); @@ -3646,7 +3640,7 @@ CopyImageFile( Tcl_Channel out) /* Where to copy to; already open for writing * binary data. */ { - size_t i, k; + Tcl_WideInt i, k; Tcl_Size m, n; Tcl_Channel in; char buf[4096]; @@ -3663,7 +3657,7 @@ CopyImageFile( */ i = Tcl_Seek(in, 0, SEEK_END); - if (i == ERROR_LENGTH) { + if (i == -1) { errMsg = "seek error"; goto copyError; } @@ -3676,8 +3670,8 @@ CopyImageFile( for (k = 0; k < i; k += m) { m = i - k; - if (m > (int) sizeof(buf)) { - m = (int) sizeof(buf); + if (m > (Tcl_Size) sizeof(buf)) { + m = sizeof(buf); } n = Tcl_Read(in, buf, m); if (n == -1) { @@ -4026,7 +4020,7 @@ ZipFSExistsObjCmd( return TCL_ERROR; } - filename = Tcl_GetString(objv[1]); + filename = TclGetString(objv[1]); ReadLock(); exists = ZipFSLookup(filename) != NULL; @@ -4075,7 +4069,7 @@ ZipFSInfoObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "filename"); return TCL_ERROR; } - filename = Tcl_GetString(objv[1]); + filename = TclGetString(objv[1]); ReadLock(); z = ZipFSLookup(filename); if (z) { @@ -4153,17 +4147,17 @@ ZipFSListObjCmd( } switch (idx) { case OPT_GLOB: - pattern = Tcl_GetString(objv[2]); + pattern = TclGetString(objv[2]); break; case OPT_REGEXP: - regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2])); + regexp = Tcl_RegExpCompile(interp, TclGetString(objv[2])); if (!regexp) { return TCL_ERROR; } break; } } else if (objc == 2) { - pattern = Tcl_GetString(objv[1]); + pattern = TclGetString(objv[1]); } /* @@ -4398,7 +4392,7 @@ ZipChannelClose( ZipEntry *z = info->zipEntryPtr; assert(info->ubufToFree && info->ubuf); unsigned char *newdata; - newdata = (unsigned char *)attemptckrealloc( + newdata = (unsigned char *)Tcl_AttemptRealloc( info->ubufToFree, info->numBytes ? info->numBytes : 1); /* Bug [23dd83ce7c] */ if (newdata == NULL) { @@ -4411,7 +4405,7 @@ ZipChannelClose( /* Replace old content */ if (z->data) { - ckfree(z->data); + Tcl_Free(z->data); } z->data = newdata; /* May be NULL when ubufToFree was NULL */ z->numBytes = z->numCompressedBytes = info->numBytes; @@ -4427,12 +4421,12 @@ ZipChannelClose( Unlock(); if (info->ubufToFree) { assert(info->ubuf); - ckfree(info->ubufToFree); + Tcl_Free(info->ubufToFree); info->ubuf = NULL; info->ubufToFree = NULL; info->ubufSize = 0; } - ckfree(info); + Tcl_Free(info); return TCL_OK; } @@ -4576,7 +4570,7 @@ ZipChannelWrite( needed = info->maxWrite; } unsigned char *newBuf = - (unsigned char *)attemptckrealloc(info->ubufToFree, needed); + (unsigned char *)Tcl_AttemptRealloc(info->ubufToFree, needed); if (newBuf == NULL) { *errloc = ENOMEM; return -1; @@ -4665,18 +4659,6 @@ ZipChannelWideSeek( info->cursor = (Tcl_Size) offset; return info->cursor; } - -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) -static int -ZipChannelSeek( - void *instanceData, - long offset, - int mode, - int *errloc) -{ - return ZipChannelWideSeek(instanceData, offset, mode, errloc); -} -#endif /* *------------------------------------------------------------------------- @@ -4864,7 +4846,7 @@ ZipChannelOpen( /* Set up a writable channel. */ if (InitWritableChannel(interp, info, z, mode) == TCL_ERROR) { - ckfree(info); + Tcl_Free(info); goto error; } } else if (z->data) { @@ -4880,7 +4862,7 @@ ZipChannelOpen( */ if (InitReadableChannel(interp, info, z) == TCL_ERROR) { - ckfree(info); + Tcl_Free(info); goto error; } } @@ -4898,10 +4880,10 @@ ZipChannelOpen( ZIPFS_ERROR(interp, "invalid CRC"); ZIPFS_ERROR_CODE(interp, "CRC_FAILED"); if (info->ubufToFree) { - ckfree(info->ubufToFree); + Tcl_Free(info->ubufToFree); info->ubufSize = 0; } - ckfree(info); + Tcl_Free(info); goto error; } } @@ -4959,7 +4941,7 @@ InitWritableChannel( info->maxWrite = ZipFS.wrmax; info->ubufSize = z->numBytes ? z->numBytes : 1; - info->ubufToFree = (unsigned char *)attemptckalloc(info->ubufSize); + info->ubufToFree = (unsigned char *)Tcl_AttemptAlloc(info->ubufSize); info->ubuf = info->ubufToFree; if (info->ubufToFree == NULL) { goto memoryError; @@ -5015,7 +4997,7 @@ InitWritableChannel( assert(stream.avail_in >= ZIP_CRYPT_HDR_LEN); stream.avail_in -= ZIP_CRYPT_HDR_LEN; - cbuf = (unsigned char *) attemptckalloc(stream.avail_in ? stream.avail_in : 1); + cbuf = (unsigned char *) Tcl_AttemptAlloc(stream.avail_in ? stream.avail_in : 1); if (!cbuf) { goto memoryError; } @@ -5043,7 +5025,7 @@ InitWritableChannel( goto corruptionError; info->numBytes = z->numBytes; if (cbuf) { - ckfree(cbuf); + Tcl_Free(cbuf); } } else if (z->isEncrypted) { /* @@ -5083,14 +5065,14 @@ InitWritableChannel( corruptionError: if (cbuf) { memset(info->keys, 0, sizeof(info->keys)); - ckfree(cbuf); + Tcl_Free(cbuf); } ZIPFS_ERROR(interp, "decompression error"); ZIPFS_ERROR_CODE(interp, "CORRUPT"); error_cleanup: if (info->ubufToFree) { - ckfree(info->ubufToFree); + Tcl_Free(info->ubufToFree); info->ubufToFree = NULL; info->ubuf = NULL; info->ubufSize = 0; @@ -5167,7 +5149,7 @@ InitReadableChannel( if (info->isEncrypted) { assert(stream.avail_in >= ZIP_CRYPT_HDR_LEN); stream.avail_in -= ZIP_CRYPT_HDR_LEN; - ubuf = (unsigned char *) attemptckalloc(stream.avail_in ? stream.avail_in : 1); + ubuf = (unsigned char *) Tcl_AttemptAlloc(stream.avail_in ? stream.avail_in : 1); if (!ubuf) { goto memoryError; } @@ -5182,7 +5164,7 @@ InitReadableChannel( } info->ubufSize = info->numBytes ? info->numBytes : 1; - info->ubufToFree = (unsigned char *)attemptckalloc(info->ubufSize); + info->ubufToFree = (unsigned char *)Tcl_AttemptAlloc(info->ubufSize); info->ubuf = info->ubufToFree; stream.next_out = info->ubuf; if (!info->ubuf) { @@ -5211,7 +5193,7 @@ InitReadableChannel( if (ubuf) { info->isEncrypted = 0; memset(info->keys, 0, sizeof(info->keys)); - ckfree(ubuf); + Tcl_Free(ubuf); } } else if (info->isEncrypted) { unsigned int j, len; @@ -5224,7 +5206,7 @@ InitReadableChannel( (z->numCompressedBytes - ZIP_CRYPT_HDR_LEN) != z->numBytes) goto corruptionError; len = z->numCompressedBytes - ZIP_CRYPT_HDR_LEN; - ubuf = (unsigned char *) attemptckalloc(len); + ubuf = (unsigned char *) Tcl_AttemptAlloc(len); if (ubuf == NULL) { goto memoryError; } @@ -5251,10 +5233,10 @@ InitReadableChannel( error_cleanup: if (ubuf) { memset(info->keys, 0, sizeof(info->keys)); - ckfree(ubuf); + Tcl_Free(ubuf); } if (info->ubufToFree) { - ckfree(info->ubufToFree); + Tcl_Free(info->ubufToFree); info->ubufToFree = NULL; info->ubuf = NULL; info->ubufSize = 0; @@ -5423,7 +5405,7 @@ ZipFSStatProc( if (!pathPtr) { return -1; } - return ZipEntryStat(Tcl_GetString(pathPtr), buf); + return ZipEntryStat(TclGetString(pathPtr), buf); } /* @@ -5452,7 +5434,7 @@ ZipFSAccessProc( if (!pathPtr) { return -1; } - return ZipEntryAccess(Tcl_GetString(pathPtr), mode); + return ZipEntryAccess(TclGetString(pathPtr), mode); } /* @@ -5498,11 +5480,11 @@ AppendWithPrefix( Tcl_DString *prefix, /* The prefix to add to the element, or NULL * for don't do that. */ const char *name, /* The name to append. */ - int nameLen) /* The length of the name. May be -1 for + size_t nameLen) /* The length of the name. May be TCL_INDEX_NONE for * append-up-to-NUL-byte. */ { if (prefix) { - int prefixLength = Tcl_DStringLength(prefix); + size_t prefixLength = Tcl_DStringLength(prefix); Tcl_DStringAppend(prefix, name, nameLen); Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj( @@ -5578,13 +5560,13 @@ ZipFSMatchInDirectoryProc( * The prefix that gets prepended to results. */ - prefix = TclGetStringFromObj(pathPtr, &prefixLen); + prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen); /* * The (normalized) path we're searching. */ - path = TclGetStringFromObj(normPathPtr, &len); + path = Tcl_GetStringFromObj(normPathPtr, &len); Tcl_DStringInit(&dsPref); if (strcmp(prefix, path) == 0) { @@ -5653,7 +5635,7 @@ ZipFSMatchInDirectoryProc( */ l = strlen(pattern); - pat = (char *) ckalloc(len + l + 2); + pat = (char *) Tcl_Alloc(len + l + 2); memcpy(pat, path, len); while ((len > 1) && (pat[len - 1] == '/')) { --len; @@ -5722,7 +5704,7 @@ ZipFSMatchInDirectoryProc( } } Tcl_DeleteHashTable(&duplicates); - ckfree(pat); + Tcl_Free(pat); end: Unlock(); @@ -5763,8 +5745,8 @@ ZipFSMatchMountPoints( Tcl_HashSearch search; int l; Tcl_Size normLength; - const char *path = TclGetStringFromObj(normPathPtr, &normLength); - Tcl_Size len = (size_t) normLength; + const char *path = Tcl_GetStringFromObj(normPathPtr, &normLength); + Tcl_Size len = normLength; if (len < 1) { /* @@ -5801,7 +5783,7 @@ ZipFSMatchMountPoints( if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0) && (z->name[len] == '/') - && (CountSlashes(z->name) == l) + && ((int) CountSlashes(z->name) == l) && Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)) { AppendWithPrefix(result, prefix, z->name, lenz); } @@ -5809,7 +5791,7 @@ ZipFSMatchMountPoints( } else if ((zf->mountPointLen > len + 1) && (strncmp(zf->mountPoint, path, len) == 0) && (zf->mountPoint[len] == '/') - && (CountSlashes(zf->mountPoint) == l) + && ((int) CountSlashes(zf->mountPoint) == l) && Tcl_StringCaseMatch(zf->mountPoint + len + 1, pattern, 0)) { /* @@ -5850,7 +5832,7 @@ ZipFSPathInFilesystemProc( if (!pathPtr) { return -1; } - path = TclGetStringFromObj(pathPtr, &len); + path = Tcl_GetStringFromObj(pathPtr, &len); /* * Claim any path under ZIPFS_VOLUME as ours. This is both a necessary @@ -5969,7 +5951,7 @@ ZipFSFileAttrsGetProc( if (!pathPtr) { return -1; } - path = TclGetStringFromObj(pathPtr, &len); + path = Tcl_GetStringFromObj(pathPtr, &len); ReadLock(); z = ZipFSLookup(path); if (!z && !ContainsMountPoint(path, -1)) { @@ -6362,14 +6344,14 @@ void TclZipfsFinalize(void) Tcl_DeleteHashEntry(hPtr); CleanupMount(zf); /* Frees file entries belonging to the archive */ ZipFSCloseArchive(NULL, zf); - ckfree(zf); + Tcl_Free(zf); } Tcl_FSUnregister(&zipfsFilesystem); Tcl_DeleteHashTable(&ZipFS.fileHash); Tcl_DeleteHashTable(&ZipFS.zipHash); if (ZipFS.fallbackEntryEncoding) { - ckfree(ZipFS.fallbackEntryEncoding); + Tcl_Free(ZipFS.fallbackEntryEncoding); ZipFS.fallbackEntryEncoding = NULL; } @@ -6401,12 +6383,12 @@ TclZipfs_AppHook( #endif /* _WIN32 */ { const char *archive; - const char *version = Tcl_InitSubsystems(); + const char *result; #ifdef _WIN32 - Tcl_FindExecutable(NULL); + result = Tcl_FindExecutable(NULL); #else - Tcl_FindExecutable((*argvPtr)[0]); + result = Tcl_FindExecutable((*argvPtr)[0]); #endif archive = Tcl_GetNameOfExecutable(); TclZipfs_Init(NULL); @@ -6444,7 +6426,7 @@ TclZipfs_AppHook( Tcl_DecrRefCount(vfsInitScript); if (found == TCL_OK) { zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return version; + return result; } } #ifdef SUPPORT_BUILTIN_ZIP_INSTALL @@ -6477,7 +6459,7 @@ TclZipfs_AppHook( if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { Tcl_SetStartupScript(vfsInitScript, NULL); } - return version; + return result; } else if (!TclZipfs_Mount(NULL, archive, ZIPFS_APP_MOUNT, NULL)) { int found; Tcl_Obj *vfsInitScript; @@ -6501,7 +6483,7 @@ TclZipfs_AppHook( Tcl_DecrRefCount(vfsInitScript); if (found == TCL_OK) { zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return version; + return result; } } #ifdef _WIN32 @@ -6509,7 +6491,7 @@ TclZipfs_AppHook( #endif /* _WIN32 */ #endif /* SUPPORT_BUILTIN_ZIP_INSTALL */ } - return version; + return result; } #else /* !HAVE_ZLIB */ diff --git a/generic/tclZlib.c b/generic/tclZlib.c index e951060..8ec9303 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -181,7 +181,7 @@ static void ConvertError(Tcl_Interp *interp, int code, uLong adler); static Tcl_Obj * ConvertErrorToList(int code, uLong adler); static inline int Deflate(z_streamp strm, void *bufferPtr, - int bufferSize, int flush, int *writtenPtr); + size_t bufferSize, int flush, size_t *writtenPtr); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); @@ -206,7 +206,7 @@ static void ZlibTransformTimerRun(void *clientData); static const Tcl_ChannelType zlibChannelType = { "zlib", TCL_CHANNEL_VERSION_5, - TCL_CLOSE2PROC, + NULL, ZlibTransformInput, ZlibTransformOutput, NULL, /* seekProc */ @@ -423,6 +423,7 @@ GenerateHeader( { Tcl_Obj *value; int len, result = TCL_ERROR; + Tcl_Size length; Tcl_WideInt wideValue = 0; const char *valueStr; Tcl_Encoding latin1enc; @@ -443,8 +444,8 @@ GenerateHeader( goto error; } else if (value != NULL) { Tcl_EncodingState state; - valueStr = TclGetStringFromObj(value, &len); - result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, + valueStr = Tcl_GetStringFromObj(value, &length); + result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, length, TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_PROFILE_STRICT, &state, headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len, NULL); @@ -478,8 +479,8 @@ GenerateHeader( goto error; } else if (value != NULL) { Tcl_EncodingState state; - valueStr = TclGetStringFromObj(value, &len); - result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, + valueStr = Tcl_GetStringFromObj(value, &length); + result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, length, TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_PROFILE_STRICT, &state, headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); @@ -517,7 +518,7 @@ GenerateHeader( if (GetValue(interp, dictObj, "time", &value) != TCL_OK) { goto error; - } else if (value != NULL && Tcl_GetWideIntFromObj(interp, value, + } else if (value != NULL && TclGetWideIntFromObj(interp, value, &wideValue) != TCL_OK) { goto error; } @@ -576,7 +577,7 @@ ExtractHeader( } } - Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, TCL_INDEX_NONE, + (void)Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, TCL_INDEX_NONE, &tmp); SetValue(dictObj, "comment", Tcl_DStringToObj(&tmp)); } @@ -593,7 +594,7 @@ ExtractHeader( } } - Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, TCL_INDEX_NONE, + (void)Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, TCL_INDEX_NONE, &tmp); SetValue(dictObj, "filename", Tcl_DStringToObj(&tmp)); } @@ -623,9 +624,12 @@ SetInflateDictionary( Tcl_Obj *compDictObj) { if (compDictObj != NULL) { - int length; - unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); + Tcl_Size length = 0; + unsigned char *bytes = Tcl_GetBytesFromObj(NULL, compDictObj, &length); + if (bytes == NULL) { + return Z_DATA_ERROR; + } return inflateSetDictionary(strm, bytes, length); } return Z_OK; @@ -637,9 +641,12 @@ SetDeflateDictionary( Tcl_Obj *compDictObj) { if (compDictObj != NULL) { - int length; - unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); + Tcl_Size length = 0; + unsigned char *bytes = Tcl_GetBytesFromObj(NULL, compDictObj, &length); + if (bytes == NULL) { + return Z_DATA_ERROR; + } return deflateSetDictionary(strm, bytes, length); } return Z_OK; @@ -649,9 +656,9 @@ static inline int Deflate( z_streamp strm, void *bufferPtr, - int bufferSize, + size_t bufferSize, int flush, - int *writtenPtr) + size_t *writtenPtr) { int e; @@ -668,7 +675,7 @@ static inline void AppendByteArray( Tcl_Obj *listObj, void *buffer, - int size) + size_t size) { if (size > 0) { Tcl_Obj *baObj = Tcl_NewByteArrayObj((unsigned char *) buffer, size); @@ -730,11 +737,11 @@ Tcl_ZlibStreamInit( case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; if (dictObj) { - gzHeaderPtr = (GzipHeader *)ckalloc(sizeof(GzipHeader)); + gzHeaderPtr = (GzipHeader *)Tcl_Alloc(sizeof(GzipHeader)); memset(gzHeaderPtr, 0, sizeof(GzipHeader)); if (GenerateHeader(interp, dictObj, gzHeaderPtr, NULL) != TCL_OK) { - ckfree(gzHeaderPtr); + Tcl_Free(gzHeaderPtr); return TCL_ERROR; } } @@ -764,7 +771,7 @@ Tcl_ZlibStreamInit( break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; - gzHeaderPtr = (GzipHeader *)ckalloc(sizeof(GzipHeader)); + gzHeaderPtr = (GzipHeader *)Tcl_Alloc(sizeof(GzipHeader)); memset(gzHeaderPtr, 0, sizeof(GzipHeader)); gzHeaderPtr->header.name = (Bytef *) gzHeaderPtr->nativeFilenameBuf; @@ -790,7 +797,7 @@ Tcl_ZlibStreamInit( " TCL_ZLIB_STREAM_INFLATE"); } - zshPtr = (ZlibStreamHandle *)ckalloc(sizeof(ZlibStreamHandle)); + zshPtr = (ZlibStreamHandle *)Tcl_Alloc(sizeof(ZlibStreamHandle)); zshPtr->interp = interp; zshPtr->mode = mode; zshPtr->format = format; @@ -890,9 +897,9 @@ Tcl_ZlibStreamInit( Tcl_DecrRefCount(zshPtr->compDictObj); } if (zshPtr->gzHeaderPtr) { - ckfree(zshPtr->gzHeaderPtr); + Tcl_Free(zshPtr->gzHeaderPtr); } - ckfree(zshPtr); + Tcl_Free(zshPtr); return TCL_ERROR; } @@ -1003,10 +1010,10 @@ ZlibStreamCleanup( Tcl_DecrRefCount(zshPtr->compDictObj); } if (zshPtr->gzHeaderPtr) { - ckfree(zshPtr->gzHeaderPtr); + Tcl_Free(zshPtr->gzHeaderPtr); } - ckfree(zshPtr); + Tcl_Free(zshPtr); } /* @@ -1184,7 +1191,7 @@ Tcl_ZlibStreamSetCompressionDictionary( ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; if (compressionDictionaryObj && (NULL == Tcl_GetBytesFromObj(NULL, - compressionDictionaryObj, NULL))) { + compressionDictionaryObj, (Tcl_Size *)NULL))) { /* Missing or invalid compression dictionary */ compressionDictionaryObj = NULL; } @@ -1227,7 +1234,8 @@ Tcl_ZlibStreamPut( ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; char *dataTmp = NULL; int e; - int size, outSize, toStore; + Tcl_Size size = 0; + size_t outSize, toStore; unsigned char *bytes; if (zshPtr->streamEnd) { @@ -1276,7 +1284,7 @@ Tcl_ZlibStreamPut( if (outSize > BUFFER_SIZE_LIMIT) { outSize = BUFFER_SIZE_LIMIT; } - dataTmp = (char *)ckalloc(outSize); + dataTmp = (char *)Tcl_Alloc(outSize); while (1) { e = Deflate(&zshPtr->stream, dataTmp, outSize, flush, &toStore); @@ -1310,7 +1318,7 @@ Tcl_ZlibStreamPut( if (outSize < BUFFER_SIZE_LIMIT) { outSize = BUFFER_SIZE_LIMIT; /* There may be *lots* of data left to output... */ - dataTmp = (char *)ckrealloc(dataTmp, outSize); + dataTmp = (char *)Tcl_Realloc(dataTmp, outSize); } } @@ -1319,7 +1327,7 @@ Tcl_ZlibStreamPut( */ AppendByteArray(zshPtr->outData, dataTmp, toStore); - ckfree(dataTmp); + Tcl_Free(dataTmp); } else { /* * This is easy. Just append to the inData list. @@ -1352,15 +1360,15 @@ int Tcl_ZlibStreamGet( Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */ Tcl_Obj *data, /* A place to append the data. */ - int count) /* Number of bytes to grab as a maximum, you + Tcl_Size count) /* Number of bytes to grab as a maximum, you * may get less! */ { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; int e; - Tcl_Size listLen, i, itemLen, dataPos = 0; + Tcl_Size listLen, i, itemLen = 0, dataPos = 0; Tcl_Obj *itemObj; unsigned char *dataPtr, *itemPtr; - Tcl_Size existing; + Tcl_Size existing = 0; /* * Getting beyond the of stream, just return empty string. @@ -1375,7 +1383,7 @@ Tcl_ZlibStreamGet( } if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) { - if (count == -1) { + if (count < 0) { /* * The only safe thing to do is restict to 65k. We might cause a * panic for out of memory if we just kept growing the buffer. @@ -1415,7 +1423,7 @@ Tcl_ZlibStreamGet( if (Tcl_IsShared(itemObj)) { itemObj = Tcl_DuplicateObj(itemObj); } - itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); + itemPtr = Tcl_GetBytesFromObj(NULL, itemObj, &itemLen); Tcl_IncrRefCount(itemObj); zshPtr->currentInput = itemObj; zshPtr->stream.next_in = itemPtr; @@ -1487,7 +1495,7 @@ Tcl_ZlibStreamGet( if (Tcl_IsShared(itemObj)) { itemObj = Tcl_DuplicateObj(itemObj); } - itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); + itemPtr = Tcl_GetBytesFromObj(NULL, itemObj, &itemLen); Tcl_IncrRefCount(itemObj); zshPtr->currentInput = itemObj; zshPtr->stream.next_in = itemPtr; @@ -1532,11 +1540,11 @@ Tcl_ZlibStreamGet( } } else { TclListObjLengthM(NULL, zshPtr->outData, &listLen); - if (count == -1) { + if (count < 0) { count = 0; for (i=0; i<listLen; i++) { Tcl_ListObjIndex(NULL, zshPtr->outData, i, &itemObj); - (void) Tcl_GetByteArrayFromObj(itemObj, &itemLen); + (void) Tcl_GetBytesFromObj(NULL, itemObj, &itemLen); if (i == 0) { count += itemLen - zshPtr->outPos; } else { @@ -1561,9 +1569,9 @@ Tcl_ZlibStreamGet( */ Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj); - itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); - if (itemLen-zshPtr->outPos >= count-dataPos) { - size_t len = count - dataPos; + itemPtr = Tcl_GetBytesFromObj(NULL, itemObj, &itemLen); + if ((itemLen-zshPtr->outPos) >= count-dataPos) { + Tcl_Size len = count - dataPos; memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len); zshPtr->outPos += len; @@ -1572,7 +1580,7 @@ Tcl_ZlibStreamGet( zshPtr->outPos = 0; } } else { - size_t len = itemLen - zshPtr->outPos; + Tcl_Size len = itemLen - zshPtr->outPos; memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len); dataPos += len; @@ -1675,7 +1683,7 @@ Tcl_ZlibDeflate( TclNewObj(obj); memset(&stream, 0, sizeof(z_stream)); - stream.avail_in = (uInt) inLen; + stream.avail_in = inLen; stream.next_in = inData; /* @@ -1809,10 +1817,10 @@ Tcl_ZlibInflate( if (gzipHeaderDictObj) { headerPtr = &header; memset(headerPtr, 0, sizeof(gz_header)); - nameBuf = (char *)ckalloc(MAXPATHLEN); + nameBuf = (char *)Tcl_Alloc(MAXPATHLEN); header.name = (Bytef *) nameBuf; header.name_max = MAXPATHLEN - 1; - commentBuf = (char *)ckalloc(MAX_COMMENT_LEN); + commentBuf = (char *)Tcl_Alloc(MAX_COMMENT_LEN); header.comment = (Bytef *) commentBuf; header.comm_max = MAX_COMMENT_LEN - 1; } @@ -1834,7 +1842,7 @@ Tcl_ZlibInflate( TclNewObj(obj); outData = Tcl_SetByteArrayLength(obj, bufferSize); memset(&stream, 0, sizeof(z_stream)); - stream.avail_in = (uInt) inLen+1; /* +1 because zlib can "over-request" + stream.avail_in = inLen+1; /* +1 because zlib can "over-request" * input (but ignore it!) */ stream.next_in = inData; stream.avail_out = bufferSize; @@ -1917,8 +1925,8 @@ Tcl_ZlibInflate( ExtractHeader(&header, gzipHeaderDictObj); SetValue(gzipHeaderDictObj, "size", Tcl_NewWideIntObj(stream.total_out)); - ckfree(nameBuf); - ckfree(commentBuf); + Tcl_Free(nameBuf); + Tcl_Free(commentBuf); } Tcl_SetObjResult(interp, obj); return TCL_OK; @@ -1927,10 +1935,10 @@ Tcl_ZlibInflate( TclDecrRefCount(obj); ConvertError(interp, e, stream.adler); if (nameBuf) { - ckfree(nameBuf); + Tcl_Free(nameBuf); } if (commentBuf) { - ckfree(commentBuf); + Tcl_Free(commentBuf); } return TCL_ERROR; } @@ -1981,8 +1989,11 @@ ZlibCmd( int objc, Tcl_Obj *const objv[]) { - int command, dlen, i, option, level = -1; - unsigned start, buffersize = 0; + int i, option, level = -1; + size_t buffersize = 0; + Tcl_Size dlen = 0; + unsigned int start; + Tcl_WideInt wideLen; Byte *data; Tcl_Obj *headerDictObj; const char *extraInfoStr = NULL; @@ -1994,7 +2005,7 @@ ZlibCmd( enum zlibCommands { CMD_ADLER, CMD_COMPRESS, CMD_CRC, CMD_DECOMPRESS, CMD_DEFLATE, CMD_GUNZIP, CMD_GZIP, CMD_INFLATE, CMD_PUSH, CMD_STREAM - }; + } command; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command arg ?...?"); @@ -2005,7 +2016,7 @@ ZlibCmd( return TCL_ERROR; } - switch ((enum zlibCommands) command) { + switch (command) { case CMD_ADLER: /* adler32 str ?startvalue? * -> checksum */ if (objc < 3 || objc > 4) { @@ -2135,14 +2146,15 @@ ZlibCmd( return TCL_ERROR; } if (objc > 3) { - if (Tcl_GetIntFromObj(interp, objv[3], - (int *) &buffersize) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[3], + &wideLen) != TCL_OK) { return TCL_ERROR; } - if (buffersize < MIN_NONSTREAM_BUFFER_SIZE - || buffersize > MAX_BUFFER_SIZE) { + if (wideLen < MIN_NONSTREAM_BUFFER_SIZE + || wideLen > MAX_BUFFER_SIZE) { goto badBuffer; } + buffersize = wideLen; } return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_RAW, objv[2], buffersize, NULL); @@ -2154,14 +2166,15 @@ ZlibCmd( return TCL_ERROR; } if (objc > 3) { - if (Tcl_GetIntFromObj(interp, objv[3], - (int *) &buffersize) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[3], + &wideLen) != TCL_OK) { return TCL_ERROR; } - if (buffersize < MIN_NONSTREAM_BUFFER_SIZE - || buffersize > MAX_BUFFER_SIZE) { + if (wideLen < MIN_NONSTREAM_BUFFER_SIZE + || wideLen > MAX_BUFFER_SIZE) { goto badBuffer; } + buffersize = wideLen; } return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], buffersize, NULL); @@ -2185,14 +2198,15 @@ ZlibCmd( } switch (option) { case 0: - if (Tcl_GetIntFromObj(interp, objv[i+1], - (int *) &buffersize) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[i+1], + &wideLen) != TCL_OK) { return TCL_ERROR; } - if (buffersize < MIN_NONSTREAM_BUFFER_SIZE - || buffersize > MAX_BUFFER_SIZE) { + if (wideLen < MIN_NONSTREAM_BUFFER_SIZE + || wideLen > MAX_BUFFER_SIZE) { goto badBuffer; } + buffersize = wideLen; break; case 1: headerVarObj = objv[i+1]; @@ -2262,7 +2276,7 @@ ZlibStreamSubcmd( enum zlibFormats { FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, FMT_INFLATE - }; + } fmt; int i, format, mode = 0, option, level; enum objIndices { OPT_COMPRESSION_DICTIONARY = 0, @@ -2303,7 +2317,7 @@ ZlibStreamSubcmd( return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &format) != TCL_OK) { + &fmt) != TCL_OK) { return TCL_ERROR; } @@ -2312,7 +2326,7 @@ ZlibStreamSubcmd( * specified. */ - switch ((enum zlibFormats) format) { + switch (fmt) { case FMT_DEFLATE: desc = compressionOpts; mode = TCL_ZLIB_STREAM_DEFLATE; @@ -2422,9 +2436,9 @@ ZlibPushSubcmd( enum zlibFormats { FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, FMT_INFLATE - }; + } fmt; Tcl_Channel chan; - int chanMode, format, mode = 0, level, i, option; + int chanMode, format, mode = 0, level, i; static const char *const pushCompressOptions[] = { "-dictionary", "-header", "-level", NULL }; @@ -2432,7 +2446,7 @@ ZlibPushSubcmd( "-dictionary", "-header", "-level", "-limit", NULL }; const char *const *pushOptions = pushDecompressOptions; - enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit}; + enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit} option; Tcl_Obj *headerObj = NULL, *compDictObj = NULL; int limit = DEFAULT_BUFFER_SIZE; Tcl_Size dummy; @@ -2443,10 +2457,10 @@ ZlibPushSubcmd( } if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &format) != TCL_OK) { + &fmt) != TCL_OK) { return TCL_ERROR; } - switch ((enum zlibFormats) format) { + switch (fmt) { case FMT_DEFLATE: mode = TCL_ZLIB_STREAM_DEFLATE; format = TCL_ZLIB_FORMAT_RAW; @@ -2494,7 +2508,7 @@ ZlibPushSubcmd( } 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)); + "decompression may only be applied to readable channels",TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", (void *)NULL); return TCL_ERROR; } @@ -2515,7 +2529,7 @@ ZlibPushSubcmd( Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (void *)NULL); return TCL_ERROR; } - switch ((enum pushOptionsEnum) option) { + switch (option) { case poHeader: headerObj = objv[i]; if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { @@ -2595,7 +2609,7 @@ ZlibStreamCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int command, count, code; + int count, code; Tcl_Obj *obj; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", @@ -2605,7 +2619,7 @@ ZlibStreamCmd( enum zlibStreamCommands { zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush, zs_fullflush, zs_get, zs_header, zs_put, zs_reset - }; + } command; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option data ?...?"); @@ -2617,7 +2631,7 @@ ZlibStreamCmd( return TCL_ERROR; } - switch ((enum zlibStreamCommands) command) { + switch (command) { case zs_add: /* $strm add ?$flushopt? $data */ return ZlibStreamAddCmd(zstream, interp, objc, objv); case zs_header: /* $strm header */ @@ -2721,14 +2735,14 @@ ZlibStreamAddCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int index, code, buffersize = -1, flush = -1, i; + int code, buffersize = -1, flush = -1, i; Tcl_Obj *obj, *compDictObj = NULL; static const char *const add_options[] = { "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL }; enum addOptions { ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush - }; + } index; for (i=2; i<objc-1; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0, @@ -2736,7 +2750,7 @@ ZlibStreamAddCmd( return TCL_ERROR; } - switch ((enum addOptions) index) { + switch (index) { case ao_flush: /* -flush */ if (flush >= 0) { flush = -2; @@ -2806,7 +2820,7 @@ ZlibStreamAddCmd( */ if (compDictObj != NULL) { - Tcl_Size len; + Tcl_Size len = 0; if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, &len)) { return TCL_ERROR; @@ -2848,14 +2862,14 @@ ZlibStreamPutCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int index, flush = -1, i; + int flush = -1, i; Tcl_Obj *compDictObj = NULL; static const char *const put_options[] = { "-dictionary", "-finalize", "-flush", "-fullflush", NULL }; enum putOptions { po_dictionary, po_finalize, po_flush, po_fullflush - }; + } index; for (i=2; i<objc-1; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], put_options, "option", 0, @@ -2863,7 +2877,7 @@ ZlibStreamPutCmd( return TCL_ERROR; } - switch ((enum putOptions) index) { + switch (index) { case po_flush: /* -flush */ if (flush >= 0) { flush = -2; @@ -2913,7 +2927,7 @@ ZlibStreamPutCmd( */ if (compDictObj != NULL) { - Tcl_Size len; + Tcl_Size len = 0; if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, &len)) { return TCL_ERROR; @@ -2978,7 +2992,7 @@ ZlibTransformClose( { ZlibChannelData *cd = (ZlibChannelData *)instanceData; int e, result = TCL_OK; - int written; + size_t written; if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) { return EINVAL; @@ -3054,14 +3068,14 @@ ZlibTransformClose( } if (cd->inBuffer) { - ckfree(cd->inBuffer); + Tcl_Free(cd->inBuffer); cd->inBuffer = NULL; } if (cd->outBuffer) { - ckfree(cd->outBuffer); + Tcl_Free(cd->outBuffer); cd->outBuffer = NULL; } - ckfree(cd); + Tcl_Free(cd); return result; } @@ -3134,13 +3148,13 @@ ZlibTransformInput( * Three cases here: * 1. Got some data from the underlying channel (readBytes > 0) so * it should be fed through the decompression engine. - * 2. Got an error (readBytes < 0) which we should report up except + * 2. Got an error (readBytes == -1) which we should report up except * for the case where we can convert it to a short read. * 3. Got an end-of-data from EOF or blocking (readBytes == 0). If * it is EOF, try flushing the data out of the decompressor. */ - if (readBytes < 0) { + if (readBytes == -1) { /* See ReflectInput() in tclIORTrans.c */ if (Tcl_InputBlocked(cd->parent) && (gotBytes > 0)) { @@ -3220,7 +3234,8 @@ ZlibTransformOutput( ZlibChannelData *cd = (ZlibChannelData *)instanceData; Tcl_DriverOutputProc *outProc = Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent)); - int e, produced; + int e; + size_t produced; Tcl_Obj *errObj; if (cd->mode == TCL_ZLIB_STREAM_INFLATE) { @@ -3282,7 +3297,8 @@ ZlibTransformFlush( ZlibChannelData *cd, int flushType) { - int e, len; + int e; + size_t len; cd->outStream.avail_in = 0; do { @@ -3498,14 +3514,14 @@ ZlibTransformGetOption( Tcl_DStringAppendElement(dsPtr, "-dictionary"); if (cd->compDictObj) { Tcl_DStringAppendElement(dsPtr, - Tcl_GetString(cd->compDictObj)); + TclGetString(cd->compDictObj)); } else { Tcl_DStringAppendElement(dsPtr, ""); } } else { if (cd->compDictObj) { Tcl_Size length; - const char *str = TclGetStringFromObj(cd->compDictObj, &length); + const char *str = Tcl_GetStringFromObj(cd->compDictObj, &length); Tcl_DStringAppend(dsPtr, str, length); } @@ -3526,7 +3542,7 @@ ZlibTransformGetOption( ExtractHeader(&cd->inHeader.header, tmpObj); if (optionName == NULL) { Tcl_DStringAppendElement(dsPtr, "-header"); - Tcl_DStringAppendElement(dsPtr, Tcl_GetString(tmpObj)); + Tcl_DStringAppendElement(dsPtr, TclGetString(tmpObj)); Tcl_DecrRefCount(tmpObj); } else { TclDStringAppendObj(dsPtr, tmpObj); @@ -3709,7 +3725,7 @@ ZlibStackChannelTransform( * dictionary (not dictObj!) to use if * necessary. */ { - ZlibChannelData *cd = (ZlibChannelData *)ckalloc(sizeof(ZlibChannelData)); + ZlibChannelData *cd = (ZlibChannelData *)Tcl_Alloc(sizeof(ZlibChannelData)); Tcl_Channel chan; int wbits = 0; @@ -3745,7 +3761,7 @@ ZlibStackChannelTransform( if (compDictObj != NULL) { cd->compDictObj = Tcl_DuplicateObj(compDictObj); Tcl_IncrRefCount(cd->compDictObj); - Tcl_GetByteArrayFromObj(cd->compDictObj, (Tcl_Size *)NULL); + Tcl_GetBytesFromObj(NULL, cd->compDictObj, (Tcl_Size *)NULL); } if (format == TCL_ZLIB_FORMAT_RAW) { @@ -3772,7 +3788,7 @@ ZlibStackChannelTransform( if (cd->inAllocated < cd->readAheadLimit) { cd->inAllocated = cd->readAheadLimit; } - cd->inBuffer = (char *)ckalloc(cd->inAllocated); + cd->inBuffer = (char *)Tcl_Alloc(cd->inAllocated); if (cd->flags & IN_HEADER) { if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) { goto error; @@ -3789,7 +3805,7 @@ ZlibStackChannelTransform( goto error; } cd->outAllocated = DEFAULT_BUFFER_SIZE; - cd->outBuffer = (char *)ckalloc(cd->outAllocated); + cd->outBuffer = (char *)Tcl_Alloc(cd->outAllocated); if (cd->flags & OUT_HEADER) { if (deflateSetHeader(&cd->outStream, &cd->outHeader.header) != Z_OK) { goto error; @@ -3814,17 +3830,17 @@ ZlibStackChannelTransform( error: if (cd->inBuffer) { - ckfree(cd->inBuffer); + Tcl_Free(cd->inBuffer); inflateEnd(&cd->inStream); } if (cd->outBuffer) { - ckfree(cd->outBuffer); + Tcl_Free(cd->outBuffer); deflateEnd(&cd->outStream); } if (cd->compDictObj) { Tcl_DecrRefCount(cd->compDictObj); } - ckfree(cd); + Tcl_Free(cd); return NULL; } @@ -3993,10 +4009,7 @@ TclZlibInit( * Formally provide the package as a Tcl built-in. */ -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) - Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); -#endif - return Tcl_PkgProvide(interp, "tcl::zlib", TCL_ZLIB_VERSION); + return Tcl_PkgProvideEx(interp, "tcl::zlib", TCL_ZLIB_VERSION, NULL); } /* @@ -4071,7 +4084,7 @@ int Tcl_ZlibStreamGet( Tcl_ZlibStream zshandle, Tcl_Obj *data, - Tcl_Size count) + size_t count) { return TCL_OK; } @@ -4096,7 +4109,7 @@ Tcl_ZlibInflate( Tcl_Interp *interp, int format, Tcl_Obj *data, - Tcl_Size bufferSize, + size_t bufferSize, Tcl_Obj *gzipHeaderDictObj) { if (interp) { @@ -4110,7 +4123,7 @@ unsigned int Tcl_ZlibCRC32( TCL_UNUSED(unsigned int), TCL_UNUSED(const unsigned char *), - TCL_UNUSED(Tcl_Size)) + TCL_UNUSED(size_t)) { return 0; } @@ -4119,7 +4132,7 @@ unsigned int Tcl_ZlibAdler32( TCL_UNUSED(unsigned int), TCL_UNUSED(const unsigned char *), - TCL_UNUSED(Tcl_Size)) + TCL_UNUSED(size_t)) { return 0; } diff --git a/library/auto.tcl b/library/auto.tcl index 9aa4da3..b28451c 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -108,7 +108,7 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { catch {lappend paths [::tcl::pkgconfig get bindir,runtime]} } if {[catch {::${basename}::pkgconfig get dllfile,runtime} dllfile]} { - set dllfile "lib${basename}${version}[info sharedlibextension]" + set dllfile "libtcl9${basename}${version}[info sharedlibextension]" } set dir [file dirname [file join [pwd] [info nameofexecutable]]] lappend paths $dir @@ -302,7 +302,7 @@ proc auto_mkindex_old {dir args} { set f "" set error [catch { set f [open $file] - fconfigure $f -encoding utf-8 -eofchar "\x1A {}" + fconfigure $f -encoding utf-8 -eofchar \x1A while {[gets $f line] >= 0} { if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { set procName [lindex [auto_qualify $procName "::"] 0] @@ -414,7 +414,7 @@ proc auto_mkindex_parser::mkindex {file} { set scriptFile $file set fid [open $file] - fconfigure $fid -encoding utf-8 -eofchar "\x1A {}" + fconfigure $fid -encoding utf-8 -eofchar \x1A set contents [read $fid] close $fid diff --git a/library/cookiejar/cookiejar.tcl b/library/cookiejar/cookiejar.tcl index 85f73b4..c9c0b1c 100644 --- a/library/cookiejar/cookiejar.tcl +++ b/library/cookiejar/cookiejar.tcl @@ -8,7 +8,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. # Dependencies -package require Tcl 8.6 +package require Tcl 8.6- package require http 2.8.4 package require sqlite3 package require tcl::idna 1.0 diff --git a/library/http/http.tcl b/library/http/http.tcl index 2d75cb0..26893fb 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1786,7 +1786,7 @@ proc http::OpenSocket {token DoLater} { fconfigure $sock -translation {auto crlf} \ -buffersize $state(-blocksize) if {[package vsatisfies [package provide Tcl] 9.0-]} { - fconfigure $sock -profile tcl8 + fconfigure $sock -profile replace } ##Log socket opened, DONE fconfigure - token $token } @@ -2207,7 +2207,7 @@ proc http::Connected {token proto phost srvurl} { fconfigure $sock -translation [list $trRead crlf] \ -buffersize $state(-blocksize) if {[package vsatisfies [package provide Tcl] 9.0-]} { - fconfigure $sock -profile tcl8 + fconfigure $sock -profile replace } # The following is disallowed in safe interpreters, but the socket is @@ -2600,7 +2600,7 @@ proc http::ReceiveResponse {token} { fconfigure $sock -translation [list auto $trWrite] \ -buffersize $state(-blocksize) if {[package vsatisfies [package provide Tcl] 9.0-]} { - fconfigure $sock -profile tcl8 + fconfigure $sock -profile replace } Log ^D$tk begin receiving response - token $token @@ -4594,7 +4594,7 @@ proc http::Eot {token {reason {}}} { set enc [CharsetToEncoding $state(charset)] if {$enc ne "binary"} { if {[package vsatisfies [package provide Tcl] 9.0-]} { - set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)] + set state(body) [encoding convertfrom -profile replace $enc $state(body)] } else { set state(body) [encoding convertfrom $enc $state(body)] } @@ -4681,7 +4681,7 @@ proc http::GuessType {token} { return 0 } if {[package vsatisfies [package provide Tcl] 9.0-]} { - set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)] + set state(body) [encoding convertfrom -profile replace $enc $state(body)] } else { set state(body) [encoding convertfrom $enc $state(body)] } @@ -4766,7 +4766,7 @@ proc http::quoteString {string} { # than [regsub]/[subst]). [Bug 1020491] if {[package vsatisfies [package provide Tcl] 9.0-]} { - set string [encoding convertto -profile tcl8 $http(-urlencoding) $string] + set string [encoding convertto -profile replace $http(-urlencoding) $string] } else { set string [encoding convertto $http(-urlencoding) $string] } diff --git a/library/init.tcl b/library/init.tcl index 33be0ac..ee5b07b 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -19,7 +19,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact tcl 8.7a6 +package require -exact tcl 9.0b1 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: @@ -47,7 +47,15 @@ package require -exact tcl 8.7a6 if {![info exists auto_path]} { if {[info exists env(TCLLIBPATH)] && (![interp issafe])} { - set auto_path $env(TCLLIBPATH) + set auto_path [apply {{} { + lmap path $::env(TCLLIBPATH) { + # Paths relative to unresolvable home dirs are ignored + if {[catch {file tildeexpand $path} expanded_path]} { + continue + } + set expanded_path + } + }}] } else { set auto_path "" } @@ -442,7 +450,7 @@ proc auto_load_index {} { continue } else { set error [catch { - fconfigure $f -encoding utf-8 -eofchar "\x1A {}" + fconfigure $f -encoding utf-8 -eofchar \x1A set id [gets $f] if {$id eq "# Tcl autoload index file, version 2.0"} { eval [read $f] diff --git a/library/install.tcl b/library/install.tcl index 50e40df..4abdead 100644 --- a/library/install.tcl +++ b/library/install.tcl @@ -35,7 +35,7 @@ proc ::practcl::_pkgindex_directory {path} { # Read the file, and override assumptions as needed ### set fin [open $file r] - fconfigure $fin -encoding utf-8 -eofchar "\x1A {}" + fconfigure $fin -encoding utf-8 -eofchar \x1A set dat [read $fin] close $fin # Look for a teapot style Package statement @@ -59,7 +59,7 @@ proc ::practcl::_pkgindex_directory {path} { foreach file [glob -nocomplain $path/*.tcl] { if { [file tail $file] == "version_info.tcl" } continue set fin [open $file r] - fconfigure $fin -encoding utf-8 -eofchar "\x1A {}" + fconfigure $fin -encoding utf-8 -eofchar \x1A set dat [read $fin] close $fin if {![regexp "package provide" $dat]} continue @@ -79,7 +79,7 @@ proc ::practcl::_pkgindex_directory {path} { return $buffer } set fin [open $pkgidxfile r] - fconfigure $fin -encoding utf-8 -eofchar "\x1A {}" + fconfigure $fin -encoding utf-8 -eofchar \x1A set dat [read $fin] close $fin set trace 0 diff --git a/library/package.tcl b/library/package.tcl index 2d72a7c..17ace66 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -137,6 +137,9 @@ proc pkg_mkIndex {args} { } on error {msg opt} { return -options $opt $msg } + if {[llength $fileList] == 0} { + return -code error "no files matched glob pattern \"$patternList\"" + } foreach file $fileList { # For each file, figure out what commands and packages it provides. # To do this, create a child interpreter, load the file into the diff --git a/library/safe.tcl b/library/safe.tcl index b84d2f5..830f14f 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -127,7 +127,7 @@ proc ::safe::CheckInterp {child} { # we had the bad idea to support for the sake of user simplicity in # create/init but which makes life hard in configure... # So this will be hopefully written and some integrated with opt1.0 -# (hopefully for tcl8.1 ?) +# (hopefully for tcl9.0 ?) proc ::safe::interpConfigure {args} { variable AutoPathSync switch [llength $args] { @@ -619,8 +619,6 @@ proc ::safe::InterpInit { ::interp alias $child ::tcl::info::nameofexecutable {} \ ::safe::AliasExeName $child - # The allowed child variables already have been set by Tcl_MakeSafe(3) - # Source init.tcl and tm.tcl into the child, to get auto_load and # other procedures defined: @@ -832,9 +830,6 @@ proc ::safe::CheckFileName {child file} { # prevent discovery of what home directories exist. proc ::safe::AliasFileSubcommand {child subcommand name} { - if {[string match ~* $name]} { - set name ./$name - } tailcall ::interp invokehidden $child tcl:file:$subcommand $name } @@ -1081,7 +1076,7 @@ proc ::safe::AliasSource {child args} { set replacementMsg "script error" set code [catch { set f [open $realfile] - fconfigure $f -encoding $encoding -eofchar "\x1A {}" + fconfigure $f -encoding $encoding -eofchar \x1A set contents [read $f] close $f ::interp eval $child [list info script $file] @@ -1424,7 +1419,7 @@ namespace eval ::safe { # Set to 1 for "traditional" behavior: a child's entire access path and # module path are copied to its ::auto_path, which is updated whenever # the user calls ::safe::interpAddToAccessPath to add to the access path. - variable AutoPathSync 1 + variable AutoPathSync 0 # Log command, set via 'setLogCmd'. Logging is disabled when empty. variable Log {} diff --git a/library/tm.tcl b/library/tm.tcl index 75abfb0..96bfe03 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -338,7 +338,10 @@ proc ::tcl::tm::Defaults {} { ] { if {![info exists env($ev)]} continue foreach p [split $env($ev) $sep] { - path add $p + # Paths relative to unresolvable home dirs are ignored + if {![catch {file tildeexpand $p} expanded_path]} { + path add $expanded_path + } } } } diff --git a/library/tzdata/SystemV/AST4 b/library/tzdata/SystemV/AST4 deleted file mode 100644 index eced0d2..0000000 --- a/library/tzdata/SystemV/AST4 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Puerto_Rico)]} { - LoadTimeZoneFile America/Puerto_Rico -} -set TZData(:SystemV/AST4) $TZData(:America/Puerto_Rico) diff --git a/library/tzdata/SystemV/AST4ADT b/library/tzdata/SystemV/AST4ADT deleted file mode 100644 index c24308f..0000000 --- a/library/tzdata/SystemV/AST4ADT +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Halifax)]} { - LoadTimeZoneFile America/Halifax -} -set TZData(:SystemV/AST4ADT) $TZData(:America/Halifax) diff --git a/library/tzdata/SystemV/CST6 b/library/tzdata/SystemV/CST6 deleted file mode 100644 index d46c015..0000000 --- a/library/tzdata/SystemV/CST6 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Regina)]} { - LoadTimeZoneFile America/Regina -} -set TZData(:SystemV/CST6) $TZData(:America/Regina) diff --git a/library/tzdata/SystemV/CST6CDT b/library/tzdata/SystemV/CST6CDT deleted file mode 100644 index 234af89..0000000 --- a/library/tzdata/SystemV/CST6CDT +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Chicago)]} { - LoadTimeZoneFile America/Chicago -} -set TZData(:SystemV/CST6CDT) $TZData(:America/Chicago) diff --git a/library/tzdata/SystemV/EST5 b/library/tzdata/SystemV/EST5 deleted file mode 100644 index 52818c1..0000000 --- a/library/tzdata/SystemV/EST5 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Indianapolis)]} { - LoadTimeZoneFile America/Indianapolis -} -set TZData(:SystemV/EST5) $TZData(:America/Indianapolis) diff --git a/library/tzdata/SystemV/EST5EDT b/library/tzdata/SystemV/EST5EDT deleted file mode 100644 index 6cf2743..0000000 --- a/library/tzdata/SystemV/EST5EDT +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/New_York)]} { - LoadTimeZoneFile America/New_York -} -set TZData(:SystemV/EST5EDT) $TZData(:America/New_York) diff --git a/library/tzdata/SystemV/HST10 b/library/tzdata/SystemV/HST10 deleted file mode 100644 index a4316af..0000000 --- a/library/tzdata/SystemV/HST10 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Pacific/Honolulu)]} { - LoadTimeZoneFile Pacific/Honolulu -} -set TZData(:SystemV/HST10) $TZData(:Pacific/Honolulu) diff --git a/library/tzdata/SystemV/MST7 b/library/tzdata/SystemV/MST7 deleted file mode 100644 index e67a781..0000000 --- a/library/tzdata/SystemV/MST7 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Phoenix)]} { - LoadTimeZoneFile America/Phoenix -} -set TZData(:SystemV/MST7) $TZData(:America/Phoenix) diff --git a/library/tzdata/SystemV/MST7MDT b/library/tzdata/SystemV/MST7MDT deleted file mode 100644 index fda5bf1..0000000 --- a/library/tzdata/SystemV/MST7MDT +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Denver)]} { - LoadTimeZoneFile America/Denver -} -set TZData(:SystemV/MST7MDT) $TZData(:America/Denver) diff --git a/library/tzdata/SystemV/PST8 b/library/tzdata/SystemV/PST8 deleted file mode 100644 index 8e30bb8..0000000 --- a/library/tzdata/SystemV/PST8 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Pacific/Pitcairn)]} { - LoadTimeZoneFile Pacific/Pitcairn -} -set TZData(:SystemV/PST8) $TZData(:Pacific/Pitcairn) diff --git a/library/tzdata/SystemV/PST8PDT b/library/tzdata/SystemV/PST8PDT deleted file mode 100644 index 8281a9a..0000000 --- a/library/tzdata/SystemV/PST8PDT +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Los_Angeles)]} { - LoadTimeZoneFile America/Los_Angeles -} -set TZData(:SystemV/PST8PDT) $TZData(:America/Los_Angeles) diff --git a/library/tzdata/SystemV/YST9 b/library/tzdata/SystemV/YST9 deleted file mode 100644 index 32d3717..0000000 --- a/library/tzdata/SystemV/YST9 +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Pacific/Gambier)]} { - LoadTimeZoneFile Pacific/Gambier -} -set TZData(:SystemV/YST9) $TZData(:Pacific/Gambier) diff --git a/library/tzdata/SystemV/YST9YDT b/library/tzdata/SystemV/YST9YDT deleted file mode 100644 index fba405f..0000000 --- a/library/tzdata/SystemV/YST9YDT +++ /dev/null @@ -1,5 +0,0 @@ -# created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Anchorage)]} { - LoadTimeZoneFile America/Anchorage -} -set TZData(:SystemV/YST9YDT) $TZData(:America/Anchorage) diff --git a/libtommath/tommath_private.h b/libtommath/tommath_private.h index 8aab7c3..f5ee285 100644 --- a/libtommath/tommath_private.h +++ b/libtommath/tommath_private.h @@ -188,9 +188,6 @@ MP_STATIC_ASSERT(prec_geq_min_prec, MP_PREC >= MP_MIN_PREC) /* random number source */ extern MP_PRIVATE mp_err(*s_mp_rand_source)(void *out, size_t size); -#ifdef __cplusplus -extern "C" { -#endif /* lowlevel functions, do not call! */ MP_PRIVATE mp_bool s_mp_get_bit(const mp_int *a, unsigned int b); MP_PRIVATE mp_err s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; @@ -246,10 +243,6 @@ MP_DEPRECATED(s_mp_toom_mul) mp_err mp_toom_mul(const mp_int *a, const mp_int *b MP_DEPRECATED(s_mp_toom_sqr) mp_err mp_toom_sqr(const mp_int *a, mp_int *b); MP_DEPRECATED(s_mp_reverse) void bn_reverse(unsigned char *s, int len); -#ifdef __cplusplus -} -#endif - #ifndef TCL_WITH_EXTERNAL_TOMMATH #undef mp_sqr #define mp_sqr TclBN_mp_sqr diff --git a/macosx/README b/macosx/README index 73be6c4..7261a01 100644 --- a/macosx/README +++ b/macosx/README @@ -108,7 +108,7 @@ The following build configurations are available: The Xcode projects refer to the toplevel tcl source directory via the TCL_SRCROOT user build setting, by default this is set to the project-relative path '../../tcl', if your tcl source directory is named differently, e.g. -'../../tcl8.7', you need to manually change the TCL_SRCROOT setting by editing +'../../tcl9.0', you need to manually change the TCL_SRCROOT setting by editing your ${USER}.pbxuser file (located inside the Tcl.xcodeproj bundle directory) with a text editor. @@ -126,9 +126,9 @@ Detailed Instructions for building with macosx/GNUmakefile - Unpack the Tcl source release archive. - The following instructions assume the Tcl source tree is named "tcl${ver}", -(where ${ver} is a shell variable containing the Tcl version number e.g. '8.7'). +(where ${ver} is a shell variable containing the Tcl version number e.g. '9.0'). Setup this shell variable as follows: - ver="8.7" + ver="9.0" - Setup environment variables as desired, e.g. for a universal build on 10.5: CFLAGS="-arch x86_64 -arch arm64 -mmacosx-version-min=10.5" diff --git a/macosx/Tcl-Common.xcconfig b/macosx/Tcl-Common.xcconfig index 5193b70..7f181c0 100644 --- a/macosx/Tcl-Common.xcconfig +++ b/macosx/Tcl-Common.xcconfig @@ -27,11 +27,9 @@ FRAMEWORK_INSTALL_PATH = /Library/Frameworks INCLUDEDIR = $(PREFIX)/include LIBDIR = $(PREFIX)/lib MANDIR = $(PREFIX)/man -PER_ARCH_CFLAGS_ppc = -mcpu=G3 -mtune=G4 $(PER_ARCH_CFLAGS_ppc) -PER_ARCH_CFLAGS_ppc64 = -mcpu=G5 -mpowerpc64 $(PER_ARCH_CFLAGS_ppc64) PREFIX = /usr/local TCL_CONFIGURE_ARGS = --enable-dtrace TCL_LIBRARY = $(LIBDIR)/tcl$(VERSION) TCL_PACKAGE_PATH = "$(LIBDIR)" TCL_DEFS = HAVE_TCL_CONFIG_H -VERSION = 8.7 +VERSION = 9.0 diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index e8c0924..8d27c1c 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -1319,7 +1319,6 @@ F96D3F3B08F272A8004A47F5 /* dde */, F96D3F8C08F272A8004A47F5 /* history.tcl */, F96D3F8D08F272A8004A47F5 /* http */, - F96D3F9008F272A8004A47F5 /* http1.0 */, F96D3F9308F272A8004A47F5 /* init.tcl */, F96D3F9408F272A8004A47F5 /* msgcat */, F96D401708F272AA004A47F5 /* opt */, @@ -1353,15 +1352,6 @@ path = http; sourceTree = "<group>"; }; - F96D3F9008F272A8004A47F5 /* http1.0 */ = { - isa = PBXGroup; - children = ( - F96D3F9108F272A8004A47F5 /* http.tcl */, - F96D3F9208F272A8004A47F5 /* pkgIndex.tcl */, - ); - path = http1.0; - sourceTree = "<group>"; - }; F96D3F9408F272A8004A47F5 /* msgcat */ = { isa = PBXGroup; children = ( diff --git a/macosx/tclMacOSXBundle.c b/macosx/tclMacOSXBundle.c index 6707ef0..5388238 100644 --- a/macosx/tclMacOSXBundle.c +++ b/macosx/tclMacOSXBundle.c @@ -146,41 +146,6 @@ OpenResourceMap( /* *---------------------------------------------------------------------- * - * Tcl_MacOSXOpenBundleResources -- - * - * Given the bundle name for a shared library, this routine sets - * libraryPath to the Resources/Scripts directory in the framework - * package. If hasResourceFile is true, it will also open the main - * resource file for the bundle. - * - * Results: - * TCL_OK if the bundle could be opened, and the Scripts folder found. - * TCL_ERROR otherwise. - * - * Side effects: - * libraryVariableName may be set, and the resource file opened. - * - *---------------------------------------------------------------------- - */ - -#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) -#undef Tcl_MacOSXOpenBundleResources -int -Tcl_MacOSXOpenBundleResources( - Tcl_Interp *interp, - const char *bundleName, - int hasResourceFile, - int maxPathLen, - char *libraryPath) -{ - return Tcl_MacOSXOpenVersionedBundleResources(interp, bundleName, NULL, - hasResourceFile, maxPathLen, libraryPath); -} -#endif - -/* - *---------------------------------------------------------------------- - * * Tcl_MacOSXOpenVersionedBundleResources -- * * Given the bundle and version name for a shared library (version name @@ -205,7 +170,7 @@ Tcl_MacOSXOpenVersionedBundleResources( const char *bundleName, const char *bundleVersion, int hasResourceFile, - int maxPathLen, + Tcl_Size maxPathLen, char *libraryPath) { #ifdef HAVE_COREFOUNDATION diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index eb40b3b..332e0a4 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -88,7 +88,8 @@ static const Tcl_ObjType tclOSTypeType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfOSType, /* updateStringProc */ - SetOSTypeFromAny /* setFromAnyProc */ + SetOSTypeFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; enum { @@ -202,7 +203,7 @@ TclMacOSXGetFileAttribute( return TCL_OK; #else Tcl_SetObjResult(interp, Tcl_NewStringObj( - "Mac OS X file attributes not supported", -1)); + "Mac OS X file attributes not supported", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (void *)NULL); return TCL_ERROR; #endif /* HAVE_GETATTRLIST */ @@ -334,7 +335,7 @@ TclMacOSXSetFileAttribute( if (newRsrcForkSize != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "setting nonzero rsrclength not supported", -1)); + "setting nonzero rsrclength not supported", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (void *)NULL); return TCL_ERROR; } @@ -375,7 +376,7 @@ TclMacOSXSetFileAttribute( return TCL_OK; #else Tcl_SetObjResult(interp, Tcl_NewStringObj( - "Mac OS X file attributes not supported", -1)); + "Mac OS X file attributes not supported", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (void *)NULL); return TCL_ERROR; #endif @@ -639,9 +640,10 @@ SetOSTypeFromAny( int result = TCL_OK; Tcl_DString ds; Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); + Tcl_Size length; - string = TclGetString(objPtr); - Tcl_UtfToExternalDString(encoding, string, objPtr->length, &ds); + string = Tcl_GetStringFromObj(objPtr, &length); + Tcl_UtfToExternalDStringEx(NULL, encoding, string, length, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); if (Tcl_DStringLength(&ds) > 4) { if (interp) { @@ -692,7 +694,7 @@ UpdateStringOfOSType( Tcl_Obj *objPtr) /* OSType object whose string rep to * update. */ { - const int size = TCL_UTF_MAX * 4; + const size_t size = TCL_UTF_MAX * 4; char *dst = Tcl_InitStringRep(objPtr, NULL, size); OSType osType = (OSType) objPtr->internalRep.wideValue; int written = 0; diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 169c7b9..7bf0fb3 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -311,7 +311,7 @@ typedef struct FileHandler { * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; @@ -505,7 +505,7 @@ static CFStringRef tclEventsOnlyRunLoopMode = NULL; */ static void StartNotifierThread(void); -static TCL_NORETURN void NotifierThreadProc(ClientData clientData); +static TCL_NORETURN void NotifierThreadProc(void *clientData); static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); static void TimerWakeUp(CFRunLoopTimerRef timer, void *info); static void QueueFileEvents(void *info); @@ -612,7 +612,7 @@ LookUpFileHandler( *---------------------------------------------------------------------- */ -ClientData +void * TclpInitNotifier(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -868,7 +868,7 @@ StartNotifierThread(void) void TclpFinalizeNotifier( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -970,7 +970,7 @@ TclpFinalizeNotifier( void TclpAlertNotifier( - ClientData clientData) + void *clientData) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; @@ -1047,7 +1047,7 @@ TclpSetTimer( static void TimerWakeUp( TCL_UNUSED(CFRunLoopTimerRef), - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { } @@ -1114,13 +1114,13 @@ TclpCreateFileHandler( * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); if (filePtr == NULL) { - filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->readyMask = 0; filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; @@ -1235,7 +1235,7 @@ TclpDeleteFileHandler( } else { prevPtr->nextPtr = filePtr->nextPtr; } - ckfree(filePtr); + Tcl_Free(filePtr); } /* @@ -1334,7 +1334,7 @@ FileHandlerEventProc( *---------------------------------------------------------------------- */ -ClientData +void * TclpNotifierData(void) { return NULL; @@ -1518,7 +1518,7 @@ QueueFileEvents( if (filePtr->readyMask == 0) { FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) - ckalloc(sizeof(FileHandlerEvent)); + Tcl_Alloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; @@ -1908,7 +1908,7 @@ int TclAsyncNotifier( int sigNumber, /* Signal number. */ TCL_UNUSED(Tcl_ThreadId), /* Target thread. */ - TCL_UNUSED(ClientData), /* Notifier data. */ + TCL_UNUSED(void *), /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { @@ -1967,7 +1967,7 @@ TclAsyncNotifier( static TCL_NORETURN void NotifierThreadProc( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr; fd_set readableMask, writableMask, exceptionalMask; diff --git a/tests/abstractlist.test b/tests/abstractlist.test new file mode 100644 index 0000000..79c30fb --- /dev/null +++ b/tests/abstractlist.test @@ -0,0 +1,635 @@ +# Exercise AbstractList via the "lstring" command defined in tclTestABSList.c +# +# Copyright © 2022 Brian Griffin +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +catch { + ::tcltest::loadTestedCommands + package require -exact tcl::test [info patchlevel] +} + +testConstraint testevalex [llength [info commands testevalex]] +testConstraint testobj [llength [info commands testobj]] +testConstraint lstring [llength [info commands lstring]] +testConstraint lgen [llength [info commands lgegenn]] + +set abstractlisttestvars [info var *] + +proc value-cmp {vara varb} { + upvar $vara a + upvar $varb b + set ta [tcl::unsupported::representation $a] + set tb [tcl::unsupported::representation $b] + return [string compare $ta $tb] +} + +set str "If you can keep your head when all about you Are losing theirs and blaming it on you," +set str2 "If you can trust yourself when all men doubt you, But make allowance for their doubting, too." + +test abstractlist-1.0 {error cases} -constraints lstring -body { + lstring +} \ + -returnCodes 1 \ + -result {wrong # args: should be "lstring string"} + +test abstractlist-1.1 {error cases} -constraints lstring -body { + lstring a b c +} -returnCodes 1 \ + -result {wrong # args: should be "lstring string"} + +test abstractlist-2.0 {no shimmer llength} -constraints {testobj lstring} -body { + set l [lstring $str] + set l-isa [testobj objtype $l] + set len [llength $l] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${len} ${l-isa2} +} -cleanup { +unset l +} -result {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring 85 lstring} + +test abstractlist-2.1 {no shimmer lindex} {testobj lstring} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set ele [lindex $l 22] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${ele} ${l-isa2} +} {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring e lstring} + +test abstractlist-2.2 {no shimmer lreverse} {testobj lstring} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set r [lreverse $l] + set r-isa [testobj objtype $r] + set l-isa2 [testobj objtype $l] + list $r ${l-isa} ${r-isa} ${l-isa2} +} {{, u o y { } n o { } t i { } g n i m a l b { } d n a { } s r i e h t { } g n i s o l { } e r A { } u o y { } t u o b a { } l l a { } n e h w { } d a e h { } r u o y { } p e e k { } n a c { } u o y { } f I} lstring lstring lstring} + +test abstractlist-2.3 {no shimmer lrange} {testobj lstring} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set il [lsearch -all [lstring $str] { }] + set l-isa2 [testobj objtype $l] + lappend il [llength $l] + set start 0 + set words [lmap i $il { + set w [join [lrange $l $start $i-1] {} ] + set start [expr {$i+1}] + set w + }] + set l-isa3 [testobj objtype $l] + list ${l-isa} $il ${l-isa2} ${l-isa3} $words +} {lstring {2 6 10 15 20 25 30 34 40 44 48 55 62 66 74 77 80 85} lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} + +test abstractlist-2.4 {no shimmer foreach} {testobj lstring} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set word {} + set words {} + foreach c $l { + if {$c eq { }} { + lappend words $word + set word {} + } else { + append word $c + } + } + if {$word ne ""} { + lappend words $word + } + set l-isa2 [testobj objtype $l] + list ${l-isa} ${l-isa2} $words +} {lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} + +# +# The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. +# +test abstractlist-2.5 {!no shimmer lreplace} {testobj lstring} { + set l [lstring $str2] + set l-isa [testobj objtype $l] + set m [lreplace $l 78 86 { } f a i l i n g] + set m-isa [testobj objtype $m] + set l-isa1 [testobj objtype $l] + list ${l-isa} $m ${m-isa} ${l-isa1} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } f a i l i n g , { } t o o .} lstring lstring} + +test abstractlist-2.6 {no shimmer ledit} {testobj lstring} { + # "ledit m 9 8 S" + set l [lstring $str2] + set l-isa [testobj objtype $l] + set e [ledit l 68 67 s] + set e-isa [testobj objtype $e] + list ${l-isa} $e ${e-isa} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e s { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} + +test abstractlist-2.7 {no shimmer linsert} -constraints {testobj lstring} -body { + # "ledit m 9 8 S" + set l [lstring $str2] + set l-isa [testobj objtype $l] + set i [linsert $l 11 {*}[split "truly " {}]] + set i-isa [testobj objtype $i] + set res [list ${l-isa} $i ${i-isa}] + set p [lpop i 23] + set p-isa [testobj objtype $p] + set i-isa2 [testobj objtype $i] + lappend res $p ${p-isa} $i ${i-isa2} +} -cleanup { +unset l i l-isa i-isa res p p-isa +} -result {lstring {I f { } y o u { } c a n { } t r u l y { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring y none {I f { } y o u { } c a n { } t r u l y { } t r u s t { } o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} + +test abstractlist-2.8 {shimmer lassign} {testobj lstring} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lassign $l i n c] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} lstring lstring} + +test abstractlist-2.9 {no shimmer lremove} {testobj lstring} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lremove $l 0 1] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring} + +test abstractlist-2.10 {shimmer lreverse} {testobj lstring} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lreverse $l] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring} + +test abstractlist-2.11 {shimmer lset} {testobj lstring} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set m [lset l 2 k] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} + +# lrepeat +test abstractlist-2.12 {shimmer lrepeat} {testobj lstring} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set m [lrepeat 3 $l] + set m-isa [testobj objtype $m] + set n [lindex $m 1] + list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] +} {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} + +test abstractlist-2.13 {no shimmer join llength==1} {testobj lstring} { + set l [lstring G] + set l-isa [testobj objtype $l] + set j [join $l :] + set j-isa [testobj objtype $j] + list ${l-isa} $l ${j-isa} $j +} {lstring G none G} + +test abstractlist-2.14 {error case lset multiple indicies} -constraints {testobj lstring} -body { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set m [lset l 2 0 1 k] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} -returnCodes 1 \ + -result {Multiple indicies not supported by lstring.} + +# lsort + +test abstractlist-3.0 {no shimmer llength} {testobj lstring} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set len [llength $l] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${len} ${l-isa2} +} {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring 85 lstring} + +test abstractlist-3.1 {no shimmer lindex} {testobj lstring} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set n 22 + set ele [lindex $l $n] ;# exercise INST_LIST_INDEX + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${ele} ${l-isa2} +} {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring e lstring} + +test abstractlist-3.2 {no shimmer lreverse} {testobj lstring} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set r [lreverse $l] + set r-isa [testobj objtype $r] + set l-isa2 [testobj objtype $l] + list $r ${l-isa} ${r-isa} ${l-isa2} +} {{, u o y { } n o { } t i { } g n i m a l b { } d n a { } s r i e h t { } g n i s o l { } e r A { } u o y { } t u o b a { } l l a { } n e h w { } d a e h { } r u o y { } p e e k { } n a c { } u o y { } f I} lstring lstring lstring} + +test abstractlist-3.3 {shimmer lrange} {testobj lstring} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set il [lsearch -all [lstring -not SLICE $str] { }] + set l-isa2 [testobj objtype $l] + lappend il [llength $l] + set start 0 + set words [lmap i $il { + set w [join [lrange $l $start $i-1] {} ] + set start [expr {$i+1}] + set w + }] + set l-isa3 [testobj objtype $l]; # lrange defaults to list behavior + list ${l-isa} $il ${l-isa2} ${l-isa3} $words +} {lstring {2 6 10 15 20 25 30 34 40 44 48 55 62 66 74 77 80 85} lstring list {If you can keep your head when all about you Are losing theirs and blaming it on you,}} + +test abstractlist-3.4 {no shimmer foreach} {testobj lstring} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set word {} + set words {} + foreach c $l { + if {$c eq { }} { + lappend words $word + set word {} + } else { + append word $c + } + } + if {$word ne ""} { + lappend words $word + } + set l-isa2 [testobj objtype $l] + list ${l-isa} ${l-isa2} $words +} {lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} + +# +# The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. +# +test abstractlist-3.5 {!no shimmer lreplace} {testobj lstring} { + set l [lstring -not SLICE $str2] + set l-isa [testobj objtype $l] + set m [lreplace $l 79 86 f a i l i n g] + set m-isa [testobj objtype $m] + set l-isa1 [testobj objtype $l] + list ${l-isa} $m ${m-isa} ${l-isa1} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } f a i l i n g , { } t o o .} lstring lstring} + +test abstractlist-3.6 {no shimmer ledit} {testobj lstring} { + # "ledit m 9 8 S" + set l [lstring -not SLICE $str2] + set l-isa [testobj objtype $l] + set e [ledit l 68 67 s] + set e-isa [testobj objtype $e] + list ${l-isa} $e ${e-isa} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e s { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} + +test abstractlist-3.7 {no shimmer linsert} {testobj lstring} { + # "ledit m 9 8 S" + set res {} + set l [lstring -not SLICE $str2] + set l-isa [testobj objtype $l] + set i [linsert $l 35 {*}[split "wo" {}]] + set i-isa [testobj objtype $i] + set res [list ${l-isa} $i ${i-isa}] + set p [lpop i 23] + set p-isa [testobj objtype $p] + set i-isa2 [testobj objtype $i] + lappend res $p ${p-isa} $i ${i-isa2} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } w o m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring l none {I f { } y o u { } c a n { } t r u s t { } y o u r s e f { } w h e n { } a l l { } w o m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} + +test abstractlist-3.8 {shimmer lassign} {testobj lstring} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lassign $l i n c] ;# must be using lrange internally + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} list list} + +test abstractlist-3.9 {no shimmer lremove} {testobj lstring} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lremove $l 0 1] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring} + +test abstractlist-3.10 {shimmer lreverse} {testobj lstring} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lreverse $l] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring} + +test abstractlist-3.11 {shimmer lset} {testobj lstring} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set four 4 + set m [lset l $four-2 k] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} + +# lrepeat +test abstractlist-3.12 {shimmer lrepeat} {testobj lstring} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set m [lrepeat 3 $l] + set m-isa [testobj objtype $m] + set n [lindex $m 1] + list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] +} {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} + +# lsort +foreach not {{} REVERSE SLICE SETELEMENT REPLACE GETELEMENTS} { + + testConstraint [format "%sShimmer" [string totitle $not]] [expr {$not eq ""}] + set options [expr {$not ne "" ? "-not $not" : ""}] + +test abstractlist-$not-4.0 {no shimmer llength} {testobj lstring} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set len [llength $l] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${len} ${l-isa2} +} {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring 85 lstring} + +test abstractlist-$not-4.1 {no shimmer lindex} {testobj lstring} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set ele [lindex $l 22] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${ele} ${l-isa2} +} {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring e lstring} + +test abstractlist-$not-4.2 {lreverse} {ReverseShimmer testobj lstring} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set r [lreverse $l] + set r-isa [testobj objtype $r] + set l-isa2 [testobj objtype $l] + list $r ${l-isa} ${r-isa} ${l-isa2} +} {{, u o y { } n o { } t i { } g n i m a l b { } d n a { } s r i e h t { } g n i s o l { } e r A { } u o y { } t u o b a { } l l a { } n e h w { } d a e h { } r u o y { } p e e k { } n a c { } u o y { } f I} lstring lstring lstring} + +test abstractlist-$not-4.3 {no shimmer lrange} {RangeShimmer testobj lstring} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set il [lsearch -all [lstring {*}$options $str] { }] + set l-isa2 [testobj objtype $l] + lappend il [llength $l] + set start 0 + set words [lmap i $il { + set w [join [lrange $l $start $i-1] {} ] + set start [expr {$i+1}] + set w + }] + set l-isa3 [testobj objtype $l] + list ${l-isa} $il ${l-isa2} ${l-isa3} $words +} {lstring {2 7 10 16 25 29 36 39 47 55 58 63} lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} + +test abstractlist-$not-4.4 {no shimmer foreach} {testobj lstring} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set word {} + set words {} + foreach c $l { + if {$c eq { }} { + lappend words $word + set word {} + } else { + append word $c + } + } + if {$word ne ""} { + lappend words $word + } + set l-isa2 [testobj objtype $l] + list ${l-isa} ${l-isa2} $words +} {lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} + +# +# The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. +# +test abstractlist-$not-4.5 {!no shimmer lreplace} {RangeShimmer testobj lstring} { + set l [lstring {*}$options $str2] + set l-isa [testobj objtype $l] + set m [lreplace $l 18 23 { } f a i l ?] + set m-isa [testobj objtype $m] + set l-isa1 [testobj objtype $l] + list ${l-isa} $m ${m-isa} ${l-isa1} +} {lstring {} list lstring} + +test abstractlist-$not-4.6 {no shimmer ledit} {SetelementShimmer ReplaceShimmer testobj lstring} { + set l [lstring {*}$options $str2] + set l-isa [testobj objtype $l] + set e [ledit l 68 67 s] + set e-isa [testobj objtype $e] + list ${l-isa} $e ${e-isa} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e s { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} + +test abstractlist-$not-4.7 {no shimmer linsert} {ReplaceShimmer GetelementsShimmer testobj lstring} { + set l [lstring {*}$options $str2] + set l-isa [testobj objtype $l] + set i [linsert $l 12 {*}[split "almost " {}]] + set i-isa [testobj objtype $i] + set res [list ${l-isa} $i ${i-isa}] + set p [lpop i 23] + set p-isa [testobj objtype $p] + set i-isa2 [testobj objtype $i] + lappend res $p ${p-isa} $i ${i-isa2} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} + +# lassign probably uses lrange internally +test abstractlist-$not-4.8 {shimmer lassign} {RangeShimmer testobj lstring} { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lassign $l i n c] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} lstring lstring} + +test abstractlist-$not-4.9 {no shimmer lremove} {ReplaceShimmer testobj lstring} { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lremove $l 0 1] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring} + +test abstractlist-$not-4.10 {shimmer lreverse} {ReverseShimmer testobj lstring} { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lreverse $l] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring} + +test abstractlist-$not-4.11 {shimmer lset} {SetelementShimmer testobj lstring} { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set m [lset l 2 k] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} + +test abstractlist-$not-4.11x {lset not compiled} {SetelementShimmer testobj lstring testevalex} { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set m [testevalex {lset l 2 k}] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} + +test abstractlist-$not-4.11e {error case lset multiple indicies} \ + -constraints {SetelementShimmer testobj lstring testevalex} -body { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set m [testevalex {lset l 2 0 1 k}] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} -returnCodes 1 \ + -result {Multiple indicies not supported by lstring.} + +# lrepeat +test abstractlist-$not-4.12 {shimmer lrepeat} -constraints {testobj lstring} -body { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set m [lrepeat 3 $l] + set m-isa [testobj objtype $m] + set n [lindex $m 1] + list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] +} -cleanup { +} -result {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} + +# Disable constraint +testConstraint [format "%sShimmer" [string totitle $not]] 1 + +} + +# +# Test fix for bug in TEBC for STR CONCAT, and LIST INDEX +# instructions. +# This example abstract list (lgen) causes a rescursive call in TEBC, +# stack management was not included for these instructions in TEBC. +# +test abstractlist-lgen-bug {bug in str concat and list operations} -constraints lgen -setup { + set lgenfile [makeFile { + # Test TIP 192 - Lazy Lists + + set res {} + set cntr 0 + + # Fatal error here when [source]'d -- It is a refcounting problem... + lappend res Index*2:[lgen 1 expr 2* ]:-- + set x [lseq 17] + set y [lgen 17 apply {{index} {expr {$index * 6}}}] ;# expr * 6 + foreach i $x n $y { + lappend res "$i -> $n" + } + proc my_expr {offset index} { + expr {$index + $offset} + } + lappend res my_expr(3):[my_expr 3 0] + + lappend res [set ss [lgen 15 my_expr 7]] + lappend res s2:[list "Index+7:" $ss ":--"] + + lappend res foo:[list "Index-8:" [lgen 15 my_expr -8] ":--"] + + set 9 [lgen 15 my_expr 7] + lappend res 9len=[llength $9] + lappend res 9(3)=[lindex $9 3] + lappend res bar:[list "Index+7:" $9 ":--"] + + lappend res Index+7:$9:-- + + lappend res Index+7:[lgen 15 my_expr 7]:-- + + proc fib {phi n} { + set d [expr {round(pow($phi, $n) / sqrt(5.0))}] + return $d + } + set phi [expr {(1 + sqrt(5.0)) / 2.0}] + + lappend res fib:[lmap n [lseq 5] {fib $phi $n}] + + set x [lgen 20 fib $phi] + lappend res "First 20 fibbinacci:[lgen 20 fib $phi]" + lappend res "First 20 fibbinacci from x :$x" + unset x + lappend res Good-Bye! + set res + } source.file] +} -body { + set tcl_traceExec 0 + set tcl_traceCompile 0 + set f $lgenfile + #set script [format "puts ====-%s-====\nsource %s\nputs ====-done-====\n" $f $f] + set script [format "source %s" $f] + #puts stderr "eval $script" + eval $script +} -cleanup { + removeFile source.file + unset res +} -result {Index*2:0:-- {0 -> 0} {1 -> 6} {2 -> 12} {3 -> 18} {4 -> 24} {5 -> 30} {6 -> 36} {7 -> 42} {8 -> 48} {9 -> 54} {10 -> 60} {11 -> 66} {12 -> 72} {13 -> 78} {14 -> 84} {15 -> 90} {16 -> 96} my_expr(3):3 {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} {s2:Index+7: {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} :--} {foo:Index-8: {-8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6} :--} 9len=15 9(3)=10 {bar:Index+7: {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} :--} {Index+7:7 8 9 10 11 12 13 14 15 16 17 18 19 20 21:--} {Index+7:7 8 9 10 11 12 13 14 15 16 17 18 19 20 21:--} {fib:0 1 1 2 3} {First 20 fibbinacci:0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181} {First 20 fibbinacci from x :0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181} Good-Bye!} + +test abstractlist-lgen-bug2 {bug in foreach} -constraints lgen -body { + + set x [lseq 17] + set y [lgen 17 expr 6*] + + lappend res x-[lrange [tcl::unsupported::representation $x] 0 3] + lappend res y-[lrange [tcl::unsupported::representation $y] 0 3] + foreach i $x n $y { + lappend res "$i -> $n" + } + lappend res x-[lrange [tcl::unsupported::representation $x] 0 3] + lappend res y-[lrange [tcl::unsupported::representation $y] 0 3] + +} -cleanup { + unset res +} -result {{x-value is a arithseries} {y-value is a lgenseries} {0 -> 0} {1 -> 6} {2 -> 12} {3 -> 18} {4 -> 24} {5 -> 30} {6 -> 36} {7 -> 42} {8 -> 48} {9 -> 54} {10 -> 60} {11 -> 66} {12 -> 72} {13 -> 78} {14 -> 84} {15 -> 90} {16 -> 96} {x-value is a arithseries} {y-value is a lgenseries}} + +# scalar values +test abstractlist-int {TclLengthOne: anti-shimmer of boolean, int, double, bignum} testobj { + set res {} + foreach i [list [expr {1+0}] [expr {true}] [expr {3.141592}] [expr {round(double(0x7fffffffffffffff))}]] { + lappend res [testobj objtype $i] + lappend res [llength $i] + lappend res [testobj objtype $i] + } +#set w [expr {3.141592}] +#lappend res [testobj objtype $w] [llength $w] [testobj objtype $w] + set res +} {int 1 int boolean 1 boolean double 1 double bignum 1 bignum} + +# lsort + +# cleanup +::tcltest::cleanupTests + +proc my_abstl_cleanup {vars} { + set nowvars [uplevel info vars] + foreach var $nowvars { + if {$var ni $vars} { + uplevel unset $var + lappend clean-list $var + } + } + return ${clean-list} +} + +my_abstl_cleanup $abstractlisttestvars diff --git a/tests/apply.test b/tests/apply.test index 24b27cc..a5f1f8f 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -261,7 +261,7 @@ test apply-9.1 {leaking internal rep} -setup { lindex $lines 3 3 } set lam [list {} {set a 1}] -} -constraints {memory} -body { +} -constraints memory -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { ::apply [lrange $lam 0 end] diff --git a/tests/assemble.test b/tests/assemble.test index 4452b38..0a7631a 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -534,18 +534,6 @@ test assemble-7.16 {incrStk} { -result 12 -cleanup {rename x {}} } -test assemble-7.17 {land/lor} { - -body { - proc x {a b} { - list \ - [assemble {load a; load b; land}] \ - [assemble {load a; load b; lor}] - } - list [x 0 0] [x 0 23] [x 35 0] [x 47 59] - } - -result {{0 0} {0 1} {0 1} {1 1}} - -cleanup {rename x {}} -} test assemble-7.18 {lappendArrayStk} { -body { proc x {} { 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/bigdata.test b/tests/bigdata.test new file mode 100644 index 0000000..a5a2077 --- /dev/null +++ b/tests/bigdata.test @@ -0,0 +1,1182 @@ +# Test cases for large sized data +# +# 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. + +# These are very rudimentary tests for large size arguments to commands. +# They do not exercise all possible code paths such as shared/unshared Tcl_Objs, +# literal/variable arguments etc. +# They do however test compiled and uncompiled execution. + +if {"::tcltest" ni [namespace children]} { + package require tcltest + + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] +source [file join [file dirname [info script]] tcltests.tcl] + +# +# bigtest and bigtestRO (RO->read only) generate compiled and uncompiled +# versions of the given test script. The difference between the two is +# that bigtest generates separate test instances for the two cases while +# bigtestRO generates a single test case covering both. The latter can +# only be used when operands are not modified and when combining tests +# does not consume too much additional memory. + +# Wrapper to generate compiled and uncompiled cases for a test. If $args does +# not contain a -body key, $comment is treated as the test body +proc bigtest {id comment result args} { + if {[dict exists $args -body]} { + set body [dict get $args -body] + dict unset args -body + } else { + set body $comment + } + dict lappend args -constraints bigdata + + uplevel 1 [list test $id.uncompiled "$comment (uncompiled)" \ + -body [list testevalex $body] \ + -result $result \ + {*}$args] + + uplevel 1 [list test $id.compiled-script "$comment (compiled script)" \ + -body [list try $body] \ + -result $result \ + {*}$args] + + return + + # TODO - is this proc compilation required separately from the compile-script above? + dict append args -setup \n[list proc testxproc {} $body] + dict append args -cleanup "\nrename testxproc {}" + uplevel 1 [list test $id.compiled-proc "$comment (compiled proc)" \ + -body {testxproc} \ + -result $result \ + {*}$args] +} + +# Like bigtest except that both compiled and uncompiled are combined into one +# test using the same inout argument. This saves time but for obvious reasons +# should only be used when the input argument is not modified. +proc bigtestRO {id comment result args} { + if {[dict exists $args -body]} { + set body [dict get $args -body] + dict unset args -body + } else { + set body $comment + } + dict lappend args -constraints bigdata + + set wrapper "" + set body "{$body}" + append wrapper "set uncompiled_result \[testevalex $body]" \n + append wrapper "set compiled_result \[try $body]" \n + append wrapper {list $uncompiled_result $compiled_result} + uplevel 1 [list test $id.uncompiled,compiled {$comment} \ + -body $wrapper \ + -result [list $result $result] \ + {*}$args] + return +} + +interp alias {} bigClean {} unset -nocomplain s s1 s2 bin bin1 bin2 l l1 l2 + +interp alias {} bigString {} testbigdata string +interp alias {} bigBinary {} testbigdata bytearray +interp alias {} bigList {} testbigdata list +proc bigPatLen {} { + proc bigPatLen {} "return [string length [testbigdata string]]" + bigPatLen +} + +# Returns list of expected elements at the indices specified +proc bigStringIndices {indices} { + set pat [testbigdata string] + set patlen [string length $pat] + lmap idx $indices { + string index $pat [expr {$idx%$patlen}] + } +} + +# Returns the largest multiple of the pattern length that is less than $limit +proc bigPatlenMultiple {limit} { + set patlen [bigPatLen] + return [expr {($limit/$patlen)*$patlen}] +} + +set ::bigLengths(intmax) 0x7fffffff +set ::bigLengths(uintmax) 0xffffffff +# Some tests are more convenient if operands are multiple of pattern length +if {[testConstraint bigdata]} { +set ::bigLengths(patlenmultiple) [bigPatlenMultiple $::bigLengths(intmax)] +set ::bigLengths(upatlenmultiple) [bigPatlenMultiple $::bigLengths(uintmax)] +} + +# +# script limits +bigtestRO script-length-bigdata-1 {Test script length limit} b -body { + try [string cat [string repeat " " 0x7ffffff7] "set a b"] +} +# TODO - different behaviour between compiled and uncompiled +test script-length-bigdata-2.compiled {Test script length limit} -body { + try [string cat [string repeat " " 0x7ffffff8] "set a b"] +} -constraints { + bigdata +} -result {Script length 2147483647 exceeds max permitted length 2147483646.} -returnCodes error +test script-length-bigdata-2.uncompiled {Test script length limit} -body { + testevalex [string cat [string repeat " " 0x7ffffff8] "set a b"] +} -constraints { + bigdata + } -result b +test script-bytecode-length-bigdata-1 {Test bytecode length limit} -body { + # Note we need to exceed bytecode limit without exceeding script char limit + set s [string repeat {{*}$x;} [expr 0x7fffffff/6]] + catch $s r e +} -cleanup { + bigClean +} -constraints panic-in-EnterCmdStartData + +# +# string cat +bigtest string-cat-bigdata-1 "string cat large small result > INT_MAX" 1 -body { + string equal \ + [string cat [bigString $::bigLengths(patlenmultiple)] [bigString]] \ + [bigString [expr {[bigPatLen]+$::bigLengths(patlenmultiple)}]] +} +bigtest string-cat-bigdata-2 "string cat small large result > INT_MAX" 1 -body { + string equal \ + [string cat [bigString] [bigString $::bigLengths(patlenmultiple)]] \ + [bigString [expr {[bigPatLen]+$::bigLengths(patlenmultiple)}]] +} +bigtest string-cat-bigdata-3 "string cat result > UINT_MAX" 1 -body { + set s [bigString $::bigLengths(patlenmultiple)] + string equal \ + [string cat $s [bigString] $s] \ + [bigString [expr {[bigPatLen]+2*$::bigLengths(patlenmultiple)}]] +} + +# +# string compare/equal +bigtestRO string-equal/compare-bigdata-1 "string compare/equal equal strings" {0 1} -body { + list [string compare $s1 $s2] [string equal $s1 $s2] +} -setup { + set s1 [bigString 0x100000000] + set s2 [bigString 0x100000000]; # Separate so Tcl_Obj is not the same +} -cleanup { + bigClean +} +bigtestRO string-equal/compare-bigdata-2 "string compare/equal -length unequal strings" {-1 0 0 1} -body { + # Also tests lengths do not wrap + set result {} + lappend result [string compare $s1 $s2] + lappend result [string equal $s1 $s2] + # Check lengths > UINT_MAX + # Also that lengths do not truncate to sizeof(int) + lappend result [string compare -length 0x100000000 $s1 $s2] + lappend result [string equal -length 0x100000000 $s1 $s2] +} -setup { + set s1 [bigString 0x100000001] + set s2 [bigString 0x100000001 0x100000000]; # Differs in last char +} -cleanup { + bigClean +} + +# +# string first +bigtestRO string-first-bigdata-1 "string first > INT_MAX" {2147483648 -1 2147483650 1} -body { + list \ + [string first X $s] \ + [string first Y $s] \ + [string first 0 $s 0x80000000] \ + [string first 1 $s end-0x80000010] +} -setup { + set s [bigString 0x8000000a 0x80000000] +} -cleanup { + bigClean +} + +bigtestRO string-first-bigdata-2 "string first > UINT_MAX" {4294967296 -1 4294967300 1} -body { + list \ + [string first X $s] \ + [string first Y $s] \ + [string first 0 $s 0x100000000] \ + [string first 1 $s end-0x100000010] +} -setup { + set s [bigString 0x10000000a 0x100000000] +} -cleanup { + bigClean +} + +bigtestRO string-first-bigdata-3 "string first - long needle" 10 -body { + string first $needle $s +} -setup { + set s [bigString 0x10000000a 0] + set needle [bigString 0x100000000] +} -cleanup { + bigClean needle +} + +# +# string index +bigtestRO string-index-bigdata-1 "string index" {6 7 5 {} 5 4 {} 9 {}} -body { + list \ + [string index $s 0x100000000] \ + [string index $s 0x100000000+1] \ + [string index $s 0x100000000-1] \ + [string index $s 0x10000000a] \ + [string index $s end] \ + [string index $s end-1] \ + [string index $s end+1] \ + [string index $s end-0x100000000] \ + [string index $s end-0x10000000a] +} -setup { + set s [bigString 0x10000000a] +} -cleanup { + bigClean +} + +# +# string insert +bigtestRO string-insert-bigdata-1 "string insert" 1 -body { + # Note insert at multiple of 10 to enable comparison against generated string + string equal [string insert [bigString 4294967312] 4294967310 "0123456789"] [bigString 4294967322] +} +bigtestRO string-insert-bigdata-2 "string insert" 1 -body { + string equal [string insert [bigString 4294967312] 10 "0123456789"] [bigString 4294967322] +} + +# +# string is +bigtestRO string-is-bigdata-1 "string is" {1 0 0 4294967296} -body { + # TODO - add the other "is" classes + unset -nocomplain failat result + lappend result [string is alnum -failindex failat $s] [info exists failat] + lappend result [string is digit -failindex failat $s] $failat +} -setup { + set s [bigString 0x10000000a 0x100000000] +} -cleanup { + bigClean failat +} + +# +# string last +bigtestRO string-last-bigdata-1 "string last > INT_MAX" {2 -1 2147483640 11} -body { + set s [bigString 0x80000010 2] + list \ + [string last X $s] \ + [string last Y $s] \ + [string last 0 $s 0x80000000] \ + [string last 1 $s end-0x80000000] +} -setup { + set s [bigString 0x80000010 2] +} -cleanup { + bigClean +} +bigtestRO string-last-bigdata-2 "string last > UINT_MAX" {4294967320 -1 4294967290 1} -body { + list \ + [string last 0 $s] \ + [string last Y $s] \ + [string last 0 $s 0x100000000] \ + [string last 1 $s end-0x100000010] +} -setup { + set s [bigString 0x10000001a 2] +} -cleanup { + bigClean +} +bigtestRO string-last-bigdata-3 "string last - long needle" 0 -body { + string last $needle $s +} -setup { + set s [bigString 0x10000000a 0x10000000a] + set needle [bigString 0x100000000] +} -cleanup { + bigClean needle +} + +# +# string length +bigtestRO string-length-bigdata-1 {string length $s} 4294967296 -setup { + set s [bigString 0x100000000] +} -cleanup { + bigClean +} + +# +# string map +bigtestRO string-map-bigdata-1 {string map} {5 0 0 5} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [string map {0 5 5 0} $s] + list \ + [string index $s2 0] \ + [string index $s2 5] \ + [string index $s2 end] \ + [string index $s2 end-5] +} -setup { + set s [bigString 0x100000000] +} -cleanup { + bigClean +} -constraints bug-takesTooLong + +# +# string match +bigtestRO string-match-bigdata-1 {string match} {1 0 1} -body { + list \ + [string match 0*5 $s] \ + [string match 0*4 $s] \ + [string match $s $s] +} -setup { + set s [bigString 0x100000000] +} -cleanup { + bigClean +} + +# +# string range +bigtestRO string-range-bigdata-1 "string range" {6 7 5 {} 5 4 {} 9 {}} -body { + list \ + [string range $s 0x100000000 0x100000000] \ + [string range $s 0x100000000+1 0x100000000+1] \ + [string range $s 0x100000000-1 0x100000000-1] \ + [string range $s 0x10000000a 0x10000000a] \ + [string range $s end end] \ + [string range $s end-1 end-1] \ + [string range $s end+1 end+1] \ + [string range $s end-0x100000000 end-0x100000000] \ + [string range $s end-0x10000000a end-0x10000000a] +} -setup { + set s [bigString 0x10000000a] +} -cleanup { + bigClean +} +bigtestRO string-range-bigdata-2 "bug ad9361fd20 case 1" aXaaaa -body { + string range [string insert [string repeat a 0x80000000] end-0x7fffffff X] 0 5 +} +bigtestRO string-range-bigdata-3 "bug ad9361fd20 case 2" 2 -body { + string length [string range $s end-0x7fffffff end-0x7ffffffe] +} -setup { + set s [string repeat a 0xffffffff] +} -cleanup { + bigClean +} +# TODO - add tests for large result range + +# +# string repeat - use bigtest, not bigtestRO !! +bigtest string-repeat-bigdata-1 "string repeat single char length > UINT_MAX" 4294967296 -body { + string length [string repeat x 0x100000000] +} +bigtest string-repeat-bigdata-2 "string repeat multiple char" {4294967296 0123456789abcdef 0123456789abcdef} -body { + set s [string repeat 0123456789abcdef [expr 0x100000000/16]] + list \ + [string length $s] \ + [string range $s 0 15] \ + [string range $s end-15 end] +} -cleanup { + bigClean +} + +# +# string replace +bigtestRO string-replace-bigdata-1 "string replace" {789012345 012345678 XYZ789012345 012345678XYZ} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain result + lappend result [string replace $s 0 0x100000000] + lappend result [string replace $s end-0x100000000 end] + lappend result [string replace $s 0 0x100000000 XYZ] + lappend result [string replace $s end-0x100000000 end XYZ] +} -setup { + set s [bigString 0x10000000a] +} -cleanup { + bigClean +} +# TODO - +# - replacements string is large +# - replace in the middle - string length grows, shrinks +# - last < first + +# +# string reverse +bigtestRO string-reverse-bigdata-1 "string reverse" {5432109876 9876543210} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 result + set s2 [string reverse $s] + list [string range $s2 0 9] [string range $s2 end-9 end] +} -setup { + set s [bigString 0x10000000a] +} -cleanup { + bigClean +} + +# +# string tolower +bigtestRO string-tolower-bigdata-1 "string tolower" 1 -body { + string equal [string tolower $s] [string repeat abcd $repts] +} -setup { + set repts [expr 0x100000010/4] + set s [string repeat ABCD $repts] +} -cleanup { + bigClean repts +} +bigtestRO string-tolower-bigdata-2 "string tolower first last" {4294967312 ABCDabcdABCD 4294967312 ABCDabcdABCD 4294967312 ABCDabcdABCD} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 result + set s2 [string tolower $s 4 7] + lappend result [string length $s2] [string range $s2 0 11] + + unset s2; #Explicit free to reduce total memory + set s2 [string tolower $s 0x100000008 0x10000000b] + lappend result [string length $s2] [string range $s2 0x100000004 end] + + unset s2; #Explicit free to reduce total memory + set s2 [string tolower $s end-7 end-4] + lappend result [string length $s2] [string range $s2 0x100000004 end] +} -setup { + set repts [expr 0x100000010/4] + set s [string repeat ABCD $repts] +} -cleanup { + bigClean repts +} + +# +# string totitle +bigtestRO string-totitle-bigdata-1 "string totitle first last" {4294967312 aBcDAbcdaBcD 4294967312 aBcDAbcdaBcD 4294967312 aBcDAbcdaBcD} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 result + set s2 [string totitle $s 4 7] + lappend result [string length $s2] [string range $s2 0 11] + unset s2; #Explicit free to reduce total memory + set s2 [string totitle $s 0x100000008 0x10000000b] + lappend result [string length $s2] [string range $s2 0x100000004 0x10000000f] + unset s2; #Explicit free to reduce total memory + set s2 [string totitle $s end-7 end-4] + lappend result [string length $s2] [string range $s2 0x100000004 0x10000000f] +} -setup { + set repts [expr 0x100000010/4] + set s [string repeat aBcD $repts] +} -cleanup { + bigClean repts +} + +# +# string toupper +bigtestRO string-toupper-bigdata-1 "string toupper" 1 -body { + string equal [string toupper $s] [string repeat ABCD $repts] +} -setup { + set repts [expr 0x100000010/4] + set s [string repeat abcd $repts] +} -cleanup { + bigClean repts +} +bigtestRO string-toupper-bigdata-2 "string toupper first last" {4294967312 abcdABCDabcd 4294967312 abcdABCDabcd 4294967312 abcdABCDabcd} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 result + set s2 [string toupper $s 4 7] + lappend result [string length $s2] [string range $s2 0 11] + unset s2; #Explicit free to reduce total memory + set s2 [string toupper $s 0x100000008 0x10000000b] + lappend result [string length $s2] [string range $s2 0x100000004 0x10000000f] + unset s2; #Explicit free to reduce total memory + set s2 [string toupper $s end-7 end-4] + lappend result [string length $s2] [string range $s2 0x100000004 0x10000000f] +} -setup { + set repts [expr 0x100000010/4] + set s [string repeat abcd $repts] +} -cleanup { + bigClean repts +} + +# +# string trim +bigtestRO string-trim-bigdata-1 "string trim" {abcdyxxy yxxyabcd} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [string trim $s xy] + list [string range $s2 0 7] [string range $s2 end-7 end] +} -setup { + set repts [expr 0x100000010/8] + set s [string repeat xyabcdyx $repts] +} -cleanup { + bigClean +} + +# +# string trimleft +bigtestRO string-trimleft-bigdata-1 "string trimleft" {abcdyxxy xyabcdyx} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [string trimleft $s xy] + list [string range $s2 0 7] [string range $s2 end-7 end] +} -setup { + set repts [expr 0x100000010/8] + set s [string repeat xyabcdyx $repts] +} -cleanup { + bigClean +} + +# +# string trimright +bigtestRO string-trimright-bigdata-1 "string trimright" {xyabcdyx yxxyabcd} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [string trimright $s xy] + list [string range $s2 0 7] [string range $s2 end-7 end] +} -setup { + set repts [expr 0x100000010/8] + set s [string repeat xyabcdyx $repts] +} -cleanup { + bigClean +} + +# +# append +bigtestRO append-bigdata-1 "append large to small" 1 -body { + set s 0123456789 + append s [bigString 0x100000000] + string equal $s [bigString 0x10000000a] +} -cleanup { + bigClean +} +bigtest append-bigdata-2 "append small to cross UINT_MAX boundary" 1 -body { + append s 0123456789 + string equal $s [bigString 4294967300] +} -setup { + set s [bigString 4294967290] +} -cleanup { + bigClean +} +bigtest append-bigdata-3 "append small to cross UINT_MAX boundary" 1 -body { + set s2 "" + append s2 $s $s $s $s + string equal $s2 [bigString 4294967320] +} -setup { + # Make length multiple of 4 AND 10 since the bigString pattern length is 10 + set len [expr 4294967320/4] + set s [bigString $len] +} -cleanup { + bigClean +} + +# +# format +bigtestRO format-bigdata-1 "format %s" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [format %s $s] + string equal $s $s2 +} -setup { + set s [bigString 0x100000000] +} -cleanup { + bigClean +} +bigtest format-bigdata-2 "format bigstring%s" 1 -body { + set s [format $s X] + string equal $s [bigString 0x100000001 0x100000000] +} -setup { + set s [bigString 0x100000000] + append s %s +} -cleanup { + bigClean +} +bigtest format-bigdata-3 "format big width" {4294967300 { } { a}} -body { + set s [format %4294967300s a] + list [string length $s] [string range $s 0 3] [string range $s end-3 end] +} -cleanup { + bigClean +} +bigtest format-bigdata-4 "format big negative width" {4294967300 {a } { }} -body { + set s [format %-4294967300s a] + list [string length $s] [string range $s 0 3] [string range $s end-3 end] +} -cleanup { + bigClean +} +bigtest format-bigdata-5 "format big * width" {4294967300 { } { a}} -body { + set s [format %*s 4294967300 a] + list [string length $s] [string range $s 0 3] [string range $s end-3 end] +} -cleanup { + bigClean +} +bigtest format-bigdata-6 "format big negative * width" {4294967300 {a } { }} -body { + set s [format %*s -4294967300 a] + list [string length $s] [string range $s 0 3] [string range $s end-3 end] +} -cleanup { + bigClean +} +bigtestRO format-bigdata-7 "format big precision" {4294967300 0123 6789} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [format %.4294967300s $s] + list [string length $s2] [string range $s2 0 3] [string range $s2 end-3 end] +} -setup { + set s [testbigdata string 4294967310] +} -cleanup { + bigClean +} +bigtestRO format-bigdata-8 "format big * precision" {4294967300 0123 6789} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [format %.*s 4294967300 $s] + list [string length $s2] [string range $s2 0 3] [string range $s2 end-3 end] +} -setup { + set s [testbigdata string 4294967310] +} -cleanup { + bigClean +} + +# +# scan +bigtestRO scan-bigdata-1 "scan %s" {1 1 2 X 1 2 4294967300 01234X} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain result digits x + lappend result [string equal [scan $s %s] $s] + lappend result [string equal [scan $s {%[0-9X]}] $s] + lappend result [scan $s {%[0-9]%s} digits x] $x + lappend result [string equal $digits [bigString 0x100000009]] + lappend result [scan $s %4294967300s%s x y] + lappend result [string length $x] $y +} -setup { + set s [bigString 0x10000000a 0x100000009] +} -cleanup { + bigClean digits +} + +# +# regexp +bigtestRO regexp-bigdata-1 "regexp" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain result digits + lappend result [regexp {[[:digit:]]*X} $s] +} -setup { + set s [bigString 0x100000000 0x100000000] +} -cleanup { + bigClean digits +} +bigtestRO regexp-bigdata-2 "regexp with capture" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain result digits match + lappend result [regexp {([[:digit:]])*X} $s match digits] [string equal $match $s] + puts B + unset match; # Free up memory + lappend result [string equal $digits [bigString 0x100000009]] +} -setup { + set s [bigString 0x10000000a 0x100000009] +} -cleanup { + bigClean digits match +} -constraints bug-takesTooLong + +# +# regsub +bigtestRO regsub-bigdata-1 "regsub" X -body { + regsub -all \\d $s {} +} -setup { + set s [bigString 0x100000001 0x100000000] +} -cleanup { + bigClean +} -constraints bug-takesTooLong +bigtestRO regsub-bigdata-2 "regsub" 1 -body { + string equal [regsub -all \\d $s x] [string cat [string repeat x 0x100000000] X] +} -setup { + set s [bigString 0x100000001 0x100000000] +} -cleanup { + bigClean +} -constraints bug-takesTooLong + +# +# subst +bigtestRO subst-bigdata-1 "subst" {1 1} -body { + unset -nocomplain result + lappend result [string equal [subst $s] $s] + lappend result [string equal [subst {$s}] $s] +} -setup { + set s [bigString 0x10000000a] +} -cleanup { + bigClean +} + +# +# binary format +bigtestRO binary-format-bigdata-1 "binary format aN" [list 4294967296 X\0\0\0 \0\0\0\0] -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain bin + set bin [binary format a4294967296 X] + list [string length $bin] [string range $bin 0 3] [string range $bin end-3 end] +} -cleanup { + bigClean +} +# TODO - do string compare and add other format specifiers + +bigtestRO binary-format-bigdata-2 "binary format a*" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain bin2 + set bin2 [binary format a* $bin] + string equal $bin $bin2 +} -setup { + set bin [bigBinary 4294967296] +} -cleanup { + bigClean +} + +# +# binary scan +bigtestRO binary-scan-bigdata-1 "binary scan aN" {4294967296 0123 2345} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain bin2 + binary scan $bin a4294967296 bin2 + list [string length $bin2] [string range $bin2 0 3] [string range $bin2 end-3 end] +} -setup { + set bin [bigBinary 4294967296] +} -cleanup { + bigClean +} +# TODO - do string compare and add other format specifiers once above bug is fixed + +bigtestRO binary-scan-bigdata-2 "binary scan a*" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain bin2 + binary scan $bin a* bin2 + string equal $bin $bin2 +} -setup { + set bin [bigBinary 4294967296] +} -cleanup { + bigClean +} +# TODO - do string compare and add other format specifiers once above bug is fixed + +# +# binary encode / decode base64 +bigtestRO binary-encode/decode-base64-bigdata-1 "binary encode/decode base64" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + string equal $bin [binary decode base64 [binary encode base64 $bin]] +} -setup { + set bin [bigBinary 4294967296] +} -cleanup { + bigClean +} + +# +# binary encode / decode hex +bigtestRO binary-encode/decode-hex-bigdata-1 "binary encode/decode hex" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + string equal $bin [binary decode hex [binary encode hex $bin]] +} -setup { + set bin [bigBinary 4294967296] +} -cleanup { + bigClean +} + +# +# binary encode / decode uuencode +bigtestRO binary-encode/decode-uuencode-bigdata-1 "binary encode/decode uuencode" 1 -body { + string equal $bin [binary decode uuencode [binary encode uuencode $bin]] +} -setup { + set bin [bigBinary 4294967296] +} -cleanup { + bigClean +} + +################################################################ +# List commands + +# +# foreach +bigtestRO foreach-bigdata-1 "foreach" 1 -body { + # Unset explicitly before setting as bigtestRO runs the script twice. + unset -nocomplain l2 + foreach x $l { + lappend l2 $x + } + testlutil equal $l $l2 +} -setup { + set l [bigList 0x100000000] +} -cleanup { + bigClean +} + +# +# lappend +bigtest lappend-bigdata-1 "lappend" {4294967300 4294967300 {1 2 3 4 5 a b c d}} -body { + # Do NOT initialize l in a -setup block. That requires more memory and fails. + # Do not have enough memory for a full compare. + # Just check end + set l [bigList 0x100000000] + list [llength [lappend l a b c d]] [llength $l] [lrange $l end-8 end] +} -cleanup { + bigClean +} + +# +# lassign +bigtestRO lassign-bigdata-1 "lassign" {0 1 2 3 4 5 6 7 8 {9 0 1 2 3 4 5 6 7 8} {6 7 8 9 0 1 2 3 4 5}} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain l2 + set l2 [lassign $l a b c d e f g h i] + list $a $b $c $d $e $f $g $h $i [lrange $l2 0 9] [lrange $l2 end-9 end] +} -setup { + set l [bigList 0x10000000a] +} -cleanup { + bigClean +} + +# +# ledit +bigtest ledit-bigdata-1 "ledit - small result" {{0 X Y Z 8} {0 X Y Z 8}} -body { + list [ledit l 1 0x100000001 X Y Z] $l +} -setup { + set l [bigList 0x100000003] +} -cleanup { + bigClean +} + +bigtest ledit-bigdata-2 "ledit - large result" {4294967304 4294967304 {a b c d e f g 7}} -body { + # Do NOT initialize l in a -setup block. That requires more memory and fails. + set l [bigList 0x100000002] + list [llength [ledit l 0x100000000 0x100000000 a b c d e f g]] [llength $l] [lrange $l 0x100000000 end] +} -cleanup { + bigClean +} + +bigtest ledit-bigdata-3 "ledit - small -> large result" {2147483650 2147483650 {a b 0 1 2 3 4 5} {0 1 e f g h i j}} -body { + set l2 {a b c d e f g h i j} + list [llength [ledit l2 2 3 {*}$l]] [llength $l2] [lrange $l2 0 7] [lrange $l2 end-7 end] +} -setup { + # Note total number of arguments has to be less than INT_MAX + set l [bigList 2147483642] +} -cleanup { + bigClean +} -constraints memory-allocation-panic + +# +# lindex +bigtestRO lindex-bigdata-1 "lindex" {6 7 5 {} 5 4 {} 9 {}} -body { + list \ + [lindex $l 0x100000000] \ + [lindex $l 0x100000000+1] \ + [lindex $l 0x100000000-1] \ + [lindex $l 0x10000000a] \ + [lindex $l end] \ + [lindex $l end-1] \ + [lindex $l end+1] \ + [lindex $l end-0x100000000] \ + [lindex $l end-0x10000000a] +} -setup { + set l [bigList 0x10000000a] +} -cleanup { + bigClean +} +# TODO nested index + +# +# linsert +# Cannot use bigtestRO here because 16GB memory not enough to have two 4G sized lists +# Have to throw away source list every time. Also means we cannot compare entire lists +# and instead just compare the affected range +bigtest linsert-bigdata-1 "linsert" {4294967330 1} -body { + # Note insert at multiple of 10 to enable comparison against generated string + set ins [split abcdefghij ""] + set pat [split 0123456789 ""] + set insidx 2000000000 + set l [linsert [bigList 4294967320] $insidx {*}$ins] + list \ + [llength $l] \ + [testlutil equal [lrange $l $insidx-10 $insidx+19] [concat $pat $ins $pat]] +} -cleanup { + bigClean +} + +# +# list and {*} +# TODO - compiled and uncompiled behave differently so tested separately +test list-bigdata-1.compiled {list {*}} -body { + set l [bigList 0x100000000] + set l2 [list {*}$l] + unset l + list [llength $l2] [lindex $l2 0] [lindex $l2 end] +} -cleanup { + bigClean +} -constraints { + bigdata +} -result {4294967296 0 5} +test list-bigdata-1.uncompiled {list {*}} -body { + set l [bigList 0x7fffffff] + testevalex {set l2 [list {*}$l]} +} -cleanup { + bigClean +} -constraints { + bigdata +} -result {Number of words in command exceeds limit 2147483647.} -returnCodes error + +# +# llength +bigtestRO llength-bigdata-1 {llength} 4294967296 -body { + llength $l +} -setup { + set l [bigList 0x100000000] +} -cleanup { + bigClean +} + +# +# lmap +bigtestRO lmap-bigdata-1 "lmap" 4294967296 -body { + set n 0 + if {0} { + # TODO - This is the right test but runs out of memory + testlutil equal $l [lmap e $l {set e}] + } else { + lmap e $l {incr n; continue} + } + set n +} -setup { + set l [bigList 0x100000000] +} -cleanup { + bigClean + puts "" +} + +# +# lrange +bigtestRO lrange-bigdata-1 "lrange" {6 {6 7} 7 5 {} 5 4 {} 9 {8 9} {}} -body { + list \ + [lrange $l 0x100000000 0x100000000] \ + [lrange $l 0x100000000 0x100000001] \ + [lrange $l 0x100000000+1 0x100000000+1] \ + [lrange $l 0x100000000-1 0x100000000-1] \ + [lrange $l 0x10000000a 0x10000000a] \ + [lrange $l end end] \ + [lrange $l end-1 end-1] \ + [lrange $l end+1 end+1] \ + [lrange $l end-0x100000000 end-0x100000000] \ + [lrange $l end-0x100000001 end-0x100000000] \ + [lrange $l end-0x10000000a end-0x10000000a] +} -setup { + set l [bigList 0x10000000a] +} -cleanup { + bigClean +} +# TODO - add tests for large result range + +# +# lrepeat - use bigtest, not bigtestRO !! +bigtest lrepeat-bigdata-1 "lrepeat single element length > UINT_MAX" 4294967296 -body { + # Just to test long lengths are accepted as arguments + llength [lrepeat 0x100000000 x] +} + +bigtest lrepeat-bigdata-2 "string repeat multiple char" {4294967400 {0 1 2 3 4 5 6 7}} -body { + set len [expr 4294967400/8] + set l [lrepeat $len 0 1 2 3 4 5 6 7] + list [llength $l] [lrange $l end-7 end] +} -cleanup { + bigClean +} + +# +# lreplace +bigtestRO lreplace-bigdata-1 "lreplace - small result" [list \ + [split 789012345 ""] \ + [split 012345678 ""] \ + [split XYZ789012345 ""] \ + [split 012345678XYZ ""] \ + ] -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain result + lappend result [lreplace $l 0 0x100000000] + lappend result [lreplace $l end-0x100000000 end] + lappend result [lreplace $l 0 0x100000000 X Y Z] + lappend result [lreplace $l end-0x100000000 end X Y Z] +} -setup { + set l [bigList 0x10000000a] +} -cleanup { + bigClean +} + +bigtest lreplace-bigdata-2 "lreplace - large result" {4294967301 {a b c d e 0 1 2 3 4 5 6}} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain l2 + set l2 [lreplace [bigList 4294967296] 4294967290 0 a b c d e] + lrange $l2 4294967290 end +} -setup { + #set l [bigList 4294967296] +} -cleanup { + bigClean +} -constraints bug-outofmemorypanic + +# +# lsearch +bigtestRO lsearch-bigdata-1 "lsearch" {4294967300 4294967310 -1} -body { + list \ + [lsearch -exact $l X] \ + [lsearch -exact -start 4294967291 $l 0] \ + [lsearch -exact $l Y] +} -setup { + set l [bigList 0x100000010 4294967300] +} -cleanup { + bigClean +} +# TODO - stride, inline, all + +# +# lseq +bigtest lseq-bigdata-1 "lseq" {4294967297 4294967296} -body { + list [llength $l] [lindex $l 0x100000000] +} -setup { + set l [lseq 0x100000001] +} -cleanup { + bigClean +} +bigtest lseq-bigdata-2 "lseq" {9223372036854775807 9223372036854775799} -body { + list [llength $l] [lindex $l 9223372036854775800] +} -setup { + set l [lseq 0x7fffffffffffffff]; llength $l +} -cleanup { + bigClean +} -constraints bug-fa00fbbbab + +# +# lset +bigtest lset-bigdata-1 "lset" {4294967297 4294967297 {1 2 3 4 5 X}} -body { + # Do NOT initialize l in a -setup block. That requires more memory and fails. + set l [bigList 0x100000001] + list [llength [lset l 0x100000000 X]] [llength $l] [lrange $l end-5 end] +} -cleanup { + bigClean +} + +# +# lsort +bigtestRO lsort-bigdata-1 "lsort" [list 4294967296 [lrepeat 10 0] [lrepeat 10 9]] -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain l2 + set l2 [lsort $l] + list [llength $l2] [lrange $l2 0 9] [lrange $l2 end-9 end] +} -setup { + set l [bigList 0x100000000] +} -cleanup { + bigClean +} -constraints notenoughmemoryexception + +# +# join +bigtestRO join-bigdata-1 "join" [list 0123456789 6789012345] -body { + set s [join $l ""] + list [string range $s 0 9] [string range $s end-9 end] +} -setup { + set l [bigList 0x100000000] +} -cleanup { + bigClean +} + +bigtest split-bigdata-1 "split" {4294967296 {0 1 2 3 4} {1 2 3 4 5}} -body { + # Fill list compare needs too much memory + set l [split $s ""] + list [llength $l] [lrange 0 4] [lrange end-4 end] +} -setup { + set s [bigString 0x100000000] +} -cleanup { + bigClean +} -constraints bug-takesTooLong + +bigtestRO concat-bigdata-1 "concat" {4294967296 {0 1 2 3 4} {6 7 0 1 2} {3 4 5 6 7}} -body { + unset -nocomplain l2 + set l2 [concat $l $l] + list [llength $l2] [lrange $l2 0 4] [lrange $l2 0x80000000-2 0x80000000+2] [lrange $l2 end-4 end] +} -setup { + set l [bigList 0x80000000] +} + +test puts-bigdata-1 "puts" -setup { + set fpath [makeFile {} bug-0306a5563.data] +} -constraints { + bigdata +} -body { + set fd [open $fpath w] + puts -nonewline $fd [testbigdata string 0x80000001] + close $fd + set fd [open $fpath] + seek $fd 0x7FFFFFFA + set written [read $fd] + close $fd + set written +} -result {2345678} + +test puts-bigdata-2 "puts" -setup { + set fpath [tcltest::makeFile {} bug-0306a5563.data] +} -constraints { + bigdata +} -body { + set fd [open $fpath w] + set s [testbigdata string 0x7FFFFFFE] + # The character to append in the next line is —, EM DASH, + # code point 0x2014 (decimal 8212, UTF-8 #xE2 #x80 #x94) + append s \u2014 + puts -nonewline $fd $s + close $fd + set fd [open $fpath] + seek $fd 0x7FFFFFFA + set written [read $fd] + close $fd + set written +} -result {2345—} + +test source-bigdata-1 "source" -setup { + # This test crashes because the frame linenumber tracking + # wraps around at INT_MAX + set fpath [tcltest::makeFile {} source-bigdata-1.tcl] + set fd [open $fpath w] + fconfigure $fd -translation lf + puts -nonewline $fd [string repeat \n 4294967296] + puts $fd {dict get [info frame 0] line} + close $fd +} -constraints { + bigdata knownBug +} -body { + set line [source $fpath] +} -result 4294967297 + +# +# TODO +# lremove +# lreverse +# encoding convertfrom +# encoding convertto +# dict * + + + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/binary.test b/tests/binary.test index 03ef846..299e1e0 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -15,11 +15,14 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands +source [file join [file dirname [info script]] tcltests.tcl] + catch [list package require -exact tcl::test [info patchlevel]] testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}] testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] # Big test for correct ordering of data in [expr] proc testIEEE {} { @@ -3008,7 +3011,7 @@ test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678 binary encode hex \U0001f415 binary scan \U0001f415 a* v; set v set str {} -} -result {} +} -result * -match glob -returnCodes error testConstraint testsetbytearraylength \ @@ -3017,9 +3020,21 @@ testConstraint testsetbytearraylength \ test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength { testsetbytearraylength [string cat A B C] 1 } A -test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength { +test binary-79.2 {Tcl_SetByteArrayLength} -body { testsetbytearraylength [string cat Ł B C] 1 +} -constraints testsetbytearraylength -returnCodes error -match glob -result * +test binary-79.3 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B \u0141] 0 +} {} +test binary-79.4 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B \u0141] 1 } A +test binary-79.5 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B \u0141] 2 +} AB +test binary-79.6 {Tcl_SetByteArrayLength} -body { + testsetbytearraylength [string cat A B \u0141] 3 +} -constraints testsetbytearraylength -returnCodes error -match glob -result * test binary-80.1 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring "乎" @@ -3033,6 +3048,9 @@ test binary-80.3 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes test binary-80.4 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"] } -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)" +test binary-80.5 {Tcl_GetBytesFromObj} -constraints {testbytestring pointerIs64bit deprecated} -body { + testbytestring [string repeat A [expr 2**31]] +} -returnCodes 1 -result "byte sequence length exceeds INT_MAX" # ---------------------------------------------------------------------- # cleanup diff --git a/tests/case.test b/tests/case.test deleted file mode 100644 index 1c12e3a..0000000 --- a/tests/case.test +++ /dev/null @@ -1,94 +0,0 @@ -# Commands covered: case -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright © 1991-1993 The Regents of the University of California. -# Copyright © 1994 Sun Microsystems, Inc. -# Copyright © 1998-1999 Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {![llength [info commands case]]} { - # No "case" command? So no need to test - return -} - -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 - namespace import -force ::tcltest::* -} - -test case-1.1 {simple pattern} { - case a in a {format 1} b {format 2} c {format 3} default {format 4} -} 1 -test case-1.2 {simple pattern} { - case b a {format 1} b {format 2} c {format 3} default {format 4} -} 2 -test case-1.3 {simple pattern} { - case x in a {format 1} b {format 2} c {format 3} default {format 4} -} 4 -test case-1.4 {simple pattern} { - case x a {format 1} b {format 2} c {format 3} -} {} -test case-1.5 {simple pattern matches many times} { - case b a {format 1} b {format 2} b {format 3} b {format 4} -} 2 -test case-1.6 {fancier pattern} { - case cx a {format 1} *c {format 2} *x {format 3} default {format 4} -} 3 -test case-1.7 {list of patterns} { - case abc in {a b c} {format 1} {def abc ghi} {format 2} -} 2 - -test case-2.1 {error in executed command} { - list [catch {case a in a {error "Just a test"} default {format 1}} msg] \ - $msg $::errorInfo -} {1 {Just a test} {Just a test - while executing -"error "Just a test"" - ("a" arm line 1) - invoked from within -"case a in a {error "Just a test"} default {format 1}"}} -test case-2.2 {error: not enough args} { - list [catch {case} msg] $msg -} {1 {wrong # args: should be "case string ?in? ?pattern body ...? ?default body?"}} -test case-2.3 {error: pattern with no body} { - list [catch {case a b} msg] $msg -} {1 {extra case pattern with no body}} -test case-2.4 {error: pattern with no body} { - list [catch {case a in b {format 1} c} msg] $msg -} {1 {extra case pattern with no body}} -test case-2.5 {error in default command} { - list [catch {case foo in a {error case1} default {error case2} \ - b {error case 3}} msg] $msg $::errorInfo -} {1 case2 {case2 - while executing -"error case2" - ("default" arm line 1) - invoked from within -"case foo in a {error case1} default {error case2} b {error case 3}"}} - -test case-3.1 {single-argument form for pattern/command pairs} { - case b in { - a {format 1} - b {format 2} - default {format 6} - } -} {2} -test case-3.2 {single-argument form for pattern/command pairs} { - case b { - a {format 1} - b {format 2} - default {format 6} - } -} {2} -test case-3.3 {single-argument form for pattern/command pairs} { - list [catch {case z in {a 2 b}} msg] $msg -} {1 {extra case pattern with no body}} - -# cleanup -::tcltest::cleanupTests -return diff --git a/tests/chan.test b/tests/chan.test index 4155c36..87d642c 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -11,6 +11,9 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +source [file join [file dirname [info script]] tcltests.tcl] + +package require tcltests # # Note: The tests for the chan methods "create" and "postevent" @@ -49,19 +52,19 @@ test chan-4.1 {chan command: configure subcommand} -body { } -returnCodes error -result "wrong # args: should be \"chan configure channelId ?-option value ...?\"" test chan-4.2 {chan command: [Bug 800753]} -body { chan configure stdout -eofchar Ā -} -returnCodes error -match glob -result {bad value*} +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} test chan-4.3 {chan command: [Bug 800753]} -body { chan configure stdout -eofchar \x00 -} -returnCodes error -match glob -result {bad value*} -test chan-4.4 {chan command: check valid inValue, no outValue} -body { +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} +test chan-4.4 {chan command: check valid inValue, no outValue} -constraints deprecated -body { chan configure stdout -eofchar [list \x27 {}] } -result {} test chan-4.5 {chan command: check valid inValue, invalid outValue} -body { chan configure stdout -eofchar [list \x27 \x80] -} -returnCodes error -match glob -result {bad value for -eofchar:*} +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} test chan-4.6 {chan command: check no inValue, valid outValue} -body { chan configure stdout -eofchar [list {} \x27] -} -result {} -cleanup {chan configure stdout -eofchar [list {} {}]} +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} -cleanup {chan configure stdout -eofchar {}} test chan-5.1 {chan command: copy subcommand} -body { chan copy foo diff --git a/tests/chanio.test b/tests/chanio.test index f3461f0..69f9690 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -63,7 +63,7 @@ namespace eval ::tcl::test::io { set umaskValue 0 testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}] - testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}] + testConstraint makeFileInHome [expr {![file exists $::env(HOME)/_test_] && [file writable $::env(HOME)]}] # set up a long data file for some of the following tests @@ -82,7 +82,7 @@ namespace eval ::tcl::test::io { if {$argv != ""} { set f [open [lindex $argv 0]] } - chan configure $f -encoding binary -translation lf -blocking 0 -eofchar "\x1A \x1A" + chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A chan configure stdout -encoding binary -translation lf -buffering none chan event $f readable "foo $f" proc foo {f} { @@ -483,7 +483,7 @@ test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} -body { chan puts $f "abcdef\x1Aghijk\nwombat" chan close $f set f [open $path(test1)] - chan configure $f -eofchar "\x1A \x1A" + chan configure $f -eofchar \x1A list [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f @@ -493,7 +493,7 @@ test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} -body { chan puts $f "abcdefghijk\nwom\x1Abat" chan close $f set f [open $path(test1)] - chan configure $f -eofchar "\x1A \x1A" + chan configure $f -eofchar \x1A list [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f @@ -1001,7 +1001,7 @@ test chan-io-6.52 {Tcl_GetsObj: saw EOF character} -constraints {testchannel} -b chan puts -nonewline $f "123456\x1Ak9012345\r" chan close $f set f [open $path(test1)] - chan configure $f -eofchar "\x1A \x1A" + chan configure $f -eofchar \x1A list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] } -cleanup { chan close $f @@ -1891,13 +1891,13 @@ test chan-io-20.2 {Tcl_CreateChannel: initial settings} -constraints {win} -body list [chan configure $f -eofchar] [chan configure $f -translation] } -cleanup { chan close $f -} -result [list [list \x1A ""] {auto crlf}] +} -result {{} {auto crlf}} test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -body { set f [open $path(test1) w+] list [chan configure $f -eofchar] [chan configure $f -translation] } -cleanup { chan close $f -} -result {{{} {}} {auto lf}} +} -result {{} {auto lf}} test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { set path(stdout) [makeFile {} stdout] } -constraints {stdio notWinCI} -body { @@ -3107,7 +3107,7 @@ test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} -setup { chan puts -nonewline $f hello\nthere\nand\rhere\n\x1A chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan read $f } -cleanup { chan close $f @@ -3120,11 +3120,11 @@ test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} -setup { file delete $path(test1) } -constraints {win} -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan read $f } -cleanup { chan close $f @@ -3142,7 +3142,7 @@ test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $s chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A set l "" lappend l [chan gets $f] lappend l [chan gets $f] @@ -3163,7 +3163,7 @@ test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} -setup { chan puts $f $s chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A set l "" lappend l [chan gets $f] lappend l [chan gets $f] @@ -3241,7 +3241,7 @@ test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} -setup { chan puts $f [format abc\ndef\n%cqrs\ntuv 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3255,7 +3255,7 @@ test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3269,7 +3269,7 @@ test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3283,7 +3283,7 @@ test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3297,7 +3297,7 @@ test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3311,7 +3311,7 @@ test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3662,7 +3662,7 @@ test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} -setup { chan puts $f [format "hello\nthere\nand\rhere\n\%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3678,11 +3678,11 @@ test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} -setup { set l "" } -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3702,7 +3702,7 @@ test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3720,7 +3720,7 @@ test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3804,7 +3804,7 @@ test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3822,7 +3822,7 @@ test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3840,7 +3840,7 @@ test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3858,7 +3858,7 @@ test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3876,7 +3876,7 @@ test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3894,7 +3894,7 @@ test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -4650,86 +4650,86 @@ test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {9 8 1} +} -result {8 8 1} test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {9 8 1} +} -result {8 8 1} test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {9 8 1} +} -result {8 8 1} test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {9 8 1} +} -result {8 8 1} test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {11 8 1} +} -result {10 8 1} test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {11 8 1} +} -result {10 8 1} test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup { file delete $path(test1) } -body { @@ -4739,7 +4739,7 @@ test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4753,7 +4753,7 @@ test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4767,7 +4767,7 @@ test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4781,7 +4781,7 @@ test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4795,7 +4795,7 @@ test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4809,7 +4809,7 @@ test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -5287,29 +5287,29 @@ test chan-io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { file delete $path(test1) set l "" -} -constraints {unix} -body { +} -constraints {unix deprecated} -body { set f1 [open $path(test1) w+] lappend l [chan configure $f1 -eofchar] - chan configure $f1 -eofchar {ON GO} + chan configure $f1 -eofchar {O {}} lappend l [chan configure $f1 -eofchar] - chan configure $f1 -eofchar {D D} + chan configure $f1 -eofchar D lappend l [chan configure $f1 -eofchar] } -cleanup { chan close $f1 -} -result {{{} {}} {O G} {D D}} -test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup { +} -result {{} O D} +test chan-io-39.22a {Tcl_SetChannelOption, invariance} -constraints deprecated -setup { file delete $path(test1) set l [list] } -body { set f1 [open $path(test1) w+] - chan configure $f1 -eofchar {ON GO} + chan configure $f1 -eofchar {O {}} lappend l [chan configure $f1 -eofchar] - chan configure $f1 -eofchar {D D} + chan configure $f1 -eofchar D lappend l [chan configure $f1 -eofchar] lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg] } -cleanup { chan close $f1 -} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} +} -result {O D {1 {bad value for -eofchar: must be non-NUL ASCII character}}} test chan-io-39.23 { Tcl_GetChannelOption, server socket is not readable or writable, but should still have valid -eofchar and -translation options. @@ -5321,7 +5321,7 @@ test chan-io-39.23 { [chan configure $sock -translation] } -cleanup { chan close $sock -} -result {{{}} auto} +} -result {{} auto} test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\ writable so we can't change -eofchar or -translation} -setup { set l [list] @@ -5332,7 +5332,7 @@ test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\ [chan configure $sock -translation] } -cleanup { chan close $sock -} -result {{{}} auto} +} -result {{} auto} test chan-io-40.1 {POSIX open access modes: RDWR} -setup { file delete $path(test3) @@ -5492,21 +5492,16 @@ test chan-io-40.15 {POSIX open access modes: RDWR} { chan close $f lappend x [viewFile test3] } {zzy abzzy} -test chan-io-40.16 {tilde substitution in open} -constraints makeFileInHome -setup { - makeFile {Some text} _test_ ~ +test chan-io-40.16 {verify no tilde substitution in open} -setup { + set curdir [pwd] + cd [temporaryDirectory] } -body { - file exists [file join $::env(HOME) _test_] + close [open ~ w] + list [file isfile ~] } -cleanup { - removeFile _test_ ~ + file delete ./~ ;# ./ because don't want to delete home in case of bugs! + cd $curdir } -result 1 -test chan-io-40.17 {tilde substitution in open} -setup { - set home $::env(HOME) -} -body { - unset ::env(HOME) - open ~/foo -} -returnCodes error -cleanup { - set ::env(HOME) $home -} -result {couldn't find HOME environment variable to expand path} test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body { chan event foo @@ -6051,7 +6046,7 @@ test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6075,7 +6070,7 @@ test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6099,7 +6094,7 @@ test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6123,7 +6118,7 @@ test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6147,7 +6142,7 @@ test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mo chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6171,7 +6166,7 @@ test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6195,7 +6190,7 @@ test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} - chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6219,7 +6214,7 @@ test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6243,7 +6238,7 @@ test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} - chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6267,7 +6262,7 @@ test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6291,7 +6286,7 @@ test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mod chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6315,7 +6310,7 @@ test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} - chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6875,8 +6870,7 @@ test chan-io-52.9 {TclCopyChannel & encodings} {fcopy} { [file size $path(utf8-fcopy.txt)] \ [file size $path(utf8-rp.txt)] } {3 5 5} -test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy notWinCI} -body { - # encoding to binary (=> implies that the internal utf-8 is written) +test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy} -body { set in [open $path(kyrillic.txt) r] set out [open $path(utf8-fcopy.txt) w] chan configure $in -encoding koi8-r -translation lf @@ -6888,25 +6882,31 @@ test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy notWinCI} -b chan close $in chan close $out unset in out -} -result 5 +} -returnCodes 1 -match glob -result {error writing "*":\ + invalid or incomplete multibyte or wide character} test chan-io-52.11 {TclCopyChannel & encodings} -setup { set f [open $path(utf8-fcopy.txt) w] fconfigure $f -encoding utf-8 -translation lf puts $f АА close $f } -constraints {fcopy} -body { - # binary to encoding => the input has to be in utf-8 to make sense to the - # encoder set in [open $path(utf8-fcopy.txt) r] set out [open $path(kyrillic.txt) w] # -translation binary is also -encoding binary chan configure $in -translation binary - chan configure $out -encoding koi8-r -translation lf - chan copy $in $out - chan close $in - chan close $out - file size $path(kyrillic.txt) -} -result 3 + chan configure $out -encoding koi8-r -translation lf -profile strict + catch {chan copy $in $out} cres copts + return $cres +} -cleanup { + if {$in in [chan names]} { + close $in + } + if {$out in [chan names]} { + close $out + } + catch {unset cres} +} -match glob -result {error writing "*": invalid or incomplete\ + multibyte or wide character} test chan-io-53.1 {CopyData} -setup { file delete $path(test1) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 7cae5c8..ad5a67d 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -22,10 +22,6 @@ testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint testbytestring [llength [info commands testbytestring]] -testConstraint time64bit [expr { - $::tcl_platform(pointerSize) >= 8 || - [llength [info command testsize]] && [testsize st_mtime] >= 8 -}] testConstraint linkDirectory [expr { ![testConstraint win] || ($::tcl_platform(osVersion) >= 5.0 @@ -67,8 +63,6 @@ test cmdAH-0.2 {Tcl_BreakObjCmd, success} { list [catch {break} msg] $msg } {3 {}} -# Tcl_CaseObjCmd is tested in case.test - test cmdAH-1.1 {Tcl_CatchObjCmd, errors} -returnCodes error -body { catch } -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} @@ -109,7 +103,7 @@ test cmdAH-2.3 {Tcl_CdObjCmd} -setup { set env(HOME) $oldpwd file mkdir $foodir cd $foodir - cd ~ + cd [file home] string equal [pwd] $oldpwd } -cleanup { cd $oldpwd @@ -133,8 +127,21 @@ test cmdAH-2.4 {Tcl_CdObjCmd} -setup { set env(HOME) $temp } -result 1 test cmdAH-2.5 {Tcl_CdObjCmd} -returnCodes error -body { - cd ~~ -} -result {user "~" doesn't exist} + cd ~ +} -result {couldn't change working directory to "~": no such file or directory} +test cmdAH-2.5.1 {Tcl_CdObjCmd} -setup { + set oldpwd [pwd] + cd [temporaryDirectory] + file delete ./~ + file mkdir ~ +} -body { + cd ~ + pwd +} -cleanup { + cd [temporaryDirectory] + file delete ./~ + cd $oldpwd +} -result [file join [temporaryDirectory] ~] test cmdAH-2.6 {Tcl_CdObjCmd} -returnCodes error -body { cd _foobar } -result {couldn't change working directory to "_foobar": no such file or directory} @@ -815,7 +822,7 @@ test cmdAH-8.43 {Tcl_FileObjCmd: dirname} -setup { } -constraints testsetplatform -body { set env(HOME) "/homewontexist/test" testsetplatform unix - file dirname ~ + file dirname [file home] } -cleanup { set env(HOME) $temp } -result /homewontexist @@ -825,19 +832,13 @@ test cmdAH-8.44 {Tcl_FileObjCmd: dirname} -setup { } -constraints testsetplatform -body { set env(HOME) "~" testsetplatform unix - file dirname ~ + file dirname [file home] } -cleanup { set env(HOME) $temp -} -result ~ -test cmdAH-8.45 {Tcl_FileObjCmd: dirname} -setup { - set temp $::env(HOME) -} -constraints {win testsetplatform} -match regexp -body { - set ::env(HOME) "/homewontexist/test" - testsetplatform windows +} -result . +test cmdAH-8.45 {Tcl_FileObjCmd: dirname ~} -body { file dirname ~ -} -cleanup { - set ::env(HOME) $temp -} -result {([a-zA-Z]:?)/homewontexist} +} -result . test cmdAH-8.46 {Tcl_FileObjCmd: dirname} { set f [file normalize [info nameof]] file exists $f @@ -945,36 +946,19 @@ test cmdAH-9.26 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {//foo/bar} } {} -test cmdAH-9.42 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { - global env - set temp $env(HOME) -} -body { - set env(HOME) "/home/test" - testsetplatform unix +test cmdAH-9.42 {Tcl_FileObjCmd: tail ~} -body { file tail ~ -} -cleanup { - set env(HOME) $temp -} -result test +} -result ~ test cmdAH-9.43 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) } -body { set env(HOME) "~" testsetplatform unix - file tail ~ + file tail [file home] } -cleanup { set env(HOME) $temp -} -result {} -test cmdAH-9.44 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { - global env - set temp $env(HOME) -} -body { - set env(HOME) "/home/test" - testsetplatform windows - file tail ~ -} -cleanup { - set env(HOME) $temp -} -result test +} -result ~ test cmdAH-9.46 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail {f.oo\bar/baz.bat} @@ -1005,7 +989,7 @@ test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} { [file tail {~/test/~foo}] \ [file tail [file normalize {~/~foo}]] \ [file tail [file normalize {~/test/~foo}]] -} [lrepeat 4 ./~foo] +} [lrepeat 4 ~foo] # rootname test cmdAH-10.1 {Tcl_FileObjCmd: rootname} -returnCodes error -body { @@ -1259,7 +1243,7 @@ test cmdAH-14.3 {Tcl_FileObjCmd: join} testsetplatform { test cmdAH-15.1 {Tcl_FileObjCmd} -constraints testsetplatform -body { testsetplatform unix file atime ~_bad_user -} -returnCodes error -result {user "_bad_user" doesn't exist} +} -returnCodes error -result {could not read "~_bad_user": no such file or directory} catch {testsetplatform $platform} @@ -1382,9 +1366,8 @@ test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} { file exists ~nOsUcHuSeR } 0 test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} -body { - # should probably be a non-error in fact... file nativename ~nOsUcHuSeR -} -returnCodes error -match glob -result * +} -result ~nOsUcHuSeR # The test below has to be done in /tmp rather than the current directory in # order to guarantee (?) a local file system: some NFS file systems won't do # the stuff below correctly. @@ -1724,16 +1707,20 @@ test cmdAH-24.14.1 { } -match regexp -result {could not (?:get modification time|read)} -returnCodes error # 3155760000 is 64-bit Unix time, Wed Jan 01 00:00:00 GMT 2070: -test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup { +test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -setup { set filename [makeFile "" foo.text] } -body { + # This test may fail if your system does not have a 64-bit time_t. + # That is to be expected and is not a problem with Tcl. list [file atime $filename 3155760000] [file atime $filename] } -cleanup { removeFile $filename } -result {3155760000 3155760000} -test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup { +test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -setup { set filename [makeFile "" foo.text] } -body { + # This test may fail if your system does not have a 64-bit time_t. + # That is to be expected and is not a problem with Tcl. list [file mtime $filename 3155760000] [file mtime $filename] } -cleanup { file delete -force $filename @@ -2028,9 +2015,6 @@ test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file t x } -match glob -result {unknown or ambiguous subcommand "t": must be *} -test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { - file dirname ~woohgy -} -result {user "woohgy" doesn't exist} # channels # In testing 'file channels', we need to make sure that a channel created in diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 316a945..c8f5e0e 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -19,6 +19,18 @@ catch [list package require -exact tcl::test [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +proc memusage {} { + set fd [open /proc/[pid]/statm] + set line [gets $fd] + if {[llength $line] != 7} { + error "Unexpected /proc/pid/statm format" + } + set result [lindex $line 5] + close $fd + return $result +} +testConstraint hasMemUsage [expr {![catch {memusage}]}] + testConstraint testobj [llength [info commands testobj]] source [file join [file dirname [info script]] internals.tcl] namespace import -force ::tcltest::internals::* @@ -137,7 +149,7 @@ test cmdIL-1.32 {lsort -stride errors} -returnCodes error -body { } -result {expected integer but got "foo"} test cmdIL-1.33 {lsort -stride errors} -returnCodes error -body { lsort -stride 1 bar -} -match glob -result {stride length must be between 2 and *} +} -result {stride length must be at least 2} test cmdIL-1.34 {lsort -stride errors} -returnCodes error -body { lsort -stride 2 {a b c} } -result {list size must be a multiple of the stride length} @@ -170,7 +182,7 @@ test cmdIL-1.42 {lsort -stride and-index} -body { } -returnCodes error -result {index "-1-1" out of range} test cmdIL-1.43 {lsort -stride errors} -returnCodes error -body { lsort -stride 4294967296 bar -} -match glob -result {stride length must be between 2 and *} +} -result {list size must be a multiple of the stride length} # Can't think of any good tests for the MergeSort and MergeLists procedures, # except a bunch of random lists to sort. @@ -743,19 +755,31 @@ test cmdIL-6.24 {lassign command - memory leak testing} -setup { rename stress {} } # Assorted shimmering problems -test cmdIL-6.25 {lassign command - shimmering protection} -body { +test cmdIL-6.25 {lassign command (compiled) - shimmering protection} -body { apply {{} { set x {a b c} list [lassign $x $x y] $x [set $x] $y }} } -result {c {a b c} a b} -test cmdIL-6.26 {lassign command - shimmering protection} -body { +test cmdIL-6.26 {lassign command (uncompiled) - shimmering protection} -body { apply {{} { set x {a b c} set lassign lassign list [$lassign $x $x y] $x [set $x] $y }} } -result {c {a b c} a b} +test cmdIL-6.27 {bug-f5e36eb588 - uncompiled lassign on lseq does not bloat memory} -constraints { + hasMemUsage +} -body { + set l [lseq 1000000] + lassign $l x + set premem [memusage] + set lassign lassign + $lassign $l x + set postmem [memusage] + expr {($postmem-$premem) < 100} +} -result 1 + test cmdIL-7.1 {lreverse command} -body { lreverse diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index 40dea76..ec7eda1 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -19,7 +19,6 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands -catch [list package require -exact tcl::test [info patchlevel]] # Big test for correct ordering of data in [expr] @@ -79,9 +78,6 @@ proc testIEEE {} { } testConstraint ieeeFloatingPoint [testIEEE] -testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] -testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] - # procedures used below proc put_hello_char {c} { diff --git a/tests/compExpr.test b/tests/compExpr.test index eaef772..84c53de 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -14,7 +14,6 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact tcl::test [info patchlevel]] # Constrain memory leak tests testConstraint memory [llength [info commands memory]] diff --git a/tests/compile.test b/tests/compile.test index 36b4f3a..cf552e2 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -326,7 +326,7 @@ test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { } -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; string index a 0o9 }} -} -returnCodes error -match glob -result {*invalid octal number*} +} -returnCodes error -match glob -result {*} test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; array set var {one two many} }} } -returnCodes error -result {list must have an even number of elements} diff --git a/tests/dict.test b/tests/dict.test index 1515675..59b600e 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -14,6 +14,13 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +catch { + ::tcltest::loadTestedCommands + package require -exact tcl::test [info patchlevel] +} + +testConstraint testobj [llength [info commands testobj]] + # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { @@ -27,6 +34,7 @@ if {[testConstraint memory]} { expr {$end - $tmp} } } + test dict-1.1 {dict command basic syntax} -returnCodes error -body { dict @@ -138,8 +146,16 @@ test dict-3.15 {compiled dict get error cleanliness - Bug 2431847} -body { dict get $a(z) d }} } -returnCodes error -result {key "d" not known in dictionary} -test dict-3.16 {dict/list shimmering - Bug 3004007} {set l [list p 1 p 2 q 3];dict get $l q;set l} {p 1 p 2 q 3} -test dict-3.17 {dict/list shimmering - Bug 3004007} {set l [list p 1 p 2 q 3];dict get $l q;llength $l} 6 +test dict-3.16 {dict/list shimmering - Bug 3004007} testobj { + set l [list p 1 p 2 q 3] + dict get $l q + list $l [testobj objtype $l] +} {{p 1 p 2 q 3} dict} +test dict-3.17 {dict/list shimmering - Bug 3004007} testobj { + set l [list p 1 p 2 q 3] + dict get $l q + list [llength $l] [testobj objtype $l] +} {6 dict} test dict-4.1 {dict replace command} { dict replace {a b c d} @@ -657,20 +673,20 @@ test dict-14.13 {dict for command: script results} { error "return didn't go far enough" }} } ok,a,b -test dict-14.14 {dict for command: handle representation loss} -body { +test dict-14.14 {dict for command: handle representation loss} -constraints testobj -body { set dictVar {a b c d e f g h} set keys {} set values {} dict for {k v} $dictVar { - if {[llength $dictVar]} { + if {[string length $dictVar]} { lappend keys $k lappend values $v } } - list [lsort $keys] [lsort $values] + list [lsort $keys] [lsort $values] [testobj objtype $dictVar] } -cleanup { unset dictVar keys values k v -} -result {{a c e g} {b d f h}} +} -result {{a c e g} {b d f h} string} test dict-14.15 {dict for command: keys are unique and iterated over once only} -setup { unset -nocomplain accum array set accum {} @@ -1802,33 +1818,33 @@ test dict-24.13 {dict map command: script results} { error "return didn't go far enough" }} } ok,a,b -test dict-24.14 {dict map command: handle representation loss} -setup { +test dict-24.14 {dict map command: handle representation loss} -constraints testobj -setup { set keys {} set values {} } -body { set dictVar {a b c d e f g h} list [dict size [dict map {k v} $dictVar { - if {[llength $dictVar]} { + if {[string length $dictVar]} { lappend keys $k lappend values $v return -level 0 $k } - }]] [lsort $keys] [lsort $values] + }]] [lsort $keys] [lsort $values] [testobj objtype $dictVar] } -cleanup { unset dictVar keys values k v -} -result {4 {a c e g} {b d f h}} -test dict-24.14a {dict map command: handle representation loss} -body { +} -result {4 {a c e g} {b d f h} string} +test dict-24.14a {dict map command: handle representation loss} -constraints testobj -body { apply {{} { set dictVar {a b c d e f g h} list [dict size [dict map {k v} $dictVar { - if {[llength $dictVar]} { + if {[string length $dictVar]} { lappend keys $k lappend values $v return -level 0 $k } - }]] [lsort $keys] [lsort $values] + }]] [lsort $keys] [lsort $values] [testobj objtype $dictVar] }} -} -result {4 {a c e g} {b d f h}} +} -result {4 {a c e g} {b d f h} string} test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup { unset -nocomplain accum array set accum {} diff --git a/tests/encoding.test b/tests/encoding.test index 70aa99e..8bc096c 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -22,8 +22,6 @@ catch { package require -exact tcl::test [info patchlevel] } -source [file join [file dirname [info script]] tcltests.tcl] - proc toutf {args} { variable x lappend x "toutf $args" @@ -335,7 +333,7 @@ test encoding-15.4 {UtfToUtfProc emoji character input} -body { set x \xED\xA0\xBD\xED\xB8\x82 set y [encoding convertfrom -profile tcl8 utf-8 \xED\xA0\xBD\xED\xB8\x82] list [string length $x] $y -} -result "6 😂" +} -result "6 \uD83D\uDE02" test encoding-15.5 {UtfToUtfProc emoji character input} { set x \xF0\x9F\x98\x82 set y [encoding convertfrom utf-8 \xF0\x9F\x98\x82] @@ -346,7 +344,7 @@ test encoding-15.6 {UtfToUtfProc emoji character output} { set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83D\uDE02\uD83D] binary scan $y H* z list [string length $y] $z -} {10 edb882f09f9882eda0bd} +} {12 edb882eda0bdedb882eda0bd} test encoding-15.7 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83D\uD83D] @@ -521,7 +519,7 @@ test encoding-16.14 {Utf16ToUtfProc} -body { } -result \uDC00 test encoding-16.15 {Utf16ToUtfProc} -body { encoding convertfrom utf-16le \x00\xD8\x00\xDC -} -result \uD800\uDC00 +} -result \U010000 test encoding-16.16 {Utf16ToUtfProc} -body { encoding convertfrom -profile tcl8 utf-16le \x00\xDC\x00\xD8 } -result \uDC00\uD800 @@ -585,9 +583,9 @@ test encoding-16.25.tcl8 {Utf32ToUtfProc} -body { test encoding-17.1 {UtfToUtf16Proc} -body { encoding convertto utf-16 "\U460DC" } -result "\xD8\xD8\xDC\xDC" -test encoding-17.2 {UtfToUcs2Proc, invalid testcase, see [5607d6482c]} -constraints deprecated -body { - encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] -} -result "\uFFFD" +test encoding-17.2 {UtfToUcs2Proc} -body { + encoding convertfrom utf-16 \xD8\xD8\xDC\xDC +} -result "\U460DC" test encoding-17.3 {UtfToUtf16Proc} -body { encoding convertto -profile tcl8 utf-16be "\uDCDC" } -result "\xDC\xDC" @@ -1120,6 +1118,32 @@ test encoding-29.0 {get encoding nul terminator lengths} -constraints { [testencoding nullength ksc5601] } -result {1 2 4 2 2} +test encoding-30.0 {encoding convertto large strings UINT_MAX} -constraints { + perf +} -body { + # Test to ensure not misinterpreted as -1 + list [string length [set s [string repeat A 0xFFFFFFFF]]] [string equal $s [encoding convertto ascii $s]] +} -result {4294967295 1} + +test encoding-30.1 {encoding convertto large strings > 4GB} -constraints { + perf +} -body { + list [string length [set s [string repeat A 0x100000000]]] [string equal $s [encoding convertto ascii $s]] +} -result {4294967296 1} + +test encoding-30.2 {encoding convertfrom large strings UINT_MAX} -constraints { + perf +} -body { + # Test to ensure not misinterpreted as -1 + list [string length [set s [string repeat A 0xFFFFFFFF]]] [string equal $s [encoding convertfrom ascii $s]] +} -result {4294967295 1} + +test encoding-30.3 {encoding convertfrom large strings > 4GB} -constraints { + perf +} -body { + list [string length [set s [string repeat A 0x100000000]]] [string equal $s [encoding convertfrom ascii $s]] +} -result {4294967296 1} + test encoding-bug-6a3e2cb0f0-1 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body { encoding convertfrom -profile tcl8 iso2022-jp x\x1B\x7Aaby } -result x\uFFFDy diff --git a/tests/encodingVectors.tcl b/tests/encodingVectors.tcl index 3961917..8bd6b87 100644 --- a/tests/encodingVectors.tcl +++ b/tests/encodingVectors.tcl @@ -10,7 +10,7 @@ # List of defined encoding profiles set encProfiles {tcl8 strict replace} -set encDefaultProfile tcl8; # Should reflect the default from implementation +set encDefaultProfile strict; # Should reflect the default from implementation # encValidStrings - Table of valid strings. # @@ -332,22 +332,22 @@ lappend encInvalidBytes {*}{ utf-8 ED9F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 ED9F7F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 EDA080 tcl8 \uD800 -1 {} {High surrogate} - utf-8 EDA080 replace \uFFFD -1 {} {High surrogate} + utf-8 EDA080 replace \uFFFD -1 {knownBug} {High surrogate} utf-8 EDA080 strict {} 0 {} {High surrogate} utf-8 EDAFBF tcl8 \uDBFF -1 {} {High surrogate} - utf-8 EDAFBF replace \uFFFD -1 {} {High surrogate} + utf-8 EDAFBF replace \uFFFD -1 {knownBug} {High surrogate} utf-8 EDAFBF strict {} 0 {} {High surrogate} utf-8 EDB080 tcl8 \uDC00 -1 {} {Low surrogate} - utf-8 EDB080 replace \uFFFD -1 {} {Low surrogate} + utf-8 EDB080 replace \uFFFD -1 {knownBug} {Low surrogate} utf-8 EDB080 strict {} 0 {} {Low surrogate} - utf-8 EDBFBF tcl8 \uDFFF -1 {} {Low surrogate} - utf-8 EDBFBF replace \uFFFD -1 {} {Low surrogate} + utf-8 EDBFBF tcl8 \uDFFF -1 {knownBug} {Low surrogate} + utf-8 EDBFBF replace \uFFFD -1 {knownBug} {Low surrogate} utf-8 EDBFBF strict {} 0 {} {Low surrogate} - utf-8 EDA080EDB080 tcl8 \U00010000 -1 {} {High low surrogate pair} - utf-8 EDA080EDB080 replace \uFFFD\uFFFD -1 {} {High low surrogate pair} + utf-8 EDA080EDB080 tcl8 \U00010000 -1 {knownBug} {High low surrogate pair} + utf-8 EDA080EDB080 replace \uFFFD\uFFFD -1 {knownBug} {High low surrogate pair} utf-8 EDA080EDB080 strict {} 0 {} {High low surrogate pair} - utf-8 EDAFBFEDBFBF tcl8 \U0010FFFF -1 {} {High low surrogate pair} - utf-8 EDAFBFEDBFBF replace \uFFFD\uFFFD -1 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF tcl8 \U0010FFFF -1 {knownBug} {High low surrogate pair} + utf-8 EDAFBFEDBFBF replace \uFFFD\uFFFD -1 {knownBug} {High low surrogate pair} utf-8 EDAFBFEDBFBF strict {} 0 {} {High low surrogate pair} utf-8 EE tcl8 \u00EE -1 {} {Missing trail byte} @@ -553,10 +553,10 @@ lappend encInvalidBytes {*}{ utf-16le 41 replace \uFFFD -1 {solo tail} {Truncated} utf-16le 41 strict {} 0 {solo tail} {Truncated} utf-16le 00D8 tcl8 \uD800 -1 {} {Missing low surrogate} - utf-16le 00D8 replace \uFFFD -1 {knownBug} {Missing low surrogate} + utf-16le 00D8 replace \uFFFD -1 {} {Missing low surrogate} utf-16le 00D8 strict {} 0 {knownBug} {Missing low surrogate} utf-16le 00DC tcl8 \uDC00 -1 {} {Missing high surrogate} - utf-16le 00DC replace \uFFFD -1 {knownBug} {Missing high surrogate} + utf-16le 00DC replace \uFFFD -1 {} {Missing high surrogate} utf-16le 00DC strict {} 0 {knownBug} {Missing high surrogate} utf-16be 41 tcl8 \uFFFD -1 {solo tail} {Truncated} diff --git a/tests/env.test b/tests/env.test index 5317897..345567b 100644 --- a/tests/env.test +++ b/tests/env.test @@ -18,6 +18,11 @@ if {"::tcltest" ni [namespace children]} { source [file join [file dirname [info script]] tcltests.tcl] +testConstraint utf8system [string equal [encoding system] utf-8] +if {[llength [auto_execok bash]]} { + testConstraint haveBash 1 +} + # [exec] is required here to see the actual environment received by child # processes. proc getenv {} { @@ -411,6 +416,56 @@ test env-7.3 { }} } -cleanup cleanup1 -result 1 +test env-7.4 { + get env variable through upvar +} -setup setup1 -body { + apply {{} { + set ::env(test7_4) origvalue + upvar #0 env(test7_4) var + return $var + }} +} -cleanup cleanup1 -result origvalue + +test env-7.5 { + set env variable through upvar +} -setup setup1 -body { + apply {{} { + set ::env(test7_5) origvalue + upvar #0 env(test7_5) var + set var newvalue + return $::env(test7_5) + }} +} -cleanup cleanup1 -result newvalue + +test env-7.6 { + unset env variable through upvar +} -setup setup1 -body { + apply {{} { + set ::env(test7_6) origvalue + upvar #0 env(test7_6) var + unset var + return [array get env test7_6] + }} +} -cleanup cleanup1 -result {} + +test env-7.7 { + create new (unset) env variable through upvar +} -setup setup1 -body { + apply {{} { + unset -nocomplain ::env(test7_7) + upvar #0 env(test7_7) var + interp create interp1 + set var newvalue + set result [interp1 eval {info exists ::env(test7_7)}] + if {$result} { + lappend result [interp1 eval {set ::env(test7_7)}] + } + interp delete interp1 + return $result + }} +} -cleanup cleanup1 -result {1 newvalue} + + test env-8.0 { memory usage - valgrind does not report reachable memory } -body { @@ -458,6 +513,22 @@ test env-9.1 { } } -result {} +test env-10.0 { + Unequal environment strings test should test unequal +} -constraints {unix haveBash utf8system knownBug} -setup { + set tclScript [makeFile { + puts [string equal $env(XX) $env(YY)] + } tclScript] + set shellCode { + export XX=$'\351' + export YY=$'\303\251' + } + append shellCode "[info nameofexecutable] $tclScript\n" + set shScript [makeFile $shellCode shScript] +} -body { + exec {*}[auto_execok bash] $shScript +} -result 0 + # cleanup diff --git a/tests/exec.test b/tests/exec.test index 4058ae9..4f7a1a8 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -434,15 +434,21 @@ test exec-10.19 {errors in exec invocation} -constraints {exec} -body { exec cat >@ $f } -returnCodes error -result "channel \"$f\" wasn't opened for writing" close $f -test exec-10.20 {errors in exec invocation} -constraints {exec notValgrind} -body { +test exec-10.20.1 {errors in exec invocation} -constraints {unix exec notValgrind} -body { exec ~non_existent_user/foo/bar -} -returnCodes error -result {user "non_existent_user" doesn't exist} -test exec-10.21 {errors in exec invocation} -constraints {exec notValgrind} -body { +} -returnCodes error -result {couldn't execute "~non_existent_user/foo/bar": no such file or directory} +test exec-10.20.2 {errors in exec invocation} -constraints {win exec notValgrind} -body { + exec ~non_existent_user/foo/bar +} -returnCodes error -result {couldn't execute "~non_existent_user\foo\bar": no such file or directory} +test exec-10.21.1 {errors in exec invocation} -constraints {unix exec notValgrind} -body { + exec [interpreter] true | ~xyzzy_bad_user/x | false +} -returnCodes error -result {couldn't execute "~xyzzy_bad_user/x": no such file or directory} +test exec-10.21.2 {errors in exec invocation} -constraints {win exec notValgrind} -body { exec [interpreter] true | ~xyzzy_bad_user/x | false -} -returnCodes error -result {user "xyzzy_bad_user" doesn't exist} +} -returnCodes error -result {couldn't execute "~xyzzy_bad_user\x": no such file or directory} test exec-10.22 {errors in exec invocation} -constraints {exec notValgrind} -body { exec echo test > ~non_existent_user/foo/bar -} -returnCodes error -result {user "non_existent_user" doesn't exist} +} -returnCodes error -result {couldn't write file "~non_existent_user/foo/bar": no such file or directory} # Commands in background. test exec-11.1 {commands in background} {exec} { @@ -706,6 +712,35 @@ test exec-20.1 {exec .CMD file} -constraints {win} -body { exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1" viewFile $log } -result "\"Testing exec-20.1\"" + +# Test with encoding mismatches (Bug 0f1ddc0df7fb7) +test exec-21.1 {exec encoding mismatch on stdout} -setup { + set path(script) [makeFile { + fconfigure stdout -translation binary + puts a\xe9b + } script] + set enc [encoding system] + encoding system utf-8 +} -cleanup { + removeFile $path(script) + encoding system $enc +} -body { + exec [info nameofexecutable] $path(script) +} -result a\uFFFDb +test exec-21.2 {exec encoding mismatch on stderr} -setup { + set path(script) [makeFile { + fconfigure stderr -translation binary + puts stderr a\xe9b + } script] + set enc [encoding system] + encoding system utf-8 +} -cleanup { + removeFile $path(script) + encoding system $enc +} -body { + list [catch {exec [info nameofexecutable] $path(script)} r] $r +} -result [list 1 a\uFFFDb] + # ---------------------------------------------------------------------- # cleanup diff --git a/tests/execute.test b/tests/execute.test index 8702de6..90af21c 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -34,7 +34,6 @@ testConstraint testobj [expr { && [llength [info commands teststringobj]] }] -testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] testConstraint testexprlongobj [llength [info commands testexprlongobj]] @@ -464,10 +463,6 @@ test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { list [catch {expr {! $x}} msg] $msg } {1 {can't use non-numeric string "foo" as operand of "!"}} -# INST_BITNOT not tested -# INST_CALL_BUILTIN_FUNC1 not tested -# INST_CALL_FUNC1 not tested - # INST_TRY_CVT_TO_NUMERIC is partially tested: test execute-3.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} { set x [testintobj set 1 1] @@ -1066,7 +1061,7 @@ test execute-9.1 {Interp result resetting [Bug 1522803]} { } SUCCESS test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} { - apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} İ + apply {s {binary scan [binary format a $s] c x; list $x [scan $s$s %c%c]}} İ } {48 {304 304}} test execute-10.2 {Bug 2802881} -setup { interp create child diff --git a/tests/expr-old.test b/tests/expr-old.test index 2401bd4..7274851 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -25,7 +25,6 @@ testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] -testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] # Big test for correct ordering of data in [expr] @@ -950,7 +949,7 @@ test expr-old-36.1 {ExprLooksLikeInt procedure} -body { test expr-old-36.2 {ExprLooksLikeInt procedure} { set x 0o289 list [catch {expr {$x+1}} msg] $msg -} {1 {can't use invalid octal number "0o289" as operand of "+"}} +} {1 {can't use non-numeric string "0o289" as operand of "+"}} test expr-old-36.3 {ExprLooksLikeInt procedure} { list [catch {expr 0289.1} msg] $msg } {0 289.1} @@ -1002,7 +1001,7 @@ test expr-old-36.14 {ExprLooksLikeInt procedure} { test expr-old-36.15 {ExprLooksLikeInt procedure} { set x "0o99 " list [catch {expr {$x+1}} msg] $msg -} {1 {can't use invalid octal number "0o99 " as operand of "+"}} +} {1 {can't use non-numeric string "0o99 " as operand of "+"}} test expr-old-36.16 {ExprLooksLikeInt procedure} { set x " 0xffffffffffffffffffffffffffffffffffffff " expr {$x+1} diff --git a/tests/expr.test b/tests/expr.test index 2c1dc21..f2c7ae6 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -16,13 +16,11 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact tcl::test [info patchlevel]] # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] -testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] # Big test for correct ordering of data in [expr] @@ -853,7 +851,7 @@ test expr-21.21 {non-numeric boolean variables} { test expr-21.22 {non-numeric boolean variables} { set v "" list [catch {expr {!$v}} err] $err -} {1 {can't use empty string "" as operand of "!"}} +} {1 {can't use non-numeric string "" as operand of "!"}} # Test for non-numeric float handling. test expr-22.1 {non-numeric floats} { @@ -7454,43 +7452,45 @@ test expr-62.10 {TIP 582: comments can go inside function calls} { (1,2)} } 2 -# Bug e3dcab1d14 -proc do-one-test-expr-63 {e p float athreshold} { - # e - power of 2 to test - # p - tcl_precision to test with - # float - floating point value 2**-$p - # athreshold - tolerable absolute error (1/2 decimal digit in - # least significant place plus 1/2 least significant bit) - set trouble {} - set ::tcl_precision $p - set xfmt x[expr $float] - set ::tcl_precision 0 - set fmt [string range $xfmt 1 end] - set aerror [expr {abs($fmt - $float)}] - if {$aerror > $athreshold} { - return "Result $fmt is more than $athreshold away from $float" - } else { - return {} - } -} - -proc run-test-expr-63 {} { - for {set e 0} {$e <= 1023} {incr e} { - set pt [expr {floor($e*log(2)/log(10))}] - for {set p 6} {$p <= 17} {incr p} { - set athreshold [expr {0.5*10.0**-($pt+$p) + 2.0**-($e+53)}] - set numer [expr {5**$e}] - set xfloat x[expr {2.**-$e}] - set float [string range $xfloat 1 end] - test expr-63.$p.$e "convert 2**-$e to decimal at precision $p" { - do-one-test-expr-63 $e $p $float $athreshold - } {} - } - } - rename do-one-test-expr-63 {} - rename run-test-expr-63 {} -} -run-test-expr-63 +# Bug e3dcab1d14 TODO: Need to work out a test case that fails +# without tcl_precision, which has been eliminated in 9.0 + +# proc do-one-test-expr-63 {e p float athreshold} { +# # e - power of 2 to test +# # p - tcl_precision to test wuth +# # float - floating point value 2**-$p +# # athreshold - tolerable absolute error (1/2 decimal digit in +# # least significant place plus 1/2 least significant bit) +# set trouble {} +# set ::tcl_precision $p +# set xfmt x[expr $float] +# set ::tcl_precision 0 +# set fmt [string range $xfmt 1 end] +# set aerror [expr {abs($fmt - $float)}] +# if {$aerror > $athreshold} { +# return "Result $fmt is more than $athreshold away from $float" +# } else { +# return {} +# } +# } + +# proc run-test-expr-63 {} { +# for {set e 0} {$e <= 1023} {incr e} { +# set pt [expr {floor($e*log(2)/log(10))}] +# for {set p 6} {$p <= 17} {incr p} { +# set athreshold [expr {0.5*10.0**-($pt+$p) + 2.0**-($e+53)}] +# set numer [expr {5**$e}] +# set xfloat x[expr {2.**-$e}] +# set float [string range $xfloat 1 end] +# test expr-63.$p.$e "convert 2**-$e to decimal at precision $p" { +# do-one-test-expr-63 $e $p $float $athreshold +# } {} +# } +# } +# rename do-one-test-expr-63 {} +# rename run-test-expr-63 {} +# } +# run-test-expr-63 # cleanup unset -nocomplain a diff --git a/tests/fCmd.test b/tests/fCmd.test index 2469762..9940192 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -102,6 +102,14 @@ if {[testConstraint unix]} { set user "root" } } +if {[testConstraint win]} { + catch { + set user $::env(USERNAME) + } + if {$user eq ""} { + set user Administrator + } +} # Try getting a lower case glob pattern that will match the home directory of # a given user to test ~user and [file tildeexpand ~user]. Note this may not @@ -167,6 +175,10 @@ proc checkcontent {file matchString} { } proc openup {path} { + # Double check for inadvertent ~ -> home directory mapping + if {[string match ~* $path]} { + set file ./$path + } testchmod 0o777 $path if {[file isdirectory $path]} { catch { @@ -182,9 +194,13 @@ proc cleanup {args} { foreach p [concat $wd $args] { set x "" catch { - set x [glob -directory $p tf* td*] + set x [glob -directory $p tf* td* ~*] } foreach file $x { + # Double check for inadvertent ~ -> home directory mapping + if {[string match ~* $file]} { + set file ./$file + } if { [catch {file delete -force -- $file}] && [testConstraint testchmod] @@ -224,6 +240,43 @@ test fCmd-1.1 {TclFileRenameCmd} -constraints {notRoot} -setup { file rename tf1 tf2 glob tf* } -result {tf2} +test fCmd-1.2 {TclFileRenameCmd when target is ~} -setup { + cleanup + createfile tf1 +} -cleanup { + file delete ./~ +} -body { + file rename tf1 ~ + file isfile ~ +} -result 1 +test fCmd-1.3 {TclFileRenameCmd when target is ~user} -setup { + cleanup + createfile tf1 +} -cleanup { + file delete ./~$user +} -body { + file rename tf1 ~$user + file isfile ~$user +} -result 1 +test fCmd-1.4 {TclFileRenameCmd when source is ~} -setup { + cleanup + createfile ./~ +} -cleanup { + file delete ./~ +} -body { + file rename ~ tf1 + list [file exists ~] [file exists tf1] +} -result {0 1} +test fCmd-1.5 {TclFileRenameCmd when source is ~user} -setup { + cleanup + createfile ./~$user +} -cleanup { + file delete ./~$user +} -body { + file rename ~$user tf1 + list [file exists ~$user] [file exists tf1] +} -result {0 1} + test fCmd-2.1 {TclFileCopyCmd} -constraints {notRoot} -setup { cleanup @@ -232,6 +285,42 @@ test fCmd-2.1 {TclFileCopyCmd} -constraints {notRoot} -setup { file copy tf1 tf2 lsort [glob tf*] } -result {tf1 tf2} +test fCmd-2.2 {TclFileCopyCmd when target is ~} -setup { + cleanup + createfile tf1 +} -cleanup { + file delete ./~ +} -body { + file copy tf1 ~ + list [file exists tf1] [file exists ~] +} -result {1 1} +test fCmd-2.3 {TclFileCopyCmd when target is ~user} -setup { + cleanup + createfile tf1 +} -cleanup { + file delete ./~$user +} -body { + file copy tf1 ~$user + list [file exists tf1] [file exists ~$user] +} -result {1 1} +test fCmd-2.4 {TclFileCopyCmd when source is ~} -setup { + cleanup + createfile ./~ +} -cleanup { + file delete ./~ +} -body { + file copy ~ tf1 + list [file exists ~] [file exists tf1] +} -result {1 1} +test fCmd-2.5 {TclFileCopyCmd when source is ~user} -setup { + cleanup + createfile ./~$user +} -cleanup { + file delete ./~$user +} -body { + file copy ~$user tf1 + list [file exists ~$user] [file exists tf1] +} -result {1 1} test fCmd-3.1 {FileCopyRename: FileForceOption fails} -constraints {notRoot} -body { file rename -xyz @@ -241,7 +330,7 @@ test fCmd-3.2 {FileCopyRename: not enough args} -constraints {notRoot} -body { } -returnCodes error -result {wrong # args: should be "file rename ?-option value ...? source ?source ...? target"} test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} -constraints {notRoot} -body { file rename xyz ~_totally_bogus_user -} -returnCodes error -result {user "_totally_bogus_user" doesn't exist} +} -returnCodes error -result {error renaming "xyz": no such file or directory} test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { @@ -315,7 +404,7 @@ test fCmd-3.14 {FileCopyRename: FileBasename fails} -setup { } -constraints {notRoot} -returnCodes error -body { file mkdir td1 file rename ~_totally_bogus_user td1 -} -result {user "_totally_bogus_user" doesn't exist} +} -result {error renaming "~_totally_bogus_user": no such file or directory} test fCmd-3.15 {FileCopyRename: source[0] == '\x00'} -setup { cleanup } -constraints {notRoot unixOrWin} -returnCodes error -body { @@ -353,11 +442,17 @@ test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} -setup { catch {file mkdir td1 td2 tf1 td3 td4} glob td1 td2 tf1 td3 td4 } -result {td1 td2 tf1} -test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} -setup { +test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName treats ~ as normal char} -setup { cleanup -} -constraints {notRoot} -returnCodes error -body { +} -constraints {notRoot} -body { + list [file isdir ~] [file mkdir ~] [file isdir ~] +} -result {0 {} 1} +test fCmd-4.4.1 {TclFileMakeDirsCmd: Tcl_TranslateFileName treats ~ as normal char} -setup { + cleanup +} -constraints {notRoot} -body { file mkdir ~_totally_bogus_user -} -result {user "_totally_bogus_user" doesn't exist} + file isdir ~_totally_bogus_user +} -result 1 test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\x00'} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { @@ -465,15 +560,16 @@ test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup { catch {file delete tf1 td1 $root tf2} list [file exists tf1] [file exists tf2] [file exists td1] } -cleanup {cleanup} -result {0 1 0} -test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} -constraints {notRoot} -body { +test fCmd-5.6 { + TclFileDeleteCmd: Tcl_TranslateFileName treats ~user as normal char +} -constraints {notRoot} -body { file delete ~_totally_bogus_user -} -returnCodes error -result {user "_totally_bogus_user" doesn't exist} -test fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} -setup { - catch {file delete ~/tf1} +} -result {} +test fCmd-5.7 { + TclFileDeleteCmd: Tcl_TranslateFileName treats ~ as normal char } -constraints {notRoot} -body { createfile ~/tf1 - file delete ~/tf1 -} -result {} +} -returnCodes error -result {couldn't open "~/tf1": no such file or directory} test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} -setup { cleanup } -constraints {notRoot} -body { @@ -672,37 +768,37 @@ test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup { cleanup } -constraints {unix notRoot} -body { - file mkdir ~/td1/td2 - set td1name [file join [file dirname ~] [file tail ~] td1] + file mkdir [file home]/td1/td2 + set td1name [file join [file dirname [file home]] [file tail [file home]] td1] file attributes $td1name -permissions 0 - file copy ~/td1 td1 + file copy [file home]/td1 td1 } -returnCodes error -cleanup { file attributes $td1name -permissions 0o755 - file delete -force ~/td1 -} -result {error copying "~/td1": permission denied} + file delete -force [file home]/td1 +} -result "error copying \"[file home]/td1\": permission denied" test fCmd-6.25 {CopyRenameOneFile: error uses original name} -setup { cleanup } -constraints {unix notRoot} -body { file mkdir td2 - file mkdir ~/td1 - set td1name [file join [file dirname ~] [file tail ~] td1] + file mkdir [file home]/td1 + set td1name [file join [file dirname [file home]] [file tail [file home]] td1] file attributes $td1name -permissions 0 - file copy td2 ~/td1 + file copy td2 [file home]/td1 } -returnCodes error -cleanup { file attributes $td1name -permissions 0o755 - file delete -force ~/td1 -} -result {error copying "td2" to "~/td1/td2": permission denied} + file delete -force [file home]/td1 +} -result "error copying \"td2\" to \"[file home]/td1/td2\": permission denied" test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} -setup { cleanup } -constraints {unix notRoot} -body { - file mkdir ~/td1/td2 - set td2name [file join [file dirname ~] [file tail ~] td1 td2] + file mkdir [file home]/td1/td2 + set td2name [file join [file dirname [file home]] [file tail [file home]] td1 td2] file attributes $td2name -permissions 0 - file copy ~/td1 td1 + file copy [file home]/td1 td1 } -returnCodes error -cleanup { file attributes $td2name -permissions 0o755 - file delete -force ~/td1 -} -result "error copying \"~/td1\" to \"td1\": \"[file join $::env(HOME) td1 td2]\": permission denied" + file delete -force [file home]/td1 +} -result "error copying \"[file home]/td1\" to \"td1\": \"[file join $::env(HOME) td1 td2]\": permission denied" test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { cleanup $tmpspace } -constraints {notRoot xdev} -returnCodes error -body { @@ -778,15 +874,15 @@ test fCmd-7.4 {FileForceOption: bad option} -constraints {notRoot} -setup { } -result {bad option "-tf1": must be -force or --} test fCmd-7.5 {FileForceOption: multiple times through loop} -setup { cleanup -} -constraints {notRoot} -returnCodes error -body { +} -constraints {notRoot} -body { createfile -- createfile -force file delete -force -force -- -- -force glob -- -- -force -} -result {no files matched glob patterns "-- -force"} +} -result {} test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ - -constraints {unix notRoot knownBug} -body { + -constraints {unix notRoot knownBug tildeexpansion} -body { # Labeled knownBug because it is dangerous [Bug: 3881] file mkdir td1 file attr td1 -perm 0o40000 @@ -797,11 +893,11 @@ test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ test fCmd-8.2 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ -constraints {unix notRoot} -body { string equal [file tail ~$user] ~$user -} -result 0 +} -result 1 test fCmd-8.3 {file copy and path translation: ensure correct error} -body { - file copy ~ [file join this file doesnt exist] + file copy [file home] [file join this file doesnt exist] } -returnCodes error -result [subst \ - {error copying "~" to "[file join this file doesnt exist]": no such file or directory}] + {error copying "[file home]" to "[file join this file doesnt exist]": no such file or directory}] test fCmd-9.1 {file rename: comprehensive: EACCES} -setup { cleanup @@ -943,9 +1039,9 @@ test fCmd-9.10 {file rename: comprehensive: file to new name and dir} -setup { testchmod 0o444 tf2 file rename tf1 [file join td1 tf3] file rename tf2 [file join td1 tf4] - list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \ + list [glob tf*] [lsort [glob -directory td1 t*]] \ [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] -} -result [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}] +} -result [subst {{} {[file join td1 tf3] [file join td1 tf4]} 1 0}] test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} -setup { cleanup } -constraints {notRoot testchmod} -body { @@ -1553,9 +1649,11 @@ test fCmd-14.8 {copyfile: copy directory failing} -setup { # # Coverage tests for TclMkdirCmd() # + +# ~ is no longer a special char. Need a test case where translation fails. test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} -setup { set temp $::env(HOME) -} -constraints {notRoot} -body { +} -constraints {notRoot TODO} -body { global env unset env(HOME) catch {file mkdir ~/tfa} @@ -1654,9 +1752,10 @@ test fCmd-16.4 {accept zero files (TIP 323)} -body { test fCmd-16.5 {accept zero files (TIP 323)} -body { file delete -- } -result {} +# ~ is no longer a special char. Need a test case where translation fails. test fCmd-16.6 {delete: source filename translation failing} -setup { set temp $::env(HOME) -} -constraints {notRoot} -body { +} -constraints {notRoot TODO} -body { global env unset env(HOME) catch {file delete ~/tfa} @@ -2282,7 +2381,7 @@ test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} -setup { file attributes ~_totally_bogus_user } -returnCodes error -cleanup { testsetplatform $platform -} -result {user "_totally_bogus_user" doesn't exist} +} -result {could not read "~_totally_bogus_user": no such file or directory} test fCmd-27.3 {TclFileAttrsCmd - all attributes} -setup { catch {file delete -force -- foo.tmp} } -body { diff --git a/tests/fileName.test b/tests/fileName.test index b147bd7..46f1c5e 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -72,15 +72,15 @@ test filename-1.4 {Tcl_GetPathType: unix} {testsetplatform} { test filename-1.5 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~ -} absolute +} relative test filename-1.6 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~/foo -} absolute +} relative test filename-1.7 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~foo -} absolute +} relative test filename-1.8 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ./~foo @@ -137,15 +137,15 @@ test filename-3.12 {Tcl_GetPathType: windows} {testsetplatform} { test filename-3.13 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~foo -} absolute +} relative test filename-3.14 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~ -} absolute +} relative test filename-3.15 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~/foo -} absolute +} relative test filename-3.16 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ./~foo @@ -214,11 +214,11 @@ test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} { test filename-4.16 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ~foo/~bar -} {~foo ./~bar} +} {~foo ~bar} test filename-4.17 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ~foo/~bar/~baz -} {~foo ./~bar ./~baz} +} {~foo ~bar ~baz} test filename-4.18 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo/bar~/baz @@ -358,11 +358,11 @@ test filename-6.26 {Tcl_SplitPath: win} {testsetplatform} { test filename-6.27 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ~foo/~bar -} {~foo ./~bar} +} {~foo ~bar} test filename-6.28 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ~foo/~bar/~baz -} {~foo ./~bar ./~baz} +} {~foo ~bar ~baz} test filename-6.29 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split foo/bar~/baz @@ -370,7 +370,7 @@ test filename-6.29 {Tcl_SplitPath: win} {testsetplatform} { test filename-6.30 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:~foo -} {c: ./~foo} +} {c: ~foo} test filename-7.1 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix @@ -415,7 +415,7 @@ test filename-7.10 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.11 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ~a ~b -} {~b} +} {~a/~b} test filename-7.12 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a b @@ -423,11 +423,11 @@ test filename-7.12 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.13 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a ~b -} {~b} +} {./~a/~b} test filename-7.14 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a ./~b -} {./~a/~b} +} {./~a/./~b} test filename-7.15 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a . b @@ -435,7 +435,7 @@ test filename-7.15 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a . ./~b -} {a/./~b} +} {a/././~b} test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join //a b @@ -491,11 +491,11 @@ test filename-9.10 {Tcl_JoinPath: win} {testsetplatform} { test filename-9.11 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ~ ./~foo -} {~/~foo} +} {~/./~foo} test filename-9.12 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join / ~foo -} {~foo} +} {/~foo} test filename-9.13 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ./a/ b c @@ -601,7 +601,7 @@ test filename-10.6 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {/home/test/foo} +} -result {~/foo} test filename-10.7 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -609,9 +609,9 @@ test filename-10.7 {Tcl_TranslateFileName} -setup { unset env(HOME) testsetplatform unix testtranslatefilename ~/foo -} -returnCodes error -cleanup { +} -cleanup { set env(HOME) $temp -} -result {couldn't find HOME environment variable to expand path} +} -result {~/foo} test filename-10.8 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -621,7 +621,7 @@ test filename-10.8 {Tcl_TranslateFileName} -setup { testtranslatefilename ~ } -cleanup { set env(HOME) $temp -} -result {/home/test} +} -result {~} test filename-10.9 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -631,7 +631,7 @@ test filename-10.9 {Tcl_TranslateFileName} -setup { testtranslatefilename ~ } -cleanup { set env(HOME) $temp -} -result {/home/test} +} -result {~} test filename-10.10 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -641,7 +641,7 @@ test filename-10.10 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {/home/test/foo} +} -result {~/foo} test filename-10.17 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -651,7 +651,7 @@ test filename-10.17 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {\home\foo} +} -result {~\foo} test filename-10.18 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -661,7 +661,7 @@ test filename-10.18 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo\\bar } -cleanup { set env(HOME) $temp -} -result {\home\foo\bar} +} -result {~\foo\bar} test filename-10.19 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -671,11 +671,11 @@ test filename-10.19 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {c:foo} -test filename-10.20 {Tcl_TranslateFileName} -returnCodes error -body { +} -result {~\foo} +test filename-10.20 {Tcl_TranslateFileName} -body { testtranslatefilename ~blorp/foo } -constraints {testtranslatefilename testtranslatefilename} \ - -result {user "blorp" doesn't exist} + -result {~blorp\foo} test filename-10.21 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -685,7 +685,7 @@ test filename-10.21 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {c:\foo} +} -result {~\foo} test filename-10.22 {Tcl_TranslateFileName} -body { testsetplatform windows testtranslatefilename foo//bar @@ -702,9 +702,9 @@ test filename-10.24 {Tcl_TranslateFileName} -body { testtranslatefilename ~ouster/foo } -result {/home/ouster/foo} -constraints {nonPortable testtranslatefilename} -test filename-11.1 {Tcl_GlobCmd} -returnCodes error -body { +test filename-11.1 {Tcl_GlobCmd} -body { glob -} -result {no files matched glob patterns ""} +} -result {} test filename-11.2 {Tcl_GlobCmd} -returnCodes error -body { glob -gorp } -result {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -tails, -types, or --} @@ -714,45 +714,46 @@ test filename-11.3 {Tcl_GlobCmd} -body { test filename-11.4 {Tcl_GlobCmd} -body { glob -nocomplain } -result {} -test filename-11.5 {Tcl_GlobCmd} -returnCodes error -body { - glob -nocomplain * ~xyqrszzz -} -result {user "xyqrszzz" doesn't exist} -test filename-11.6 {Tcl_GlobCmd} -returnCodes error -body { +test filename-11.5 {Tcl_GlobCmd} -body { + # Should not error out because of ~ + catch {glob -nocomplain * ~xyqrszzz} +} -result 0 +test filename-11.6 {Tcl_GlobCmd} -body { glob ~xyqrszzz -} -result {user "xyqrszzz" doesn't exist} -test filename-11.7 {Tcl_GlobCmd} -returnCodes error -body { +} -result {} +test filename-11.7 {Tcl_GlobCmd} -body { glob -- -nocomplain -} -result {no files matched glob pattern "-nocomplain"} +} -result {} test filename-11.8 {Tcl_GlobCmd} -body { glob -nocomplain -- -nocomplain } -result {} test filename-11.9 {Tcl_GlobCmd} -constraints {testsetplatform} -body { testsetplatform unix glob ~\\xyqrszzz/bar -} -returnCodes error -result {user "\xyqrszzz" doesn't exist} +} -result {} test filename-11.10 {Tcl_GlobCmd} -constraints {testsetplatform} -body { testsetplatform unix glob -nocomplain ~\\xyqrszzz/bar -} -returnCodes error -result {user "\xyqrszzz" doesn't exist} +} -result {} test filename-11.11 {Tcl_GlobCmd} -constraints {testsetplatform} -body { testsetplatform unix glob ~xyqrszzz\\/\\bar -} -returnCodes error -result {user "xyqrszzz" doesn't exist} +} -result {} test filename-11.12 {Tcl_GlobCmd} -constraints {testsetplatform} -setup { testsetplatform unix set home $env(HOME) } -body { unset env(HOME) glob ~/* -} -returnCodes error -cleanup { +} -cleanup { set env(HOME) $home -} -result {couldn't find HOME environment variable to expand path} +} -result {} if {[testConstraint testsetplatform]} { testsetplatform $platform } -test filename-11.13 {Tcl_GlobCmd} { +test filename-11.13 {Tcl_GlobCmd} -body { file join [lindex [glob ~] 0] -} [file join $env(HOME)] +} -result {} set oldpwd [pwd] set oldhome $env(HOME) catch {cd [makeDirectory tcl[pid]]} @@ -770,12 +771,12 @@ touch globTest/a1/b1/x2.c touch globTest/a1/b2/y2.c touch globTest/.1 touch globTest/x,z1.c -test filename-11.14 {Tcl_GlobCmd} { +test filename-11.14 {Tcl_GlobCmd} -body { glob ~/globTest -} [list [file join $env(HOME) globTest]] -test filename-11.15 {Tcl_GlobCmd} { +} -result {} +test filename-11.15 {Tcl_GlobCmd} -body { glob ~\\/globTest -} [list [file join $env(HOME) globTest]] +} -result {} test filename-11.16 {Tcl_GlobCmd} { glob globTest } {globTest} @@ -1098,42 +1099,42 @@ file delete -force $tildeglobname set globname globTest unset horribleglobname tildeglobname -test filename-12.1 {simple globbing} {unixOrWin} { +test filename-12.1 {simple globbing} -constraints {unixOrWin} -body { glob {} -} {.} +} -result {.} test filename-12.1.1 {simple globbing} -constraints {unixOrWin} -body { glob -types f {} -} -returnCodes error -result {no files matched glob pattern ""} -test filename-12.1.2 {simple globbing} {unixOrWin} { +} -result {} +test filename-12.1.2 {simple globbing} -constraints {unixOrWin} -body { glob -types d {} -} {.} -test filename-12.1.3 {simple globbing} {unix} { +} -result {.} +test filename-12.1.3 {simple globbing} -constraints {unix} -body { glob -types hidden {} -} {.} +} -result {.} test filename-12.1.4 {simple globbing} -constraints {win} -body { glob -types hidden {} -} -returnCodes error -result {no files matched glob pattern ""} +} -result {} test filename-12.1.5 {simple globbing} -constraints {win} -body { glob -types hidden c:/ -} -returnCodes error -result {no files matched glob pattern "c:/"} -test filename-12.1.6 {simple globbing} {win} { +} -result {} +test filename-12.1.6 {simple globbing} -constraints {win} -body { glob c:/ -} {c:/} -test filename-12.3 {simple globbing} { +} -result {c:/} +test filename-12.3 {simple globbing} -body { glob -nocomplain \{a1,a2\} -} {} +} -result {} set globPreResult globTest/ set x1 x1.c set y1 y1.c -test filename-12.4 {simple globbing} {unixOrWin} { +test filename-12.4 {simple globbing} -constraints {unixOrWin} -body { lsort [glob globTest/x1.c globTest/y1.c globTest/foo] -} "$globPreResult$x1 $globPreResult$y1" -test filename-12.5 {simple globbing} { +} -result "$globPreResult$x1 $globPreResult$y1" +test filename-12.5 {simple globbing} -body { glob globTest\\/x1.c -} "$globPreResult$x1" -test filename-12.6 {simple globbing} { +} -result "$globPreResult$x1" +test filename-12.6 {simple globbing} -body { glob globTest\\/\\x1.c -} "$globPreResult$x1" +} -result "$globPreResult$x1" test filename-12.7 {globbing at filesystem root} -constraints {unix} -body { list [glob -nocomplain /*] [glob -path / *] } -match compareWords -result equal @@ -1253,7 +1254,7 @@ test filename-14.17 {asterisks, question marks, and brackets} -setup { set temp $env(HOME) } -body { set env(HOME) [file join $env(HOME) globTest] - glob ~/z* + glob [file home]/z* } -cleanup { set env(HOME) $temp } -result [list [file join $env(HOME) globTest z1.c]] @@ -1265,10 +1266,10 @@ test filename-14.20 {asterisks, question marks, and brackets} { } {} test filename-14.21 {asterisks, question marks, and brackets} -body { glob globTest/*/gorp -} -returnCodes error -result {no files matched glob pattern "globTest/*/gorp"} +} -result {} test filename-14.22 {asterisks, question marks, and brackets} -body { glob goo/* x*z foo?q -} -returnCodes error -result {no files matched glob patterns "goo/* x*z foo?q"} +} -result {} test filename-14.23 {slash globbing} {unix} { glob / } / @@ -1350,11 +1351,10 @@ test filename-15.4 {unix specific no complain: no errors, good result} \ glob -nocomplain ~ouster ~foo ~welch } {/home/ouster /home/welch} test filename-15.4.1 {no complain: errors, sequencing} { - # test used to fail because if an error occurs, the interp's result is - # reset... But, the sequence means we throw a different error first. + # ~xxx no longer expanded so errors about unknown users should not occur list [catch {glob -nocomplain ~wontexist ~blahxyz ~} res1] $res1 \ [catch {glob -nocomplain ~ ~blahxyz ~wontexist} res2] $res2 -} {1 {user "wontexist" doesn't exist} 1 {user "blahxyz" doesn't exist}} +} {0 {} 0 {}} test filename-15.4.2 {no complain: errors, sequencing} -body { # test used to fail because if an error occurs, the interp's result is # reset... @@ -1364,20 +1364,12 @@ test filename-15.4.2 {no complain: errors, sequencing} -body { test filename-15.5 {unix specific globbing} {unix nonPortable} { glob ~ouster/.csh* } "/home/ouster/.cshrc" -touch globTest/odd\\\[\]*?\{\}name -test filename-15.6 {unix specific globbing} -constraints {unix} -setup { - global env - set temp $env(HOME) -} -body { - set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name - glob ~ -} -cleanup { - set env(HOME) $temp -} -result [list [lindex [glob ~] 0]/globTest/odd\\\[\]*?\{\}name] -catch {file delete -force globTest/odd\\\[\]*?\{\}name} -test filename-15.7 {win specific globbing} -constraints {win} -body { +# 15.6 removed. It checked if glob ~ returned valid information if +# home directory contained glob chars. Since ~ expansion is no longer +# supported, the test was meaningless +test filename-15.7 {glob tilde} -body { glob ~ -} -match regexp -result {[^/]$} +} -result {} test filename-15.8 {win and unix specific globbing} -constraints {unixOrWin} -setup { global env set temp $env(HOME) @@ -1388,7 +1380,7 @@ test filename-15.8 {win and unix specific globbing} -constraints {unixOrWin} -se } -cleanup { set env(HOME) $temp catch {file delete -force $env(HOME)/globTest/anyname} -} -result [list [lindex [glob ~] 0]/globTest/anyname] +} -result {} # The following tests are only valid for Windows systems. set oldDir [pwd] @@ -1567,7 +1559,7 @@ test fileName-20.5 {Bug 2837800} -setup { test fileName-20.6 {Bug 2837800} -setup { # Recall that we have $env(HOME) set so that references # to ~ point to [temporaryDirectory] - makeFile {} test ~ + makeFile {} test [file home] set dd [makeDirectory isolate] set d [makeDirectory ./~ $dd] set savewd [pwd] @@ -1578,7 +1570,7 @@ test fileName-20.6 {Bug 2837800} -setup { cd $savewd removeDirectory ./~ $dd removeDirectory isolate - removeFile test ~ + removeFile test [file home] } -result {} test fileName-20.7 {Bug 2806250} -setup { set savewd [pwd] @@ -1603,34 +1595,42 @@ test fileName-20.8 {Bug 2806250} -setup { removeFile ./~test $d removeDirectory isolate cd $savewd -} -result ./~test -test fileName-20.9 {globbing for special chars} -setup { - makeFile {} test ~ - set d [makeDirectory isolate] - set savewd [pwd] - cd $d -} -body { - glob -nocomplain -directory ~ test -} -cleanup { - cd $savewd - removeDirectory isolate - removeFile test ~ -} -result ~/test +} -result ~test test fileName-20.10 {globbing for special chars} -setup { - set s [makeDirectory sub ~] + set s [makeDirectory sub [file home]] makeFile {} fileName-20.10 $s set d [makeDirectory isolate] set savewd [pwd] cd $d } -body { - glob -nocomplain -directory ~ -join * fileName-20.10 + glob -nocomplain -directory [file home] -join * fileName-20.10 } -cleanup { cd $savewd removeDirectory isolate removeFile fileName-20.10 $s - removeDirectory sub ~ -} -result ~/sub/fileName-20.10 - + removeDirectory sub [file home] +} -result [file home]/sub/fileName-20.10 +test fileName-20.11 {glob dir with undecodable file names} -setup { + # Specifically use /tmp as on WSL [temporaryDirectory] + # on NTFS prevents creation of arbitrary byte sequences in names. + set prevDir [pwd] + set testDir /tmp/tcltest/fileName-20.11 + file delete -force $testDir; # Clear it + file mkdir $testDir + cd $testDir + set prevEnc [encoding system] + # Create a file name that is invalid if interpreted as utf-8 + encoding system iso8859-1 + close [open \xe9 w] +} -cleanup { + encoding system $prevEnc + cd $prevDir + file delete -force $testDir +} -constraints {unix knownBug} -body { + set result [file exists [lindex [glob *] 0]] + encoding system utf-8 + lappend result [file exists [lindex [glob *] 0]] +} -result {1 1} apply [list {} { test fileName-6d4e9d1af5bf5b7d { diff --git a/tests/fileSystem.test b/tests/fileSystem.test index be17717..5f841b5 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -268,24 +268,23 @@ file delete -force [file join dir.dir dirinside.link] removeFile [file join dir.dir inside.file] removeDirectory [file join dir.dir dirinside.dir] removeDirectory dir.dir -test filesystem-1.30 {normalisation of nonexistent user} -body { +test filesystem-1.30 { + normalisation of nonexistent user - verify no tilde expansion +} -body { file normalize ~noonewiththisname -} -returnCodes error -result {user "noonewiththisname" doesn't exist} +} -result [file join [pwd] ~noonewiththisname] test filesystem-1.30.1 {normalisation of existing user} -body { - catch {file normalize ~$::tcl_platform(user)} -} -result {0} -test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body { - file normalize ~nonexistentuser@nonexistentdomain -} -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist} + file normalize ~$::tcl_platform(user) +} -result [file join [pwd] ~$::tcl_platform(user)] test filesystem-1.30.3 {file normalization should distinguish between ~ and ~user} -setup { set oldhome $::env(HOME) - set olduserhome [file normalize ~$::tcl_platform(user)] + set olduserhome [file home $::tcl_platform(user)] set ::env(HOME) [file join $oldhome temp] } -cleanup { set ::env(HOME) $oldhome } -body { - list [string equal [file normalize ~] $::env(HOME)] \ - [string equal $olduserhome [file normalize ~$::tcl_platform(user)]] + list [string equal [file home] $::env(HOME)] \ + [string equal $olduserhome [file home $::tcl_platform(user)]] } -result {1 1} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix @@ -484,7 +483,10 @@ test filesystem-4.3 {testfilesystem} -constraints testfilesystem -body { return $filesystemReport } -match glob -result {*{matchindirectory *}*} -test filesystem-5.1 {cache and ~} -constraints testfilesystem -setup { +# This test is meaningless if there is no tilde expansion +test filesystem-5.1 {cache and ~} -constraints { + testfilesystem tildeexpansion +} -setup { set orig $::env(HOME) } -body { set ::env(HOME) /foo/bar/blah @@ -950,7 +952,7 @@ test filesystem-9.7 {path objects and glob and file tail and tilde} -setup { cd [tcltest::temporaryDirectory] file delete -force tilde cd $origdir -} -result {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} +} -result {1 0 ~testNotExist ~testNotExist 1 0 ~testNotExist 0 ~testNotExist} test filesystem-9.8 {path objects and glob and file tail and tilde} -setup { set res {} set origdir [pwd] @@ -968,7 +970,7 @@ test filesystem-9.8 {path objects and glob and file tail and tilde} -setup { cd [tcltest::temporaryDirectory] file delete -force tilde cd $origdir -} -result {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} +} -result {~testNotExist ~testNotExist 0 ~testNotExist 0 ~testNotExist} test filesystem-9.9 {path objects and glob and file tail and tilde} -setup { set res {} set origdir [pwd] @@ -986,7 +988,7 @@ test filesystem-9.9 {path objects and glob and file tail and tilde} -setup { cd [tcltest::temporaryDirectory] file delete -force tilde cd $origdir -} -result {0 0 0 0 1} +} -result {0 1 0 1 1} # ---------------------------------------------------------------------- diff --git a/tests/get.test b/tests/get.test index 0281760..eff4fa0 100644 --- a/tests/get.test +++ b/tests/get.test @@ -99,25 +99,18 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} { } {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}} # Bug 7114ac6141 test get-3.3 {tcl_GetInt with iffy numbers} testgetint { - lmap x {0 " 0" "0 " " 0 " " 0xa " " 007 " " 0o10 " " 0b10 "} { + lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} { catch {testgetint 44 $x} x set x } -} {44 44 44 44 54 51 52 46} +} {44 44 44 44 54 54 52 46} -test get-3.4 {Tcl_GetDouble with iffy numbers} {testdoubleobj} { - lmap x {0 0.0 " .0" ".0 " " 0e0 " "- 0" "-0" "0o12" "0b10" "2_0.3_4e+1_5" _1.0e+2 1_.0e+2 1._0e+2 1.0_e+2 1.0e_+2 1.0e+_2 1.0e+2_ 1_1.0e+0_2 2__2.0e+2__2 54321________} { +test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj { + lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10" "2_0.3_4e+1_5" _1.0e+2 1_.0e+2 1._0e+2 1.0_e+2 1.0e_+2 1.0e+_2 1.0e+2_ 1_1.0e+0_2 2__2.0e+2__2 54321________} { catch {testdoubleobj set 1 $x} x set x } -} {0.0 0.0 0.0 0.0 0.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0 20340000000000000.0 {expected floating-point number but got "_1.0e+2"} {expected floating-point number but got "1_.0e+2"} {expected floating-point number but got "1._0e+2"} {expected floating-point number but got "1.0_e+2"} {expected floating-point number but got "1.0e_+2"} {expected floating-point number but got "1.0e+_2"} {expected floating-point number but got "1.0e+2_"} 1100.0 2.2e+23 {expected floating-point number but got "54321________"}} - -test get-3.4.1 {Tcl_GetDouble with iffy numbers} {testdoubleobj deprecated} { - lmap x {"09"} { - catch {testdoubleobj set 1 $x} x - set x - } -} {{expected floating-point number but got "09" (looks like invalid octal number)}} +} {0.0 0.0 0.0 0.0 0.0 9.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0 20340000000000000.0 {expected floating-point number but got "_1.0e+2"} {expected floating-point number but got "1_.0e+2"} {expected floating-point number but got "1._0e+2"} {expected floating-point number but got "1.0_e+2"} {expected floating-point number but got "1.0e_+2"} {expected floating-point number but got "1.0e+_2"} {expected floating-point number but got "1.0e+2_"} 1100.0 2.2e+23 {expected floating-point number but got "54321________"}} test get-3.5 {tcl_GetInt with numeric whitespace (i.e. '_')} testgetint { lmap x {0_0 " 1_0" "0_2 " " 3_3 " 14__23__32___4 " 0x0_a " 0b1111_1111 " 0_07 " " 0o1_0 " " 0b_1_0 " " 0_b1_0 " _33 42_ 0_x15 0_o17 0_d19 0x_b 0o_2_0 0o2__3_4} { diff --git a/tests/http.test b/tests/http.test index c77dceb..f7bb723 100644 --- a/tests/http.test +++ b/tests/http.test @@ -15,7 +15,6 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } -source [file join [file dirname [info script]] tcltests.tcl] package require http 2.10 #http::register http 80 ::socket @@ -739,8 +738,10 @@ test http-7.3.$ThreadLevel {http::formatQuery} -setup { } -cleanup { http::config -urlencoding $enc } -result {unknown encoding ""} -test http-7.4.$ThreadLevel {http::formatQuery} -constraints deprecated -setup { +test http-7.4.$ThreadLevel {http::formatQuery} -setup { set enc [http::config -urlencoding] +} -constraints { + knownProfileBug } -body { # this would be reverting to http <=2.4 behavior w/o errors # with Tcl 8.x (unknown chars become '?'), generating a @@ -749,7 +750,7 @@ test http-7.4.$ThreadLevel {http::formatQuery} -constraints deprecated -setup { http::mapReply "∈" } -cleanup { http::config -urlencoding $enc -} -result {%3F} +} -errorCode {TCL ENCODING ILLEGALSEQUENCE 0} -result {unexpected character at index 0: 'U+002208'} package require tcl::idna 1.0 diff --git a/tests/indexObj.test b/tests/indexObj.test index 1cf782a..f157637 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -19,6 +19,8 @@ catch [list package require -exact tcl::test [info patchlevel]] testConstraint testindexobj [llength [info commands testindexobj]] testConstraint testgetintforindex [llength [info commands testgetintforindex]] testConstraint testparseargs [llength [info commands testparseargs]] +testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}] +testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}] test indexObj-1.1 {exact match} testindexobj { testindexobj 1 1 xyz abc def xyz alm @@ -184,7 +186,7 @@ test indexObj-8.4 {Tcl_GetIntForIndex INT_MAX} testgetintforindex { } 2147483647 test indexObj-8.5 {Tcl_GetIntForIndex INT_MAX+1} testgetintforindex { testgetintforindex 2147483648 0 -} 2147483647 +} [expr {[testConstraint has64BitLengths] ? 2147483648 : 2147483647}] test indexObj-8.6 {Tcl_GetIntForIndex end-1} testgetintforindex { testgetintforindex end-1 2147483646 } 2147483645 @@ -209,18 +211,19 @@ test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex { test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex { testgetintforindex end -2 } -2 -test indexObj-8.14 {Tcl_GetIntForIndex end+1} testgetintforindex { +test indexObj-8.14 {Tcl_GetIntForIndex end+1} -constraints { + testgetintforindex has64BitLengths +} -body { testgetintforindex end+1 -1 -} 2147483647 +} -result 9223372036854775807 +test indexObj-8.14.32bits {Tcl_GetIntForIndex end+1} -constraints { + testgetintforindex has32BitLengths +} -body { + testgetintforindex end+1 -1 +} -result 2147483647 test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex { testgetintforindex end+1 -2 } -1 -test indexObj-8.16 {Tcl_GetIntForIndex integer} testgetintforindex { - testgetintforindex -1 -1 -} -2147483648 -test indexObj-8.17 {Tcl_GetIntForIndex integer} testgetintforindex { - testgetintforindex -2 -1 -} -2147483648 # cleanup ::tcltest::cleanupTests diff --git a/tests/info.test b/tests/info.test index ef41bdf..6c49b2d 100644 --- a/tests/info.test +++ b/tests/info.test @@ -20,9 +20,9 @@ if {{::tcltest} ni [namespace children]} { namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -source [file join [file dirname [info script]] tcltests.tcl] catch [list package require -exact tcl::test [info patchlevel]] testConstraint zlib [llength [info commands zlib]] + # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. @@ -101,10 +101,10 @@ test info-2.5 {info body option, returning bytecompiled bodies} -body { # Fix for problem tested for in info-2.5 caused problems when # procedure body had no string rep (i.e. was not yet bytecode) # causing an empty string to be returned [Bug #545644] -test info-2.6 {info body option, returning list bodies} deprecated { +test info-2.6 {info body option, returning list bodies} { proc foo args [list subst bar] - list [string bytelength [info body foo]] \ - [foo; string bytelength [info body foo]] + list [string length [info body foo]] \ + [foo; string length [info body foo]] } {9 9} proc testinfocmdcount {} { @@ -678,16 +678,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp -} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c -} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l -} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s -} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### diff --git a/tests/interp.test b/tests/interp.test index fa263e2..30570bb 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -2414,21 +2414,21 @@ test interp-29.1.4 {interp recursionlimit argument checking} { interp delete moo list $result $msg } {1 {expected integer but got "bar"}} -test interp-29.1.5 {interp recursionlimit argument checking} { +test interp-29.1.5 {interp recursionlimit argument checking} -body { interp create moo set result [catch {interp recursionlimit moo 0} msg] interp delete moo list $result $msg -} {1 {recursion limit must be > 0}} -test interp-29.1.6 {interp recursionlimit argument checking} { +} -match glob -result {1 {recursion limit must be > 0}} +test interp-29.1.6 {interp recursionlimit argument checking} -body { interp create moo set result [catch {interp recursionlimit moo -1} msg] interp delete moo list $result $msg -} {1 {recursion limit must be > 0}} +} -match glob -result {1 {recursion limit must be > 0}} test interp-29.1.7 {interp recursionlimit argument checking} { interp create moo - set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg] + set result [catch {interp recursionlimit moo [expr {wide(1)<<64}]} msg] interp delete moo list $result [string range $msg 0 35] } {1 {integer value too large to represent}} @@ -2444,21 +2444,21 @@ test interp-29.1.9 {child recursionlimit argument checking} { interp delete moo list $result $msg } {1 {expected integer but got "foo"}} -test interp-29.1.10 {child recursionlimit argument checking} { +test interp-29.1.10 {child recursionlimit argument checking} -body { interp create moo set result [catch {moo recursionlimit 0} msg] interp delete moo list $result $msg -} {1 {recursion limit must be > 0}} -test interp-29.1.11 {child recursionlimit argument checking} { +} -match glob -result {1 {recursion limit must be > 0}} +test interp-29.1.11 {child recursionlimit argument checking} -body { interp create moo set result [catch {moo recursionlimit -1} msg] interp delete moo list $result $msg -} {1 {recursion limit must be > 0}} +} -match glob -result {1 {recursion limit must be > 0}} test interp-29.1.12 {child recursionlimit argument checking} { interp create moo - set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg] + set result [catch {moo recursionlimit [expr {wide(1)<<64}]} msg] interp delete moo list $result [string range $msg 0 35] } {1 {integer value too large to represent}} @@ -3339,7 +3339,7 @@ test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { interp delete $i lappend result $msg } -result {1 {time limit exceeded}} -test interp-34.11 {time limit extension in callbacks} -setup { +test interp-34.11 {time limit extension in callbacks} -constraints knownBug -setup { proc cb1 {i t} { global result lappend result cb1 @@ -3524,7 +3524,7 @@ test interp-35.19 {interp limit syntax} -body { interp limit $i time -seconds -1 } -cleanup { interp delete $i -} -match glob -returnCodes error -result {seconds must be between 0 and *} +} -returnCodes error -result {seconds must be non-negative} test interp-35.20 {interp limit syntax} -body { set i [interp create] interp limit $i time -millis foobar @@ -3536,7 +3536,7 @@ test interp-35.21 {interp limit syntax} -body { interp limit $i time -millis -1 } -cleanup { interp delete $i -} -match glob -returnCodes error -result {milliseconds must be between 0 and *} +} -returnCodes error -result {milliseconds must be non-negative} test interp-35.22 {interp time limits normalize milliseconds} -body { set i [interp create] interp limit $i time -seconds 1 -millis 1500 diff --git a/tests/io.test b/tests/io.test index 00ae8f86..86a871b 100644 --- a/tests/io.test +++ b/tests/io.test @@ -36,6 +36,7 @@ namespace eval ::tcl::test::io { } source [file join [file dirname [info script]] tcltests.tcl] +testConstraint pointerIs64bit [expr {$::tcl_platform(pointerSize) >= 8}] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] testConstraint testfevent [llength [info commands testfevent]] @@ -79,7 +80,7 @@ set path(cat) [makeFile { if {$argv != ""} { set f [open [lindex $argv 0]] } - fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar "\x1A \x1A" + fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A fconfigure stdout -encoding binary -translation lf -buffering none fileevent $f readable "foo $f" proc foo {f} { @@ -196,6 +197,51 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { set sizes } {19 19 19 19 19} +proc testreadwrite {size {mode ""} args} { + set tmpfile [file join [temporaryDirectory] io-1.10.tmp] + set w [string repeat A $size] + try { + set fd [open $tmpfile w$mode] + try { + if {[llength $args]} { + fconfigure $fd {*}$args + } + puts -nonewline $fd $w + } finally { + close $fd + } + set fd [open $tmpfile r$mode] + try { + if {[llength $args]} { + fconfigure $fd {*}$args + } + set r [read $fd] + } finally { + close $fd + } + } finally { + file delete $tmpfile + } + string equal $w $r +} + +test io-1.10 {WriteChars: large file (> INT_MAX). Bug 3d01d51bc4} -constraints { + pointerIs64bit perf +} -body { + testreadwrite 0x80000000 +} -result 1 +test io-1.11 {WriteChars: large file (> UINT_MAX). Bug 3d01d51bc4} -constraints { + pointerIs64bit perf +} -body { + testreadwrite 0x100000000 "" -buffersize 1000000 +} -result 1 +test io-1.12 {WriteChars: large file (== UINT_MAX). Bug 90ff9b7f73} -constraints { + pointerIs64bit perf +} -body { + # *Exactly* UINT_MAX - separate bug from the general large file tests + testreadwrite 0xffffffff +} -result 1 + test io-2.1 {WriteBytes} { # loop until all bytes are written @@ -237,6 +283,25 @@ test io-2.4 {WriteBytes: reset sawLF after each buffer} { close $f lappend x [contents $path(test1)] } [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] +test io-2.5 {WriteBytes: large file (> INT_MAX). Bug 3d01d51bc4} -constraints { + pointerIs64bit perf +} -body { + # Binary mode + testreadwrite 0x80000000 b +} -result 1 +test io-2.6 {WriteBytes: large file (> UINT_MAX). Bug 3d01d51bc4} -constraints { + pointerIs64bit perf +} -body { + # Binary mode + testreadwrite 0x100000000 b -buffersize 1000000 +} -result 1 +test io-2.7 {WriteBytes: large file (== UINT_MAX). Bug 90ff9b7f73} -constraints { + pointerIs64bit perf +} -body { + # *Exactly* UINT_MAX - separate bug from the general large file tests + testreadwrite 0xffffffff b +} -result 1 + test io-3.1 {WriteChars: compatibility with WriteBytes} { # loop until all bytes are written @@ -519,7 +584,7 @@ test io-6.8 {Tcl_GetsObj: remember if EOF is seen} { puts $f "abcdef\x1Aghijk\nwombat" close $f set f [open $path(test1)] - fconfigure $f -eofchar "\x1A \x1A" + fconfigure $f -eofchar \x1A set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -529,7 +594,7 @@ test io-6.9 {Tcl_GetsObj: remember if EOF is seen} { puts $f "abcdefghijk\nwom\x1Abat" close $f set f [open $path(test1)] - fconfigure $f -eofchar "\x1A \x1A" + fconfigure $f -eofchar \x1A set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -1038,7 +1103,7 @@ test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { puts -nonewline $f "123456\x1Ak9012345\r" close $f set f [open $path(test1)] - fconfigure $f -eofchar "\x1A \x1A" + fconfigure $f -eofchar \x1A set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] close $f set x @@ -1582,7 +1647,7 @@ test io-12.11 {ReadChars: multibyte chars split} -body { puts -nonewline $f [string repeat a 9]\xC2 close $f set f [open $path(test1)] - fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 11 + fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 10 set in [read $f] close $f scan [string index $in end] %c @@ -2109,13 +2174,13 @@ test io-20.2 {Tcl_CreateChannel: initial settings} {win} { set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] close $f set x -} [list [list \x1A ""] {auto crlf}] +} {{} {auto crlf}} test io-20.3 {Tcl_CreateChannel: initial settings} {unix} { set f [open $path(test1) w+] set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] close $f set x -} {{{} {}} {auto lf}} +} {{} {auto lf}} set path(stdout) [makeFile {} stdout] test io-20.5 {Tcl_CreateChannel: install channel in empty slot} stdio { set f [open $path(script) w] @@ -3398,7 +3463,7 @@ test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { puts -nonewline $f hello\nthere\nand\rhere\n\x1A close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set c [read $f] close $f set c @@ -3410,11 +3475,11 @@ here test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set c [read $f] close $f set c @@ -3431,7 +3496,7 @@ test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3451,7 +3516,7 @@ test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3529,7 +3594,7 @@ test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3543,7 +3608,7 @@ test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3557,7 +3622,7 @@ test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3571,7 +3636,7 @@ test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3585,7 +3650,7 @@ test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3599,7 +3664,7 @@ test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3932,7 +3997,7 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3947,11 +4012,11 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3971,7 +4036,7 @@ test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3989,7 +4054,7 @@ test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -4073,7 +4138,7 @@ test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -4091,7 +4156,7 @@ test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -4109,7 +4174,7 @@ test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -4127,7 +4192,7 @@ test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -4145,7 +4210,7 @@ test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -4163,7 +4228,7 @@ test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -5044,87 +5109,87 @@ test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} stdio { test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f list $s $l $e -} {9 8 1} +} {8 8 1} test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f list $s $l $e -} {9 8 1} +} {8 8 1} test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f list $s $l $e -} {9 8 1} +} {8 8 1} test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f list $s $l $e -} {9 8 1} +} {8 8 1} test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f list $s $l $e -} {11 8 1} +} {10 8 1} test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f list $s $l $e -} {11 8 1} +} {10 8 1} test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { file delete $path(test1) set f [open $path(test1) w] @@ -5134,7 +5199,7 @@ test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5149,7 +5214,7 @@ test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5164,7 +5229,7 @@ test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5179,7 +5244,7 @@ test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5194,7 +5259,7 @@ test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5209,7 +5274,7 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5232,31 +5297,31 @@ test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body { test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l [string length [set in [read $f]]] set e [eof $f] close $f list $s $l $e [scan [string index $in end] %c] -} -result {9 8 1 13} +} -result {8 8 1 13} test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A puts $f {} close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l [string length [set in [read $f]]] set e [eof $f] close $f list $s $l $e [scan [string index $in end] %c] -} -result {2 1 1 13} +} -result {1 1 1 13} test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] @@ -5280,7 +5345,7 @@ test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5295,7 +5360,7 @@ test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5779,30 +5844,30 @@ test io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ close $s2 set modes } {auto crlf} -test io-39.22 {Tcl_SetChannelOption, invariance} -constraints {unix} -body { +test io-39.22 {Tcl_SetChannelOption, invariance} -constraints {unix deprecated} -body { file delete $path(test1) set f1 [open $path(test1) w+] set l "" lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar {ON GO} + fconfigure $f1 -eofchar {O {}} lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar {D D} + fconfigure $f1 -eofchar D lappend l [fconfigure $f1 -eofchar] close $f1 set l -} -result {{{} {}} {O G} {D D}} -test io-39.22a {Tcl_SetChannelOption, invariance} -body { +} -result {{} O D} +test io-39.22a {Tcl_SetChannelOption, invariance} -constraints deprecated -body { file delete $path(test1) set f1 [open $path(test1) w+] set l [list] - fconfigure $f1 -eofchar {ON GO} + fconfigure $f1 -eofchar {O {}} lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar {D D} + fconfigure $f1 -eofchar D lappend l [fconfigure $f1 -eofchar] lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg] close $f1 set l -} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} +} -result {O D {1 {bad value for -eofchar: must be non-NUL ASCII character}}} test io-39.23 {Tcl_GetChannelOption, server socket is not readable or writable, it should still have valid -eofchar and -translation options } { set l [list] @@ -5810,7 +5875,7 @@ test io-39.23 {Tcl_GetChannelOption, server socket is not readable or lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation] close $sock set l -} {{{}} auto} +} {{} auto} test io-39.24 {Tcl_SetChannelOption, server socket is not readable or writable so we can't change -eofchar or -translation } { set l [list] @@ -5819,7 +5884,7 @@ test io-39.24 {Tcl_SetChannelOption, server socket is not readable or lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation] close $sock set l -} {{{}} auto} +} {{} auto} test io-40.1 {POSIX open access modes: RDWR} { file delete $path(test3) @@ -5988,7 +6053,7 @@ test io-40.17 {tilde substitution in open} { set x [list [catch {open ~/foo} msg] $msg] set ::env(HOME) $home set x -} {1 {couldn't find HOME environment variable to expand path}} +} {1 {couldn't open "~/foo": no such file or directory}} test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} { list [catch {fileevent foo} msg] $msg @@ -6562,7 +6627,7 @@ test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6590,7 +6655,7 @@ test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6618,7 +6683,7 @@ test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6646,7 +6711,7 @@ test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6674,7 +6739,7 @@ test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} { set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6702,7 +6767,7 @@ test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6730,7 +6795,7 @@ test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6758,7 +6823,7 @@ test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fil set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6786,7 +6851,7 @@ test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6814,7 +6879,7 @@ test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fil set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6842,7 +6907,7 @@ test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {f set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6870,7 +6935,7 @@ test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -7449,10 +7514,7 @@ test io-52.9 {TclCopyChannel & encodings} {fcopy} { [file size $path(utf8-fcopy.txt)] \ [file size $path(utf8-rp.txt)] } {3 5 5} -test io-52.10 {TclCopyChannel & encodings} -constraints {fcopy notWinCI} -body { - # encoding to binary (=> implies that the - # internal utf-8 is written) - +test io-52.10 {TclCopyChannel & encodings} -constraints fcopy -body { set in [open $path(kyrillic.txt) r] set out [open $path(utf8-fcopy.txt) w] @@ -7466,29 +7528,31 @@ test io-52.10 {TclCopyChannel & encodings} -constraints {fcopy notWinCI} -body { } -cleanup { close $in close $out -} -result 5 +} -returnCodes 1 -match glob -result {error writing "*":\ + invalid or incomplete multibyte or wide character} test io-52.11 {TclCopyChannel & encodings} -setup { set out [open $path(utf8-fcopy.txt) w] - fconfigure $out -encoding utf-8 -translation lf - puts $out "АА" + fconfigure $out -encoding utf-8 -translation lf -profile strict + puts $out АА close $out } -constraints {fcopy} -body { - # binary to encoding => the input has to be - # in utf-8 to make sense to the encoder - set in [open $path(utf8-fcopy.txt) r] set out [open $path(kyrillic.txt) w] - # -translation binary is also -encoding binary fconfigure $in -translation binary - fconfigure $out -encoding koi8-r -translation lf - - fcopy $in $out - close $in - close $out - - file size $path(kyrillic.txt) -} -result 3 + fconfigure $out -encoding koi8-r -translation lf -profile strict + catch {fcopy $in $out} cres copts + return $cres +} -cleanup { + if {$in in [chan names]} { + close $in + } + if {$out in [chan names]} { + close $out + } + catch {unset cres} +} -match glob -result {error writing "*": invalid or incomplete\ + multibyte or wide character} test io-52.12 {coverage of -translation auto} { file delete $path(test1) $path(test2) @@ -7783,6 +7847,29 @@ test io-52.23 {TclCopyChannel & encodings} -setup { unset ::s0 } -match glob -result {0 {error writing "file*": invalid or incomplete multibyte or wide character}} +test io-52.24 {fcopy -size should always be characters} -setup { + set out [open utf8-fcopy-52.24.txt w] + fconfigure $out -encoding utf-8 -translation lf + puts $out "Á" + close $out +} -constraints {fcopy} -body { + set in [open utf8-fcopy-52.24.txt r] + set out [open utf8-fcopy-52.24.out.txt w+] + + fconfigure $in -encoding utf-8 -profile tcl8 + fconfigure $out -encoding utf-8 -profile tcl8 + fcopy $in $out -size 1 + seek $out 0 + # a result of \xc3 means that only the first byte of the utf-8 encoding of + # Á made it into to the output file. + read $out +} -cleanup { + close $in + close $out + catch {file delete utf8-fcopy-52.24.txt} + catch {file delete utf8-fcopy-52.24.out.txt} +} -result Á + test io-53.1 {CopyData} {fcopy} { file delete $path(test1) set f1 [open $thisScript] @@ -9445,10 +9532,11 @@ test io-75.9 {unrepresentable character write throws error in strict profile} -s } -match glob -result [list {A} {error writing "*":\ invalid or incomplete multibyte or wide character}] -# Incomplete sequence test. -# This error may IMHO only be detected with the close. -# But the read already returns the incomplete sequence. -test io-75.10 {incomplete multibyte encoding read is ignored} -setup { +test io-75.10 { + incomplete multibyte encoding read is not ignored because "binary" sets + profile to strict +} -setup { + set res {} set fn [makeFile {} io-75.10] set f [open $fn w+] fconfigure $f -encoding binary @@ -9457,14 +9545,21 @@ test io-75.10 {incomplete multibyte encoding read is ignored} -setup { seek $f 0 fconfigure $f -encoding utf-8 -buffering none } -body { + catch {read $f} errmsg + lappend res $errmsg + seek $f 0 + chan configure $f -profile tcl8 set d [read $f] binary scan $d H* hd - set hd + lappend res $hd + return $res } -cleanup { close $f removeFile io-75.10 - unset d hd -} -result 41c0 + unset result +} -match glob -result {{error reading "file*":\ + invalid or incomplete multibyte or wide character} 41c0} + # The current result returns the orphan byte as byte. # This may be expected due to special utf-8 handling. @@ -9492,7 +9587,11 @@ test io-75.11 {shiftjis encoding error read results in error (strict profile)} - } -match glob -result {41 1 {error reading "file*":\ invalid or incomplete multibyte or wide character} 0} -test io-75.12 {invalid utf-8 encoding read is ignored} -setup { +test io-75.12 { + invalid utf-8 encoding read is not ignored because setting the encoding to + "binary" also set the profile to strict +} -setup { + set res {} set fn [makeFile {} io-75.12] set f [open $fn w+] fconfigure $f -encoding binary @@ -9501,13 +9600,20 @@ test io-75.12 {invalid utf-8 encoding read is ignored} -setup { seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf } -body { + catch {read $f} errmsg + lappend res $errmsg + chan configure $f -profile tcl8 + seek $f 0 set d [read $f] binary scan $d H* hd - set hd + lappend res $hd + return $res } -cleanup { close $f removeFile io-75.12 -} -result 4181 + unset res +} -match glob -result {{error reading "file*":\ + invalid or incomplete multibyte or wide character} 4181} test io-75.13 { In nonblocking mode when there is an encoding error the data that has been successfully read so far is returned first and then the error is returned @@ -9718,8 +9824,41 @@ test io-76.10 {channel mode dropping} -setup { } -match glob -result {Tcl_RemoveChannelMode error:\ Bad mode, would make channel inacessible. Channel: "*"} +# Encoding errors on pipeline +# Ensures fix for exec bug [0f1ddc0df7] does not affect open +# It should still fail unless -profile is explicitly set to replace +test io-77.1 {open pipe encoding mismatch} -setup { + set scriptFile [makeFile { + fconfigure stdout -translation binary + puts -nonewline a\xe9b + flush stdout + } script] +} -cleanup { + close $fd + removeFile $scriptFile +} -body { + set fd [open |[list [info nameofexecutable] $scriptFile r+]] + fconfigure $fd -encoding utf-8 + list [catch {read $fd} result opts] [string match {error reading "*": invalid or incomplete multibyte or wide character} $result] [dict get $opts -errorcode] +} -result [list 1 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}] +test io-77.2 {open pipe encoding mismatch - use replace profile} -setup { + set scriptFile [makeFile { + fconfigure stdout -translation binary + puts -nonewline a\xe9b + flush stdout + } script] +} -cleanup { + close $fd + removeFile $scriptFile +} -body { + set fd [open |[list [info nameofexecutable] $scriptFile r+]] + fconfigure $fd -encoding utf-8 -profile replace + read $fd +} -result a\uFFFDb + + # cleanup -foreach file [list fooBar longfile script script2 output test1 pipe my_script \ +foreach file [list fooBar longfile script2 output test1 pipe my_script \ test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { removeFile $file } diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 2b9aed6..94129a2 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -241,11 +241,11 @@ test iocmd-8.7 {fconfigure command} -setup { file delete $path(test1) } -body { set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} -encoding utf-16 -profile tcl8 + fconfigure $f1 -translation lf -eofchar {} -encoding utf-16 fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -profile tcl8 -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -profile strict -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -263,11 +263,11 @@ test iocmd-8.9 {fconfigure command} -setup { } -body { set f1 [open $path(test1) w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ - -eofchar {} -encoding binary -profile tcl8 + -eofchar {} -encoding binary fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -profile tcl8 -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding iso8859-1 -eofchar {} -profile strict -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -369,27 +369,6 @@ test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPort } -returnCodes error -result [expectedOpts "-blah" {-inputmode}] # TODO: Test parsing of serial channel options (nonPortable, since requires an # open channel to work with). -test iocmd-8.21 {fconfigure command / -nocomplainencoding 0 error} -constraints { - deprecated obsolete -} -setup { - # I don't know how else to open the console, but this is non-portable - set console stdin -} -body { - fconfigure $console -nocomplainencoding 0 -} -returnCodes error -result "bad value for -nocomplainencoding: only true allowed" -test iocmd-8.22 {fconfigure command / -nocomplainencoding 0, no error if -strictencoding already defined} -setup { - set console stdin - set oldprofile [fconfigure $console -profile] -} -constraints { - obsolete -} -body { - fconfigure $console -strictencoding 1 - fconfigure $console -nocomplainencoding 0 - fconfigure $console -nocomplainencoding -} -cleanup { - fconfigure $console -strictencoding $oldmode -} -result 0 - test iocmd-8.23 {fconfigure -profile badprofile} -body { fconfigure stdin -profile froboz @@ -517,9 +496,16 @@ test iocmd-12.10 {POSIX open access modes: BINARY} { close $f set result } 5 -test iocmd-12.11 {POSIX open access modes: BINARY} { +test iocmd-12.11 {POSIX open access modes: BINARY} -body { + after 100 set f [open $path(test1) {WRONLY BINARY TRUNC}] - puts $f Ɉ ;# gets truncated to H + puts $f Ɉ ;# throws an exception +} -cleanup { + close $f +} -returnCodes 1 -match glob -result {error writing "*": invalid or incomplete multibyte or wide character} +test iocmd-12.12 {POSIX open access modes: BINARY} { + set f [open $path(test1) {WRONLY BINARY TRUNC}] + puts $f H close $f set f [open $path(test1) r] fconfigure $f -translation binary @@ -1403,34 +1389,34 @@ test iocmd-24.15 {chan write, EAGAIN means that writing is not allowed at this t test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { set res {} - proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} + proc foo args {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] note [fconfigure $c] close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -profile * -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} - proc foo {args} {oninit cget cgetall; onfinal; track; return ""} + proc foo args {oninit cget cgetall; onfinal; track; return ""} set c [chan create {r w} foo] note [fconfigure $c] close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -profile * -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} - proc foo {args} { + proc foo args { oninit cget cgetall; onfinal; track - return "-bar foo -snarf x" + return {-bar foo -snarf x} } set c [chan create {r w} foo] note [fconfigure $c] close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -profile * -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { @@ -2951,7 +2937,7 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body rename foo {} set res } -constraints {testchannel thread} \ - -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}} + -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} * -translation {auto *}}} test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -2964,7 +2950,7 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { rename foo {} set res } -constraints {testchannel thread} \ - -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}} + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} * -translation {auto *}}} test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -2980,7 +2966,7 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { rename foo {} set res } -constraints {testchannel thread} \ - -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *} -bar foo -snarf x}} + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} * -translation {auto *} -bar foo -snarf x}} test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/iogt.test b/tests/iogt.test index 5692682..cb02d40 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -549,8 +549,8 @@ test iogt-2.3 {basic I/O, mixed trail} {testchannel unix} { set trail [list] audit_flow trail -attach $fin audit_flow trail -attach $fout - fconfigure $fin -buffersize 20 - fconfigure $fout -buffersize 10 + fconfigure $fin -buffersize 20 -profile tcl8 + fconfigure $fout -buffersize 10 -profile tcl8 fcopy $fin $fout close $fin close $fout diff --git a/tests/lindex.test b/tests/lindex.test index ffe0d9e..17a9ed2 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -70,11 +70,11 @@ test lindex-3.4 {integer 3} -constraints testevalex -body { test lindex-3.5 {bad octal} -constraints testevalex -body { set x 0o8 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-3.6 {bad octal} -constraints testevalex -body { set x -0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-3.7 {indexes don't shimmer wide ints} -body { set x [expr {(wide(1)<<31) - 2}] list $x [lindex {1 2 3} $x] [incr x] [incr x] @@ -114,11 +114,11 @@ test lindex-4.5 {index = end-3} testevalex { test lindex-4.6 {bad octal} -constraints testevalex -body { set x end-0o8 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-4.7 {bad octal} -constraints testevalex -body { set x end--0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-4.8 {bad integer, not octal} testevalex { set x end-0a2 list [catch { testevalex {lindex {a b c} $x} } result] $result @@ -274,11 +274,11 @@ test lindex-11.4 {integer 3} { test lindex-11.5 {bad octal} -body { set x 0o8 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-11.6 {bad octal} -body { set x -0o9 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} # Indices relative to end @@ -320,11 +320,11 @@ test lindex-12.5 {index = end-3} { test lindex-12.6 {bad octal} -body { set x end-0o8 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-12.7 {bad octal} -body { set x end--0o9 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-12.8 {bad integer, not octal} { set x end-0a2 list [catch { lindex {a b c} $x } result] $result diff --git a/tests/listObj.test b/tests/listObj.test index 55fc089..249d446 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -22,6 +22,9 @@ catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] testConstraint memory [llength [info commands memory]] +set INT_MAX 0x7fffffff; # Assumes sizeof(int) == 4 +set SIZE_MAX [expr {(1 << (8*$::tcl_platform(pointerSize) - 1)) - 1}] + catch {unset x} test listobj-1.1 {Tcl_GetListObjType} emptyTest { # Test removed; tested an internal detail @@ -206,10 +209,25 @@ test listobj-10.3 {Tcl_ListObjReplace with negative count value} testobj { testlistobj replace 1 1 -1 f testlistobj get 1 } {a f b c d e} +test listobj-10.4 {Tcl_ListObjReplace with $SIZE_MAX count value} testobj { + testlistobj set 1 a b c d e + testlistobj replace 1 1 $SIZE_MAX f + testlistobj get 1 +} {a f} +test listobj-10.5 {Tcl_ListObjReplace with SIZE_MAX-1 count value} testobj { + testlistobj set 1 a b c d e + testlistobj replace 1 1 [expr {$SIZE_MAX -1}] f + testlistobj get 1 +} {a f} test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj { testobj bug3598580 } 123 +test listobj-11.2 {Bug e58d7e19e9: Upwards compatibility of TclObjTypeHasProc()} testobj { + set l [testobj buge58d7e19e9 "a x c"] + # Since $l is a V1 objType, it's lengthProc will be accessed, but not its indexProc. + list [llength $l] [lindex $l 2] +} {100 c} # Stolen from dict.test proc listobjmemcheck script { @@ -301,9 +319,7 @@ test listobj-14.2 {Tcl_ListObjIndex out-of-bounds index for native lists with sp list [testlistobj index 1 -1] [testlistobj index 1 1000] } -result {null null} -test listobj-14.3 {Tcl_ListObjIndex out-of-bounds index for lseq} -constraints { - testobj -} -setup { +test listobj-14.3 {Tcl_ListObjIndex out-of-bounds index for lseq} -constraints {bug-30e4e9102f testobj} -setup { testobj set 1 [lseq 3] } -cleanup { testobj freeallvars diff --git a/tests/listRep.test b/tests/listRep.test index 02ff18f..11af9ad 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -221,7 +221,7 @@ test listrep-1.2 { set l [linsert [freeSpaceNone] $end 99] validate $l list $l [leadSpace $l] [tailSpace $l] -} -result [list {0 1 2 3 4 5 6 7 99} 0 9] +} -result [list {0 1 2 3 4 5 6 7 99} 0 4] test listrep-1.2.1 { Inserts at back of unshared list with no free space should allocate all @@ -231,7 +231,7 @@ test listrep-1.2.1 { lset l $end+1 99 validate $l list $l [leadSpace $l] [tailSpace $l] -} -result [list {0 1 2 3 4 5 6 7 99} 0 9] +} -result [list {0 1 2 3 4 5 6 7 99} 0 4] test listrep-1.2.2 { Inserts at back of unshared list with no free space should allocate all @@ -241,7 +241,7 @@ test listrep-1.2.2 { lappend l 99 validate $l list $l [leadSpace $l] [tailSpace $l] -} -result [list {0 1 2 3 4 5 6 7 99} 0 9] +} -result [list {0 1 2 3 4 5 6 7 99} 0 4] test listrep-1.3 { Inserts in middle of unshared list with no free space should reallocate with @@ -1160,7 +1160,7 @@ test listrep-3.3 { set l [linsert [freeSpaceBoth 8 1 1] $zero -3 -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list [irange -3 7] 6 5 1] +} -result [list [irange -3 7] 3 2 1] test listrep-3.3.1 { Inserts in front of unshared spanned list with insufficient total freespace @@ -1169,7 +1169,7 @@ test listrep-3.3.1 { set l [lreplace [freeSpaceBoth 8 1 1] $zero -1 -3 -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list [irange -3 7] 6 5 1] +} -result [list [irange -3 7] 3 2 1] test listrep-3.4 { Inserts at back of unshared spanned list with room at back should not @@ -1255,7 +1255,7 @@ test listrep-3.6 { set l [linsert [freeSpaceBoth 8 1 1] $end 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list [irange 0 10] 1 10 1] +} -result [list [irange 0 10] 1 4 1] test listrep-3.6.1 { Inserts in back of unshared spanned list with insufficient total freespace @@ -1265,7 +1265,7 @@ test listrep-3.6.1 { set l [lreplace [freeSpaceBoth 8 1 1] $end+1 $end+1 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list [irange 0 10] 1 10 1] +} -result [list [irange 0 10] 1 4 1] test listrep-3.6.2 { Inserts in back of unshared spanned list with insufficient total freespace @@ -1276,7 +1276,7 @@ test listrep-3.6.2 { lappend l 8 9 10 validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list [irange 0 10] 1 10 1] +} -result [list [irange 0 10] 1 4 1] test listrep-3.6.3 { Inserts in back of unshared spanned list with insufficient total freespace @@ -1287,7 +1287,7 @@ test listrep-3.6.3 { lset l $end+1 8 validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list [irange 0 8] 0 9 1] +} -result [list [irange 0 8] 0 4 1] test listrep-3.7 { Inserts in front half of unshared spanned list with room in front should not @@ -1341,7 +1341,7 @@ test listrep-3.10 { set l [linsert [freeSpaceBoth 8 1 1] $one -3 -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1] +} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 4 1] test listrep-3.10.1 { Inserts in front half of unshared spanned list with insufficient total space. @@ -1350,7 +1350,7 @@ test listrep-3.10.1 { set l [lreplace [freeSpaceBoth 8 1 1] $one -1 -3 -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1] +} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 4 1] test listrep-3.11 { Inserts in back half of unshared spanned list with room in back should not @@ -1414,7 +1414,7 @@ test listrep-3.14 { set l [linsert [freeSpaceBoth 8 1 1] $end-$one 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1] +} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 4 1] test listrep-3.14.1 { Inserts in back half of unshared spanned list with insufficient @@ -1424,7 +1424,7 @@ test listrep-3.14.1 { set l [lreplace [freeSpaceBoth 8 1 1] $end -1 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1] +} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 4 1] test listrep-3.15 { Deletes from front of small unshared span list results in elements @@ -1714,7 +1714,7 @@ test listrep-3.27 { set l [lreplace [freeSpaceBoth 8 1 1] $zero $one 10 11 12 13 14] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list {10 11 12 13 14 2 3 4 5 6 7} 6 5 1] +} -result [list {10 11 12 13 14 2 3 4 5 6 7} 3 2 1] test listrep-3.28 { Replacement of elements at back with same number of elements in unshared @@ -1770,7 +1770,7 @@ test listrep-3.32 { set l [lreplace [freeSpaceBoth 8 1 1] $end-1 $end 10 11 12 13 14] validate $l list $l [leadSpace $l] [tailSpace $l] -} -result [list {0 1 2 3 4 5 10 11 12 13 14} 1 10] +} -result [list {0 1 2 3 4 5 10 11 12 13 14} 1 4] test listrep-3.33 { Replacement of elements in the middle in an unshared spanned list with @@ -1864,7 +1864,7 @@ test listrep-3.41 { set l [lreplace [freeSpaceBoth 8 1 1] $one $one 8 9 10 11 12] validate $l list $l [leadSpace $l] [tailSpace $l] -} -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 11] +} -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 5] # # 4.* - tests on shared spanned lists diff --git a/tests/load.test b/tests/load.test index be5b1c1..77a6dec 100644 --- a/tests/load.test +++ b/tests/load.test @@ -25,7 +25,7 @@ if {![info exists ext]} { } # Tests require the existence of one of the DLLs in the dltest directory. set testDir [file join [file dirname [info nameofexecutable]] dltest] -set x [file join $testDir pkga$ext] +set x [file join $testDir tcl9pkga$ext] set dll "[file tail $x]Required" testConstraint $dll [file readable $x] @@ -70,31 +70,31 @@ test load-1.8 {basic errors} -returnCodes error -body { load -global } -result {couldn't figure out prefix for -global} -test load-2.1 {basic loading, with guess for package name} -constraints \ - [list $dll $loaded deprecated] -body { - load -global [file join $testDir pkga$ext] +test load-2.1 {basic loading, with guess for package name} \ + [list $dll $loaded] { + load -global [file join $testDir tcl9pkga$ext] list [pkga_eq abc def] [lsort [info commands pkga_*]] -} -result {0 {pkga_eq pkga_quote}} +} {0 {pkga_eq pkga_quote}} interp create -safe child test load-2.2 {loading into a safe interpreter, with package name conversion} \ [list $dll $loaded] { - load -lazy [file join $testDir pkgb$ext] Pkgb child + load -lazy [file join $testDir tcl9pkgb$ext] Pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \ -body { - list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode + list [catch {load [file join $testDir tcl9pkgc$ext] Foo} msg] $msg $errorCode } -match glob \ -result [list 1 {cannot find symbol "Foo_Init"*} \ {TCL LOOKUP LOAD_SYMBOL *Foo_Init}] test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { - list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg + list [catch {load [file join $testDir tcl9pkga$ext] {} child} msg] $msg } {1 {can't use library in a safe interpreter: no Pkga_SafeInit procedure}} test load-3.1 {error in _Init procedure, same interpreter} \ [list $dll $loaded] { - list [catch {load [file join $testDir pkge$ext] pkge} msg] \ + list [catch {load [file join $testDir tcl9pkge$ext] Pkge} msg] \ $msg $::errorInfo $::errorCode } {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory while executing @@ -102,14 +102,14 @@ test load-3.1 {error in _Init procedure, same interpreter} \ invoked from within "if 44 {open non_existent}" invoked from within -"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} +"load [file join $testDir tcl9pkge$ext] Pkge"} {POSIX ENOENT {no such file or directory}}} test load-3.2 {error in _Init procedure, child interpreter} \ [list $dll $loaded] { catch {interp delete x} interp create x set ::errorCode foo set ::errorInfo bar - set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \ + set result [list [catch {load [file join $testDir tcl9pkge$ext] Pkge x} msg] \ $msg $::errorInfo $::errorCode] interp delete x set result @@ -119,27 +119,27 @@ test load-3.2 {error in _Init procedure, child interpreter} \ invoked from within "if 44 {open non_existent}" invoked from within -"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}} +"load [file join $testDir tcl9pkge$ext] Pkge x"} {POSIX ENOENT {no such file or directory}}} test load-4.1 {reloading package into same interpreter} [list $dll $loaded] { - list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg + list [catch {load [file join $testDir tcl9pkga$ext] Pkga} msg] $msg } {0 {}} test load-4.2 {reloading package into same interpreter} -setup { - catch {load [file join $testDir pkga$ext] Pkga} + catch {load [file join $testDir tcl9pkga$ext] Pkga} } -constraints [list $dll $loaded] -returnCodes error -body { - load [file join $testDir pkga$ext] Pkgb -} -result "file \"[file join $testDir pkga$ext]\" is already loaded for prefix \"Pkga\"" + load [file join $testDir tcl9pkga$ext] Pkgb +} -result "file \"[file join $testDir tcl9pkga$ext]\" is already loaded for prefix \"Pkga\"" test load-5.1 {file name not specified and no static package: pick default} -setup { catch {interp delete x} interp create x } -constraints [list $dll $loaded] -body { - load -global [file join $testDir pkga$ext] Pkga + load -global [file join $testDir tcl9pkga$ext] Pkga load {} Pkga x info loaded x } -cleanup { interp delete x -} -result [list [list [file join $testDir pkga$ext] Pkga]] +} -result [list [list [file join $testDir tcl9pkga$ext] Pkga]] # On some platforms, like SunOS 4.1.3, these tests can't be run because # they cause the process to exit. @@ -153,8 +153,8 @@ test load-6.1 {errors loading file} [list $dll $loaded] { test load-7.1 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" teststaticlibrary Test 1 0 - load {} test - load {} test child + load {} Test + load {} Test child list [set x] [child eval set x] } {loaded loaded} test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { @@ -168,18 +168,18 @@ test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" teststaticlibrary More 0 1 - load {} more + load {} More set x } {not loaded} -catch {load [file join $testDir pkga$ext] Pkga} -catch {load [file join $testDir pkgb$ext] Pkgb} -catch {load [file join $testDir pkge$ext] Pkge} -set currentRealLibraries [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] +catch {load [file join $testDir tcl9pkga$ext] Pkga} +catch {load [file join $testDir tcl9pkgb$ext] Pkgb} +catch {load [file join $testDir tcl9pkge$ext] Pkge} +set currentRealLibraries [list [list [file join $testDir tcl9pkge$ext] Pkge] [list [file join $testDir tcl9pkgb$ext] Pkgb] [list [file join $testDir tcl9pkga$ext] Pkga]] test load-7.4 {Tcl_StaticLibrary procedure, redundant calls} -setup { teststaticlibrary Test 1 0 teststaticlibrary Another 0 0 teststaticlibrary More 0 1 -} -constraints [list teststaticlibrary $dll $loaded deprecated] -body { +} -constraints [list teststaticlibrary $dll $loaded] -body { teststaticlibrary Double 0 1 teststaticlibrary Double 0 1 info loaded @@ -204,14 +204,14 @@ test load-8.2 {TclGetLoadedLibraries procedure} -constraints {teststaticlibrary_ } -returnCodes error -result {could not find interpreter "gorp"} test load-8.3a {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded {}] -} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir tcl9pkga$ext] Pkga] [list [file join $testDir tcl9pkgb$ext] Pkgb] {*}$alreadyLoaded]] test load-8.3b {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded child] -} [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] +} [lsort -index 1 [list {{} Test} [list [file join $testDir tcl9pkgb$ext] Pkgb]]] test load-8.4 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { - load [file join $testDir pkgb$ext] Pkgb + load [file join $testDir tcl9pkgb$ext] Pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] -} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] +} [list [lsort -index 1 [concat [list [list [file join $testDir tcl9pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir tcl9pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child test load-9.1 {Tcl_StaticLibrary, load already-loaded package into another interp} -setup { @@ -234,7 +234,7 @@ test load-10.1 {load from vfs} -setup { cd $testDir testsimplefilesystem 1 } -constraints [list $dll $loaded testsimplefilesystem] -body { - list [catch {load simplefs:/pkgd$ext Pkgd} msg] $msg + list [catch {load simplefs:/tcl9pkgd$ext Pkgd} msg] $msg } -result {0 {}} -cleanup { testsimplefilesystem 0 cd $dir @@ -243,7 +243,7 @@ test load-10.1 {load from vfs} -setup { test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \ [list $dll $loaded] { - load [file join $testDir pkgooa$ext] + load [file join $testDir tcl9pkgooa$ext] list [pkgooa_stubsok] [lsort [info commands pkgooa_*]] } {1 pkgooa_stubsok} diff --git a/tests/lrepeat.test b/tests/lrepeat.test index c1c8b02..6734281 100644 --- a/tests/lrepeat.test +++ b/tests/lrepeat.test @@ -61,7 +61,7 @@ test lrepeat-1.7 {Accept zero repetitions (TIP 323)} { } -result {} } -test lrepeat-1.8 {Do not build enormous lists - Bug 2130992} -body { +test lrepeat-1.8 {Do not build enormous lists - Bug 2130992} -constraints knownBug -body { lrepeat 0x10000000 a b c d e f g h } -returnCodes error -match glob -result * diff --git a/tests/lsearch.test b/tests/lsearch.test index c913e60..b8a8aa7 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -552,7 +552,7 @@ test lsearch-23.1 {lsearch -stride option, errors} -body { } -returnCodes error -result {"-stride" option must be followed by stride length} test lsearch-23.2 {lsearch -stride option, errors} -body { lsearch -stride 0 {a b} a -} -returnCodes error -match glob -result {stride length must be between 1 and *} +} -returnCodes error -result {stride length must be at least 1} test lsearch-23.3 {lsearch -stride option, errors} -body { lsearch -stride 2 {a b c} a } -returnCodes error -result {list size must be a multiple of the stride length} @@ -690,7 +690,7 @@ test lsearch-28.9 {lsearch -sorted with -stride} -body { } -result 9 test lsearch-28.10 {lsearch -sorted with -stride} -body { lsearch -sorted -stride 4294967296 -index 1 -subindices -inline {3 5 8 7 2 9} 9 -} -returnCodes 1 -match glob -result {stride length must be between 1 and *} +} -returnCodes 1 -result {list size must be a multiple of the stride length} # cleanup diff --git a/tests/lseq.test b/tests/lseq.test index 4c1f14b..7e25654 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -17,8 +17,9 @@ if {"::tcltest" ni [namespace children]} { testConstraint arithSeriesDouble 1 testConstraint arithSeriesShimmer 1 testConstraint arithSeriesShimmerOk 1 -#testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}] -#testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}] +testConstraint knownBug 0 +testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}] +testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}] proc memusage {} { set fd [open /proc/[pid]/statm] @@ -464,9 +465,69 @@ test lseq-3.32 {lsearch nested lists of lseq} -constraints arithSeriesShimmer -b list [lindex [tcl::unsupported::representation $a] 3] $a $b \ [lindex [tcl::unsupported::representation [lindex $srchlist 15]] 3] } -cleanup { + unset a b srchlist i +} -result {list {{20 23 26 29 32 35 38}} arithseries arithseries} + + +# lsearch - +# -- should not shimmer lseq list +# -- should not leak lseq elements +test lseq-3.33 {lsearch nested lists of lseq} -constraints arithSeriesShimmer -body { + set srchlist {} + for {set i 5} {$i < 25} {incr i} { + lappend srchlist [lseq $i count 7 by 3] + } + set a [lsearch -all -inline -index 1 $srchlist 23] + set b [lmap i $a {lindex [tcl::unsupported::representation $i] 3}] + list [lindex [tcl::unsupported::representation $a] 3] $a $b \ + [lindex [tcl::unsupported::representation [lindex $srchlist 15]] 3] +} -cleanup { unset srchlist i a b } -result {list {{20 23 26 29 32 35 38}} arithseries arithseries} +test lseq-3.34 {"in" operator} -body { + set seq [lseq 0.3 15e4 0.1] + set inlist {} + set nilist {} + foreach y [lseq 3012.0 3013.0 0.03] { + if {$y in $seq} { + lappend inlist $y + } else { + lappend nilist $y + } + } + list $inlist $nilist +} -cleanup { + unset seq inlist nilist y +} -result {{3012.0 3012.3 3012.6 3012.9} {3012.03 3012.06 3012.09 3012.12 3012.15 3012.18 3012.21 3012.24 3012.27 3012.33 3012.36 3012.39 3012.42 3012.45 3012.48 3012.51 3012.54 3012.57 3012.63 3012.66 3012.69 3012.72 3012.75 3012.78 3012.81 3012.84 3012.87 3012.93 3012.96 3012.99}} + +test lseq-3.35 {"in" operator integer} -body { + set seq [lseq 3 int(15e4) 5] + set inlist {} + set nilist {} + foreach y [lseq 3012 3213 3] { + if {$y in $seq} { + lappend inlist $y + } else { + lappend nilist $y + } + } + list $inlist $nilist +} -cleanup { + unset seq inlist nilist y +} -result {{3018 3033 3048 3063 3078 3093 3108 3123 3138 3153 3168 3183 3198 3213} {3012 3015 3021 3024 3027 3030 3036 3039 3042 3045 3051 3054 3057 3060 3066 3069 3072 3075 3081 3084 3087 3090 3096 3099 3102 3105 3111 3114 3117 3120 3126 3129 3132 3135 3141 3144 3147 3150 3156 3159 3162 3165 3171 3174 3177 3180 3186 3189 3192 3195 3201 3204 3207 3210}} + +test lseq-3.36 {"in" non-numeric case} -body { + if {"barney" in [lseq 15]} { + set res found + } else { + set res not-found + } + set res +} -cleanup { + unset res +} -result {not-found} + test lseq-4.1 {end expressions} -body { set start 7 lseq $start $start+11 @@ -532,7 +593,26 @@ test lseq-4.3 {TIP examples} -body { # # Ticket 9933cc4d88697f05976accebd31c1e3ba6efe9c6 - lseq corner case -test lseq-4.4 {lseq corner case} -body { +test lseq-4.4 {lseq corner case} -constraints has64BitLengths -body { + set tcmd { + set res {} + set s [catch {lindex [lseq 10 100] 0} e] + lappend res $s $e + set s [catch {lindex [lseq 10 9223372036854775000] 0} e] + lappend res $s $e + set s [catch {llength [lseq 10 9223372036854775000]} e] + lappend res $s $e + set s [catch {lindex [lseq 10 2147483647] 0} e] + lappend res $s $e + set s [catch {llength [lseq 10 2147483647]} e] + lappend res $s $e + } + eval $tcmd +} -cleanup { + unset res s e tcmd +} -result {0 10 0 10 0 9223372036854774991 0 10 0 2147483638} + +test lseq-4.4.32 {lseq corner case} -constraints has32BitLengths -body { set tcmd { set res {} set s [catch {lindex [lseq 10 100] 0} e] @@ -556,9 +636,6 @@ test lseq-4.4 {lseq corner case} -body { test lseq-4.5 {lindex off by one} -body { lappend res [eval {lindex [lseq 1 4] end}] lappend res [eval {lindex [lseq 1 4] end-1}] -} -setup { - # Since 4.3 does not clean up and 4.4 may not run under constraint - set res {} } -cleanup { unset res } -result {4 3} @@ -605,11 +682,15 @@ test lseq-4.11 {bug lseq / lindex discrepancies} -body { lindex [lseq 0x7fffffff] 0x80000000 } -result {} -test lseq-4.12 {bug lseq} -body { +test lseq-4.12 {bug lseq} -constraints has64BitLengths -body { + llength [lseq 0x100000000] +} -result {4294967296} + +test lseq-4.12.32 {bug lseq} -constraints has32BitLengths -body { llength [lseq 0x100000000] } -returnCodes 1 -result {max length of a Tcl list exceeded} -test lseq-4.13 {bug lseq} -constraints knownBug -body { +test lseq-4.13 {bug lseq} -constraints has64BitLengths -body { set l [lseq 0x7fffffffffffffff] list \ [llength $l] \ @@ -689,7 +770,7 @@ test lseq-bug-54329e39c7 {does not cause memory bloat} -constraints { set premem [memusage] p $l set postmem [memusage] - expr {($postmem - $premem) < 10} + expr {[string match *purify* [tcl::build-info]] || ($postmem - $premem < 10) ? 1 : ($postmem - $premem)} } -result 1 # cleanup diff --git a/tests/main.test b/tests/main.test index 4aadd79..2703dc1 100644 --- a/tests/main.test +++ b/tests/main.test @@ -606,7 +606,7 @@ namespace eval ::tcl::test::main { catch {set f [open "|[list [interpreter]]" w+]} catch {chan configure $f -blocking 0} } -body { - type $f "chan configure stdin -eofchar \"\\x1A {}\" + type $f "chan configure stdin -eofchar \\x1A if 1 \{\n\x1A" variable wait chan event $f readable \ diff --git a/tests/mathop.test b/tests/mathop.test index 3c25a2b..57d48d6 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -126,10 +126,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.15 {compiled +: errors} -returnCodes error -body { + 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "+"} + } -result {can't use non-numeric string "0o8" as operand of "+"} test mathop-1.16 {compiled +: errors} -returnCodes error -body { + 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "+"} + } -result {can't use non-numeric string "0o8" as operand of "+"} test mathop-1.17 {compiled +: errors} -returnCodes error -body { + 0 [error expectedError] } -result expectedError @@ -164,10 +164,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.33 {interpreted +: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "+"} + } -result {can't use non-numeric string "0o8" as operand of "+"} test mathop-1.34 {interpreted +: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "+"} + } -result {can't use non-numeric string "0o8" as operand of "+"} test mathop-1.35 {interpreted +: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -201,10 +201,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.15 {compiled *: errors} -returnCodes error -body { * 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "*"} + } -result {can't use non-numeric string "0o8" as operand of "*"} test mathop-2.16 {compiled *: errors} -returnCodes error -body { * 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "*"} + } -result {can't use non-numeric string "0o8" as operand of "*"} test mathop-2.17 {compiled *: errors} -returnCodes error -body { * 0 [error expectedError] } -result expectedError @@ -239,10 +239,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.33 {interpreted *: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "*"} + } -result {can't use non-numeric string "0o8" as operand of "*"} test mathop-2.34 {interpreted *: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "*"} + } -result {can't use non-numeric string "0o8" as operand of "*"} test mathop-2.35 {interpreted *: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -399,10 +399,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.15 {compiled &: errors} -returnCodes error -body { & 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "&"} + } -result {can't use non-numeric string "0o8" as operand of "&"} test mathop-6.16 {compiled &: errors} -returnCodes error -body { & 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "&"} + } -result {can't use non-numeric string "0o8" as operand of "&"} test mathop-6.17 {compiled &: errors} -returnCodes error -body { & 0 [error expectedError] } -result expectedError @@ -441,10 +441,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.33 {interpreted &: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "&"} + } -result {can't use non-numeric string "0o8" as operand of "&"} test mathop-6.34 {interpreted &: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "&"} + } -result {can't use non-numeric string "0o8" as operand of "&"} test mathop-6.35 {interpreted &: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -509,10 +509,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.15 {compiled |: errors} -returnCodes error -body { | 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "|"} + } -result {can't use non-numeric string "0o8" as operand of "|"} test mathop-7.16 {compiled |: errors} -returnCodes error -body { | 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "|"} + } -result {can't use non-numeric string "0o8" as operand of "|"} test mathop-7.17 {compiled |: errors} -returnCodes error -body { | 0 [error expectedError] } -result expectedError @@ -551,10 +551,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.33 {interpreted |: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "|"} + } -result {can't use non-numeric string "0o8" as operand of "|"} test mathop-7.34 {interpreted |: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "|"} + } -result {can't use non-numeric string "0o8" as operand of "|"} test mathop-7.35 {interpreted |: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -619,10 +619,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.15 {compiled ^: errors} -returnCodes error -body { ^ 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "^"} + } -result {can't use non-numeric string "0o8" as operand of "^"} test mathop-8.16 {compiled ^: errors} -returnCodes error -body { ^ 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "^"} + } -result {can't use non-numeric string "0o8" as operand of "^"} test mathop-8.17 {compiled ^: errors} -returnCodes error -body { ^ 0 [error expectedError] } -result expectedError @@ -661,10 +661,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.33 {interpreted ^: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "^"} + } -result {can't use non-numeric string "0o8" as operand of "^"} test mathop-8.34 {interpreted ^: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "^"} + } -result {can't use non-numeric string "0o8" as operand of "^"} test mathop-8.35 {interpreted ^: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 468c648..36b613f 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -293,12 +293,13 @@ namespace eval test_ns_hier1 { namespace eval test_ns_hier2a {} namespace eval test_ns_hier2b {} } +# TIP 278: secondary lookup disabled for vars, tests disabled with # test namespace-old-5.4 {nested namespaces can access global namespace} { - list [namespace eval test_ns_hier1 {set test_ns_var_global}] \ + list [namespace eval test_ns_hier1 {#set test_ns_var_global}] \ [namespace eval test_ns_hier1 {test_ns_cmd_global}] \ - [namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_global}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {#set test_ns_var_global}] \ [namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_global}] -} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}} +} {{} {cmd in ::} {} {cmd in ::}} test namespace-old-5.5 {variables in different namespaces don't conflict} { list [set test_ns_hier1::test_ns_level] \ [set test_ns_hier1::test_ns_hier2::test_ns_level] @@ -468,11 +469,12 @@ test namespace-old-6.11 {commands affect all parent namespaces} { } list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] } {{cache2 version} {cache2 version}} +# TIP 278: secondary lookup disabled, catch added, result changed from {global version} test namespace-old-6.12 {define test variables} { variable test_ns_cache_var "global version" set trigger {set test_ns_cache_var} - namespace eval test_ns_cache1 $trigger -} {global version} + list [catch {namespace eval test_ns_cache1 $trigger} msg] $msg +} {1 {can't read "test_ns_cache_var": no such variable}} set trigger {set test_ns_cache_var} test namespace-old-6.13 {one-level check for variable shadowing} { namespace eval test_ns_cache1 { @@ -481,22 +483,24 @@ test namespace-old-6.13 {one-level check for variable shadowing} { namespace eval test_ns_cache1 $trigger } {cache1 version} variable ::test_ns_cache_var "global version" +# TIP 278: secondary lookup disabled, catch added, result changed from {global version} test namespace-old-6.14 {deleting variables changes variable epoch} { namespace eval test_ns_cache1 { variable test_ns_cache_var "cache1 version" } list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 {unset test_ns_cache_var}] \ - [namespace eval test_ns_cache1 $trigger] -} {{cache1 version} {} {global version}} + [catch {namespace eval test_ns_cache1 $trigger}] +} {{cache1 version} {} 1} +# TIP 278: secondary lookup disabled, catch added, result changed test namespace-old-6.15 {define test namespaces} { namespace eval test_ns_cache2 { variable test_ns_cache_var "global cache2 version" } set trigger2 {set test_ns_cache2::test_ns_cache_var} - list [namespace eval test_ns_cache1 $trigger2] \ - [namespace eval test_ns_cache1::test_ns_cache2 $trigger] -} {{global cache2 version} {global version}} + catch {list [namespace eval test_ns_cache1 $trigger2] \ + [namespace eval test_ns_cache1::test_ns_cache2 $trigger]} +} 1 set trigger2 {set test_ns_cache2::test_ns_cache_var} test namespace-old-6.16 {public variables affect all parent namespaces} { variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" diff --git a/tests/namespace.test b/tests/namespace.test index c98ad4a..ae233cb 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -48,9 +48,9 @@ test namespace-2.2 {Tcl_GetCurrentNamespace} { set l {} lappend l [namespace current] namespace eval test_ns_1 { - lappend l [namespace current] + lappend ::l [namespace current] namespace eval foo { - lappend l [namespace current] + lappend ::l [namespace current] } } lappend l [namespace current] @@ -710,6 +710,8 @@ test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} -setup [catch {namespace children test_ns_777} msg] $msg } } -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} + +# TIP 278: secondary lookup disabled, results changed from {10 20} test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} variable v 10 @@ -721,9 +723,11 @@ test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup { } } -body { namespace eval test_ns_1 { - list $v $test_ns_2::v + # list $v $test_ns_2::v + list [catch {set v} msg] $msg [catch {set test_ns_2::v} msg] $msg } -} -result {10 20} +} -result {1 {can't read "v": no such variable} 0 20} + test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { namespace eval foo {} @@ -784,15 +788,17 @@ test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"} lappend l [test_ns_1::test_ns_2:: hello] } -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} + +# TIP 278: secondary lookup disabled, added catch, result changed from y test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -body { namespace eval test_ns_1 { variable {} - set test_ns_1::(x) y + catch {set test_ns_1::(x) y} ::msg } - set test_ns_1::(x) -} -result y + list $::msg [catch {set test_ns_1::(x)} msg] $msg +} -result {{can't set "test_ns_1::(x)": parent namespace doesn't exist} 1 {can't read "test_ns_1::(x)": no such variable}} test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -returnCodes error -body { @@ -965,13 +971,15 @@ test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} -setup { set x } } -result {777} + +# TIP 278: secondary lookup disabled, catch added, result changed from 314159 test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} { namespace eval test_ns_1 { variable x 777 unset x - set x ;# must be global x now + list [catch {set x} msg] $msg ;# must not be global x now } -} {314159} +} {1 {can't read "x": no such variable}} test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} -body { namespace eval test_ns_1 { set wuzzat @@ -983,6 +991,8 @@ test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} { } set test_ns_1::a } {hello} + +# TIP 278: secondary lookup disabled, result changed from 1 test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} -setup { namespace eval test_ns_1 {} } -body { @@ -996,7 +1006,7 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} - namespace eval test_ns_1 set a 1 namespace delete test_ns_1 return $a -} -result 1 +} -result 0 catch {unset a} catch {unset x} @@ -1617,6 +1627,8 @@ test namespace-34.6 {NamespaceWhichCmd, -command is default} -setup { [namespace which ::test_ns_2::cmd2] } } -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} + +# TIP 278: secondary lookup disabled, catch added, result changed test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup { catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { @@ -1636,12 +1648,12 @@ test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup { } } -body { namespace eval test_ns_3 { - list [namespace which -variable env] \ + list [catch {namespace which -variable env } msg] $msg \ [namespace which -variable v3] \ [namespace which -variable ::test_ns_2::v2] \ [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg } -} -result {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} +} -result {0 {} ::test_ns_3::v3 ::test_ns_2::v2 0 {}} test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} diff --git a/tests/obj.test b/tests/obj.test index 64a1d5b..eb85c84 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -19,16 +19,13 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] -source [file join [file dirname [info script]] tcltests.tcl] - testConstraint testobj [llength [info commands testobj]] testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] -test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {testobj deprecated} { +test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 foreach {t} { - bytearray bytecode cmdName dict @@ -48,10 +45,10 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 12] - lappend result [testobj convert 1 bytearray] + lappend result [testobj convert 1 string] lappend result [testobj type 1] lappend result [testobj refcount 1] -} {{} 12 12 bytearray 3} +} {{} 12 12 string 3} test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" diff --git a/tests/parse.test b/tests/parse.test index b0c051b..517d577 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -376,12 +376,12 @@ test parse-8.8 {Tcl_EvalObjv procedure, async handlers} -constraints { return "new result" } set handler1 [testasync create async1] - set aresult xxx - set acode yyy + set ::aresult xxx + set ::acode yyy } -cleanup { testasync delete } -body { - list [testevalobjv 0 testasync mark $handler1 original 0] $acode $aresult + list [testevalobjv 0 testasync mark $handler1 original 0] $::acode $::aresult } -result {{new result} 0 original} test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} testevalobjv { list [catch {testevalobjv 0 error message} msg] $msg @@ -601,8 +601,8 @@ test parse-12.6 {Tcl_ParseVarName procedure, braced variable name} testparser { testparser {${..[]b}cd} 0 } {- {${..[]b}cd} 1 word {${..[]b}cd} 3 variable {${..[]b}} 1 text {..[]b} 0 text cd 0 {}} test parse-12.7 {Tcl_ParseVarName procedure, braced variable name} testparser { - testparser "\$\{\{\} " 0 -} {- \$\{\{\}\ 1 word \$\{\{\} 2 variable \$\{\{\} 1 text \{ 0 {}} + testparser "\$\{\{\\\\\}\} " 0 +} {- {${{\\}} } 1 word {${{\\}}} 2 variable {${{\\}}} 1 text {{\\}} 0 {}} test parse-12.8 {Tcl_ParseVarName procedure, missing close brace} testparser { list [catch {testparser "$\{abc" 0} msg] $msg $::errorInfo } {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\$\\\{abc\"\ 0\"} @@ -797,7 +797,7 @@ test parse-15.16 {CommandComplete procedure} { } 1 test parse-15.17 {CommandComplete procedure} { info complete {a b "c $dd("} -} 0 +} 1 test parse-15.18 {CommandComplete procedure} { info complete {a b "c \"} } 0 diff --git a/tests/parseExpr.test b/tests/parseExpr.test index fd32df9..476a250 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -919,8 +919,8 @@ test parseExpr-21.43 {error message} -body { in expression \"...8901234567890*\"foobar\$\{abcdefghijklmnopqrstuv...\"" test parseExpr-21.44 {error message} -body { expr {123456789012345678901234567890*"foo$bar(abcdefghijklmnopqrstuvwxyz"} -} -returnCodes error -result {missing ) -in expression "...8901234567890*"foo$bar(abcdefghijklmnopqrstuv..."} +} -returnCodes error -result {invalid character in array index +in expression "...8901234567890*"foo$bar(abcdefghijklmnopqrstu..."} test parseExpr-21.45 {error message} -body { expr {123456789012345678901234567890*"foo$bar([{}abcdefghijklmnopqrstuvwxyz])"} } -returnCodes error -result {extra characters after close-brace diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 33add42..49f5849 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -553,7 +553,7 @@ removeFile [file join pkg circ3.tcl] # Some tests require the existence of one of the DLLs in the dltest directory set x [file join [file dirname [info nameofexecutable]] dltest \ - pkga[info sharedlibextension]] + tcl9pkga[info sharedlibextension]] set dll "[file tail $x]Required" testConstraint $dll [file exists $x] @@ -575,8 +575,8 @@ test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] { # it. set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl] exec [interpreter] << $cmd - pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl -} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" + pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath tcl9pkga[info sharedlibextension] pkga.tcl +} "0 {{pkga:1.0 {tclPkgSetup {tcl9pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] { # Do all [load]ing of shared libraries in another process, so we can diff --git a/tests/regexp.test b/tests/regexp.test index 16c775e..b06c163 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -765,14 +765,14 @@ test regexp-19.2 {regsub null replacement} { string equal $result $expected } 1 -test regexp-20.1 {regsub shared object shimmering} -constraints deprecated -body { +test regexp-20.1 {regsub shared object shimmering} -body { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz set b $a set c abcdefghijklmnopqurstuvwxyz0123456789 regsub $a $c $b d - list $d [string length $d] [string bytelength $d] -} -result [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] + list $d [string length $d] +} -result [list abcdefghijklmnopqurstuvwxyz0123456789 37] test regexp-20.2 {regsub shared object shimmering with -about} -body { eval regexp -about abc } -result {0 {}} diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 42f1b3b..6cf95b5 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -16,8 +16,6 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -source [file join [file dirname [info script]] tcltests.tcl] - # Procedure to evaluate a script within a proc, to test compilation # functionality @@ -793,16 +791,16 @@ test regexpComp-19.1 {regsub null replacement} { } } "\0a\0hel\0a\0lo\0a\0 14" -test regexpComp-20.1 {regsub shared object shimmering} deprecated { +test regexpComp-20.1 {regsub shared object shimmering} { evalInProc { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz set b $a set c abcdefghijklmnopqurstuvwxyz0123456789 regsub $a $c $b d - list $d [string length $d] [string bytelength $d] + list $d [string length $d] } -} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] +} [list abcdefghijklmnopqurstuvwxyz0123456789 37] test regexpComp-20.2 {regsub shared object shimmering with -about} { evalInProc { eval regexp -about abc diff --git a/tests/result.test b/tests/result.test index 5ae29b2..770e401 100644 --- a/tests/result.test +++ b/tests/result.test @@ -33,7 +33,7 @@ test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} { } {append result} test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 0 -} {dynamic result presentOrFreed} +} {dynamic result freed} test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 0 } {object result same} @@ -45,7 +45,7 @@ test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} { } {42} test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 1 -} {42 presentOrFreed} +} {42 freed} test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 1 } {42 different} diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/tests/safe-stock86.test diff --git a/tests/safe.test b/tests/safe.test index 0a888f4..8af6c24 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -734,10 +734,10 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i] } -cleanup { safe::interpDelete $i -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ - {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ - {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ - {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar} -autoPath *}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar} -autoPath *}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto -autoPath *}} test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { # this test shall work, believed equivalent to 9.6 set i [safe::interpCreate \ @@ -759,10 +759,10 @@ test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { } -cleanup { safe::interpDelete $i unset -nocomplain a b c d e f g i -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ - {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ - {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ - {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar} -autoPath *}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar} -autoPath *}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto -autoPath *}} test safe-9.8 {autoloading commands indexed in tclIndex files, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { @@ -1951,7 +1951,7 @@ test safe-16.5 {Bug 3529949: defang ~ in paths used by AliasGlob (1)} -setup { safe::interpDelete $i set env(HOME) $savedHOME unset savedHOME -} -result {~} +} -result {$p(:0:)/~} test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup { set savedHOME $env(HOME) set env(HOME) /foo/bar @@ -1965,7 +1965,7 @@ test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup { safe::interpDelete $i set env(HOME) $savedHOME unset savedHOME -} -result {~} +} -result {$p(:0:)/foo/bar/~} test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup { set i [safe::interpCreate] set user $tcl_platform(user) @@ -1974,7 +1974,7 @@ test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup } -cleanup { safe::interpDelete $i unset user -} -result {~USER} +} -result {$p(:0:)/~USER} test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup { set i [safe::interpCreate] set user $tcl_platform(user) @@ -1983,7 +1983,7 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup } -cleanup { safe::interpDelete $i unset user -} -result {~USER} +} -result {$p(:0:)/foo/bar/~USER} ### 17. Test the use of ::auto_path for loading commands (via tclIndex files) ### and non-module packages (via pkgIndex.tcl files). diff --git a/tests/scan.test b/tests/scan.test index 98ec314..6d7a9fb 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -864,6 +864,7 @@ test scan-13.9 {Tcl_ScanObjCmd, inline XPG case limit error} -body { scan abc {%2147483648$s} } -result {"%n$" argument index out of range} -returnCodes error + # scan infinities - not working test scan-14.1 {positive infinity} { diff --git a/tests/source.test b/tests/source.test index f5f9f0f..98aaee2 100644 --- a/tests/source.test +++ b/tests/source.test @@ -114,7 +114,7 @@ test source-2.7 {utf-8 with BOM} -setup { puts $out "\uFEFFset y new-y" close $out set y old-y - source -encoding utf-8 $sourcefile + source $sourcefile return $y } -cleanup { removeFile $sourcefile @@ -226,7 +226,7 @@ test source-7.1 {source -encoding test} -setup { close $f } -body { set x unset - source -encoding utf-8 $sourcefile + source $sourcefile set x } -cleanup { removeFile source.file @@ -269,7 +269,7 @@ test source-7.5 {source -encoding: correct operation} -setup { puts $f "proc € {} {return foo}" close $f } -body { - source -encoding utf-8 $sourcefile + source $sourcefile € } -cleanup { removeFile source.file diff --git a/tests/string.test b/tests/string.test index b003898..a232f1e 100644 --- a/tests/string.test +++ b/tests/string.test @@ -34,7 +34,6 @@ testConstraint testobj [expr {[info commands testobj] ne {}}] testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] testConstraint testevalex [expr {[info commands testevalex] ne {}}] testConstraint testbytestring [llength [info commands testbytestring]] -testConstraint testutf16string [llength [info commands testutf16string]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -76,7 +75,7 @@ if {$noComp} { test string-1.1.$noComp {error conditions} -body { list [catch {run {string gorp a b}} msg] $msg -} -match glob -result {1 {unknown or ambiguous subcommand "gorp": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -result {1 {unknown or ambiguous subcommand "gorp": must be cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2.$noComp {error conditions} { list [catch {run {string}} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} @@ -431,7 +430,7 @@ test string-4.16.$noComp {string first, normal string vs pure unicode string} -b # Representation checks are canaries run {list [representationpoke $s] [representationpoke $m] \ [string first $m $s]} -} -match glob -result {{*string 1} {*string 0} 2} +} -result {{string 1} {string 0} 2} test string-4.17.$noComp {string first, corner case} -body { run {string first a aaa 4294967295} } -result -1 @@ -506,10 +505,10 @@ test string-5.16.$noComp {string index, bytearray object with string obj shimmer } 0 test string-5.17.$noComp {string index, bad integer} -body { list [catch {run {string index "abc" 0o8}} msg] $msg -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test string-5.18.$noComp {string index, bad integer} -body { list [catch {run {string index "abc" end-0o0289}} msg] $msg -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test string-5.19.$noComp {string index, bytearray object out of bounds} { run {string index [binary format I* {0x50515253 0x52}] -1} } {} @@ -1054,19 +1053,6 @@ test string-7.16.$noComp {string last, start index} { run {string last Üa ÜadÜad end-1} } 3 -test string-8.1.$noComp {string bytelength} deprecated { - list [catch {run {string bytelength}} msg] $msg -} {1 {wrong # args: should be "string bytelength string"}} -test string-8.2.$noComp {string bytelength} deprecated { - list [catch {run {string bytelength a b}} msg] $msg -} {1 {wrong # args: should be "string bytelength string"}} -test string-8.3.$noComp {string bytelength} deprecated { - run {string bytelength "\xC7"} -} 2 -test string-8.4.$noComp {string bytelength} deprecated { - run {string b ""} -} 0 - test string-9.1.$noComp {string length} { list [catch {run {string length}} msg] $msg } {1 {wrong # args: should be "string length string"}} @@ -1860,7 +1846,7 @@ test string-20.1.$noComp {string trimright errors} { } {1 {wrong # args: should be "string trimright string ?chars?"}} test string-20.2.$noComp {string trimright errors} -body { list [catch {run {string trimg a}} msg] $msg -} -match glob -result {1 {unknown or ambiguous subcommand "trimg": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -result {1 {unknown or ambiguous subcommand "trimg": must be cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-20.3.$noComp {string trimright} { run {string trimright " XYZ "} } { XYZ} @@ -1969,18 +1955,18 @@ test string-21.22.$noComp {string trimright, unicode} { run {string trimright "\uF602Hello world!\uF602" \uD83D\uDE02} } "\uF602Hello world!\uF602" test string-21.23.$noComp {string trim, unicode} { - run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} + run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D} } "\uD83D\uDE02Hello world!\uD83D\uDE02" test string-21.24.$noComp {string trimleft, unicode} { run {string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} } "\uD83D\uDE02Hello world!\uD83D\uDE02" test string-21.25.$noComp {string trimright, unicode} { - run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} + run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D} } "\uD83D\uDE02Hello world!\uD83D\uDE02" test string-22.1.$noComp {string wordstart} -body { list [catch {run {string word a}} msg] $msg -} -match glob -result {1 {unknown or ambiguous subcommand "word": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -result {1 {unknown or ambiguous subcommand "word": must be cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-22.2.$noComp {string wordstart} -body { list [catch {run {string wordstart a}} msg] $msg } -result {1 {wrong # args: should be "string wordstart string index"}} @@ -2141,22 +2127,22 @@ test string-24.15.$noComp {string reverse command - pure bytearray} { } 030201 test string-24.16.$noComp {string reverse command - surrogates} { run {string reverse \u0444bulb\uD83D\uDE02} -} \uD83D\uDE02blub\u0444 +} \uDE02\uD83Dblub\u0444 test string-24.17.$noComp {string reverse command - surrogates} { run {string reverse \uD83D\uDE02hello\uD83D\uDE02} -} \uD83D\uDE02olleh\uD83D\uDE02 +} \uDE02\uD83Dolleh\uDE02\uD83D test string-24.18.$noComp {string reverse command - surrogates} { set s \u0444bulb\uD83D\uDE02 # shim shimmery ... string index $s 0 run {string reverse $s} -} \uD83D\uDE02blub\u0444 +} \uDE02\uD83Dblub\u0444 test string-24.19.$noComp {string reverse command - surrogates} { set s \uD83D\uDE02hello\uD83D\uDE02 # shim shimmery ... string index $s 0 run {string reverse $s} -} \uD83D\uDE02olleh\uD83D\uDE02 +} \uDE02\uD83Dolleh\uDE02\uD83D test string-25.1.$noComp {string is list} { run {string is list {a b c}} @@ -2453,11 +2439,11 @@ test string-29.11.$noComp {string cat, efficiency} -body { test string-29.12.$noComp {string cat, efficiency} -body { tcl::unsupported::representation \ [run {string cat [encoding convertto utf-8 {}] [list x]}] -} -match glob -result {*, string representation "x"} +} -match glob -result {*, no string representation} test string-29.13.$noComp {string cat, efficiency} -body { tcl::unsupported::representation [run {string cat \ [encoding convertto utf-8 {}] [encoding convertto utf-8 {}] [list x]}] -} -match glob -result {*, string representation "x"} +} -match glob -result {*, no string representation} test string-29.14.$noComp {string cat, efficiency} -setup { set e [encoding convertto utf-8 {}] } -cleanup { @@ -2645,17 +2631,6 @@ test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} { } 0 }; # foreach noComp {0 1} - -test string-bug-b79df322a9 {Tcl_GetUnicode/Tcl_NewUnicodeObj api} -constraints { - testutf16string deprecated -} -body { - # This simple test suffices because the bug has nothing to do with - # the actual encoding conversion. The test was added because these - # functions are no longer called within the Tcl core and thus - # not tested by either `string`, not `encoding` tests. - testutf16string "abcde" -} -result abcde - # cleanup rename MemStress {} diff --git a/tests/stringObj.test b/tests/stringObj.test index 6fbdc05..605c9dd 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -19,18 +19,20 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] -source [file join [file dirname [info script]] tcltests.tcl] testConstraint testobj [llength [info commands testobj]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] -test stringObj-1.1 {string type registration} {testobj deprecated} { +test stringObj-1.1 {string type registration} testobj { set t [testobj types] set first [string first "string" $t] set result [expr {$first >= 0}] } 1 +set INT_MAX 0x7fffffff; # Assumes sizeof(int) == 4 +set SIZE_MAX [expr {(1 << (8*$::tcl_platform(pointerSize) - 1)) - 1}] + test stringObj-2.1 {Tcl_NewStringObj} testobj { set result "" lappend result [testobj freeallvars] @@ -56,27 +58,27 @@ test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} testob lappend result [testobj refcount 1] } {{} 512 foo string 2} -test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} {testobj deprecated} { +test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} testobj { testobj freeallvars teststringobj set 1 test teststringobj setlength 1 3 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {3 3 tes} +} {3 4 tes} test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} testobj { testobj freeallvars teststringobj set 1 abcdef teststringobj setlength 1 10 teststringobj length 1 } 10 -test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} {testobj deprecated} { +test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} testobj { testobj freeallvars teststringobj set 1 abcdef teststringobj append 1 xyzq -1 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {10 10 abcdefxyzq} -test stringObj-4.4 {Tcl_SetObjLength procedure, "empty string", length 0} {testobj deprecated} { +} {10 15 abcdefxyzq} +test stringObj-4.4 {Tcl_SetObjLength procedure, "empty string", length 0} testobj { testobj freeallvars testobj newobj 1 teststringobj setlength 1 0 @@ -96,7 +98,7 @@ test stringObj-5.2 {Tcl_AppendToObj procedure, length calculation} testobj { teststringobj append 1 123 -1 teststringobj get 1 } {x y bbCC123} -test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {testobj deprecated} { +test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} testobj { testobj freeallvars teststringobj set 1 xyz teststringobj setlength 1 15 @@ -108,7 +110,7 @@ test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {testobj depr teststringobj append 1 abcdef -1 lappend result [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {15 15 16 16 xy12345678abcdef} +} {15 15 16 24 xy12345678abcdef} test stringObj-6.1 {Tcl_AppendStringsToObj procedure, type conversion} testobj { testobj freeallvars @@ -134,13 +136,13 @@ test stringObj-6.4 {Tcl_AppendStringsToObj procedure, counting space} testobj { teststringobj appendstrings 1 { 123 } abcdefg list [teststringobj length 1] [teststringobj get 1] } {15 {abc 123 abcdefg}} -test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} {testobj deprecated} { +test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} testobj { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 123 abcdefg list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1] -} {10 10 123abcdefg} -test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj deprecated} { +} {10 15 123abcdefg} +test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testobj { testobj freeallvars teststringobj set 1 abc teststringobj setlength 1 10 @@ -149,7 +151,7 @@ test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} {testo list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {10 10 ab34567890} -test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj deprecated} { +test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} testobj { testobj freeallvars teststringobj set 1 abc teststringobj setlength 1 10 @@ -157,8 +159,8 @@ test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testo teststringobj appendstrings 1 34567890x list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {11 11 ab34567890x} -test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} {testobj deprecated} { +} {11 17 ab34567890x} +test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} testobj { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 {} @@ -171,14 +173,14 @@ test stringObj-6.9 {Tcl_AppendStringToObj, pure unicode} testobj { teststringobj get 1 } adcfoobarsoom -test stringObj-7.1 {SetStringFromAny procedure} {testobj deprecated} { +test stringObj-7.1 {SetStringFromAny procedure} testobj { testobj freeallvars teststringobj set2 1 [list a b] teststringobj append 1 x -1 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {4 4 {a bx}} -test stringObj-7.2 {SetStringFromAny procedure, null object} {testobj deprecated} { +} {4 6 {a bx}} +test stringObj-7.2 {SetStringFromAny procedure, null object} testobj { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 {} @@ -196,7 +198,7 @@ test stringObj-7.4 {SetStringFromAny called with string obj} testobj { [string length $x] [testobj objtype $x] } {6 string 6 string} -test stringObj-8.1 {DupStringInternalRep procedure} {testobj deprecated} { +test stringObj-8.1 {DupStringInternalRep procedure} testobj { testobj freeallvars teststringobj set 1 {} teststringobj append 1 abcde -1 @@ -205,7 +207,7 @@ test stringObj-8.1 {DupStringInternalRep procedure} {testobj deprecated} { [teststringobj maxchars 1] [teststringobj get 1] \ [teststringobj length 2] [teststringobj length2 2] \ [teststringobj maxchars 2] [teststringobj get 2] -} {5 5 5 abcde 5 5 5 abcde} +} {5 8 0 abcde 5 5 0 abcde} test stringObj-8.2 {DupUnicodeInternalRep, mixed width chars} testobj { set x abc\xEF\xBF\xAEghi string length $x @@ -454,71 +456,75 @@ test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 3 } foo -test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj knownBug deprecated} { +test stringObj-15.5 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 0 } foofoo -test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj knownBug deprecated} { +test stringObj-15.6 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 1 } foooo -test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj knownBug deprecated} { +test stringObj-15.7 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 2 } fooo -test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj deprecated} { +test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 3 } foo -test stringObj-16.0 {Tcl_GetRange: normal case} {testobj deprecated} { +test stringObj-16.0 {Tcl_GetRange: normal case} testobj { teststringobj set 1 abcde teststringobj range 1 1 3 } bcd -test stringObj-16.1 {Tcl_GetRange: first > end} {testobj deprecated} { +test stringObj-16.1 {Tcl_GetRange: first > end} testobj { teststringobj set 1 abcde teststringobj range 1 10 5 } {} -test stringObj-16.2 {Tcl_GetRange: last > end} {testobj deprecated} { +test stringObj-16.2 {Tcl_GetRange: last > end} testobj { teststringobj set 1 abcde teststringobj range 1 3 13 } de -test stringObj-16.3 {Tcl_GetRange: first = TCL_INDEX_NONE} {testobj deprecated} { +test stringObj-16.3 {Tcl_GetRange: first = TCL_INDEX_NONE} testobj { teststringobj set 1 abcde teststringobj range 1 -1 3 } abcd -test stringObj-16.4 {Tcl_GetRange: last = TCL_INDEX_NONE} {testobj deprecated} { +test stringObj-16.4 {Tcl_GetRange: last = TCL_INDEX_NONE} testobj { teststringobj set 1 abcde teststringobj range 1 1 -1 } bcde -test stringObj-16.5 {Tcl_GetRange: first = last = TCL_INDEX_NONE} {testobj deprecated} { +test stringObj-16.5 {Tcl_GetRange: first = last = TCL_INDEX_NONE} testobj { teststringobj set 1 abcde teststringobj range 1 -1 -1 } abcde -test stringObj-16.6 {Tcl_GetRange: old anomaly} {testobj deprecated} { +test stringObj-16.6 {Tcl_GetRange: old anomaly} testobj { # Older implementations could return "cde" teststringobj set 1 abcde teststringobj range 1 2 0 } {} -test stringObj-16.7 {Tcl_GetRange: first = 0x7FFFFFFF-1} {testobj deprecated} { +test stringObj-16.7 {Tcl_GetRange: first = INT_MAX-1} testobj { + teststringobj set 1 abcde + teststringobj range 1 [expr {$INT_MAX-1}] 3 +} {} +test stringObj-16.8 {Tcl_GetRange: first = SIZE_MAX-1} testobj { teststringobj set 1 abcde - teststringobj range 1 [expr {0x7FFFFFFF-1}] 3 + teststringobj range 1 [expr {$SIZE_MAX - 1}] 3 } {} -test stringObj-16.8 {Tcl_GetRange: last = 0x7FFFFFFF-1} {testobj deprecated} { +test stringObj-16.9 {Tcl_GetRange: last = INT_MAX-1} testobj { teststringobj set 1 abcde - teststringobj range 1 1 [expr {0x7FFFFFFF-1}] + teststringobj range 1 1 [expr {$INT_MAX-1}] } bcde -test stringObj-16.9 {Tcl_GetRange: last = 0x7FFFFFFF-1} {testobj deprecated} { +test stringObj-16.10 {Tcl_GetRange: last = SIZE_MAX-1} testobj { teststringobj set 1 abcde - teststringobj range 1 1 [expr {0x7FFFFFFF - 1}] + teststringobj range 1 1 [expr {$SIZE_MAX - 1}] } bcde -test stringObj-16.10 {Tcl_GetRange: first = last = 0x7FFFFFFF-1} {testobj deprecated} { +test stringObj-16.11 {Tcl_GetRange: first = last = INT_MAX-1} testobj { teststringobj set 1 abcde - teststringobj range 1 [expr {0x7FFFFFFF-1}] [expr {0x7FFFFFFF-1}] + teststringobj range 1 [expr {$INT_MAX-1}] [expr {$INT_MAX-1}] } {} -test stringObj-16.11 {Tcl_GetRange: first = last = 0x7FFFFFFF-1} {testobj deprecated} { +test stringObj-16.12 {Tcl_GetRange: first = last = SIZE_MAX-1} testobj { teststringobj set 1 abcde - set i [expr {0x7FFFFFFF - 1}] + set i [expr {$SIZE_MAX - 1}] teststringobj range 1 $i $i } {} diff --git a/tests/tcltest.test b/tests/tcltest.test index 114ce30..20d75bb 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -547,6 +547,7 @@ set notReadableDir [file join [temporaryDirectory] notreadable] set notWritableDir [file join [temporaryDirectory] notwritable] makeDirectory notreadable makeDirectory notwritable + switch -- $::tcl_platform(platform) { unix { file attributes $notReadableDir -permissions 0o333 diff --git a/tests/trace.test b/tests/trace.test index 2b16e2f..64c9111 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -19,8 +19,6 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] -source [file join [file dirname [info script]] tcltests.tcl] - testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testevalobjv [llength [info commands testevalobjv]] @@ -900,23 +898,6 @@ foreach type {variable command execution} err $errs abbvlist $abbvs { } rename x {} -test trace-14.7 {trace command, "trace variable" errors} deprecated { - list [catch {trace variable} msg] $msg -} [list 1 "wrong # args: should be \"trace variable name ops command\""] -test trace-14.8 {trace command, "trace variable" errors} deprecated { - list [catch {trace variable x} msg] $msg -} [list 1 "wrong # args: should be \"trace variable name ops command\""] -test trace-14.9 {trace command, "trace variable" errors} deprecated { - list [catch {trace variable x y} msg] $msg -} [list 1 "wrong # args: should be \"trace variable name ops command\""] -test trace-14.10 {trace command, "trace variable" errors} deprecated { - list [catch {trace variable x y z w} msg] $msg -} [list 1 "wrong # args: should be \"trace variable name ops command\""] -test trace-14.11 {trace command, "trace variable" errors} deprecated { - list [catch {trace variable x y z} msg] $msg -} [list 1 "bad operations \"y\": should be one or more of rwua"] - - test trace-14.12 {trace command ("remove variable" option)} { unset -nocomplain x set info {} diff --git a/tests/unload.test b/tests/unload.test index 75cbcde..df217be 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -27,7 +27,7 @@ if {![info exists ext]} { # Tests require the existence of one of the DLLs in the dltest directory. set testDir [file join [file dirname [info nameofexecutable]] dltest] -set x [file join $testDir pkgua$ext] +set x [file join $testDir tcl9pkgua$ext] set dll "[file tail $x]Required" testConstraint $dll [file readable $x] @@ -46,7 +46,7 @@ proc loadIfNotPresent {pkg args} { global testDir ext set loaded [lmap x [info loaded {*}$args] {lindex $x 1}] if {[string totitle $pkg] ni $loaded} { - load [file join $testDir $pkg$ext] + load [file join $testDir tcl9$pkg$ext] } } @@ -77,37 +77,37 @@ set pkgua_loaded {} set pkgua_detached {} set pkgua_unloaded {} # Tests for loading/unloading in trusted (non-safe) interpreters... -test unload-2.1 {basic loading of non-unloadable package, with guess for prefix} [list $dll $loaded deprecated] { +test unload-2.1 {basic loading of non-unloadable package, with guess for prefix} [list $dll $loaded] { loadIfNotPresent pkga list [pkga_eq abc def] [lsort [info commands pkga_*]] } {0 {pkga_eq pkga_quote}} -test unload-2.2 {basic loading of unloadable package, with guess for prefix} [list $dll $loaded deprecated] { +test unload-2.2 {basic loading of unloadable package, with guess for prefix} [list $dll $loaded] { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ - [load [file join $testDir pkgua$ext]] \ + [load [file join $testDir tcl9pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } {{} {} {} {} 0 {pkgua_eq pkgua_quote} . {} {}} test unload-2.3 {basic unloading of non-unloadable package, with guess for prefix} -setup { loadIfNotPresent pkga } -constraints [list $dll $loaded] -returnCodes error -match glob -body { - unload [file join $testDir pkga$ext] + unload [file join $testDir tcl9pkga$ext] } -result {file "*" cannot be unloaded under a trusted interpreter} test unload-2.4 {basic unloading of unloadable package, with guess for prefix} -setup { loadIfNotPresent pkgua } -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ - [unload [file join $testDir pkgua$ext]] \ + [unload [file join $testDir tcl9pkgua$ext]] \ [info commands pkgua_*] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } -result {. {} {} {} {} . . .} test unload-2.5 {reloading of unloaded package, with guess for prefix} -setup { if {$pkgua_loaded eq ""} { loadIfNotPresent pkgua - unload [file join $testDir pkgua$ext] + unload [file join $testDir tcl9pkgua$ext] } -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ - [load [file join $testDir pkgua$ext]] \ + [load [file join $testDir tcl9pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } -result {. . . {} 0 {pkgua_eq pkgua_quote} .. . .} @@ -115,12 +115,12 @@ test unload-2.6 {basic unloading of re-loaded package, with guess for prefix} -s # Establish expected state if {$pkgua_loaded eq ""} { loadIfNotPresent pkgua - unload [file join $testDir pkgua$ext] - load [file join $testDir pkgua$ext] + unload [file join $testDir tcl9pkgua$ext] + load [file join $testDir tcl9pkgua$ext] } -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ - [unload [file join $testDir pkgua$ext]] \ + [unload [file join $testDir tcl9pkgua$ext]] \ [info commands pkgua_*] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } -result {.. . . {} {} .. .. ..} @@ -135,14 +135,14 @@ child eval { test unload-3.1 {basic loading of non-unloadable package in a safe interpreter} \ [list $dll $loaded] { catch {rename pkgb_sub {}} - load [file join $testDir pkgb$ext] Pkgb child + load [file join $testDir tcl9pkgb$ext] Pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} test unload-3.2 {basic loading of unloadable package in a safe interpreter} \ - [list $dll $loaded deprecated] { + [list $dll $loaded] { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pkgua child] \ + [load [file join $testDir tcl9pkgua$ext] Pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -150,46 +150,46 @@ test unload-3.2 {basic loading of unloadable package in a safe interpreter} \ test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} -setup { loadIfNotPresent pkga } -constraints [list $dll $loaded] -returnCodes error -match glob -body { - unload [file join $testDir pkga$ext] {} child + unload [file join $testDir tcl9pkga$ext] {} child } -result {file "*" has never been loaded in this interpreter} test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for prefix} -setup { if {[lsearch -index 1 [info loaded child] Pkgb] < 0} { - load [file join $testDir pkgb$ext] Pkgb child + load [file join $testDir tcl9pkgb$ext] Pkgb child } } -constraints [list $dll $loaded] -returnCodes error -match glob -body { - unload [file join $testDir pkgb$ext] {} child + unload [file join $testDir tcl9pkgb$ext] {} child } -result {file "*" cannot be unloaded under a safe interpreter} test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for prefix} -setup { if {[lsearch -index 1 [info loaded child] Pkgua] < 0} { - load [file join $testDir pkgua$ext] Pkgua child + load [file join $testDir tcl9pkgua$ext] Pkgua child } } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [unload [file join $testDir pkgua$ext] {} child] \ + [unload [file join $testDir tcl9pkgua$ext] {} child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{. {} {}} {} {} {. . .}} test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for prefix} -setup { if {[child eval set pkgua_loaded] eq ""} { - load [file join $testDir pkgua$ext] {} child - unload [file join $testDir pkgua$ext] {} child + load [file join $testDir tcl9pkgua$ext] {} child + unload [file join $testDir tcl9pkgua$ext] {} child } -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] {} child] \ + [load [file join $testDir tcl9pkgua$ext] {} child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}} test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with prefix conversion} -setup { if {[child eval set pkgua_loaded] eq ""} { - load [file join $testDir pkgua$ext] {} child - unload [file join $testDir pkgua$ext] {} child - load [file join $testDir pkgua$ext] {} child + load [file join $testDir tcl9pkgua$ext] {} child + unload [file join $testDir tcl9pkgua$ext] {} child + load [file join $testDir tcl9pkgua$ext] {} child } -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [unload [file join $testDir pkgua$ext] pKgUa child] \ + [unload [file join $testDir tcl9pkgua$ext] Pkgua child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{.. . .} {} {} {.. .. ..}} @@ -208,9 +208,9 @@ test unload-4.1 {loading of unloadable package in trusted interpreter, with gues set pkgua_detached "" set pkgua_unloaded "" incr load(M) -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \ - [load [file join $testDir pkgua$ext]] \ + [load [file join $testDir tcl9pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] } -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} @@ -222,9 +222,9 @@ test unload-4.2 {basic loading of unloadable package in a safe interpreter} -set set pkgua_unloaded "" } incr load(C) -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pkgua child] \ + [load [file join $testDir tcl9pkgua$ext] Pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -232,9 +232,9 @@ test unload-4.2 {basic loading of unloadable package in a safe interpreter} -set ## Load package in child-trusted interpreter... test unload-4.3 {basic loading of unloadable package in a second trusted interpreter} -setup { incr load(T) -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pkgua child-trusted] \ + [load [file join $testDir tcl9pkgua$ext] Pkgua child-trusted] \ [child-trusted eval pkgua_eq abc def] \ [lsort [child-trusted eval info commands pkgua_*]] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -242,45 +242,45 @@ test unload-4.3 {basic loading of unloadable package in a second trusted interpr ## Unload the package from the main trusted interpreter... test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for prefix} -setup { if {!$load(M)} { - load [file join $testDir pkgua$ext] + load [file join $testDir tcl9pkgua$ext] } if {!$load(C)} { - load [file join $testDir pkgua$ext] {} child + load [file join $testDir tcl9pkgua$ext] {} child incr load(C) } if {!$load(T)} { - load [file join $testDir pkgua$ext] {} child-trusted + load [file join $testDir tcl9pkgua$ext] {} child-trusted incr load(T) } -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \ - [unload [file join $testDir pkgua$ext]] \ + [unload [file join $testDir tcl9pkgua$ext]] \ [info commands pkgua_*] \ [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] } -result {{. {} {}} {} {} {. . {}}} ## Unload the package from the child safe interpreter... test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup { if {!$load(C)} { - load [file join $testDir pkgua$ext] {} child + load [file join $testDir tcl9pkgua$ext] {} child } if {!$load(T)} { - load [file join $testDir pkgua$ext] {} child-trusted + load [file join $testDir tcl9pkgua$ext] {} child-trusted incr load(T) } -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [unload [file join $testDir pkgua$ext] {} child] \ + [unload [file join $testDir tcl9pkgua$ext] {} child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{. {} {}} {} {} {. . {}}} ## Unload the package from the child trusted interpreter... test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup { if {!$load(T)} { - load [file join $testDir pkgua$ext] {} child-trusted + load [file join $testDir tcl9pkgua$ext] {} child-trusted } } -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [unload [file join $testDir pkgua$ext] {} child-trusted] \ + [unload [file join $testDir tcl9pkgua$ext] {} child-trusted] \ [child-trusted eval info commands pkgua_*] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{. {} {}} {} {} {. . .}} @@ -291,10 +291,10 @@ test unload-5.1 {unload a module loaded from vfs} \ set dir [pwd] cd $testDir testsimplefilesystem 1 - load simplefs:/pkgua$ext pkgua + load simplefs:/tcl9pkgua$ext Pkgua } \ -body { - list [catch {unload simplefs:/pkgua$ext} msg] $msg + list [catch {unload simplefs:/tcl9pkgua$ext} msg] $msg } \ -result {0 {}} diff --git a/tests/upvar.test b/tests/upvar.test index 8a1319e..a394f4d 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -207,6 +207,67 @@ test upvar-5.3 {traces involving upvars} { p1 foo bar set x } {{x1 {} unset} x1} +test upvar-5.4 {read trace on upvar array element} -body { + proc p1 {a b} { + array set foo {c 22 d 33} + trace add variable foo {read write unset} tproc + p2 + trace remove variable foo {read write unset} tproc + } + proc p2 {} { + upvar foo(c) x1 + set x1 + } + set x --- + p1 foo bar + set x +} -result {{x1 c read} x1} +test upvar-5.5 {write trace on upvar array element} -body { + proc p1 {a b} { + array set foo {c 22 d 33} + trace add variable foo {read write unset} tproc + p2 + trace remove variable foo {read write unset} tproc + } + proc p2 {} { + upvar foo(c) x1 + set x1 22 + } + set x --- + p1 foo bar + set x +} -result {{x1 c write} x1} +test upvar-5.6 {unset trace on upvar array element} -body { + proc p1 {a b} { + array set foo {c 22 d 33} + trace add variable foo {read write unset} tproc + p2 + trace remove variable foo {read write unset} tproc + } + proc p2 {} { + upvar foo(c) x1 + unset x1 + } + set x --- + p1 foo bar + set x +} -result {{x1 c unset} x1} +test upvar-5.7 {trace on non-existent upvar array element} -body { + proc p1 {a b} { + array set foo {} + trace add variable foo {read write unset} tproc + p2 + trace remove variable foo {read write unset} tproc + return [array get foo] + } + proc p2 {} { + upvar foo(hi) x1 + set x1 there + } + set x --- + lappend x [p1 foo bar] + set x +} -result {{x1 hi write} x1 {hi there}} test upvar-6.1 {retargeting an upvar} { proc p1 {} { diff --git a/tests/utf.test b/tests/utf.test index edb01c1..f3242b6 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -16,8 +16,6 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] -source [file join [file dirname [info script]] tcltests.tcl] - testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testfindfirst [llength [info commands testfindfirst]] testConstraint testfindlast [llength [info commands testfindlast]] @@ -49,7 +47,7 @@ test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { expr {[format %c -1] eq [testbytestring \xEF\xBF\xBD]} } 1 -test utf-1.7.0 {Tcl_UniCharToUtf: 4 byte sequences} {testbytestring} { +test utf-1.7 {Tcl_UniCharToUtf: 4 byte sequences} testbytestring { expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]} } 1 test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring { @@ -64,11 +62,11 @@ test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring { expr {[format %c 0xDC42] eq [testbytestring \xED\xB1\x82]} } 1 -test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {testbytestring} { - expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]} +test utf-1.12 {Tcl_UniCharToUtf: Invalid surrogate} testbytestring { + expr {"\UD842" eq [testbytestring \xED\xA1\x82]} } 1 -test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} {testbytestring} { - expr {"\UD842" eq [testbytestring \xEF\xBF\xBD]} +test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} { + expr {"\UD842" eq "\uD842"} } 1 test utf-1.14 {Tcl_UniCharToUtf: surrogate pairs from concat} { set lo \uDE02 @@ -165,9 +163,9 @@ test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars t test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1 } 3 -test utf-4.12 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring deprecated} { +test utf-4.12 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end -} 2 +} 1 test utf-4.13 {Tcl_NumUtfChars: end of string} {testnumutfchars testbytestring} { testnumutfchars foobar[testbytestring \xF2\xC2\xA0] end } 8 @@ -533,13 +531,13 @@ test utf-7.9.1 {Tcl_UtfPrev} {testutfprev testbytestring} { test utf-7.9.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xF8\xA0] 3 } 2 -test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring} { +test utf-7.10 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0] } 1 -test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring} { +test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3 } 1 -test utf-7.10.3 {Tcl_UtfPrev} {testutfprev testbytestring} { +test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3 } 1 test utf-7.11 {Tcl_UtfPrev} {testutfprev testbytestring} { @@ -581,13 +579,13 @@ test utf-7.14.1 {Tcl_UtfPrev} {testutfprev testbytestring} { test utf-7.14.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xA0\xF8] 4 } 3 -test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring} { +test utf-7.15 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xA0] } 1 -test utf-7.15.3 {Tcl_UtfPrev} {testutfprev testbytestring} { +test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4 } 1 -test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring} { +test utf-7.15.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4 } 1 test utf-7.16 {Tcl_UtfPrev} testutfprev { @@ -716,7 +714,7 @@ test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} tes test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} { testutfprev [testbytestring \xE8\xA0\x00] 2 } 0 -test utf-7.48 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { +test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] } 1 test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { @@ -728,7 +726,7 @@ test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbyte test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 2 } 1 -test utf-7.49 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { +test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { testutfprev A[testbytestring \xF4\x90\x80\x80] } 4 test utf-7.49.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { @@ -819,10 +817,10 @@ test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring { test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring { expr {"\u4E216" eq "[testbytestring \xE4\xB8\xA1]6"} } 1 -test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} {testbytestring} { +test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} testbytestring { expr {"\U1E2165" eq "[testbytestring \xF0\x9E\x88\x96]5"} } 1 -test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} {testbytestring} { +test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} testbytestring { expr {"\U10E2165" eq "[testbytestring \xF4\x8E\x88\x96]5"} } 1 diff --git a/tests/utfext.test b/tests/utfext.test index d2da50b..fd82b16 100644 --- a/tests/utfext.test +++ b/tests/utfext.test @@ -66,7 +66,7 @@ foreach {enc utfhex hex} $utfExtMap { # Test for insufficient space test xx-bufferoverflow {buffer overflow Tcl_ExternalToUtf} -body { - testencoding Tcl_UtfToExternal ucs-2 A {start end} {} 1 + testencoding Tcl_UtfToExternal utf-16 A {start end} {} 1 } -result [list nospace {} \xFF] -constraints testencoding # Another bug - char limit not obeyed @@ -75,10 +75,10 @@ test xx-bufferoverflow {buffer overflow Tcl_ExternalToUtf} -body { # nospace {} abcÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ test TableToUtf-bug-5be203d6ca {Bug 5be203d6ca - truncated prefix in table encoding} -body { - set src \x82\x4f\x82\x50\x82 - lassign [testencoding Tcl_ExternalToUtf shiftjis $src {start} 0 16 srcRead dstWritten charsWritten] buf - set result [list [testencoding Tcl_ExternalToUtf shiftjis $src {start} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten] - lappend result {*}[list [testencoding Tcl_ExternalToUtf shiftjis [string range $src $srcRead end] {end} 0 10 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten] + set src \x82\x4F\x82\x50\x82 + lassign [testencoding Tcl_ExternalToUtf shiftjis $src {start profiletcl8} 0 16 srcRead dstWritten charsWritten] buf + set result [list [testencoding Tcl_ExternalToUtf shiftjis $src {start profiletcl8} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten] + lappend result {*}[list [testencoding Tcl_ExternalToUtf shiftjis [string range $src $srcRead end] {end profiletcl8} 0 10 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten] } -result [list [list multibyte 0 \xEF\xBC\x90\xEF\xBC\x91\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 4 6 2 [list ok 0 \xC2\x82\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 1 2 1] -constraints testencoding diff --git a/tests/util.test b/tests/util.test index c3b9f2d..ec79336 100644 --- a/tests/util.test +++ b/tests/util.test @@ -22,9 +22,6 @@ testConstraint testconcatobj [llength [info commands testconcatobj]] testConstraint testdoubledigits [llength [info commands testdoubledigits]] testConstraint testprint [llength [info commands testprint]] -testConstraint precision [expr {![catch {set saved_precision $::tcl_precision}]}] - - # Big test for correct ordering of data in [expr] proc testIEEE {} { @@ -395,38 +392,6 @@ test util-5.52 {Tcl_StringMatch} { } 0 -test util-6.1 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { - set old_precision $::tcl_precision - set ::tcl_precision 12 -} -body { - concat x[expr {1.4}] -} -cleanup { - set ::tcl_precision $old_precision -} -result {x1.4} -test util-6.2 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { - set old_precision $::tcl_precision - set ::tcl_precision 12 -} -body { - concat x[expr {1.39999999999}] -} -cleanup { - set ::tcl_precision $old_precision -} -result {x1.39999999999} -test util-6.3 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { - set old_precision $::tcl_precision - set ::tcl_precision 12 -} -body { - concat x[expr {1.399999999999}] -} -cleanup { - set ::tcl_precision $old_precision -} -result {x1.4} -test util-6.4 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { - set old_precision $::tcl_precision - set ::tcl_precision 5 -} -body { - concat x[expr {1.123412341234}] -} -cleanup { - set tcl_precision $old_precision -} -result {x1.1234} test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr {2.0}] } {x2.0} @@ -434,50 +399,6 @@ test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr {3.0e98}] } {x3e+98} -test util-7.1 {TclPrecTraceProc - unset callbacks} -constraints precision -setup { - set old_precision $::tcl_precision -} -body { - set tcl_precision 7 - set x $tcl_precision - unset tcl_precision - list $x $tcl_precision -} -cleanup { - set ::tcl_precision $old_precision -} -result {7 7} -test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -constraints precision -setup { - set old_precision $::tcl_precision -} -body { - set tcl_precision 12 - interp create child - set x [child eval set tcl_precision] - child eval {set tcl_precision 6} - interp delete child - list $x $tcl_precision -} -cleanup { - set ::tcl_precision $old_precision -} -result {12 6} -test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -constraints precision -setup { - set old_precision $::tcl_precision -} -body { - set tcl_precision 12 - interp create -safe child - set x [child eval { - list [catch {set tcl_precision 8} msg] $msg - }] - interp delete child - list $x $tcl_precision -} -cleanup { - set ::tcl_precision $old_precision -} -result {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12} -test util-7.4 {TclPrecTraceProc - write traces, bogus values} -constraints precision -setup { - set old_precision $::tcl_precision -} -body { - set tcl_precision 12 - list [catch {set tcl_precision abc} msg] $msg $tcl_precision -} -cleanup { - set ::tcl_precision $old_precision -} -result {1 {can't set "tcl_precision": improper value for precision} 12} - # This test always succeeded in the C locale anyway... test util-8.1 {TclNeedSpace - correct utf-8 handling} { # Bug 411825 @@ -2233,1874 +2154,6 @@ test util-15.8 {smallest normal} {*}{ } } -foreach ::tcl_precision {0 12} { - for {set e -312} {$e < -9} {incr e} { - test util-16.1.$::tcl_precision.$e {shortening of numbers} \ - "expr {1.1e$e}" 1.1e$e - } -} -set tcl_precision 0 -for {set e -9} {$e < -4} {incr e} { - test util-16.1.$::tcl_precision.$e {shortening of numbers} \ - "expr {1.1e$e}" 1.1e$e -} -set tcl_precision 12 -for {set e -9} {$e < -4} {incr e} { - test util-16.1.$::tcl_precision.$e {8.4 compatible formatting of doubles} precision \ - "expr {1.1e$e}" 1.1e[format %+03d $e] -} -foreach ::tcl_precision {0 12} { - test util-16.1.$::tcl_precision.-4 {shortening of numbers} \ - {expr {1.1e-4}} \ - 0.00011 - test util-16.1.$::tcl_precision.-3 {shortening of numbers} \ - {expr {1.1e-3}} \ - 0.0011 - test util-16.1.$::tcl_precision.-2 {shortening of numbers} \ - {expr {1.1e-2}} \ - 0.011 - test util-16.1.$::tcl_precision.-1 {shortening of numbers} \ - {expr {1.1e-1}} \ - 0.11 - test util-16.1.$::tcl_precision.0 {shortening of numbers} \ - {expr {1.1}} \ - 1.1 - for {set e 1} {$e < 17} {incr e} { - test util-16.1.$::tcl_precision.$e {shortening of numbers} \ - "expr {11[string repeat 0 [expr {$e-1}]].0}" \ - 11[string repeat 0 [expr {$e-1}]].0 - } - for {set e 17} {$e < 309} {incr e} { - test util-16.1.$::tcl_precision.$e {shortening of numbers} \ - "expr {1.1e$e}" 1.1e+$e - } -} -set tcl_precision 17 -test util-16.1.17.-300 {8.4 compatible formatting of doubles} precision \ - {expr {1e-300}} \ - 1e-300 -test util-16.1.17.-299 {8.4 compatible formatting of doubles} precision \ - {expr {1e-299}} \ - 9.9999999999999999e-300 -test util-16.1.17.-298 {8.4 compatible formatting of doubles} precision \ - {expr {1e-298}} \ - 9.9999999999999991e-299 -test util-16.1.17.-297 {8.4 compatible formatting of doubles} precision \ - {expr {1e-297}} \ - 1e-297 -test util-16.1.17.-296 {8.4 compatible formatting of doubles} precision \ - {expr {1e-296}} \ - 1e-296 -test util-16.1.17.-295 {8.4 compatible formatting of doubles} precision \ - {expr {1e-295}} \ - 1.0000000000000001e-295 -test util-16.1.17.-294 {8.4 compatible formatting of doubles} precision \ - {expr {1e-294}} \ - 1e-294 -test util-16.1.17.-293 {8.4 compatible formatting of doubles} precision \ - {expr {1e-293}} \ - 1.0000000000000001e-293 -test util-16.1.17.-292 {8.4 compatible formatting of doubles} precision \ - {expr {1e-292}} \ - 1.0000000000000001e-292 -test util-16.1.17.-291 {8.4 compatible formatting of doubles} precision \ - {expr {1e-291}} \ - 9.9999999999999996e-292 -test util-16.1.17.-290 {8.4 compatible formatting of doubles} precision \ - {expr {1e-290}} \ - 1.0000000000000001e-290 -test util-16.1.17.-289 {8.4 compatible formatting of doubles} precision \ - {expr {1e-289}} \ - 1e-289 -test util-16.1.17.-288 {8.4 compatible formatting of doubles} precision \ - {expr {1e-288}} \ - 1.0000000000000001e-288 -test util-16.1.17.-287 {8.4 compatible formatting of doubles} precision \ - {expr {1e-287}} \ - 1e-287 -test util-16.1.17.-286 {8.4 compatible formatting of doubles} precision \ - {expr {1e-286}} \ - 1.0000000000000001e-286 -test util-16.1.17.-285 {8.4 compatible formatting of doubles} precision \ - {expr {1e-285}} \ - 1.0000000000000001e-285 -test util-16.1.17.-284 {8.4 compatible formatting of doubles} precision \ - {expr {1e-284}} \ - 1e-284 -test util-16.1.17.-283 {8.4 compatible formatting of doubles} precision \ - {expr {1e-283}} \ - 9.9999999999999995e-284 -test util-16.1.17.-282 {8.4 compatible formatting of doubles} precision \ - {expr {1e-282}} \ - 1e-282 -test util-16.1.17.-281 {8.4 compatible formatting of doubles} precision \ - {expr {1e-281}} \ - 1e-281 -test util-16.1.17.-280 {8.4 compatible formatting of doubles} precision \ - {expr {1e-280}} \ - 9.9999999999999996e-281 -test util-16.1.17.-279 {8.4 compatible formatting of doubles} precision \ - {expr {1e-279}} \ - 1.0000000000000001e-279 -test util-16.1.17.-278 {8.4 compatible formatting of doubles} precision \ - {expr {1e-278}} \ - 9.9999999999999994e-279 -test util-16.1.17.-277 {8.4 compatible formatting of doubles} precision \ - {expr {1e-277}} \ - 9.9999999999999997e-278 -test util-16.1.17.-276 {8.4 compatible formatting of doubles} precision \ - {expr {1e-276}} \ - 1.0000000000000001e-276 -test util-16.1.17.-275 {8.4 compatible formatting of doubles} precision \ - {expr {1e-275}} \ - 9.9999999999999993e-276 -test util-16.1.17.-274 {8.4 compatible formatting of doubles} precision \ - {expr {1e-274}} \ - 9.9999999999999997e-275 -test util-16.1.17.-273 {8.4 compatible formatting of doubles} precision \ - {expr {1e-273}} \ - 1.0000000000000001e-273 -test util-16.1.17.-272 {8.4 compatible formatting of doubles} precision \ - {expr {1e-272}} \ - 9.9999999999999993e-273 -test util-16.1.17.-271 {8.4 compatible formatting of doubles} precision \ - {expr {1e-271}} \ - 9.9999999999999996e-272 -test util-16.1.17.-270 {8.4 compatible formatting of doubles} precision \ - {expr {1e-270}} \ - 1e-270 -test util-16.1.17.-269 {8.4 compatible formatting of doubles} precision \ - {expr {1e-269}} \ - 9.9999999999999996e-270 -test util-16.1.17.-268 {8.4 compatible formatting of doubles} precision \ - {expr {1e-268}} \ - 9.9999999999999996e-269 -test util-16.1.17.-267 {8.4 compatible formatting of doubles} precision \ - {expr {1e-267}} \ - 9.9999999999999998e-268 -test util-16.1.17.-266 {8.4 compatible formatting of doubles} precision \ - {expr {1e-266}} \ - 9.9999999999999998e-267 -test util-16.1.17.-265 {8.4 compatible formatting of doubles} precision \ - {expr {1e-265}} \ - 9.9999999999999998e-266 -test util-16.1.17.-264 {8.4 compatible formatting of doubles} precision \ - {expr {1e-264}} \ - 1e-264 -test util-16.1.17.-263 {8.4 compatible formatting of doubles} precision \ - {expr {1e-263}} \ - 1e-263 -test util-16.1.17.-262 {8.4 compatible formatting of doubles} precision \ - {expr {1e-262}} \ - 1e-262 -test util-16.1.17.-261 {8.4 compatible formatting of doubles} precision \ - {expr {1e-261}} \ - 9.9999999999999998e-262 -test util-16.1.17.-260 {8.4 compatible formatting of doubles} precision \ - {expr {1e-260}} \ - 9.9999999999999996e-261 -test util-16.1.17.-259 {8.4 compatible formatting of doubles} precision \ - {expr {1e-259}} \ - 1.0000000000000001e-259 -test util-16.1.17.-258 {8.4 compatible formatting of doubles} precision \ - {expr {1e-258}} \ - 9.9999999999999995e-259 -test util-16.1.17.-257 {8.4 compatible formatting of doubles} precision \ - {expr {1e-257}} \ - 9.9999999999999998e-258 -test util-16.1.17.-256 {8.4 compatible formatting of doubles} precision \ - {expr {1e-256}} \ - 9.9999999999999998e-257 -test util-16.1.17.-255 {8.4 compatible formatting of doubles} precision \ - {expr {1e-255}} \ - 1e-255 -test util-16.1.17.-254 {8.4 compatible formatting of doubles} precision \ - {expr {1e-254}} \ - 9.9999999999999991e-255 -test util-16.1.17.-253 {8.4 compatible formatting of doubles} precision \ - {expr {1e-253}} \ - 1.0000000000000001e-253 -test util-16.1.17.-252 {8.4 compatible formatting of doubles} precision \ - {expr {1e-252}} \ - 9.9999999999999994e-253 -test util-16.1.17.-251 {8.4 compatible formatting of doubles} precision \ - {expr {1e-251}} \ - 1e-251 -test util-16.1.17.-250 {8.4 compatible formatting of doubles} precision \ - {expr {1e-250}} \ - 1.0000000000000001e-250 -test util-16.1.17.-249 {8.4 compatible formatting of doubles} precision \ - {expr {1e-249}} \ - 1.0000000000000001e-249 -test util-16.1.17.-248 {8.4 compatible formatting of doubles} precision \ - {expr {1e-248}} \ - 9.9999999999999998e-249 -test util-16.1.17.-247 {8.4 compatible formatting of doubles} precision \ - {expr {1e-247}} \ - 1e-247 -test util-16.1.17.-246 {8.4 compatible formatting of doubles} precision \ - {expr {1e-246}} \ - 9.9999999999999996e-247 -test util-16.1.17.-245 {8.4 compatible formatting of doubles} precision \ - {expr {1e-245}} \ - 9.9999999999999993e-246 -test util-16.1.17.-244 {8.4 compatible formatting of doubles} precision \ - {expr {1e-244}} \ - 9.9999999999999993e-245 -test util-16.1.17.-243 {8.4 compatible formatting of doubles} precision \ - {expr {1e-243}} \ - 1e-243 -test util-16.1.17.-242 {8.4 compatible formatting of doubles} precision \ - {expr {1e-242}} \ - 9.9999999999999997e-243 -test util-16.1.17.-241 {8.4 compatible formatting of doubles} precision \ - {expr {1e-241}} \ - 9.9999999999999997e-242 -test util-16.1.17.-240 {8.4 compatible formatting of doubles} precision \ - {expr {1e-240}} \ - 9.9999999999999997e-241 -test util-16.1.17.-239 {8.4 compatible formatting of doubles} precision \ - {expr {1e-239}} \ - 1.0000000000000001e-239 -test util-16.1.17.-238 {8.4 compatible formatting of doubles} precision \ - {expr {1e-238}} \ - 9.9999999999999999e-239 -test util-16.1.17.-237 {8.4 compatible formatting of doubles} precision \ - {expr {1e-237}} \ - 9.9999999999999999e-238 -test util-16.1.17.-236 {8.4 compatible formatting of doubles} precision \ - {expr {1e-236}} \ - 1e-236 -test util-16.1.17.-235 {8.4 compatible formatting of doubles} precision \ - {expr {1e-235}} \ - 9.9999999999999996e-236 -test util-16.1.17.-234 {8.4 compatible formatting of doubles} precision \ - {expr {1e-234}} \ - 9.9999999999999996e-235 -test util-16.1.17.-233 {8.4 compatible formatting of doubles} precision \ - {expr {1e-233}} \ - 9.9999999999999996e-234 -test util-16.1.17.-232 {8.4 compatible formatting of doubles} precision \ - {expr {1e-232}} \ - 1e-232 -test util-16.1.17.-231 {8.4 compatible formatting of doubles} precision \ - {expr {1e-231}} \ - 9.9999999999999999e-232 -test util-16.1.17.-230 {8.4 compatible formatting of doubles} precision \ - {expr {1e-230}} \ - 1e-230 -test util-16.1.17.-229 {8.4 compatible formatting of doubles} precision \ - {expr {1e-229}} \ - 1.0000000000000001e-229 -test util-16.1.17.-228 {8.4 compatible formatting of doubles} precision \ - {expr {1e-228}} \ - 1e-228 -test util-16.1.17.-227 {8.4 compatible formatting of doubles} precision \ - {expr {1e-227}} \ - 9.9999999999999994e-228 -test util-16.1.17.-226 {8.4 compatible formatting of doubles} precision \ - {expr {1e-226}} \ - 9.9999999999999992e-227 -test util-16.1.17.-225 {8.4 compatible formatting of doubles} precision \ - {expr {1e-225}} \ - 9.9999999999999996e-226 -test util-16.1.17.-224 {8.4 compatible formatting of doubles} precision \ - {expr {1e-224}} \ - 1e-224 -test util-16.1.17.-223 {8.4 compatible formatting of doubles} precision \ - {expr {1e-223}} \ - 9.9999999999999997e-224 -test util-16.1.17.-222 {8.4 compatible formatting of doubles} precision \ - {expr {1e-222}} \ - 1e-222 -test util-16.1.17.-221 {8.4 compatible formatting of doubles} precision \ - {expr {1e-221}} \ - 1e-221 -test util-16.1.17.-220 {8.4 compatible formatting of doubles} precision \ - {expr {1e-220}} \ - 9.9999999999999999e-221 -test util-16.1.17.-219 {8.4 compatible formatting of doubles} precision \ - {expr {1e-219}} \ - 1e-219 -test util-16.1.17.-218 {8.4 compatible formatting of doubles} precision \ - {expr {1e-218}} \ - 1e-218 -test util-16.1.17.-217 {8.4 compatible formatting of doubles} precision \ - {expr {1e-217}} \ - 1.0000000000000001e-217 -test util-16.1.17.-216 {8.4 compatible formatting of doubles} precision \ - {expr {1e-216}} \ - 1e-216 -test util-16.1.17.-215 {8.4 compatible formatting of doubles} precision \ - {expr {1e-215}} \ - 1e-215 -test util-16.1.17.-214 {8.4 compatible formatting of doubles} precision \ - {expr {1e-214}} \ - 9.9999999999999991e-215 -test util-16.1.17.-213 {8.4 compatible formatting of doubles} precision \ - {expr {1e-213}} \ - 9.9999999999999995e-214 -test util-16.1.17.-212 {8.4 compatible formatting of doubles} precision \ - {expr {1e-212}} \ - 9.9999999999999995e-213 -test util-16.1.17.-211 {8.4 compatible formatting of doubles} precision \ - {expr {1e-211}} \ - 1.0000000000000001e-211 -test util-16.1.17.-210 {8.4 compatible formatting of doubles} precision \ - {expr {1e-210}} \ - 1e-210 -test util-16.1.17.-209 {8.4 compatible formatting of doubles} precision \ - {expr {1e-209}} \ - 1e-209 -test util-16.1.17.-208 {8.4 compatible formatting of doubles} precision \ - {expr {1e-208}} \ - 1.0000000000000001e-208 -test util-16.1.17.-207 {8.4 compatible formatting of doubles} precision \ - {expr {1e-207}} \ - 9.9999999999999993e-208 -test util-16.1.17.-206 {8.4 compatible formatting of doubles} precision \ - {expr {1e-206}} \ - 1e-206 -test util-16.1.17.-205 {8.4 compatible formatting of doubles} precision \ - {expr {1e-205}} \ - 1e-205 -test util-16.1.17.-204 {8.4 compatible formatting of doubles} precision \ - {expr {1e-204}} \ - 1e-204 -test util-16.1.17.-203 {8.4 compatible formatting of doubles} precision \ - {expr {1e-203}} \ - 1e-203 -test util-16.1.17.-202 {8.4 compatible formatting of doubles} precision \ - {expr {1e-202}} \ - 1e-202 -test util-16.1.17.-201 {8.4 compatible formatting of doubles} precision \ - {expr {1e-201}} \ - 9.9999999999999995e-202 -test util-16.1.17.-200 {8.4 compatible formatting of doubles} precision \ - {expr {1e-200}} \ - 9.9999999999999998e-201 -test util-16.1.17.-199 {8.4 compatible formatting of doubles} precision \ - {expr {1e-199}} \ - 9.9999999999999998e-200 -test util-16.1.17.-198 {8.4 compatible formatting of doubles} precision \ - {expr {1e-198}} \ - 9.9999999999999991e-199 -test util-16.1.17.-197 {8.4 compatible formatting of doubles} precision \ - {expr {1e-197}} \ - 9.9999999999999999e-198 -test util-16.1.17.-196 {8.4 compatible formatting of doubles} precision \ - {expr {1e-196}} \ - 1e-196 -test util-16.1.17.-195 {8.4 compatible formatting of doubles} precision \ - {expr {1e-195}} \ - 1.0000000000000001e-195 -test util-16.1.17.-194 {8.4 compatible formatting of doubles} precision \ - {expr {1e-194}} \ - 1e-194 -test util-16.1.17.-193 {8.4 compatible formatting of doubles} precision \ - {expr {1e-193}} \ - 1e-193 -test util-16.1.17.-192 {8.4 compatible formatting of doubles} precision \ - {expr {1e-192}} \ - 1.0000000000000001e-192 -test util-16.1.17.-191 {8.4 compatible formatting of doubles} precision \ - {expr {1e-191}} \ - 1e-191 -test util-16.1.17.-190 {8.4 compatible formatting of doubles} precision \ - {expr {1e-190}} \ - 1e-190 -test util-16.1.17.-189 {8.4 compatible formatting of doubles} precision \ - {expr {1e-189}} \ - 1.0000000000000001e-189 -test util-16.1.17.-188 {8.4 compatible formatting of doubles} precision \ - {expr {1e-188}} \ - 9.9999999999999995e-189 -test util-16.1.17.-187 {8.4 compatible formatting of doubles} precision \ - {expr {1e-187}} \ - 1e-187 -test util-16.1.17.-186 {8.4 compatible formatting of doubles} precision \ - {expr {1e-186}} \ - 9.9999999999999991e-187 -test util-16.1.17.-185 {8.4 compatible formatting of doubles} precision \ - {expr {1e-185}} \ - 9.9999999999999999e-186 -test util-16.1.17.-184 {8.4 compatible formatting of doubles} precision \ - {expr {1e-184}} \ - 1.0000000000000001e-184 -test util-16.1.17.-183 {8.4 compatible formatting of doubles} precision \ - {expr {1e-183}} \ - 1e-183 -test util-16.1.17.-182 {8.4 compatible formatting of doubles} precision \ - {expr {1e-182}} \ - 1e-182 -test util-16.1.17.-181 {8.4 compatible formatting of doubles} precision \ - {expr {1e-181}} \ - 1e-181 -test util-16.1.17.-180 {8.4 compatible formatting of doubles} precision \ - {expr {1e-180}} \ - 1e-180 -test util-16.1.17.-179 {8.4 compatible formatting of doubles} precision \ - {expr {1e-179}} \ - 1e-179 -test util-16.1.17.-178 {8.4 compatible formatting of doubles} precision \ - {expr {1e-178}} \ - 9.9999999999999995e-179 -test util-16.1.17.-177 {8.4 compatible formatting of doubles} precision \ - {expr {1e-177}} \ - 9.9999999999999995e-178 -test util-16.1.17.-176 {8.4 compatible formatting of doubles} precision \ - {expr {1e-176}} \ - 1e-176 -test util-16.1.17.-175 {8.4 compatible formatting of doubles} precision \ - {expr {1e-175}} \ - 1e-175 -test util-16.1.17.-174 {8.4 compatible formatting of doubles} precision \ - {expr {1e-174}} \ - 1e-174 -test util-16.1.17.-173 {8.4 compatible formatting of doubles} precision \ - {expr {1e-173}} \ - 1e-173 -test util-16.1.17.-172 {8.4 compatible formatting of doubles} precision \ - {expr {1e-172}} \ - 1e-172 -test util-16.1.17.-171 {8.4 compatible formatting of doubles} precision \ - {expr {1e-171}} \ - 9.9999999999999998e-172 -test util-16.1.17.-170 {8.4 compatible formatting of doubles} precision \ - {expr {1e-170}} \ - 9.9999999999999998e-171 -test util-16.1.17.-169 {8.4 compatible formatting of doubles} precision \ - {expr {1e-169}} \ - 1e-169 -test util-16.1.17.-168 {8.4 compatible formatting of doubles} precision \ - {expr {1e-168}} \ - 1e-168 -test util-16.1.17.-167 {8.4 compatible formatting of doubles} precision \ - {expr {1e-167}} \ - 1e-167 -test util-16.1.17.-166 {8.4 compatible formatting of doubles} precision \ - {expr {1e-166}} \ - 1e-166 -test util-16.1.17.-165 {8.4 compatible formatting of doubles} precision \ - {expr {1e-165}} \ - 1e-165 -test util-16.1.17.-164 {8.4 compatible formatting of doubles} precision \ - {expr {1e-164}} \ - 9.9999999999999996e-165 -test util-16.1.17.-163 {8.4 compatible formatting of doubles} precision \ - {expr {1e-163}} \ - 9.9999999999999992e-164 -test util-16.1.17.-162 {8.4 compatible formatting of doubles} precision \ - {expr {1e-162}} \ - 9.9999999999999995e-163 -test util-16.1.17.-161 {8.4 compatible formatting of doubles} precision \ - {expr {1e-161}} \ - 1e-161 -test util-16.1.17.-160 {8.4 compatible formatting of doubles} precision \ - {expr {1e-160}} \ - 9.9999999999999999e-161 -test util-16.1.17.-159 {8.4 compatible formatting of doubles} precision \ - {expr {1e-159}} \ - 9.9999999999999999e-160 -test util-16.1.17.-158 {8.4 compatible formatting of doubles} precision \ - {expr {1e-158}} \ - 1.0000000000000001e-158 -test util-16.1.17.-157 {8.4 compatible formatting of doubles} precision \ - {expr {1e-157}} \ - 9.9999999999999994e-158 -test util-16.1.17.-156 {8.4 compatible formatting of doubles} precision \ - {expr {1e-156}} \ - 1e-156 -test util-16.1.17.-155 {8.4 compatible formatting of doubles} precision \ - {expr {1e-155}} \ - 1e-155 -test util-16.1.17.-154 {8.4 compatible formatting of doubles} precision \ - {expr {1e-154}} \ - 9.9999999999999997e-155 -test util-16.1.17.-153 {8.4 compatible formatting of doubles} precision \ - {expr {1e-153}} \ - 1e-153 -test util-16.1.17.-152 {8.4 compatible formatting of doubles} precision \ - {expr {1e-152}} \ - 1.0000000000000001e-152 -test util-16.1.17.-151 {8.4 compatible formatting of doubles} precision \ - {expr {1e-151}} \ - 9.9999999999999994e-152 -test util-16.1.17.-150 {8.4 compatible formatting of doubles} precision \ - {expr {1e-150}} \ - 1e-150 -test util-16.1.17.-149 {8.4 compatible formatting of doubles} precision \ - {expr {1e-149}} \ - 9.9999999999999998e-150 -test util-16.1.17.-148 {8.4 compatible formatting of doubles} precision \ - {expr {1e-148}} \ - 9.9999999999999994e-149 -test util-16.1.17.-147 {8.4 compatible formatting of doubles} precision \ - {expr {1e-147}} \ - 9.9999999999999997e-148 -test util-16.1.17.-146 {8.4 compatible formatting of doubles} precision \ - {expr {1e-146}} \ - 1e-146 -test util-16.1.17.-145 {8.4 compatible formatting of doubles} precision \ - {expr {1e-145}} \ - 9.9999999999999991e-146 -test util-16.1.17.-144 {8.4 compatible formatting of doubles} precision \ - {expr {1e-144}} \ - 9.9999999999999995e-145 -test util-16.1.17.-143 {8.4 compatible formatting of doubles} precision \ - {expr {1e-143}} \ - 9.9999999999999995e-144 -test util-16.1.17.-142 {8.4 compatible formatting of doubles} precision \ - {expr {1e-142}} \ - 1e-142 -test util-16.1.17.-141 {8.4 compatible formatting of doubles} precision \ - {expr {1e-141}} \ - 1e-141 -test util-16.1.17.-140 {8.4 compatible formatting of doubles} precision \ - {expr {1e-140}} \ - 9.9999999999999998e-141 -test util-16.1.17.-139 {8.4 compatible formatting of doubles} precision \ - {expr {1e-139}} \ - 1e-139 -test util-16.1.17.-138 {8.4 compatible formatting of doubles} precision \ - {expr {1e-138}} \ - 1.0000000000000001e-138 -test util-16.1.17.-137 {8.4 compatible formatting of doubles} precision \ - {expr {1e-137}} \ - 9.9999999999999998e-138 -test util-16.1.17.-136 {8.4 compatible formatting of doubles} precision \ - {expr {1e-136}} \ - 1e-136 -test util-16.1.17.-135 {8.4 compatible formatting of doubles} precision \ - {expr {1e-135}} \ - 1e-135 -test util-16.1.17.-134 {8.4 compatible formatting of doubles} precision \ - {expr {1e-134}} \ - 1e-134 -test util-16.1.17.-133 {8.4 compatible formatting of doubles} precision \ - {expr {1e-133}} \ - 1.0000000000000001e-133 -test util-16.1.17.-132 {8.4 compatible formatting of doubles} precision \ - {expr {1e-132}} \ - 9.9999999999999999e-133 -test util-16.1.17.-131 {8.4 compatible formatting of doubles} precision \ - {expr {1e-131}} \ - 9.9999999999999999e-132 -test util-16.1.17.-130 {8.4 compatible formatting of doubles} precision \ - {expr {1e-130}} \ - 1.0000000000000001e-130 -test util-16.1.17.-129 {8.4 compatible formatting of doubles} precision \ - {expr {1e-129}} \ - 9.9999999999999993e-130 -test util-16.1.17.-128 {8.4 compatible formatting of doubles} precision \ - {expr {1e-128}} \ - 1.0000000000000001e-128 -test util-16.1.17.-127 {8.4 compatible formatting of doubles} precision \ - {expr {1e-127}} \ - 1e-127 -test util-16.1.17.-126 {8.4 compatible formatting of doubles} precision \ - {expr {1e-126}} \ - 9.9999999999999995e-127 -test util-16.1.17.-125 {8.4 compatible formatting of doubles} precision \ - {expr {1e-125}} \ - 1e-125 -test util-16.1.17.-124 {8.4 compatible formatting of doubles} precision \ - {expr {1e-124}} \ - 9.9999999999999993e-125 -test util-16.1.17.-123 {8.4 compatible formatting of doubles} precision \ - {expr {1e-123}} \ - 1.0000000000000001e-123 -test util-16.1.17.-122 {8.4 compatible formatting of doubles} precision \ - {expr {1e-122}} \ - 1.0000000000000001e-122 -test util-16.1.17.-121 {8.4 compatible formatting of doubles} precision \ - {expr {1e-121}} \ - 9.9999999999999998e-122 -test util-16.1.17.-120 {8.4 compatible formatting of doubles} precision \ - {expr {1e-120}} \ - 9.9999999999999998e-121 -test util-16.1.17.-119 {8.4 compatible formatting of doubles} precision \ - {expr {1e-119}} \ - 1e-119 -test util-16.1.17.-118 {8.4 compatible formatting of doubles} precision \ - {expr {1e-118}} \ - 9.9999999999999999e-119 -test util-16.1.17.-117 {8.4 compatible formatting of doubles} precision \ - {expr {1e-117}} \ - 1e-117 -test util-16.1.17.-116 {8.4 compatible formatting of doubles} precision \ - {expr {1e-116}} \ - 9.9999999999999999e-117 -test util-16.1.17.-115 {8.4 compatible formatting of doubles} precision \ - {expr {1e-115}} \ - 1.0000000000000001e-115 -test util-16.1.17.-114 {8.4 compatible formatting of doubles} precision \ - {expr {1e-114}} \ - 1.0000000000000001e-114 -test util-16.1.17.-113 {8.4 compatible formatting of doubles} precision \ - {expr {1e-113}} \ - 9.9999999999999998e-114 -test util-16.1.17.-112 {8.4 compatible formatting of doubles} precision \ - {expr {1e-112}} \ - 9.9999999999999995e-113 -test util-16.1.17.-111 {8.4 compatible formatting of doubles} precision \ - {expr {1e-111}} \ - 1.0000000000000001e-111 -test util-16.1.17.-110 {8.4 compatible formatting of doubles} precision \ - {expr {1e-110}} \ - 1.0000000000000001e-110 -test util-16.1.17.-109 {8.4 compatible formatting of doubles} precision \ - {expr {1e-109}} \ - 9.9999999999999999e-110 -test util-16.1.17.-108 {8.4 compatible formatting of doubles} precision \ - {expr {1e-108}} \ - 1e-108 -test util-16.1.17.-107 {8.4 compatible formatting of doubles} precision \ - {expr {1e-107}} \ - 1e-107 -test util-16.1.17.-106 {8.4 compatible formatting of doubles} precision \ - {expr {1e-106}} \ - 9.9999999999999994e-107 -test util-16.1.17.-105 {8.4 compatible formatting of doubles} precision \ - {expr {1e-105}} \ - 9.9999999999999997e-106 -test util-16.1.17.-104 {8.4 compatible formatting of doubles} precision \ - {expr {1e-104}} \ - 9.9999999999999993e-105 -test util-16.1.17.-103 {8.4 compatible formatting of doubles} precision \ - {expr {1e-103}} \ - 9.9999999999999996e-104 -test util-16.1.17.-102 {8.4 compatible formatting of doubles} precision \ - {expr {1e-102}} \ - 9.9999999999999993e-103 -test util-16.1.17.-101 {8.4 compatible formatting of doubles} precision \ - {expr {1e-101}} \ - 1.0000000000000001e-101 -test util-16.1.17.-100 {8.4 compatible formatting of doubles} precision \ - {expr {1e-100}} \ - 1e-100 -test util-16.1.17.-99 {8.4 compatible formatting of doubles} precision \ - {expr {1e-99}} \ - 1e-99 -test util-16.1.17.-98 {8.4 compatible formatting of doubles} precision \ - {expr {1e-98}} \ - 9.9999999999999994e-99 -test util-16.1.17.-97 {8.4 compatible formatting of doubles} precision \ - {expr {1e-97}} \ - 1e-97 -test util-16.1.17.-96 {8.4 compatible formatting of doubles} precision \ - {expr {1e-96}} \ - 9.9999999999999991e-97 -test util-16.1.17.-95 {8.4 compatible formatting of doubles} precision \ - {expr {1e-95}} \ - 9.9999999999999999e-96 -test util-16.1.17.-94 {8.4 compatible formatting of doubles} precision \ - {expr {1e-94}} \ - 9.9999999999999996e-95 -test util-16.1.17.-93 {8.4 compatible formatting of doubles} precision \ - {expr {1e-93}} \ - 9.999999999999999e-94 -test util-16.1.17.-92 {8.4 compatible formatting of doubles} precision \ - {expr {1e-92}} \ - 9.9999999999999999e-93 -test util-16.1.17.-91 {8.4 compatible formatting of doubles} precision \ - {expr {1e-91}} \ - 1e-91 -test util-16.1.17.-90 {8.4 compatible formatting of doubles} precision \ - {expr {1e-90}} \ - 9.9999999999999999e-91 -test util-16.1.17.-89 {8.4 compatible formatting of doubles} precision \ - {expr {1e-89}} \ - 1e-89 -test util-16.1.17.-88 {8.4 compatible formatting of doubles} precision \ - {expr {1e-88}} \ - 9.9999999999999993e-89 -test util-16.1.17.-87 {8.4 compatible formatting of doubles} precision \ - {expr {1e-87}} \ - 1e-87 -test util-16.1.17.-86 {8.4 compatible formatting of doubles} precision \ - {expr {1e-86}} \ - 1.0000000000000001e-86 -test util-16.1.17.-85 {8.4 compatible formatting of doubles} precision \ - {expr {1e-85}} \ - 9.9999999999999998e-86 -test util-16.1.17.-84 {8.4 compatible formatting of doubles} precision \ - {expr {1e-84}} \ - 1e-84 -test util-16.1.17.-83 {8.4 compatible formatting of doubles} precision \ - {expr {1e-83}} \ - 1e-83 -test util-16.1.17.-82 {8.4 compatible formatting of doubles} precision \ - {expr {1e-82}} \ - 9.9999999999999996e-83 -test util-16.1.17.-81 {8.4 compatible formatting of doubles} precision \ - {expr {1e-81}} \ - 9.9999999999999996e-82 -test util-16.1.17.-80 {8.4 compatible formatting of doubles} precision \ - {expr {1e-80}} \ - 9.9999999999999996e-81 -test util-16.1.17.-79 {8.4 compatible formatting of doubles} precision \ - {expr {1e-79}} \ - 1e-79 -test util-16.1.17.-78 {8.4 compatible formatting of doubles} precision \ - {expr {1e-78}} \ - 1e-78 -test util-16.1.17.-77 {8.4 compatible formatting of doubles} precision \ - {expr {1e-77}} \ - 9.9999999999999993e-78 -test util-16.1.17.-76 {8.4 compatible formatting of doubles} precision \ - {expr {1e-76}} \ - 9.9999999999999993e-77 -test util-16.1.17.-75 {8.4 compatible formatting of doubles} precision \ - {expr {1e-75}} \ - 9.9999999999999996e-76 -test util-16.1.17.-74 {8.4 compatible formatting of doubles} precision \ - {expr {1e-74}} \ - 9.9999999999999996e-75 -test util-16.1.17.-73 {8.4 compatible formatting of doubles} precision \ - {expr {1e-73}} \ - 1e-73 -test util-16.1.17.-72 {8.4 compatible formatting of doubles} precision \ - {expr {1e-72}} \ - 9.9999999999999997e-73 -test util-16.1.17.-71 {8.4 compatible formatting of doubles} precision \ - {expr {1e-71}} \ - 9.9999999999999992e-72 -test util-16.1.17.-70 {8.4 compatible formatting of doubles} precision \ - {expr {1e-70}} \ - 1e-70 -test util-16.1.17.-69 {8.4 compatible formatting of doubles} precision \ - {expr {1e-69}} \ - 9.9999999999999996e-70 -test util-16.1.17.-68 {8.4 compatible formatting of doubles} precision \ - {expr {1e-68}} \ - 1.0000000000000001e-68 -test util-16.1.17.-67 {8.4 compatible formatting of doubles} precision \ - {expr {1e-67}} \ - 9.9999999999999994e-68 -test util-16.1.17.-66 {8.4 compatible formatting of doubles} precision \ - {expr {1e-66}} \ - 9.9999999999999998e-67 -test util-16.1.17.-65 {8.4 compatible formatting of doubles} precision \ - {expr {1e-65}} \ - 9.9999999999999992e-66 -test util-16.1.17.-64 {8.4 compatible formatting of doubles} precision \ - {expr {1e-64}} \ - 9.9999999999999997e-65 -test util-16.1.17.-63 {8.4 compatible formatting of doubles} precision \ - {expr {1e-63}} \ - 1.0000000000000001e-63 -test util-16.1.17.-62 {8.4 compatible formatting of doubles} precision \ - {expr {1e-62}} \ - 1e-62 -test util-16.1.17.-61 {8.4 compatible formatting of doubles} precision \ - {expr {1e-61}} \ - 1e-61 -test util-16.1.17.-60 {8.4 compatible formatting of doubles} precision \ - {expr {1e-60}} \ - 9.9999999999999997e-61 -test util-16.1.17.-59 {8.4 compatible formatting of doubles} precision \ - {expr {1e-59}} \ - 1e-59 -test util-16.1.17.-58 {8.4 compatible formatting of doubles} precision \ - {expr {1e-58}} \ - 1e-58 -test util-16.1.17.-57 {8.4 compatible formatting of doubles} precision \ - {expr {1e-57}} \ - 9.9999999999999995e-58 -test util-16.1.17.-56 {8.4 compatible formatting of doubles} precision \ - {expr {1e-56}} \ - 1e-56 -test util-16.1.17.-55 {8.4 compatible formatting of doubles} precision \ - {expr {1e-55}} \ - 9.9999999999999999e-56 -test util-16.1.17.-54 {8.4 compatible formatting of doubles} precision \ - {expr {1e-54}} \ - 1e-54 -test util-16.1.17.-53 {8.4 compatible formatting of doubles} precision \ - {expr {1e-53}} \ - 1e-53 -test util-16.1.17.-52 {8.4 compatible formatting of doubles} precision \ - {expr {1e-52}} \ - 1e-52 -test util-16.1.17.-51 {8.4 compatible formatting of doubles} precision \ - {expr {1e-51}} \ - 1e-51 -test util-16.1.17.-50 {8.4 compatible formatting of doubles} precision \ - {expr {1e-50}} \ - 1e-50 -test util-16.1.17.-49 {8.4 compatible formatting of doubles} precision \ - {expr {1e-49}} \ - 9.9999999999999994e-50 -test util-16.1.17.-48 {8.4 compatible formatting of doubles} precision \ - {expr {1e-48}} \ - 9.9999999999999997e-49 -test util-16.1.17.-47 {8.4 compatible formatting of doubles} precision \ - {expr {1e-47}} \ - 9.9999999999999997e-48 -test util-16.1.17.-46 {8.4 compatible formatting of doubles} precision \ - {expr {1e-46}} \ - 1e-46 -test util-16.1.17.-45 {8.4 compatible formatting of doubles} precision \ - {expr {1e-45}} \ - 9.9999999999999998e-46 -test util-16.1.17.-44 {8.4 compatible formatting of doubles} precision \ - {expr {1e-44}} \ - 9.9999999999999995e-45 -test util-16.1.17.-43 {8.4 compatible formatting of doubles} precision \ - {expr {1e-43}} \ - 1.0000000000000001e-43 -test util-16.1.17.-42 {8.4 compatible formatting of doubles} precision \ - {expr {1e-42}} \ - 1e-42 -test util-16.1.17.-41 {8.4 compatible formatting of doubles} precision \ - {expr {1e-41}} \ - 1e-41 -test util-16.1.17.-40 {8.4 compatible formatting of doubles} precision \ - {expr {1e-40}} \ - 9.9999999999999993e-41 -test util-16.1.17.-39 {8.4 compatible formatting of doubles} precision \ - {expr {1e-39}} \ - 9.9999999999999993e-40 -test util-16.1.17.-38 {8.4 compatible formatting of doubles} precision \ - {expr {1e-38}} \ - 9.9999999999999996e-39 -test util-16.1.17.-37 {8.4 compatible formatting of doubles} precision \ - {expr {1e-37}} \ - 1.0000000000000001e-37 -test util-16.1.17.-36 {8.4 compatible formatting of doubles} precision \ - {expr {1e-36}} \ - 9.9999999999999994e-37 -test util-16.1.17.-35 {8.4 compatible formatting of doubles} precision \ - {expr {1e-35}} \ - 1e-35 -test util-16.1.17.-34 {8.4 compatible formatting of doubles} precision \ - {expr {1e-34}} \ - 9.9999999999999993e-35 -test util-16.1.17.-33 {8.4 compatible formatting of doubles} precision \ - {expr {1e-33}} \ - 1.0000000000000001e-33 -test util-16.1.17.-32 {8.4 compatible formatting of doubles} precision \ - {expr {1e-32}} \ - 1.0000000000000001e-32 -test util-16.1.17.-31 {8.4 compatible formatting of doubles} precision \ - {expr {1e-31}} \ - 1.0000000000000001e-31 -test util-16.1.17.-30 {8.4 compatible formatting of doubles} precision \ - {expr {1e-30}} \ - 1.0000000000000001e-30 -test util-16.1.17.-29 {8.4 compatible formatting of doubles} precision \ - {expr {1e-29}} \ - 9.9999999999999994e-30 -test util-16.1.17.-28 {8.4 compatible formatting of doubles} precision \ - {expr {1e-28}} \ - 9.9999999999999997e-29 -test util-16.1.17.-27 {8.4 compatible formatting of doubles} precision \ - {expr {1e-27}} \ - 1e-27 -test util-16.1.17.-26 {8.4 compatible formatting of doubles} precision \ - {expr {1e-26}} \ - 1e-26 -test util-16.1.17.-25 {8.4 compatible formatting of doubles} precision \ - {expr {1e-25}} \ - 1e-25 -test util-16.1.17.-24 {8.4 compatible formatting of doubles} precision \ - {expr {1e-24}} \ - 9.9999999999999992e-25 -test util-16.1.17.-23 {8.4 compatible formatting of doubles} precision \ - {expr {1e-23}} \ - 9.9999999999999996e-24 -test util-16.1.17.-22 {8.4 compatible formatting of doubles} precision \ - {expr {1e-22}} \ - 1e-22 -test util-16.1.17.-21 {8.4 compatible formatting of doubles} precision \ - {expr {1e-21}} \ - 9.9999999999999991e-22 -test util-16.1.17.-20 {8.4 compatible formatting of doubles} precision \ - {expr {1e-20}} \ - 9.9999999999999995e-21 -test util-16.1.17.-19 {8.4 compatible formatting of doubles} precision \ - {expr {1e-19}} \ - 9.9999999999999998e-20 -test util-16.1.17.-18 {8.4 compatible formatting of doubles} precision \ - {expr {1e-18}} \ - 1.0000000000000001e-18 -test util-16.1.17.-17 {8.4 compatible formatting of doubles} precision \ - {expr {1e-17}} \ - 1.0000000000000001e-17 -test util-16.1.17.-16 {8.4 compatible formatting of doubles} precision \ - {expr {1e-16}} \ - 9.9999999999999998e-17 -test util-16.1.17.-15 {8.4 compatible formatting of doubles} precision \ - {expr {1e-15}} \ - 1.0000000000000001e-15 -test util-16.1.17.-14 {8.4 compatible formatting of doubles} precision \ - {expr {1e-14}} \ - 1e-14 -test util-16.1.17.-13 {8.4 compatible formatting of doubles} precision \ - {expr {1e-13}} \ - 1e-13 -test util-16.1.17.-12 {8.4 compatible formatting of doubles} precision \ - {expr {1e-12}} \ - 9.9999999999999998e-13 -test util-16.1.17.-11 {8.4 compatible formatting of doubles} precision \ - {expr {1e-11}} \ - 9.9999999999999994e-12 -test util-16.1.17.-10 {8.4 compatible formatting of doubles} precision \ - {expr {1e-10}} \ - 1e-10 -test util-16.1.17.-9 {8.4 compatible formatting of doubles} precision \ - {expr {1e-9}} \ - 1.0000000000000001e-09 -test util-16.1.17.-8 {8.4 compatible formatting of doubles} precision \ - {expr {1e-8}} \ - 1e-08 -test util-16.1.17.-7 {8.4 compatible formatting of doubles} precision \ - {expr {1e-7}} \ - 9.9999999999999995e-08 -test util-16.1.17.-6 {8.4 compatible formatting of doubles} precision \ - {expr {1e-6}} \ - 9.9999999999999995e-07 -test util-16.1.17.-5 {8.4 compatible formatting of doubles} precision \ - {expr {1e-5}} \ - 1.0000000000000001e-05 -test util-16.1.17.-4 {8.4 compatible formatting of doubles} precision \ - {expr {1e-4}} \ - 0.0001 -test util-16.1.17.-3 {8.4 compatible formatting of doubles} precision \ - {expr {1e-3}} \ - 0.001 -test util-16.1.17.-2 {8.4 compatible formatting of doubles} precision \ - {expr {1e-2}} \ - 0.01 -test util-16.1.17.-1 {8.4 compatible formatting of doubles} precision \ - {expr {1e-1}} \ - 0.10000000000000001 -test util-16.1.17.0 {8.4 compatible formatting of doubles} precision \ - {expr {1e0}} \ - 1.0 -test util-16.1.17.1 {8.4 compatible formatting of doubles} precision \ - {expr {1e1}} \ - 10.0 -test util-16.1.17.2 {8.4 compatible formatting of doubles} precision \ - {expr {1e2}} \ - 100.0 -test util-16.1.17.3 {8.4 compatible formatting of doubles} precision \ - {expr {1e3}} \ - 1000.0 -test util-16.1.17.4 {8.4 compatible formatting of doubles} precision \ - {expr {1e4}} \ - 10000.0 -test util-16.1.17.5 {8.4 compatible formatting of doubles} precision \ - {expr {1e5}} \ - 100000.0 -test util-16.1.17.6 {8.4 compatible formatting of doubles} precision \ - {expr {1e6}} \ - 1000000.0 -test util-16.1.17.7 {8.4 compatible formatting of doubles} precision \ - {expr {1e7}} \ - 10000000.0 -test util-16.1.17.8 {8.4 compatible formatting of doubles} precision \ - {expr {1e8}} \ - 100000000.0 -test util-16.1.17.9 {8.4 compatible formatting of doubles} precision \ - {expr {1e9}} \ - 1000000000.0 -test util-16.1.17.10 {8.4 compatible formatting of doubles} precision \ - {expr {1e10}} \ - 10000000000.0 -test util-16.1.17.11 {8.4 compatible formatting of doubles} precision \ - {expr {1e11}} \ - 100000000000.0 -test util-16.1.17.12 {8.4 compatible formatting of doubles} precision \ - {expr {1e12}} \ - 1000000000000.0 -test util-16.1.17.13 {8.4 compatible formatting of doubles} precision \ - {expr {1e13}} \ - 10000000000000.0 -test util-16.1.17.14 {8.4 compatible formatting of doubles} precision \ - {expr {1e14}} \ - 100000000000000.0 -test util-16.1.17.15 {8.4 compatible formatting of doubles} precision \ - {expr {1e15}} \ - 1000000000000000.0 -test util-16.1.17.16 {8.4 compatible formatting of doubles} precision \ - {expr {1e16}} \ - 10000000000000000.0 -test util-16.1.17.17 {8.4 compatible formatting of doubles} precision \ - {expr {1e17}} \ - 1e+17 -test util-16.1.17.18 {8.4 compatible formatting of doubles} precision \ - {expr {1e18}} \ - 1e+18 -test util-16.1.17.19 {8.4 compatible formatting of doubles} precision \ - {expr {1e19}} \ - 1e+19 -test util-16.1.17.20 {8.4 compatible formatting of doubles} precision \ - {expr {1e20}} \ - 1e+20 -test util-16.1.17.21 {8.4 compatible formatting of doubles} precision \ - {expr {1e21}} \ - 1e+21 -test util-16.1.17.22 {8.4 compatible formatting of doubles} precision \ - {expr {1e22}} \ - 1e+22 -test util-16.1.17.23 {8.4 compatible formatting of doubles} precision \ - {expr {1e23}} \ - 9.9999999999999992e+22 -test util-16.1.17.24 {8.4 compatible formatting of doubles} precision \ - {expr {1e24}} \ - 9.9999999999999998e+23 -test util-16.1.17.25 {8.4 compatible formatting of doubles} precision \ - {expr {1e25}} \ - 1.0000000000000001e+25 -test util-16.1.17.26 {8.4 compatible formatting of doubles} precision \ - {expr {1e26}} \ - 1e+26 -test util-16.1.17.27 {8.4 compatible formatting of doubles} precision \ - {expr {1e27}} \ - 1e+27 -test util-16.1.17.28 {8.4 compatible formatting of doubles} precision \ - {expr {1e28}} \ - 9.9999999999999996e+27 -test util-16.1.17.29 {8.4 compatible formatting of doubles} precision \ - {expr {1e29}} \ - 9.9999999999999991e+28 -test util-16.1.17.30 {8.4 compatible formatting of doubles} precision \ - {expr {1e30}} \ - 1e+30 -test util-16.1.17.31 {8.4 compatible formatting of doubles} precision \ - {expr {1e31}} \ - 9.9999999999999996e+30 -test util-16.1.17.32 {8.4 compatible formatting of doubles} precision \ - {expr {1e32}} \ - 1.0000000000000001e+32 -test util-16.1.17.33 {8.4 compatible formatting of doubles} precision \ - {expr {1e33}} \ - 9.9999999999999995e+32 -test util-16.1.17.34 {8.4 compatible formatting of doubles} precision \ - {expr {1e34}} \ - 9.9999999999999995e+33 -test util-16.1.17.35 {8.4 compatible formatting of doubles} precision \ - {expr {1e35}} \ - 9.9999999999999997e+34 -test util-16.1.17.36 {8.4 compatible formatting of doubles} precision \ - {expr {1e36}} \ - 1e+36 -test util-16.1.17.37 {8.4 compatible formatting of doubles} precision \ - {expr {1e37}} \ - 9.9999999999999995e+36 -test util-16.1.17.38 {8.4 compatible formatting of doubles} precision \ - {expr {1e38}} \ - 9.9999999999999998e+37 -test util-16.1.17.39 {8.4 compatible formatting of doubles} precision \ - {expr {1e39}} \ - 9.9999999999999994e+38 -test util-16.1.17.40 {8.4 compatible formatting of doubles} precision \ - {expr {1e40}} \ - 1e+40 -test util-16.1.17.41 {8.4 compatible formatting of doubles} precision \ - {expr {1e41}} \ - 1e+41 -test util-16.1.17.42 {8.4 compatible formatting of doubles} precision \ - {expr {1e42}} \ - 1e+42 -test util-16.1.17.43 {8.4 compatible formatting of doubles} precision \ - {expr {1e43}} \ - 1e+43 -test util-16.1.17.44 {8.4 compatible formatting of doubles} precision \ - {expr {1e44}} \ - 1.0000000000000001e+44 -test util-16.1.17.45 {8.4 compatible formatting of doubles} precision \ - {expr {1e45}} \ - 9.9999999999999993e+44 -test util-16.1.17.46 {8.4 compatible formatting of doubles} precision \ - {expr {1e46}} \ - 9.9999999999999999e+45 -test util-16.1.17.47 {8.4 compatible formatting of doubles} precision \ - {expr {1e47}} \ - 1e+47 -test util-16.1.17.48 {8.4 compatible formatting of doubles} precision \ - {expr {1e48}} \ - 1e+48 -test util-16.1.17.49 {8.4 compatible formatting of doubles} precision \ - {expr {1e49}} \ - 9.9999999999999995e+48 -test util-16.1.17.50 {8.4 compatible formatting of doubles} precision \ - {expr {1e50}} \ - 1.0000000000000001e+50 -test util-16.1.17.51 {8.4 compatible formatting of doubles} precision \ - {expr {1e51}} \ - 9.9999999999999999e+50 -test util-16.1.17.52 {8.4 compatible formatting of doubles} precision \ - {expr {1e52}} \ - 9.9999999999999999e+51 -test util-16.1.17.53 {8.4 compatible formatting of doubles} precision \ - {expr {1e53}} \ - 9.9999999999999999e+52 -test util-16.1.17.54 {8.4 compatible formatting of doubles} precision \ - {expr {1e54}} \ - 1.0000000000000001e+54 -test util-16.1.17.55 {8.4 compatible formatting of doubles} precision \ - {expr {1e55}} \ - 1e+55 -test util-16.1.17.56 {8.4 compatible formatting of doubles} precision \ - {expr {1e56}} \ - 1.0000000000000001e+56 -test util-16.1.17.57 {8.4 compatible formatting of doubles} precision \ - {expr {1e57}} \ - 1e+57 -test util-16.1.17.58 {8.4 compatible formatting of doubles} precision \ - {expr {1e58}} \ - 9.9999999999999994e+57 -test util-16.1.17.59 {8.4 compatible formatting of doubles} precision \ - {expr {1e59}} \ - 9.9999999999999997e+58 -test util-16.1.17.60 {8.4 compatible formatting of doubles} precision \ - {expr {1e60}} \ - 9.9999999999999995e+59 -test util-16.1.17.61 {8.4 compatible formatting of doubles} precision \ - {expr {1e61}} \ - 9.9999999999999995e+60 -test util-16.1.17.62 {8.4 compatible formatting of doubles} precision \ - {expr {1e62}} \ - 1e+62 -test util-16.1.17.63 {8.4 compatible formatting of doubles} precision \ - {expr {1e63}} \ - 1.0000000000000001e+63 -test util-16.1.17.64 {8.4 compatible formatting of doubles} precision \ - {expr {1e64}} \ - 1e+64 -test util-16.1.17.65 {8.4 compatible formatting of doubles} precision \ - {expr {1e65}} \ - 9.9999999999999999e+64 -test util-16.1.17.66 {8.4 compatible formatting of doubles} precision \ - {expr {1e66}} \ - 9.9999999999999995e+65 -test util-16.1.17.67 {8.4 compatible formatting of doubles} precision \ - {expr {1e67}} \ - 9.9999999999999998e+66 -test util-16.1.17.68 {8.4 compatible formatting of doubles} precision \ - {expr {1e68}} \ - 9.9999999999999995e+67 -test util-16.1.17.69 {8.4 compatible formatting of doubles} precision \ - {expr {1e69}} \ - 1.0000000000000001e+69 -test util-16.1.17.70 {8.4 compatible formatting of doubles} precision \ - {expr {1e70}} \ - 1.0000000000000001e+70 -test util-16.1.17.71 {8.4 compatible formatting of doubles} precision \ - {expr {1e71}} \ - 1e+71 -test util-16.1.17.72 {8.4 compatible formatting of doubles} precision \ - {expr {1e72}} \ - 9.9999999999999994e+71 -test util-16.1.17.73 {8.4 compatible formatting of doubles} precision \ - {expr {1e73}} \ - 9.9999999999999998e+72 -test util-16.1.17.74 {8.4 compatible formatting of doubles} precision \ - {expr {1e74}} \ - 9.9999999999999995e+73 -test util-16.1.17.75 {8.4 compatible formatting of doubles} precision \ - {expr {1e75}} \ - 9.9999999999999993e+74 -test util-16.1.17.76 {8.4 compatible formatting of doubles} precision \ - {expr {1e76}} \ - 1e+76 -test util-16.1.17.77 {8.4 compatible formatting of doubles} precision \ - {expr {1e77}} \ - 9.9999999999999998e+76 -test util-16.1.17.78 {8.4 compatible formatting of doubles} precision \ - {expr {1e78}} \ - 1e+78 -test util-16.1.17.79 {8.4 compatible formatting of doubles} precision \ - {expr {1e79}} \ - 9.9999999999999997e+78 -test util-16.1.17.80 {8.4 compatible formatting of doubles} precision \ - {expr {1e80}} \ - 1e+80 -test util-16.1.17.81 {8.4 compatible formatting of doubles} precision \ - {expr {1e81}} \ - 9.9999999999999992e+80 -test util-16.1.17.82 {8.4 compatible formatting of doubles} precision \ - {expr {1e82}} \ - 9.9999999999999996e+81 -test util-16.1.17.83 {8.4 compatible formatting of doubles} precision \ - {expr {1e83}} \ - 1e+83 -test util-16.1.17.84 {8.4 compatible formatting of doubles} precision \ - {expr {1e84}} \ - 1.0000000000000001e+84 -test util-16.1.17.85 {8.4 compatible formatting of doubles} precision \ - {expr {1e85}} \ - 1e+85 -test util-16.1.17.86 {8.4 compatible formatting of doubles} precision \ - {expr {1e86}} \ - 1e+86 -test util-16.1.17.87 {8.4 compatible formatting of doubles} precision \ - {expr {1e87}} \ - 9.9999999999999996e+86 -test util-16.1.17.88 {8.4 compatible formatting of doubles} precision \ - {expr {1e88}} \ - 9.9999999999999996e+87 -test util-16.1.17.89 {8.4 compatible formatting of doubles} precision \ - {expr {1e89}} \ - 9.9999999999999999e+88 -test util-16.1.17.90 {8.4 compatible formatting of doubles} precision \ - {expr {1e90}} \ - 9.9999999999999997e+89 -test util-16.1.17.91 {8.4 compatible formatting of doubles} precision \ - {expr {1e91}} \ - 1.0000000000000001e+91 -test util-16.1.17.92 {8.4 compatible formatting of doubles} precision \ - {expr {1e92}} \ - 1e+92 -test util-16.1.17.93 {8.4 compatible formatting of doubles} precision \ - {expr {1e93}} \ - 1e+93 -test util-16.1.17.94 {8.4 compatible formatting of doubles} precision \ - {expr {1e94}} \ - 1e+94 -test util-16.1.17.95 {8.4 compatible formatting of doubles} precision \ - {expr {1e95}} \ - 1e+95 -test util-16.1.17.96 {8.4 compatible formatting of doubles} precision \ - {expr {1e96}} \ - 1e+96 -test util-16.1.17.97 {8.4 compatible formatting of doubles} precision \ - {expr {1e97}} \ - 1.0000000000000001e+97 -test util-16.1.17.98 {8.4 compatible formatting of doubles} precision \ - {expr {1e98}} \ - 1e+98 -test util-16.1.17.99 {8.4 compatible formatting of doubles} precision \ - {expr {1e99}} \ - 9.9999999999999997e+98 -test util-16.1.17.100 {8.4 compatible formatting of doubles} precision \ - {expr {1e100}} \ - 1e+100 -test util-16.1.17.101 {8.4 compatible formatting of doubles} precision \ - {expr {1e101}} \ - 9.9999999999999998e+100 -test util-16.1.17.102 {8.4 compatible formatting of doubles} precision \ - {expr {1e102}} \ - 9.9999999999999998e+101 -test util-16.1.17.103 {8.4 compatible formatting of doubles} precision \ - {expr {1e103}} \ - 1e+103 -test util-16.1.17.104 {8.4 compatible formatting of doubles} precision \ - {expr {1e104}} \ - 1e+104 -test util-16.1.17.105 {8.4 compatible formatting of doubles} precision \ - {expr {1e105}} \ - 9.9999999999999994e+104 -test util-16.1.17.106 {8.4 compatible formatting of doubles} precision \ - {expr {1e106}} \ - 1.0000000000000001e+106 -test util-16.1.17.107 {8.4 compatible formatting of doubles} precision \ - {expr {1e107}} \ - 9.9999999999999997e+106 -test util-16.1.17.108 {8.4 compatible formatting of doubles} precision \ - {expr {1e108}} \ - 1e+108 -test util-16.1.17.109 {8.4 compatible formatting of doubles} precision \ - {expr {1e109}} \ - 9.9999999999999998e+108 -test util-16.1.17.110 {8.4 compatible formatting of doubles} precision \ - {expr {1e110}} \ - 1e+110 -test util-16.1.17.111 {8.4 compatible formatting of doubles} precision \ - {expr {1e111}} \ - 9.9999999999999996e+110 -test util-16.1.17.112 {8.4 compatible formatting of doubles} precision \ - {expr {1e112}} \ - 9.9999999999999993e+111 -test util-16.1.17.113 {8.4 compatible formatting of doubles} precision \ - {expr {1e113}} \ - 1e+113 -test util-16.1.17.114 {8.4 compatible formatting of doubles} precision \ - {expr {1e114}} \ - 1e+114 -test util-16.1.17.115 {8.4 compatible formatting of doubles} precision \ - {expr {1e115}} \ - 1e+115 -test util-16.1.17.116 {8.4 compatible formatting of doubles} precision \ - {expr {1e116}} \ - 1e+116 -test util-16.1.17.117 {8.4 compatible formatting of doubles} precision \ - {expr {1e117}} \ - 1.0000000000000001e+117 -test util-16.1.17.118 {8.4 compatible formatting of doubles} precision \ - {expr {1e118}} \ - 9.9999999999999997e+117 -test util-16.1.17.119 {8.4 compatible formatting of doubles} precision \ - {expr {1e119}} \ - 9.9999999999999994e+118 -test util-16.1.17.120 {8.4 compatible formatting of doubles} precision \ - {expr {1e120}} \ - 9.9999999999999998e+119 -test util-16.1.17.121 {8.4 compatible formatting of doubles} precision \ - {expr {1e121}} \ - 1e+121 -test util-16.1.17.122 {8.4 compatible formatting of doubles} precision \ - {expr {1e122}} \ - 1e+122 -test util-16.1.17.123 {8.4 compatible formatting of doubles} precision \ - {expr {1e123}} \ - 9.9999999999999998e+122 -test util-16.1.17.124 {8.4 compatible formatting of doubles} precision \ - {expr {1e124}} \ - 9.9999999999999995e+123 -test util-16.1.17.125 {8.4 compatible formatting of doubles} precision \ - {expr {1e125}} \ - 9.9999999999999992e+124 -test util-16.1.17.126 {8.4 compatible formatting of doubles} precision \ - {expr {1e126}} \ - 9.9999999999999992e+125 -test util-16.1.17.127 {8.4 compatible formatting of doubles} precision \ - {expr {1e127}} \ - 9.9999999999999995e+126 -test util-16.1.17.128 {8.4 compatible formatting of doubles} precision \ - {expr {1e128}} \ - 1.0000000000000001e+128 -test util-16.1.17.129 {8.4 compatible formatting of doubles} precision \ - {expr {1e129}} \ - 1e+129 -test util-16.1.17.130 {8.4 compatible formatting of doubles} precision \ - {expr {1e130}} \ - 1.0000000000000001e+130 -test util-16.1.17.131 {8.4 compatible formatting of doubles} precision \ - {expr {1e131}} \ - 9.9999999999999991e+130 -test util-16.1.17.132 {8.4 compatible formatting of doubles} precision \ - {expr {1e132}} \ - 9.9999999999999999e+131 -test util-16.1.17.133 {8.4 compatible formatting of doubles} precision \ - {expr {1e133}} \ - 1e+133 -test util-16.1.17.134 {8.4 compatible formatting of doubles} precision \ - {expr {1e134}} \ - 9.9999999999999992e+133 -test util-16.1.17.135 {8.4 compatible formatting of doubles} precision \ - {expr {1e135}} \ - 9.9999999999999996e+134 -test util-16.1.17.136 {8.4 compatible formatting of doubles} precision \ - {expr {1e136}} \ - 1.0000000000000001e+136 -test util-16.1.17.137 {8.4 compatible formatting of doubles} precision \ - {expr {1e137}} \ - 1e+137 -test util-16.1.17.138 {8.4 compatible formatting of doubles} precision \ - {expr {1e138}} \ - 1e+138 -test util-16.1.17.139 {8.4 compatible formatting of doubles} precision \ - {expr {1e139}} \ - 1e+139 -test util-16.1.17.140 {8.4 compatible formatting of doubles} precision \ - {expr {1e140}} \ - 1.0000000000000001e+140 -test util-16.1.17.141 {8.4 compatible formatting of doubles} precision \ - {expr {1e141}} \ - 1e+141 -test util-16.1.17.142 {8.4 compatible formatting of doubles} precision \ - {expr {1e142}} \ - 1.0000000000000001e+142 -test util-16.1.17.143 {8.4 compatible formatting of doubles} precision \ - {expr {1e143}} \ - 1e+143 -test util-16.1.17.144 {8.4 compatible formatting of doubles} precision \ - {expr {1e144}} \ - 1e+144 -test util-16.1.17.145 {8.4 compatible formatting of doubles} precision \ - {expr {1e145}} \ - 9.9999999999999999e+144 -test util-16.1.17.146 {8.4 compatible formatting of doubles} precision \ - {expr {1e146}} \ - 9.9999999999999993e+145 -test util-16.1.17.147 {8.4 compatible formatting of doubles} precision \ - {expr {1e147}} \ - 9.9999999999999998e+146 -test util-16.1.17.148 {8.4 compatible formatting of doubles} precision \ - {expr {1e148}} \ - 1e+148 -test util-16.1.17.149 {8.4 compatible formatting of doubles} precision \ - {expr {1e149}} \ - 1e+149 -test util-16.1.17.150 {8.4 compatible formatting of doubles} precision \ - {expr {1e150}} \ - 9.9999999999999998e+149 -test util-16.1.17.151 {8.4 compatible formatting of doubles} precision \ - {expr {1e151}} \ - 1e+151 -test util-16.1.17.152 {8.4 compatible formatting of doubles} precision \ - {expr {1e152}} \ - 1e+152 -test util-16.1.17.153 {8.4 compatible formatting of doubles} precision \ - {expr {1e153}} \ - 1e+153 -test util-16.1.17.154 {8.4 compatible formatting of doubles} precision \ - {expr {1e154}} \ - 1e+154 -test util-16.1.17.155 {8.4 compatible formatting of doubles} precision \ - {expr {1e155}} \ - 1e+155 -test util-16.1.17.156 {8.4 compatible formatting of doubles} precision \ - {expr {1e156}} \ - 9.9999999999999998e+155 -test util-16.1.17.157 {8.4 compatible formatting of doubles} precision \ - {expr {1e157}} \ - 9.9999999999999998e+156 -test util-16.1.17.158 {8.4 compatible formatting of doubles} precision \ - {expr {1e158}} \ - 9.9999999999999995e+157 -test util-16.1.17.159 {8.4 compatible formatting of doubles} precision \ - {expr {1e159}} \ - 9.9999999999999993e+158 -test util-16.1.17.160 {8.4 compatible formatting of doubles} precision \ - {expr {1e160}} \ - 1e+160 -test util-16.1.17.161 {8.4 compatible formatting of doubles} precision \ - {expr {1e161}} \ - 1e+161 -test util-16.1.17.162 {8.4 compatible formatting of doubles} precision \ - {expr {1e162}} \ - 9.9999999999999994e+161 -test util-16.1.17.163 {8.4 compatible formatting of doubles} precision \ - {expr {1e163}} \ - 9.9999999999999994e+162 -test util-16.1.17.164 {8.4 compatible formatting of doubles} precision \ - {expr {1e164}} \ - 1e+164 -test util-16.1.17.165 {8.4 compatible formatting of doubles} precision \ - {expr {1e165}} \ - 9.999999999999999e+164 -test util-16.1.17.166 {8.4 compatible formatting of doubles} precision \ - {expr {1e166}} \ - 9.9999999999999994e+165 -test util-16.1.17.167 {8.4 compatible formatting of doubles} precision \ - {expr {1e167}} \ - 1e+167 -test util-16.1.17.168 {8.4 compatible formatting of doubles} precision \ - {expr {1e168}} \ - 9.9999999999999993e+167 -test util-16.1.17.169 {8.4 compatible formatting of doubles} precision \ - {expr {1e169}} \ - 9.9999999999999993e+168 -test util-16.1.17.170 {8.4 compatible formatting of doubles} precision \ - {expr {1e170}} \ - 1e+170 -test util-16.1.17.171 {8.4 compatible formatting of doubles} precision \ - {expr {1e171}} \ - 9.9999999999999995e+170 -test util-16.1.17.172 {8.4 compatible formatting of doubles} precision \ - {expr {1e172}} \ - 1.0000000000000001e+172 -test util-16.1.17.173 {8.4 compatible formatting of doubles} precision \ - {expr {1e173}} \ - 1e+173 -test util-16.1.17.174 {8.4 compatible formatting of doubles} precision \ - {expr {1e174}} \ - 1.0000000000000001e+174 -test util-16.1.17.175 {8.4 compatible formatting of doubles} precision \ - {expr {1e175}} \ - 9.9999999999999994e+174 -test util-16.1.17.176 {8.4 compatible formatting of doubles} precision \ - {expr {1e176}} \ - 1e+176 -test util-16.1.17.177 {8.4 compatible formatting of doubles} precision \ - {expr {1e177}} \ - 1e+177 -test util-16.1.17.178 {8.4 compatible formatting of doubles} precision \ - {expr {1e178}} \ - 1.0000000000000001e+178 -test util-16.1.17.179 {8.4 compatible formatting of doubles} precision \ - {expr {1e179}} \ - 9.9999999999999998e+178 -test util-16.1.17.180 {8.4 compatible formatting of doubles} precision \ - {expr {1e180}} \ - 1e+180 -test util-16.1.17.181 {8.4 compatible formatting of doubles} precision \ - {expr {1e181}} \ - 9.9999999999999992e+180 -test util-16.1.17.182 {8.4 compatible formatting of doubles} precision \ - {expr {1e182}} \ - 1.0000000000000001e+182 -test util-16.1.17.183 {8.4 compatible formatting of doubles} precision \ - {expr {1e183}} \ - 9.9999999999999995e+182 -test util-16.1.17.184 {8.4 compatible formatting of doubles} precision \ - {expr {1e184}} \ - 1e+184 -test util-16.1.17.185 {8.4 compatible formatting of doubles} precision \ - {expr {1e185}} \ - 9.9999999999999998e+184 -test util-16.1.17.186 {8.4 compatible formatting of doubles} precision \ - {expr {1e186}} \ - 9.9999999999999998e+185 -test util-16.1.17.187 {8.4 compatible formatting of doubles} precision \ - {expr {1e187}} \ - 9.9999999999999991e+186 -test util-16.1.17.188 {8.4 compatible formatting of doubles} precision \ - {expr {1e188}} \ - 1e+188 -test util-16.1.17.189 {8.4 compatible formatting of doubles} precision \ - {expr {1e189}} \ - 1e+189 -test util-16.1.17.190 {8.4 compatible formatting of doubles} precision \ - {expr {1e190}} \ - 1.0000000000000001e+190 -test util-16.1.17.191 {8.4 compatible formatting of doubles} precision \ - {expr {1e191}} \ - 1.0000000000000001e+191 -test util-16.1.17.192 {8.4 compatible formatting of doubles} precision \ - {expr {1e192}} \ - 1e+192 -test util-16.1.17.193 {8.4 compatible formatting of doubles} precision \ - {expr {1e193}} \ - 1.0000000000000001e+193 -test util-16.1.17.194 {8.4 compatible formatting of doubles} precision \ - {expr {1e194}} \ - 9.9999999999999994e+193 -test util-16.1.17.195 {8.4 compatible formatting of doubles} precision \ - {expr {1e195}} \ - 9.9999999999999998e+194 -test util-16.1.17.196 {8.4 compatible formatting of doubles} precision \ - {expr {1e196}} \ - 9.9999999999999995e+195 -test util-16.1.17.197 {8.4 compatible formatting of doubles} precision \ - {expr {1e197}} \ - 9.9999999999999995e+196 -test util-16.1.17.198 {8.4 compatible formatting of doubles} precision \ - {expr {1e198}} \ - 1e+198 -test util-16.1.17.199 {8.4 compatible formatting of doubles} precision \ - {expr {1e199}} \ - 1.0000000000000001e+199 -test util-16.1.17.200 {8.4 compatible formatting of doubles} precision \ - {expr {1e200}} \ - 9.9999999999999997e+199 -test util-16.1.17.201 {8.4 compatible formatting of doubles} precision \ - {expr {1e201}} \ - 1e+201 -test util-16.1.17.202 {8.4 compatible formatting of doubles} precision \ - {expr {1e202}} \ - 9.999999999999999e+201 -test util-16.1.17.203 {8.4 compatible formatting of doubles} precision \ - {expr {1e203}} \ - 9.9999999999999999e+202 -test util-16.1.17.204 {8.4 compatible formatting of doubles} precision \ - {expr {1e204}} \ - 9.9999999999999999e+203 -test util-16.1.17.205 {8.4 compatible formatting of doubles} precision \ - {expr {1e205}} \ - 1e+205 -test util-16.1.17.206 {8.4 compatible formatting of doubles} precision \ - {expr {1e206}} \ - 1e+206 -test util-16.1.17.207 {8.4 compatible formatting of doubles} precision \ - {expr {1e207}} \ - 1e+207 -test util-16.1.17.208 {8.4 compatible formatting of doubles} precision \ - {expr {1e208}} \ - 9.9999999999999998e+207 -test util-16.1.17.209 {8.4 compatible formatting of doubles} precision \ - {expr {1e209}} \ - 1.0000000000000001e+209 -test util-16.1.17.210 {8.4 compatible formatting of doubles} precision \ - {expr {1e210}} \ - 9.9999999999999993e+209 -test util-16.1.17.211 {8.4 compatible formatting of doubles} precision \ - {expr {1e211}} \ - 9.9999999999999996e+210 -test util-16.1.17.212 {8.4 compatible formatting of doubles} precision \ - {expr {1e212}} \ - 9.9999999999999991e+211 -test util-16.1.17.213 {8.4 compatible formatting of doubles} precision \ - {expr {1e213}} \ - 9.9999999999999998e+212 -test util-16.1.17.214 {8.4 compatible formatting of doubles} precision \ - {expr {1e214}} \ - 9.9999999999999995e+213 -test util-16.1.17.215 {8.4 compatible formatting of doubles} precision \ - {expr {1e215}} \ - 9.9999999999999991e+214 -test util-16.1.17.216 {8.4 compatible formatting of doubles} precision \ - {expr {1e216}} \ - 1e+216 -test util-16.1.17.217 {8.4 compatible formatting of doubles} precision \ - {expr {1e217}} \ - 9.9999999999999996e+216 -test util-16.1.17.218 {8.4 compatible formatting of doubles} precision \ - {expr {1e218}} \ - 1.0000000000000001e+218 -test util-16.1.17.219 {8.4 compatible formatting of doubles} precision \ - {expr {1e219}} \ - 9.9999999999999997e+218 -test util-16.1.17.220 {8.4 compatible formatting of doubles} precision \ - {expr {1e220}} \ - 1e+220 -test util-16.1.17.221 {8.4 compatible formatting of doubles} precision \ - {expr {1e221}} \ - 1e+221 -test util-16.1.17.222 {8.4 compatible formatting of doubles} precision \ - {expr {1e222}} \ - 1e+222 -test util-16.1.17.223 {8.4 compatible formatting of doubles} precision \ - {expr {1e223}} \ - 1e+223 -test util-16.1.17.224 {8.4 compatible formatting of doubles} precision \ - {expr {1e224}} \ - 9.9999999999999997e+223 -test util-16.1.17.225 {8.4 compatible formatting of doubles} precision \ - {expr {1e225}} \ - 9.9999999999999993e+224 -test util-16.1.17.226 {8.4 compatible formatting of doubles} precision \ - {expr {1e226}} \ - 9.9999999999999996e+225 -test util-16.1.17.227 {8.4 compatible formatting of doubles} precision \ - {expr {1e227}} \ - 1.0000000000000001e+227 -test util-16.1.17.228 {8.4 compatible formatting of doubles} precision \ - {expr {1e228}} \ - 9.9999999999999992e+227 -test util-16.1.17.229 {8.4 compatible formatting of doubles} precision \ - {expr {1e229}} \ - 9.9999999999999999e+228 -test util-16.1.17.230 {8.4 compatible formatting of doubles} precision \ - {expr {1e230}} \ - 1.0000000000000001e+230 -test util-16.1.17.231 {8.4 compatible formatting of doubles} precision \ - {expr {1e231}} \ - 1.0000000000000001e+231 -test util-16.1.17.232 {8.4 compatible formatting of doubles} precision \ - {expr {1e232}} \ - 1.0000000000000001e+232 -test util-16.1.17.233 {8.4 compatible formatting of doubles} precision \ - {expr {1e233}} \ - 9.9999999999999997e+232 -test util-16.1.17.234 {8.4 compatible formatting of doubles} precision \ - {expr {1e234}} \ - 1e+234 -test util-16.1.17.235 {8.4 compatible formatting of doubles} precision \ - {expr {1e235}} \ - 1.0000000000000001e+235 -test util-16.1.17.236 {8.4 compatible formatting of doubles} precision \ - {expr {1e236}} \ - 1.0000000000000001e+236 -test util-16.1.17.237 {8.4 compatible formatting of doubles} precision \ - {expr {1e237}} \ - 9.9999999999999994e+236 -test util-16.1.17.238 {8.4 compatible formatting of doubles} precision \ - {expr {1e238}} \ - 1e+238 -test util-16.1.17.239 {8.4 compatible formatting of doubles} precision \ - {expr {1e239}} \ - 9.9999999999999999e+238 -test util-16.1.17.240 {8.4 compatible formatting of doubles} precision \ - {expr {1e240}} \ - 1e+240 -test util-16.1.17.241 {8.4 compatible formatting of doubles} precision \ - {expr {1e241}} \ - 1.0000000000000001e+241 -test util-16.1.17.242 {8.4 compatible formatting of doubles} precision \ - {expr {1e242}} \ - 1.0000000000000001e+242 -test util-16.1.17.243 {8.4 compatible formatting of doubles} precision \ - {expr {1e243}} \ - 1.0000000000000001e+243 -test util-16.1.17.244 {8.4 compatible formatting of doubles} precision \ - {expr {1e244}} \ - 1.0000000000000001e+244 -test util-16.1.17.245 {8.4 compatible formatting of doubles} precision \ - {expr {1e245}} \ - 1e+245 -test util-16.1.17.246 {8.4 compatible formatting of doubles} precision \ - {expr {1e246}} \ - 1.0000000000000001e+246 -test util-16.1.17.247 {8.4 compatible formatting of doubles} precision \ - {expr {1e247}} \ - 9.9999999999999995e+246 -test util-16.1.17.248 {8.4 compatible formatting of doubles} precision \ - {expr {1e248}} \ - 1e+248 -test util-16.1.17.249 {8.4 compatible formatting of doubles} precision \ - {expr {1e249}} \ - 9.9999999999999992e+248 -test util-16.1.17.250 {8.4 compatible formatting of doubles} precision \ - {expr {1e250}} \ - 9.9999999999999992e+249 -test util-16.1.17.251 {8.4 compatible formatting of doubles} precision \ - {expr {1e251}} \ - 1e+251 -test util-16.1.17.252 {8.4 compatible formatting of doubles} precision \ - {expr {1e252}} \ - 1.0000000000000001e+252 -test util-16.1.17.253 {8.4 compatible formatting of doubles} precision \ - {expr {1e253}} \ - 9.9999999999999994e+252 -test util-16.1.17.254 {8.4 compatible formatting of doubles} precision \ - {expr {1e254}} \ - 9.9999999999999994e+253 -test util-16.1.17.255 {8.4 compatible formatting of doubles} precision \ - {expr {1e255}} \ - 9.9999999999999999e+254 -test util-16.1.17.256 {8.4 compatible formatting of doubles} precision \ - {expr {1e256}} \ - 1e+256 -test util-16.1.17.257 {8.4 compatible formatting of doubles} precision \ - {expr {1e257}} \ - 1e+257 -test util-16.1.17.258 {8.4 compatible formatting of doubles} precision \ - {expr {1e258}} \ - 1.0000000000000001e+258 -test util-16.1.17.259 {8.4 compatible formatting of doubles} precision \ - {expr {1e259}} \ - 9.9999999999999993e+258 -test util-16.1.17.260 {8.4 compatible formatting of doubles} precision \ - {expr {1e260}} \ - 1.0000000000000001e+260 -test util-16.1.17.261 {8.4 compatible formatting of doubles} precision \ - {expr {1e261}} \ - 9.9999999999999993e+260 -test util-16.1.17.262 {8.4 compatible formatting of doubles} precision \ - {expr {1e262}} \ - 1e+262 -test util-16.1.17.263 {8.4 compatible formatting of doubles} precision \ - {expr {1e263}} \ - 1e+263 -test util-16.1.17.264 {8.4 compatible formatting of doubles} precision \ - {expr {1e264}} \ - 1e+264 -test util-16.1.17.265 {8.4 compatible formatting of doubles} precision \ - {expr {1e265}} \ - 1.0000000000000001e+265 -test util-16.1.17.266 {8.4 compatible formatting of doubles} precision \ - {expr {1e266}} \ - 1e+266 -test util-16.1.17.267 {8.4 compatible formatting of doubles} precision \ - {expr {1e267}} \ - 9.9999999999999997e+266 -test util-16.1.17.268 {8.4 compatible formatting of doubles} precision \ - {expr {1e268}} \ - 9.9999999999999997e+267 -test util-16.1.17.269 {8.4 compatible formatting of doubles} precision \ - {expr {1e269}} \ - 1e+269 -test util-16.1.17.270 {8.4 compatible formatting of doubles} precision \ - {expr {1e270}} \ - 1e+270 -test util-16.1.17.271 {8.4 compatible formatting of doubles} precision \ - {expr {1e271}} \ - 9.9999999999999995e+270 -test util-16.1.17.272 {8.4 compatible formatting of doubles} precision \ - {expr {1e272}} \ - 1.0000000000000001e+272 -test util-16.1.17.273 {8.4 compatible formatting of doubles} precision \ - {expr {1e273}} \ - 9.9999999999999995e+272 -test util-16.1.17.274 {8.4 compatible formatting of doubles} precision \ - {expr {1e274}} \ - 9.9999999999999992e+273 -test util-16.1.17.275 {8.4 compatible formatting of doubles} precision \ - {expr {1e275}} \ - 9.9999999999999996e+274 -test util-16.1.17.276 {8.4 compatible formatting of doubles} precision \ - {expr {1e276}} \ - 1.0000000000000001e+276 -test util-16.1.17.277 {8.4 compatible formatting of doubles} precision \ - {expr {1e277}} \ - 1e+277 -test util-16.1.17.278 {8.4 compatible formatting of doubles} precision \ - {expr {1e278}} \ - 9.9999999999999996e+277 -test util-16.1.17.279 {8.4 compatible formatting of doubles} precision \ - {expr {1e279}} \ - 1.0000000000000001e+279 -test util-16.1.17.280 {8.4 compatible formatting of doubles} precision \ - {expr {1e280}} \ - 1e+280 -test util-16.1.17.281 {8.4 compatible formatting of doubles} precision \ - {expr {1e281}} \ - 1e+281 -test util-16.1.17.282 {8.4 compatible formatting of doubles} precision \ - {expr {1e282}} \ - 1e+282 -test util-16.1.17.283 {8.4 compatible formatting of doubles} precision \ - {expr {1e283}} \ - 9.9999999999999996e+282 -test util-16.1.17.284 {8.4 compatible formatting of doubles} precision \ - {expr {1e284}} \ - 1.0000000000000001e+284 -test util-16.1.17.285 {8.4 compatible formatting of doubles} precision \ - {expr {1e285}} \ - 9.9999999999999998e+284 -test util-16.1.17.286 {8.4 compatible formatting of doubles} precision \ - {expr {1e286}} \ - 1e+286 -test util-16.1.17.287 {8.4 compatible formatting of doubles} precision \ - {expr {1e287}} \ - 1.0000000000000001e+287 -test util-16.1.17.288 {8.4 compatible formatting of doubles} precision \ - {expr {1e288}} \ - 1e+288 -test util-16.1.17.289 {8.4 compatible formatting of doubles} precision \ - {expr {1e289}} \ - 1.0000000000000001e+289 -test util-16.1.17.290 {8.4 compatible formatting of doubles} precision \ - {expr {1e290}} \ - 1.0000000000000001e+290 -test util-16.1.17.291 {8.4 compatible formatting of doubles} precision \ - {expr {1e291}} \ - 9.9999999999999996e+290 -test util-16.1.17.292 {8.4 compatible formatting of doubles} precision \ - {expr {1e292}} \ - 1e+292 -test util-16.1.17.293 {8.4 compatible formatting of doubles} precision \ - {expr {1e293}} \ - 9.9999999999999992e+292 -test util-16.1.17.294 {8.4 compatible formatting of doubles} precision \ - {expr {1e294}} \ - 1.0000000000000001e+294 -test util-16.1.17.295 {8.4 compatible formatting of doubles} precision \ - {expr {1e295}} \ - 9.9999999999999998e+294 -test util-16.1.17.296 {8.4 compatible formatting of doubles} precision \ - {expr {1e296}} \ - 9.9999999999999998e+295 -test util-16.1.17.297 {8.4 compatible formatting of doubles} precision \ - {expr {1e297}} \ - 1e+297 -test util-16.1.17.298 {8.4 compatible formatting of doubles} precision \ - {expr {1e298}} \ - 9.9999999999999996e+297 -test util-16.1.17.299 {8.4 compatible formatting of doubles} precision \ - {expr {1e299}} \ - 1.0000000000000001e+299 -test util-16.1.17.300 {8.4 compatible formatting of doubles} precision \ - {expr {1e300}} \ - 1.0000000000000001e+300 -test util-16.1.17.301 {8.4 compatible formatting of doubles} precision \ - {expr {1e301}} \ - 1.0000000000000001e+301 -test util-16.1.17.302 {8.4 compatible formatting of doubles} precision \ - {expr {1e302}} \ - 1.0000000000000001e+302 -test util-16.1.17.303 {8.4 compatible formatting of doubles} precision \ - {expr {1e303}} \ - 1e+303 -test util-16.1.17.304 {8.4 compatible formatting of doubles} precision \ - {expr {1e304}} \ - 9.9999999999999994e+303 -test util-16.1.17.305 {8.4 compatible formatting of doubles} precision \ - {expr {1e305}} \ - 9.9999999999999994e+304 -test util-16.1.17.306 {8.4 compatible formatting of doubles} precision \ - {expr {1e306}} \ - 1e+306 -test util-16.1.17.307 {8.4 compatible formatting of doubles} precision \ - {expr {1e307}} \ - 9.9999999999999999e+306 - test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { set r {} foreach {input} { @@ -4178,10 +2231,6 @@ test util-18.12 {Tcl_ObjPrintf} {testprint} { testprint "%I64d %Id" 65537 } {65537 65537} -if {[catch {set ::tcl_precision $saved_precision}]} { - unset ::tcl_precision -} - # cleanup ::tcltest::cleanupTests return diff --git a/tests/var.test b/tests/var.test index 5300adc..405a4b8 100644 --- a/tests/var.test +++ b/tests/var.test @@ -269,10 +269,11 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { catch {unset ::test_ns_var::vv} proc p {} { # create namespace var vv linked to global a - testupvar 1 a {} vv namespace + testupvar 2 a {} vv namespace } p } + # Modified: that should create a global var according to the docs! list $test_ns_var::vv [set test_ns_var::vv 123] $a } -result {456 123 123} test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { @@ -464,7 +465,7 @@ test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { set six 666 namespace eval test_ns_var { variable five 5 six - lappend a $five + lappend ::a $five } lappend a $test_ns_var::five \ [set test_ns_var::six 6] [set test_ns_var::six] $six @@ -491,9 +492,9 @@ test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, l set a "" namespace eval test_ns_var { variable eight 8 - lappend a $eight + lappend ::a $eight variable eight - lappend a $eight + lappend ::a $eight } set a } {8 8} @@ -1479,6 +1480,781 @@ test var-24.24 {array default unset: errors} -setup { } -returnCodes error -cleanup { unset -nocomplain ary } -result * -match glob + +# The const command +test var-25.1 {const: no argument} -body { + apply {{} { + const + return $X + }} +} -returnCodes error -result {wrong # args: should be "const varName value"} +test var-25.2 {const: single argument} -body { + apply {{} { + const X + return $X + }} +} -returnCodes error -result {wrong # args: should be "const varName value"} +test var-25.3 {const: two arguments (basic correct usage)} { + apply {{} { + set res [const X gorp] + return [list $res $X] + }} +} {{} gorp} +test var-25.4 {const: three arguments} -body { + apply {{} { + const X gorp foo + return $X + }} +} -returnCodes error -result {wrong # args: should be "const varName value"} +test var-25.5 {const: four arguments} -body { + apply {{} { + const X gorp foo bar + return $X + }} +} -returnCodes error -result {wrong # args: should be "const varName value"} + +test var-26.1 {const: unmodifiable by set} -body { + apply {{} { + const X 123 + set X gorp + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.2 {const: unmodifiable by append} -body { + apply {{} { + const X 123 + append X gorp + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.3 {const: unmodifiable by lappend} -body { + apply {{} { + const X 123 + lappend X gorp + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.4 {const: unmodifiable by incr} -body { + apply {{} { + const X 123 + incr X + }} +} -returnCodes error -result {can't incr "X": variable is a constant} +test var-26.5 {const: unmodifiable by dict set} -body { + apply {{} { + const X {a 123} + dict set X a gorp + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.6 {const: unmodifiable by regsub} -body { + apply {{} { + const X abcabc + regsub -all {a(.)} $X {\1\1} X + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.7 {const: unmodifiable by gets} -setup { + set file [makeFile foo var26.7.txt] + set f [open $file] +} -body { + apply {f { + const X abcabc + gets $f X + }} $f +} -returnCodes error -cleanup { + close $f + removeFile $file +} -result {can't set "X": variable is a constant} +test var-26.8 {const: may not be array} -body { + apply {{} { + array set X {a b} + const X 1 + return $X + }} +} -returnCodes error -result {can't make constant "X": variable is array} +test var-26.9.1 {const: may not be array element} -body { + apply {{} { + array set X {a b} + const X(a) 1 + return $X(a) + }} +} -returnCodes error -result {can't make constant "X(a)": name refers to an element in an array} +test var-26.9.2 {const: may not be array element} -body { + apply {{} { + array set X {a b} + const X(b) 1 + return $X(b) + }} +} -returnCodes error -result {can't make constant "X(b)": name refers to an element in an array} +test var-26.10.1 {const: unmodifiable by const but not an error} { + apply {{} { + const X 1 + const X 2 + return $X + }} +} 1 +test var-26.10.2 {const: unmodifiable by const but not an error} { + apply {{} { + lmap x {1 2 3} { + const A 2 + const B 3 + const C 5 + expr {$A * $x**2 + $B * $x + $C} + } + }} +} {10 19 32} +test var-26.11 {const: may not be unset} -body { + apply {{} { + const X 1 + unset X + }} +} -returnCodes error -result {can't unset "X": variable is a constant} +test var-26.12 {const: may not be unset, but -nocomplain doesn't complain} { + apply {{} { + const X 1 + unset -nocomplain X + return $X + }} +} 1 +test var-26.13 {const and traces: write trace causes fail} -body { + apply {{} { + trace add variable X write {apply {args { + error "ERR: $args" + }}} + const X gorp + return $X + }} +} -returnCodes error -result {can't set "X": ERR: X {} write} +test var-26.14 {const and traces: write trace err causes no const} -body { + apply {{} { + set trace {apply {args { + error "ERR: $args" + }}} + trace add variable X write $trace + catch { + const X gorp + } + trace remove variable X write $trace + set X 123 + return $X + }} +} -result 123 +test var-26.15 {const and traces: read traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + apply {{} { + trace add variable X read {apply {args { + lappend ::traces $args + }}} + const X gorp + list $X $X $::traces + }} +} -result {gorp gorp {{X {} read} {X {} read}}} -cleanup { + unset -nocomplain traces +} +test var-26.16 {const and traces: write traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + apply {{} { + trace add variable X write {apply {args { + lappend ::traces $args + }}} + const X gorp + const X foo + catch {set X bar} + list $X $::traces + }} +} -result {gorp {{X {} write}}} -cleanup { + unset -nocomplain traces +} +test var-26.17 {const and traces: unset traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + list {*}[apply {{} { + trace add variable X unset {apply {args { + lappend ::traces $args + }}} + const X gorp + unset -nocomplain X + list $X $::traces + }}] $traces +} -result {gorp {} {{X {} unset}}} -cleanup { + unset -nocomplain traces +} + +# Same [const], but definitely not compiled +test var-27.1 {const: unmodifiable by set} -body { + apply {const { + $const X 123 + set X gorp + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.2 {const: unmodifiable by append} -body { + apply {const { + $const X 123 + append X gorp + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.3 {const: unmodifiable by lappend} -body { + apply {const { + $const X 123 + lappend X gorp + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.4 {const: unmodifiable by incr} -body { + apply {const { + $const X 123 + incr X + }} const +} -returnCodes error -result {can't incr "X": variable is a constant} +test var-27.5 {const: unmodifiable by dict set} -body { + apply {const { + $const X {a 123} + dict set X a gorp + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.6 {const: unmodifiable by regsub} -body { + apply {const { + $const X abcabc + regsub -all {a(.)} $X {\1\1} X + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.7 {const: unmodifiable by gets} -setup { + set file [makeFile foo var27.7.txt] + set f [open $file] +} -body { + apply {{const f} { + $const X abcabc + gets $f X + }} const $f +} -returnCodes error -cleanup { + close $f + removeFile $file +} -result {can't set "X": variable is a constant} +test var-27.8 {const: may not be array} -body { + apply {const { + array set X {a b} + $const X 1 + return $X + }} const +} -returnCodes error -result {can't make constant "X": variable is array} +test var-27.9.1 {const: may not be array element} -body { + apply {const { + array set X {a b} + $const X(a) 1 + return $X(a) + }} const +} -returnCodes error -result {can't make constant "X(a)": name refers to an element in an array} +test var-27.9.2 {const: may not be array element} -body { + apply {const { + array set X {a b} + $const X(b) 1 + return $X(b) + }} const +} -returnCodes error -result {can't make constant "X(b)": name refers to an element in an array} +test var-27.10.1 {const: unmodifiable by const but not an error} { + apply {const { + $const X 1 + $const X 2 + return $X + }} const +} 1 +test var-27.10.2 {const: unmodifiable by const but not an error} { + apply {const { + lmap x {1 2 3} { + $const A 2 + $const B 3 + $const C 5 + expr {$A * $x**2 + $B * $x + $C} + } + }} const +} {10 19 32} +test var-27.11 {const: may not be unset} -body { + apply {const { + $const X 1 + unset X + }} const +} -returnCodes error -result {can't unset "X": variable is a constant} +test var-27.12 {const: may not be unset, but -nocomplain doesn't complain} { + apply {const { + $const X 1 + unset -nocomplain X + return $X + }} const +} 1 +test var-27.13 {const and traces: write trace causes fail} -body { + apply {const { + trace add variable X write {apply {args { + error "ERR: $args" + }}} + $const X gorp + return $X + }} const +} -returnCodes error -result {can't set "X": ERR: X {} write} +test var-27.14 {const and traces: write trace err causes no const} -body { + apply {const { + set trace {apply {args { + error "ERR: $args" + }}} + trace add variable X write $trace + catch { + $const X gorp + } + trace remove variable X write $trace + set X 123 + return $X + }} const +} -result 123 +test var-27.15 {const and traces: read traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + apply {const { + trace add variable X read {apply {args { + lappend ::traces $args + }}} + $const X gorp + list $X $X $::traces + }} const +} -result {gorp gorp {{X {} read} {X {} read}}} -cleanup { + unset -nocomplain traces +} +test var-27.16 {const and traces: write traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + apply {const { + trace add variable X write {apply {args { + lappend ::traces $args + }}} + $const X gorp + $const X foo + catch {set X bar} + list $X $::traces + }} const +} -result {gorp {{X {} write}}} -cleanup { + unset -nocomplain traces +} +test var-27.17 {const and traces: unset traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + list {*}[apply {const { + trace add variable X unset {apply {args { + lappend ::traces $args + }}} + $const X gorp + unset -nocomplain X + list $X $::traces + }} const] $traces +} -result {gorp {} {{X {} unset}}} -cleanup { + unset -nocomplain traces +} + +test var-28.1 {const: in a namespace} -setup { + namespace eval var28 {} +} -body { + namespace eval var28 { + variable X + const X gorp + return $X + } +} -cleanup { + namespace delete var28 +} -result gorp +test var-28.2 {const: in a namespace} -setup { + namespace eval var28 {} +} -body { + namespace eval var28 { + variable X + const X gorp + } + apply {{} { + variable X + set X 123 + } var28} +} -cleanup { + namespace delete var28 +} -returnCodes error -result {can't set "X": variable is a constant} +test var-28.3 {const: in a namespace} -setup { + namespace eval var28 {} +} -body { + namespace eval var28 { + variable X + const X gorp + } + apply {{} { + variable X + unset X + } var28} +} -cleanup { + namespace delete var28 +} -returnCodes error -result {can't unset "X": variable is a constant} +test var-28.4 {const: in a namespace} -setup { + namespace eval var28 {} +} -body { + namespace eval var28 { + variable X + const X gorp + } + namespace delete var28 + namespace eval var28 { + variable X abc + } + apply {{} { + variable X + return $X + } var28} +} -cleanup { + namespace delete var28 +} -result abc +test var-28.5 {const: in a namespace, direct access from proc} -setup { + namespace eval var28 {} +} -body { + set result [apply {{} { + const ::var28::X abc + # Constant in namespace, NOT locally! + info exists X + }}] + apply {res { + variable X + list $res [catch {unset X} msg] $msg $X + } var28} $result +} -cleanup { + namespace delete var28 +} -result {0 1 {can't unset "X": variable is a constant} abc} + +test var-29.1 {const: globally} -setup { + set int [interp create] +} -body { + $int eval { + const X gorp + apply {{} { + global X + return $X + }} + } +} -cleanup { + interp delete $int +} -result gorp +test var-29.2 {const: TclOO variable resolution} -setup { + oo::class create Parent +} -body { + oo::class create C { + superclass Parent + variable X + constructor {} { + const X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + set c [C new] + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Parent destroy +} -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} +test var-29.3 {const: TclOO variable resolution} -setup { + oo::class create Parent +} -body { + oo::class create C { + superclass Parent + private variable X + constructor {} { + const X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + set c [C new] + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Parent destroy +} -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} +test var-29.4 {const: TclOO variable resolution} -setup { + oo::class create Parent +} -body { + oo::class create C { + superclass Parent + variable X + constructor {} { + set X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + set X gorp + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + set c [C new] + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Parent destroy +} -result {123 {0 abc} {0 gorp} 0 {}} +test var-29.5 {const: TclOO variable resolution} -setup { + set c [oo::object create Instance] +} -body { + oo::objdefine $c { + variable X + method init {} { + const X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + $c init + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Instance destroy +} -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} +test var-29.6 {const: TclOO variable resolution} -setup { + set c [oo::object create Instance] +} -body { + oo::objdefine $c { + private variable X + method init {} { + const X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + $c init + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Instance destroy +} -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} +test var-29.7 {const: TclOO variable resolution} -setup { + set c [oo::object create Instance] +} -body { + oo::objdefine $c { + variable X + method init {} { + set X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + set X gorp + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + $c init + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Instance destroy +} -result {123 {0 abc} {0 gorp} 0 {}} + +# The info constant and info consts commands +test var-30.1 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts]] [info constant X] + const X 1 + lappend consts [lsort [info consts]] [info constant X] + const Y 2 + lappend consts [lsort [info consts]] + const X 3 + lappend consts [lsort [info consts]] + }} +} {{} 0 X 1 {X Y} {X Y}} +test var-30.2 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts X]] + const X 1 + lappend consts [lsort [info consts X]] + const Y 2 + lappend consts [lsort [info consts X]] + const X 3 + lappend consts [lsort [info consts X]] + }} +} {{} X X X} +test var-30.3 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts ?]] + const X 1 + lappend consts [lsort [info consts ?]] + const Y 2 + lappend consts [lsort [info consts ?]] + const XX 3 + lappend consts [lsort [info consts ?]] + }} +} {{} X {X Y} {X Y}} +test var-30.4 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts X]] + set X 1 + lappend consts [lsort [info consts X]] + set Y 2 + lappend consts [lsort [info consts X]] + set X 3 + lappend consts [lsort [info consts X]] + }} +} {{} {} {} {}} +test var-30.5 {info consts: in a namespace} -setup { + namespace eval var30 {} +} -body { + namespace eval var30 { + const X gorp + info consts + } +} -cleanup { + namespace delete var30 +} -result X +test var-30.6 {info consts: in a namespace} -setup { + namespace eval var30 {} +} -body { + namespace eval var30 { + const X gorp + variable Y foo + } + info consts var30::* +} -cleanup { + namespace delete var30 +} -result ::var30::X +test var-30.7 {info constant: bad constant names: array element} { + apply {{} { + info constant a(b) + }} +} 0 +test var-30.8 {info constant: bad constant names: array} { + apply {{} { + array set a {} + info constant a + }} +} 0 +test var-30.9 {info constant: bad constant names: no var} { + apply {{} { + info constant a + }} +} 0 +test var-30.10 {info constant: bad constant names: no namespace} { + apply {{} { + info constant ::var29::no::such::ns::a + }} +} 0 +test var-30.11 {info constant: bad constant names: dangling upvar} { + apply {{} { + upvar 0 no_var a + info constant a + }} +} 0 +test var-30.12 {info constant: bad constant names: bad name} { + apply {{} { + info constant a(b + }} +} 0 +test var-30.13 {info constant: bad constant names: nesting} { + apply {{} { + array set b {c d} + upvar 0 b(c) a + info constant a(d) + }} +} 0 + +test var-31.1 {info constant: syntax} -returnCodes error -body { + info constant +} -result {wrong # args: should be "info constant varName"} +test var-31.2 {info constant: syntax} -returnCodes error -body { + info constant foo bar +} -result {wrong # args: should be "info constant varName"} +test var-31.3 {info consts: syntax} -returnCodes error -body { + info consts foo bar +} -result {wrong # args: should be "info consts ?pattern?"} catch {namespace delete ns} catch {unset arr} diff --git a/tests/winConsole.test b/tests/winConsole.test index 3f23c07..5aa130b 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -344,7 +344,7 @@ test console-fconfigure-set-3.0 { fconfigure stderr -winsize } -constraints {win interactive} -body { fconfigure stderr -winsize {10 30} -} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -profile, -translation} -returnCodes error +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -profile, or -translation} -returnCodes error # Multiple threads diff --git a/tests/winFile.test b/tests/winFile.test index 0c13a0e..231fb3f 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -28,7 +28,7 @@ testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] test winFile-1.1 {TclpGetUserHome} -constraints {win} -body { glob ~nosuchuser -} -returnCodes error -result {user "nosuchuser" doesn't exist} +} -result {} test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body { # The administrator account should always exist. glob ~administrator diff --git a/tests/zipfs.test b/tests/zipfs.test index 69c682e..be4ba19 100644 --- a/tests/zipfs.test +++ b/tests/zipfs.test @@ -1448,14 +1448,14 @@ namespace eval test_ns_zipfs { 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-type-d-f $basicMounts [list -type {d f} $defMountPt/*] [zipfspathsmt $defMountPt test testdir] - testzipfsglob basic-type-l $basicMounts [list -type l $defMountPt/*] "no files matched glob pattern \"$defMountPt/*\"" -returnCodes error + testzipfsglob basic-type-l $basicMounts [list -type l $defMountPt/*] {} foreach type {b c l p s} { - testzipfsglob basic-type-$type $basicMounts [list -type $type $defMountPt/*] "no files matched glob pattern \"$defMountPt/*\"" -returnCodes error + testzipfsglob basic-type-$type $basicMounts [list -type $type $defMountPt/*] {} testzipfsglob basic-type-f-$type $basicMounts [list -type [list f $type] $defMountPt/*] [zipfspathsmt $defMountPt test] testzipfsglob basic-type-d-$type $basicMounts [list -type [list d $type] $defMountPt/*] [zipfspathsmt $defMountPt testdir] } testzipfsglob basic-path $basicMounts [list -path $defMountPt/t *d*] [zipfspathsmt $defMountPt testdir] - testzipfsglob basic-enoent $basicMounts [list $defMountPt/x*] "no files matched glob pattern \"$defMountPt/x*\"" -returnCodes error + 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 @@ -1473,7 +1473,7 @@ namespace eval test_ns_zipfs { testzipfsglob root-type-f $rootMounts [list -type f [zipfs root]*] [zipfspaths test] testzipfsglob root-type-d-f $rootMounts [list -type {d f} [zipfs root]*] [zipfspaths test testdir] -constraints !zipfslib testzipfsglob root-path $rootMounts [list -path [zipfs root]t *d*] [zipfspaths testdir] - testzipfsglob root-enoent $rootMounts [list [zipfs root]x*] {no files matched glob pattern "//zipfs:/x*"} -returnCodes error + 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 diff --git a/tests/zlib.test b/tests/zlib.test index 7679102..6becb91 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -288,23 +288,23 @@ test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup { test zlib-8.6 {transformation and fconfigure} -setup { set file [makeFile {} test.z] set fd [open $file wb] -} -constraints {zlib deprecated} -body { +} -constraints zlib -body { list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \ [chan pop $fd; fconfigure $fd] } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] -} -constraints {zlib deprecated} -body { +} -constraints zlib -body { list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \ [chan pop $fd; fconfigure $fd] } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" diff --git a/tools/README b/tools/README index a37c2f4..6e5b20e 100644 --- a/tools/README +++ b/tools/README @@ -9,11 +9,6 @@ uniClass.tcl -- Script for generating regexp class tables from the Tcl "string is" classes Generating HTML files. -The tcltk-man2html.tcl script generates a nice set of HTML with -good cross references. Use it like - cd unix - ./configure - make html This script is very picky about the organization of man pages, effectively acting as a style enforcer. The resulting documentation can be found at diff --git a/tools/checkLibraryDoc.tcl b/tools/checkLibraryDoc.tcl index 36d82b2..0ed322c 100644 --- a/tools/checkLibraryDoc.tcl +++ b/tools/checkLibraryDoc.tcl @@ -3,7 +3,7 @@ # This script attempts to determine what APIs exist in the source base that # have not been documented. By grepping through all of the doc/*.3 man # pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list -# against the list of Pkg_ APIs found in the source (e.g., tcl8.7/*/*.[ch]) +# against the list of Pkg_ APIs found in the source (e.g., tcl9.0/*/*.[ch]) # we create six lists: # 1) APIs in Source not in Docs. # 2) APIs in Docs not in Source. @@ -43,15 +43,12 @@ set StructList { Tcl_Pid \ Tcl_QueuePosition \ Tcl_ResolvedVarInfo \ - Tcl_SavedResult \ Tcl_ThreadDataKey \ Tcl_ThreadId \ Tcl_Time \ Tcl_TimerToken \ Tcl_Token \ Tcl_Trace \ - Tcl_Value \ - Tcl_ValueType \ Tcl_Var \ Tk_3DBorder \ Tk_ArgvInfo \ diff --git a/tools/findDocWords.tcl b/tools/findDocWords.tcl new file mode 100644 index 0000000..0b25315 --- /dev/null +++ b/tools/findDocWords.tcl @@ -0,0 +1,52 @@ +# findDocWords.tcl -- +# +# This script attempts to find all non-dictionary words in the Tcl or Tk +# documentation tree. It handles the fairly common compoundWord trick our +# docs use, and isn't confused by nroff formatting directives, so it isn't +# just a standard spell check. +# +# Arguments: +# 1: Directory to look for man source files in. +# 2: Path to a plain text dictionary. Try /usr/share/dict/words on Linux. +# +# Copyright © 2024 Donal K Fellows. +# See "license.terms" for the license. + +lassign $argv dir dictionary + +set f [open $dictionary] +while {[gets $f line] > 0} { + dict set realWord [string tolower $line] yes +} +close $f +puts "loaded [dict size $realWord] words from dictionary" + +set files [glob -directory $dir {*.[13n]}] +set found {} + +proc identifyWords {fragment filename} { + global realWord found + foreach frag [split [string map {\\fB "" \\fR "" \\fI "" \\fP "" \\0 _} $fragment] _] { + if {[string is entier $frag]} continue + set frag [string trim $frag "\\0123456789"] + if {$frag eq ""} continue + foreach word [regexp -all -inline {^[a-z]+|[A-Z][a-z]*} $frag] { + set word [string tolower $word] + if {![dict exists $realWord $word]} { + dict lappend found $word $filename + } + } + } +} + +foreach fn $files { + set f [open $fn] + foreach word [regexp -all -inline {[\\\w]+} [read $f]] { + identifyWords $word $fn + } + close $f +} +set len [tcl::mathfunc::max {*}[lmap word [dict keys $found] {string length $word}]] +foreach word [lsort [dict keys $found]] { + puts [format "%-${len}s: %s" $word [lindex [dict get $found $word] 0]] +} diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index 89e4ccc..b02bd9f 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -811,21 +811,6 @@ proc genStubs::forAllStubs {name slotProc onAll textVar set temp {} set plat aqua if {!$slot(unix) && !$slot(macosx)} { - if {[string range $skipString 1 2] ne "/*"} { - # genStubs.tcl previously had a bug here causing it to - # erroneously generate both a unix entry and an aqua - # entry for a given stubs table slot. To preserve - # backwards compatibility, generate a dummy stubs entry - # before every aqua entry (note that this breaks the - # correspondence between emitted entry number and - # actual position of the entry in the stubs table, e.g. - # TkIntStubs entry 113 for aqua is in fact at position - # 114 in the table, entry 114 at position 116 etc). - eval {append temp} $skipString - set temp "[string range $temp 0 end-1] /*\ - Dummy entry for stubs table backwards\ - compatibility */\n" - } if {$slot($plat)} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } elseif {$onAll} { diff --git a/tools/regexpTestLib.tcl b/tools/regexpTestLib.tcl index 71dc909..c5c156e 100644 --- a/tools/regexpTestLib.tcl +++ b/tools/regexpTestLib.tcl @@ -183,9 +183,9 @@ proc convertTestLine {currentLine len lineNum srcLineNum} { set noBraces 0 if {[regexp {=|>} $flags] == 1} { regsub -all {_} $currentLine {\\ } currentLine - regsub -all {A} $currentLine {\\007} currentLine + regsub -all {A} $currentLine {\\x07} currentLine regsub -all {B} $currentLine {\\b} currentLine - regsub -all {E} $currentLine {\\033} currentLine + regsub -all {E} $currentLine {\\x1B} currentLine regsub -all {F} $currentLine {\\f} currentLine regsub -all {N} $currentLine {\\n} currentLine diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index 2dec0a6..7b3558d 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -22,7 +22,7 @@ if {[catch {package require Tcl 8.6-} msg]} { # Copyright © 1995-1997 Roger E. Critchlow Jr # Copyright © 2004-2010 Donal K. Fellows -set ::Version "50/8.7" +set ::Version "50/9.0" set ::CSSFILE "docs.css" ## @@ -578,7 +578,7 @@ proc plus-pkgs {type args} { ## Set up some special cases. It would be nice if we didn't have them, ## but we do... ## -set excluded_pages {case menubar pack-old} +set excluded_pages {} set forced_index_pages {GetDash} set process_first_patterns {*/ttk_widget.n */options.n} set ensemble_commands { diff --git a/tools/tsdPerf.c b/tools/tsdPerf.c index 4c96f28..0bcc11b 100644 --- a/tools/tsdPerf.c +++ b/tools/tsdPerf.c @@ -10,7 +10,7 @@ typedef struct { static int -tsdPerfSetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { +tsdPerfSetObjCmd(void *cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf)); Tcl_WideInt i; @@ -29,7 +29,7 @@ tsdPerfSetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const } static int -tsdPerfGetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { +tsdPerfGetObjCmd(void *cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf)); diff --git a/tools/ucm2tests.tcl b/tools/ucm2tests.tcl deleted file mode 100644 index dc878ef..0000000 --- a/tools/ucm2tests.tcl +++ /dev/null @@ -1,352 +0,0 @@ -# ucm2tests.tcl -# -# Parses given ucm files (from ICU) to generate test data -# for encodings. -# -# tclsh ucm2tests.tcl PATH_TO_ICU_UCM_DIRECTORY ?OUTPUTPATH? -# - -namespace eval ucm { - # No means to change these currently but ... - variable outputPath - variable outputChan - variable errorChan stderr - variable verbose 0 - - # Map Tcl encoding name to ICU UCM file name - variable encNameMap - array set encNameMap { - cp1250 glibc-CP1250-2.1.2 - cp1251 glibc-CP1251-2.1.2 - cp1252 glibc-CP1252-2.1.2 - cp1253 glibc-CP1253-2.1.2 - cp1254 glibc-CP1254-2.1.2 - cp1255 glibc-CP1255-2.1.2 - cp1256 glibc-CP1256-2.1.2 - cp1257 glibc-CP1257-2.1.2 - cp1258 glibc-CP1258-2.1.2 - gb1988 glibc-GB_1988_80-2.3.3 - iso8859-1 glibc-ISO_8859_1-2.1.2 - iso8859-2 glibc-ISO_8859_2-2.1.2 - iso8859-3 glibc-ISO_8859_3-2.1.2 - iso8859-4 glibc-ISO_8859_4-2.1.2 - iso8859-5 glibc-ISO_8859_5-2.1.2 - iso8859-6 glibc-ISO_8859_6-2.1.2 - iso8859-7 glibc-ISO_8859_7-2.3.3 - iso8859-8 glibc-ISO_8859_8-2.3.3 - iso8859-9 glibc-ISO_8859_9-2.1.2 - iso8859-10 glibc-ISO_8859_10-2.1.2 - iso8859-11 glibc-ISO_8859_11-2.1.2 - iso8859-13 glibc-ISO_8859_13-2.3.3 - iso8859-14 glibc-ISO_8859_14-2.1.2 - iso8859-15 glibc-ISO_8859_15-2.1.2 - iso8859-16 glibc-ISO_8859_16-2.3.3 - } - - # Array keyed by Tcl encoding name. Each element contains mapping of - # Unicode code point -> byte sequence for that encoding as a flat list - # (or dictionary). Both are stored as hex strings - variable charMap - - # Array keyed by Tcl encoding name. List of invalid code sequences - # each being a hex string. - variable invalidCodeSequences - - # Array keyed by Tcl encoding name. List of unicode code points that are - # not mapped, each being a hex string. - variable unmappedCodePoints - - # The fallback character per encoding - variable encSubchar -} - -proc ucm::abort {msg} { - variable errorChan - puts $errorChan $msg - exit 1 -} -proc ucm::warn {msg} { - variable errorChan - puts $errorChan $msg -} -proc ucm::log {msg} { - variable verbose - if {$verbose} { - variable errorChan - puts $errorChan $msg - } -} -proc ucm::print {s} { - variable outputChan - puts $outputChan $s -} - -proc ucm::parse_SBCS {encName fd} { - variable charMap - variable invalidCodeSequences - variable unmappedCodePoints - - set result {} - while {[gets $fd line] >= 0} { - if {[string match #* $line]} { - continue - } - if {[string equal "END CHARMAP" [string trim $line]]} { - break - } - if {![regexp {^\s*<U([[:xdigit:]]{4})>\s*((\\x[[:xdigit:]]{2})+)\s*(\|(0|1|2|3|4))} $line -> unichar bytes - - precision]} { - error "Unexpected line parsing SBCS: $line" - } - set bytes [string map {\\x {}} $bytes]; # \xNN -> NN - if {$precision eq "" || $precision eq "0"} { - lappend result $unichar $bytes - } else { - # It is a fallback mapping - ignore - } - } - set charMap($encName) $result - - # Find out invalid code sequences and unicode code points that are not mapped - set valid {} - set mapped {} - foreach {unich bytes} $result { - lappend mapped $unich - lappend valid $bytes - } - set invalidCodeSequences($encName) {} - for {set i 0} {$i <= 255} {incr i} { - set hex [format %.2X $i] - if {[lsearch -exact $valid $hex] < 0} { - lappend invalidCodeSequences($encName) $hex - } - } - - set unmappedCodePoints($encName) {} - for {set i 0} {$i <= 65535} {incr i} { - set hex [format %.4X $i] - if {[lsearch -exact $mapped $hex] < 0} { - lappend unmappedCodePoints($encName) $hex - # Only look for (at most) one below 256 and one above 1024 - if {$i < 255} { - # Found one so jump past 8 bits - set i 255 - } else { - break - } - } - if {$i == 255} { - set i 1023 - } - } - lappend unmappedCodePoints($encName) D800 DC00 10000 10FFFF -} - -proc ucm::generate_boilerplate {} { - # Common procedures - print { -# This file is automatically generated by ucm2tests.tcl. -# Edits will be overwritten on next generation. -# -# Generates tests comparing Tcl encodings to ICU. -# The generated file is NOT standalone. It should be sourced into a test script. - -proc ucmConvertfromMismatches {enc map} { - set mismatches {} - foreach {unihex hex} $map { - set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits - set unich [subst "\\U$unihex"] - if {[encoding convertfrom -profile strict $enc [binary decode hex $hex]] ne $unich} { - lappend mismatches "<[printable $unich],$hex>" - } - } - return $mismatches -} -proc ucmConverttoMismatches {enc map} { - set mismatches {} - foreach {unihex hex} $map { - set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits - set unich [subst "\\U$unihex"] - if {[encoding convertto -profile strict $enc $unich] ne [binary decode hex $hex]} { - lappend mismatches "<[printable $unich],$hex>" - } - } - return $mismatches -} -if {[info commands printable] eq ""} { - proc printable {s} { - set print "" - foreach c [split $s ""] { - set i [scan $c %c] - if {[string is print $c] && ($i <= 127)} { - append print $c - } elseif {$i <= 0xff} { - append print \\x[format %02X $i] - } elseif {$i <= 0xffff} { - append print \\u[format %04X $i] - } else { - append print \\U[format %08X $i] - } - } - return $print - } -} - } -} ; # generate_boilerplate - -proc ucm::generate_tests {} { - variable encNameMap - variable charMap - variable invalidCodeSequences - variable unmappedCodePoints - variable outputPath - variable outputChan - variable encSubchar - - if {[info exists outputPath]} { - set outputChan [open $outputPath w] - fconfigure $outputChan -translation lf - } else { - set outputChan stdout - } - - array set tclNames {} - foreach encName [encoding names] { - set tclNames($encName) "" - } - - generate_boilerplate - foreach encName [lsort -dictionary [array names encNameMap]] { - if {![info exists charMap($encName)]} { - warn "No character map read for $encName" - continue - } - unset tclNames($encName) - - # Print the valid tests - print "\n#\n# $encName (generated from $encNameMap($encName))" - print "\ntest encoding-convertfrom-ucmCompare-$encName {Compare against ICU UCM} -body \{" - print " ucmConvertfromMismatches $encName {$charMap($encName)}" - print "\} -result {}" - print "\ntest encoding-convertto-ucmCompare-$encName {Compare against ICU UCM} -body \{" - print " ucmConverttoMismatches $encName {$charMap($encName)}" - print "\} -result {}" - if {0} { - # This will generate individual tests for every char - # and test in lead, tail, middle, solo configurations - # but takes considerable time - print "lappend encValidStrings \{*\}\{" - foreach {unich hex} $charMap($encName) { - print " $encName \\u$unich $hex {} {}" - } - print "\}; # $encName" - } - - # Generate the invalidity checks - print "\n# $encName - invalid byte sequences" - print "lappend encInvalidBytes \{*\}\{" - foreach hex $invalidCodeSequences($encName) { - # Map XXXX... to \xXX\xXX... - set uhex [regsub -all .. $hex {\\x\0}] - set uhex \\U[string range 00000000$hex end-7 end] - print " $encName $hex tcl8 $uhex -1 {} {}" - print " $encName $hex replace \\uFFFD -1 {} {}" - print " $encName $hex strict {} 0 {} {}" - } - print "\}; # $encName" - - print "\n# $encName - invalid byte sequences" - print "lappend encUnencodableStrings \{*\}\{" - if {[info exists encSubchar($encName)]} { - set subchar $encSubchar($encName) - } else { - set subchar "3F"; # Tcl uses ? by default - } - foreach hex $unmappedCodePoints($encName) { - set uhex \\U[string range 00000000$hex end-7 end] - print " $encName $uhex tcl8 $subchar -1 {} {}" - print " $encName $uhex replace $subchar -1 {} {}" - print " $encName $uhex strict {} 0 {} {}" - } - print "\}; # $encName" - } - - if {[array size tclNames]} { - warn "Missing encoding: [lsort [array names tclNames]]" - } - if {[info exists outputPath]} { - close $outputChan - unset outputChan - } -} - -proc ucm::parse_file {encName ucmPath} { - variable charMap - variable encSubchar - - set fd [open $ucmPath] - try { - # Parse the metadata - unset -nocomplain state - while {[gets $fd line] >= 0} { - if {[regexp {<(code_set_name|mb_cur_max|mb_cur_min|uconv_class|subchar)>\s+(\S+)} $line -> key val]} { - set state($key) $val - } elseif {[regexp {^\s*CHARMAP\s*$} $line]} { - set state(charmap) "" - break - } else { - # Skip all else - } - } - if {![info exists state(charmap)]} { - abort "Error: $ucmPath has No CHARMAP line." - } - foreach key {code_set_name uconv_class} { - if {[info exists state($key)]} { - set state($key) [string trim $state($key) {"}] - } - } - if {[info exists charMap($encName)]} { - abort "Duplicate file for $encName ($path)" - } - if {![info exists state(uconv_class)]} { - abort "Error: $ucmPath has no uconv_class definition." - } - if {[info exists state(subchar)]} { - # \xNN\xNN.. -> NNNN.. - set encSubchar($encName) [string map {\\x {}} $state(subchar)] - } - switch -exact -- $state(uconv_class) { - SBCS { - if {[catch { - parse_SBCS $encName $fd - } result]} { - abort "Could not process $ucmPath. $result" - } - } - default { - log "Skipping $ucmPath -- not SBCS encoding." - return - } - } - } finally { - close $fd - } -} - -proc ucm::run {} { - variable encNameMap - variable outputPath - switch [llength $::argv] { - 2 {set outputPath [lindex $::argv 1]} - 1 {} - default { - abort "Usage: [info nameofexecutable] $::argv0 path/to/icu/ucm/data ?outputfile?" - } - } - foreach {encName fname} [array get encNameMap] { - ucm::parse_file $encName [file join [lindex $::argv 0] ${fname}.ucm] - } - generate_tests -} - -ucm::run diff --git a/tools/valgrind_suppress b/tools/valgrind_suppress index 11ca880..c165948 100644 --- a/tools/valgrind_suppress +++ b/tools/valgrind_suppress @@ -47,6 +47,7 @@ Memcheck:Leak match-leak-kinds: reachable fun:malloc + ... fun:decompose_rpath ... fun:dlopen_doit @@ -181,6 +182,17 @@ } { + TclpGetGrGid/getgrgid_r/tls_get_addr_tail + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:tls_get_addr_tail + ... + fun:TclpGetGrGid +} + +{ TclpGetGrGid/getgrgid_r/module_load Memcheck:Leak match-leak-kinds: reachable diff --git a/unix/Makefile.in b/unix/Makefile.in index 3f05a27..3da7199 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -54,7 +54,7 @@ DLL_INSTALL_DIR = @DLL_INSTALL_DIR@ SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Path name to use when installing Tcl modules. -MODULE_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)/../tcl8 +MODULE_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)/../tcl9 # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) @@ -124,7 +124,7 @@ ENV_FLAGS = # To enable memory debugging, call configure with --enable-symbols=mem # Warning: if you enable memory debugging, you must do it *everywhere*, -# including all the code that calls Tcl, and you must use ckalloc and ckfree +# including all the code that calls Tcl, and you must use Tcl_Alloc and Tcl_Free # everywhere instead of malloc and free. TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ @@ -293,10 +293,11 @@ DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \ TCLSH_OBJS = tclAppInit.o TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ - tclThreadTest.o tclUnixTest.o + tclThreadTest.o tclUnixTest.o tclTestABSList.o XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ - tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o + tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o \ + tclTestABSList.o GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclArithSeries.o tclAssembly.o tclAsync.o tclBasic.o tclBinary.o \ @@ -347,6 +348,8 @@ TOMMATH_OBJS = bn_s_mp_reverse.o bn_s_mp_mul_digs_fast.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o STUB_LIB_OBJS = tclStubLib.o \ + tclStubCall.o \ + tclStubLibTbl.o \ tclTomMathStubLib.o \ tclOOStubLib.o \ ${COMPAT_OBJS} @@ -465,6 +468,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclStrToD.c \ $(GENERIC_DIR)/tclTest.c \ + $(GENERIC_DIR)/tclTestABSList.c \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclThread.c \ @@ -490,6 +494,8 @@ OO_SRCS = \ STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ + $(GENERIC_DIR)/tclStubCall.c \ + $(GENERIC_DIR)/tclStubLibTbl.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.c @@ -1052,7 +1058,7 @@ install-libraries: libraries else true; \ fi; \ done; - @for i in 8.4 8.4/platform 8.5 8.6 8.7; \ + @for i in 9.0 9.0/platform; \ do \ if [ ! -d "$(MODULE_INSTALL_DIR)/$$i" ] ; then \ echo "Making directory $(MODULE_INSTALL_DIR)/$$i"; \ @@ -1072,23 +1078,23 @@ install-libraries: libraries done @echo "Installing package http 2.10b1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \ - "$(MODULE_INSTALL_DIR)/8.6/http-2.10b1.tm" + "$(MODULE_INSTALL_DIR)/9.0/http-2.10b1.tm" @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/" @for i in $(TOP_DIR)/library/opt/*.tcl; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done @echo "Installing package msgcat 1.7.1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ - "$(MODULE_INSTALL_DIR)/8.7/msgcat-1.7.1.tm" + "$(MODULE_INSTALL_DIR)/9.0/msgcat-1.7.1.tm" @echo "Installing package tcltest 2.5.6 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ - "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.6.tm" + "$(MODULE_INSTALL_DIR)/9.0/tcltest-2.5.6.tm" @echo "Installing package platform 1.0.19 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \ - "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.19.tm" + "$(MODULE_INSTALL_DIR)/9.0/platform-1.0.19.tm" @echo "Installing package platform::shell 1.1.4 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \ - "$(MODULE_INSTALL_DIR)/8.4/platform/shell-1.1.4.tm" + "$(MODULE_INSTALL_DIR)/9.0/platform/shell-1.1.4.tm" @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/" @for i in $(TOP_DIR)/library/encoding/*.enc; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/encoding"; \ @@ -1563,6 +1569,9 @@ tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) tclUuid.h $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c +tclTestABSList.o: $(GENERIC_DIR)/tclTestABSList.c $(MATHHDRS) + $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestABSList.c + tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c @@ -1933,6 +1942,16 @@ Zzutil.o: $(ZLIB_DIR)/zutil.c tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD @CFLAGS_NOLTO@ $(GENERIC_DIR)/tclStubLib.c +tclStubCall.o: $(GENERIC_DIR)/tclStubCall.c + $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD \ + -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ + -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ + -DCFG_RUNTIME_BINDIR="\"$(bindir)\"" \ + $(GENERIC_DIR)/tclStubCall.c + +tclStubLibTbl.o: $(GENERIC_DIR)/tclStubLibTbl.c + $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLibTbl.c + tclTomMathStubLib.o: $(GENERIC_DIR)/tclTomMathStubLib.c $(CC) -c $(STUB_CC_SWITCHES) @CFLAGS_NOLTO@ $(GENERIC_DIR)/tclTomMathStubLib.c @@ -2004,6 +2023,7 @@ PKG_CFG_ARGS = @PKG_CFG_ARGS@ # cannot use absolute paths due to issues in nested configure when path to # build dir contains spaces). PKG_DIR = ./pkgs +PKG8_DIR = ./pkgs8 configure-packages: @for i in $(PKGS_DIR)/*; do \ @@ -2011,6 +2031,14 @@ configure-packages: if [ -x $$i/configure ] ; then \ pkg=`basename $$i`; \ echo "Configuring package '$$pkg'"; \ + mkdir -p $(PKG8_DIR)/$$pkg; \ + if [ ! -f $(PKG8_DIR)/$$pkg/Makefile ] ; then \ + ( cd $(PKG8_DIR)/$$pkg; \ + $$i/configure --with-tcl8 --with-tcl=../.. \ + --with-tclinclude=$(GENERIC_DIR) \ + $(PKG_CFG_ARGS) --libdir=$(PACKAGE_DIR) \ + --enable-shared; ) || exit $$?; \ + fi; \ mkdir -p $(PKG_DIR)/$$pkg; \ if [ ! -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ ( cd $(PKG_DIR)/$$pkg; \ @@ -2027,6 +2055,10 @@ packages: configure-packages ${STUB_LIB_FILE} @for i in $(PKGS_DIR)/*; do \ if [ -d $$i ] ; then \ pkg=`basename $$i`; \ + if [ -f $(PKG8_DIR)/$$pkg/Makefile ] ; then \ + echo "Building package '$$pkg' for Tcl 8"; \ + ( cd $(PKG8_DIR)/$$pkg; $(MAKE); ) || exit $$?; \ + fi; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ echo "Building package '$$pkg'"; \ ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) || exit $$?; \ @@ -2038,6 +2070,11 @@ install-packages: packages @for i in $(PKGS_DIR)/*; do \ if [ -d $$i ] ; then \ pkg=`basename $$i`; \ + if [ -f $(PKG8_DIR)/$$pkg/Makefile ] ; then \ + echo "Installing package '$$pkg' for Tcl 8"; \ + ( cd $(PKG8_DIR)/$$pkg; $(MAKE) install \ + "DESTDIR=$(INSTALL_ROOT)"; ) || exit $$?; \ + fi; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ echo "Installing package '$$pkg'"; \ ( cd $(PKG_DIR)/$$pkg; $(MAKE) install \ @@ -2065,6 +2102,9 @@ clean-packages: @for i in $(PKGS_DIR)/*; do \ if [ -d $$i ] ; then \ pkg=`basename $$i`; \ + if [ -f $(PKG8_DIR)/$$pkg/Makefile ] ; then \ + ( cd $(PKG8_DIR)/$$pkg; $(MAKE) clean; ) \ + fi; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ ( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \ fi; \ @@ -2075,12 +2115,17 @@ distclean-packages: @for i in $(PKGS_DIR)/*; do \ if [ -d $$i ] ; then \ pkg=`basename $$i`; \ + if [ -f $(PKG8_DIR)/$$pkg/Makefile ] ; then \ + ( cd $(PKG8_DIR)/$$pkg; $(MAKE) distclean; ) \ + fi; \ + rm -rf $(PKG8_DIR)/$$pkg; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ ( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \ fi; \ rm -rf $(PKG_DIR)/$$pkg; \ fi; \ done; \ + rm -rf $(PKG8_DIR) rm -rf $(PKG_DIR) dist-packages: configure-packages @@ -2412,8 +2457,8 @@ alldist: dist #-------------------------------------------------------------------------- # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool -# workspace. It depends on the Tcl & Tk being in directories called tcl8.* & -# tk8.* up two directories from the TOOL_DIR. +# workspace. It depends on the Tcl & Tk being in directories called tcl9.* & +# tk9.* up two directories from the TOOL_DIR. # # Note that for platforms where this is important, it is more common to use a # build of this HTML documentation that has already been placed online. As diff --git a/unix/configure b/unix/configure index 818fb46..10e947a 100755 --- a/unix/configure +++ b/unix/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.72 for tcl 8.7. +# Generated by GNU Autoconf 2.72 for tcl 9.0. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation, @@ -601,8 +601,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' -PACKAGE_VERSION='8.7' -PACKAGE_STRING='tcl 8.7' +PACKAGE_VERSION='9.0' +PACKAGE_STRING='tcl 9.0' PACKAGE_BUGREPORT='' PACKAGE_URL='' @@ -1366,7 +1366,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -'configure' configures tcl 8.7 to adapt to many kinds of systems. +'configure' configures tcl 9.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1428,7 +1428,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of tcl 8.7:";; + short | recursive ) echo "Configuration of tcl 9.0:";; esac cat <<\_ACEOF @@ -1545,7 +1545,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -tcl configure 8.7 +tcl configure 9.0 generated by GNU Autoconf 2.72 Copyright (C) 2023 Free Software Foundation, Inc. @@ -2028,7 +2028,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by tcl $as_me 8.7, which was +It was created by tcl $as_me 9.0, which was generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw @@ -2707,10 +2707,10 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -TCL_VERSION=8.7 -TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=7 -TCL_PATCH_LEVEL="a6" +TCL_VERSION=9.0 +TCL_MAJOR_VERSION=9 +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL="b1" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} @@ -7796,6 +7796,59 @@ printf "%s\n" "#define _ISOC99_SOURCE 1" >>confdefs.h fi + if test ${tcl_cv_flag__file_offset_bits+y} +then : + printf %s "(cached) " >&6 +else case e in #( + e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <sys/stat.h> +int +main (void) +{ +switch (0) { case 0: case (sizeof(off_t)==sizeof(long long)): ; } + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + tcl_cv_flag__file_offset_bits=no +else case e in #( + e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#define _FILE_OFFSET_BITS 64 +#include <sys/stat.h> +int +main (void) +{ +switch (0) { case 0: case (sizeof(off_t)==sizeof(long long)): ; } + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + tcl_cv_flag__file_offset_bits=yes +else case e in #( + e) tcl_cv_flag__file_offset_bits=no ;; +esac +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; +esac +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; +esac +fi + + if test "x${tcl_cv_flag__file_offset_bits}" = "xyes" ; then + +printf "%s\n" "#define _FILE_OFFSET_BITS 64" >>confdefs.h + + tcl_flags="$tcl_flags _FILE_OFFSET_BITS" + fi + + if test ${tcl_cv_flag__largefile64_source+y} then : printf %s "(cached) " >&6 @@ -7900,9 +7953,9 @@ printf "%s\n" "yes" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } # Now check for auxiliary declarations - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for struct dirent64" >&5 -printf %s "checking for struct dirent64... " >&6; } -if test ${tcl_cv_struct_dirent64+y} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for 64-bit time_t" >&5 +printf %s "checking for 64-bit time_t... " >&6; } +if test ${tcl_cv_time_t_64+y} then : printf %s "(cached) " >&6 else case e in #( @@ -7910,36 +7963,70 @@ else case e in #( cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include <sys/types.h> -#include <dirent.h> int main (void) { -struct dirent64 p; +switch (0) {case 0: case (sizeof(time_t)==sizeof(long long)): ;} ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : - tcl_cv_struct_dirent64=yes + tcl_cv_time_t_64=yes else case e in #( - e) tcl_cv_struct_dirent64=no ;; + e) tcl_cv_time_t_64=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_dirent64" >&5 -printf "%s\n" "$tcl_cv_struct_dirent64" >&6; } - if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_time_t_64" >&5 +printf "%s\n" "$tcl_cv_time_t_64" >&6; } + if test "x${tcl_cv_time_t_64}" = "xno" ; then + # Note that _TIME_BITS=64 requires _FILE_OFFSET_BITS=64 + # which SC_TCL_EARLY_FLAGS has defined if necessary. + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if _TIME_BITS=64 enables 64-bit time_t" >&5 +printf %s "checking if _TIME_BITS=64 enables 64-bit time_t... " >&6; } +if test ${tcl_cv__time_bits+y} +then : + printf %s "(cached) " >&6 +else case e in #( + e) + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#define _TIME_BITS 64 +#include <sys/types.h> +int +main (void) +{ +switch (0) {case 0: case (sizeof(time_t)==sizeof(long long)): ;} + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO" +then : + tcl_cv__time_bits=yes +else case e in #( + e) tcl_cv__time_bits=no ;; +esac +fi +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; +esac +fi +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv__time_bits" >&5 +printf "%s\n" "$tcl_cv__time_bits" >&6; } + if test "x${tcl_cv__time_bits}" = "xyes" ; then -printf "%s\n" "#define HAVE_STRUCT_DIRENT64 1" >>confdefs.h +printf "%s\n" "#define _TIME_BITS 64" >>confdefs.h + fi fi - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for DIR64" >&5 -printf %s "checking for DIR64... " >&6; } -if test ${tcl_cv_DIR64+y} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for struct dirent64" >&5 +printf %s "checking for struct dirent64... " >&6; } +if test ${tcl_cv_struct_dirent64+y} then : printf %s "(cached) " >&6 else case e in #( @@ -7951,64 +8038,64 @@ else case e in #( int main (void) { -struct dirent64 *p; DIR64 d = opendir64("."); - p = readdir64(d); rewinddir64(d); closedir64(d); +struct dirent64 p; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : - tcl_cv_DIR64=yes + tcl_cv_struct_dirent64=yes else case e in #( - e) tcl_cv_DIR64=no ;; + e) tcl_cv_struct_dirent64=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_DIR64" >&5 -printf "%s\n" "$tcl_cv_DIR64" >&6; } - if test "x${tcl_cv_DIR64}" = "xyes" ; then +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_dirent64" >&5 +printf "%s\n" "$tcl_cv_struct_dirent64" >&6; } + if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then -printf "%s\n" "#define HAVE_DIR64 1" >>confdefs.h +printf "%s\n" "#define HAVE_STRUCT_DIRENT64 1" >>confdefs.h fi - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for struct stat64" >&5 -printf %s "checking for struct stat64... " >&6; } -if test ${tcl_cv_struct_stat64+y} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for DIR64" >&5 +printf %s "checking for DIR64... " >&6; } +if test ${tcl_cv_DIR64+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ -#include <sys/stat.h> +#include <sys/types.h> +#include <dirent.h> int main (void) { -struct stat64 p; - +struct dirent64 *p; DIR64 d = opendir64("."); + p = readdir64(d); rewinddir64(d); closedir64(d); ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : - tcl_cv_struct_stat64=yes + tcl_cv_DIR64=yes else case e in #( - e) tcl_cv_struct_stat64=no ;; + e) tcl_cv_DIR64=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_stat64" >&5 -printf "%s\n" "$tcl_cv_struct_stat64" >&6; } - if test "x${tcl_cv_struct_stat64}" = "xyes" ; then +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_DIR64" >&5 +printf "%s\n" "$tcl_cv_DIR64" >&6; } + if test "x${tcl_cv_DIR64}" = "xyes" ; then -printf "%s\n" "#define HAVE_STRUCT_STAT64 1" >>confdefs.h +printf "%s\n" "#define HAVE_DIR64 1" >>confdefs.h fi @@ -10492,9 +10579,6 @@ fi fi -printf "%s\n" "#define TCL_DEFAULT_ENCODING \"utf-8\"" >>confdefs.h - - printf "%s\n" "#define TCL_LOAD_FROM_MEMORY 1" >>confdefs.h @@ -11333,15 +11417,11 @@ fi # Replace ${VERSION} with contents of ${TCL_VERSION} # double-eval to account for TCL_TRIM_DOTS. # -eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}" +eval "TCL_STUB_LIB_FILE=libtclstub.a" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" eval "TCL_STUB_LIB_DIR=\"${libdir}\"" -if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then - TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" -else - TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`" -fi +TCL_STUB_LIB_FLAG="-ltclstub" TCL_BUILD_STUB_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}" TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}" @@ -11941,7 +12021,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by tcl $as_me 8.7, which was +This file was extended by tcl $as_me 9.0, which was generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -12000,7 +12080,7 @@ ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -tcl config.status 8.7 +tcl config.status 9.0 configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" diff --git a/unix/configure.ac b/unix/configure.ac index 57433d8..cf1eb87 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -3,7 +3,7 @@ dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. -AC_INIT([tcl],[8.7]) +AC_INIT([tcl],[9.0]) AC_PREREQ([2.69]) dnl This is only used when included from macosx/configure.ac @@ -23,10 +23,10 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ #endif /* _TCLCONFIG */]) ]) -TCL_VERSION=8.7 -TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=7 -TCL_PATCH_LEVEL="a6" +TCL_VERSION=9.0 +TCL_MAJOR_VERSION=9 +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL="b1" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} @@ -542,8 +542,6 @@ if test "`uname -s`" = "Darwin" ; then AC_CHECK_HEADERS(libkern/OSAtomic.h) AC_CHECK_FUNCS(OSSpinLockLock) fi - AC_DEFINE(TCL_DEFAULT_ENCODING, "utf-8", - [Are we to override what our default encoding is?]) AC_DEFINE(TCL_LOAD_FROM_MEMORY, 1, [Can this platform load code from memory?]) AC_DEFINE(TCL_WIDE_CLICKS, 1, @@ -908,15 +906,11 @@ fi # Replace ${VERSION} with contents of ${TCL_VERSION} # double-eval to account for TCL_TRIM_DOTS. # -eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}" +eval "TCL_STUB_LIB_FILE=libtclstub.a" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" eval "TCL_STUB_LIB_DIR=\"${libdir}\"" -if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then - TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" -else - TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`" -fi +TCL_STUB_LIB_FLAG="-ltclstub" TCL_BUILD_STUB_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}" TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}" diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 9a01875..06d0e30 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -25,17 +25,23 @@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic \ ${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS} -all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} \ - pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} pkgt${SHLIB_SUFFIX} pkgua${SHLIB_SUFFIX} \ - pkgooa${SHLIB_SUFFIX} +all: embtest tcl9pkga${SHLIB_SUFFIX} tcl9pkgb${SHLIB_SUFFIX} tcl9pkgc${SHLIB_SUFFIX} \ + tcl9pkgd${SHLIB_SUFFIX} tcl9pkge${SHLIB_SUFFIX} tcl9pkgt${SHLIB_SUFFIX} tcl9pkgua${SHLIB_SUFFIX} \ + tcl9pkgooa${SHLIB_SUFFIX} pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgt${SHLIB_SUFFIX} @if test -n "$(DLTEST_SUFFIX)"; then $(MAKE) dltest_suffix; fi @touch ../dltest.marker -dltest_suffix: pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} pkgc${DLTEST_SUFFIX} \ - pkgd${DLTEST_SUFFIX} pkge${DLTEST_SUFFIX} pkgt${DLTEST_SUFFIX} pkgua${DLTEST_SUFFIX} \ - pkgooa${DLTEST_SUFFIX} +dltest_suffix: tcl9pkga${DLTEST_SUFFIX} tcl9pkgb${DLTEST_SUFFIX} tcl9pkgc${DLTEST_SUFFIX} \ + tcl9pkgd${DLTEST_SUFFIX} tcl9pkge${DLTEST_SUFFIX} tcl9pkgt${DLTEST_SUFFIX} tcl9pkgua${DLTEST_SUFFIX} \ + tcl9pkgooa${DLTEST_SUFFIX} pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} pkgc${DLTEST_SUFFIX} pkgt${DLTEST_SUFFIX} @touch ../dltest.marker +embtest.o: $(SRC_DIR)/embtest.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/embtest.c + +pkgπ.o: $(SRC_DIR)/pkgπ.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgπ.c + pkga.o: $(SRC_DIR)/pkga.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c @@ -45,67 +51,112 @@ pkgb.o: $(SRC_DIR)/pkgb.c pkgc.o: $(SRC_DIR)/pkgc.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgc.c +pkgt.o: $(SRC_DIR)/pkgt.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgt.c + +tcl8pkga.o: $(SRC_DIR)/pkga.c + $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(SRC_DIR)/pkga.c + +tcl8pkgb.o: $(SRC_DIR)/pkgb.c + $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(SRC_DIR)/pkgb.c + +tcl8pkgc.o: $(SRC_DIR)/pkgc.c + $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(SRC_DIR)/pkgc.c + +tcl8pkgt.o: $(SRC_DIR)/pkgt.c + $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(SRC_DIR)/pkgt.c + pkgd.o: $(SRC_DIR)/pkgd.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgd.c pkge.o: $(SRC_DIR)/pkge.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c -pkgt.o: $(SRC_DIR)/pkgt.c - $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgt.c - pkgua.o: $(SRC_DIR)/pkgua.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgua.c pkgooa.o: $(SRC_DIR)/pkgooa.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgooa.c -pkga${SHLIB_SUFFIX}: pkga.o +embtest: embtest.o + $(CC) $(CC_SWITCHES) -o $@ embtest.o ${SHLIB_LD_LIBS} + +tcl9pkgπ${SHLIB_SUFFIX}: pkgπ.o + ${SHLIB_LD} -o $@ pkgπ.o ${SHLIB_LD_LIBS} + +tcl9pkga${SHLIB_SUFFIX}: pkga.o ${SHLIB_LD} -o $@ pkga.o ${SHLIB_LD_LIBS} -pkgb${SHLIB_SUFFIX}: pkgb.o +tcl9pkgb${SHLIB_SUFFIX}: pkgb.o ${SHLIB_LD} -o $@ pkgb.o ${SHLIB_LD_LIBS} -pkgc${SHLIB_SUFFIX}: pkgc.o +tcl9pkgc${SHLIB_SUFFIX}: pkgc.o ${SHLIB_LD} -o $@ pkgc.o ${SHLIB_LD_LIBS} -pkgd${SHLIB_SUFFIX}: pkgd.o +tcl9pkgt${SHLIB_SUFFIX}: pkgt.o + ${SHLIB_LD} -o $@ pkgt.o ${SHLIB_LD_LIBS} + +pkga${SHLIB_SUFFIX}: tcl8pkga.o + ${SHLIB_LD} -o $@ tcl8pkga.o ${SHLIB_LD_LIBS} + +pkgb${SHLIB_SUFFIX}: tcl8pkgb.o + ${SHLIB_LD} -o $@ tcl8pkgb.o ${SHLIB_LD_LIBS} + +pkgc${SHLIB_SUFFIX}: tcl8pkgc.o + ${SHLIB_LD} -o $@ tcl8pkgc.o ${SHLIB_LD_LIBS} + +pkgt${SHLIB_SUFFIX}: tcl8pkgt.o + ${SHLIB_LD} -o $@ tcl8pkgt.o ${SHLIB_LD_LIBS} + +tcl9pkgd${SHLIB_SUFFIX}: pkgd.o ${SHLIB_LD} -o $@ pkgd.o ${SHLIB_LD_LIBS} -pkge${SHLIB_SUFFIX}: pkge.o +tcl9pkge${SHLIB_SUFFIX}: pkge.o ${SHLIB_LD} -o $@ pkge.o ${SHLIB_LD_LIBS} -pkgt${SHLIB_SUFFIX}: pkgt.o - ${SHLIB_LD} -o $@ pkgt.o ${SHLIB_LD_LIBS} - -pkgua${SHLIB_SUFFIX}: pkgua.o +tcl9pkgua${SHLIB_SUFFIX}: pkgua.o ${SHLIB_LD} -o $@ pkgua.o ${SHLIB_LD_LIBS} -pkgooa${SHLIB_SUFFIX}: pkgooa.o +tcl9pkgooa${SHLIB_SUFFIX}: pkgooa.o ${SHLIB_LD} -o $@ pkgooa.o ${SHLIB_LD_LIBS} -pkga${DLTEST_SUFFIX}: pkga.o +tcl9pkgπ${DLTEST_SUFFIX}: pkgπ.o + ${DLTEST_LD} -o $@ pkgπ.o ${SHLIB_LD_LIBS} + +tcl9pkga${DLTEST_SUFFIX}: pkga.o ${DLTEST_LD} -o $@ pkga.o ${SHLIB_LD_LIBS} -pkgb${DLTEST_SUFFIX}: pkgb.o +tcl9pkgb${DLTEST_SUFFIX}: pkgb.o ${DLTEST_LD} -o $@ pkgb.o ${SHLIB_LD_LIBS} -pkgc${DLTEST_SUFFIX}: pkgc.o +tcl9pkgc${DLTEST_SUFFIX}: pkgc.o ${DLTEST_LD} -o $@ pkgc.o ${SHLIB_LD_LIBS} -pkgd${DLTEST_SUFFIX}: pkgd.o +tcl9pkgt${DLTEST_SUFFIX}: pkgt.o + ${DLTEST_LD} -o $@ pkgt.o ${SHLIB_LD_LIBS} + +pkga${DLTEST_SUFFIX}: tcl8pkga.o + ${DLTEST_LD} -o $@ tcl8pkga.o ${SHLIB_LD_LIBS} + +pkgb${DLTEST_SUFFIX}: tcl8pkgb.o + ${DLTEST_LD} -o $@ tcl8pkgb.o ${SHLIB_LD_LIBS} + +pkgc${DLTEST_SUFFIX}: tcl8pkgc.o + ${DLTEST_LD} -o $@ tcl8pkgc.o ${SHLIB_LD_LIBS} + +pkgt${DLTEST_SUFFIX}: tcl8pkgt.o + ${DLTEST_LD} -o $@ tcl8pkgt.o ${SHLIB_LD_LIBS} + +tcl9pkgd${DLTEST_SUFFIX}: pkgd.o ${DLTEST_LD} -o $@ pkgd.o ${SHLIB_LD_LIBS} -pkge${DLTEST_SUFFIX}: pkge.o +tcl9pkge${DLTEST_SUFFIX}: pkge.o ${DLTEST_LD} -o $@ pkge.o ${SHLIB_LD_LIBS} -pkgt${DLTEST_SUFFIX}: pkgt.o - ${DLTEST_LD} -o $@ pkgt.o ${SHLIB_LD_LIBS} - -pkgua${DLTEST_SUFFIX}: pkgua.o +tcl9pkgua${DLTEST_SUFFIX}: pkgua.o ${DLTEST_LD} -o $@ pkgua.o ${SHLIB_LD_LIBS} -pkgooa${DLTEST_SUFFIX}: pkgooa.o +tcl9pkgooa${DLTEST_SUFFIX}: pkgooa.o ${DLTEST_LD} -o $@ pkgooa.o ${SHLIB_LD_LIBS} clean: diff --git a/unix/dltest/embtest.c b/unix/dltest/embtest.c new file mode 100644 index 0000000..ff58cc4 --- /dev/null +++ b/unix/dltest/embtest.c @@ -0,0 +1,40 @@ +#include "tcl.h" +#include <stdio.h> + +MODULE_SCOPE const TclStubs *tclStubsPtr; + +int main(int argc, char **argv) { + const char *version; + int exitcode = 0; + (void)argc; + + if (tclStubsPtr != NULL) { + printf("ERROR: stub table is already initialized"); + exitcode = 1; + } + tclStubsPtr = NULL; + version = Tcl_SetPanicProc(Tcl_ConsolePanic); + if (tclStubsPtr == NULL) { + printf("ERROR: Tcl_SetPanicProc does not initialize the stub table\n"); + exitcode = 1; + } + tclStubsPtr = NULL; + version = Tcl_InitSubsystems(); + if (tclStubsPtr == NULL) { + printf("ERROR: Tcl_InitSubsystems does not initialize the stub table\n"); + exitcode = 1; + } + tclStubsPtr = NULL; + version = Tcl_FindExecutable(argv[0]); + if (version != NULL) { + printf("Tcl_FindExecutable gives version %s\n", version); + } + if (tclStubsPtr == NULL) { + printf("ERROR: Tcl_FindExecutable does not initialize the stub table\n"); + exitcode = 1; + } + if (!exitcode) { + printf("All OK!\n"); + } + return exitcode; +} diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c index f249b1d..0b23215 100644 --- a/unix/dltest/pkga.c +++ b/unix/dltest/pkga.c @@ -40,7 +40,7 @@ Pkga_EqObjCmd( { int result; const char *str1, *str2; - int len1, len2; + Tcl_Size len1, len2; (void)dummy; if (objc != 3) { diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index 165c5e3..ca64a11 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -34,10 +34,6 @@ *---------------------------------------------------------------------- */ -#ifndef Tcl_GetErrorLine -# define Tcl_GetErrorLine(interp) ((interp)->errorLine) -#endif - static int Pkgb_SubObjCmd( void *dummy, /* Not used. */ @@ -91,7 +87,7 @@ Pkgb_UnsafeObjCmd( (void)objc; (void)objv; - return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL); + return Tcl_EvalEx(interp, "list unsafe command invoked", TCL_INDEX_NONE, TCL_EVAL_GLOBAL); } static int diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c index 8e9c829..582d457 100644 --- a/unix/dltest/pkgc.c +++ b/unix/dltest/pkgc.c @@ -81,7 +81,7 @@ Pkgc_UnsafeObjCmd( (void)objc; (void)objv; - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", TCL_INDEX_NONE)); return TCL_OK; } diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c index 172d579..e713b23 100644 --- a/unix/dltest/pkgd.c +++ b/unix/dltest/pkgd.c @@ -81,7 +81,7 @@ Pkgd_UnsafeObjCmd( (void)objc; (void)objv; - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", TCL_INDEX_NONE)); return TCL_OK; } diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c index 26a4b79..5f0db9b 100644 --- a/unix/dltest/pkge.c +++ b/unix/dltest/pkge.c @@ -41,5 +41,5 @@ Pkge_Init( if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } - return Tcl_EvalEx(interp, script, -1, 0); + return Tcl_EvalEx(interp, script, TCL_INDEX_NONE, 0); } diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index 6d56ec1..ba25d91 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -127,7 +127,7 @@ PkguaEqObjCmd( { int result; const char *str1, *str2; - int len1, len2; + Tcl_Size len1, len2; (void)dummy; if (objc != 3) { diff --git a/unix/dltest/pkgπ.c b/unix/dltest/pkgπ.c new file mode 100644 index 0000000..58b36db --- /dev/null +++ b/unix/dltest/pkgπ.c @@ -0,0 +1,85 @@ +/* + * pkgπ.c -- + * + * This file contains a simple Tcl package "pkgπ" that is intended for + * testing the Tcl dynamic loading facilities. + * + * Copyright © 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#undef STATIC_BUILD +#include "tcl.h" + +/* + *---------------------------------------------------------------------- + * + * Pkga_EqObjCmd -- + * + * This procedure is invoked to process the "pkga_eq" Tcl command. It + * expects two arguments and returns 1 if they are the same, 0 if they + * are different. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkg\u03C0_\u03A0ObjCmd( + void *dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + (void)dummy; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(3.14159)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgπ_Init -- + * + * This is a package initialization procedure, which is called by Tcl + * when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +DLLEXPORT int +Pkg\u03C0_Init( + Tcl_Interp *interp) /* Interpreter in which the package is to be + * made available. */ +{ + int code; + + if (Tcl_InitStubs(interp, "9.0", 0) == NULL) { + return TCL_ERROR; + } + code = Tcl_PkgProvide(interp, "pkgπ", "1.0"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateObjCommand(interp, "π", Pkg\u03C0_\u03A0ObjCmd, NULL, NULL); + return TCL_OK; +} diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 68048f4..4a9fe40 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -93,11 +93,11 @@ AC_DEFUN([SC_PATH_TCLCONFIG], [ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ - `ls -d /usr/lib/tcl8.7 2>/dev/null` \ + `ls -d /usr/lib/tcl9.0 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ - `ls -d /usr/local/lib/tcl8.7 2>/dev/null` \ - `ls -d /usr/local/lib/tcl/tcl8.7 2>/dev/null` \ + `ls -d /usr/local/lib/tcl9.0 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tcl9.0 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" @@ -226,11 +226,11 @@ AC_DEFUN([SC_PATH_TKCONFIG], [ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ - `ls -d /usr/lib/tk8.7 2>/dev/null` \ + `ls -d /usr/lib/tk9.0 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ - `ls -d /usr/local/lib/tk8.7 2>/dev/null` \ - `ls -d /usr/local/lib/tcl/tk8.7 2>/dev/null` \ + `ls -d /usr/local/lib/tk9.0 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tk9.0 2>/dev/null` \ ; do if test -f "$i/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i; pwd)`" @@ -2294,6 +2294,7 @@ AC_DEFUN([SC_TCL_LINK_LIBS], [ # # Might define the following vars: # _ISOC99_SOURCE +# _FILE_OFFSET_BITS # _LARGEFILE64_SOURCE # #-------------------------------------------------------------------- @@ -2316,6 +2317,8 @@ AC_DEFUN([SC_TCL_EARLY_FLAGS],[ tcl_flags="" SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include <stdlib.h>], [char *p = (char *)strtoll; char *q = (char *)strtoull;]) + SC_TCL_EARLY_FLAG(_FILE_OFFSET_BITS,[#include <sys/stat.h>], + [switch (0) { case 0: case (sizeof(off_t)==sizeof(long long)): ; }],64) SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include <sys/stat.h>], [struct stat64 buf; int i = stat64("/", &buf);]) if test "x${tcl_flags}" = "x" ; then @@ -2338,8 +2341,8 @@ AC_DEFUN([SC_TCL_EARLY_FLAGS],[ # Might define the following vars: # TCL_WIDE_INT_IS_LONG # HAVE_STRUCT_DIRENT64, HAVE_DIR64 -# HAVE_STRUCT_STAT64 # HAVE_TYPE_OFF64_T +# _TIME_BITS # #-------------------------------------------------------------------- @@ -2359,6 +2362,23 @@ AC_DEFUN([SC_TCL_64BIT_FLAGS], [ else AC_MSG_RESULT([no]) # Now check for auxiliary declarations + AC_CACHE_CHECK([for 64-bit time_t], tcl_cv_time_t_64,[ + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>]], + [[switch (0) {case 0: case (sizeof(time_t)==sizeof(long long)): ;}]])], + [tcl_cv_time_t_64=yes],[tcl_cv_time_t_64=no])]) + if test "x${tcl_cv_time_t_64}" = "xno" ; then + # Note that _TIME_BITS=64 requires _FILE_OFFSET_BITS=64 + # which SC_TCL_EARLY_FLAGS has defined if necessary. + AC_CACHE_CHECK([if _TIME_BITS=64 enables 64-bit time_t], tcl_cv__time_bits,[ + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#define _TIME_BITS 64 +#include <sys/types.h>]], + [[switch (0) {case 0: case (sizeof(time_t)==sizeof(long long)): ;}]])], + [tcl_cv__time_bits=yes],[tcl_cv__time_bits=no])]) + if test "x${tcl_cv__time_bits}" = "xyes" ; then + AC_DEFINE(_TIME_BITS, 64, [_TIME_BITS=64 enables 64-bit time_t.]) + fi + fi + AC_CACHE_CHECK([for struct dirent64], tcl_cv_struct_dirent64,[ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h> #include <dirent.h>]], [[struct dirent64 p;]])], @@ -2376,14 +2396,6 @@ AC_DEFUN([SC_TCL_64BIT_FLAGS], [ AC_DEFINE(HAVE_DIR64, 1, [Is 'DIR64' in <sys/types.h>?]) fi - AC_CACHE_CHECK([for struct stat64], tcl_cv_struct_stat64,[ - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/stat.h>]], [[struct stat64 p; -]])], - [tcl_cv_struct_stat64=yes], [tcl_cv_struct_stat64=no])]) - if test "x${tcl_cv_struct_stat64}" = "xyes" ; then - AC_DEFINE(HAVE_STRUCT_STAT64, 1, [Is 'struct stat64' in <sys/stat.h>?]) - fi - AC_CHECK_FUNCS(open64 lseek64) AC_MSG_CHECKING([for off64_t]) AC_CACHE_VAL(tcl_cv_type_off64_t,[ diff --git a/unix/tcl.spec b/unix/tcl.spec index 3956126..d56cee3 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.7a6 +Version: 9.0b1 Release: 2 License: BSD Group: Development/Languages diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 04ae564..c49df55 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -158,15 +158,16 @@ Tcl_AppInit( * is the name of the application. If this line is deleted then no * user-specific startup file will be run under any conditions. */ - #ifdef DJGPP - Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL, - Tcl_NewStringObj("~/tclsh.rc", TCL_INDEX_NONE), TCL_GLOBAL_ONLY); +#define INITFILENAME "tclshrc.tcl" #else - Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL, - Tcl_NewStringObj("~/.tclshrc", TCL_INDEX_NONE), TCL_GLOBAL_ONLY); +#define INITFILENAME ".tclshrc" #endif + (void)Tcl_EvalEx(interp, + "set tcl_rcFileName [file tildeexpand ~/" INITFILENAME "]", + -1, + TCL_EVAL_GLOBAL); return TCL_OK; } diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index cc75c29..eb566dc 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -235,9 +235,6 @@ /* Define to 1 if the system has the type 'struct sockaddr_storage'. */ #undef HAVE_STRUCT_SOCKADDR_STORAGE -/* Is 'struct stat64' in <sys/stat.h>? */ -#undef HAVE_STRUCT_STAT64 - /* Define to 1 if 'st_blksize' is a member of 'struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLKSIZE @@ -426,9 +423,6 @@ /* Are bytecode statistics enabled? */ #undef TCL_COMPILE_STATS -/* Are we to override what our default encoding is? */ -#undef TCL_DEFAULT_ENCODING - /* Is Tcl built as a framework? */ #undef TCL_FRAMEWORK @@ -480,6 +474,9 @@ /* Are Darwin SUSv3 extensions available? */ #undef _DARWIN_C_SOURCE +/* Add the _FILE_OFFSET_BITS flag when building */ +#undef _FILE_OFFSET_BITS + /* Add the _ISOC99_SOURCE flag when building */ #undef _ISOC99_SOURCE @@ -498,6 +495,9 @@ /* Do we want the thread-safe OS API? */ #undef _THREAD_SAFE +/* _TIME_BITS=64 enables 64-bit time_t. */ +#undef _TIME_BITS + /* Do we want to use the XOPEN network library? */ #undef _XOPEN_SOURCE diff --git a/unix/tclConfig.sh.in b/unix/tclConfig.sh.in index f2ac768..30d0bda 100644 --- a/unix/tclConfig.sh.in +++ b/unix/tclConfig.sh.in @@ -21,11 +21,6 @@ TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' -# TCL_DBGX used to be used to distinguish debug vs. non-debug builds. -# This was a righteous pain so the core doesn't do that any more. -# DEPRECATED, will be removed in Tcl 9! -TCL_DBGX='' - # Default flags used in an optimized and debuggable build, respectively. TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@' TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@' diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c index 649c21b..659e659 100644 --- a/unix/tclEpollNotfy.c +++ b/unix/tclEpollNotfy.c @@ -42,7 +42,7 @@ typedef struct FileHandler { * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ LIST_ENTRY(FileHandler) readyNode; /* Next/previous in list of FileHandlers asso- @@ -150,7 +150,7 @@ static int PlatformEventsWait(struct epoll_event *events, *---------------------------------------------------------------------- */ -ClientData +void * TclpInitNotifier(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -208,7 +208,7 @@ PlatformEventsControl( } if (isNew) { newPedPtr = (struct PlatformEventData *) - ckalloc(sizeof(struct PlatformEventData)); + Tcl_Alloc(sizeof(struct PlatformEventData)); newPedPtr->filePtr = filePtr; newPedPtr->tsdPtr = tsdPtr; filePtr->pedPtr = newPedPtr; @@ -275,7 +275,7 @@ PlatformEventsControl( void TclpFinalizeNotifier( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -295,14 +295,14 @@ TclpFinalizeNotifier( tsdPtr->triggerPipe[1] = -1; } #endif /* HAVE_EVENTFD */ - ckfree(tsdPtr->triggerFilePtr->pedPtr); - ckfree(tsdPtr->triggerFilePtr); + Tcl_Free(tsdPtr->triggerFilePtr->pedPtr); + Tcl_Free(tsdPtr->triggerFilePtr); if (tsdPtr->eventsFd > 0) { close(tsdPtr->eventsFd); tsdPtr->eventsFd = 0; } if (tsdPtr->readyEvents) { - ckfree(tsdPtr->readyEvents); + Tcl_Free(tsdPtr->readyEvents); tsdPtr->maxReadyEvents = 0; } pthread_mutex_unlock(&tsdPtr->notifierMutex); @@ -347,7 +347,7 @@ PlatformEventsInit(void) if (errno) { Tcl_Panic("Tcl_InitNotifier: %s", "could not create mutex"); } - filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler)); #ifdef HAVE_EVENTFD tsdPtr->triggerEventFd = eventfd(0, EFD_CLOEXEC | EFD_NONBLOCK); if (tsdPtr->triggerEventFd <= 0) { @@ -368,7 +368,7 @@ PlatformEventsInit(void) PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1); if (!tsdPtr->readyEvents) { tsdPtr->maxReadyEvents = 512; - tsdPtr->readyEvents = (struct epoll_event *) ckalloc( + tsdPtr->readyEvents = (struct epoll_event *) Tcl_Alloc( tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0])); } LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr); @@ -513,14 +513,14 @@ TclpCreateFileHandler( * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); int isNew = (filePtr == NULL); if (isNew) { - filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->readyMask = 0; filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; @@ -577,7 +577,7 @@ TclpDeleteFileHandler( PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_DEL, 0); if (filePtr->pedPtr) { - ckfree(filePtr->pedPtr); + Tcl_Free(filePtr->pedPtr); } /* @@ -589,7 +589,7 @@ TclpDeleteFileHandler( } else { prevPtr->nextPtr = filePtr->nextPtr; } - ckfree(filePtr); + Tcl_Free(filePtr); } /* @@ -683,7 +683,7 @@ TclpWaitForEvent( if (filePtr->readyMask == 0) { FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) - ckalloc(sizeof(FileHandlerEvent)); + Tcl_Alloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; @@ -759,7 +759,7 @@ TclpWaitForEvent( if (filePtr->readyMask == 0) { FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) - ckalloc(sizeof(FileHandlerEvent)); + Tcl_Alloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; @@ -791,7 +791,7 @@ int TclAsyncNotifier( int sigNumber, /* Signal number. */ Tcl_ThreadId threadId, /* Target thread. */ - ClientData clientData, /* Notifier data. */ + void *clientData, /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { diff --git a/unix/tclKqueueNotfy.c b/unix/tclKqueueNotfy.c index 2f495bd..487af9c 100644 --- a/unix/tclKqueueNotfy.c +++ b/unix/tclKqueueNotfy.c @@ -40,7 +40,7 @@ typedef struct FileHandler { * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ LIST_ENTRY(FileHandler) readyNode; /* Next/previous in list of FileHandlers asso- @@ -167,7 +167,7 @@ PlatformEventsControl( if (isNew) { newPedPtr = (struct PlatformEventData *) - ckalloc(sizeof(struct PlatformEventData)); + Tcl_Alloc(sizeof(struct PlatformEventData)); newPedPtr->filePtr = filePtr; newPedPtr->tsdPtr = tsdPtr; filePtr->pedPtr = newPedPtr; @@ -274,7 +274,7 @@ PlatformEventsControl( void TclpFinalizeNotifier( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -292,7 +292,7 @@ TclpFinalizeNotifier( tsdPtr->eventsFd = 0; } if (tsdPtr->readyEvents) { - ckfree(tsdPtr->readyEvents); + Tcl_Free(tsdPtr->readyEvents); tsdPtr->maxReadyEvents = 0; } pthread_mutex_unlock(&tsdPtr->notifierMutex); @@ -330,7 +330,7 @@ TclpFinalizeNotifier( *---------------------------------------------------------------------- */ -ClientData +void * TclpInitNotifier(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -359,13 +359,13 @@ TclpInitNotifier(void) } else if (fcntl(tsdPtr->eventsFd, F_SETFD, FD_CLOEXEC) == -1) { Tcl_Panic("fcntl: %s", strerror(errno)); } - filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler)); filePtr->fd = tsdPtr->triggerPipe[0]; filePtr->mask = TCL_READABLE; PlatformEventsControl(filePtr, tsdPtr, EV_ADD, 1); if (!tsdPtr->readyEvents) { tsdPtr->maxReadyEvents = 512; - tsdPtr->readyEvents = (struct kevent *) ckalloc( + tsdPtr->readyEvents = (struct kevent *) Tcl_Alloc( tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0])); } LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr); @@ -518,14 +518,14 @@ TclpCreateFileHandler( * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); int isNew = (filePtr == NULL); if (isNew) { - filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->readyMask = 0; filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; @@ -581,7 +581,7 @@ TclpDeleteFileHandler( PlatformEventsControl(filePtr, tsdPtr, EV_DELETE, 0); if (filePtr->pedPtr) { - ckfree(filePtr->pedPtr); + Tcl_Free(filePtr->pedPtr); } /* @@ -593,7 +593,7 @@ TclpDeleteFileHandler( } else { prevPtr->nextPtr = filePtr->nextPtr; } - ckfree(filePtr); + Tcl_Free(filePtr); } /* @@ -695,7 +695,7 @@ TclpWaitForEvent( if (filePtr->readyMask == 0) { FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) - ckalloc(sizeof(FileHandlerEvent)); + Tcl_Alloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; @@ -755,7 +755,7 @@ TclpWaitForEvent( if (filePtr->readyMask == 0) { FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) - ckalloc(sizeof(FileHandlerEvent)); + Tcl_Alloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; @@ -787,7 +787,7 @@ int TclAsyncNotifier( int sigNumber, /* Signal number. */ Tcl_ThreadId threadId, /* Target thread. */ - ClientData clientData, /* Notifier data. */ + void *clientData, /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index 13b183b..ee92318 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -106,9 +106,13 @@ TclpDlopen( */ Tcl_DString ds; - const char *fileName = Tcl_GetString(pathPtr); + const char *fileName = TclGetString(pathPtr); - native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, fileName, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + native = Tcl_DStringValue(&ds); /* * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070] */ @@ -127,11 +131,11 @@ TclpDlopen( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't load file \"%s\": %s", - Tcl_GetString(pathPtr), errorStr)); + TclGetString(pathPtr), errorStr)); } return TCL_ERROR; } - newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle)); + newHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(*newHandle)); newHandle->clientData = handle; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; @@ -179,7 +183,11 @@ FindSymbol( * the underscore. */ - native = Tcl_UtfToExternalDString(NULL, symbol, TCL_INDEX_NONE, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, symbol, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return NULL; + } + native = Tcl_DStringValue(&ds); proc = dlsym(handle, native); /* INTL: Native. */ if (proc == NULL) { Tcl_DStringInit(&newName); @@ -191,7 +199,7 @@ FindSymbol( #ifdef __cplusplus if (proc == NULL) { char buf[32]; - snprintf(buf, sizeof(buf), "%d", Tcl_DStringLength(&ds)); + snprintf(buf, sizeof(buf), "%d", (int)Tcl_DStringLength(&ds)); Tcl_DStringInit(&newName); TclDStringAppendLiteral(&newName, "__Z"); Tcl_DStringAppend(&newName, buf, TCL_INDEX_NONE); @@ -256,7 +264,7 @@ UnloadFile( void *handle = loadHandle->clientData; dlclose(handle); - ckfree(loadHandle); + Tcl_Free(loadHandle); } /* diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index b831e36..7525abe 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -106,7 +106,7 @@ static const char * DyldOFIErrorMsg( int err) { - switch(err) { + switch (err) { case NSObjectFileImageSuccess: return NULL; case NSObjectFileImageFailure: @@ -184,8 +184,12 @@ TclpDlopen( */ nativePath = (const char *)Tcl_FSGetNativePath(pathPtr); - nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), - TCL_INDEX_NONE, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, TclGetString(pathPtr), + TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + nativeFileName = Tcl_DStringValue(&ds); #if TCL_DYLD_USE_DLFCN /* @@ -258,7 +262,7 @@ TclpDlopen( module = NSLinkModule(dyldObjFileImage, nativePath, nsflags); NSDestroyObjectFileImage(dyldObjFileImage); if (module) { - modulePtr = (Tcl_DyldModuleHandle *)ckalloc(sizeof(Tcl_DyldModuleHandle)); + modulePtr = (Tcl_DyldModuleHandle *)Tcl_Alloc(sizeof(Tcl_DyldModuleHandle)); modulePtr->module = module; modulePtr->nextPtr = NULL; } else { @@ -278,13 +282,13 @@ TclpDlopen( || dyldLibHeader || modulePtr #endif /* TCL_DYLD_USE_NSMODULE */ ) { - dyldLoadHandle = (Tcl_DyldLoadHandle *)ckalloc(sizeof(Tcl_DyldLoadHandle)); + dyldLoadHandle = (Tcl_DyldLoadHandle *)Tcl_Alloc(sizeof(Tcl_DyldLoadHandle)); dyldLoadHandle->dlHandle = dlHandle; #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) dyldLoadHandle->dyldLibHeader = dyldLibHeader; dyldLoadHandle->modulePtr = modulePtr; #endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */ - newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle)); + newHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(*newHandle)); newHandle->clientData = dyldLoadHandle; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; @@ -341,7 +345,11 @@ FindSymbol( Tcl_DString ds; const char *native; - native = Tcl_UtfToExternalDString(NULL, symbol, TCL_INDEX_NONE, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, symbol, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return NULL; + } + native = Tcl_DStringValue(&ds); if (dyldLoadHandle->dlHandle) { #if TCL_DYLD_USE_DLFCN proc = (Tcl_LibraryInitProc *)dlsym(dyldLoadHandle->dlHandle, native); @@ -382,7 +390,7 @@ FindSymbol( modulePtr = modulePtr->nextPtr; } if (modulePtr == NULL) { - modulePtr = (Tcl_DyldModuleHandle *)ckalloc(sizeof(Tcl_DyldModuleHandle)); + modulePtr = (Tcl_DyldModuleHandle *)Tcl_Alloc(sizeof(Tcl_DyldModuleHandle)); modulePtr->module = module; modulePtr->nextPtr = dyldLoadHandle->modulePtr; dyldLoadHandle->modulePtr = modulePtr; @@ -457,12 +465,12 @@ UnloadFile( (void) NSUnLinkModule(modulePtr->module, NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES); modulePtr = modulePtr->nextPtr; - ckfree(ptr); + Tcl_Free(ptr); } #endif /* TCL_DYLD_USE_NSMODULE */ } - ckfree(dyldLoadHandle); - ckfree(loadHandle); + Tcl_Free(dyldLoadHandle); + Tcl_Free(loadHandle); } /* @@ -583,7 +591,7 @@ TclpLoadMemory( if ((size_t) codeSize >= sizeof(struct fat_header) + fh_nfat_arch * sizeof(struct fat_arch)) { - void *fatarchs = (char*)buffer + sizeof(struct fat_header); + void *fatarchs = (char *)buffer + sizeof(struct fat_header); const NXArchInfo *arch = NXGetLocalArchInfo(); struct fat_arch *fa; @@ -664,14 +672,14 @@ TclpLoadMemory( * Stash the module reference within the load handle we create and return. */ - modulePtr = (Tcl_DyldModuleHandle *)ckalloc(sizeof(Tcl_DyldModuleHandle)); + modulePtr = (Tcl_DyldModuleHandle *)Tcl_Alloc(sizeof(Tcl_DyldModuleHandle)); modulePtr->module = module; modulePtr->nextPtr = NULL; - dyldLoadHandle = (Tcl_DyldLoadHandle *)ckalloc(sizeof(Tcl_DyldLoadHandle)); + dyldLoadHandle = (Tcl_DyldLoadHandle *)Tcl_Alloc(sizeof(Tcl_DyldLoadHandle)); dyldLoadHandle->dlHandle = NULL; dyldLoadHandle->dyldLibHeader = NULL; dyldLoadHandle->modulePtr = modulePtr; - newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle)); + newHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(*newHandle)); newHandle->clientData = dyldLoadHandle; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c index b52fa2a..5acd397 100644 --- a/unix/tclLoadNext.c +++ b/unix/tclLoadNext.c @@ -14,14 +14,17 @@ #include <mach-o/rld.h> #include <streams/streams.h> -/* Static procedures defined within this file */ + +/* + * Static procedures defined within this file. + */ static void * FindSymbol(Tcl_Interp *interp, - Tcl_LoadHandle loadHandle, const char* symbol); + Tcl_LoadHandle loadHandle, const char *symbol); static void UnloadFile(Tcl_LoadHandle loadHandle); /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TclpDlopen -- * @@ -29,13 +32,13 @@ static void UnloadFile(Tcl_LoadHandle loadHandle); * to the new code. * * Results: - * A standard Tcl completion code. If an error occurs, an error message + * A standard Tcl completion code. If an error occurs, an error message * is left in the interp's result. * * Side effects: * New code suddenly appears in memory. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -61,7 +64,7 @@ TclpDlopen( NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE); - fileName = Tcl_GetString(pathPtr); + fileName = TclGetString(pathPtr); /* * First try the full path the user gave us. This is particularly @@ -78,12 +81,16 @@ TclpDlopen( /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the - * binary path + * binary path. */ Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, fileName, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + native = Tcl_DStringValue(&ds); files = {native,NULL}; result = rld_load(errorStream, &header, files, NULL); Tcl_DStringFree(&ds); @@ -101,12 +108,12 @@ TclpDlopen( } NXCloseMemory(errorStream, NX_FREEBUFFER); - newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle)); + newHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(*newHandle)); newHandle->clientData = INT2PTR(1); newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; - *loadHandle = newHandle; *unloadProcPtr = &UnloadFile; + *loadHandle = newHandle; return TCL_OK; } @@ -169,13 +176,13 @@ FindSymbol( *---------------------------------------------------------------------- */ -void +static void UnloadFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { - ckfree(loadHandle); + Tcl_Free(loadHandle); } /* diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index 81468b8..43f29c8 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -36,16 +36,17 @@ #include <sys/types.h> #include <loader.h> + /* - * Static functions defined within this file. + * Static procedures defined within this file. */ static void * FindSymbol(Tcl_Interp *interp, - Tcl_LoadHandle loadHandle, const char* symbol); -static void UnloadFile(Tcl_LoadHandle handle); + Tcl_LoadHandle loadHandle, const char *symbol); +static void UnloadFile(Tcl_LoadHandle loadHandle); /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TclpDlopen -- * @@ -53,13 +54,13 @@ static void UnloadFile(Tcl_LoadHandle handle); * to the new code. * * Results: - * A standard Tcl completion code. If an error occurs, an error message + * A standard Tcl completion code. If an error occurs, an error message * is left in the interp's result. * * Side effects: * New code suddenly appears in memory. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -79,11 +80,11 @@ TclpDlopen( Tcl_LoadHandle newHandle; ldr_module_t lm; char *pkg; - char *fileName = Tcl_GetString(pathPtr); + char *fileName = TclGetString(pathPtr); const char *native; /* - * First try the full path the user gave us. This is particularly + * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ @@ -100,7 +101,11 @@ TclpDlopen( Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, fileName, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + native = Tcl_DStringValue(&ds); lm = (Tcl_LibraryInitProc *) load(native, LDR_NOFLAGS); Tcl_DStringFree(&ds); } @@ -128,12 +133,13 @@ TclpDlopen( } else { pkg++; } - newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle)); + newHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(*newHandle)); newHandle->clientData = pkg; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; - *loadHandle = newHandle; *unloadProcPtr = &UnloadFile; + *loadHandle = newHandle; + return TCL_OK; } @@ -147,7 +153,7 @@ TclpDlopen( * * Results: * Returns a pointer to the function associated with 'symbol' if it is - * found. Otherwise returns NULL and may leave an error message in the + * found. Otherwise returns NULL and may leave an error message in the * interp's result. * *---------------------------------------------------------------------- @@ -159,14 +165,14 @@ FindSymbol( Tcl_LoadHandle loadHandle, const char *symbol) { - void *retval = ldr_lookup_package((char *) loadHandle, symbol); + void *proc = ldr_lookup_package((char *) loadHandle, symbol); - if (retval == NULL && interp != NULL) { + if (proc == NULL && interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot find symbol \"%s\"", symbol)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, (void *)NULL); } - return retval; + return proc; } /* @@ -193,7 +199,7 @@ UnloadFile( * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { - ckfree(loadHandle); + Tcl_Free(loadHandle); } /* diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index 5cde183..63e9328 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -31,13 +31,13 @@ static void UnloadFile(Tcl_LoadHandle handle); * to the new code. * * Results: - * A standard Tcl completion code. If an error occurs, an error message + * A standard Tcl completion code. If an error occurs, an error message * is left in the interp's result. * * Side effects: * New code suddenly appears in memory. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -57,7 +57,7 @@ TclpDlopen( shl_t handle; Tcl_LoadHandle newHandle; const char *native; - char *fileName = Tcl_GetString(pathPtr); + char *fileName = TclGetString(pathPtr); /* * The flags below used to be BIND_IMMEDIATE; they were changed at the @@ -86,7 +86,11 @@ TclpDlopen( Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, fileName, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + native = Tcl_DStringValue(&ds); handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L); Tcl_DStringFree(&ds); } @@ -97,7 +101,7 @@ TclpDlopen( fileName, Tcl_PosixError(interp))); return TCL_ERROR; } - newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle)); + newHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(*newHandle)); newHandle->clientData = handle; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = *unloadProcPtr = &UnloadFile; @@ -182,7 +186,7 @@ UnloadFile( shl_t handle = (shl_t) loadHandle->clientData; shl_unload(handle); - ckfree(loadHandle); + Tcl_Free(loadHandle); } /* diff --git a/unix/tclSelectNotfy.c b/unix/tclSelectNotfy.c index fc77e77..feabfa8 100644 --- a/unix/tclSelectNotfy.c +++ b/unix/tclSelectNotfy.c @@ -32,7 +32,7 @@ typedef struct FileHandler { * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; @@ -214,7 +214,7 @@ static sigset_t allSigMask; */ #if TCL_THREADS -static TCL_NORETURN void NotifierThreadProc(ClientData clientData); +static TCL_NORETURN void NotifierThreadProc(void *clientData); #if defined(HAVE_PTHREAD_ATFORK) static int atForkInit = 0; static void AtForkChild(void); @@ -313,7 +313,7 @@ static unsigned int __stdcall NotifierProc(void *hwnd, unsigned int message, *---------------------------------------------------------------------- */ -ClientData +void * TclpInitNotifier(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -480,13 +480,13 @@ TclpCreateFileHandler( * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); if (filePtr == NULL) { - filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->readyMask = 0; filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; @@ -595,7 +595,7 @@ TclpDeleteFileHandler( } else { prevPtr->nextPtr = filePtr->nextPtr; } - ckfree(filePtr); + Tcl_Free(filePtr); } #if TCL_THREADS && defined(__CYGWIN__) @@ -885,7 +885,7 @@ TclpWaitForEvent( if (filePtr->readyMask == 0) { FileHandlerEvent *fileEvPtr = - (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent)); + (FileHandlerEvent *) Tcl_Alloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; @@ -921,7 +921,7 @@ int TclAsyncNotifier( int sigNumber, /* Signal number. */ TCL_UNUSED(Tcl_ThreadId), /* Target thread. */ - TCL_UNUSED(ClientData), /* Notifier data. */ + TCL_UNUSED(void *), /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { @@ -989,7 +989,7 @@ TclAsyncNotifier( #if TCL_THREADS static TCL_NORETURN void NotifierThreadProc( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr; fd_set readableMask; @@ -1179,7 +1179,7 @@ NotifierThreadProc( */ do { - i = read(receivePipe, buf, 1); + i = (int)read(receivePipe, buf, 1); if (i <= 0) { break; } else if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) { diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index fc2280a..1436b5c 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", (char *)NULL); \ + Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (void *)NULL); \ } /* @@ -131,10 +131,6 @@ static int FileInputProc(void *instanceData, char *buf, int toRead, int *errorCode); static int FileOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); -#ifndef TCL_NO_DEPRECATED -static int FileSeekProc(void *instanceData, long offset, - int mode, int *errorCode); -#endif static int FileTruncateProc(void *instanceData, long long length); static long long FileWideSeekProc(void *instanceData, @@ -166,14 +162,10 @@ static int TtySetOptionProc(void *instanceData, static const Tcl_ChannelType fileChannelType = { "file", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - TCL_CLOSE2PROC, /* Close proc. */ + NULL, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ -#ifndef TCL_NO_DEPRECATED - FileSeekProc, /* Seek proc. */ -#else NULL, -#endif NULL, /* Set option proc. */ FileGetOptionProc, /* Get option proc. */ FileWatchProc, /* Initialize notifier. */ @@ -196,7 +188,7 @@ static const Tcl_ChannelType fileChannelType = { static const Tcl_ChannelType ttyChannelType = { "tty", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - TCL_CLOSE2PROC, /* Close proc. */ + NULL, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ NULL, /* Seek proc. */ @@ -386,7 +378,7 @@ FileCloseProc( errorCode = errno; } } - ckfree(fsPtr); + Tcl_Free(fsPtr); return errorCode; } @@ -437,67 +429,6 @@ TtyCloseProc( /* *---------------------------------------------------------------------- * - * FileSeekProc -- - * - * This function is called by the generic IO level to move the access - * point in a file based channel. - * - * Results: - * -1 if failed, the new position if successful. An output argument - * contains the POSIX error code if an error occurred, or zero. - * - * Side effects: - * Moves the location at which the channel will be accessed in future - * operations. - * - *---------------------------------------------------------------------- - */ -#ifndef TCL_NO_DEPRECATED -static int -FileSeekProc( - void *instanceData, /* File state. */ - long offset, /* Offset to seek to. */ - int mode, /* Relative to where should we seek? Can be - * one of SEEK_START, SEEK_SET or SEEK_END. */ - int *errorCodePtr) /* To store error code. */ -{ - FileState *fsPtr = (FileState *)instanceData; - long long oldLoc, newLoc; - - /* - * Save our current place in case we need to roll-back the seek. - */ - - oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR); - if (oldLoc == -1) { - /* - * Bad things are happening. Error out... - */ - - *errorCodePtr = errno; - return -1; - } - - newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode); - - /* - * Check for expressability in our return type, and roll-back otherwise. - */ - - if (newLoc > INT_MAX) { - *errorCodePtr = EOVERFLOW; - TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET); - return -1; - } else { - *errorCodePtr = (newLoc == -1) ? errno : 0; - } - return (int) newLoc; -} -#endif - -/* - *---------------------------------------------------------------------- - * * FileWideSeekProc -- * * This function is called by the generic IO level to move the access @@ -910,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", (char *)NULL); + "VALUE", (void *)NULL); } return TCL_ERROR; } @@ -931,9 +862,9 @@ 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", (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", (void *)NULL); } - ckfree(argv); + Tcl_Free(argv); return TCL_ERROR; } @@ -956,7 +887,7 @@ TtySetOptionProc( } iostate.c_cc[VSTOP] = character; } - ckfree(argv); + Tcl_Free(argv); tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate); return TCL_OK; @@ -997,16 +928,16 @@ TtySetOptionProc( "bad value for -ttycontrol: should be a list of" " signal,value pairs", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", (char *)NULL); + "VALUE", (void *)NULL); } - ckfree(argv); + Tcl_Free(argv); return TCL_ERROR; } ioctl(fsPtr->fileState.fd, TIOCMGET, &control); for (i = 0; i < argc-1; i += 2) { if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) { - ckfree(argv); + Tcl_Free(argv); return TCL_ERROR; } if (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) { @@ -1030,7 +961,7 @@ TtySetOptionProc( } #else /* TIOCSBRK & TIOCCBRK */ UNSUPPORTED_OPTION("-ttycontrol BREAK"); - ckfree(argv); + Tcl_Free(argv); return TCL_ERROR; #endif /* TIOCSBRK & TIOCCBRK */ } else { @@ -1039,15 +970,15 @@ TtySetOptionProc( "bad signal \"%s\" for -ttycontrol: must be" " DTR, RTS or BREAK", argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", (char *)NULL); + "VALUE", (void *)NULL); } - ckfree(argv); + Tcl_Free(argv); return TCL_ERROR; } } /* -ttycontrol options loop */ ioctl(fsPtr->fileState.fd, TIOCMSET, &control); - ckfree(argv); + Tcl_Free(argv); return TCL_OK; #else /* TIOCMGET&TIOCMSET */ UNSUPPORTED_OPTION("-ttycontrol"); @@ -1071,7 +1002,7 @@ TtySetOptionProc( "bad mode \"%s\" for -closemode: must be" " default, discard, or drain", value)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", (char *)NULL); + "VALUE", (void *)NULL); } return TCL_ERROR; } @@ -1129,7 +1060,7 @@ TtySetOptionProc( "bad mode \"%s\" for -inputmode: must be" " normal, password, raw, or reset", value)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", (char *)NULL); + "VALUE", (void *)NULL); } return TCL_ERROR; } @@ -1282,11 +1213,11 @@ TtyGetOptionProc( tcgetattr(fsPtr->fileState.fd, &iostate); Tcl_DStringInit(&ds); - Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds); + Tcl_ExternalToUtfDStringEx(NULL, NULL, (char *) &iostate.c_cc[VSTART], 1, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); TclDStringClear(&ds); - Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTOP], 1, &ds); + Tcl_ExternalToUtfDStringEx(NULL, NULL, (char *) &iostate.c_cc[VSTOP], 1, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); } @@ -1707,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", (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (void *)NULL); } return TCL_ERROR; } @@ -1737,7 +1668,7 @@ TtyParseMode( "n, o, or e" #endif /* PAREXT */ )); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (void *)NULL); } return TCL_ERROR; } @@ -1746,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", (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (void *)NULL); } return TCL_ERROR; } @@ -1754,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", (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (void *)NULL); } return TCL_ERROR; } @@ -1861,7 +1792,7 @@ TclpOpenFileChannel( if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), "\": filename is invalid on this platform", - (char *)NULL); + (void *)NULL); } return NULL; } @@ -1916,7 +1847,7 @@ TclpOpenFileChannel( snprintf(channelName, sizeof(channelName), "file%d", fd); } - fsPtr = (TtyState *)ckalloc(sizeof(TtyState)); + fsPtr = (TtyState *)Tcl_Alloc(sizeof(TtyState)); fsPtr->fileState.validMask = channelPermissions | TCL_EXCEPTION; fsPtr->fileState.fd = fd; #ifdef SUPPORTS_TTY @@ -1941,7 +1872,7 @@ TclpOpenFileChannel( if (Tcl_SetChannelOption(interp, fsPtr->fileState.channel, "-translation", translation) != TCL_OK) { - Tcl_Close(NULL, fsPtr->fileState.channel); + Tcl_CloseEx(NULL, fsPtr->fileState.channel, 0); return NULL; } } @@ -1985,7 +1916,6 @@ Tcl_MakeFileChannel( if (isatty(fd)) { channelTypePtr = &ttyChannelType; snprintf(channelName, sizeof(channelName), "serial%d", fd); - goto final; } else #endif /* SUPPORTS_TTY */ if (TclOSfstat(fd, &buf) == 0 && S_ISSOCK(buf.st_mode)) { @@ -1999,11 +1929,14 @@ Tcl_MakeFileChannel( || sockaddr.sa_family == AF_INET6)) { return (Tcl_Channel)TclpMakeTcpClientChannelMode(INT2PTR(fd), mode); } + goto normalChannelAfterAll; + } else { + normalChannelAfterAll: + channelTypePtr = &fileChannelType; + snprintf(channelName, sizeof(channelName), "file%d", fd); } - channelTypePtr = &fileChannelType; - snprintf(channelName, sizeof(channelName), "file%d", fd); -final: - fsPtr = (TtyState *)ckalloc(sizeof(TtyState)); + + fsPtr = (TtyState *)Tcl_Alloc(sizeof(TtyState)); fsPtr->fileState.fd = fd; fsPtr->fileState.validMask = mode | TCL_EXCEPTION; fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName, @@ -2152,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", - (char *)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", - (char *)NULL); + (void *)NULL); return TCL_ERROR; } @@ -2190,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", (char *)NULL); + "FILE_FAILURE", (void *)NULL); return TCL_ERROR; } *filePtr = f; @@ -2201,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", - (char *)NULL); + (void *)NULL); return TCL_ERROR; } diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 3a7778e..30ddb71 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -8,8 +8,6 @@ */ #include "tclInt.h" -#include <pwd.h> -#include <grp.h> #include <errno.h> #include <string.h> @@ -118,10 +116,10 @@ static int CopyString(const char *src, char *buf, int buflen); #endif #ifdef NEED_PW_CLEANER -static void FreePwBuf(ClientData dummy); +static void FreePwBuf(void *dummy); #endif #ifdef NEED_GR_CLEANER -static void FreeGrBuf(ClientData dummy); +static void FreeGrBuf(void *dummy); #endif #endif /* TCL_THREADS */ @@ -201,7 +199,7 @@ TclpGetPwNam( if (tsdPtr->pbuflen < 1) { tsdPtr->pbuflen = 1024; } - tsdPtr->pbuf = (char *)ckalloc(tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)Tcl_Alloc(tsdPtr->pbuflen); Tcl_CreateThreadExitHandler(FreePwBuf, NULL); } while (1) { @@ -214,7 +212,7 @@ TclpGetPwNam( return NULL; } tsdPtr->pbuflen *= 2; - tsdPtr->pbuf = (char *)ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)Tcl_Realloc(tsdPtr->pbuf, tsdPtr->pbuflen); } return (pwPtr != NULL ? &tsdPtr->pwd : NULL); @@ -281,7 +279,7 @@ TclpGetPwUid( if (tsdPtr->pbuflen < 1) { tsdPtr->pbuflen = 1024; } - tsdPtr->pbuf = (char *)ckalloc(tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)Tcl_Alloc(tsdPtr->pbuflen); Tcl_CreateThreadExitHandler(FreePwBuf, NULL); } while (1) { @@ -294,7 +292,7 @@ TclpGetPwUid( return NULL; } tsdPtr->pbuflen *= 2; - tsdPtr->pbuf = (char *)ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen); + tsdPtr->pbuf = (char *)Tcl_Realloc(tsdPtr->pbuf, tsdPtr->pbuflen); } return (pwPtr != NULL ? &tsdPtr->pwd : NULL); @@ -336,11 +334,11 @@ TclpGetPwUid( #ifdef NEED_PW_CLEANER static void FreePwBuf( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - ckfree(tsdPtr->pbuf); + Tcl_Free(tsdPtr->pbuf); } #endif /* NEED_PW_CLEANER */ @@ -384,7 +382,7 @@ TclpGetGrNam( if (tsdPtr->gbuflen < 1) { tsdPtr->gbuflen = 1024; } - tsdPtr->gbuf = (char *)ckalloc(tsdPtr->gbuflen); + tsdPtr->gbuf = (char *)Tcl_Alloc(tsdPtr->gbuflen); Tcl_CreateThreadExitHandler(FreeGrBuf, NULL); } while (1) { @@ -397,7 +395,7 @@ TclpGetGrNam( return NULL; } tsdPtr->gbuflen *= 2; - tsdPtr->gbuf = (char *)ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen); + tsdPtr->gbuf = (char *)Tcl_Realloc(tsdPtr->gbuf, tsdPtr->gbuflen); } return (grPtr != NULL ? &tsdPtr->grp : NULL); @@ -464,7 +462,7 @@ TclpGetGrGid( if (tsdPtr->gbuflen < 1) { tsdPtr->gbuflen = 1024; } - tsdPtr->gbuf = (char *)ckalloc(tsdPtr->gbuflen); + tsdPtr->gbuf = (char *)Tcl_Alloc(tsdPtr->gbuflen); Tcl_CreateThreadExitHandler(FreeGrBuf, NULL); } while (1) { @@ -477,7 +475,7 @@ TclpGetGrGid( return NULL; } tsdPtr->gbuflen *= 2; - tsdPtr->gbuf = (char *)ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen); + tsdPtr->gbuf = (char *)Tcl_Realloc(tsdPtr->gbuf, tsdPtr->gbuflen); } return (grPtr != NULL ? &tsdPtr->grp : NULL); @@ -519,11 +517,11 @@ TclpGetGrGid( #ifdef NEED_GR_CLEANER static void FreeGrBuf( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - ckfree(tsdPtr->gbuf); + Tcl_Free(tsdPtr->gbuf); } #endif /* NEED_GR_CLEANER */ diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index b009d97..48023b1 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -41,8 +41,6 @@ */ #include "tclInt.h" -#include <utime.h> -#include <grp.h> #ifndef HAVE_STRUCT_STAT_ST_BLKSIZE #ifndef NO_FSTATFS #include <sys/statfs.h> @@ -260,13 +258,15 @@ MODULE_SCOPE long tclMacOSXDarwinRelease; #else # define haveRealpath 1 #endif +#else /* NO_REALPATH */ +/* + * At least TclpObjNormalizedPath now requires REALPATH +*/ +#error NO_REALPATH is not supported #endif /* NO_REALPATH */ #ifdef HAVE_FTS -#if defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) -/* fts doesn't do stat64 */ -# define noFtsStat 1 -#elif defined(__APPLE__) && defined(__LP64__) && \ +#if defined(__APPLE__) && defined(__LP64__) && \ defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \ MAC_OS_X_VERSION_MIN_REQUIRED < 1050 /* @@ -544,9 +544,9 @@ TclUnixCopyFile( int dontCopyAtts) /* If flag set, don't copy attributes. */ { int srcFd, dstFd; - unsigned blockSize; /* Optimal I/O blocksize for filesystem */ + size_t blockSize; /* Optimal I/O blocksize for filesystem */ char *buffer; /* Data buffer for copy */ - size_t nread; + ssize_t nread; #ifdef DJGPP #define BINMODE |O_BINARY @@ -600,21 +600,21 @@ TclUnixCopyFile( if (blockSize <= 0) { blockSize = DEFAULT_COPY_BLOCK_SIZE; } - buffer = (char *)ckalloc(blockSize); + buffer = (char *)Tcl_Alloc(blockSize); while (1) { - nread = (size_t) read(srcFd, buffer, blockSize); - if ((nread == (size_t) -1) || (nread == 0)) { + nread = read(srcFd, buffer, blockSize); + if ((nread == -1) || (nread == 0)) { break; } - if ((size_t) write(dstFd, buffer, nread) != nread) { - nread = (size_t) -1; + if (write(dstFd, buffer, nread) != nread) { + nread = -1; break; } } - ckfree(buffer); + Tcl_Free(buffer); close(srcFd); - if ((close(dstFd) != 0) || (nread == (size_t) -1)) { + if ((close(dstFd) != 0) || (nread == -1)) { unlink(dst); /* INTL: Native. */ return TCL_ERROR; } @@ -759,28 +759,35 @@ TclpObjCopyDirectory( Tcl_Obj *transPtr; transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr); - Tcl_UtfToExternalDString(NULL, + ret = Tcl_UtfToExternalDStringEx(NULL, NULL, (transPtr != NULL ? TclGetString(transPtr) : NULL), - -1, &srcString); + -1, 0, &srcString, NULL); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } - transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr); - Tcl_UtfToExternalDString(NULL, + if (ret != TCL_OK) { + *errorPtr = srcPathPtr; + } else { + transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr); + ret = Tcl_UtfToExternalDStringEx(NULL, NULL, (transPtr != NULL ? TclGetString(transPtr) : NULL), - -1, &dstString); - if (transPtr != NULL) { - Tcl_DecrRefCount(transPtr); + -1, TCL_ENCODING_PROFILE_TCL8, &dstString, NULL); + if (transPtr != NULL) { + Tcl_DecrRefCount(transPtr); + } + if (ret != TCL_OK) { + *errorPtr = destPathPtr; + } else { + ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0); + /* Note above call only sets ds on error */ + if (ret != TCL_OK) { + *errorPtr = Tcl_DStringToObj(&ds); + } + Tcl_DStringFree(&dstString); + } + Tcl_DStringFree(&srcString); } - - ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0); - - Tcl_DStringFree(&srcString); - Tcl_DStringFree(&dstString); - if (ret != TCL_OK) { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE); - Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); } return ret; @@ -823,18 +830,24 @@ TclpObjRemoveDirectory( int ret; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); - Tcl_UtfToExternalDString(NULL, + ret = Tcl_UtfToExternalDStringEx(NULL, NULL, (transPtr != NULL ? TclGetString(transPtr) : NULL), - -1, &pathString); + -1, TCL_ENCODING_PROFILE_TCL8, &pathString, NULL); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } - ret = DoRemoveDirectory(&pathString, recursive, &ds); - Tcl_DStringFree(&pathString); + if (ret != TCL_OK) { + *errorPtr = pathPtr; + } else { + ret = DoRemoveDirectory(&pathString, recursive, &ds); + Tcl_DStringFree(&pathString); + /* Note above call only sets ds on error */ + if (ret != TCL_OK) { + *errorPtr = Tcl_DStringToObj(&ds); + } + } if (ret != TCL_OK) { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE); - Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); } return ret; @@ -883,7 +896,7 @@ DoRemoveDirectory( result = TCL_OK; if ((errno != EEXIST) || (recursive == 0)) { if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, path, TCL_INDEX_NONE, errorPtr); + Tcl_ExternalToUtfDStringEx(NULL, NULL, path, TCL_INDEX_NONE, 0, errorPtr, NULL); } result = TCL_ERROR; } @@ -950,8 +963,8 @@ TraverseUnixTree( { Tcl_StatBuf statBuf; const char *source, *errfile; - int result, sourceLen; - int targetLen; + int result; + size_t targetLen, sourceLen; #ifndef HAVE_FTS int numProcessed = 0; Tcl_DirEntry *dirEntPtr; @@ -1132,7 +1145,7 @@ TraverseUnixTree( end: if (errfile != NULL) { if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, errfile, TCL_INDEX_NONE, errorPtr); + Tcl_ExternalToUtfDStringEx(NULL, NULL, errfile, TCL_INDEX_NONE, 0, errorPtr, NULL); } result = TCL_ERROR; } @@ -1202,8 +1215,8 @@ TraversalCopy( */ if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr), - Tcl_DStringLength(dstPtr), errorPtr); + Tcl_ExternalToUtfDStringEx(NULL, NULL, Tcl_DStringValue(dstPtr), + Tcl_DStringLength(dstPtr), 0, errorPtr, NULL); } return TCL_ERROR; } @@ -1253,8 +1266,8 @@ TraversalDelete( break; } if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr), - Tcl_DStringLength(srcPtr), errorPtr); + Tcl_ExternalToUtfDStringEx(NULL, NULL, Tcl_DStringValue(srcPtr), + Tcl_DStringLength(srcPtr), 0, errorPtr, NULL); } return TCL_ERROR; } @@ -1421,7 +1434,7 @@ GetOwnerAttribute( } else { Tcl_DString ds; - (void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, TCL_INDEX_NONE, &ds); + (void)Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, TCL_INDEX_NONE, &ds); *attributePtrPtr = Tcl_DStringToObj(&ds); } return TCL_OK; @@ -1497,14 +1510,19 @@ SetGroupAttribute( int result; const char *native; - if (Tcl_GetWideIntFromObj(NULL, attributePtr, &gid) != TCL_OK) { + if (TclGetWideIntFromObj(NULL, attributePtr, &gid) != TCL_OK) { Tcl_DString ds; struct group *groupPtr = NULL; const char *string; + Tcl_Size length; - string = TclGetString(attributePtr); + string = Tcl_GetStringFromObj(attributePtr, &length); - native = Tcl_UtfToExternalDString(NULL, string, attributePtr->length, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, string, length, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + native = Tcl_DStringValue(&ds); groupPtr = TclpGetGrNam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); @@ -1563,14 +1581,19 @@ SetOwnerAttribute( int result; const char *native; - if (Tcl_GetWideIntFromObj(NULL, attributePtr, &uid) != TCL_OK) { + if (TclGetWideIntFromObj(NULL, attributePtr, &uid) != TCL_OK) { Tcl_DString ds; struct passwd *pwPtr = NULL; const char *string; + Tcl_Size length; - string = TclGetString(attributePtr); + string = Tcl_GetStringFromObj(attributePtr, &length); - native = Tcl_UtfToExternalDString(NULL, string, attributePtr->length, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, string, length, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + native = Tcl_DStringValue(&ds); pwPtr = TclpGetPwNam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); @@ -1643,12 +1666,12 @@ SetPermissionsAttribute( Tcl_Obj *modeObj; TclNewLiteralStringObj(modeObj, "0o"); - Tcl_AppendToObj(modeObj, modeStringPtr+scanned+1, -1); - result = Tcl_GetWideIntFromObj(NULL, modeObj, &mode); + Tcl_AppendToObj(modeObj, modeStringPtr+scanned+1, TCL_INDEX_NONE); + result = TclGetWideIntFromObj(NULL, modeObj, &mode); Tcl_DecrRefCount(modeObj); } if (result == TCL_OK - || Tcl_GetWideIntFromObj(NULL, attributePtr, &mode) == TCL_OK) { + || TclGetWideIntFromObj(NULL, attributePtr, &mode) == TCL_OK) { newMode = (mode_t) (mode & 0x00007FFF); } else { Tcl_StatBuf buf; @@ -1930,7 +1953,7 @@ GetModeFromPermString( int TclpObjNormalizePath( - TCL_UNUSED(Tcl_Interp *), + Tcl_Interp *interp, Tcl_Obj *pathPtr, /* An unshared object containing the path to * normalize. */ int nextCheckpoint) /* offset to start at in pathPtr. Must either @@ -1942,8 +1965,8 @@ TclpObjNormalizePath( { const char *currentPathEndPosition; char cur; - const char *path = TclGetString(pathPtr); - size_t pathLen = pathPtr->length; + Tcl_Size pathLen; + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); Tcl_DString ds; const char *nativePath; #ifndef NO_REALPATH @@ -1964,8 +1987,12 @@ TclpObjNormalizePath( const char *lastDir = strrchr(currentPathEndPosition, '/'); if (lastDir != NULL) { - nativePath = Tcl_UtfToExternalDString(NULL, path, - lastDir-path, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, path, + lastDir-path, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return -1; + } + nativePath = Tcl_DStringValue(&ds); if (Realpath(nativePath, normPath) != NULL) { if (*nativePath != '/' && *normPath == '/') { /* @@ -2000,8 +2027,12 @@ TclpObjNormalizePath( int accessOk; - nativePath = Tcl_UtfToExternalDString(NULL, path, - currentPathEndPosition - path, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, path, + currentPathEndPosition - path, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return -1; + } + nativePath = Tcl_DStringValue(&ds); accessOk = access(nativePath, F_OK); Tcl_DStringFree(&ds); @@ -2045,9 +2076,13 @@ TclpObjNormalizePath( return 0; } - nativePath = Tcl_UtfToExternalDString(NULL, path,nextCheckpoint, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, path,nextCheckpoint, 0, &ds, NULL)) { + Tcl_DStringFree(&ds); + return -1; + } + nativePath = Tcl_DStringValue(&ds); if (Realpath(nativePath, normPath) != NULL) { - int newNormLen; + Tcl_Size newNormLen; wholeStringOk: newNormLen = strlen(normPath); @@ -2081,7 +2116,7 @@ TclpObjNormalizePath( */ Tcl_DStringFree(&ds); - Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds); + Tcl_ExternalToUtfDStringEx(NULL, NULL, normPath, newNormLen, 0, &ds, NULL); if (path[nextCheckpoint] != '\0') { /* @@ -2166,14 +2201,17 @@ TclUnixOpenTemporaryFile( Tcl_DString templ, tmp; const char *string; int fd; + Tcl_Size length; /* - * We should also check against making more then TMP_MAX of these. + * We should also check against making more than TMP_MAX of these. */ if (dirObj) { - string = TclGetString(dirObj); - Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ); + string = Tcl_GetStringFromObj(dirObj, &length); + if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, length, 0, &templ, NULL) != TCL_OK) { + return -1; + } } else { Tcl_DStringInit(&templ); Tcl_DStringAppend(&templ, DefaultTempDir(), TCL_INDEX_NONE); /* INTL: native */ @@ -2182,8 +2220,11 @@ TclUnixOpenTemporaryFile( TclDStringAppendLiteral(&templ, "/"); if (basenameObj) { - string = TclGetString(basenameObj); - Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp); + string = Tcl_GetStringFromObj(basenameObj, &length); + if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, length, 0, &tmp, NULL) != TCL_OK) { + Tcl_DStringFree(&tmp); + return -1; + } TclDStringAppendDString(&templ, &tmp); Tcl_DStringFree(&tmp); } else { @@ -2194,8 +2235,11 @@ TclUnixOpenTemporaryFile( #ifdef HAVE_MKSTEMPS if (extensionObj) { - string = TclGetString(extensionObj); - Tcl_UtfToExternalDString(NULL, string, extensionObj->length, &tmp); + string = Tcl_GetStringFromObj(extensionObj, &length); + if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, length, 0, &tmp, NULL) != TCL_OK) { + Tcl_DStringFree(&templ); + return -1; + } TclDStringAppendDString(&templ, &tmp); fd = mkstemps(Tcl_DStringValue(&templ), Tcl_DStringLength(&tmp)); Tcl_DStringFree(&tmp); @@ -2211,8 +2255,11 @@ TclUnixOpenTemporaryFile( } if (resultingNameObj) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&templ), - Tcl_DStringLength(&templ), &tmp); + if (Tcl_ExternalToUtfDStringEx(NULL, NULL, Tcl_DStringValue(&templ), + Tcl_DStringLength(&templ), 0, &tmp, NULL) != TCL_OK) { + Tcl_DStringFree(&templ); + return -1; + } Tcl_SetStringObj(resultingNameObj, Tcl_DStringValue(&tmp), Tcl_DStringLength(&tmp)); Tcl_DStringFree(&tmp); @@ -2298,7 +2345,9 @@ TclpCreateTemporaryDirectory( if (dirObj) { string = TclGetString(dirObj); - Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ); + if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, dirObj->length, 0, &templ, NULL) != TCL_OK) { + return NULL; + } } else { Tcl_DStringInit(&templ); Tcl_DStringAppend(&templ, DefaultTempDir(), TCL_INDEX_NONE); /* INTL: native */ @@ -2311,7 +2360,10 @@ TclpCreateTemporaryDirectory( if (basenameObj) { string = TclGetString(basenameObj); if (basenameObj->length) { - Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp); + if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, basenameObj->length, 0, &tmp, NULL) != TCL_OK) { + Tcl_DStringFree(&templ); + return NULL; + } TclDStringAppendDString(&templ, &tmp); Tcl_DStringFree(&tmp); } else { @@ -2336,8 +2388,11 @@ TclpCreateTemporaryDirectory( * The template has been updated. Tell the caller what it was. */ - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&templ), - Tcl_DStringLength(&templ), &tmp); + if (Tcl_ExternalToUtfDStringEx(NULL, NULL, Tcl_DStringValue(&templ), + Tcl_DStringLength(&templ), 0, &tmp, NULL) != TCL_OK) { + Tcl_DStringFree(&templ); + return NULL; + } Tcl_DStringFree(&templ); return Tcl_DStringToObj(&tmp); } @@ -2359,12 +2414,12 @@ static WCHAR * winPathFromObj( Tcl_Obj *fileName) { - int size; + size_t size; const char *native = (const char *)Tcl_FSGetNativePath(fileName); WCHAR *winPath; size = cygwin_conv_path(1, native, NULL, 0); - winPath = (WCHAR *)ckalloc(size); + winPath = (WCHAR *)Tcl_Alloc(size); cygwin_conv_path(1, native, winPath, size); return winPath; @@ -2404,7 +2459,7 @@ GetUnixFileAttributes( WCHAR *winPath = winPathFromObj(fileName); fileAttributes = GetFileAttributesW(winPath); - ckfree(winPath); + Tcl_Free(winPath); if (fileAttributes == -1) { StatError(interp, fileName); @@ -2451,7 +2506,7 @@ SetUnixFileAttributes( fileAttributes = old = GetFileAttributesW(winPath); if (fileAttributes == -1) { - ckfree(winPath); + Tcl_Free(winPath); StatError(interp, fileName); return TCL_ERROR; } @@ -2464,12 +2519,12 @@ SetUnixFileAttributes( if ((fileAttributes != old) && !SetFileAttributesW(winPath, fileAttributes)) { - ckfree(winPath); + Tcl_Free(winPath); StatError(interp, fileName); return TCL_ERROR; } - ckfree(winPath); + Tcl_Free(winPath); return TCL_OK; } #elif defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index fc3adab..42be6bc 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -155,7 +155,7 @@ TclpFindExecutable( #endif { encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, name, TCL_INDEX_NONE, &utfName); + Tcl_ExternalToUtfDStringEx(NULL, encoding, name, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &utfName, NULL); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding); Tcl_DStringFree(&utfName); @@ -182,8 +182,8 @@ TclpFindExecutable( Tcl_DStringAppend(&nameString, name, TCL_INDEX_NONE); Tcl_DStringFree(&buffer); - Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd), - Tcl_DStringLength(&cwd), &buffer); + Tcl_UtfToExternalDStringEx(NULL, NULL, Tcl_DStringValue(&cwd), + Tcl_DStringLength(&cwd), TCL_ENCODING_PROFILE_TCL8, &buffer, NULL); if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') { TclDStringAppendLiteral(&buffer, "/"); } @@ -192,8 +192,8 @@ TclpFindExecutable( Tcl_DStringFree(&nameString); encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), TCL_INDEX_NONE, - &utfName); + Tcl_ExternalToUtfDStringEx(NULL, encoding, Tcl_DStringValue(&buffer), TCL_INDEX_NONE, + TCL_ENCODING_PROFILE_TCL8, &utfName, NULL); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding); Tcl_DStringFree(&utfName); @@ -308,7 +308,13 @@ TclpMatchInDirectory( * Now open the directory for reading and iterate over the contents. */ - native = Tcl_UtfToExternalDString(NULL, dirName, TCL_INDEX_NONE, &ds); + if (Tcl_UtfToExternalDStringEx(interp, NULL, dirName, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&dsOrig); + Tcl_DStringFree(&ds); + Tcl_DecrRefCount(fileNamePtr); + return TCL_ERROR; + } + native = Tcl_DStringValue(&ds); if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */ || !S_ISDIR(statBuf.st_mode)) { @@ -372,8 +378,12 @@ TclpMatchInDirectory( * and pattern. If so, add the file to the result. */ - utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, TCL_INDEX_NONE, - &utfDs); + if (Tcl_ExternalToUtfDStringEx(interp, NULL, entryPtr->d_name, TCL_INDEX_NONE, + 0, &utfDs, NULL) != TCL_OK) { + matchResult = -1; + break; + } + utfname = Tcl_DStringValue(&utfDs); if (Tcl_StringCaseMatch(utfname, pattern, 0)) { int typeOk = 1; @@ -599,7 +609,13 @@ TclpGetUserHome( { struct passwd *pwPtr; Tcl_DString ds; - const char *native = Tcl_UtfToExternalDString(NULL, name, TCL_INDEX_NONE, &ds); + const char *native; + + if (Tcl_UtfToExternalDStringEx(NULL, NULL, name, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return NULL; + } + native = Tcl_DStringValue(&ds); pwPtr = TclpGetPwNam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); @@ -607,7 +623,11 @@ TclpGetUserHome( if (pwPtr == NULL) { return NULL; } - return Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, TCL_INDEX_NONE, bufferPtr); + if (Tcl_ExternalToUtfDStringEx(NULL, NULL, pwPtr->pw_dir, TCL_INDEX_NONE, 0, bufferPtr, NULL) != TCL_OK) { + return NULL; + } else { + return Tcl_DStringValue(bufferPtr); + } } /* @@ -712,9 +732,9 @@ TclpObjLstat( *---------------------------------------------------------------------- */ -ClientData +void * TclpGetNativeCwd( - ClientData clientData) + void *clientData) { char buffer[MAXPATHLEN+1]; @@ -729,7 +749,7 @@ TclpGetNativeCwd( #endif /* USEGETWD */ if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) { - char *newCd = (char *)ckalloc(strlen(buffer) + 1); + char *newCd = (char *)Tcl_Alloc(strlen(buffer) + 1); strcpy(newCd, buffer); return newCd; @@ -785,7 +805,10 @@ TclpGetCwd( } return NULL; } - return Tcl_ExternalToUtfDString(NULL, buffer, TCL_INDEX_NONE, bufferPtr); + if (Tcl_ExternalToUtfDStringEx(interp, NULL, buffer, TCL_INDEX_NONE, 0, bufferPtr, NULL) != TCL_OK) { + return NULL; + } + return Tcl_DStringValue(bufferPtr); } /* @@ -820,7 +843,11 @@ TclpReadlink( const char *native; Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, path, TCL_INDEX_NONE, &ds); + if (Tcl_UtfToExternalDStringEx(NULL, NULL, path, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return NULL; + } + native = Tcl_DStringValue(&ds); length = readlink(native, link, sizeof(link)); /* INTL: Native. */ Tcl_DStringFree(&ds); @@ -828,11 +855,12 @@ TclpReadlink( return NULL; } - Tcl_ExternalToUtfDString(NULL, link, length, linkPtr); - return Tcl_DStringValue(linkPtr); -#else - return NULL; + if (Tcl_ExternalToUtfDStringEx(NULL, NULL, link, length, 0, linkPtr, NULL) == TCL_OK) { + return Tcl_DStringValue(linkPtr); + } #endif /* !DJGPP */ + + return NULL; } /* @@ -961,8 +989,12 @@ TclpObjLink( if (transPtr == NULL) { return NULL; } - target = TclGetStringFromObj(transPtr, &length); - target = Tcl_UtfToExternalDString(NULL, target, length, &ds); + target = Tcl_GetStringFromObj(transPtr, &length); + if (Tcl_UtfToExternalDStringEx(NULL, NULL, target, length, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return NULL; + } + target = Tcl_DStringValue(&ds); Tcl_DecrRefCount(transPtr); if (symlink(target, src) != 0) { @@ -982,7 +1014,7 @@ TclpObjLink( Tcl_Obj *linkPtr = NULL; char link[MAXPATHLEN]; - Tcl_Size length; + ssize_t length; Tcl_DString ds; Tcl_Obj *transPtr; @@ -997,7 +1029,9 @@ TclpObjLink( return NULL; } - Tcl_ExternalToUtfDString(NULL, link, length, &ds); + if (Tcl_ExternalToUtfDStringEx(NULL, NULL, link, (size_t)length, 0, &ds, NULL) != TCL_OK) { + return NULL; + } linkPtr = Tcl_DStringToObj(&ds); Tcl_IncrRefCount(linkPtr); return linkPtr; @@ -1058,11 +1092,11 @@ TclpFilesystemPathType( Tcl_Obj * TclpNativeToNormalized( - ClientData clientData) + void *clientData) { Tcl_DString ds; - Tcl_ExternalToUtfDString(NULL, (const char *) clientData, TCL_INDEX_NONE, &ds); + Tcl_ExternalToUtfDStringEx(NULL, NULL, (const char *) clientData, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); return Tcl_DStringToObj(&ds); } @@ -1082,7 +1116,7 @@ TclpNativeToNormalized( *--------------------------------------------------------------------------- */ -ClientData +void * TclNativeCreateNativeRep( Tcl_Obj *pathPtr) { @@ -1115,8 +1149,12 @@ TclNativeCreateNativeRep( Tcl_IncrRefCount(validPathPtr); } - str = TclGetStringFromObj(validPathPtr, &len); - Tcl_UtfToExternalDString(NULL, str, len, &ds); + str = Tcl_GetStringFromObj(validPathPtr, &len); + if (Tcl_UtfToExternalDStringEx(NULL, NULL, str, len, 0, &ds, NULL) != TCL_OK) { + Tcl_DecrRefCount(validPathPtr); + Tcl_DStringFree(&ds); + return NULL; + } len = Tcl_DStringLength(&ds) + sizeof(char); if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) { /* See bug [3118489]: NUL in filenames */ @@ -1125,7 +1163,7 @@ TclNativeCreateNativeRep( return NULL; } Tcl_DecrRefCount(validPathPtr); - nativePathPtr = (char *)ckalloc(len); + nativePathPtr = (char *)Tcl_Alloc(len); memcpy(nativePathPtr, Tcl_DStringValue(&ds), len); Tcl_DStringFree(&ds); @@ -1149,9 +1187,9 @@ TclNativeCreateNativeRep( *--------------------------------------------------------------------------- */ -ClientData +void * TclNativeDupInternalRep( - ClientData clientData) + void *clientData) { char *copy; size_t len; @@ -1166,7 +1204,7 @@ TclNativeDupInternalRep( len = (strlen((const char*) clientData) + 1) * sizeof(char); - copy = (char *)ckalloc(len); + copy = (char *)Tcl_Alloc(len); memcpy(copy, clientData, len); return copy; } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index ce08425..982c36b 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -92,7 +92,7 @@ typedef struct { */ #ifndef TCL_DEFAULT_ENCODING -#define TCL_DEFAULT_ENCODING "iso8859-1" +#define TCL_DEFAULT_ENCODING "utf-8" #endif /* @@ -455,7 +455,7 @@ TclpInitPlatform(void) void TclpInitLibraryPath( char **valuePtr, - unsigned int *lengthPtr, + size_t *lengthPtr, Tcl_Encoding *encodingPtr) { #define LIBRARY_SIZE 32 @@ -473,12 +473,12 @@ TclpInitLibraryPath( */ str = getenv("TCL_LIBRARY"); /* INTL: Native. */ - Tcl_ExternalToUtfDString(NULL, str, TCL_INDEX_NONE, &buffer); + Tcl_ExternalToUtfDStringEx(NULL, NULL, str, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &buffer, NULL); str = Tcl_DStringValue(&buffer); if ((str != NULL) && (str[0] != '\0')) { Tcl_DString ds; - int pathc; + Tcl_Size pathc; const char **pathv; char installLib[LIBRARY_SIZE]; @@ -512,7 +512,7 @@ TclpInitLibraryPath( str = Tcl_JoinPath(pathc, pathv, &ds); Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_DStringToObj(&ds)); } - ckfree(pathv); + Tcl_Free(pathv); } /* @@ -544,10 +544,17 @@ TclpInitLibraryPath( Tcl_DStringFree(&buffer); *encodingPtr = Tcl_GetEncoding(NULL, NULL); - str = TclGetString(pathPtr); - *lengthPtr = pathPtr->length; - *valuePtr = (char *)ckalloc(*lengthPtr + 1); - memcpy(*valuePtr, str, *lengthPtr + 1); + + /* + * Note lengthPtr is (size_t *) which is unsigned so cannot + * pass directly to Tcl_GetStringFromObj. + * TODO - why is the type size_t anyways? + */ + Tcl_Size length; + str = Tcl_GetStringFromObj(pathPtr, &length); + *lengthPtr = length; + *valuePtr = (char *)Tcl_Alloc(length + 1); + memcpy(*valuePtr, str, length + 1); Tcl_DecrRefCount(pathPtr); } @@ -864,6 +871,18 @@ TclpSetVariables( Tcl_SetVar2(interp, "tcl_pkgPath", NULL, pkgPath, TCL_GLOBAL_ONLY); } + { + /* Some platforms build configure scripts expect ~ expansion so do that */ + Tcl_Obj *origPaths; + Tcl_Obj *resolvedPaths; + origPaths = Tcl_GetVar2Ex(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY); + resolvedPaths = TclResolveTildePathList(origPaths); + if (resolvedPaths != origPaths && resolvedPaths != NULL) { + Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, + resolvedPaths, TCL_GLOBAL_ONLY); + } + } + #ifdef DJGPP Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY); #else @@ -1001,16 +1020,16 @@ TclpSetVariables( *---------------------------------------------------------------------- */ -int +Tcl_Size TclpFindVariable( const char *name, /* Name of desired environment variable * (native). */ - int *lengthPtr) /* Used to return length of name (for + Tcl_Size *lengthPtr) /* Used to return length of name (for * successful searches) or number of non-NULL * entries in environ (for unsuccessful * searches). */ { - int i, result = -1; + Tcl_Size i, result = -1; const char *env, *p1, *p2; Tcl_DString envString; diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index 0a2b695..402e04f 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -27,7 +27,7 @@ static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); # define NOTIFIER_SELECT #elif !defined(NOTIFIER_EPOLL) && !defined(NOTIFIER_KQUEUE) # define NOTIFIER_SELECT -static TCL_NORETURN void NotifierThreadProc(ClientData clientData); +static TCL_NORETURN void NotifierThreadProc(void *clientData); # if defined(HAVE_PTHREAD_ATFORK) static void AtForkChild(void); # endif /* HAVE_PTHREAD_ATFORK */ @@ -497,13 +497,13 @@ AtForkChild(void) *---------------------------------------------------------------------- */ -ClientData +void * TclpNotifierData(void) { #if defined(NOTIFIER_EPOLL) || defined(NOTIFIER_KQUEUE) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - return (ClientData) tsdPtr; + return (void *) tsdPtr; #else return NULL; #endif diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 63e576b..64dd8baf 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -46,7 +46,7 @@ typedef struct { TclFile inFile; /* Output from pipe. */ TclFile outFile; /* Input to pipe. */ TclFile errorFile; /* Error output from pipe. */ - int numPids; /* How many processes are attached to this + size_t numPids; /* How many processes are attached to this * pipe? */ Tcl_Pid *pidPtr; /* The process IDs themselves. Allocated by * the creator of the pipe. */ @@ -80,7 +80,7 @@ static int SetupStdFile(TclFile file, int type); static const Tcl_ChannelType pipeChannelType = { "pipe", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - TCL_CLOSE2PROC, /* Close proc. */ + NULL, /* Close proc. */ PipeInputProc, /* Input proc. */ PipeOutputProc, /* Output proc. */ NULL, /* Seek proc. */ @@ -152,7 +152,11 @@ TclpOpenFile( const char *native; Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fname, TCL_INDEX_NONE, &ds); + if (Tcl_UtfToExternalDStringEx(NULL, NULL, fname, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + Tcl_DStringFree(&ds); + return NULL; + } + native = Tcl_DStringValue(&ds); fd = TclOSopen(native, mode, 0666); /* INTL: Native. */ Tcl_DStringFree(&ds); if (fd != -1) { @@ -209,7 +213,12 @@ TclpCreateTempFile( Tcl_DString dstring; char *native; - native = Tcl_UtfToExternalDString(NULL, contents, TCL_INDEX_NONE, &dstring); + if (Tcl_UtfToExternalDStringEx(NULL, NULL, contents, TCL_INDEX_NONE, 0, &dstring, NULL) != TCL_OK) { + close(fd); + Tcl_DStringFree(&dstring); + return NULL; + } + native = Tcl_DStringValue(&dstring); if (write(fd, native, Tcl_DStringLength(&dstring)) == -1) { close(fd); Tcl_DStringFree(&dstring); @@ -392,7 +401,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - int argc, /* Number of arguments in following array. */ + size_t argc, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings in UTF-8. * argv[0] contains the name of the executable * translated using Tcl_TranslateFileName @@ -422,7 +431,7 @@ TclpCreateProcess( Tcl_DString *dsArray; char **newArgv; int pid; - int i; + size_t i; #if defined(HAVE_POSIX_SPAWNP) int childErrno; static int use_spawn = -1; @@ -452,7 +461,15 @@ TclpCreateProcess( newArgv = (char **)TclStackAlloc(interp, (argc+1) * sizeof(char *)); newArgv[argc] = NULL; for (i = 0; i < argc; i++) { - newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], TCL_INDEX_NONE, &dsArray[i]); + if (Tcl_UtfToExternalDStringEx(interp, NULL, argv[i], TCL_INDEX_NONE, 0, &dsArray[i], NULL) != TCL_OK) { + while (i-- > 0) { + Tcl_DStringFree(&dsArray[i]); + } + TclStackFree(interp, newArgv); + TclStackFree(interp, dsArray); + goto error; + } + newArgv[i] = Tcl_DStringValue(&dsArray[i]); } #if defined(HAVE_VFORK) || defined(HAVE_POSIX_SPAWNP) @@ -621,7 +638,7 @@ TclpCreateProcess( } TclpCloseFile(errPipeIn); - *pidPtr = (Tcl_Pid) INT2PTR(pid); + *pidPtr = (Tcl_Pid)INT2PTR(pid); return TCL_OK; error: @@ -821,7 +838,7 @@ TclpCreateCommandChannel( TclFile writeFile, /* If non-null, gives the file for writing. */ TclFile errorFile, /* If non-null, gives the file where errors * can be read. */ - int numPids, /* The number of pids in the pid array. */ + size_t numPids, /* The number of pids in the pid array. */ Tcl_Pid *pidPtr) /* An array of process identifiers. Allocated * by the caller, freed when the channel is * closed or the processes are detached (in a @@ -829,7 +846,7 @@ TclpCreateCommandChannel( { char channelName[16 + TCL_INTEGER_SPACE]; int channelId; - PipeState *statePtr = (PipeState *)ckalloc(sizeof(PipeState)); + PipeState *statePtr = (PipeState *)Tcl_Alloc(sizeof(PipeState)); int mode; statePtr->inFile = readFile; @@ -943,7 +960,7 @@ TclGetAndDetachPids( PipeState *pipePtr; const Tcl_ChannelType *chanTypePtr; Tcl_Obj *pidsObj; - int i; + size_t i; /* * Punt if the channel is not a command channel. @@ -963,7 +980,7 @@ TclGetAndDetachPids( } Tcl_SetObjResult(interp, pidsObj); if (pipePtr->numPids > 0) { - ckfree(pipePtr->pidPtr); + Tcl_Free(pipePtr->pidPtr); pipePtr->numPids = 0; } } @@ -1085,6 +1102,8 @@ PipeClose2Proc( errChan = Tcl_MakeFileChannel( INT2PTR(GetFd(pipePtr->errorFile)), TCL_READABLE); + /* Error channels should not raise encoding errors */ + Tcl_SetChannelOption(NULL, errChan, "-profile", "replace"); } else { errChan = NULL; } @@ -1093,9 +1112,9 @@ PipeClose2Proc( } if (pipePtr->numPids != 0) { - ckfree(pipePtr->pidPtr); + Tcl_Free(pipePtr->pidPtr); } - ckfree(pipePtr); + Tcl_Free(pipePtr); if (errorCode == 0) { return result; } @@ -1325,7 +1344,7 @@ Tcl_WaitPid( while (1) { result = (int) waitpid(real_pid, statPtr, options); if ((result != -1) || (errno != EINTR)) { - return (Tcl_Pid) INT2PTR(result); + return (Tcl_Pid)INT2PTR(result); } } } @@ -1349,14 +1368,14 @@ Tcl_WaitPid( int Tcl_PidObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ { Tcl_Channel chan; PipeState *pipePtr; - int i; + size_t i; Tcl_Obj *resultPtr; if (objc > 2) { @@ -1371,7 +1390,7 @@ Tcl_PidObjCmd( * Get the channel and make sure that it refers to a pipe. */ - chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); + chan = Tcl_GetChannel(interp, TclGetString(objv[1]), NULL); if (chan == NULL) { return TCL_ERROR; } @@ -1387,7 +1406,7 @@ Tcl_PidObjCmd( TclNewObj(resultPtr); for (i = 0; i < pipePtr->numPids; i++) { Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewWideIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i])))); + Tcl_NewWideIntObj(TclpGetPid(pipePtr->pidPtr[i]))); } Tcl_SetObjResult(interp, resultPtr); } diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index f9fd702..cdc67d2 100644 --- a/unix/tclUnixPort.h +++ b/unix/tclUnixPort.h @@ -82,11 +82,8 @@ typedef off_t Tcl_SeekOffset; extern "C" { #endif /* Make some symbols available without including <windows.h> */ -# define DWORD unsigned int # define CP_UTF8 65001 # define GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS 0x00000004 -# define HANDLE void * -# define HINSTANCE void * # define HMODULE void * # define MAX_PATH 260 # define SOCKET unsigned int @@ -118,10 +115,6 @@ extern "C" { #ifdef __cplusplus } #endif -#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) -# define TclOSfstat(fd, buf) fstat64(fd, (struct stat64 *)buf) -# define TclOSstat(name, buf) stat64(name, (struct stat64 *)buf) -# define TclOSlstat(name,buf) lstat64(name, (struct stat64 *)buf) #else # define TclOSfstat(fd, buf) fstat(fd, (struct stat *)buf) # define TclOSstat(name, buf) stat(name, (struct stat *)buf) @@ -655,9 +648,9 @@ typedef int socklen_t; *--------------------------------------------------------------------------- */ -#define TclpSysAlloc(size, isBin) malloc((size_t)(size)) -#define TclpSysFree(ptr) free((char *)(ptr)) -#define TclpSysRealloc(ptr, size) realloc((char *)(ptr), (size_t)(size)) +#define TclpSysAlloc(size) malloc(size) +#define TclpSysFree(ptr) free(ptr) +#define TclpSysRealloc(ptr, size) realloc(ptr, size) /* *--------------------------------------------------------------------------- diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index d6e5386..36ed409 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -156,11 +156,7 @@ static Tcl_FileProc WrapNotify; static const Tcl_ChannelType tcpChannelType = { "tcp", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ -#ifndef TCL_NO_DEPRECATED - TcpCloseProc, /* Close proc. */ -#else - TCL_CLOSE2PROC, /* Close proc. */ -#endif + NULL, /* Close proc. */ TcpInputProc, /* Input proc. */ TcpOutputProc, /* Output proc. */ NULL, /* Seek proc. */ @@ -220,7 +216,7 @@ printaddrinfo( static void InitializeHostName( char **valuePtr, - unsigned int *lengthPtr, + size_t *lengthPtr, Tcl_Encoding *encodingPtr) { const char *native = NULL; @@ -242,12 +238,12 @@ InitializeHostName( char *dot = strchr(u.nodename, '.'); if (dot != NULL) { - char *node = (char *)ckalloc(dot - u.nodename + 1); + char *node = (char *)Tcl_Alloc(dot - u.nodename + 1); memcpy(node, u.nodename, dot - u.nodename); node[dot - u.nodename] = '\0'; hp = TclpGetHostByName(node); - ckfree(node); + Tcl_Free(node); } } if (hp != NULL) { @@ -286,11 +282,11 @@ InitializeHostName( *encodingPtr = Tcl_GetEncoding(NULL, NULL); if (native) { *lengthPtr = strlen(native); - *valuePtr = (char *)ckalloc(*lengthPtr + 1); + *valuePtr = (char *)Tcl_Alloc(*lengthPtr + 1); memcpy(*valuePtr, native, *lengthPtr + 1); } else { *lengthPtr = 0; - *valuePtr = (char *)ckalloc(1); + *valuePtr = (char *)Tcl_Alloc(1); *valuePtr[0] = '\0'; } } @@ -316,7 +312,8 @@ InitializeHostName( const char * Tcl_GetHostName(void) { - return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); + Tcl_Obj *tclObj = TclGetProcessGlobalValue(&hostName); + return TclGetString(tclObj); } /* @@ -626,7 +623,7 @@ TcpCloseProc( while (fds != NULL) { TcpFdList *next = fds->next; - ckfree(fds); + Tcl_Free(fds); fds = next; } if (statePtr->addrlist != NULL) { @@ -635,7 +632,7 @@ TcpCloseProc( if (statePtr->myaddrlist != NULL) { freeaddrinfo(statePtr->myaddrlist); } - ckfree(statePtr); + Tcl_Free(statePtr); return errorCode; } @@ -1531,7 +1528,7 @@ Tcl_OpenTcpClient( * Allocate a new TcpState for this socket. */ - statePtr = (TcpState *)ckalloc(sizeof(TcpState)); + statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); statePtr->flags = async ? TCP_ASYNC_CONNECT : 0; statePtr->cachedBlocking = TCL_MODE_BLOCKING; @@ -1554,7 +1551,7 @@ Tcl_OpenTcpClient( statePtr, TCL_READABLE | TCL_WRITABLE); if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation", "auto crlf") == TCL_ERROR) { - Tcl_Close(NULL, statePtr->channel); + Tcl_CloseEx(NULL, statePtr->channel, 0); return NULL; } return statePtr->channel; @@ -1610,7 +1607,7 @@ TclpMakeTcpClientChannelMode( TcpState *statePtr; char channelName[SOCK_CHAN_LENGTH]; - statePtr = (TcpState *)ckalloc(sizeof(TcpState)); + statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); statePtr->fds.fd = PTR2INT(sock); statePtr->flags = 0; @@ -1621,7 +1618,7 @@ TclpMakeTcpClientChannelMode( statePtr, mode); if (Tcl_SetChannelOption(NULL, statePtr->channel, "-translation", "auto crlf") == TCL_ERROR) { - Tcl_Close(NULL, statePtr->channel); + Tcl_CloseEx(NULL, statePtr->channel, 0); return NULL; } return statePtr->channel; @@ -1837,14 +1834,14 @@ Tcl_OpenTcpServerEx( * Allocate a new TcpState for this socket. */ - statePtr = (TcpState *)ckalloc(sizeof(TcpState)); + statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); statePtr->acceptProc = acceptProc; statePtr->acceptProcData = acceptProcData; snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr)); newfds = &statePtr->fds; } else { - newfds = (TcpFdList *)ckalloc(sizeof(TcpFdList)); + newfds = (TcpFdList *)Tcl_Alloc(sizeof(TcpFdList)); memset(newfds, (int) 0, sizeof(TcpFdList)); fds->next = newfds; } @@ -1928,7 +1925,7 @@ TcpAccept( (void) fcntl(newsock, F_SETFD, FD_CLOEXEC); - newSockState = (TcpState *)ckalloc(sizeof(TcpState)); + newSockState = (TcpState *)Tcl_Alloc(sizeof(TcpState)); memset(newSockState, 0, sizeof(TcpState)); newSockState->flags = 0; newSockState->fds.fd = newsock; diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 4f052a8..133cdf6 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -10,6 +10,8 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#undef BUILD_tcl +#undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif @@ -129,7 +131,7 @@ TclplatformtestInit( static int TestfilehandlerCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -310,7 +312,7 @@ TestfilehandlerCmd( static void TestFileHandlerProc( - ClientData clientData, /* Points to a Pipe structure. */ + void *clientData, /* Points to a Pipe structure. */ int mask) /* Indicates which events happened: * TCL_READABLE or TCL_WRITABLE. */ { @@ -343,7 +345,7 @@ TestFileHandlerProc( static int TestfilewaitCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -351,7 +353,7 @@ TestfilewaitCmd( int mask, result, timeout; Tcl_Channel channel; int fd; - ClientData data; + void *data; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "file readable|writable|both timeout"); @@ -374,7 +376,7 @@ TestfilewaitCmd( } if (Tcl_GetChannelHandle(channel, (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE, - (ClientData*) &data) != TCL_OK) { + (void **) &data) != TCL_OK) { Tcl_AppendResult(interp, "couldn't get channel file", (void *)NULL); return TCL_ERROR; } @@ -411,7 +413,7 @@ TestfilewaitCmd( static int TestfindexecutableCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -453,7 +455,7 @@ TestfindexecutableCmd( static int TestforkCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -499,7 +501,7 @@ TestforkCmd( static int TestalarmCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -577,7 +579,7 @@ AlarmHandler( static int TestgotsigCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(int) /*objc*/, TCL_UNUSED(Tcl_Obj *const *)) @@ -608,7 +610,7 @@ TestgotsigCmd( static int TestchmodCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index c67495e..71e451f 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -160,14 +160,6 @@ PCondTimedWait( } #endif /* HAVE_PTHREAD_MUTEX_RECURSIVE */ -#ifndef TCL_NO_DEPRECATED -typedef struct { - char nabuf[16]; -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; -#endif /* TCL_NO_DEPRECATED */ - /* * globalLock is used to serialize creation of mutexes, condition variables, * and thread local storage. This is the only place that can count on the @@ -221,8 +213,8 @@ int TclpThreadCreate( Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */ - ClientData clientData, /* The one argument to Main() */ - TCL_HASH_TYPE stackSize, /* Size of stack for the new thread */ + void *clientData, /* The one argument to Main() */ + size_t stackSize, /* Size of stack for the new thread */ int flags) /* Flags controlling behaviour of the new * thread. */ { @@ -236,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 { /* @@ -585,7 +577,7 @@ Tcl_MutexLock( * Double inside global lock check to avoid a race condition. */ - pmutexPtr = (PMutex *)ckalloc(sizeof(PMutex)); + pmutexPtr = (PMutex *)Tcl_Alloc(sizeof(PMutex)); PMutexInit(pmutexPtr); *mutexPtr = (Tcl_Mutex) pmutexPtr; TclRememberMutex(mutexPtr); @@ -649,7 +641,7 @@ TclpFinalizeMutex( if (pmutexPtr != NULL) { PMutexDestroy(pmutexPtr); - ckfree(pmutexPtr); + Tcl_Free(pmutexPtr); *mutexPtr = NULL; } } @@ -695,7 +687,7 @@ Tcl_ConditionWait( */ if (*condPtr == NULL) { - pcondPtr = (pthread_cond_t *)ckalloc(sizeof(pthread_cond_t)); + pcondPtr = (pthread_cond_t *)Tcl_Alloc(sizeof(pthread_cond_t)); pthread_cond_init(pcondPtr, NULL); *condPtr = (Tcl_Condition) pcondPtr; TclRememberCondition(condPtr); @@ -783,59 +775,11 @@ TclpFinalizeCondition( if (pcondPtr != NULL) { pthread_cond_destroy(pcondPtr); - ckfree(pcondPtr); + Tcl_Free(pcondPtr); *condPtr = NULL; } } -#endif /* TCL_THREADS */ - -/* - *---------------------------------------------------------------------- - * - * TclpReaddir, TclpInetNtoa -- - * - * These procedures replace core C versions to be used in a threaded - * environment. - * - * Results: - * See documentation of C functions. - * - * Side effects: - * See documentation of C functions. - * - * Notes: - * TclpReaddir is no longer used by the core (see 1095909), but it - * appears in the internal stubs table (see #589526). - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -Tcl_DirEntry * -TclpReaddir( - TclDIR * dir) -{ - return TclOSreaddir(dir); -} - -#undef TclpInetNtoa -char * -TclpInetNtoa( - struct in_addr addr) -{ -#if TCL_THREADS - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - unsigned char *b = (unsigned char*) &addr.s_addr; - - snprintf(tsdPtr->nabuf, sizeof(tsdPtr->nabuf), "%u.%u.%u.%u", b[0], b[1], b[2], b[3]); - return tsdPtr->nabuf; -#else - return inet_ntoa(addr); -#endif -} -#endif /* TCL_NO_DEPRECATED */ -#if TCL_THREADS /* * Additions by AOL for specialized thread memory allocator. */ @@ -925,7 +869,7 @@ TclpThreadCreateKey(void) { pthread_key_t *ptkeyPtr; - ptkeyPtr = (pthread_key_t *)TclpSysAlloc(sizeof(pthread_key_t), 0); + ptkeyPtr = (pthread_key_t *)TclpSysAlloc(sizeof(pthread_key_t)); if (NULL == ptkeyPtr) { Tcl_Panic("unable to allocate thread key!"); } diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index f242cf4..20b9a67 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -16,41 +16,13 @@ #endif /* - * TclpGetDate is coded to return a pointer to a 'struct tm'. For thread - * safety, this structure must be in thread-specific data. The 'tmKey' - * variable is the key to this buffer. - */ - -#ifndef TCL_NO_DEPRECATED -static Tcl_ThreadDataKey tmKey; -typedef struct { - struct tm gmtime_buf; - struct tm localtime_buf; -} ThreadSpecificData; - -/* - * If we fall back on the thread-unsafe versions of gmtime and localtime, use - * this mutex to try to protect them. - */ - -TCL_DECLARE_MUTEX(tmMutex) - -static char *lastTZ = NULL; /* Holds the last setting of the TZ - * environment variable, or an empty string if - * the variable was not set. */ - -/* * Static functions declared in this file. */ -static void SetTZIfNecessary(void); -static void CleanupMemory(ClientData clientData); -#endif /* TCL_NO_DEPRECATED */ - static void NativeScaleTime(Tcl_Time *timebuf, - ClientData clientData); + void *clientData); static void NativeGetTime(Tcl_Time *timebuf, - ClientData clientData); + void *clientData); /* * TIP #233 (Virtualized Time): Data for the time hooks, if any. @@ -94,10 +66,10 @@ IsTimeNative(void) *---------------------------------------------------------------------- */ -unsigned long +unsigned long long TclpGetSeconds(void) { - return time(NULL); + return (unsigned long long) time(NULL); } /* @@ -123,7 +95,7 @@ TclpGetMicroseconds(void) Tcl_Time time; GetTime(&time); - return ((long long) time.sec)*1000000 + time.usec; + return time.sec * 1000000 + time.usec; } /* @@ -145,30 +117,32 @@ TclpGetMicroseconds(void) *---------------------------------------------------------------------- */ -unsigned long +unsigned long long TclpGetClicks(void) { - unsigned long now; + unsigned long long now; #ifdef NO_GETTOD if (!IsTimeNative()) { Tcl_Time time; GetTime(&time); - now = ((unsigned long)(time.sec)*1000000UL) + (unsigned long)(time.usec); + now = ((unsigned long long)(time.sec)*1000000ULL) + + (unsigned long long)(time.usec); } else { /* * A semi-NativeGetTime, specialized to clicks. */ struct tms dummy; - now = (unsigned long) times(&dummy); + now = (unsigned long long) times(&dummy); } #else /* !NO_GETTOD */ Tcl_Time time; GetTime(&time); - now = ((unsigned long)(time.sec)*1000000UL) + (unsigned long)(time.usec); + now = ((unsigned long long)(time.sec)*1000000ULL) + + (unsigned long long)(time.usec); #endif /* NO_GETTOD */ return now; @@ -290,17 +264,15 @@ TclpWideClickInMicrosec(void) static int initialized = 0; static double scale = 0.0; - if (initialized) { - return scale; - } else { + if (!initialized) { mach_timebase_info_data_t tb; mach_timebase_info(&tb); /* value of tb.numer / tb.denom = 1 click in nanoseconds */ - scale = ((double)tb.numer) / tb.denom / 1000; + scale = ((double) tb.numer) / tb.denom / 1000; initialized = 1; - return scale; } + return scale; #else #error Wide high-resolution clicks not implemented on this platform #endif /* MAC_OSX_TCL */ @@ -338,116 +310,6 @@ Tcl_GetTime( /* *---------------------------------------------------------------------- * - * TclpGetDate -- - * - * This function converts between seconds and struct tm. If useGMT is - * true, then the returned date will be in Greenwich Mean Time (GMT). - * Otherwise, it will be in the local time zone. - * - * Results: - * Returns a static tm structure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -struct tm * -TclpGetDate( - const time_t *time, - int useGMT) -{ - if (useGMT) { - return TclpGmtime(time); - } else { - return TclpLocaltime(time); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpGmtime -- - * - * Wrapper around the 'gmtime' library function to make it thread safe. - * - * Results: - * Returns a pointer to a 'struct tm' in thread-specific data. - * - * Side effects: - * Invokes gmtime or gmtime_r as appropriate. - * - *---------------------------------------------------------------------- - */ - -struct tm * -TclpGmtime( - const time_t *timePtr) /* Pointer to the number of seconds since the - * local system's epoch */ -{ - /* - * Get a thread-local buffer to hold the returned time. - */ - - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey); - -#ifdef HAVE_GMTIME_R - gmtime_r(timePtr, &tsdPtr->gmtime_buf); -#else - Tcl_MutexLock(&tmMutex); - memcpy(&tsdPtr->gmtime_buf, gmtime(timePtr), sizeof(struct tm)); - Tcl_MutexUnlock(&tmMutex); -#endif - - return &tsdPtr->gmtime_buf; -} - -/* - *---------------------------------------------------------------------- - * - * TclpLocaltime -- - * - * Wrapper around the 'localtime' library function to make it thread - * safe. - * - * Results: - * Returns a pointer to a 'struct tm' in thread-specific data. - * - * Side effects: - * Invokes localtime or localtime_r as appropriate. - * - *---------------------------------------------------------------------- - */ - -struct tm * -TclpLocaltime( - const time_t *timePtr) /* Pointer to the number of seconds since the - * local system's epoch */ -{ - /* - * Get a thread-local buffer to hold the returned time. - */ - - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey); - - SetTZIfNecessary(); -#ifdef HAVE_LOCALTIME_R - localtime_r(timePtr, &tsdPtr->localtime_buf); -#else - Tcl_MutexLock(&tmMutex); - memcpy(&tsdPtr->localtime_buf, localtime(timePtr), sizeof(struct tm)); - Tcl_MutexUnlock(&tmMutex); -#endif - - return &tsdPtr->localtime_buf; -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_SetTimeProc -- * * TIP #233 (Virtualized Time): Registers two handlers for the @@ -466,7 +328,7 @@ void Tcl_SetTimeProc( Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, - ClientData clientData) + void *clientData) { tclGetTimeProcPtr = getProc; tclScaleTimeProcPtr = scaleProc; @@ -493,7 +355,7 @@ void Tcl_QueryTimeProc( Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, - ClientData *clientData) + void **clientData) { if (getProc) { *getProc = tclGetTimeProcPtr; @@ -526,7 +388,7 @@ Tcl_QueryTimeProc( static void NativeScaleTime( TCL_UNUSED(Tcl_Time *), - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { /* Native scale is 1:1. Nothing is done */ } @@ -551,7 +413,7 @@ NativeScaleTime( static void NativeGetTime( Tcl_Time *timePtr, - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { struct timeval tv; @@ -559,72 +421,6 @@ NativeGetTime( timePtr->sec = tv.tv_sec; timePtr->usec = tv.tv_usec; } -/* - *---------------------------------------------------------------------- - * - * SetTZIfNecessary -- - * - * Determines whether a call to 'tzset' is needed prior to the next call - * to 'localtime' or examination of the 'timezone' variable. - * - * Results: - * None. - * - * Side effects: - * If 'tzset' has never been called in the current process, or if the - * value of the environment variable TZ has changed since the last call - * to 'tzset', then 'tzset' is called again. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -static void -SetTZIfNecessary(void) -{ - const char *newTZ = getenv("TZ"); - - Tcl_MutexLock(&tmMutex); - if (newTZ == NULL) { - newTZ = ""; - } - if (lastTZ == NULL || strcmp(lastTZ, newTZ)) { - tzset(); - if (lastTZ == NULL) { - Tcl_CreateExitHandler(CleanupMemory, NULL); - } else { - ckfree(lastTZ); - } - lastTZ = (char *) ckalloc(strlen(newTZ) + 1); - strcpy(lastTZ, newTZ); - } - Tcl_MutexUnlock(&tmMutex); -} - -/* - *---------------------------------------------------------------------- - * - * CleanupMemory -- - * - * Releases the private copy of the TZ environment variable upon exit - * from Tcl. - * - * Results: - * None. - * - * Side effects: - * Frees allocated memory. - * - *---------------------------------------------------------------------- - */ - -static void -CleanupMemory( - TCL_UNUSED(ClientData)) -{ - ckfree(lastTZ); -} -#endif /* TCL_NO_DEPRECATED */ /* * Local Variables: diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c index 4388009..aa88760 100644 --- a/unix/tclXtNotify.c +++ b/unix/tclXtNotify.c @@ -33,7 +33,7 @@ typedef struct FileHandler { XtInputId except; /* Xt exception callback handle. */ Tcl_FileProc *proc; /* Procedure to call, in the style of * Tcl_CreateFileHandler. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; @@ -79,10 +79,10 @@ static int initialized = 0; static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); static void FileProc(XtPointer clientData, int *source, XtInputId *id); -static void NotifierExitHandler(ClientData clientData); +static void NotifierExitHandler(void *clientData); static void TimerProc(XtPointer clientData, XtIntervalId *id); static void CreateFileHandler(int fd, int mask, - Tcl_FileProc *proc, ClientData clientData); + Tcl_FileProc *proc, void *clientData); static void DeleteFileHandler(int fd); static void SetTimer(const Tcl_Time * timePtr); static int WaitForEvent(const Tcl_Time * timePtr); @@ -229,7 +229,7 @@ InitNotifier(void) static void NotifierExitHandler( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { if (notifier.currentTimeout != 0) { XtRemoveTimeOut(notifier.currentTimeout); @@ -265,7 +265,7 @@ static void SetTimer( const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ { - long timeout; + unsigned long timeout; if (!initialized) { InitNotifier(); @@ -278,7 +278,7 @@ SetTimer( if (timePtr) { timeout = timePtr->sec * 1000 + timePtr->usec / 1000; notifier.currentTimeout = XtAppAddTimeOut(notifier.appContext, - (unsigned long) timeout, TimerProc, NULL); + timeout, TimerProc, NULL); } else { notifier.currentTimeout = 0; } @@ -339,7 +339,7 @@ CreateFileHandler( * called. */ Tcl_FileProc *proc, /* Procedure to call for each selected * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { FileHandler *filePtr; @@ -356,7 +356,7 @@ CreateFileHandler( } } if (filePtr == NULL) { - filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->read = 0; filePtr->write = 0; @@ -467,7 +467,7 @@ DeleteFileHandler( if (filePtr->mask & TCL_EXCEPTION) { XtRemoveInput(filePtr->except); } - ckfree(filePtr); + Tcl_Free(filePtr); } /* @@ -522,7 +522,7 @@ FileProc( */ filePtr->readyMask |= mask; - fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent)); + fileEvPtr = (FileHandlerEvent *) Tcl_Alloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c index e660c69..09f454c 100644 --- a/unix/tclXtTest.c +++ b/unix/tclXtTest.c @@ -77,7 +77,7 @@ Tclxttest_Init( static int TesteventloopCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ diff --git a/win/Makefile.in b/win/Makefile.in index 0250911..877c4f3 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -50,7 +50,7 @@ LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Path name to use when installing Tcl modules. -MODULE_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)/../tcl8 +MODULE_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)/../tcl9 # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) @@ -145,9 +145,11 @@ TCL_VFS_ROOT = libtcl.vfs TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ TCL_DLL_FILE = @TCL_DLL_FILE@ TCL_LIB_FILE = @TCL_LIB_FILE@ -DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX} +DDE_DLL_FILE = tcl9dde$(DDEVER)${DLLSUFFIX} +DDE_DLL_FILE8 = tcldde$(DDEVER)${DLLSUFFIX} DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${DLLSUFFIX}${LIBSUFFIX} -REG_DLL_FILE = tclregistry$(REGVER)${DLLSUFFIX} +REG_DLL_FILE = tcl9registry$(REGVER)${DLLSUFFIX} +REG_DLL_FILE8 = tclregistry$(REGVER)${DLLSUFFIX} REG_LIB_FILE = @LIBPREFIX@tclregistry$(REGVER)${DLLSUFFIX}${LIBSUFFIX} TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX} TEST_EXE_FILE = tcltest${EXESUFFIX} @@ -271,6 +273,7 @@ ${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} TCLTEST_OBJS = \ tclTest.$(OBJEXT) \ + tclTestABSList.$(OBJEXT) \ tclTestObj.$(OBJEXT) \ tclTestProcBodyObj.$(OBJEXT) \ tclThreadTest.$(OBJEXT) \ @@ -461,6 +464,8 @@ REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ + tclStubCall.$(OBJEXT) \ + tclStubLibTbl.$(OBJEXT) \ tclTomMathStubLib.$(OBJEXT) \ tclOOStubLib.$(OBJEXT) \ tclWinPanic.$(OBJEXT) @@ -519,7 +524,7 @@ tcltest: binaries $(TEST_EXE_FILE) $(TEST_DLL_FILE) $(CAT32) tcltest.cmd binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions ${TCL_ZIP_FILE} $(TCLSH) -winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE} +winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE} ${DDE_DLL_FILE8} ${REG_DLL_FILE8} libraries: @@ -593,6 +598,14 @@ ${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS} @MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) $(COPY) tclsh.exe.manifest ${REG_DLL_FILE}.manifest +${DDE_DLL_FILE8}: ${TCL_STUB_LIB_FILE} tcl8WinDde.$(OBJEXT) + @MAKE_DLL@ tcl8WinDde.$(OBJEXT) $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + $(COPY) tclsh.exe.manifest ${DDE_DLL_FILE8}.manifest + +${REG_DLL_FILE8}: ${TCL_STUB_LIB_FILE} tcl8WinReg.$(OBJEXT) + @MAKE_DLL@ -DTCL_MAJOR_VERSION=8 tcl8WinReg.$(OBJEXT) $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + $(COPY) tclsh.exe.manifest ${REG_DLL_FILE8}.manifest + ${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} @$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE} @MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) @@ -649,9 +662,15 @@ tclWinPipe.${OBJEXT}: tclWinPipe.c tclWinReg.${OBJEXT}: tclWinReg.c $(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) +tcl8WinReg.${OBJEXT}: tclWinReg.c + $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + tclWinDde.${OBJEXT}: tclWinDde.c $(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) +tcl8WinDde.${OBJEXT}: tclWinDde.c + $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + tclAppInit.${OBJEXT}: tclAppInit.c $(CC) -c $(CC_SWITCHES) $(EXTFLAGS) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME) @@ -711,6 +730,15 @@ tclUuid.h: $(TOP_DIR)/manifest.uuid tclStubLib.${OBJEXT}: tclStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @CFLAGS_NOLTO@ @DEPARG@ $(CC_OBJNAME) +tclStubCall.${OBJEXT}: tclStubCall.c + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD \ + -DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \ + -DCFG_RUNTIME_BINDIR="\"$(bindir_native)\"" \ + @DEPARG@ $(CC_OBJNAME) + +tclStubLibTbl.${OBJEXT}: tclStubLibTbl.c + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) + tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c $(CC) -c $(CC_SWITCHES) @CFLAGS_NOLTO@ @DEPARG@ $(CC_OBJNAME) @@ -841,6 +869,10 @@ install-binaries: binaries $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \ fi + @if [ -f $(DDE_DLL_FILE8) ]; then \ + echo Installing $(DDE_DLL_FILE8); \ + $(COPY) $(DDE_DLL_FILE8) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \ + fi @if [ -f $(DDE_LIB_FILE) ]; then \ echo Installing $(DDE_LIB_FILE); \ $(COPY) $(DDE_LIB_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \ @@ -851,6 +883,10 @@ install-binaries: binaries $(COPY) $(ROOT_DIR)/library/registry/pkgIndex.tcl \ "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \ fi + @if [ -f $(REG_DLL_FILE8) ]; then \ + echo Installing $(REG_DLL_FILE8); \ + $(COPY) $(REG_DLL_FILE8) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \ + fi @if [ -f $(REG_LIB_FILE) ]; then \ echo Installing $(REG_LIB_FILE); \ $(COPY) $(REG_LIB_FILE) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \ @@ -874,7 +910,7 @@ install-libraries: libraries install-tzdata install-msgs else true; \ fi; \ done; - @for i in 8.4 8.4/platform 8.5 8.6 8.7; \ + @for i in 9.0 9.0/platform; \ do \ if [ ! -d "$(MODULE_INSTALL_DIR)/$$i" ] ; then \ echo "Making directory $(MODULE_INSTALL_DIR)/$$i"; \ @@ -892,19 +928,19 @@ install-libraries: libraries install-tzdata install-msgs $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done; @echo "Installing package http 2.10b1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10b1.tm"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/9.0/http-2.10b1.tm"; @echo "Installing package opt 0.4.7"; @for j in $(ROOT_DIR)/library/opt/*.tcl; do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.7.1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/8.7/msgcat-1.7.1.tm"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/9.0/msgcat-1.7.1.tm"; @echo "Installing package tcltest 2.5.6 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.6.tm"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/9.0/tcltest-2.5.6.tm"; @echo "Installing package platform 1.0.19 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.19.tm"; + @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/9.0/platform-1.0.19.tm"; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/8.4/platform/shell-1.1.4.tm"; + @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/9.0/platform/shell-1.1.4.tm"; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ @@ -1110,7 +1146,7 @@ genstubs: # # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool -# workspace. It depends on the Tcl & Tk being in directories called tcl8.* & +# workspace. It depends on the Tcl & Tk being in directories called tcl9.* & # tk8.* up two directories from the TOOL_DIR. # @@ -1,4 +1,4 @@ -Tcl 8.7 for Windows +Tcl 9.0 for Windows 1. Introduction --------------- @@ -16,7 +16,7 @@ The information in this file is maintained on the web at: In order to compile Tcl for Windows, you need the following: - Tcl 8.7 Source Distribution (plus any patches) + Tcl 9.0 Source Distribution (plus any patches) and @@ -80,9 +80,9 @@ Use the Makefile "install" target to install Tcl. It will install it according to the prefix options you provided in the correct directory structure. -Note that in order to run tclsh87.exe, you must ensure that tcl87.dll, +Note that in order to run tclsh90.exe, you must ensure that tcl90.dll, libtommath.dll and zlib1.dll are on your path, in the system -directory, or in the directory containing tclsh87.exe. +directory, or in the directory containing tclsh90.exe. Note: Tcl no longer provides support for systems earlier than Windows 7. You will also need the Windows Universal C runtime (UCRT): diff --git a/win/configure b/win/configure index 75a3c38..e689ad4 100755 --- a/win/configure +++ b/win/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.72 for tcl 8.7. +# Generated by GNU Autoconf 2.72 for tcl 9.0. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation, @@ -601,8 +601,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' -PACKAGE_VERSION='8.7' -PACKAGE_STRING='tcl 8.7' +PACKAGE_VERSION='9.0' +PACKAGE_STRING='tcl 9.0' PACKAGE_BUGREPORT='' PACKAGE_URL='' @@ -654,10 +654,6 @@ TCL_DDE_MINOR_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_VERSION TCL_PACKAGE_PATH -TCL_EXP_FILE -TCL_BUILD_EXP_FILE -TCL_LD_SEARCH_FLAGS -TCL_CC_SEARCH_FLAGS TCL_BUILD_LIB_SPEC MAKE_EXE MAKE_DLL @@ -799,7 +795,6 @@ ac_user_opts=' enable_option_checking with_encoding enable_shared -enable_time64bit enable_64bit enable_zipfs enable_symbols @@ -1362,7 +1357,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -'configure' configures tcl 8.7 to adapt to many kinds of systems. +'configure' configures tcl 9.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1424,7 +1419,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of tcl 8.7:";; + short | recursive ) echo "Configuration of tcl 9.0:";; esac cat <<\_ACEOF @@ -1433,7 +1428,6 @@ Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-shared build and link with shared libraries (default: on) - --enable-time64bit force 64-bit time_t for 32-bit build (default: off) --enable-64bit enable 64bit support (where applicable) --enable-zipfs build with Zipfs support (default: on) --enable-symbols build with debugging symbols (default: off) @@ -1522,7 +1516,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -tcl configure 8.7 +tcl configure 9.0 generated by GNU Autoconf 2.72 Copyright (C) 2023 Free Software Foundation, Inc. @@ -1732,7 +1726,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by tcl $as_me 8.7, which was +It was created by tcl $as_me 9.0, which was generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw @@ -2414,10 +2408,10 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=8.7 -TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=7 -TCL_PATCH_LEVEL="a6" +TCL_VERSION=9.0 +TCL_MAJOR_VERSION=9 +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL="b1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 @@ -3945,27 +3939,6 @@ printf "%s\n" "#define STATIC_BUILD 1" >>confdefs.h #-------------------------------------------------------------------- -# Check whether --enable-time64bit was given. -#-------------------------------------------------------------------- - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking force of 64-bit time_t" >&5 -printf %s "checking force of 64-bit time_t... " >&6; } -# Check whether --enable-time64bit was given. -if test ${enable_time64bit+y} -then : - enableval=$enable_time64bit; tcl_ok=$enableval -else case e in #( - e) tcl_ok=no ;; -esac -fi - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: \"$tcl_ok\"" >&5 -printf "%s\n" "\"$tcl_ok\"" >&6; } -if test "$tcl_ok" = "yes"; then - CFLAGS="${CFLAGS} -D_USE_64BIT_TIME_T" -fi - -#-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called # after SC_ENABLE_SHARED checks the configure switches. @@ -5885,8 +5858,8 @@ eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" -eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\"" -eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\"" +eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${LIBSUFFIX}\"" +eval "TCL_STUB_LIB_FLAG=\"-ltclstub${LIBFLAGSUFFIX}\"" eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\"" eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\"" eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\"" @@ -6014,12 +5987,6 @@ TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d -# empty on win, but needs sub'ing - - - - - @@ -6577,7 +6544,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by tcl $as_me 8.7, which was +This file was extended by tcl $as_me 9.0, which was generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -6632,7 +6599,7 @@ ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -tcl config.status 8.7 +tcl config.status 9.0 configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" diff --git a/win/configure.ac b/win/configure.ac index 8391161..8eb748e 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -3,7 +3,7 @@ # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. -AC_INIT([tcl],[8.7]) +AC_INIT([tcl],[9.0]) AC_CONFIG_SRCDIR([../generic/tcl.h]) AC_PREREQ([2.69]) @@ -12,10 +12,10 @@ AC_PREREQ([2.69]) # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=8.7 -TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=7 -TCL_PATCH_LEVEL="a6" +TCL_VERSION=9.0 +TCL_MAJOR_VERSION=9 +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL="b1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 @@ -92,20 +92,6 @@ SC_TCL_CFG_ENCODING SC_ENABLE_SHARED #-------------------------------------------------------------------- -# Check whether --enable-time64bit was given. -#-------------------------------------------------------------------- - -AC_MSG_CHECKING([force of 64-bit time_t]) -AC_ARG_ENABLE(time64bit, - AS_HELP_STRING([--enable-time64bit], - [force 64-bit time_t for 32-bit build (default: off)]), - [tcl_ok=$enableval], [tcl_ok=no]) -AC_MSG_RESULT("$tcl_ok") -if test "$tcl_ok" = "yes"; then - CFLAGS="${CFLAGS} -D_USE_64BIT_TIME_T" -fi - -#-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called # after SC_ENABLE_SHARED checks the configure switches. @@ -334,8 +320,8 @@ eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" -eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\"" -eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\"" +eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${LIBSUFFIX}\"" +eval "TCL_STUB_LIB_FLAG=\"-ltclstub${LIBFLAGSUFFIX}\"" eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\"" eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\"" eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\"" @@ -463,13 +449,7 @@ AC_SUBST(POST_MAKE_LIB) AC_SUBST(MAKE_DLL) AC_SUBST(MAKE_EXE) -# empty on win, but needs sub'ing AC_SUBST(TCL_BUILD_LIB_SPEC) -AC_SUBST(TCL_CC_SEARCH_FLAGS) -AC_SUBST(TCL_LD_SEARCH_FLAGS) -AC_SUBST(TCL_BUILD_EXP_FILE) -AC_SUBST(TCL_EXP_FILE) -AC_SUBST(DL_LIBS) AC_SUBST(TCL_PACKAGE_PATH) # win only diff --git a/win/makefile.vc b/win/makefile.vc index 3f6a7e5..6e059e8 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -52,7 +52,7 @@ # 64-bit compiler, if your SDK has it.
#
# Basic macros and options usable on the commandline (see rules.vc for more info):
-# OPTS=msvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,time64bit,unchecked,none
+# OPTS=nomsvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,unchecked,none
# Sets special options for the core. The default is for none.
# Any combination of the above may be used (comma separated).
# 'none' will over-ride everything to nothing.
@@ -75,8 +75,6 @@ # have the dde and registry extensions linked inside.
# symbols = Adds symbols for step debugging.
# thrdalloc = Use the thread allocator (shared global free pool).
-# time64bit = Forces a build using 64-bit time_t for 32-bit build
-# (CRT library should support this).
# unchecked = Allows a symbols build to not use the debug
# enabled runtime (msvcrt.dll not msvcrtd.dll
# or libcmt.lib not libcmtd.lib).
@@ -217,10 +215,10 @@ DDEVERSION = $(DDEDOTVERSION:.=) REGDOTVERSION = 1.3
REGVERSION = $(REGDOTVERSION:.=)
-TCLREGLIBNAME = $(PROJECT)registry$(REGVERSION)$(SUFX:t=).$(EXT)
+TCLREGLIBNAME = $(PROJECT)9registry$(REGVERSION)$(SUFX:t=).$(EXT)
TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME)
-TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT)
+TCLDDELIBNAME = $(PROJECT)9dde$(DDEVERSION)$(SUFX:t=).$(EXT)
TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME)
TCLTEST = $(OUT_DIR)\$(PROJECT)test$(VERSION)$(SUFX:t=).exe
@@ -236,6 +234,7 @@ TCLTESTOBJS = \ $(TMP_DIR)\tclTestProcBodyObj.obj \
$(TMP_DIR)\tclThreadTest.obj \
$(TMP_DIR)\tclWinTest.obj \
+ $(TMP_DIR)\tclTestABSList.obj \
!if !$(STATIC_BUILD)
$(OUT_DIR)\tommath.lib \
!endif
@@ -247,8 +246,8 @@ COREOBJS = \ $(TMP_DIR)\regerror.obj \
$(TMP_DIR)\regexec.obj \
$(TMP_DIR)\regfree.obj \
- $(TMP_DIR)\tclAlloc.obj \
$(TMP_DIR)\tclArithSeries.obj \
+ $(TMP_DIR)\tclAlloc.obj \
$(TMP_DIR)\tclAssembly.obj \
$(TMP_DIR)\tclAsync.obj \
$(TMP_DIR)\tclBasic.obj \
@@ -452,6 +451,8 @@ TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \
$(TMP_DIR)\tclStubLib.obj \
+ $(TMP_DIR)\tclStubCall.obj \
+ $(TMP_DIR)\tclStubLibTbl.obj \
$(TMP_DIR)\tclTomMathStubLib.obj \
$(TMP_DIR)\tclOOStubLib.obj \
$(TMP_DIR)\tclWinPanic.obj
@@ -810,10 +811,7 @@ $(OUT_DIR)\tclConfig.sh: $(WIN_DIR)\tclConfig.sh.in @STLIB_LD@ $(lib32) -nologo
@SHLIB_LD_LIBS@ $(baselibs) $(PRJ_LIBS)
@SHLIB_SUFFIX@ .dll
-@DL_LIBS@
@LDFLAGS@
-@TCL_CC_SEARCH_FLAGS@
-@TCL_LD_SEARCH_FLAGS@
@LIBOBJS@
@RANLIB@
@TCL_LIB_FLAG@ $(PROJECT)$(VERSION)$(SUFX).lib
@@ -883,6 +881,9 @@ $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclUuid.h $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
$(cc32) $(appcflags) -Fo$@ $?
+$(TMP_DIR)\tclTestABSList.obj: $(GENERICDIR)\tclTestABSList.c
+ $(cc32) $(appcflags) -Fo$@ $?
+
$(TMP_DIR)\tclWinTest.obj: $(WIN_DIR)\tclWinTest.c
$(CCAPPCMD) $?
@@ -929,11 +930,11 @@ $(TMP_DIR)\tclAppInit.obj: $(WIN_DIR)\tclAppInit.c ### The following objects should be built using the stub interfaces
$(TMP_DIR)\tclWinReg.obj: $(WIN_DIR)\tclWinReg.c
- $(cc32) $(appcflags) /DUSE_TCL_STUBS -Fo$@ $?
+ $(cc32) $(appcflags_nostubs) /DUSE_TCL_STUBS=1 -Fo$@ $?
$(TMP_DIR)\tclWinDde.obj: $(WIN_DIR)\tclWinDde.c
- $(cc32) $(appcflags) /DUSE_TCL_STUBS -Fo$@ $?
+ $(cc32) $(appcflags_nostubs) /DUSE_TCL_STUBS=1 -Fo$@ $?
### The following objects are part of the stub library and should not
@@ -943,6 +944,15 @@ $(TMP_DIR)\tclWinDde.obj: $(WIN_DIR)\tclWinDde.c $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c
$(cc32) $(stubscflags) -Fo$@ $?
+$(TMP_DIR)\tclStubCall.obj: $(GENERICDIR)\tclStubCall.c
+ $(cc32) $(stubscflags) \
+ /DCFG_RUNTIME_DLLFILE="\"$(TCLLIBNAME)\"" \
+ /DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \
+ $(TCL_INCLUDES) -Fo$@ $?
+
+$(TMP_DIR)\tclStubLibTbl.obj: $(GENERICDIR)\tclStubLibTbl.c
+ $(cc32) $(stubscflags) $(TCL_INCLUDES) -Fo$@ $?
+
$(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c
$(cc32) $(stubscflags) -Fo$@ $?
@@ -1088,30 +1098,24 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata @if not exist "$(MODULE_INSTALL_DIR)" \
$(MKDIR) "$(MODULE_INSTALL_DIR)"
@echo Installing package http $(PKG_HTTP_VER) as a Tcl Module
- @if not exist "$(MODULE_INSTALL_DIR)\8.6" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.6"
+ @if not exist "$(MODULE_INSTALL_DIR)\9.0" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\9.0"
@$(COPY) "$(ROOT)\library\http\http.tcl" \
- "$(MODULE_INSTALL_DIR)\8.6\http-$(PKG_HTTP_VER).tm"
+ "$(MODULE_INSTALL_DIR)\9.0\http-$(PKG_HTTP_VER).tm"
@echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module
- @if not exist "$(MODULE_INSTALL_DIR)\8.7" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.7"
@$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \
- "$(MODULE_INSTALL_DIR)\8.7\msgcat-$(PKG_MSGCAT_VER).tm"
+ "$(MODULE_INSTALL_DIR)\9.0\msgcat-$(PKG_MSGCAT_VER).tm"
@echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module
- @if not exist "$(MODULE_INSTALL_DIR)\8.5" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.5"
@$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \
- "$(MODULE_INSTALL_DIR)\8.5\tcltest-$(PKG_TCLTEST_VER).tm"
+ "$(MODULE_INSTALL_DIR)\9.0\tcltest-$(PKG_TCLTEST_VER).tm"
@echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module
- @if not exist "$(MODULE_INSTALL_DIR)\8.4" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4"
- @if not exist "$(MODULE_INSTALL_DIR)\8.4\platform" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4\platform"
+ @if not exist "$(MODULE_INSTALL_DIR)\9.0\platform" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\9.0\platform"
@$(COPY) "$(ROOT)\library\platform\platform.tcl" \
- "$(MODULE_INSTALL_DIR)\8.4\platform-$(PKG_PLATFORM_VER).tm"
+ "$(MODULE_INSTALL_DIR)\9.0\platform-$(PKG_PLATFORM_VER).tm"
@echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\platform\shell.tcl" \
- "$(MODULE_INSTALL_DIR)\8.4\platform\shell-$(PKG_SHELL_VER).tm"
+ "$(MODULE_INSTALL_DIR)\9.0\platform\shell-$(PKG_SHELL_VER).tm"
!endif
@echo Installing $(TCLDDELIBNAME)
!if !$(STATIC_BUILD)
diff --git a/win/tcl.dsp b/win/tcl.dsp index d033560..a5e4a63 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -36,7 +36,7 @@ CFG=tcl - Win32 Debug Static # PROP BASE Intermediate_Dir "Release\tcl_Dynamic"
# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc MSVCDIR=IDE"
# PROP BASE Rebuild_Opt "-a"
-# PROP BASE Target_File "Release\tclsh87.exe"
+# PROP BASE Target_File "Release\tclsh90.exe"
# PROP BASE Bsc_Name ""
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
@@ -45,7 +45,7 @@ CFG=tcl - Win32 Debug Static # PROP Intermediate_Dir "Release\tcl_Dynamic"
# PROP Cmd_Line "nmake -nologo -f makefile.vc MSVCDIR=IDE"
# PROP Rebuild_Opt "clean release"
-# PROP Target_File "Release\tclsh87t.exe"
+# PROP Target_File "Release\tclsh90t.exe"
# PROP Bsc_Name ""
# PROP Target_Dir ""
@@ -57,7 +57,7 @@ CFG=tcl - Win32 Debug Static # PROP BASE Intermediate_Dir "Debug\tcl_Dynamic"
# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols MSVCDIR=IDE"
# PROP BASE Rebuild_Opt "-a"
-# PROP BASE Target_File "Debug\tclsh87g.exe"
+# PROP BASE Target_File "Debug\tclsh90g.exe"
# PROP BASE Bsc_Name ""
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
@@ -66,7 +66,7 @@ CFG=tcl - Win32 Debug Static # PROP Intermediate_Dir "Debug\tcl_Dynamic"
# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=threads,symbols MSVCDIR=IDE"
# PROP Rebuild_Opt "clean release"
-# PROP Target_File "Debug\tclsh87tg.exe"
+# PROP Target_File "Debug\tclsh90tg.exe"
# PROP Bsc_Name ""
# PROP Target_Dir ""
@@ -78,7 +78,7 @@ CFG=tcl - Win32 Debug Static # PROP BASE Intermediate_Dir "Debug\tcl_Static"
# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols,static MSVCDIR=IDE"
# PROP BASE Rebuild_Opt "-a"
-# PROP BASE Target_File "Debug\tclsh87sg.exe"
+# PROP BASE Target_File "Debug\tclsh90sg.exe"
# PROP BASE Bsc_Name ""
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
@@ -87,7 +87,7 @@ CFG=tcl - Win32 Debug Static # PROP Intermediate_Dir "Debug\tcl_Static"
# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols,static MSVCDIR=IDE"
# PROP Rebuild_Opt "-a"
-# PROP Target_File "Debug\tclsh87sg.exe"
+# PROP Target_File "Debug\tclsh90sg.exe"
# PROP Bsc_Name ""
# PROP Target_Dir ""
@@ -99,7 +99,7 @@ CFG=tcl - Win32 Debug Static # PROP BASE Intermediate_Dir "Release\tcl_Static"
# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=static MSVCDIR=IDE"
# PROP BASE Rebuild_Opt "-a"
-# PROP BASE Target_File "Release\tclsh87s.exe"
+# PROP BASE Target_File "Release\tclsh90s.exe"
# PROP BASE Bsc_Name ""
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
@@ -108,7 +108,7 @@ CFG=tcl - Win32 Debug Static # PROP Intermediate_Dir "Release\tcl_Static"
# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=static MSVCDIR=IDE"
# PROP Rebuild_Opt "-a"
-# PROP Target_File "Release\tclsh87s.exe"
+# PROP Target_File "Release\tclsh90s.exe"
# PROP Bsc_Name ""
# PROP Target_Dir ""
@@ -1240,6 +1240,14 @@ SOURCE=..\generic\tclStubLib.c # End Source File
# Begin Source File
+SOURCE=..\generic\tclStubCall.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclStubLibTbl.c
+# End Source File
+# Begin Source File
+
SOURCE=..\generic\tclOOStubLib.c
# End Source File
# Begin Source File
@@ -985,13 +985,13 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ #------------------------------------------------------------------------ AC_DEFUN([SC_WITH_TCL], [ - if test -d ../../tcl8.7$1/win; then - TCL_BIN_DEFAULT=../../tcl8.7$1/win + if test -d ../../tcl9.0$1/win; then + TCL_BIN_DEFAULT=../../tcl9.0$1/win else - TCL_BIN_DEFAULT=../../tcl8.7/win + TCL_BIN_DEFAULT=../../tcl9.0/win fi - AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.7 binaries from DIR], + AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 9.0 binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DEFAULT; pwd`) if test ! -d $TCL_BIN_DIR; then AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist) diff --git a/win/tclAppInit.c b/win/tclAppInit.c index d1b38ee..8fad88a 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -215,8 +215,11 @@ Tcl_AppInit( * user-specific startup file will be run under any conditions. */ - Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL, - Tcl_NewStringObj("~/tclshrc.tcl", TCL_INDEX_NONE), TCL_GLOBAL_ONLY); + (void)Tcl_EvalEx(interp, + "set tcl_rcFileName [file tildeexpand ~/tclshrc.tcl]", + -1, + TCL_EVAL_GLOBAL); + return TCL_OK; } @@ -277,11 +280,10 @@ setargv( } } - /* Make sure we don't call ckalloc through the (not yet initialized) stub table */ + /* Make sure we don't call Tcl_Alloc through the (not yet initialized) stub table */ # undef Tcl_Alloc -# undef Tcl_DbCkalloc - argSpace = (TCHAR *)ckalloc(size * sizeof(char *) + argSpace = (TCHAR *)Tcl_Alloc(size * sizeof(char *) + (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR)); argv = (TCHAR **) argSpace; argSpace += size * (sizeof(char *)/sizeof(TCHAR)); diff --git a/win/tclConfig.sh.in b/win/tclConfig.sh.in index 1c33246..c980af6 100644 --- a/win/tclConfig.sh.in +++ b/win/tclConfig.sh.in @@ -23,11 +23,6 @@ TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' -# TCL_DBGX used to be used to distinguish debug vs. non-debug builds. -# This was a righteous pain so the core doesn't do that any more. -# DEPRECATED, will be removed in Tcl 9! -TCL_DBGX='' - # Default flags used in an optimized and debuggable build, respectively. TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@' TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@' @@ -48,9 +43,6 @@ TCL_ZIP_FILE='@TCL_ZIP_FILE@' # Flag to indicate whether shared libraries need export files. TCL_NEEDS_EXP_FILE='' -# Deprecated. Same as TCL_UNSHARED_LIB_SUFFIX -TCL_EXPORT_FILE_SUFFIX='@CFG_TCL_UNSHARED_LIB_SUFFIX@' - # Additional libraries to use when linking Tcl. TCL_LIBS='@LIBS@' @@ -87,7 +79,7 @@ TCL_SHLIB_SUFFIX='@SHLIB_SUFFIX@' # Library file(s) to include in tclsh and other base applications # in order to provide facilities needed by DLOBJ above. -TCL_DL_LIBS='@DL_LIBS@' +TCL_DL_LIBS='' # Flags to pass to the compiler when linking object files into # an executable tclsh or tcltest binary. @@ -97,8 +89,8 @@ TCL_LD_FLAGS='@LDFLAGS@' # run-time dynamic linker where to look for shared libraries such as # libtcl.so. Used when linking applications. Only works if there # is a variable "LIB_RUNTIME_DIR" defined in the Makefile. -TCL_CC_SEARCH_FLAGS='@TCL_CC_SEARCH_FLAGS@' -TCL_LD_SEARCH_FLAGS='@TCL_LD_SEARCH_FLAGS@' +TCL_CC_SEARCH_FLAGS='' +TCL_LD_SEARCH_FLAGS='' # Additional object files linked with Tcl to provide compatibility # with standard facilities from ANSI C or POSIX. diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 7c3d8a4..01fa6c3 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -144,7 +144,7 @@ DllMain( *---------------------------------------------------------------------- */ -HINSTANCE +void * TclWinGetTclInstance(void) { return hInstance; @@ -247,8 +247,8 @@ TclWinEncodingsCleanup(void) dlIter = driveLetterLookup; while (dlIter != NULL) { dlIter2 = dlIter->nextPtr; - ckfree(dlIter->volumeName); - ckfree(dlIter); + Tcl_Free(dlIter->volumeName); + Tcl_Free(dlIter); dlIter = dlIter2; } Tcl_MutexUnlock(&mountPointMap); @@ -341,8 +341,8 @@ TclWinDriveLetterForVolMountPoint( * Now dlPtr2 points to the structure to free. */ - ckfree(dlPtr2->volumeName); - ckfree(dlPtr2); + Tcl_Free(dlPtr2->volumeName); + Tcl_Free(dlPtr2); /* * Restart the loop - we could try to be clever and continue half @@ -377,7 +377,7 @@ TclWinDriveLetterForVolMountPoint( } } if (!alreadyStored) { - dlPtr2 = (MountPointMap *)ckalloc(sizeof(MountPointMap)); + dlPtr2 = (MountPointMap *)Tcl_Alloc(sizeof(MountPointMap)); dlPtr2->volumeName = (WCHAR *)TclNativeDupInternalRep(Target); dlPtr2->driveLetter = (WCHAR) drive[0]; dlPtr2->nextPtr = driveLetterLookup; @@ -403,7 +403,7 @@ TclWinDriveLetterForVolMountPoint( * that fact and store '-1' so we don't have to look it up each time. */ - dlPtr2 = (MountPointMap *)ckalloc(sizeof(MountPointMap)); + dlPtr2 = (MountPointMap *)Tcl_Alloc(sizeof(MountPointMap)); dlPtr2->volumeName = (WCHAR *)TclNativeDupInternalRep((void *)mountPoint); dlPtr2->driveLetter = (WCHAR)-1; dlPtr2->nextPtr = driveLetterLookup; @@ -413,76 +413,6 @@ TclWinDriveLetterForVolMountPoint( } /* - *--------------------------------------------------------------------------- - * - * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf -- - * - * Convert between UTF-8 and Unicode when running Windows. - * - * On Mac and Unix, all strings exchanged between Tcl and the OS are - * "char" oriented. We need only one Tcl_Encoding to convert between - * UTF-8 and the system's native encoding. We use NULL to represent - * that encoding. - * - * On Windows, some strings exchanged between Tcl and the OS are "char" - * oriented, while others are in Unicode. We need two Tcl_Encoding APIs - * depending on whether we are targeting a "char" or Unicode interface. - * - * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding - * of NULL should always used to convert between UTF-8 and the system's - * "char" oriented encoding. The following two functions are used in - * Windows-specific code to convert between UTF-8 and Unicode strings. - * This saves you the trouble of writing the - * following type of fragment over and over: - * - * encoding <- Tcl_GetEncoding("unicode"); - * nativeBuffer <- UtfToExternal(encoding, utfBuffer); - * Tcl_FreeEncoding(encoding); - * - * By convention, in Windows a WCHAR is a Unicode character. If you plan - * on targeting a Unicode interface when running on Windows, these - * functions should be used. If you plan on targetting a "char" oriented - * function on Windows, use Tcl_UtfToExternal() with an encoding of NULL. - * - * Results: - * The result is a pointer to the string in the desired target encoding. - * Storage for the result string is allocated in dsPtr; the caller must - * call Tcl_DStringFree() when the result is no longer needed. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -#undef Tcl_WinUtfToTChar -TCHAR * -Tcl_WinUtfToTChar( - const char *string, /* Source string in UTF-8. */ - int len, /* Source string length in bytes, or -1 for - * strlen(). */ - Tcl_DString *dsPtr) /* Uninitialized or free DString in which the - * converted string is stored. */ -{ - Tcl_DStringInit(dsPtr); - return (TCHAR *)Tcl_UtfToWCharDString(string, len, dsPtr); -} -#undef Tcl_WinTCharToUtf -char * -Tcl_WinTCharToUtf( - const TCHAR *string, /* Source string in Unicode. */ - int len, /* Source string length in bytes, or -1 for - * platform-specific string length. */ - Tcl_DString *dsPtr) /* Uninitialized or free DString in which the - * converted string is stored. */ -{ - Tcl_DStringInit(dsPtr); - return Tcl_WCharToUtfDString((WCHAR *)string, len >> 1, dsPtr); -} -#endif /* !defined(TCL_NO_DEPRECATED) */ - -/* *------------------------------------------------------------------------ * * TclWinCPUID -- diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 3be06c3..8743afe 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -72,33 +72,29 @@ typedef struct { * Static routines for this file: */ -static int FileBlockProc(ClientData instanceData, int mode); -static void FileChannelExitHandler(ClientData clientData); -static void FileCheckProc(ClientData clientData, int flags); -static int FileCloseProc(ClientData instanceData, +static int FileBlockProc(void *instanceData, int mode); +static void FileChannelExitHandler(void *clientData); +static void FileCheckProc(void *clientData, int flags); +static int FileCloseProc(void *instanceData, Tcl_Interp *interp, int flags); static int FileEventProc(Tcl_Event *evPtr, int flags); -static int FileGetHandleProc(ClientData instanceData, - int direction, ClientData *handlePtr); -static int FileGetOptionProc(ClientData instanceData, +static int FileGetHandleProc(void *instanceData, + int direction, void **handlePtr); +static int FileGetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static ThreadSpecificData *FileInit(void); -static int FileInputProc(ClientData instanceData, char *buf, +static int FileInputProc(void *instanceData, char *buf, int toRead, int *errorCode); -static int FileOutputProc(ClientData instanceData, +static int FileOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); -#ifndef TCL_NO_DEPRECATED -static int FileSeekProc(ClientData instanceData, long offset, - int mode, int *errorCode); -#endif -static long long FileWideSeekProc(ClientData instanceData, +static long long FileWideSeekProc(void *instanceData, long long offset, int mode, int *errorCode); -static void FileSetupProc(ClientData clientData, int flags); -static void FileWatchProc(ClientData instanceData, int mask); -static void FileThreadActionProc(ClientData instanceData, +static void FileSetupProc(void *clientData, int flags); +static void FileWatchProc(void *instanceData, int mask); +static void FileThreadActionProc(void *instanceData, int action); -static int FileTruncateProc(ClientData instanceData, +static int FileTruncateProc(void *instanceData, long long length); static DWORD FileGetType(HANDLE handle); static int NativeIsComPort(const WCHAR *nativeName); @@ -112,14 +108,10 @@ static Tcl_Channel OpenFileChannel(HANDLE handle, char *channelName, static const Tcl_ChannelType fileChannelType = { "file", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - TCL_CLOSE2PROC, /* Close proc. */ + NULL, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ -#ifndef TCL_NO_DEPRECATED - FileSeekProc, /* Seek proc. */ -#else NULL, -#endif NULL, /* Set option proc. */ FileGetOptionProc, /* Get option proc. */ FileWatchProc, /* Set up the notifier to watch the channel. */ @@ -200,7 +192,7 @@ FileInit(void) static void FileChannelExitHandler( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL); } @@ -224,7 +216,7 @@ FileChannelExitHandler( void FileSetupProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { FileInfo *infoPtr; @@ -267,7 +259,7 @@ FileSetupProc( static void FileCheckProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { FileEvent *evPtr; @@ -287,7 +279,7 @@ FileCheckProc( infoPtr = infoPtr->nextPtr) { if (infoPtr->watchMask && !TEST_FLAG(infoPtr->flags, FILE_PENDING)) { SET_FLAG(infoPtr->flags, FILE_PENDING); - evPtr = (FileEvent *)ckalloc(sizeof(FileEvent)); + evPtr = (FileEvent *)Tcl_Alloc(sizeof(FileEvent)); evPtr->header.proc = FileEventProc; evPtr->infoPtr = infoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); @@ -366,7 +358,7 @@ FileEventProc( static int FileBlockProc( - ClientData instanceData, /* Instance data for channel. */ + void *instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { @@ -405,7 +397,7 @@ FileBlockProc( static int FileCloseProc( - ClientData instanceData, /* Pointer to FileInfo structure. */ + void *instanceData, /* Pointer to FileInfo structure. */ TCL_UNUSED(Tcl_Interp *), int flags) { @@ -459,92 +451,13 @@ FileCloseProc( break; } } - ckfree(fileInfoPtr); + Tcl_Free(fileInfoPtr); return errorCode; } /* *---------------------------------------------------------------------- * - * FileSeekProc -- - * - * Seeks on a file-based channel. Returns the new position. - * - * Results: - * -1 if failed, the new position if successful. If failed, it also sets - * *errorCodePtr to the error code. - * - * Side effects: - * Moves the location at which the channel will be accessed in future - * operations. - * - *---------------------------------------------------------------------- - */ -#ifndef TCL_NO_DEPRECATED -static int -FileSeekProc( - ClientData instanceData, /* File state. */ - long offset, /* Offset to seek to. */ - int mode, /* Relative to where should we seek? */ - int *errorCodePtr) /* To store error code. */ -{ - FileInfo *infoPtr = (FileInfo *)instanceData; - LONG newPos, newPosHigh, oldPos, oldPosHigh; - DWORD moveMethod; - - *errorCodePtr = 0; - if (mode == SEEK_SET) { - moveMethod = FILE_BEGIN; - } else if (mode == SEEK_CUR) { - moveMethod = FILE_CURRENT; - } else { - moveMethod = FILE_END; - } - - /* - * Save our current place in case we need to roll-back the seek. - */ - - oldPosHigh = 0; - oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT); - if (oldPos == (LONG) INVALID_SET_FILE_POINTER) { - DWORD winError = GetLastError(); - - if (winError != NO_ERROR) { - Tcl_WinConvertError(winError); - *errorCodePtr = errno; - return -1; - } - } - - newPosHigh = (offset < 0 ? -1 : 0); - newPos = SetFilePointer(infoPtr->handle, offset, &newPosHigh, moveMethod); - if (newPos == (LONG) INVALID_SET_FILE_POINTER) { - DWORD winError = GetLastError(); - - if (winError != NO_ERROR) { - Tcl_WinConvertError(winError); - *errorCodePtr = errno; - return -1; - } - } - - /* - * Check for expressability in our return type, and roll-back otherwise. - */ - - if (newPosHigh != 0) { - *errorCodePtr = EOVERFLOW; - SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN); - return -1; - } - return (int) newPos; -} -#endif - -/* - *---------------------------------------------------------------------- - * * FileWideSeekProc -- * * Seeks on a file-based channel. Returns the new position. @@ -562,7 +475,7 @@ FileSeekProc( static long long FileWideSeekProc( - ClientData instanceData, /* File state. */ + void *instanceData, /* File state. */ long long offset, /* Offset to seek to. */ int mode, /* Relative to where should we seek? */ int *errorCodePtr) /* To store error code. */ @@ -614,7 +527,7 @@ FileWideSeekProc( static int FileTruncateProc( - ClientData instanceData, /* File state. */ + void *instanceData, /* File state. */ long long length) /* Length to truncate at. */ { FileInfo *infoPtr = (FileInfo *)instanceData; @@ -690,7 +603,7 @@ FileTruncateProc( static int FileInputProc( - ClientData instanceData, /* File state. */ + void *instanceData, /* File state. */ char *buf, /* Where to store data read. */ int bufSize, /* Num bytes available in buffer. */ int *errorCode) /* Where to store error code. */ @@ -745,7 +658,7 @@ FileInputProc( static int FileOutputProc( - ClientData instanceData, /* File state. */ + void *instanceData, /* File state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ @@ -792,7 +705,7 @@ FileOutputProc( static void FileWatchProc( - ClientData instanceData, /* File state. */ + void *instanceData, /* File state. */ int mask) /* What events to watch for; OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ @@ -831,9 +744,9 @@ FileWatchProc( static int FileGetHandleProc( - ClientData instanceData, /* The file state. */ + void *instanceData, /* The file state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ - ClientData *handlePtr) /* Where to store the handle. */ + void **handlePtr) /* Where to store the handle. */ { FileInfo *infoPtr = (FileInfo *)instanceData; @@ -841,7 +754,7 @@ FileGetHandleProc( return TCL_ERROR; } - *handlePtr = (ClientData) infoPtr->handle; + *handlePtr = (void *) infoPtr->handle; return TCL_OK; } @@ -981,7 +894,7 @@ StatOpenFile( static int FileGetOptionProc( - ClientData instanceData, /* The file state. */ + void *instanceData, /* The file state. */ Tcl_Interp *interp, /* For error reporting. */ const char *optionName, /* What option to read, or NULL for all. */ Tcl_DString *dsPtr) /* Where to write the value read. */ @@ -1254,7 +1167,7 @@ TclpOpenFileChannel( "couldn't open \"%s\": bad file type", TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE", - (char *)NULL); + (void *)NULL); break; } @@ -1279,7 +1192,7 @@ TclpOpenFileChannel( Tcl_Channel Tcl_MakeFileChannel( - ClientData rawHandle, /* OS level handle */ + void *rawHandle, /* OS level handle */ int mode) /* OR'ed combination of TCL_READABLE and * TCL_WRITABLE to indicate file mode. */ { @@ -1528,9 +1441,8 @@ TclpGetDefaultStdChannel( */ if (Tcl_SetChannelOption(NULL,channel,"-translation","auto")!=TCL_OK || - Tcl_SetChannelOption(NULL,channel,"-eofchar","\x1A {}")!=TCL_OK || Tcl_SetChannelOption(NULL,channel,"-buffering",bufMode)!=TCL_OK) { - Tcl_Close(NULL, channel); + Tcl_CloseEx(NULL, channel, 0); return (Tcl_Channel) NULL; } return channel; @@ -1580,7 +1492,7 @@ OpenFileChannel( } } - infoPtr = (FileInfo *)ckalloc(sizeof(FileInfo)); + infoPtr = (FileInfo *)Tcl_Alloc(sizeof(FileInfo)); /* * TIP #218. Removed the code inserting the new structure into the global @@ -1605,7 +1517,6 @@ OpenFileChannel( */ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\x1A {}"); return infoPtr->channel; } @@ -1667,7 +1578,7 @@ TclWinFlushDirtyChannels(void) static void FileThreadActionProc( - ClientData instanceData, + void *instanceData, int action) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index e1ca46a..5b30fc4 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -203,29 +203,29 @@ typedef struct { * Declarations for functions used only in this file. */ -static int ConsoleBlockModeProc(ClientData instanceData, int mode); -static void ConsoleCheckProc(ClientData clientData, int flags); -static int ConsoleCloseProc(ClientData instanceData, +static int ConsoleBlockModeProc(void *instanceData, int mode); +static void ConsoleCheckProc(void *clientData, int flags); +static int ConsoleCloseProc(void *instanceData, Tcl_Interp *interp, int flags); static int ConsoleEventProc(Tcl_Event *evPtr, int flags); -static void ConsoleExitHandler(ClientData clientData); -static int ConsoleGetHandleProc(ClientData instanceData, - int direction, ClientData *handlePtr); -static int ConsoleGetOptionProc(ClientData instanceData, +static void ConsoleExitHandler(void *clientData); +static int ConsoleGetHandleProc(void *instanceData, + int direction, void **handlePtr); +static int ConsoleGetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static void ConsoleInit(void); -static int ConsoleInputProc(ClientData instanceData, char *buf, +static int ConsoleInputProc(void *instanceData, char *buf, int toRead, int *errorCode); -static int ConsoleOutputProc(ClientData instanceData, +static int ConsoleOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); -static int ConsoleSetOptionProc(ClientData instanceData, +static int ConsoleSetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, const char *value); -static void ConsoleSetupProc(ClientData clientData, int flags); -static void ConsoleWatchProc(ClientData instanceData, int mask); -static void ProcExitHandler(ClientData clientData); -static void ConsoleThreadActionProc(ClientData instanceData, int action); +static void ConsoleSetupProc(void *clientData, int flags); +static void ConsoleWatchProc(void *instanceData, int mask); +static void ProcExitHandler(void *clientData); +static void ConsoleThreadActionProc(void *instanceData, int action); static DWORD ReadConsoleChars(HANDLE hConsole, WCHAR *lpBuffer, Tcl_Size nChars, Tcl_Size *nCharsReadPtr); static DWORD WriteConsoleChars(HANDLE hConsole, @@ -291,7 +291,7 @@ static ConsoleChannelInfo *gWatchingChannelList; static const Tcl_ChannelType consoleChannelType = { "console", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - TCL_CLOSE2PROC, /* Close proc. */ + NULL, /* Close proc. */ ConsoleInputProc, /* Input proc. */ ConsoleOutputProc, /* Output proc. */ NULL, /* Seek proc. */ @@ -329,7 +329,7 @@ RingBufferInit(RingBuffer *ringPtr, Tcl_Size capacity) if (capacity <= 0 || capacity > TCL_SIZE_MAX) { Tcl_Panic("Internal error: invalid ring buffer capacity requested."); } - ringPtr->bufPtr = (char *)ckalloc(capacity); + ringPtr->bufPtr = (char *)Tcl_Alloc(capacity); ringPtr->capacity = capacity; ringPtr->start = 0; ringPtr->length = 0; @@ -354,7 +354,7 @@ static void RingBufferClear(RingBuffer *ringPtr) { if (ringPtr->bufPtr) { - ckfree(ringPtr->bufPtr); + Tcl_Free(ringPtr->bufPtr); ringPtr->bufPtr = NULL; } ringPtr->capacity = 0; @@ -663,7 +663,7 @@ ConsoleInit(void) static void ConsoleExitHandler( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); } @@ -687,7 +687,7 @@ ConsoleExitHandler( static void ProcExitHandler( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { AcquireSRWLockExclusive(&gConsoleLock); gInitialized = 0; @@ -752,7 +752,7 @@ void NudgeWatchers (HANDLE consoleHandle) void ConsoleSetupProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { ConsoleChannelInfo *chanInfoPtr; @@ -817,7 +817,7 @@ ConsoleSetupProc( static void ConsoleCheckProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { ConsoleChannelInfo *chanInfoPtr; @@ -883,7 +883,7 @@ ConsoleCheckProc( ReleaseSRWLockShared(&handleInfoPtr->lock); if (needEvent) { - ConsoleEvent *evPtr = (ConsoleEvent *)ckalloc(sizeof(ConsoleEvent)); + ConsoleEvent *evPtr = (ConsoleEvent *)Tcl_Alloc(sizeof(ConsoleEvent)); /* See note above loop why this can be accessed without locks */ chanInfoPtr->flags |= CONSOLE_EVENT_QUEUED; @@ -916,7 +916,7 @@ ConsoleCheckProc( static int ConsoleBlockModeProc( - ClientData instanceData, /* Instance data for channel. */ + void *instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { @@ -956,7 +956,7 @@ ConsoleBlockModeProc( static int ConsoleCloseProc( - ClientData instanceData, /* Pointer to ConsoleChannelInfo structure. */ + void *instanceData, /* Pointer to ConsoleChannelInfo structure. */ TCL_UNUSED(Tcl_Interp *), int flags) { @@ -1050,7 +1050,7 @@ ConsoleCloseProc( /* There may be references already on the event queue */ chanInfoPtr->numRefs -= 1; } else { - ckfree(chanInfoPtr); + Tcl_Free(chanInfoPtr); } return errorCode; @@ -1075,7 +1075,7 @@ ConsoleCloseProc( */ static int ConsoleInputProc( - ClientData instanceData, /* Console state. */ + void *instanceData, /* Console state. */ char *bufPtr, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ @@ -1149,7 +1149,7 @@ ConsoleInputProc( * reader thread which handles these case rather than dealing with * them here (which is a little trickier than it might sound.) */ - if ((1 & (ptrdiff_t)bufPtr) == 0 /* aligned buffer */ + if ((1 & (size_t)bufPtr) == 0 /* aligned buffer */ && bufSize > 1 /* Not single byte read */ ) { DWORD lastError; @@ -1228,7 +1228,7 @@ ConsoleInputProc( */ static int ConsoleOutputProc( - ClientData instanceData, /* Console state. */ + void *instanceData, /* Console state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ @@ -1444,7 +1444,7 @@ ConsoleEventProc( } if (freeChannel) { - ckfree(chanInfoPtr); + Tcl_Free(chanInfoPtr); } return 1; @@ -1468,7 +1468,7 @@ ConsoleEventProc( static void ConsoleWatchProc( - ClientData instanceData, /* Console state. */ + void *instanceData, /* Console state. */ int newMask) /* What events to watch for, one of * of TCL_READABLE, TCL_WRITABLE */ @@ -1544,9 +1544,9 @@ ConsoleWatchProc( static int ConsoleGetHandleProc( - ClientData instanceData, /* The console state. */ + void *instanceData, /* The console state. */ TCL_UNUSED(int) /*direction*/, - ClientData *handlePtr) /* Where to store the handle. */ + void **handlePtr) /* Where to store the handle. */ { ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; @@ -1799,7 +1799,7 @@ ConsoleReaderThread( */ } - ckfree(handleInfoPtr); + Tcl_Free(handleInfoPtr); return 0; } @@ -1957,7 +1957,7 @@ ConsoleWriterThread(LPVOID arg) RingBufferClear(&handleInfoPtr->buffer); - ckfree(handleInfoPtr); + Tcl_Free(handleInfoPtr); return 0; } @@ -1994,7 +1994,8 @@ AllocateConsoleHandleInfo( DWORD consoleMode; - handleInfoPtr = (ConsoleHandleInfo *)ckalloc(sizeof(*handleInfoPtr)); + handleInfoPtr = (ConsoleHandleInfo *)Tcl_Alloc(sizeof(*handleInfoPtr)); + memset(handleInfoPtr, 0, sizeof(*handleInfoPtr)); memset(handleInfoPtr, 0, sizeof(*handleInfoPtr)); handleInfoPtr->console = consoleHandle; InitializeSRWLock(&handleInfoPtr->lock); @@ -2021,7 +2022,7 @@ AllocateConsoleHandleInfo( if (handleInfoPtr->consoleThread == NULL) { /* Note - SRWLock and condition variables do not need finalization */ RingBufferClear(&handleInfoPtr->buffer); - ckfree(handleInfoPtr); + Tcl_Free(handleInfoPtr); return NULL; } @@ -2100,7 +2101,7 @@ TclWinOpenConsoleChannel( ConsoleInit(); - chanInfoPtr = (ConsoleChannelInfo *)ckalloc(sizeof(*chanInfoPtr)); + chanInfoPtr = (ConsoleChannelInfo *)Tcl_Alloc(sizeof(*chanInfoPtr)); memset(chanInfoPtr, 0, sizeof(*chanInfoPtr)); chanInfoPtr->permissions = permissions; @@ -2159,7 +2160,7 @@ TclWinOpenConsoleChannel( if (permissions == TCL_READABLE) { SetConsoleMode(handle, chanInfoPtr->initMode); } - ckfree(chanInfoPtr); + Tcl_Free(chanInfoPtr); return NULL; } @@ -2191,7 +2192,6 @@ TclWinOpenConsoleChannel( */ Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-translation", "auto"); - Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-eofchar", "\x1A {}"); Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-encoding", "utf-16"); return chanInfoPtr->channel; } @@ -2214,7 +2214,7 @@ TclWinOpenConsoleChannel( static void ConsoleThreadActionProc( - ClientData instanceData, + void *instanceData, int action) { ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; @@ -2247,7 +2247,7 @@ ConsoleThreadActionProc( */ static int ConsoleSetOptionProc( - ClientData instanceData, /* File state. */ + void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ @@ -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", (char *)NULL); + "VALUE", (void *)NULL); } return TCL_ERROR; } @@ -2336,7 +2336,7 @@ ConsoleSetOptionProc( static int ConsoleGetOptionProc( - ClientData instanceData, /* File state. */ + void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ diff --git a/win/tclWinError.c b/win/tclWinError.c index 7e5898b..3e75a85 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -351,9 +351,9 @@ void Tcl_WinConvertError( unsigned errCode) /* Win32 error code. */ { - if (errCode >= sizeof(errorTable)/sizeof(errorTable[0])) { + if ((unsigned)errCode >= sizeof(errorTable)/sizeof(errorTable[0])) { errCode -= WSAEWOULDBLOCK; - if (errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) { + if ((unsigned)errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) { Tcl_SetErrno(errorTable[1]); } else { Tcl_SetErrno(wsaErrorTable[errCode]); @@ -381,7 +381,7 @@ Tcl_WinConvertError( *---------------------------------------------------------------------- */ -TCL_NORETURN void +void tclWinDebugPanic( const char *format, ...) { @@ -413,12 +413,6 @@ tclWinDebugPanic( fprintf(stderr, "\n"); fflush(stderr); } -# if defined(__GNUC__) - __builtin_trap(); -# else - DebugBreak(); -# endif - abort(); } #endif /* diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index e02f6d6..4cb23ea 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -309,7 +309,8 @@ DoRenameFile( if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { WCHAR *nativeSrcRest, *nativeDstRest; const char **srcArgv, **dstArgv; - Tcl_Size size, srcArgc, dstArgc; + size_t size; + Tcl_Size srcArgc, dstArgc; WCHAR nativeSrcPath[MAX_PATH]; WCHAR nativeDstPath[MAX_PATH]; Tcl_DString srcString, dstString; @@ -317,7 +318,7 @@ DoRenameFile( size = GetFullPathNameW(nativeSrc, MAX_PATH, nativeSrcPath, &nativeSrcRest); - if ((size <= 0) || (size > MAX_PATH)) { + if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } size = GetFullPathNameW(nativeDst, MAX_PATH, @@ -378,8 +379,8 @@ DoRenameFile( Tcl_SetErrno(EXDEV); } - ckfree(srcArgv); - ckfree(dstArgv); + Tcl_Free((void *)srcArgv); + Tcl_Free((void *)dstArgv); } /* @@ -1536,7 +1537,7 @@ GetWinFileAttributes( */ Tcl_Size len; - const char *str = TclGetStringFromObj(fileName, &len); + const char *str = Tcl_GetStringFromObj(fileName, &len); if (len < 4) { if (len == 0) { @@ -1604,7 +1605,7 @@ ConvertFileNameFormat( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not read \"%s\": no such file or directory", - Tcl_GetString(fileName))); + TclGetString(fileName))); errno = ENOENT; Tcl_PosixError(interp); } @@ -1624,7 +1625,7 @@ ConvertFileNameFormat( Tcl_ListObjIndex(NULL, splitPath, i, &elt); - pathv = TclGetStringFromObj(elt, &length); + pathv = Tcl_GetStringFromObj(elt, &length); if ((pathv[0] == '/') || ((length == 3) && (pathv[1] == ':')) || (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) { /* @@ -1660,7 +1661,7 @@ ConvertFileNameFormat( * likely to lead to infinite loops. */ - tempString = TclGetStringFromObj(tempPath, &length); + tempString = Tcl_GetStringFromObj(tempPath, &length); Tcl_DStringInit(&ds); nativeName = Tcl_UtfToWCharDString(tempString, length, &ds); Tcl_DecrRefCount(tempPath); @@ -1714,19 +1715,8 @@ ConvertFileNameFormat( Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp); Tcl_DStringFree(&ds); - /* - * Deal with issues of tildes being absolute. - */ - - if (Tcl_DStringValue(&dsTemp)[0] == '~') { - TclNewLiteralStringObj(tempPath, "./"); - Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), - Tcl_DStringLength(&dsTemp)); - Tcl_DStringFree(&dsTemp); - } else { - tempPath = Tcl_DStringToObj(&dsTemp); - } - Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); + tempPath = Tcl_DStringToObj(&dsTemp); + Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); FindClose(handle); } } @@ -1895,7 +1885,7 @@ CannotSetAttribute( { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot set attribute \"%s\" for file \"%s\": attribute is readonly", - tclpFileAttrStrings[objIndex], Tcl_GetString(fileName))); + tclpFileAttrStrings[objIndex], TclGetString(fileName))); errno = EINVAL; Tcl_PosixError(interp); return TCL_ERROR; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 5e47098..c0dd4fd 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -149,8 +149,8 @@ typedef struct { * Other typedefs required by this code. */ -static time_t ToCTime(FILETIME fileTime); -static void FromCTime(time_t posixTime, FILETIME *fileTime); +static __time64_t ToCTime(FILETIME fileTime); +static void FromCTime(__time64_t posixTime, FILETIME *fileTime); /* * Declarations for local functions defined in this file: @@ -177,7 +177,7 @@ static int WinLink(const WCHAR *LinkSource, const WCHAR *LinkTarget, int linkAction); static int WinSymLinkDirectory(const WCHAR *LinkDirectory, const WCHAR *LinkTarget); -MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...); +MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); /* *-------------------------------------------------------------------- @@ -808,7 +808,7 @@ NativeWriteReparse( *---------------------------------------------------------------------- */ -TCL_NORETURN void +void tclWinDebugPanic( const char *format, ...) { @@ -838,16 +838,6 @@ tclWinDebugPanic( MessageBoxW(NULL, msgString, L"Fatal Error", MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); } -#if defined(__GNUC__) - __builtin_trap(); -#elif defined(_WIN64) - __debugbreak(); -#elif defined(_MSC_VER) && defined (_M_IX86) - _asm {int 3} -#else - DebugBreak(); -#endif - abort(); } /* @@ -874,16 +864,7 @@ TclpFindExecutable( { WCHAR wName[MAX_PATH]; char name[MAX_PATH * 3]; - - /* - * Under Windows we ignore argv0, and return the path for the file used to - * create this process. Only if it is NULL, install a new panic handler. - */ - - if (argv0 == NULL) { -# undef Tcl_SetPanicProc - Tcl_SetPanicProc(tclWinDebugPanic); - } + (void)argv0; GetModuleFileNameW(NULL, wName, sizeof(wName)/sizeof(WCHAR)); WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); @@ -941,7 +922,7 @@ TclpMatchInDirectory( DWORD attr; WIN32_FILE_ATTRIBUTE_DATA data; Tcl_Size len = 0; - const char *str = TclGetStringFromObj(norm, &len); + const char *str = Tcl_GetStringFromObj(norm, &len); native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr); @@ -1001,7 +982,7 @@ TclpMatchInDirectory( */ Tcl_DStringInit(&dsOrig); - dirName = TclGetStringFromObj(fileNamePtr, &dirLength); + dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); lastChar = dirName[dirLength -1]; @@ -2288,7 +2269,7 @@ NativeStatMode( * * ToCTime -- * - * Converts a Windows FILETIME to a time_t in UTC. + * Converts a Windows FILETIME to a __time64_t in UTC. * * Results: * Returns the count of seconds from the Posix epoch. @@ -2296,7 +2277,7 @@ NativeStatMode( *------------------------------------------------------------------------ */ -static time_t +static __time64_t ToCTime( FILETIME fileTime) /* UTC time */ { @@ -2305,7 +2286,7 @@ ToCTime( convertedTime.LowPart = fileTime.dwLowDateTime; convertedTime.HighPart = (LONG) fileTime.dwHighDateTime; - return (time_t) ((convertedTime.QuadPart - + return (__time64_t) ((convertedTime.QuadPart - (long long) POSIX_EPOCH_AS_FILETIME) / (long long) 10000000); } @@ -2314,7 +2295,7 @@ ToCTime( * * FromCTime -- * - * Converts a time_t to a Windows FILETIME + * Converts a __time64_t to a Windows FILETIME * * Results: * Returns the count of 100-ns ticks seconds from the Windows epoch. @@ -2324,7 +2305,7 @@ ToCTime( static void FromCTime( - time_t posixTime, + __time64_t posixTime, FILETIME *fileTime) /* UTC Time */ { LARGE_INTEGER convertedTime; @@ -2471,7 +2452,7 @@ TclpFilesystemPathType( if (normPath == NULL) { return NULL; } - path = Tcl_GetString(normPath); + path = TclGetString(normPath); if (path == NULL) { return NULL; } @@ -2551,7 +2532,7 @@ TclpObjNormalizePath( Tcl_DString ds; /* Some workspace. */ Tcl_DStringInit(&dsNorm); - path = Tcl_GetString(pathPtr); + path = TclGetString(pathPtr); currentPathEndPosition = path + nextCheckpoint; if (*currentPathEndPosition == '/') { @@ -2649,12 +2630,12 @@ TclpObjNormalizePath( * Convert link to forward slashes. */ - for (path = Tcl_GetString(to); *path != 0; path++) { + for (path = TclGetString(to); *path != 0; path++) { if (*path == '\\') { *path = '/'; } } - path = Tcl_GetString(to); + path = TclGetString(to); currentPathEndPosition = path + nextCheckpoint; if (temp != NULL) { Tcl_DecrRefCount(temp); @@ -2820,7 +2801,7 @@ TclpObjNormalizePath( tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), nextCheckpoint); Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, TCL_INDEX_NONE); - path = TclGetStringFromObj(tmpPathPtr, &len); + path = Tcl_GetStringFromObj(tmpPathPtr, &len); Tcl_SetStringObj(pathPtr, path, len); Tcl_DecrRefCount(tmpPathPtr); } else { @@ -2889,7 +2870,7 @@ TclWinVolumeRelativeNormalize( * current volume. */ - const char *drive = Tcl_GetString(useThisCwd); + const char *drive = TclGetString(useThisCwd); absolutePath = Tcl_NewStringObj(drive,2); Tcl_AppendToObj(absolutePath, path, TCL_INDEX_NONE); @@ -2905,7 +2886,7 @@ TclWinVolumeRelativeNormalize( */ Tcl_Size cwdLen; - const char *drive = TclGetStringFromObj(useThisCwd, &cwdLen); + const char *drive = Tcl_GetStringFromObj(useThisCwd, &cwdLen); char drive_cur = path[0]; if (drive_cur >= 'a') { @@ -2978,7 +2959,7 @@ TclpNativeToNormalized( { Tcl_DString ds; Tcl_Obj *objPtr; - Tcl_Size len; + size_t len; char *copy, *p; Tcl_DStringInit(&ds); @@ -3078,7 +3059,7 @@ TclNativeCreateNativeRep( Tcl_IncrRefCount(validPathPtr); } - str = TclGetStringFromObj(validPathPtr, &len); + str = Tcl_GetStringFromObj(validPathPtr, &len); if (strlen(str) != (size_t)len) { /* @@ -3109,7 +3090,7 @@ TclNativeCreateNativeRep( * Overallocate 6 chars, making some room for extended paths */ - wp = nativePathPtr = (WCHAR *)ckalloc((len + 6) * sizeof(WCHAR)); + wp = nativePathPtr = (WCHAR *)Tcl_Alloc((len + 6) * sizeof(WCHAR)); if (nativePathPtr==0) { goto done; } @@ -3208,7 +3189,7 @@ TclNativeDupInternalRep( len = sizeof(WCHAR) * (wcslen((const WCHAR *) clientData) + 1); - copy = (char *)ckalloc(len); + copy = (char *)Tcl_Alloc(len); memcpy(copy, clientData, len); return copy; } @@ -3324,7 +3305,7 @@ TclWinFileOwned( bufsz = 0; GetTokenInformation(token, TokenUser, NULL, 0, &bufsz); if (bufsz) { - buf = (LPBYTE)ckalloc(bufsz); + buf = (LPBYTE)Tcl_Alloc(bufsz); if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) { owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid); } @@ -3340,7 +3321,7 @@ TclWinFileOwned( LocalFree(secd); /* Also frees ownerSid */ } if (buf) { - ckfree(buf); + Tcl_Free(buf); } return (owned != 0); /* Convert non-0 to 1 */ diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 01714f0..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 @@ -167,9 +167,9 @@ TclpInitLibraryPath( TclGetProcessGlobalValue(&sourceLibraryDir)); *encodingPtr = NULL; - bytes = TclGetStringFromObj(pathPtr, &length); + bytes = Tcl_GetStringFromObj(pathPtr, &length); *lengthPtr = length++; - *valuePtr = (char *)ckalloc(length); + *valuePtr = (char *)Tcl_Alloc(length); memcpy(*valuePtr, bytes, length); Tcl_DecrRefCount(pathPtr); } @@ -260,7 +260,7 @@ AppendEnvironment( objPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE); } Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - ckfree(pathv); + Tcl_Free((void *)pathv); } } @@ -284,7 +284,7 @@ AppendEnvironment( static void InitializeDefaultLibraryDir( char **valuePtr, - TCL_HASH_TYPE *lengthPtr, + size_t *lengthPtr, Tcl_Encoding *encodingPtr) { HMODULE hModule = (HMODULE)TclWinGetTclInstance(); @@ -306,7 +306,7 @@ InitializeDefaultLibraryDir( TclWinNoBackslash(name); snprintf(end + 1, LIBRARY_SIZE, "lib/tcl%s", TCL_VERSION); *lengthPtr = strlen(name); - *valuePtr = (char *)ckalloc(*lengthPtr + 1); + *valuePtr = (char *)Tcl_Alloc(*lengthPtr + 1); *encodingPtr = NULL; memcpy(*valuePtr, name, *lengthPtr + 1); } @@ -332,7 +332,7 @@ InitializeDefaultLibraryDir( static void InitializeSourceLibraryDir( char **valuePtr, - TCL_HASH_TYPE *lengthPtr, + size_t *lengthPtr, Tcl_Encoding *encodingPtr) { HMODULE hModule = (HMODULE)TclWinGetTclInstance(); @@ -354,7 +354,7 @@ InitializeSourceLibraryDir( TclWinNoBackslash(name); snprintf(end + 1, LIBRARY_SIZE, "../library"); *lengthPtr = strlen(name); - *valuePtr = (char *)ckalloc(*lengthPtr + 1); + *valuePtr = (char *)Tcl_Alloc(*lengthPtr + 1); *encodingPtr = NULL; memcpy(*valuePtr, name, *lengthPtr + 1); } @@ -496,20 +496,6 @@ TclpSetVariables( TCL_GLOBAL_ONLY); } -#if !defined(NDEBUG) && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 - - /* - * The existence of the "debug" element of the tcl_platform array - * indicates that this particular Tcl shell has been compiled with debug - * information. Using "info exists tcl_platform(debug)" a Tcl script can - * direct the interpreter to load debug versions of DLLs with the load - * command. - */ - - Tcl_SetVar2(interp, "tcl_platform", "debug", "1", - TCL_GLOBAL_ONLY); -#endif - /* * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH * environment variables, if necessary. @@ -569,9 +555,10 @@ TclpSetVariables( * * Results: * The return value is the index in environ of an entry with the name - * "name", or -1 if there is no such entry. The integer at *lengthPtr is - * filled in with the length of name (if a matching entry is found) or - * the length of the environ array (if no matching entry is found). + * "name", or -1 if there is no such entry. The integer + * at *lengthPtr is filled in with the length of name (if a matching + * entry is found) or the length of the environ array (if no + * matching entry is found). * * Side effects: * None. @@ -599,7 +586,7 @@ TclpFindVariable( */ length = strlen(name); - nameUpper = (char *)ckalloc(length + 1); + nameUpper = (char *)Tcl_Alloc(length + 1); memcpy(nameUpper, name, length+1); Tcl_UtfToUpper(nameUpper); @@ -641,7 +628,7 @@ TclpFindVariable( done: Tcl_DStringFree(&envString); - ckfree(nameUpper); + Tcl_Free(nameUpper); return result; } diff --git a/win/tclWinInt.h b/win/tclWinInt.h index d5cf7b0..1267f3f 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -79,7 +79,7 @@ typedef struct TclPipeThreadInfo { } TclPipeThreadInfo; -/* If pipe-workers will use some tcl subsystem, we can use ckalloc without +/* If pipe-workers will use some tcl subsystem, we can use Tcl_Alloc without * more overhead for finalize thread (should be executed anyway) * * #define _PTI_USE_CKALLOC 1 diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index faf80ee..265c8e7 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -121,7 +121,7 @@ TclpDlopen( } errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", - Tcl_GetString(pathPtr)); + TclGetString(pathPtr)); /* * Check for possible DLL errors. This doesn't work quite right, @@ -174,8 +174,8 @@ TclpDlopen( * Succeded; package everything up for Tcl. */ - handlePtr = (Tcl_LoadHandle)ckalloc(sizeof(struct Tcl_LoadHandle_)); - handlePtr->clientData = (ClientData) hInstance; + handlePtr = (Tcl_LoadHandle)Tcl_Alloc(sizeof(struct Tcl_LoadHandle_)); + handlePtr->clientData = (void *)hInstance; handlePtr->findSymbolProcPtr = &FindSymbol; handlePtr->unloadFileProcPtr = &UnloadFile; *loadHandle = handlePtr; @@ -259,7 +259,7 @@ UnloadFile( HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData; FreeLibrary(hInstance); - ckfree(loadHandle); + Tcl_Free(loadHandle); } /* @@ -390,7 +390,7 @@ InitDLLDirectoryName(void) */ copyToGlobalBuffer: - dllDirectoryName = (WCHAR *)ckalloc((nameLen+1) * sizeof(WCHAR)); + dllDirectoryName = (WCHAR *)Tcl_Alloc((nameLen+1) * sizeof(WCHAR)); wcscpy(dllDirectoryName, name); return TCL_OK; } diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index 7b7ef1e..de4f8f2 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -76,7 +76,7 @@ static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message, *---------------------------------------------------------------------- */ -ClientData +void * TclpInitNotifier(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -100,7 +100,7 @@ TclpInitNotifier(void) clazz.style = 0; clazz.cbClsExtra = 0; clazz.cbWndExtra = 0; - clazz.hInstance = TclWinGetTclInstance(); + clazz.hInstance = (HINSTANCE) TclWinGetTclInstance(); clazz.hbrBackground = NULL; clazz.lpszMenuName = NULL; clazz.lpszClassName = className; @@ -148,7 +148,7 @@ TclpInitNotifier(void) void TclpFinalizeNotifier( - ClientData clientData) /* Pointer to notifier data. */ + void *clientData) /* Pointer to notifier data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; @@ -188,7 +188,7 @@ TclpFinalizeNotifier( if (notifierCount) { notifierCount--; if (notifierCount == 0) { - UnregisterClassW(className, TclWinGetTclInstance()); + UnregisterClassW(className, (HINSTANCE) TclWinGetTclInstance()); } } LeaveCriticalSection(¬ifierMutex); @@ -218,7 +218,7 @@ TclpFinalizeNotifier( void TclpAlertNotifier( - ClientData clientData) /* Pointer to thread data. */ + void *clientData) /* Pointer to thread data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; @@ -287,7 +287,7 @@ TclpSetTimer( * Windows seems to get confused by zero length timers. */ - timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + timeout = (UINT)timePtr->sec * 1000 + (unsigned long)timePtr->usec / 1000; if (timeout == 0) { timeout = 1; } @@ -337,7 +337,8 @@ TclpServiceModeHook( if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { tsdPtr->hwnd = CreateWindowW(className, className, WS_TILED, - 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); + 0, 0, 0, 0, NULL, NULL, (HINSTANCE) TclWinGetTclInstance(), + NULL); /* * Send an initial message to the window to ensure that we wake up the @@ -436,7 +437,7 @@ NotifierProc( *---------------------------------------------------------------------- */ -ClientData +void * TclpNotifierData(void) { return NULL; @@ -489,7 +490,7 @@ TclpWaitForEvent( TclScaleTime(&myTime); } - timeout = myTime.sec * 1000 + myTime.usec / 1000; + timeout = (DWORD)myTime.sec * 1000 + (unsigned long)myTime.usec / 1000; } else { timeout = INFINITE; } @@ -609,7 +610,7 @@ Tcl_Sleep( */ TclScaleTime(&vdelay); - sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; + sleepTime = (DWORD)vdelay.sec * 1000 + (unsigned long)vdelay.usec / 1000; for (;;) { SleepEx(sleepTime, TRUE); @@ -624,7 +625,7 @@ Tcl_Sleep( vdelay.usec = desired.usec - now.usec; TclScaleTime(&vdelay); - sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; + sleepTime = (DWORD)vdelay.sec * 1000 + (unsigned long)vdelay.usec / 1000; } } diff --git a/win/tclWinPanic.c b/win/tclWinPanic.c index 3131286..7928dcd 100644 --- a/win/tclWinPanic.c +++ b/win/tclWinPanic.c @@ -1,4 +1,4 @@ -/* + /* * tclWinPanic.c -- * * Contains the Windows-specific command-line panic proc. @@ -28,7 +28,7 @@ *---------------------------------------------------------------------- */ -void +TCL_NORETURN1 void Tcl_ConsolePanic( const char *format, ...) { diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 9cf8271..5a18ee3 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -61,7 +61,7 @@ typedef struct { typedef struct ProcInfo { HANDLE hProcess; - TCL_HASH_TYPE dwProcessId; + int dwProcessId; struct ProcInfo *nextPtr; } ProcInfo; @@ -104,7 +104,7 @@ typedef struct PipeInfo { TclFile readFile; /* Output from pipe. */ TclFile writeFile; /* Input from pipe. */ TclFile errorFile; /* Error output from pipe. */ - TCL_HASH_TYPE numPids; /* Number of processes attached to pipe. */ + size_t numPids; /* Number of processes attached to pipe. */ Tcl_Pid *pidPtr; /* Pids of attached processes. */ Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer @@ -171,7 +171,7 @@ typedef struct { static int ApplicationType(Tcl_Interp *interp, const char *fileName, char *fullName); -static void BuildCommandLine(const char *executable, Tcl_Size argc, +static void BuildCommandLine(const char *executable, size_t argc, const char **argv, Tcl_DString *linePtr); static BOOL HasConsole(void); static int PipeBlockModeProc(void *instanceData, int mode); @@ -203,7 +203,7 @@ static void PipeThreadActionProc(void *instanceData, static const Tcl_ChannelType pipeChannelType = { "pipe", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - TCL_CLOSE2PROC, /* Close proc. */ + NULL, /* Close proc. */ PipeInputProc, /* Input proc. */ PipeOutputProc, /* Output proc. */ NULL, /* Seek proc. */ @@ -402,7 +402,7 @@ PipeCheckProc( if (needEvent) { infoPtr->flags |= PIPE_PENDING; - evPtr = (PipeEvent *)ckalloc(sizeof(PipeEvent)); + evPtr = (PipeEvent *)Tcl_Alloc(sizeof(PipeEvent)); evPtr->header.proc = PipeEventProc; evPtr->infoPtr = infoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); @@ -433,7 +433,7 @@ TclWinMakeFile( { WinFile *filePtr; - filePtr = (WinFile *)ckalloc(sizeof(WinFile)); + filePtr = (WinFile *)Tcl_Alloc(sizeof(WinFile)); filePtr->type = WIN_FILE; filePtr->handle = handle; @@ -651,7 +651,7 @@ TclpCreateTempFile( const char *contents) /* String to write into temp file, or NULL. */ { WCHAR name[MAX_PATH]; - const char *native; + const char *native = NULL; Tcl_DString dstring; HANDLE handle; @@ -679,7 +679,10 @@ TclpCreateTempFile( * Convert the contents from UTF to native encoding */ - native = Tcl_UtfToExternalDString(NULL, contents, TCL_INDEX_NONE, &dstring); + if (Tcl_UtfToExternalDStringEx(NULL, NULL, contents, TCL_INDEX_NONE, 0, &dstring, NULL) != TCL_OK) { + goto error; + } + native = Tcl_DStringValue(&dstring); toCopy = Tcl_DStringLength(&dstring); for (p = native; toCopy > 0; p++, toCopy--) { @@ -719,7 +722,9 @@ TclpCreateTempFile( Tcl_DStringFree(&dstring); } - Tcl_WinConvertError(GetLastError()); + if (native != NULL) { + Tcl_WinConvertError(GetLastError()); + } CloseHandle(handle); DeleteFileW(name); return NULL; @@ -826,7 +831,7 @@ TclpCloseFile( if (filePtr->handle != NULL && CloseHandle(filePtr->handle) == FALSE) { Tcl_WinConvertError(GetLastError()); - ckfree(filePtr); + Tcl_Free(filePtr); return -1; } } @@ -836,7 +841,7 @@ TclpCloseFile( Tcl_Panic("TclpCloseFile: unexpected file type"); } - ckfree(filePtr); + Tcl_Free(filePtr); return 0; } @@ -869,13 +874,13 @@ TclpGetPid( Tcl_MutexLock(&pipeMutex); for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->dwProcessId == PTR2UINT(pid)) { + if (infoPtr->dwProcessId == (Tcl_Size)pid) { Tcl_MutexUnlock(&pipeMutex); return infoPtr->dwProcessId; } } Tcl_MutexUnlock(&pipeMutex); - return TCL_INDEX_NONE; + return -1; } /* @@ -911,7 +916,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - Tcl_Size argc, /* Number of arguments in following array. */ + size_t argc, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings. argv[0] contains * the name of the executable converted to * native format (using the @@ -1536,14 +1541,14 @@ static void BuildCommandLine( const char *executable, /* Full path of executable (including * extension). Replacement for argv[0]. */ - Tcl_Size argc, /* Number of arguments. */ + size_t argc, /* Number of arguments. */ const char **argv, /* Argument strings in UTF. */ Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the * command line (WCHAR). */ { const char *arg, *start, *special, *bspos; int quote = 0; - Tcl_Size i; + size_t i; Tcl_DString ds; #ifdef TCL_WIN_PIPE_FULLESC /* full escape inclusive %-subst avoidance */ @@ -1769,11 +1774,11 @@ TclpCreateCommandChannel( TclFile writeFile, /* If non-null, gives the file for writing. */ TclFile errorFile, /* If non-null, gives the file where errors * can be read. */ - Tcl_Size numPids, /* The number of pids in the pid array. */ + size_t numPids, /* The number of pids in the pid array. */ Tcl_Pid *pidPtr) /* An array of process identifiers. */ { char channelName[16 + TCL_INTEGER_SPACE]; - PipeInfo *infoPtr = (PipeInfo *)ckalloc(sizeof(PipeInfo)); + PipeInfo *infoPtr = (PipeInfo *)Tcl_Alloc(sizeof(PipeInfo)); PipeInit(); @@ -1836,14 +1841,7 @@ TclpCreateCommandChannel( infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, infoPtr, infoPtr->validMask); - /* - * Pipes have AUTO translation mode on Windows and ^Z eof char, which - * means that a ^Z will be appended to them at close. This is needed for - * Windows programs that expect a ^Z at EOF. - */ - Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\x1A {}"); return infoPtr->channel; } @@ -1915,8 +1913,8 @@ TclGetAndDetachPids( { PipeInfo *pipePtr; const Tcl_ChannelType *chanTypePtr; - Tcl_Obj *pidsObj, *elemPtr; - TCL_HASH_TYPE i; + Tcl_Obj *pidsObj; + size_t i; /* * Punt if the channel is not a command channel. @@ -1930,13 +1928,14 @@ TclGetAndDetachPids( pipePtr = (PipeInfo *)Tcl_GetChannelInstanceData(chan); TclNewObj(pidsObj); for (i = 0; i < pipePtr->numPids; i++) { - TclNewIntObj(elemPtr, TclpGetPid(pipePtr->pidPtr[i])); - Tcl_ListObjAppendElement(NULL, pidsObj, elemPtr); + Tcl_ListObjAppendElement(NULL, pidsObj, + Tcl_NewWideIntObj( + TclpGetPid(pipePtr->pidPtr[i]))); Tcl_DetachPids(1, &pipePtr->pidPtr[i]); } Tcl_SetObjResult(interp, pidsObj); if (pipePtr->numPids > 0) { - ckfree(pipePtr->pidPtr); + Tcl_Free(pipePtr->pidPtr); pipePtr->numPids = 0; } } @@ -2121,10 +2120,12 @@ PipeClose2Proc( if (pipePtr->errorFile) { WinFile *filePtr = (WinFile *) pipePtr->errorFile; - errChan = Tcl_MakeFileChannel((void *)filePtr->handle, + errChan = Tcl_MakeFileChannel((void *) filePtr->handle, TCL_READABLE); - ckfree(filePtr); - } else { + Tcl_Free(filePtr); + Tcl_SetChannelOption(NULL, errChan, "-profile", "replace"); + } + else { errChan = NULL; } @@ -2133,14 +2134,14 @@ PipeClose2Proc( } if (pipePtr->numPids > 0) { - ckfree(pipePtr->pidPtr); + Tcl_Free(pipePtr->pidPtr); } if (pipePtr->writeBuf != NULL) { - ckfree(pipePtr->writeBuf); + Tcl_Free(pipePtr->writeBuf); } - ckfree(pipePtr); + Tcl_Free(pipePtr); if (errorCode == 0) { return result; @@ -2309,10 +2310,10 @@ PipeOutputProc( */ if (infoPtr->writeBuf) { - ckfree(infoPtr->writeBuf); + Tcl_Free(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = (char *)ckalloc(toWrite); + infoPtr->writeBuf = (char *)Tcl_Alloc(toWrite); } memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; @@ -2574,7 +2575,7 @@ Tcl_WaitPid( prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { - if (infoPtr->dwProcessId == PTR2UINT(pid)) { + if (infoPtr->dwProcessId == (Tcl_Size)pid) { *prevPtrPtr = infoPtr->nextPtr; break; } @@ -2684,7 +2685,7 @@ Tcl_WaitPid( } else { errno = ECHILD; *statPtr = 0xC0000000 | ECHILD; - result = (Tcl_Pid) -1; + result = (Tcl_Pid)-1; } /* @@ -2692,7 +2693,7 @@ Tcl_WaitPid( */ CloseHandle(infoPtr->hProcess); - ckfree(infoPtr); + Tcl_Free(infoPtr); return result; } @@ -2720,7 +2721,7 @@ TclWinAddProcess( void *hProcess, /* Handle to process */ Tcl_Size id) /* Global process identifier */ { - ProcInfo *procPtr = (ProcInfo *)ckalloc(sizeof(ProcInfo)); + ProcInfo *procPtr = (ProcInfo *)Tcl_Alloc(sizeof(ProcInfo)); PipeInit(); @@ -2759,18 +2760,17 @@ Tcl_PidObjCmd( Tcl_Channel chan; const Tcl_ChannelType *chanTypePtr; PipeInfo *pipePtr; - TCL_HASH_TYPE i; - Tcl_Obj *resultPtr, *elemPtr; + size_t i; + Tcl_Obj *resultPtr; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); return TCL_ERROR; } if (objc == 1) { - TclNewIntObj(elemPtr, getpid()); - Tcl_SetObjResult(interp, elemPtr); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid())); } else { - chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), + chan = Tcl_GetChannel(interp, TclGetString(objv[1]), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; @@ -2783,8 +2783,9 @@ Tcl_PidObjCmd( pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); TclNewObj(resultPtr); for (i = 0; i < pipePtr->numPids; i++) { - TclNewIntObj(elemPtr, TclpGetPid(pipePtr->pidPtr[i])); - Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, elemPtr); + Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, + Tcl_NewWideIntObj( + TclpGetPid(pipePtr->pidPtr[i]))); } Tcl_SetObjResult(interp, resultPtr); } @@ -3221,7 +3222,7 @@ TclpOpenTemporaryFile( } namePtr += length * sizeof(WCHAR); if (basenameObj) { - const char *string = TclGetStringFromObj(basenameObj, &length); + const char *string = Tcl_GetStringFromObj(basenameObj, &length); Tcl_DStringInit(&buf); Tcl_UtfToWCharDString(string, length, &buf); @@ -3297,7 +3298,7 @@ TclPipeThreadCreateTI( #ifndef _PTI_USE_CKALLOC pipeTI = (TclPipeThreadInfo *)malloc(sizeof(TclPipeThreadInfo)); #else - pipeTI = (TclPipeThreadInfo *)ckalloc(sizeof(TclPipeThreadInfo)); + pipeTI = (TclPipeThreadInfo *)Tcl_Alloc(sizeof(TclPipeThreadInfo)); #endif /* !_PTI_USE_CKALLOC */ pipeTI->evControl = CreateEventW(NULL, FALSE, FALSE, NULL); pipeTI->state = PTI_STATE_IDLE; @@ -3658,7 +3659,7 @@ TclPipeThreadStop( #ifndef _PTI_USE_CKALLOC free(pipeTI); #else - ckfree(pipeTI); + Tcl_Free(pipeTI); #endif /* !_PTI_USE_CKALLOC */ } } @@ -3708,7 +3709,7 @@ TclPipeThreadExit( #ifndef _PTI_USE_CKALLOC free(pipeTI); #else - ckfree(pipeTI); + Tcl_Free(pipeTI); /* be sure all subsystems used are finalized */ Tcl_FinalizeThread(); #endif /* !_PTI_USE_CKALLOC */ diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 9eb949b..f549420 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -511,12 +511,12 @@ typedef DWORD_PTR * PDWORD_PTR; * use by tclAlloc.c. */ -#define TclpSysAlloc(size, isBin) ((void*)HeapAlloc(GetProcessHeap(), \ - (DWORD)0, (DWORD)size)) +#define TclpSysAlloc(size) ((void*)HeapAlloc(GetProcessHeap(), \ + 0, size)) #define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \ - (DWORD)0, (HGLOBAL)ptr)) + 0, (HGLOBAL)ptr)) #define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \ - (DWORD)0, (LPVOID)ptr, (DWORD)size)) + 0, (LPVOID)ptr, size)) /* This type is not defined in the Windows headers */ #define socklen_t int @@ -527,7 +527,7 @@ typedef DWORD_PTR * PDWORD_PTR; * address platform-specific issues. */ -#define TclpReleaseFile(file) ckfree(file) +#define TclpReleaseFile(file) Tcl_Free(file) /* * The following macros and declarations wrap the C runtime library @@ -544,7 +544,4 @@ typedef DWORD_PTR * PDWORD_PTR; # define LABEL_SECURITY_INFORMATION (0x00000010L) #endif -#define Tcl_DirEntry void -#define TclDIR void - #endif /* _TCLWINPORT */ diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index cc72762..48a0ffc 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -165,30 +165,30 @@ static COMMTIMEOUTS no_timeout = { * Declarations for functions used only in this file. */ -static int SerialBlockProc(ClientData instanceData, int mode); -static void SerialCheckProc(ClientData clientData, int flags); -static int SerialCloseProc(ClientData instanceData, +static int SerialBlockProc(void *instanceData, int mode); +static void SerialCheckProc(void *clientData, int flags); +static int SerialCloseProc(void *instanceData, Tcl_Interp *interp, int flags); static int SerialEventProc(Tcl_Event *evPtr, int flags); -static void SerialExitHandler(ClientData clientData); -static int SerialGetHandleProc(ClientData instanceData, - int direction, ClientData *handlePtr); +static void SerialExitHandler(void *clientData); +static int SerialGetHandleProc(void *instanceData, + int direction, void **handlePtr); static ThreadSpecificData *SerialInit(void); -static int SerialInputProc(ClientData instanceData, char *buf, +static int SerialInputProc(void *instanceData, char *buf, int toRead, int *errorCode); -static int SerialOutputProc(ClientData instanceData, +static int SerialOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); -static void SerialSetupProc(ClientData clientData, int flags); -static void SerialWatchProc(ClientData instanceData, int mask); -static void ProcExitHandler(ClientData clientData); -static int SerialGetOptionProc(ClientData instanceData, +static void SerialSetupProc(void *clientData, int flags); +static void SerialWatchProc(void *instanceData, int mask); +static void ProcExitHandler(void *clientData); +static int SerialGetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); -static int SerialSetOptionProc(ClientData instanceData, +static int SerialSetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, const char *value); static DWORD WINAPI SerialWriterThread(LPVOID arg); -static void SerialThreadActionProc(ClientData instanceData, +static void SerialThreadActionProc(void *instanceData, int action); static int SerialBlockingRead(SerialInfo *infoPtr, LPVOID buf, DWORD bufSize, LPDWORD lpRead, LPOVERLAPPED osPtr); @@ -204,7 +204,7 @@ static int SerialBlockingWrite(SerialInfo *infoPtr, LPVOID buf, static const Tcl_ChannelType serialChannelType = { "serial", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - TCL_CLOSE2PROC, /* Close proc. */ + NULL, /* Close proc. */ SerialInputProc, /* Input proc. */ SerialOutputProc, /* Output proc. */ NULL, /* Seek proc. */ @@ -285,7 +285,7 @@ SerialInit(void) static void SerialExitHandler( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); SerialInfo *infoPtr; @@ -323,7 +323,7 @@ SerialExitHandler( static void ProcExitHandler( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { Tcl_MutexLock(&serialMutex); initialized = 0; @@ -406,7 +406,7 @@ SerialGetMilliseconds(void) void SerialSetupProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { SerialInfo *infoPtr; @@ -461,7 +461,7 @@ SerialSetupProc( static void SerialCheckProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { SerialInfo *infoPtr; @@ -535,7 +535,7 @@ SerialCheckProc( if (needEvent) { infoPtr->flags |= SERIAL_PENDING; - evPtr = (SerialEvent *)ckalloc(sizeof(SerialEvent)); + evPtr = (SerialEvent *)Tcl_Alloc(sizeof(SerialEvent)); evPtr->header.proc = SerialEventProc; evPtr->infoPtr = infoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); @@ -561,7 +561,7 @@ SerialCheckProc( static int SerialBlockProc( - ClientData instanceData, /* Instance data for channel. */ + void *instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { @@ -600,7 +600,7 @@ SerialBlockProc( static int SerialCloseProc( - ClientData instanceData, /* Pointer to SerialInfo structure. */ + void *instanceData, /* Pointer to SerialInfo structure. */ TCL_UNUSED(Tcl_Interp *), int flags) { @@ -670,10 +670,10 @@ SerialCloseProc( */ if (serialPtr->writeBuf != NULL) { - ckfree(serialPtr->writeBuf); + Tcl_Free(serialPtr->writeBuf); serialPtr->writeBuf = NULL; } - ckfree(serialPtr); + Tcl_Free(serialPtr); if (errorCode == 0) { return result; @@ -796,7 +796,7 @@ SerialBlockingWrite( LeaveCriticalSection(&infoPtr->csWrite); if (result == FALSE) { - int err = GetLastError(); + DWORD err = GetLastError(); switch (err) { case ERROR_IO_PENDING: @@ -855,7 +855,7 @@ SerialBlockingWrite( static int SerialInputProc( - ClientData instanceData, /* Serial state. */ + void *instanceData, /* Serial state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ @@ -962,7 +962,7 @@ SerialInputProc( static int SerialOutputProc( - ClientData instanceData, /* Serial state. */ + void *instanceData, /* Serial state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ @@ -1035,10 +1035,10 @@ SerialOutputProc( */ if (infoPtr->writeBuf) { - ckfree(infoPtr->writeBuf); + Tcl_Free(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = (char *)ckalloc(toWrite); + infoPtr->writeBuf = (char *)Tcl_Alloc(toWrite); } memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; @@ -1192,7 +1192,7 @@ SerialEventProc( static void SerialWatchProc( - ClientData instanceData, /* Serial state. */ + void *instanceData, /* Serial state. */ int mask) /* What events to watch for, OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ @@ -1249,13 +1249,13 @@ SerialWatchProc( static int SerialGetHandleProc( - ClientData instanceData, /* The serial state. */ + void *instanceData, /* The serial state. */ TCL_UNUSED(int) /*direction*/, - ClientData *handlePtr) /* Where to store the handle. */ + void **handlePtr) /* Where to store the handle. */ { SerialInfo *infoPtr = (SerialInfo *) instanceData; - *handlePtr = (ClientData) infoPtr->handle; + *handlePtr = (void *) infoPtr->handle; return TCL_OK; } @@ -1455,7 +1455,7 @@ TclWinOpenSerialChannel( SerialInit(); - infoPtr = (SerialInfo *)ckalloc(sizeof(SerialInfo)); + infoPtr = (SerialInfo *)Tcl_Alloc(sizeof(SerialInfo)); memset(infoPtr, 0, sizeof(SerialInfo)); infoPtr->validMask = permissions & (TCL_READABLE|TCL_WRITABLE); @@ -1508,13 +1508,7 @@ TclWinOpenSerialChannel( infoPtr->evWritable), 0, NULL); } - /* - * Files have default translation of AUTO and ^Z eof char, which means - * that a ^Z will be accepted as EOF when reading. - */ - Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\x1A {}"); return infoPtr->channel; } @@ -1619,7 +1613,7 @@ SerialModemStatusStr( static int SerialSetOptionProc( - ClientData instanceData, /* File state. */ + void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ @@ -1662,7 +1656,7 @@ SerialSetOptionProc( "bad mode \"%s\" for -closemode: must be" " default, discard, or drain", value)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", - "VALUE", (char *)NULL); + "VALUE", (void *)NULL); } return TCL_ERROR; } @@ -1687,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", (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (void *)NULL); } return TCL_ERROR; } @@ -1751,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", (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", (void *)NULL); } return TCL_ERROR; } @@ -1780,9 +1774,9 @@ 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", (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", (void *)NULL); } - ckfree(argv); + Tcl_Free((void *)argv); return TCL_ERROR; } @@ -1813,7 +1807,7 @@ SerialSetOptionProc( } dcb.XoffChar = (char) character; } - ckfree(argv); + Tcl_Free((void *)argv); if (!SetCommState(infoPtr->handle, &dcb)) { goto setStateFailed; @@ -1837,9 +1831,9 @@ 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", (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", (void *)NULL); } - ckfree(argv); + Tcl_Free((void *)argv); return TCL_ERROR; } @@ -1855,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", (char *)NULL); + "FCONFIGURE", "TTY_SIGNAL", (void *)NULL); } res = TCL_ERROR; break; @@ -1867,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", (char *)NULL); + "FCONFIGURE", "TTY_SIGNAL", (void *)NULL); } res = TCL_ERROR; break; @@ -1879,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", (char *)NULL); + "FCONFIGURE", "TTY_SIGNAL", (void *)NULL); } res = TCL_ERROR; break; @@ -1890,14 +1884,14 @@ SerialSetOptionProc( "bad signal name \"%s\" for -ttycontrol: must be" " DTR, RTS or BREAK", argv[i])); Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL", - (char *)NULL); + (void *)NULL); } res = TCL_ERROR; break; } } - ckfree(argv); + Tcl_Free((void *)argv); return res; } @@ -1923,14 +1917,14 @@ SerialSetOptionProc( inSize = atoi(argv[0]); outSize = atoi(argv[1]); } - ckfree(argv); + Tcl_Free((void *)argv); if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) { if (interp != NULL) { 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", (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", (void *)NULL); } return TCL_ERROR; } @@ -2043,7 +2037,7 @@ SerialSetOptionProc( static int SerialGetOptionProc( - ClientData instanceData, /* File state. */ + void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ @@ -2280,7 +2274,7 @@ SerialGetOptionProc( static void SerialThreadActionProc( - ClientData instanceData, + void *instanceData, int action) { SerialInfo *infoPtr = (SerialInfo *) instanceData; diff --git a/win/tclWinSock.c b/win/tclWinSock.c index c34835b..f54d8a1 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -243,12 +243,12 @@ static int FindFDInList(TcpState *statePtr, SOCKET socket); static DWORD WINAPI SocketThread(LPVOID arg); static void TcpThreadActionProc(void *instanceData, int action); +static int TcpCloseProc(void *, Tcl_Interp *); static Tcl_EventCheckProc SocketCheckProc; static Tcl_EventProc SocketEventProc; static Tcl_EventSetupProc SocketSetupProc; static Tcl_DriverBlockModeProc TcpBlockModeProc; -static Tcl_DriverCloseProc TcpCloseProc; static Tcl_DriverClose2Proc TcpClose2Proc; static Tcl_DriverSetOptionProc TcpSetOptionProc; static Tcl_DriverGetOptionProc TcpGetOptionProc; @@ -265,11 +265,7 @@ static Tcl_DriverGetHandleProc TcpGetHandleProc; static const Tcl_ChannelType tcpChannelType = { "tcp", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ -#ifndef TCL_NO_DEPRECATED - TcpCloseProc, /* Close proc. */ -#else - TCL_CLOSE2PROC, /* Close proc. */ -#endif + NULL, /* Close proc. */ TcpInputProc, /* Input proc. */ TcpOutputProc, /* Output proc. */ NULL, /* Seek proc. */ @@ -349,7 +345,7 @@ printaddrinfolist( void InitializeHostName( char **valuePtr, - TCL_HASH_TYPE *lengthPtr, + size_t *lengthPtr, Tcl_Encoding *encodingPtr) { WCHAR wbuf[256]; @@ -377,15 +373,15 @@ InitializeHostName( Tcl_DStringSetLength(&inDs, 256); if (gethostname(Tcl_DStringValue(&inDs), Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), - TCL_INDEX_NONE, &ds); + Tcl_ExternalToUtfDStringEx(NULL, NULL, Tcl_DStringValue(&inDs), + TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); } Tcl_DStringFree(&inDs); } *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); *lengthPtr = Tcl_DStringLength(&ds); - *valuePtr = (char *)ckalloc(*lengthPtr + 1); + *valuePtr = (char *)Tcl_Alloc(*lengthPtr + 1); memcpy(*valuePtr, Tcl_DStringValue(&ds), *lengthPtr + 1); Tcl_DStringFree(&ds); } @@ -1057,7 +1053,7 @@ TcpCloseProc( Tcl_WinConvertError((DWORD) WSAGetLastError()); errorCode = Tcl_GetErrno(); } - ckfree(thisfd); + Tcl_Free(thisfd); } if (statePtr->addrlist != NULL) { @@ -1098,7 +1094,7 @@ TcpCloseProc( * fear of damaging the list. */ - ckfree(statePtr); + Tcl_Free(statePtr); return errorCode; } @@ -2032,11 +2028,11 @@ Tcl_OpenTcpClient( statePtr, (TCL_READABLE | TCL_WRITABLE)); if (TCL_ERROR == Tcl_SetChannelOption(NULL, statePtr->channel, "-translation", "auto crlf")) { - Tcl_Close(NULL, statePtr->channel); + Tcl_CloseEx(NULL, statePtr->channel, 0); return NULL; } else if (TCL_ERROR == Tcl_SetChannelOption(NULL, statePtr->channel, "-eofchar", "")) { - Tcl_Close(NULL, statePtr->channel); + Tcl_CloseEx(NULL, statePtr->channel, 0); return NULL; } return statePtr->channel; @@ -2275,7 +2271,7 @@ Tcl_OpenTcpServerEx( SendSelectMessage(tsdPtr, SELECT, statePtr); if (Tcl_SetChannelOption(interp, statePtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close(NULL, statePtr->channel); + Tcl_CloseEx(NULL, statePtr->channel, 0); return NULL; } return statePtr->channel; @@ -2347,12 +2343,12 @@ TcpAccept( newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation", "auto crlf") == TCL_ERROR) { - Tcl_Close(NULL, newInfoPtr->channel); + Tcl_CloseEx(NULL, newInfoPtr->channel, 0); return; } if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close(NULL, newInfoPtr->channel); + Tcl_CloseEx(NULL, newInfoPtr->channel, 0); return; } @@ -2549,7 +2545,7 @@ SocketCheckProc( statePtr->watchEvents | FD_CONNECT | FD_ACCEPT) && !GOT_BITS(statePtr->flags, SOCKET_PENDING)) { SET_BITS(statePtr->flags, SOCKET_PENDING); - evPtr = (SocketEvent *)ckalloc(sizeof(SocketEvent)); + evPtr = (SocketEvent *)Tcl_Alloc(sizeof(SocketEvent)); evPtr->header.proc = SocketEventProc; evPtr->socket = statePtr->sockets->fd; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); @@ -2824,7 +2820,7 @@ AddSocketInfoFd( * Add the first FD. */ - statePtr->sockets = (TcpFdList *)ckalloc(sizeof(TcpFdList)); + statePtr->sockets = (TcpFdList *)Tcl_Alloc(sizeof(TcpFdList)); fds = statePtr->sockets; } else { /* @@ -2835,7 +2831,7 @@ AddSocketInfoFd( fds = fds->next; } - fds->next = (TcpFdList *)ckalloc(sizeof(TcpFdList)); + fds->next = (TcpFdList *)Tcl_Alloc(sizeof(TcpFdList)); fds = fds->next; } @@ -2868,7 +2864,7 @@ AddSocketInfoFd( static TcpState * NewSocketInfo(SOCKET socket) { - TcpState *statePtr = (TcpState *)ckalloc(sizeof(TcpState)); + TcpState *statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); @@ -3231,68 +3227,6 @@ FindFDInList( /* *---------------------------------------------------------------------- * - * TclWinGetSockOpt, et al. -- - * - * Those functions are historically exported by the stubs table and - * just use the original system calls now. - * - * Warning: - * Those functions are depreciated and will be removed with TCL 9.0. - * - * Results: - * As defined for each function. - * - * Side effects: - * As defined for each function. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -#undef TclWinGetSockOpt -int -TclWinGetSockOpt( - SOCKET s, - int level, - int optname, - char *optval, - int *optlen) -{ - - return getsockopt(s, level, optname, optval, optlen); -} -#undef TclWinSetSockOpt -int -TclWinSetSockOpt( - SOCKET s, - int level, - int optname, - const char *optval, - int optlen) -{ - return setsockopt(s, level, optname, optval, optlen); -} - -#undef TclpInetNtoa -char * -TclpInetNtoa( - struct in_addr addr) -{ - return inet_ntoa(addr); -} -#undef TclWinGetServByName -struct servent * -TclWinGetServByName( - const char *name, - const char *proto) -{ - return getservbyname(name, proto); -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * TcpThreadActionProc -- * * Insert or remove any thread local refs to this channel. diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 86f36b4..1b679a9 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -9,6 +9,8 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#undef BUILD_tcl +#undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif @@ -40,7 +42,6 @@ static Tcl_ObjCmdProc TesteventloopCmd; static Tcl_ObjCmdProc TestvolumetypeCmd; static Tcl_ObjCmdProc TestwinclockCmd; static Tcl_ObjCmdProc TestwinsleepCmd; -static Tcl_ObjCmdProc TestSizeCmd; static Tcl_ObjCmdProc TestExceptionCmd; static int TestplatformChmod(const char *nativePath, int pmode); static Tcl_ObjCmdProc TestchmodCmd; @@ -77,7 +78,6 @@ TclplatformtestInit( Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testsize", TestSizeCmd, NULL, NULL); return TCL_OK; } @@ -101,7 +101,7 @@ TclplatformtestInit( static int TesteventloopCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -177,7 +177,7 @@ TesteventloopCmd( static int TestvolumetypeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -243,7 +243,7 @@ TestvolumetypeCmd( static int TestwinclockCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Argument count */ Tcl_Obj *const objv[]) /* Argument vector */ @@ -292,7 +292,7 @@ TestwinclockCmd( static int TestwinsleepCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const * objv) /* Parameter vector */ @@ -310,28 +310,6 @@ TestwinsleepCmd( return TCL_OK; } -static int -TestSizeCmd( - TCL_UNUSED(ClientData), - Tcl_Interp* interp, /* Tcl interpreter */ - int objc, /* Parameter count */ - Tcl_Obj *const * objv) /* Parameter vector */ -{ - - if (objc != 2) { - goto syntax; - } - if (strcmp(Tcl_GetString(objv[1]), "st_mtime") == 0) { - Tcl_StatBuf *statPtr; - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(statPtr->st_mtime))); - return TCL_OK; - } - -syntax: - Tcl_WrongNumArgs(interp, 1, objv, "st_mtime"); - return TCL_ERROR; -} - /* *---------------------------------------------------------------------- * @@ -357,7 +335,7 @@ syntax: static int TestExceptionCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Argument count */ Tcl_Obj *const objv[]) /* Argument vector */ @@ -480,16 +458,16 @@ TestplatformChmod( GetLastError() != ERROR_INSUFFICIENT_BUFFER) { goto done; } - pTokenUser = (TOKEN_USER *)ckalloc(dw); + pTokenUser = (TOKEN_USER *)Tcl_Alloc(dw); if (!GetTokenInformation(hToken, TokenUser, pTokenUser, dw, &dw)) { goto done; } aceEntry[nSids].sidLen = GetLengthSid(pTokenUser->User.Sid); - aceEntry[nSids].pSid = ckalloc(aceEntry[nSids].sidLen); + aceEntry[nSids].pSid = Tcl_Alloc(aceEntry[nSids].sidLen); if (!CopySid(aceEntry[nSids].sidLen, aceEntry[nSids].pSid, pTokenUser->User.Sid)) { - ckfree(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */ + Tcl_Free(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */ goto done; } /* @@ -522,19 +500,19 @@ TestplatformChmod( GetLastError() != ERROR_INSUFFICIENT_BUFFER) { goto done; } - pTokenGroup = (TOKEN_PRIMARY_GROUP *)ckalloc(dw); + pTokenGroup = (TOKEN_PRIMARY_GROUP *)Tcl_Alloc(dw); if (!GetTokenInformation(hToken, TokenPrimaryGroup, pTokenGroup, dw, &dw)) { - ckfree(pTokenGroup); + Tcl_Free(pTokenGroup); goto done; } aceEntry[nSids].sidLen = GetLengthSid(pTokenGroup->PrimaryGroup); - aceEntry[nSids].pSid = ckalloc(aceEntry[nSids].sidLen); + aceEntry[nSids].pSid = Tcl_Alloc(aceEntry[nSids].sidLen); if (!CopySid(aceEntry[nSids].sidLen, aceEntry[nSids].pSid, pTokenGroup->PrimaryGroup)) { - ckfree(pTokenGroup); - ckfree(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */ + Tcl_Free(pTokenGroup); + Tcl_Free(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */ goto done; } - ckfree(pTokenGroup); + Tcl_Free(pTokenGroup); /* Generate mask for group ACL */ @@ -558,10 +536,10 @@ TestplatformChmod( goto done; } aceEntry[nSids].sidLen = GetLengthSid(pWorldSid); - aceEntry[nSids].pSid = ckalloc(aceEntry[nSids].sidLen); + aceEntry[nSids].pSid = Tcl_Alloc(aceEntry[nSids].sidLen); if (!CopySid(aceEntry[nSids].sidLen, aceEntry[nSids].pSid, pWorldSid)) { LocalFree(pWorldSid); - ckfree(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */ + Tcl_Free(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */ goto done; } LocalFree(pWorldSid); @@ -589,7 +567,7 @@ TestplatformChmod( newAclSize += offsetof(ACCESS_ALLOWED_ACE, SidStart) + aceEntry[i].sidLen; } - newAcl = (PACL)ckalloc(newAclSize); + newAcl = (PACL)Tcl_Alloc(newAclSize); if (!InitializeAcl(newAcl, newAclSize, ACL_REVISION)) { goto done; } @@ -618,16 +596,16 @@ TestplatformChmod( done: if (pTokenUser) { - ckfree(pTokenUser); + Tcl_Free(pTokenUser); } if (hToken) { CloseHandle(hToken); } if (newAcl) { - ckfree(newAcl); + Tcl_Free(newAcl); } for (i = 0; i < nSids; ++i) { - ckfree(aceEntry[i].pSid); + Tcl_Free(aceEntry[i].pSid); } if (res != 0) { @@ -637,6 +615,7 @@ TestplatformChmod( /* Run normal chmod command */ return chmod(nativePath, pmode); + } /* @@ -660,7 +639,7 @@ TestplatformChmod( static int TestchmodCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Parameter count */ Tcl_Obj *const * objv) /* Parameter vector */ diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index da9133f..37e0841 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -178,7 +178,7 @@ TclWinThreadStart( lpOrigStartAddress = winThreadPtr->lpStartAddress; lpOrigParameter = winThreadPtr->lpParameter; - ckfree(winThreadPtr); + Tcl_Free(winThreadPtr); return lpOrigStartAddress(lpOrigParameter); } @@ -203,15 +203,15 @@ int TclpThreadCreate( Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */ - ClientData clientData, /* The one argument to Main(). */ - TCL_HASH_TYPE stackSize, /* Size of stack for the new thread. */ + void *clientData, /* The one argument to Main(). */ + size_t stackSize, /* Size of stack for the new thread. */ int flags) /* Flags controlling behaviour of the new * thread. */ { WinThread *winThreadPtr; /* Per-thread startup info */ HANDLE tHandle; - winThreadPtr = (WinThread *)ckalloc(sizeof(WinThread)); + winThreadPtr = (WinThread *)Tcl_Alloc(sizeof(WinThread)); winThreadPtr->lpStartAddress = (LPTHREAD_START_ROUTINE) proc; winThreadPtr->lpParameter = clientData; winThreadPtr->fpControl = _controlfp(0, 0); @@ -535,7 +535,7 @@ TclFinalizeLock(void) #if TCL_THREADS /* locally used prototype */ -static void FinalizeConditionEvent(ClientData data); +static void FinalizeConditionEvent(void *data); /* *---------------------------------------------------------------------- @@ -568,7 +568,7 @@ Tcl_MutexLock( */ if (*mutexPtr == NULL) { - csPtr = (CRITICAL_SECTION *)ckalloc(sizeof(CRITICAL_SECTION)); + csPtr = (CRITICAL_SECTION *)Tcl_Alloc(sizeof(CRITICAL_SECTION)); InitializeCriticalSection(csPtr); *mutexPtr = (Tcl_Mutex)csPtr; TclRememberMutex(mutexPtr); @@ -629,7 +629,7 @@ TclpFinalizeMutex( if (csPtr != NULL) { DeleteCriticalSection(csPtr); - ckfree(csPtr); + Tcl_Free(csPtr); *mutexPtr = NULL; } } @@ -711,7 +711,7 @@ Tcl_ConditionWait( */ if (*condPtr == NULL) { - winCondPtr = (WinCondition *)ckalloc(sizeof(WinCondition)); + winCondPtr = (WinCondition *)Tcl_Alloc(sizeof(WinCondition)); InitializeCriticalSection(&winCondPtr->condLock); winCondPtr->firstPtr = NULL; winCondPtr->lastPtr = NULL; @@ -880,7 +880,7 @@ Tcl_ConditionNotify( static void FinalizeConditionEvent( - ClientData data) + void *data) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) data; @@ -922,7 +922,7 @@ TclpFinalizeCondition( if (winCondPtr != NULL) { DeleteCriticalSection(&winCondPtr->condLock); - ckfree(winCondPtr); + Tcl_Free(winCondPtr); *condPtr = NULL; } } @@ -1037,7 +1037,7 @@ TclpThreadCreateKey(void) { DWORD *key; - key = (DWORD *)TclpSysAlloc(sizeof *key, 0); + key = (DWORD *)TclpSysAlloc(sizeof *key); if (key == NULL) { Tcl_Panic("unable to allocate thread key!"); } diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 6fecbd2..a0c7833 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -12,10 +12,6 @@ #include "tclInt.h" -#define SECSPERDAY (60L * 60L * 24L) -#define SECSPERYEAR (SECSPERDAY * 365L) -#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY) - /* * Number of samples over which to estimate the performance counter. */ @@ -23,27 +19,6 @@ #define SAMPLES 64 /* - * The following arrays contain the day of year for the last day of each - * month, where index 1 is January. - */ - -#ifndef TCL_NO_DEPRECATED -static const int normalDays[] = { - -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364 -}; - -static const int leapDays[] = { - -1, 30, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 -}; - -typedef struct { - char tzName[64]; /* Time zone name */ - struct tm tm; /* time information */ -} ThreadSpecificData; -static Tcl_ThreadDataKey dataKey; -#endif /* TCL_NO_DEPRECATED */ - -/* * Data for managing high-resolution timers. */ @@ -133,10 +108,7 @@ static struct { * Declarations for functions defined later in this file. */ -#ifndef TCL_NO_DEPRECATED -static struct tm * ComputeGMT(const time_t *tp); -#endif /* TCL_NO_DEPRECATED */ -static void StopCalibration(ClientData clientData); +static void StopCalibration(void *clientData); static DWORD WINAPI CalibrationThread(LPVOID arg); static void UpdateTimeEachSecond(void); static void ResetCounterSamples(unsigned long long fileTime, @@ -144,10 +116,10 @@ static void ResetCounterSamples(unsigned long long fileTime, static long long AccumulateSample(long long perfCounter, unsigned long long fileTime); static void NativeScaleTime(Tcl_Time* timebuf, - ClientData clientData); + void *clientData); static long long NativeGetMicroseconds(void); static void NativeGetTime(Tcl_Time* timebuf, - ClientData clientData); + void *clientData); /* * TIP #233 (Virtualized Time): Data for the time hooks, if any. @@ -155,7 +127,7 @@ static void NativeGetTime(Tcl_Time* timebuf, Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime; Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime; -ClientData tclTimeClientData = NULL; +void *tclTimeClientData = NULL; /* * Inlined version of Tcl_GetTime. @@ -191,7 +163,7 @@ IsTimeNative(void) *---------------------------------------------------------------------- */ -unsigned long +unsigned long long TclpGetSeconds(void) { long long usecSincePosixEpoch; @@ -206,7 +178,7 @@ TclpGetSeconds(void) Tcl_Time t; GetTime(&t); - return t.sec; + return (unsigned long long)t.sec; } } @@ -229,7 +201,7 @@ TclpGetSeconds(void) *---------------------------------------------------------------------- */ -unsigned long +unsigned long long TclpGetClicks(void) { long long usecSincePosixEpoch; @@ -239,7 +211,7 @@ TclpGetClicks(void) */ if (IsTimeNative() && (usecSincePosixEpoch = NativeGetMicroseconds())) { - return (unsigned long) usecSincePosixEpoch; + return (Tcl_WideUInt) usecSincePosixEpoch; } else { /* * Use the Tcl_GetTime abstraction to get the time in microseconds, as @@ -249,7 +221,8 @@ TclpGetClicks(void) Tcl_Time now; /* Current Tcl time */ GetTime(&now); - return ((unsigned long)(now.sec)*1000000UL) + (unsigned long)(now.usec); + return ((unsigned long long)(now.sec)*1000000ULL) + + (unsigned long long)(now.usec); } } @@ -374,7 +347,7 @@ TclpGetMicroseconds(void) Tcl_Time now; GetTime(&now); - return (((long long) now.sec) * 1000000) + now.usec; + return now.sec * 1000000 + now.usec; } } @@ -411,8 +384,8 @@ Tcl_GetTime( */ if (IsTimeNative() && (usecSincePosixEpoch = NativeGetMicroseconds())) { - timePtr->sec = (long) (usecSincePosixEpoch / 1000000); - timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); + timePtr->sec = usecSincePosixEpoch / 1000000; + timePtr->usec = usecSincePosixEpoch % 1000000; } else { GetTime(timePtr); } @@ -438,7 +411,7 @@ Tcl_GetTime( static void NativeScaleTime( TCL_UNUSED(Tcl_Time *), - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { /* * Native scale is 1:1. Nothing is done. @@ -626,7 +599,6 @@ NativeGetMicroseconds(void) LONGLONG perfCounterLastCall, curCounterFreq; /* Copy with current data of calibration * cycle. */ - LARGE_INTEGER curCounter; /* Current performance counter. */ @@ -681,6 +653,7 @@ NativeGetMicroseconds(void) /* * High resolution timer is not available. */ + return 0; } @@ -704,7 +677,7 @@ NativeGetMicroseconds(void) static void NativeGetTime( Tcl_Time *timePtr, - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { long long usecSincePosixEpoch; @@ -714,8 +687,8 @@ NativeGetTime( usecSincePosixEpoch = NativeGetMicroseconds(); if (usecSincePosixEpoch) { - timePtr->sec = (long) (usecSincePosixEpoch / 1000000); - timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); + timePtr->sec = usecSincePosixEpoch / 1000000; + timePtr->usec = usecSincePosixEpoch % 1000000; } else { /* * High resolution timer is not available. Just use ftime. @@ -724,7 +697,7 @@ NativeGetTime( struct _timeb t; _ftime(&t); - timePtr->sec = (long) t.time; + timePtr->sec = t.time; timePtr->usec = t.millitm * 1000; } } @@ -751,7 +724,7 @@ void TclWinResetTimerResolution(void); static void StopCalibration( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { SetEvent(timeInfo.exitEvent); @@ -768,226 +741,6 @@ StopCalibration( /* *---------------------------------------------------------------------- * - * TclpGetDate -- - * - * This function converts between seconds and struct tm. If useGMT is - * true, then the returned date will be in Greenwich Mean Time (GMT). - * Otherwise, it will be in the local time zone. - * - * Results: - * Returns a static tm structure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -struct tm * -TclpGetDate( - const time_t *t, - int useGMT) -{ - struct tm *tmPtr; - time_t time; -#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) -# define t2 *t /* no need to cripple time to 32-bit */ -#else - time_t t2 = *(__time32_t *) t; -#endif - - if (!useGMT) { -#if defined(_MSC_VER) -# undef timezone /* prevent conflict with timezone() function */ - long timezone = 0; -#endif - - tzset(); - - /* - * If we are in the valid range, let the C run-time library handle it. - * Otherwise we need to fake it. Note that this algorithm ignores - * daylight savings time before the epoch. - */ - - if (t2 >= 0) { - return TclpLocaltime(&t2); - } - -#if defined(_MSC_VER) - _get_timezone(&timezone); -#endif - - time = t2 - timezone; - - /* - * If we aren't near to overflowing the long, just add the bias and - * use the normal calculation. Otherwise we will need to adjust the - * result at the end. - */ - - if (t2 < (LONG_MAX - 2*SECSPERDAY) && t2 > (LONG_MIN + 2*SECSPERDAY)) { - tmPtr = ComputeGMT(&time); - } else { - tmPtr = ComputeGMT(&t2); - - tzset(); - - /* - * Add the bias directly to the tm structure to avoid overflow. - * Propagate seconds overflow into minutes, hours and days. - */ - - time = tmPtr->tm_sec - timezone; - tmPtr->tm_sec = (int)(time % 60); - if (tmPtr->tm_sec < 0) { - tmPtr->tm_sec += 60; - time -= 60; - } - - time = tmPtr->tm_min + time / 60; - tmPtr->tm_min = (int)(time % 60); - if (tmPtr->tm_min < 0) { - tmPtr->tm_min += 60; - time -= 60; - } - - time = tmPtr->tm_hour + time / 60; - tmPtr->tm_hour = (int)(time % 24); - if (tmPtr->tm_hour < 0) { - tmPtr->tm_hour += 24; - time -= 24; - } - - time /= 24; - tmPtr->tm_mday += (int) time; - tmPtr->tm_yday += (int) time; - tmPtr->tm_wday = (tmPtr->tm_wday + (int) time) % 7; - } - } else { - tmPtr = ComputeGMT(&t2); - } - return tmPtr; -} - -/* - *---------------------------------------------------------------------- - * - * ComputeGMT -- - * - * This function computes GMT given the number of seconds since the epoch - * (midnight Jan 1 1970). - * - * Results: - * Returns a (per thread) statically allocated struct tm. - * - * Side effects: - * Updates the values of the static struct tm. - * - *---------------------------------------------------------------------- - */ - -static struct tm * -ComputeGMT( - const time_t *tp) -{ - struct tm *tmPtr; - long tmp, rem; - int isLeap; - const int *days; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - tmPtr = &tsdPtr->tm; - - /* - * Compute the 4 year span containing the specified time. - */ - - tmp = (long) (*tp / SECSPER4YEAR); - rem = (long) (*tp % SECSPER4YEAR); - - /* - * Correct for weird mod semantics so the remainder is always positive. - */ - - if (rem < 0) { - tmp--; - rem += SECSPER4YEAR; - } - - /* - * Compute the year after 1900 by taking the 4 year span and adjusting for - * the remainder. This works because 2000 is a leap year, and 1900/2100 - * are out of the range. - */ - - tmp = (tmp * 4) + 70; - isLeap = 0; - if (rem >= SECSPERYEAR) { /* 1971, etc. */ - tmp++; - rem -= SECSPERYEAR; - if (rem >= SECSPERYEAR) { /* 1972, etc. */ - tmp++; - rem -= SECSPERYEAR; - if (rem >= SECSPERYEAR + SECSPERDAY) { /* 1973, etc. */ - tmp++; - rem -= SECSPERYEAR + SECSPERDAY; - } else { - isLeap = 1; - } - } - } - tmPtr->tm_year = tmp; - - /* - * Compute the day of year and leave the seconds in the current day in the - * remainder. - */ - - tmPtr->tm_yday = rem / SECSPERDAY; - rem %= SECSPERDAY; - - /* - * Compute the time of day. - */ - - tmPtr->tm_hour = rem / 3600; - rem %= 3600; - tmPtr->tm_min = rem / 60; - tmPtr->tm_sec = rem % 60; - - /* - * Compute the month and day of month. - */ - - days = (isLeap) ? leapDays : normalDays; - for (tmp = 1; days[tmp] < tmPtr->tm_yday; tmp++) { - /* empty body */ - } - tmPtr->tm_mon = --tmp; - tmPtr->tm_mday = tmPtr->tm_yday - days[tmp]; - - /* - * Compute day of week. Epoch started on a Thursday. - */ - - tmPtr->tm_wday = (long) (*tp / SECSPERDAY) + 4; - if ((*tp % SECSPERDAY) < 0) { - tmPtr->tm_wday--; - } - tmPtr->tm_wday %= 7; - if (tmPtr->tm_wday < 0) { - tmPtr->tm_wday += 7; - } - - return tmPtr; -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * CalibrationThread -- * * Thread that manages calibration of the hi-resolution time derived from @@ -1253,6 +1006,7 @@ UpdateTimeEachSecond(void) * First adjust with a micro jump (short frozen time is * acceptable). */ + vt0 += nt0 - nt1; /* @@ -1426,77 +1180,6 @@ AccumulateSample( /* *---------------------------------------------------------------------- * - * TclpGmtime -- - * - * Wrapper around the 'gmtime' library function to make it thread safe. - * - * Results: - * Returns a pointer to a 'struct tm' in thread-specific data. - * - * Side effects: - * Invokes gmtime or gmtime_r as appropriate. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -struct tm * -TclpGmtime( - const time_t *timePtr) /* Pointer to the number of seconds since the - * local system's epoch */ -{ - /* - * The MS implementation of gmtime is thread safe because it returns the - * time in a block of thread-local storage, and Windows does not provide a - * Posix gmtime_r function. - */ - -#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) - return gmtime(timePtr); -#else - return _gmtime32((const __time32_t *) timePtr); -#endif /* _WIN64 || _USE_64BIT_TIME_T */ -} - -/* - *---------------------------------------------------------------------- - * - * TclpLocaltime -- - * - * Wrapper around the 'localtime' library function to make it thread - * safe. - * - * Results: - * Returns a pointer to a 'struct tm' in thread-specific data. - * - * Side effects: - * Invokes localtime or localtime_r as appropriate. - * - *---------------------------------------------------------------------- - */ - -struct tm * -TclpLocaltime( - const time_t *timePtr) /* Pointer to the number of seconds since the - * local system's epoch */ -{ - /* - * The MS implementation of localtime is thread safe because it returns - * the time in a block of thread-local storage, and Windows does not - * provide a Posix localtime_r function. - */ - -#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) - return localtime(timePtr); -#else - return _localtime32((const __time32_t *) timePtr); -#endif /* _WIN64 || _USE_64BIT_TIME_T */ -} -#endif /* TCL_NO_DEPRECATED */ - -/* - *---------------------------------------------------------------------- - * * Tcl_SetTimeProc -- * * TIP #233 (Virtualized Time): Registers two handlers for the @@ -1515,7 +1198,7 @@ void Tcl_SetTimeProc( Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, - ClientData clientData) + void *clientData) { tclGetTimeProcPtr = getProc; tclScaleTimeProcPtr = scaleProc; @@ -1542,7 +1225,7 @@ void Tcl_QueryTimeProc( Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, - ClientData *clientData) + void **clientData) { if (getProc) { *getProc = tclGetTimeProcPtr; |