diff options
| -rw-r--r-- | README.md | 2 | ||||
| -rw-r--r-- | doc/OpenFileChnl.3 | 30 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 46 | ||||
| -rw-r--r-- | generic/tclIOCmd.c | 29 | ||||
| -rw-r--r-- | generic/tclResult.c | 91 | ||||
| -rw-r--r-- | macosx/README | 32 | ||||
| -rw-r--r-- | tests/cmdMZ.test | 13 | ||||
| -rw-r--r-- | tests/exec.test | 39 |
8 files changed, 186 insertions, 96 deletions
@@ -31,7 +31,7 @@ site](https://sourceforge.net/projects/tcl/files/Tcl/). Tcl provides a powerful platform for creating integration applications that tie together diverse applications, protocols, devices, and frameworks. When paired with the Tk toolkit, Tcl provides the fastest and most powerful -way to create GUI applications that run on PCs, Unix, and Mac OS X. +way to create GUI applications that run on PCs, Unix, and macOS. Tcl can also be used for a variety of web-related tasks and for creating powerful command languages for applications. diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 index 59364e0..6a21cd9 100644 --- a/doc/OpenFileChnl.3 +++ b/doc/OpenFileChnl.3 @@ -9,7 +9,7 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_TruncateChannel, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels +Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_CloseEx, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_TruncateChannel, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -46,6 +46,9 @@ int int \fBTcl_Close\fR(\fIinterp, channel\fR) .sp +int +\fBTcl_CloseEx\fR(\fIinterp, channel, closeFlags\fR) +.sp Tcl_Size \fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR) .sp @@ -157,6 +160,10 @@ channel. 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. +.AP int closeFlags in +If \fB0\fR, the channel is closed in both directions. If \fBTCL_CLOSE_READ\fR, +the channel is only closed for reading. If \fBTCL_CLOSE_WRITE\fR, the channel +is only closed for writing. These flags must not be combined. .AP int appendFlag in 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. @@ -369,7 +376,7 @@ If so, it returns 1, otherwise 0. .PP No attempt is made to check whether the given channel or the standard channels are initialized or otherwise valid. -.SH TCL_CLOSE +.SH "TCL_CLOSE AND TCL_CLOSEEX" .PP \fBTcl_Close\fR destroys the channel \fIchannel\fR, which must denote a currently open channel. The channel should not be registered in any @@ -383,16 +390,23 @@ immediately; output is flushed in the background and the channel will be closed once all of the buffered data has been output. In this case errors during flushing are not reported. .PP -If the channel was closed successfully, \fBTcl_Close\fR returns \fBTCL_OK\fR. -If an error occurs, \fBTcl_Close\fR returns \fBTCL_ERROR\fR and records a -POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. +\fBTcl_CloseEx\fR allows for both full closing and half-closing of channels +depending on its \fBcloseFlags\fR parameter. See the description of the +parameter above. It is an error to attempt to close the channel for +a direction for which it is not open. The channel is destroyed only when +it has been closed for both reading and writing. Only socket and command +pipe channels support half-closing. +.PP +If the channel was closed successfully, \fBTcl_Close\fR and \fBTcl_CloseEx\fR +return \fBTCL_OK\fR. If an error occurs, they return \fBTCL_ERROR\fR and record +a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. 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 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 +Note that it is not safe to call the channel closing functions 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 \fBTcl_RegisterChannel\fR, you should instead use \fBTcl_UnregisterChannel\fR, which will internally call \fBTcl_Close\fR diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 673b4f8..59a30d2 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -551,14 +551,14 @@ EncodingConvertfromObjCmd( result = Tcl_ExternalToUtfDStringEx(interp, encoding, bytesPtr, length, flags, &ds, failVarObj ? &errorLocation : NULL); /* NOTE: ds must be freed beyond this point even on error */ + switch (result) { case TCL_OK: errorLocation = TCL_INDEX_NONE; break; case TCL_ERROR: /* Error in parameters. Should not happen. interp will have error */ - Tcl_DStringFree(&ds); - return TCL_ERROR; + goto done; default: /* * One of the TCL_CONVERT_* errors. If we were not interested in the @@ -567,8 +567,8 @@ EncodingConvertfromObjCmd( * what could be decoded and the returned error location. */ if (failVarObj == NULL) { - Tcl_DStringFree(&ds); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } break; } @@ -582,8 +582,8 @@ EncodingConvertfromObjCmd( TclNewIndexObj(failIndex, errorLocation); if (Tcl_ObjSetVar2(interp, failVarObj, NULL, failIndex, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DStringFree(&ds); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } } /* @@ -592,12 +592,14 @@ EncodingConvertfromObjCmd( */ Tcl_SetObjResult(interp, Tcl_DStringToObj(&ds)); + result = TCL_OK; - /* We're done with the encoding */ - - Tcl_FreeEncoding(encoding); - return TCL_OK; - +done: + Tcl_DStringFree(&ds); + if (encoding) { + Tcl_FreeEncoding(encoding); + } + return result; } /* @@ -651,8 +653,7 @@ EncodingConverttoObjCmd( break; case TCL_ERROR: /* Error in parameters. Should not happen. interp will have error */ - Tcl_DStringFree(&ds); - return TCL_ERROR; + goto done; default: /* * One of the TCL_CONVERT_* errors. If we were not interested in the @@ -661,8 +662,8 @@ EncodingConverttoObjCmd( * what could be decoded and the returned error location. */ if (failVarObj == NULL) { - Tcl_DStringFree(&ds); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } break; } @@ -676,20 +677,23 @@ EncodingConverttoObjCmd( TclNewIndexObj(failIndex, errorLocation); if (Tcl_ObjSetVar2(interp, failVarObj, NULL, failIndex, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DStringFree(&ds); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } } Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( (unsigned char*) Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - /* We're done with the encoding */ + result = TCL_OK; - Tcl_FreeEncoding(encoding); - return TCL_OK; +done: + Tcl_DStringFree(&ds); + if (encoding) { + Tcl_FreeEncoding(encoding); + } + return result; } diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 485812f..bd3a462 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -948,8 +948,16 @@ Tcl_ExecObjCmd( Tcl_SetResult(interp, "No value given for option -encoding.", TCL_STATIC); return TCL_ERROR; + } else { + Tcl_Encoding encoding; + encodingObj = objv[skip]; + /* Verify validity - bug [da5e1bc7bc] */ + if (Tcl_GetEncodingFromObj(interp, encodingObj, &encoding) + != TCL_OK) { + return TCL_ERROR; + } + Tcl_FreeEncoding(encoding); } - encodingObj = objv[skip]; break; } } @@ -1014,16 +1022,14 @@ Tcl_ExecObjCmd( /* Bug [0f1ddc0df7] - encoding errors - use replace profile */ if (Tcl_SetChannelOption(interp, chan, "-profile", "replace") != TCL_OK) { - return TCL_ERROR; + goto errorWithOpenChannel; } /* TIP 716 */ - if (encodingObj) { - if (Tcl_SetChannelOption( - interp, chan, "-encoding", Tcl_GetString(encodingObj)) != - TCL_OK) { - return TCL_ERROR; - } + if (encodingObj && + Tcl_SetChannelOption(interp, chan, "-encoding", + Tcl_GetString(encodingObj)) != TCL_OK) { + goto errorWithOpenChannel; } TclNewObj(resultPtr); @@ -1042,7 +1048,7 @@ Tcl_ExecObjCmd( Tcl_PosixError(interp))); Tcl_DecrRefCount(resultPtr); } - return TCL_ERROR; + goto errorWithOpenChannel; } } @@ -1069,6 +1075,11 @@ Tcl_ExecObjCmd( Tcl_SetObjResult(interp, resultPtr); return result; + +errorWithOpenChannel: + /* Interpreter should already contain error. Pass NULL to not overwrite */ + (void)Tcl_CloseEx(NULL, chan, 0); + return TCL_ERROR; } /* diff --git a/generic/tclResult.c b/generic/tclResult.c index 2e7d378..1cf3910 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -793,6 +793,9 @@ TclProcessReturn( * * Parses, checks, and stores the options to the [return] command. * + * The number of arguments (objc) must be even, with the corresponding + * objv holding values to be processed as key value .... key value. + * * Results: * Returns TCL_ERROR if any of the option values are invalid. Otherwise, * returns TCL_OK, and writes the returnOpts, code, and level values to @@ -804,6 +807,49 @@ TclProcessReturn( *---------------------------------------------------------------------- */ +static int +ExpandedOptions( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj **keys, /* Built-in keys (per thread) */ + Tcl_Obj *returnOpts, /* Options dict we are building */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + for (; objc > 1; objv += 2, objc -= 2) { + const char *opt = TclGetString(objv[0]); + const char *compare = TclGetString(keys[KEY_OPTIONS]); + + if ((objv[0]->length == keys[KEY_OPTIONS]->length) + && (memcmp(opt, compare, objv[0]->length) == 0)) { + /* Process the -options switch to emulate {*} expansion. + * + * Use lists so duplicate keys are not lost. + */ + + Tcl_Size nestc; + Tcl_Obj **nestv; + + if (TCL_ERROR == TclListObjGetElements(interp, objv[1], + &nestc, &nestv) || (nestc % 2)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad -options value: expected dictionary but got" + " \"%s\"", TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", + (char *)NULL); + return TCL_ERROR; + } + + if (TCL_ERROR == + ExpandedOptions(interp, keys, returnOpts, nestc, nestv)) { + return TCL_ERROR; + } + } else { + Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]); + } + } + return TCL_OK; +} + int TclMergeReturnOptions( Tcl_Interp *interp, /* Current interpreter. */ @@ -823,48 +869,11 @@ TclMergeReturnOptions( Tcl_Obj *returnOpts; Tcl_Obj **keys = GetKeys(); - TclNewObj(returnOpts); - for (; objc > 1; objv += 2, objc -= 2) { - const char *opt = TclGetString(objv[0]); - const char *compare = TclGetString(keys[KEY_OPTIONS]); - - if ((objv[0]->length == keys[KEY_OPTIONS]->length) - && (memcmp(opt, compare, objv[0]->length) == 0)) { - Tcl_DictSearch search; - int done = 0; - Tcl_Obj *keyPtr; - Tcl_Obj *dict = objv[1]; - - nestedOptions: - if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search, - &keyPtr, &valuePtr, &done)) { - /* - * Value is not a legal dictionary. - */ - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad %s value: expected dictionary but got \"%s\"", - compare, TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", - (char *)NULL); - goto error; - } - - while (!done) { - Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr); - Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); - } + /* All callers are expected to pass an even value for objc. */ - Tcl_DictObjGet(NULL, returnOpts, keys[KEY_OPTIONS], &valuePtr); - if (valuePtr != NULL) { - dict = valuePtr; - Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_OPTIONS]); - goto nestedOptions; - } - - } else { - Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]); - } + TclNewObj(returnOpts); + if (TCL_ERROR == ExpandedOptions(interp, keys, returnOpts, objc, objv)) { + goto error; } /* diff --git a/macosx/README b/macosx/README index f5e3716..c4221e4 100644 --- a/macosx/README +++ b/macosx/README @@ -1,7 +1,7 @@ -Tcl Mac OS X README +Tcl macOS README ------------------- -This is the README file for the Mac OS X/Darwin version of Tcl. +This is the README file for the macOS/Darwin version of Tcl. 1. Where to go for support @@ -63,14 +63,15 @@ framework directories: 3. Building Tcl on Mac OS X --------------------------- -- At least Mac OS X 10.3 is required to build Tcl. -Apple's Xcode Developer Tools need to be installed (only the most recent version -matching your OS release is supported), the Xcode installer is available on Mac -OS X install media or may be present in /Applications/Installers on Macs that -came with OS X preinstalled. The most recent version can always be downloaded -from the ADC website http://connect.apple.com (free ADC membership required). +- Tcl supports macOS 10.13 and newer. +While Tcl may build on earlier versions of the OS, it is not tested on versions +older than 10.13. You will need to install an Apple clang toolchain either by +downloading the Xcode app from Apple's App Store, or by installing the Command +Line Tools. The Command Line Tools can be installed by running the command: + xcode-select --install +in the Terminal. -- Tcl is most easily built as a Mac OS X framework via GNUmakefile in tcl/macosx +- Tcl is most easily built as a macOS framework via the GNUmakefile in tcl/macosx (see below for details), but can also be built with the standard unix configure and make buildsystem in tcl/unix as on any other unix platform (indeed, the GNUmakefile is just a wrapper around the unix buildsystem). @@ -78,11 +79,10 @@ The Mac OS X specific configure flags are --enable-framework and --disable-corefoundation (which disables CF and notably reverts to the standard select based notifier). -- To build universal binaries outside of the Xcode IDE, set CFLAGS as follows: - export CFLAGS="-arch x86_64 -arch arm64" -This requires Mac OS X 10.6 and Xcode 10.2 and will work on any architecture. -Note that configure requires CFLAGS to contain a least one architecture that can -be run on the build machine (i.e. x86_64 on Core2/Xeon). +- To build universal binaries for macOS 10.13 and newer set CFLAGS as follows: + export CFLAGS="-arch x86_64 -arch arm64 -mmacosx-version-min=10.13" +(This will cause clang to set macOS 11 as the target OS for the arm64 architecture +since Apple Silicon was not supported until macOS 11.) Universal builds of Tcl TEA extensions are also possible with CFLAGS set as above, they will be [load]able by universal as well as thin binaries of Tcl. @@ -96,8 +96,8 @@ Detailed Instructions for building with macosx/GNUmakefile Setup this shell variable as follows: ver="9.0" -- Setup environment variables as desired, e.g. for a universal build on 10.9: - CFLAGS="-arch x86_64 -arch arm64 -mmacosx-version-min=10.9" +- Setup environment variables as desired, for example: + CFLAGS="-arch x86_64 -arch arm64 -mmacosx-version-min=10.13" export CFLAGS - Change to the directory containing the Tcl source tree and build: diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 7b9032a..ff282b7 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -193,6 +193,19 @@ test cmdMZ-return-2.18 {return option handling} { return -code error -errorstack [list CALL a CALL b] yo } -> foo] [dictSort $foo] [info errorstack] } {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL b}} +test cmdMZ-return-2.19 {return option handling} -body { + return -level 0 -options {-options {-code break} -code continue} +} -returnCodes continue -result {} +test cmdMZ-return-2.20 {return option handling} { + list [catch { + return -level 0 -options {-foo 1} -options {-bar 2} + } -> foo] $foo +} {0 {-foo 1 -bar 2 -code 0 -level 0}} +test cmdMZ-return-2.21 {return option handling} { + list [catch { + return -level 0 -options {-options {-foo 1} -options {-bar 2}} + } -> foo] $foo +} {0 {-foo 1 -bar 2 -code 0 -level 0}} # Check that the result of a [return -options $opts $result] is # indistinguishable from that of the originally caught script, no matter what diff --git a/tests/exec.test b/tests/exec.test index 06d6bea..fc5f1fa 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -32,6 +32,8 @@ if {[testConstraint win] && ![info exists ::env(CI)] && testConstraint haveWinget 1 } +testConstraint testhandlecount [expr {[llength [info commands testhandlecount]] != 0}] + unset -nocomplain path # Utilities that are like Bourne shell stalwarts, but cross-platform. @@ -154,6 +156,12 @@ test exec-1.4 {long command lines} {exec} { exec [interpreter] $path(echo) $arg } $arg set arg {} +test exec-1.5 {pipelining - handle leaks} -constraints {exec stdio testhandlecount} -body { + set numHandles [testhandlecount] + set a [exec [interpreter] $path(echo) a b c d | [interpreter] $path(cat) | [interpreter] $path(wc)] + list [scan $a "%d %d %d" b c d] $b $c [expr {[testhandlecount] - $numHandles}] +} -result {3 1 4 0} + # I/O redirection: input from Tcl command. @@ -190,6 +198,13 @@ test exec-2.6 {redirecting input from immediate source, with UTF} -setup { encoding system $sysenc rename quotenonascii {} } -result {\xE9\xE0\xFC\xF1} +test exec-2.7 {handle count redirecting input from immediate source} -constraints { + exec stdio testhandlecount +} -body { + set numHandles [testhandlecount] + list [exec [interpreter] $path(cat) | [interpreter] $path(cat) << "Sample text"] \ + [expr {[testhandlecount] - $numHandles}] +} -result [list {Sample text} 0] # I/O redirection: output to file. @@ -232,6 +247,14 @@ test exec-3.7 {redirecting output to file} {exec} { close $f exec [interpreter] $path(cat) $path(gorp.file) } "Line 1\nMore text\nEven more\nLine 3" +test exec-3.8 {handle count redirecting output to file} -constraints { + exec stdio testhandlecount +} -body { + set numHandles [testhandlecount] + exec > $path(gorp.file) [interpreter] $path(echo) "Different simple words" | [interpreter] $path(cat) | [interpreter] $path(cat) + list [exec [interpreter] $path(cat) $path(gorp.file)] \ + [expr {[testhandlecount] - $numHandles}] +} -result [list "Different simple words" 0] # I/O redirection: output and stderr to file. @@ -303,6 +326,13 @@ test exec-5.7 {redirecting input from file} -constraints {exec} -body { } -cleanup { close $f } -result {Just a few thoughts} +test exec-5.8 {handle count redirecting input from file} -constraints { + exec stdio testhandlecount +} -body { + set numHandles [testhandlecount] + list [exec [interpreter] $path(cat) | [interpreter] $path(cat) < $path(gorp.file)] \ + [expr {[testhandlecount] - $numHandles}] +} -result [list {Just a few thoughts} 0] # I/O redirection: standard error through a pipeline. @@ -484,6 +514,15 @@ test exec-11.5 {commands in background} {exec} { close $f exec [interpreter] $path(gorp.file) } foo +test exec-11.6 {commands in background} -constraints { + exec stdio testhandlecount +} -body { + set numHandles [testhandlecount] + set n [llength [exec [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 &]] + after 1100 + tcl::process::purge + list $n [expr {([testhandlecount] - $numHandles) <= 0}]; # Could be < 0 if prior processes were reaped +} -result {3 1} # Make sure that background commands are properly reaped when they # eventually die. |