From 344b1355050cb57f8ec7d899a6294048748c0218 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Mar 2018 15:31:38 +0000 Subject: Rebooting a [string insert] implementation branch, bringing over pieces from the past branches and merging against the updated index parsing machinery. --- doc/string.n | 17 +++++++++++ generic/tclCmdMZ.c | 58 +++++++++++++++++++++++++++++++++++ tests/string.test | 89 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 161 insertions(+), 3 deletions(-) diff --git a/doc/string.n b/doc/string.n index 00ce85c..a5b7a29 100644 --- a/doc/string.n +++ b/doc/string.n @@ -89,6 +89,23 @@ 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 .TP +\fBstring insert \fIstring index insertString\fR +. +Returns a copy of \fIstring\fR with \fIinsertString\fR inserted at the +\fIindex\fR'th character. \fIindex\fR may be specified as described in the +\fBSTRING INDICES\fR section. +.RS +.PP +If \fIindex\fR is start-relative, the first character inserted in the returned +string will be at the specified index. If \fIindex\fR is end-relative, the last +character inserted in the returned string will be at the specified index. +.PP +If \fIindex\fR is at or before the start of \fIstring\fR (e.g., \fIindex\fR is +\fB0\fR), \fIinsertString\fR is prepended to \fIstring\fR. If \fIindex\fR is at +or after the end of \fIstring\fR (e.g., \fIindex\fR is \fBend\fR), +\fIinsertString\fR is appended to \fIstring\fR. +.RE +.TP \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR . Returns 1 if \fIstring\fR is a valid member of the specified character diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 0b65758..796a8a3 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1452,6 +1452,63 @@ StringIndexCmd( /* *---------------------------------------------------------------------- * + * StringInsertCmd -- + * + * This procedure is invoked to process the "string insert" 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. + * + *---------------------------------------------------------------------- + */ + +static int +StringInsertCmd( + ClientData dummy, /* Not used */ + Tcl_Interp *interp, /* Current interpreter */ + int objc, /* Number of arguments */ + Tcl_Obj *const objv[]) /* Argument objects */ +{ + int length; /* String length */ + int index; /* Insert index */ + Tcl_Obj *outObj; /* Output object */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string index insertString"); + return TCL_ERROR; + } + + length = Tcl_GetCharLength(objv[1]); + if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) { + return TCL_ERROR; + } + + if (index < 0) { + index = 0; + } + if (index > length) { + index = length; + } + + outObj = TclStringReplace(interp, objv[1], index, 0, objv[3], + TCL_STRING_IN_PLACE); + + if (outObj != NULL) { + Tcl_SetObjResult(interp, outObj); + return TCL_OK; + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * StringIsCmd -- * * This procedure is invoked to process the "string is" Tcl command. See @@ -3351,6 +3408,7 @@ TclInitStringCmd( {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, + {"insert", StringInsertCmd, NULL, NULL, NULL, 0}, {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, diff --git a/tests/string.test b/tests/string.test index da302eb..172c066 100644 --- a/tests/string.test +++ b/tests/string.test @@ -73,7 +73,7 @@ if {$noComp} { test string-1.1.$noComp {error conditions} { list [catch {run {string gorp a b}} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2.$noComp {error conditions} { list [catch {run {string}} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} @@ -1775,7 +1775,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} { list [catch {run {string trimg a}} msg] $msg -} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-20.3.$noComp {string trimright} { run {string trimright " XYZ "} } { XYZ} @@ -1834,7 +1834,7 @@ test string-21.14.$noComp {string wordend, unicode} { test string-22.1.$noComp {string wordstart} { list [catch {run {string word a}} msg] $msg -} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-22.2.$noComp {string wordstart} { list [catch {run {string wordstart a}} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} @@ -2300,6 +2300,89 @@ test string-29.15.$noComp {string cat, efficiency} -setup { } -match glob -result {*no string representation} } +# Note: string-30.* tests use [tcl::string::insert] rather than [string insert] +# to dodge ticket [3397978fff] which would cause all arguments to be shared, +# thereby preventing the optimizations from being tested. +test string-30.1.$noComp {string insert, start of string} { + run {tcl::string::insert 0123 0 _} +} _0123 +test string-30.2.$noComp {string insert, middle of string} { + run {tcl::string::insert 0123 2 _} +} 01_23 +test string-30.3.$noComp {string insert, end of string} { + run {tcl::string::insert 0123 4 _} +} 0123_ +test string-30.4.$noComp {string insert, start of string, end-relative} { + run {tcl::string::insert 0123 end-4 _} +} _0123 +test string-30.5.$noComp {string insert, middle of string, end-relative} { + run {tcl::string::insert 0123 end-2 _} +} 01_23 +test string-30.6.$noComp {string insert, end of string, end-relative} { + run {tcl::string::insert 0123 end _} +} 0123_ +test string-30.7.$noComp {string insert, empty target string} { + run {tcl::string::insert {} 0 _} +} _ +test string-30.8.$noComp {string insert, empty insert string} { + run {tcl::string::insert 0123 0 {}} +} 0123 +test string-30.9.$noComp {string insert, empty strings} { + run {tcl::string::insert {} 0 {}} +} {} +test string-30.10.$noComp {string insert, negative index} { + run {tcl::string::insert 0123 -1 _} +} _0123 +test string-30.11.$noComp {string insert, index beyond end} { + run {tcl::string::insert 0123 5 _} +} 0123_ +test string-30.12.$noComp {string insert, start of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 0 [makeByteArray _]} +} _0123 +test string-30.13.$noComp {string insert, middle of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]} +} 01_23 +test string-30.14.$noComp {string insert, end of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 4 [makeByteArray _]} +} 0123_ +test string-30.15.$noComp {string insert, pure byte array, neither shared} { + run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]} +} 01_23 +test string-30.16.$noComp {string insert, pure byte array, first shared} { + run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\ + [makeByteArray _]} +} 01_23 +test string-30.17.$noComp {string insert, pure byte array, second shared} { + run {tcl::string::insert [makeByteArray 0123] 2\ + [makeShared [makeByteArray _]]} +} 01_23 +test string-30.18.$noComp {string insert, pure byte array, both shared} { + run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\ + [makeShared [makeByteArray _]]} +} 01_23 +test string-30.19.$noComp {string insert, start of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 0 [makeUnicode _]} +} _0123 +test string-30.20.$noComp {string insert, middle of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 2 [makeUnicode _]} +} 01_23 +test string-30.21.$noComp {string insert, end of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 4 [makeUnicode _]} +} 0123_ +test string-30.22.$noComp {string insert, str start, pure Uni, first shared} { + run {tcl::string::insert [makeShared [makeUnicode 0123]] 0 [makeUnicode _]} +} _0123 +test string-30.23.$noComp {string insert, string mid, pure Uni, 2nd shared} { + run {tcl::string::insert [makeUnicode 0123] 2 [makeShared [makeUnicode _]]} +} 01_23 +test string-30.24.$noComp {string insert, string end, pure Uni, both shared} { + run {tcl::string::insert [makeShared [makeUnicode 0123]] 4\ + [makeShared [makeUnicode _]]} +} 0123_ +test string-30.25.$noComp {string insert, neither byte array nor Unicode} { + run {tcl::string::insert [makeList a b c] 1 zzzzzz} +} {azzzzzz b c} + } # cleanup -- cgit v0.12 From a6454e20a4ac5c7e3a1802e1080808c0d54f7d97 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Mar 2018 16:26:11 +0000 Subject: A compiler for [string insert] mirroring the one for [linsert]. --- generic/tclCmdMZ.c | 2 +- generic/tclCompCmdsSZ.c | 57 +++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 +++ 3 files changed, 61 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 796a8a3..dc0cd63 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3408,7 +3408,7 @@ TclInitStringCmd( {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, - {"insert", StringInsertCmd, NULL, NULL, NULL, 0}, + {"insert", StringInsertCmd, TclCompileStringInsertCmd, NULL, NULL, 0}, {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index cf088bb..ab82f82 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -449,6 +449,63 @@ TclCompileStringIndexCmd( } int +TclCompileStringInsertCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + int idx; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + + /* Compute and push the string in which to insert */ + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* See what can be discovered about index at compile time */ + tokenPtr = TokenAfter(tokenPtr); + if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, + TCL_INDEX_END, &idx)) { + + /* Nothing useful knowable - cease compile; let it direct eval */ + return TCL_OK; + } + + /* Compute and push the string to be inserted */ + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + + if (idx == TCL_INDEX_START) { + /* Prepend the insertion string */ + OP4( REVERSE, 2); + OP1( STR_CONCAT1, 2); + } else if (idx == TCL_INDEX_END) { + /* Append the insertion string */ + OP1( STR_CONCAT1, 2); + } else { + /* Prefix + insertion + suffix */ + if (idx < TCL_INDEX_END) { + /* See comments in compiler for [linsert]. */ + idx++; + } + OP4( OVER, 1); + OP44( STR_RANGE_IMM, 0, idx-1); + OP4( REVERSE, 3); + OP44( STR_RANGE_IMM, idx, TCL_INDEX_END); + OP1( STR_CONCAT1, 3); + } + + return TCL_OK; +} + +int TclCompileStringIsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclInt.h b/generic/tclInt.h index 81b1c05..daeb9eb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3741,6 +3741,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringInsertCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 8d4ff7c84a4acdc37c023fc436509c263f9455dc Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 24 Mar 2019 18:44:45 +0000 Subject: Start of implementation of TIP 160: better terminal control --- unix/tclUnixChan.c | 248 +++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 212 insertions(+), 36 deletions(-) diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 435579a..cede011 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -49,6 +49,16 @@ #endif /* HAVE_TERMIOS_H */ /* + * The bits supported for describing the closeMode field of TtyState. + */ + +enum CloseModeBits { + CLOSE_DEFAULT, + CLOSE_DRAIN, + CLOSE_DISCARD +}; + +/* * Helper macros to make parts of this file clearer. The macros do exactly * what they say on the tin. :-) They also only ever refer to their arguments * once, and so can be used without regard to side effects. @@ -58,7 +68,8 @@ #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) /* - * This structure describes per-instance state of a file based channel. + * These structures describe per-instance state of file-based and serial-based + * channels. */ typedef struct { @@ -69,6 +80,12 @@ typedef struct { * which operations are valid on the file. */ } FileState; +typedef struct { + FileState fileState; + int closeMode; /* One of CLOSE_DEFAULT, CLOSE_DRAIN or + * CLOSE_DISCARD. */ +} TtyState; + #ifdef SUPPORTS_TTY /* @@ -113,6 +130,8 @@ static Tcl_WideInt FileWideSeekProc(ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode); static void FileWatchProc(ClientData instanceData, int mask); #ifdef SUPPORTS_TTY +static int TtyCloseProc(ClientData instanceData, + Tcl_Interp *interp); static void TtyGetAttributes(int fd, TtyAttrs *ttyPtr); static int TtyGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, @@ -162,7 +181,7 @@ static const Tcl_ChannelType fileChannelType = { static const Tcl_ChannelType ttyChannelType = { "tty", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - FileCloseProc, /* Close proc. */ + TtyCloseProc, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ NULL, /* Seek proc. */ @@ -310,10 +329,11 @@ FileOutputProc( /* *---------------------------------------------------------------------- * - * FileCloseProc -- + * FileCloseProc, TtyCloseProc -- * - * This function is called from the generic IO level to perform - * channel-type-specific cleanup when a file based channel is closed. + * These functions are called from the generic IO level to perform + * channel-type-specific cleanup when a file- or tty-based channel is + * closed. * * Results: * 0 if successful, errno if failed. @@ -347,6 +367,38 @@ FileCloseProc( ckfree(fsPtr); return errorCode; } + +#ifdef SUPPORTS_TTY +static int +TtyCloseProc( + ClientData instanceData, + Tcl_Interp *interp) +{ + TtyState *ttyState = instanceData; + + /* + * If we've been asked by the user to drain or flush, do so now. + */ + + switch (ttyState->closeMode) { + case CLOSE_DRAIN: + tcdrain(ttyState->fileState.fd); + break; + case CLOSE_DISCARD: + tcflush(ttyState->fileState.fd, TCIOFLUSH); + break; + default: + /* Do nothing */ + break; + } + + /* + * Delegate to close for files. + */ + + return FileCloseProc(instanceData, interp); +} +#endif /* SUPPORTS_TTY */ /* *---------------------------------------------------------------------- @@ -578,7 +630,7 @@ TtySetOptionProc( const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ { - FileState *fsPtr = instanceData; + TtyState *fsPtr = instanceData; unsigned int len, vlen; TtyAttrs tty; int argc; @@ -601,7 +653,7 @@ TtySetOptionProc( * system calls results should be checked there. - dl */ - TtySetAttributes(fsPtr->fd, &tty); + TtySetAttributes(fsPtr->fileState.fd, &tty); return TCL_OK; } @@ -614,7 +666,7 @@ TtySetOptionProc( * Reset all handshake options. DTR and RTS are ON by default. */ - tcgetattr(fsPtr->fd, &iostate); + tcgetattr(fsPtr->fileState.fd, &iostate); CLEAR_BITS(iostate.c_iflag, IXON | IXOFF | IXANY); #ifdef CRTSCTS CLEAR_BITS(iostate.c_cflag, CRTSCTS); @@ -645,7 +697,7 @@ TtySetOptionProc( } return TCL_ERROR; } - tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); + tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate); return TCL_OK; } @@ -670,7 +722,7 @@ TtySetOptionProc( return TCL_ERROR; } - tcgetattr(fsPtr->fd, &iostate); + tcgetattr(fsPtr->fileState.fd, &iostate); Tcl_UtfToExternalDString(NULL, argv[0], -1, &ds); iostate.c_cc[VSTART] = *(const cc_t *) Tcl_DStringValue(&ds); @@ -681,7 +733,7 @@ TtySetOptionProc( Tcl_DStringFree(&ds); ckfree(argv); - tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); + tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate); return TCL_OK; } @@ -692,13 +744,13 @@ TtySetOptionProc( if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) { int msec; - tcgetattr(fsPtr->fd, &iostate); + tcgetattr(fsPtr->fileState.fd, &iostate); if (Tcl_GetInt(interp, value, &msec) != TCL_OK) { return TCL_ERROR; } iostate.c_cc[VMIN] = 0; iostate.c_cc[VTIME] = (msec==0) ? 0 : (msec<100) ? 1 : (msec+50)/100; - tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); + tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate); return TCL_OK; } @@ -725,7 +777,7 @@ TtySetOptionProc( return TCL_ERROR; } - ioctl(fsPtr->fd, TIOCMGET, &control); + 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); @@ -746,9 +798,9 @@ TtySetOptionProc( } else if (Tcl_UtfNcasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) { #if defined(TIOCSBRK) && defined(TIOCCBRK) if (flag) { - ioctl(fsPtr->fd, TIOCSBRK, NULL); + ioctl(fsPtr->fileState.fd, TIOCSBRK, NULL); } else { - ioctl(fsPtr->fd, TIOCCBRK, NULL); + ioctl(fsPtr->fileState.fd, TIOCCBRK, NULL); } #else /* TIOCSBRK & TIOCCBRK */ UNSUPPORTED_OPTION("-ttycontrol BREAK"); @@ -768,7 +820,7 @@ TtySetOptionProc( } } /* -ttycontrol options loop */ - ioctl(fsPtr->fd, TIOCMSET, &control); + ioctl(fsPtr->fileState.fd, TIOCMSET, &control); ckfree(argv); return TCL_OK; #else /* TIOCMGET&TIOCMSET */ @@ -776,8 +828,79 @@ TtySetOptionProc( #endif /* TIOCMGET&TIOCMSET */ } + /* + * Option -closemode drain|discard + */ + + if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) { + if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) { + fsPtr->closeMode = CLOSE_DEFAULT; + } else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) { + fsPtr->closeMode = CLOSE_DRAIN; + } else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) { + fsPtr->closeMode = CLOSE_DISCARD; + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad mode \"%s\" for -closemode: must be" + " default, discard, or drain", value)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", + "VALUE", NULL); + } + return TCL_ERROR; + } + return TCL_OK; + } + + /* + * Option -inputmode normal|password|raw + */ + + if ((len > 2) && (strncmp(optionName, "-inputmode", len) == 0)) { + if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read current serial state: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) { + iostate.c_iflag |= BRKINT | IGNPAR | ISTRIP | ICRNL | IXON; + iostate.c_oflag |= OPOST; + iostate.c_lflag |= ECHO | ICANON | ISIG; + } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) { + iostate.c_iflag |= BRKINT | IGNPAR | ISTRIP | ICRNL | IXON; + iostate.c_oflag |= OPOST; + iostate.c_lflag &= ~(ECHO); + iostate.c_lflag |= ECHONL | ICANON | ISIG; + } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) { + iostate.c_iflag = 0; + iostate.c_oflag &= ~(OPOST); + iostate.c_lflag &= ~(ECHO | ECHONL | ICANON | ISIG); + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad mode \"%s\" for -inputmode: must be" + " normal, password, or raw", value)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", + "VALUE", NULL); + } + return TCL_ERROR; + } + if (tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate) < 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't update serial state: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + return TCL_OK; + } + return Tcl_BadChannelOption(interp, optionName, - "mode handshake timeout ttycontrol xchar"); + "closemode inputmode mode handshake timeout ttycontrol xchar"); } /* @@ -805,7 +928,7 @@ TtyGetOptionProc( const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ { - FileState *fsPtr = instanceData; + TtyState *fsPtr = instanceData; unsigned int len; char buf[3*TCL_INTEGER_SPACE + 16]; int valid = 0; /* Flag if valid option parsed. */ @@ -815,6 +938,58 @@ TtyGetOptionProc( } else { len = strlen(optionName); } + + /* + * Get option -closemode + */ + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-closemode"); + } + if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) { + switch (fsPtr->closeMode) { + case CLOSE_DRAIN: + Tcl_DStringAppendElement(dsPtr, "drain"); + break; + case CLOSE_DISCARD: + Tcl_DStringAppendElement(dsPtr, "discard"); + break; + default: + Tcl_DStringAppendElement(dsPtr, "default"); + break; + } + } + + /* + * Get option -inputmode + * + * This is a great simplification of the underlying reality, but actually + * represents what almost all scripts really want to know. + */ + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-inputmode"); + } + if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) { + struct termios iostate; + + valid = 1; + tcgetattr(fsPtr->fileState.fd, &iostate); + if (iostate.c_lflag & ICANON) { + if (iostate.c_lflag & ECHO) { + Tcl_DStringAppendElement(dsPtr, "normal"); + } else { + Tcl_DStringAppendElement(dsPtr, "password"); + } + } else { + Tcl_DStringAppendElement(dsPtr, "raw"); + } + } + + /* + * Get option -mode + */ + if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-mode"); } @@ -822,7 +997,7 @@ TtyGetOptionProc( TtyAttrs tty; valid = 1; - TtyGetAttributes(fsPtr->fd, &tty); + TtyGetAttributes(fsPtr->fileState.fd, &tty); sprintf(buf, "%d,%c,%d,%d", tty.baud, tty.parity, tty.data, tty.stop); Tcl_DStringAppendElement(dsPtr, buf); } @@ -840,7 +1015,7 @@ TtyGetOptionProc( Tcl_DString ds; valid = 1; - tcgetattr(fsPtr->fd, &iostate); + tcgetattr(fsPtr->fileState.fd, &iostate); Tcl_DStringInit(&ds); Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds); @@ -865,10 +1040,10 @@ TtyGetOptionProc( int inQueue=0, outQueue=0, inBuffered, outBuffered; valid = 1; - GETREADQUEUE(fsPtr->fd, inQueue); - GETWRITEQUEUE(fsPtr->fd, outQueue); - inBuffered = Tcl_InputBuffered(fsPtr->channel); - outBuffered = Tcl_OutputBuffered(fsPtr->channel); + GETREADQUEUE(fsPtr->fileState.fd, inQueue); + GETWRITEQUEUE(fsPtr->fileState.fd, outQueue); + inBuffered = Tcl_InputBuffered(fsPtr->fileState.channel); + outBuffered = Tcl_OutputBuffered(fsPtr->fileState.channel); sprintf(buf, "%d", inBuffered+inQueue); Tcl_DStringAppendElement(dsPtr, buf); @@ -887,7 +1062,7 @@ TtyGetOptionProc( int status; valid = 1; - ioctl(fsPtr->fd, TIOCMGET, &status); + ioctl(fsPtr->fileState.fd, TIOCMGET, &status); TtyModemStatusStr(status, dsPtr); } #endif /* TIOCMGET */ @@ -896,7 +1071,7 @@ TtyGetOptionProc( return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, - "mode queue ttystatus xchar"); + "closemode inputmode mode queue ttystatus xchar"); } static const struct {int baud; speed_t speed;} speeds[] = { @@ -1367,7 +1542,7 @@ TclpOpenFileChannel( * what modes to create it? */ { int fd, channelPermissions; - FileState *fsPtr; + TtyState *fsPtr; const char *native, *translation; char channelName[16 + TCL_INTEGER_SPACE]; const Tcl_ChannelType *channelTypePtr; @@ -1451,11 +1626,12 @@ TclpOpenFileChannel( channelTypePtr = &fileChannelType; } - fsPtr = ckalloc(sizeof(FileState)); - fsPtr->validMask = channelPermissions | TCL_EXCEPTION; - fsPtr->fd = fd; + fsPtr = ckalloc(sizeof(TtyState)); + fsPtr->fileState.validMask = channelPermissions | TCL_EXCEPTION; + fsPtr->fileState.fd = fd; + fsPtr->closeMode = CLOSE_DEFAULT; - fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, + fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName, fsPtr, channelPermissions); if (translation != NULL) { @@ -1467,14 +1643,14 @@ TclpOpenFileChannel( * reports that the serial port isn't working. */ - if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation", - translation) != TCL_OK) { - Tcl_Close(NULL, fsPtr->channel); + if (Tcl_SetChannelOption(interp, fsPtr->fileState.channel, + "-translation", translation) != TCL_OK) { + Tcl_Close(NULL, fsPtr->fileState.channel); return NULL; } } - return fsPtr->channel; + return fsPtr->fileState.channel; } /* -- cgit v0.12 From 4701c749af472143bba603d903ea764623614f94 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 24 Mar 2019 22:08:26 +0000 Subject: Better handling, reset capabilty, and ensure that inherited channels are correct --- unix/tclUnixChan.c | 121 ++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 91 insertions(+), 30 deletions(-) diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index cede011..605e317 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -82,8 +82,14 @@ typedef struct { typedef struct { FileState fileState; +#ifdef SUPPORTS_TTY int closeMode; /* One of CLOSE_DEFAULT, CLOSE_DRAIN or * CLOSE_DISCARD. */ + int doReset; /* Whether we should do a terminal reset on + * close. */ + struct termios initState; /* The state of the terminal when it was + * opened. */ +#endif /* SUPPORTS_TTY */ } TtyState; #ifdef SUPPORTS_TTY @@ -100,7 +106,7 @@ typedef struct { int stop; } TtyAttrs; -#endif /* !SUPPORTS_TTY */ +#endif /* SUPPORTS_TTY */ #define UNSUPPORTED_OPTION(detail) \ if (interp) { \ @@ -374,18 +380,18 @@ TtyCloseProc( ClientData instanceData, Tcl_Interp *interp) { - TtyState *ttyState = instanceData; + TtyState *ttyPtr = instanceData; /* * If we've been asked by the user to drain or flush, do so now. */ - switch (ttyState->closeMode) { + switch (ttyPtr->closeMode) { case CLOSE_DRAIN: - tcdrain(ttyState->fileState.fd); + tcdrain(ttyPtr->fileState.fd); break; case CLOSE_DISCARD: - tcflush(ttyState->fileState.fd, TCIOFLUSH); + tcflush(ttyPtr->fileState.fd, TCIOFLUSH); break; default: /* Do nothing */ @@ -393,6 +399,14 @@ TtyCloseProc( } /* + * If we've had our state changed from the default, reset now. + */ + + if (ttyPtr->doReset) { + tcsetattr(ttyPtr->fileState.fd, TCSANOW, &ttyPtr->initState); + } + + /* * Delegate to close for files. */ @@ -860,29 +874,48 @@ TtySetOptionProc( if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read current serial state: %s", + "couldn't read serial terminal control state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) { - iostate.c_iflag |= BRKINT | IGNPAR | ISTRIP | ICRNL | IXON; - iostate.c_oflag |= OPOST; - iostate.c_lflag |= ECHO | ICANON | ISIG; + SET_BITS(iostate.c_iflag, BRKINT | IGNPAR | ISTRIP | ICRNL | IXON); + SET_BITS(iostate.c_oflag, OPOST); + SET_BITS(iostate.c_lflag, ECHO | ECHONL | ICANON | ISIG); } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) { - iostate.c_iflag |= BRKINT | IGNPAR | ISTRIP | ICRNL | IXON; - iostate.c_oflag |= OPOST; - iostate.c_lflag &= ~(ECHO); - iostate.c_lflag |= ECHONL | ICANON | ISIG; + SET_BITS(iostate.c_iflag, BRKINT | IGNPAR | ISTRIP | ICRNL | IXON); + SET_BITS(iostate.c_oflag, OPOST); + CLEAR_BITS(iostate.c_lflag, ECHO); + /* + * Note: password input turns out to be best if you echo the + * newline that the user types. Theoretically we could get users + * to do the processing of this in their scripts, but it always + * feels highly unnatural to do so in practice. + */ + SET_BITS(iostate.c_lflag, ECHONL | ICANON | ISIG); } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) { - iostate.c_iflag = 0; - iostate.c_oflag &= ~(OPOST); - iostate.c_lflag &= ~(ECHO | ECHONL | ICANON | ISIG); +#ifdef HAVE_CFMAKERAW + cfmakeraw(&iostate); +#else /* !HAVE_CFMAKERAW */ + CLEAR_BITS(iostate.c_iflag, IGNBRK | BRKINT | PARMRK | ISTRIP + | INLCR | IGNCR | ICRNL | IXON); + CLEAR_BITS(iostate.c_oflag, OPOST); + CLEAR_BITS(iostate.c_lflag, ECHO | ECHONL | ICANON | ISIG | IEXTEN); + CLEAR_BITS(iostate.c_cflag, CSIZE | PARENB); + SET_BITS(iostate.c_cflag, CS8); +#endif /* HAVE_CFMAKERAW */ + } else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) { + /* + * Reset to the initial state, whatever that is. + */ + + memcpy(&iostate, &fsPtr->initState, sizeof(struct termios)); } else { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad mode \"%s\" for -inputmode: must be" - " normal, password, or raw", value)); + " normal, password, raw, or reset", value)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } @@ -891,11 +924,25 @@ TtySetOptionProc( if (tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate) < 0) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't update serial state: %s", + "couldn't update serial terminal control state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } + + /* + * If we've changed the state from default, schedule a reset later. + * Note that this specifically does not detect changes made by calling + * an external stty program; that is deliberate, as it maintains + * compatibility with existing code! + * + * This mechanism in Tcl is not intended to be a full replacement for + * what stty does; it just handles a few common cases and tries not to + * leave things in a broken state. + */ + + fsPtr->doReset = (memcmp(&iostate, &fsPtr->initState, + sizeof(struct termios)) != 0); return TCL_OK; } @@ -1598,8 +1645,6 @@ TclpOpenFileChannel( fcntl(fd, F_SETFD, FD_CLOEXEC); - sprintf(channelName, "file%d", fd); - #ifdef SUPPORTS_TTY if (strcmp(native, "/dev/tty") != 0 && isatty(fd)) { /* @@ -1619,17 +1664,25 @@ TclpOpenFileChannel( translation = "auto crlf"; channelTypePtr = &ttyChannelType; TtyInit(fd); + sprintf(channelName, "serial%d", fd); } else #endif /* SUPPORTS_TTY */ { translation = NULL; channelTypePtr = &fileChannelType; + sprintf(channelName, "file%d", fd); } fsPtr = ckalloc(sizeof(TtyState)); fsPtr->fileState.validMask = channelPermissions | TCL_EXCEPTION; fsPtr->fileState.fd = fd; - fsPtr->closeMode = CLOSE_DEFAULT; +#ifdef SUPPORTS_TTY + if (channelTypePtr == &ttyChannelType) { + fsPtr->closeMode = CLOSE_DEFAULT; + fsPtr->doReset = 0; + tcgetattr(fsPtr->fileState.fd, &fsPtr->initState); + } +#endif /* SUPPORTS_TTY */ fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName, fsPtr, channelPermissions); @@ -1675,7 +1728,7 @@ Tcl_MakeFileChannel( int mode) /* ORed combination of TCL_READABLE and * TCL_WRITABLE to indicate file mode. */ { - FileState *fsPtr; + TtyState *fsPtr; char channelName[16 + TCL_INTEGER_SPACE]; int fd = PTR2INT(handle); const Tcl_ChannelType *channelTypePtr; @@ -1694,22 +1747,30 @@ Tcl_MakeFileChannel( sprintf(channelName, "serial%d", fd); } else #endif /* SUPPORTS_TTY */ - if ((getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0) - && (sockaddrLen > 0) - && (sockaddr.sa_family == AF_INET || sockaddr.sa_family == AF_INET6)) { + if ((getsockname(fd, (struct sockaddr *) &sockaddr, &sockaddrLen) == 0) + && (sockaddrLen > 0) + && (sockaddr.sa_family == AF_INET + || sockaddr.sa_family == AF_INET6)) { return TclpMakeTcpClientChannelMode(INT2PTR(fd), mode); } else { channelTypePtr = &fileChannelType; sprintf(channelName, "file%d", fd); } - fsPtr = ckalloc(sizeof(FileState)); - fsPtr->fd = fd; - fsPtr->validMask = mode | TCL_EXCEPTION; - fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, + fsPtr = ckalloc(sizeof(TtyState)); + fsPtr->fileState.fd = fd; + fsPtr->fileState.validMask = mode | TCL_EXCEPTION; + fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName, fsPtr, mode); +#ifdef SUPPORTS_TTY + if (channelTypePtr == &ttyChannelType) { + fsPtr->closeMode = CLOSE_DEFAULT; + fsPtr->doReset = 0; + tcgetattr(fsPtr->fileState.fd, &fsPtr->initState); + } +#endif /* SUPPORTS_TTY */ - return fsPtr->channel; + return fsPtr->fileState.channel; } /* -- cgit v0.12 From 7ff500ca4d515a5bbf1b6b4442d857c369c727fd Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 27 Mar 2019 08:29:13 +0000 Subject: Add autoconf support --- unix/configure | 4 ++-- unix/configure.ac | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/configure b/unix/configure index ea26c4f..2de5b54 100755 --- a/unix/configure +++ b/unix/configure @@ -9455,10 +9455,10 @@ $as_echo "$langinfo_ok" >&6; } #-------------------------------------------------------------------- -# Check for support of chflags and mkstemps functions +# Check for support of cfmakeraw, chflags and mkstemps functions #-------------------------------------------------------------------- -for ac_func in chflags mkstemps +for ac_func in cfmakeraw chflags mkstemps do : as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" diff --git a/unix/configure.ac b/unix/configure.ac index f34091f..74dbe08 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -553,10 +553,10 @@ fi SC_ENABLE_LANGINFO #-------------------------------------------------------------------- -# Check for support of chflags and mkstemps functions +# Check for support of cfmakeraw, chflags and mkstemps functions #-------------------------------------------------------------------- -AC_CHECK_FUNCS(chflags mkstemps) +AC_CHECK_FUNCS(cfmakeraw chflags mkstemps) #-------------------------------------------------------------------- # Check for support of isnan() function or macro -- cgit v0.12 From bc322bfae7b2bcfc1c9946a184ddf7a7c7e5d4e1 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 27 Mar 2019 13:54:18 +0000 Subject: Partial implementation on Windows. UNTESTED --- unix/tclUnixChan.c | 13 +++- win/tclWinConsole.c | 212 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 215 insertions(+), 10 deletions(-) diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 605e317..152de88 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -979,6 +979,7 @@ TtyGetOptionProc( unsigned int len; char buf[3*TCL_INTEGER_SPACE + 16]; int valid = 0; /* Flag if valid option parsed. */ + struct termios iostate; if (optionName == NULL) { len = 0; @@ -1018,10 +1019,15 @@ TtyGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-inputmode"); } if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) { - struct termios iostate; - valid = 1; - tcgetattr(fsPtr->fileState.fd, &iostate); + if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read serial terminal control state: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } if (iostate.c_lflag & ICANON) { if (iostate.c_lflag & ECHO) { Tcl_DStringAppendElement(dsPtr, "normal"); @@ -1058,7 +1064,6 @@ TtyGetOptionProc( Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) { - struct termios iostate; Tcl_DString ds; valid = 1; diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index f8b67a3..acb00cb 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -31,8 +31,10 @@ TCL_DECLARE_MUTEX(consoleMutex) * Bit masks used in the flags field of the ConsoleInfo structure below. */ -#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ -#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ +#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ +#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ +#define CONSOLE_READ_OPS (1<<4) /* Channel supports read-related ops. */ +#define CONSOLE_RESET (1<<5) /* Console mode needs to be reset. */ /* * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. @@ -102,6 +104,7 @@ typedef struct ConsoleInfo { * readable object. */ int bytesRead; /* Number of bytes in the buffer. */ int offset; /* Number of bytes read out of the buffer. */ + DWORD initMode; /* Initial console mode. */ char buffer[CONSOLE_BUFFER_SIZE]; /* Data consumed by reader thread. */ } ConsoleInfo; @@ -144,12 +147,18 @@ 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, + Tcl_Interp *interp, const char *optionName, + Tcl_DString *dsPtr); static void ConsoleInit(void); static int ConsoleInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int ConsoleOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCode); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); +static int ConsoleSetOptionProc(ClientData 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 DWORD WINAPI ConsoleWriterThread(LPVOID arg); @@ -175,8 +184,8 @@ static const Tcl_ChannelType consoleChannelType = { ConsoleInputProc, /* Input proc. */ ConsoleOutputProc, /* Output proc. */ NULL, /* Seek proc. */ - NULL, /* Set option proc. */ - NULL, /* Get option proc. */ + ConsoleSetOptionProc, /* Set option proc. */ + ConsoleGetOptionProc, /* Get option proc. */ ConsoleWatchProc, /* Set up notifier to watch the channel. */ ConsoleGetHandleProc, /* Get an OS handle from channel. */ NULL, /* close2proc. */ @@ -569,6 +578,17 @@ ConsoleCloseProc( consolePtr->validMask &= ~TCL_WRITABLE; /* + * If the user has been tinkering with the mode, reset it now. We ignore + * any errors from this; we're quite possibly about to close or exit + * anyway. + */ + + if ((consolePtr->flags & CONSOLE_READ_OPS) && + (consolePtr->flags & CONSOLE_RESET)) { + SetConsoleMode(consolePtr->handle, consolePtr->initMode); + } + + /* * Don't close the Win32 handle if the handle is a standard channel during * the thread exit process. Otherwise, one thread may kill the stdio of * another. @@ -590,7 +610,7 @@ ConsoleCloseProc( * Remove the file from the list of watched files. */ - for (nextPtrPtr = &(tsdPtr->firstConsolePtr), infoPtr = *nextPtrPtr; + for (nextPtrPtr = &tsdPtr->firstConsolePtr, infoPtr = *nextPtrPtr; infoPtr != NULL; nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { if (infoPtr == (ConsoleInfo *) consolePtr) { @@ -1332,7 +1352,9 @@ TclWinOpenConsoleChannel( * we only want to catch when complete lines are ready for reading. */ - GetConsoleMode(infoPtr->handle, &modes); + infoPtr->flags |= CONSOLE_READ_OPS; + GetConsoleMode(infoPtr->handle, &infoPtr->initMode); + modes = infoPtr->initMode; modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); modes |= ENABLE_LINE_INPUT; SetConsoleMode(infoPtr->handle, modes); @@ -1415,6 +1437,184 @@ ConsoleThreadActionProc( } /* + *---------------------------------------------------------------------- + * + * ConsoleSetOptionProc -- + * + * Sets an option on a channel. + * + * Results: + * A standard Tcl result. Also sets the interp's result on error if + * interp is not NULL. + * + * Side effects: + * May modify an option on a console. Sets Error message if needed (by + * calling Tcl_BadChannelOption). + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleSetOptionProc( + ClientData 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. */ +{ + ConsoleInfo *infoPtr = instanceData; + int len = strlen(optionName); + + /* + * Option -inputmode normal|password|raw + */ + + if ((infoPtr->flags & CONSOLE_READ_OPS) && (len > 1) && + (strncmp(optionName, "-inputmode", len) == 0)) { + DWORD mode; + + if (GetConsoleMode(infoPtr->handle, &mode) == 0) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read console mode: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) { + mode |= ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT; + } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) { + mode |= ENABLE_LINE_INPUT; + mode &= ~ENABLE_ECHO_INPUT; + } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) { + mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT); + } else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) { + /* + * Reset to the initial mode, whatever that is. + */ + + mode = infoPtr->initMode; + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad mode \"%s\" for -inputmode: must be" + " normal, password, raw, or reset", value)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", + "VALUE", NULL); + } + return TCL_ERROR; + } + if (SetConsoleMode(infoPtr->handle, mode) == 0) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set console mode: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + + /* + * If we've changed the mode from default, schedule a reset later. + */ + + if (mode == infoPtr->initMode) { + infoPtr->flags &= ~CONSOLE_RESET; + } else { + infoPtr->flags |= CONSOLE_RESET; + } + return TCL_OK; + } + + if (infoPtr->flags & CONSOLE_READ_OPS) { + return Tcl_BadChannelOption(interp, optionName, "inputmode"); + } else { + return Tcl_BadChannelOption(interp, optionName, "inputmode"); + } +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleGetOptionProc -- + * + * Gets a mode associated with an IO channel. If the optionName arg is + * non-NULL, retrieves the value of that option. If the optionName arg is + * NULL, retrieves a list of alternating option names and values for the + * given channel. + * + * Results: + * A standard Tcl result. Also sets the supplied DString to the string + * value of the option(s) returned. Sets error message if needed + * (by calling Tcl_BadChannelOption). + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleGetOptionProc( + ClientData 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). */ +{ + ConsoleInfo *infoPtr = instanceData; + int valid = 0; /* Flag if valid option parsed. */ + unsigned int len; + + if (optionName == NULL) { + len = 0; + } else { + len = strlen(optionName); + } + + /* + * Get option -inputmode + * + * This is a great simplification of the underlying reality, but actually + * represents what almost all scripts really want to know. + */ + + if (infoPtr->flags & CONSOLE_READ_OPS) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-inputmode"); + } + if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) { + DWORD mode; + + valid = 1; + if (GetConsoleMode(infoPtr->handle, &mode) == 0) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read console mode: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + if (mode & ENABLE_LINE_INPUT) { + if (mode & ENABLE_ECHO_INPUT) { + Tcl_DStringAppendElement(dsPtr, "normal"); + } else { + Tcl_DStringAppendElement(dsPtr, "password"); + } + } else { + Tcl_DStringAppendElement(dsPtr, "raw"); + } + } + } + + if (valid) { + return TCL_OK; + } + if (infoPtr->flags & CONSOLE_READ_OPS) { + return Tcl_BadChannelOption(interp, optionName, "inputmode"); + } else { + return Tcl_BadChannelOption(interp, optionName, ""); + } +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 -- cgit v0.12 From f787bc7152549932e82fc955ace3eb11f2bf8496 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 27 Mar 2019 21:14:46 +0000 Subject: Implement -closemode --- win/tclWinSerial.c | 85 ++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 80 insertions(+), 5 deletions(-) diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 8ee426b..e4393a8 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -44,6 +44,15 @@ TCL_DECLARE_MUTEX(serialMutex) #define SERIAL_ERROR (1<<4) /* + * Bit masks used for noting whether to drain or discard output on close. They + * are disjoint from each other; at most one may be set at a time. + */ + +#define SERIAL_CLOSE_DRAIN (1<<6) /* Drain all output on close. */ +#define SERIAL_CLOSE_DISCARD (1<<7) /* Discard all output on close. */ +#define SERIAL_CLOSE_MASK (3<<6) /* Both two bits above. */ + +/* * Default time to block between checking status on the serial port. */ @@ -604,7 +613,6 @@ SerialCloseProc( serialPtr->validMask &= ~TCL_READABLE; if (serialPtr->writeThread) { - TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread); CloseHandle(serialPtr->osWrite.hEvent); @@ -1278,7 +1286,7 @@ SerialWriterThread( /* exit */ break; } - infoPtr = (SerialInfo *)pipeTI->clientData; + infoPtr = (SerialInfo *) pipeTI->clientData; buf = infoPtr->writeBuf; toWrite = infoPtr->toWrite; @@ -1342,7 +1350,25 @@ SerialWriterThread( Tcl_MutexUnlock(&serialMutex); } - /* Worker exit, so inform the main thread or free TI-structure (if owned) */ + /* + * We're about to close, so do any drain or discard required. + */ + + if (infoPtr) { + switch (infoPtr->flags & SERIAL_CLOSE_MASK) { + case SERIAL_CLOSE_DRAIN: + FlushFileBuffers(infoPtr->handle); + break; + case SERIAL_CLOSE_DISCARD: + PurgeComm(infoPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR); + break; + } + } + + /* + * Worker exit, so inform the main thread or free TI-structure (if owned). + */ + TclPipeThreadExit(&pipeTI); return 0; @@ -1610,6 +1636,32 @@ SerialSetOptionProc( vlen = strlen(value); /* + * Option -closemode drain|discard|default + */ + + if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) { + if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) { + infoPtr->flags &= ~SERIAL_CLOSE_MASK; + } else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) { + infoPtr->flags &= ~SERIAL_CLOSE_MASK; + infoPtr->flags |= SERIAL_CLOSE_DRAIN; + } else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) { + infoPtr->flags &= ~SERIAL_CLOSE_MASK; + infoPtr->flags |= SERIAL_CLOSE_DISCARD; + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad mode \"%s\" for -closemode: must be" + " default, discard, or drain", value)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", + "VALUE", NULL); + } + return TCL_ERROR; + } + return TCL_OK; + } + + /* * Option -mode baud,parity,databits,stopbits */ @@ -1938,7 +1990,8 @@ SerialSetOptionProc( } return Tcl_BadChannelOption(interp, optionName, - "mode handshake pollinterval sysbuffer timeout ttycontrol xchar"); + "closemode mode handshake pollinterval sysbuffer timeout " + "ttycontrol xchar"); getStateFailed: if (interp != NULL) { @@ -1999,6 +2052,27 @@ SerialGetOptionProc( } /* + * Get option -closemode + */ + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-closemode"); + } + if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) { + switch (infoPtr->flags & SERIAL_CLOSE_MASK) { + case SERIAL_CLOSE_DRAIN: + Tcl_DStringAppendElement(dsPtr, "drain"); + break; + case SERIAL_CLOSE_DISCARD: + Tcl_DStringAppendElement(dsPtr, "discard"); + break; + default: + Tcl_DStringAppendElement(dsPtr, "default"); + break; + } + } + + /* * Get option -mode */ @@ -2174,7 +2248,8 @@ SerialGetOptionProc( return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, - "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); + "closemode mode pollinterval lasterror queue sysbuffer ttystatus " + "xchar"); } /* -- cgit v0.12 From ba13f3330ac8409d661a5713012837ede410b32a Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 28 Mar 2019 10:53:55 +0000 Subject: Documentation --- doc/open.n | 134 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 128 insertions(+), 6 deletions(-) diff --git a/doc/open.n b/doc/open.n index 1cccc0a..f6aca52 100644 --- a/doc/open.n +++ b/doc/open.n @@ -166,8 +166,9 @@ is opened and initialized in a platform-dependent manner. Acceptable values for the \fIfileName\fR to use to open a serial port are described in the PORTABILITY ISSUES section. .PP -The \fBfconfigure\fR command can be used to query and set additional -configuration options specific to serial ports (where supported): +The \fBchan configure\fR and \fBfconfigure\fR commands can be used to query +and set additional configuration options specific to serial ports (where +supported): .TP \fB\-mode\fR \fIbaud\fB,\fIparity\fB,\fIdata\fB,\fIstop\fR . @@ -249,6 +250,69 @@ handshake characters. Normally the operating system default should be DC1 (0x11) and DC3 (0x13) representing the ASCII standard XON and XOFF characters. .TP +\fB\-closemode\fR \fIcloseMode\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 +. +indicates that a system default operation should be used; all serial channels +default to this. +.TP +\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 +. +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" +.TP +\fB\-inputmode\fR \fIinputMode\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 +the assumption that it is talking to a termina, which controls how interactive +input from users is handled. The following values for \fIinputMode\fR are +supported: +.RS +.TP +\fBnormal\fR +. +indicates that normal line-oriented input should be used, with standard +terminal editing capabilities enabled. +.TP +\fBpassword\fR +. +indicates that non-echoing input should be used, with standard terminal +editing capabilitied enabled but no writing of typed characters to the +terminal (except for newlines). Some terminals may indicate this specially. +.TP +\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) +. +indicates that the terminal should be reset to what state it was in when the +terminal was opened. +.PP +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 +.VE "8.7, TIP 160" +.TP \fB\-pollinterval\fR \fImsec\fR . (Windows only). This option is used to set the maximum time between @@ -275,7 +339,7 @@ In case of a serial communication error, \fBread\fR or \fBputs\fR returns a general Tcl file I/O error. \fBfconfigure\fR \fB\-lasterror\fR can be called to get a list of error details. See below for an explanation of the various error codes. -.SH "SERIAL PORT SIGNALS" +.SS "SERIAL PORT SIGNALS" .PP RS-232 is the most commonly used standard electrical interface for serial communications. A negative voltage (-3V..-12V) define a mark (on=1) bit and @@ -316,7 +380,7 @@ milliseconds. Normally a receive or transmit data signal stays at the mark (on=1) voltage until the next character is transferred. A BREAK is sometimes used to reset the communications line or change the operating mode of communications hardware. -.SH "ERROR CODES (Windows only)" +.SS "ERROR CODES (Windows only)" .PP A lot of different errors may occur during serial read operations or during event polling in background. The external device may have been switched @@ -359,7 +423,7 @@ may cause this error. \fBBREAK\fR . A BREAK condition has been detected by your UART (see above). -.SH "PORTABILITY ISSUES" +.SS "PORTABILITY ISSUES" .TP \fBWindows \fR . @@ -408,7 +472,49 @@ input, but is redirected from a file, then the above problem does not occur. See the \fBPORTABILITY ISSUES\fR section of the \fBexec\fR command for additional information not specific to command pipelines about executing applications on the various platforms -.SH "EXAMPLE" +.SH "CONSOLE CHANNELS" +.VS "8.7, TIP 160" +On Windows only, console channels (usually \fBstdin\fR or \fBstdout\fR) +support the following option: +.TP +\fB\-inputmode\fR \fIinputMode\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 +. +indicates that normal line-oriented input should be used, with standard +console editing capabilities enabled. +.TP +\fBpassword\fR +. +indicates that non-echoing input should be used, with standard console +editing capabilitied enabled but no writing of typed characters to the +terminal (except for newlines). +.TP +\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. +.TP +\fBreset\fR (set only) +. +indicates that the console should be reset to what state it was in when the +console channel was opened. +.PP +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 +.PP +Note that the equivalent option exists on Unix, but is on the serial channel +type. +.VE "8.7, TIP 160" +.SH "EXAMPLES" .PP Open a command pipeline and catch any errors: .PP @@ -419,6 +525,22 @@ if {[catch {close $fl} err]} { puts "ls command failed: $err" } .CE +.PP +.VS "8.7, TIP 160" +Read a password securely from the user (assuming that the script is being run +interactively): +.PP +.CS +chan configure stdin \fB-inputmode password\fR +try { + chan puts -nonewline "Password: " + chan flush stdout + set thePassword [chan gets stdin] +} finally { + chan configure stdin \fB-inputmode reset\fR +} +.CE +.VE "8.7, TIP 160" .SH "SEE ALSO" file(n), close(n), filename(n), fconfigure(n), gets(n), read(n), puts(n), exec(n), pid(n), fopen(3) -- cgit v0.12 From 99c5fed89eb2433b809000fb6846d2224a812762 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 28 Mar 2019 13:11:58 +0000 Subject: Tests, but not working ones... --- tests/ioCmd.test | 128 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 73 insertions(+), 55 deletions(-) diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 68bc542..9c93102 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -206,78 +206,90 @@ test iocmd-7.5 {close command} -setup { close $chan } -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed" -test iocmd-8.1 {fconfigure command} { - list [catch {fconfigure} msg] $msg -} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} -test iocmd-8.2 {fconfigure command} { - list [catch {fconfigure a b c d e f} msg] $msg -} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} -test iocmd-8.3 {fconfigure command} { - list [catch {fconfigure a b} msg] $msg -} {1 {can not find channel named "a"}} -test iocmd-8.4 {fconfigure command} { +proc expectedOpts {got extra} { + set basicOpts { + -blocking -buffering -buffersize -encoding -eofchar -translation + } + set opts [list {*}$basicOpts {*}$extra] + lset opts end [string cat "or " [lindex $opts end]] + return [format {bad option "%s": should be one of %s} $got [join $opts ", "]] +} +test iocmd-8.1 {fconfigure command} -returnCodes error -body { + fconfigure +} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"} +test iocmd-8.2 {fconfigure command} -returnCodes error -body { + fconfigure a b c d e f +} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"} +test iocmd-8.3 {fconfigure command} -returnCodes error -body { + fconfigure a b +} -result {can not find channel named "a"} +test iocmd-8.4 {fconfigure command} -setup { file delete $path(test1) set f1 [open $path(test1) w] - set x [list [catch {fconfigure $f1 froboz} msg] $msg] +} -body { + fconfigure $f1 froboz +} -returnCodes error -cleanup { close $f1 - set x -} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.5 {fconfigure command} { - list [catch {fconfigure stdin -buffering froboz} msg] $msg -} {1 {bad value for -buffering: must be one of full, line, or none}} -test iocmd-8.6 {fconfigure command} { - list [catch {fconfigure stdin -translation froboz} msg] $msg -} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} -test iocmd-8.7 {fconfigure command} { +} -result [expectedOpts "froboz" {}] +test iocmd-8.5 {fconfigure command} -returnCodes error -body { + fconfigure stdin -buffering froboz +} -result {bad value for -buffering: must be one of full, line, or none} +test iocmd-8.6 {fconfigure command} -returnCodes error -body { + fconfigure stdin -translation froboz +} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform} +test iocmd-8.7 {fconfigure command} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation lf -eofchar {} -encoding unicode - set x [fconfigure $f1] - close $f1 - set x -} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} -test iocmd-8.8 {fconfigure command} { + fconfigure $f1 +} -cleanup { + catch {close $f1} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} +test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) + set x {} +} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ -eofchar {} -encoding unicode - set x "" lappend x [fconfigure $f1 -buffering] lappend x [fconfigure $f1] - close $f1 - set x -} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} -test iocmd-8.9 {fconfigure command} { +} -cleanup { + catch {close $f1} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} +test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ -eofchar {} -encoding binary - set x [fconfigure $f1] - close $f1 - set x -} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} -test iocmd-8.10 {fconfigure command} { - list [catch {fconfigure a b} msg] $msg -} {1 {can not find channel named "a"}} + fconfigure $f1 +} -cleanup { + catch {close $f1} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} +test iocmd-8.10 {fconfigure command} -returnCodes error -body { + fconfigure a b +} -result {can not find channel named "a"} set path(fconfigure.dummy) [makeFile {} fconfigure.dummy] -test iocmd-8.11 {fconfigure command} { +test iocmd-8.11 {fconfigure command} -body { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg] - close $chan - set res -} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.12 {fconfigure command} { + fconfigure $chan -froboz blarfo +} -returnCodes error -cleanup { + catch {close $chan} +} -result [expectedOpts "-froboz" {}] +test iocmd-8.12 {fconfigure command} -body { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -b blarfo} msg] $msg] - close $chan - set res -} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.13 {fconfigure command} { + fconfigure $chan -b blarfo +} -returnCodes error -cleanup { + catch {close $chan} +} -result [expectedOpts "-b" {}] +test iocmd-8.13 {fconfigure command} -body { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg] - close $chan - set res -} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} + fconfigure $chan -buffer blarfo +} -returnCodes error -cleanup { + catch {close $chan} +} -result [expectedOpts "-buffer" {}] removeFile fconfigure.dummy test iocmd-8.14 {fconfigure command} { fconfigure stdin -buffers @@ -294,7 +306,7 @@ test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOr close $srv unset cli srv port rename iocmdSRV {} -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -connecting, -peername, or -sockname} +} -returnCodes error -result [expectedOpts "-blah" {-connecting -peername -sockname}] test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] @@ -337,7 +349,7 @@ test iocmd-8.18 {fconfigure command / unix tty channel} -constraints {nonPortabl if {$tty ne ""} { close $tty } -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode} +} -returnCodes error -result [expectedOpts "-blah" {-closemode -inputmode -mode -queue -ttystatus -xchar}] test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup { set tty "" } -body { @@ -348,7 +360,13 @@ test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable if {$tty ne ""} { close $tty } -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar} +} -returnCodes error -result [expectedOpts "-blah" {-closemode -mode -handshake -pollinterval -sysbuffer -timeout -ttycontrol -xchar}] +test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPortable win} -setup { + # I don't know how else to open the console, but this is non-portable + set console stdin +} -body { + fconfigure $console -blah blih +} -returnCodes error -result [expectedOpts "-blah" {-inputmode}] # TODO: Test parsing of serial channel options (nonPortable, since requires an # open channel to work with). -- cgit v0.12 From 5624496889a065617fbded91ff512c4066b51f64 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 29 Mar 2019 11:57:23 +0000 Subject: Oops --- win/tclWinConsole.c | 1 + 1 file changed, 1 insertion(+) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index acb00cb..de2723b 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -1463,6 +1463,7 @@ ConsoleSetOptionProc( { ConsoleInfo *infoPtr = instanceData; int len = strlen(optionName); + int vlen = strlen(value); /* * Option -inputmode normal|password|raw -- cgit v0.12 From 8ac5057a32d3241ca2ca4a353b1cb650c09e3eb0 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 29 Mar 2019 14:22:23 +0000 Subject: Support -winsize read-only option --- doc/open.n | 16 ++++++++++++++-- unix/tclUnixChan.c | 28 +++++++++++++++++++++++++++- win/tclWinConsole.c | 31 +++++++++++++++++++++++++++++-- 3 files changed, 70 insertions(+), 5 deletions(-) diff --git a/doc/open.n b/doc/open.n index f6aca52..d128512 100644 --- a/doc/open.n +++ b/doc/open.n @@ -311,6 +311,12 @@ 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 +.TP +\fB\-winsize\fR +. +(Unix only; Windows has the equivalent option on console channels). This +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" .TP \fB\-pollinterval\fR \fImsec\fR @@ -475,7 +481,7 @@ applications on the various platforms .SH "CONSOLE CHANNELS" .VS "8.7, TIP 160" On Windows only, console channels (usually \fBstdin\fR or \fBstdout\fR) -support the following option: +support the following options: .TP \fB\-inputmode\fR \fIinputMode\fR . @@ -510,8 +516,14 @@ 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 +.TP +\fB\-winsize\fR +. +This option is query only. +It retrieves a two-element list with the the current width and height of the +console that this channel is talking to. .PP -Note that the equivalent option exists on Unix, but is on the serial channel +Note that the equivalent options exist on Unix, but are on the serial channel type. .VE "8.7, TIP 160" .SH "EXAMPLES" diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 152de88..ffeb0a7 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1119,11 +1119,37 @@ TtyGetOptionProc( } #endif /* TIOCMGET */ +#if defined(TIOCGWINSZ) + /* + * Get option -winsize + * Option is readonly and returned by [fconfigure chan -winsize] but not + * returned by [fconfigure chan] without explicit option name. + */ + + if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) { + struct winsize ws; + + valid = 1; + if (ioctl(fsPtr->fileState.fd, TIOCGWINSZ, &ws) < 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read terminal size: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + sprintf(buf, "%d", ws.ws_col); + Tcl_DStringAppendElement(dsPtr, buf); + sprintf(buf, "%d", ws.ws_row); + Tcl_DStringAppendElement(dsPtr, buf); + } +#endif /* TIOCGWINSZ */ + if (valid) { return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, - "closemode inputmode mode queue ttystatus xchar"); + "closemode inputmode mode queue ttystatus winsize xchar"); } static const struct {int baud; speed_t speed;} speeds[] = { diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index de2723b..d07bd3a 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -1530,7 +1530,7 @@ ConsoleSetOptionProc( if (infoPtr->flags & CONSOLE_READ_OPS) { return Tcl_BadChannelOption(interp, optionName, "inputmode"); } else { - return Tcl_BadChannelOption(interp, optionName, "inputmode"); + return Tcl_BadChannelOption(interp, optionName, ""); } } @@ -1605,11 +1605,38 @@ ConsoleGetOptionProc( } } + /* + * Get option -winsize + * Option is readonly and returned by [fconfigure chan -winsize] but not + * returned by [fconfigure chan] without explicit option name. + */ + + if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) { + CONSOLE_SCREEN_BUFFER_INFO consoleInfo; + + valid = 1; + if (!GetConsoleScreenBufferInfo(infoPtr->handle, &consoleInfo)) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read console size: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + sprintf(buf, "%d", + consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1); + Tcl_DStringAppendElement(dsPtr, buf); + sprintf(buf, "%d", + consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1); + Tcl_DStringAppendElement(dsPtr, buf); + } + if (valid) { return TCL_OK; } if (infoPtr->flags & CONSOLE_READ_OPS) { - return Tcl_BadChannelOption(interp, optionName, "inputmode"); + return Tcl_BadChannelOption(interp, optionName, "inputmode winsize"); } else { return Tcl_BadChannelOption(interp, optionName, ""); } -- cgit v0.12 From d78f576dc5981f706b44ef783bdc285e992db779 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 30 Mar 2019 10:36:58 +0000 Subject: Implementation of [lremove]. --- generic/tclBasic.c | 1 + generic/tclCmdIL.c | 114 +++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 ++ 3 files changed, 118 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1806557..e377951 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -262,6 +262,7 @@ static const CmdInfo builtInCmds[] = { {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, + {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index a1a7f3e..0e36455 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2704,6 +2704,120 @@ Tcl_LrangeObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_LremoveObjCmd -- + * + * This procedure is invoked to process the "lremove" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +typedef int list_index_t; + +static int +LremoveIndexCompare( + const void *el1Ptr, + const void *el2Ptr) +{ + list_index_t idx1 = *((const list_index_t *) el1Ptr); + list_index_t idx2 = *((const list_index_t *) el2Ptr); + + /* + * This will put the larger element first. + */ + + return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0; +} + +int +Tcl_LremoveObjCmd( + ClientData notUsed, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int i, idxc; + list_index_t listLen, *idxv, prevIdx; + Tcl_Obj *listObj; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); + return TCL_ERROR; + } + + listObj = objv[1]; + if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) { + return TCL_ERROR; + } + + idxc = objc - 2; + if (idxc == 0) { + Tcl_SetObjResult(interp, listObj); + return TCL_OK; + } + idxv = ckalloc((objc - 2) * sizeof(list_index_t)); + for (i = 2; i < objc; i++) { + if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1, + &idxv[i - 2]) != TCL_OK) { + ckfree(idxv); + return TCL_ERROR; + } + } + + /* + * Sort the indices, large to small so that when we remove an index we + * don't change the indices still to be processed. + */ + + if (idxc > 1) { + qsort(idxv, idxc, sizeof(list_index_t), LremoveIndexCompare); + } + + /* + * Make our working copy, then do the actual removes piecemeal. It would + * be more efficient to do range coalescing; contributions accepted! + */ + + if (Tcl_IsShared(listObj)) { + listObj = TclListObjCopy(NULL, listObj); + } + for (i = 0, prevIdx = -1 ; i < idxc ; i++) { + list_index_t idx = idxv[i]; + + /* + * Repeated index and sanity check. + */ + + if (idx == prevIdx) { + continue; + } + prevIdx = idx; + if (idx < 0 || idx >= listLen) { + continue; + } + + /* + * Note that this operation can't fail now; we know we have a list and + * we're only ever contracting that list. + */ + + (void) Tcl_ListObjReplace(interp, listObj, idx, 1, 0, NULL); + listLen--; + } + ckfree(idxv); + Tcl_SetObjResult(interp, listObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_LrepeatObjCmd -- * * This procedure is invoked to process the "lrepeat" Tcl command. See diff --git a/generic/tclInt.h b/generic/tclInt.h index 9fc778b..6a3eafe 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3471,6 +3471,9 @@ MODULE_SCOPE int Tcl_LpopObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LremoveObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrepeatObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -- cgit v0.12 From 83f6cc3841131f68cf0b1b4bb410ce6b52157629 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 30 Mar 2019 12:41:59 +0000 Subject: Tests, and reduce number of copies. --- generic/tclCmdIL.c | 36 +++++++++++++++++++++++++++++------- tests/cmdIL.test | 51 ++++++++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 77 insertions(+), 10 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 0e36455..441090c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2743,9 +2743,13 @@ Tcl_LremoveObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int i, idxc; - list_index_t listLen, *idxv, prevIdx; + list_index_t listLen, *idxv, prevIdx, first, num; Tcl_Obj *listObj; + /* + * Parse the arguments. + */ + if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); return TCL_ERROR; @@ -2780,13 +2784,14 @@ Tcl_LremoveObjCmd( } /* - * Make our working copy, then do the actual removes piecemeal. It would - * be more efficient to do range coalescing; contributions accepted! + * Make our working copy, then do the actual removes piecemeal. */ if (Tcl_IsShared(listObj)) { listObj = TclListObjCopy(NULL, listObj); } + num = 0; + first = listLen; for (i = 0, prevIdx = -1 ; i < idxc ; i++) { list_index_t idx = idxv[i]; @@ -2803,12 +2808,29 @@ Tcl_LremoveObjCmd( } /* - * Note that this operation can't fail now; we know we have a list and - * we're only ever contracting that list. + * Coalesce adjacent removes to reduce the number of copies. */ - (void) Tcl_ListObjReplace(interp, listObj, idx, 1, 0, NULL); - listLen--; + if (num == 0) { + num = 1; + first = idx; + } else if (idx + 1 == first) { + num++; + first = idx; + } else { + /* + * Note that this operation can't fail now; we know we have a list + * and we're only ever contracting that list. + */ + + (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); + listLen -= num; + num = 1; + first = idx; + } + } + if (num != 0) { + (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); } ckfree(idxv); Tcl_SetObjResult(interp, listObj); diff --git a/tests/cmdIL.test b/tests/cmdIL.test index e4931a4..215796f 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -19,7 +19,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] - + test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body { lsort } -result {wrong # args: should be "lsort ?-option value ...? list"} @@ -774,6 +774,52 @@ test cmdIL-7.8 {lreverse command - shared intrep [Bug 1675044]} -setup { rename K {} } -result 1 +test cmdIL-8.1 {lremove command: error path} -returnCodes error -body { + lremove +} -result {wrong # args: should be "lremove list ?index ...?"} +test cmdIL-8.2 {lremove command: error path} -returnCodes error -body { + lremove {{}{}} +} -result {list element in braces followed by "{}" instead of space} +test cmdIL-8.3 {lremove command: error path} -returnCodes error -body { + lremove {a b c} gorp +} -result {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?} +test cmdIL-8.4 {lremove command: no indices} -body { + lremove {a b c} +} -result {a b c} +test cmdIL-8.5 {lremove command: before start} -body { + lremove {a b c} -1 +} -result {a b c} +test cmdIL-8.6 {lremove command: after end} -body { + lremove {a b c} 3 +} -result {a b c} +test cmdIL-8.7 {lremove command} -body { + lremove {a b c} 0 +} -result {b c} +test cmdIL-8.8 {lremove command} -body { + lremove {a b c} 1 +} -result {a c} +test cmdIL-8.9 {lremove command} -body { + lremove {a b c} end +} -result {a b} +test cmdIL-8.10 {lremove command} -body { + lremove {a b c} end-1 +} -result {a c} +test cmdIL-8.11 {lremove command} -body { + lremove {a b c d e} 1 3 +} -result {a c e} +test cmdIL-8.12 {lremove command} -body { + lremove {a b c d e} 3 1 +} -result {a c e} +test cmdIL-8.13 {lremove command: same index twice} -body { + lremove {a b c d e} 2 2 +} -result {a b d e} +test cmdIL-8.14 {lremove command: same index twice} -body { + lremove {a b c d e} 3 end-1 +} -result {a b c e} +test cmdIL-8.15 {lremove command: many indices} -body { + lremove {a b c d e} 1 3 1 4 0 +} -result {c} + # This belongs in info test, but adding tests there breaks tests # that compute source file line numbers. test info-20.6 {Bug 3587651} -setup { @@ -782,8 +828,7 @@ test info-20.6 {Bug 3587651} -setup { }}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup { namespace delete my } -result 1 - - + # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 3471a570b685e48a9da13cc60a506f175ba0283b Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 30 Mar 2019 12:54:52 +0000 Subject: Added documentation --- doc/lrange.n | 2 +- doc/lremove.n | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ doc/lreplace.n | 2 +- 3 files changed, 57 insertions(+), 2 deletions(-) create mode 100644 doc/lremove.n diff --git a/doc/lrange.n b/doc/lrange.n index ba068f6..a4fd98b 100644 --- a/doc/lrange.n +++ b/doc/lrange.n @@ -72,7 +72,7 @@ elements to .CE .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lreplace(n), lsort(n), +lset(n), lremove(n), lreplace(n), lsort(n), string(n) .SH KEYWORDS element, list, range, sublist diff --git a/doc/lremove.n b/doc/lremove.n new file mode 100644 index 0000000..b947863 --- /dev/null +++ b/doc/lremove.n @@ -0,0 +1,55 @@ +'\" +'\" Copyright (c) 2019 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 lremove n 8.7 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lremove \- Remove elements from a list by index +.SH SYNOPSIS +\fBlremove \fIlist\fR ?\fIindex ...\fR? +.BE +.SH DESCRIPTION +.PP +\fBlremove\fR returns a new list formed by simultaneously removing zero or +more elements of \fIlist\fR at each of the indices given by an arbirary number +of \fIindex\fR arguments. The indices may be in any order and may be repeated; +the element at index will only be removed once. The index values are +interpreted the same as index values for the command \fBstring index\fR, +supporting simple index arithmetic and indices relative to the end of the +list. 0 refers to the first element of the list, and \fBend\fR refers to the +last element of the list. +.SH EXAMPLES +.PP +Removing the third element of a list: +.PP +.CS +% \fBlremove\fR {a b c d e} 2 +a b d e +.CE +.PP +Removing two elements from a list: +.PP +.CS +% \fBlremove\fR {a b c d e} end-1 1 +a c e +.CE +.PP +Removing the same element indicated in two different ways: +.PP +.CS +% \fBlremove\fR {a b c d e} 2 end-2 +a b d e +.CE +.SH "SEE ALSO" +list(n), lrange(n), lsearch(n), lsearch(n) +.SH KEYWORDS +element, list, remove +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/lreplace.n b/doc/lreplace.n index 32b7356..68cddfe 100644 --- a/doc/lreplace.n +++ b/doc/lreplace.n @@ -96,7 +96,7 @@ a b c d e f g h i .VE TIP505 .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lrange(n), lsort(n), +lset(n), lrange(n), lremove(n), lsort(n), string(n) .SH KEYWORDS element, list, replace -- cgit v0.12 From d2fb211d208690336c1cc183cbd4c8d488411ff2 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 1 Apr 2019 08:48:16 +0000 Subject: Implement [dict getwithdefault] --- generic/tclDictObj.c | 66 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index baf96a8..c312242 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -34,6 +34,9 @@ static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictGetCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static int DictGetWithDefaultCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp, @@ -89,6 +92,7 @@ static const EnsembleImplMap implementationMap[] = { {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, + {"getwithdefault", DictGetWithDefaultCmd, NULL, NULL, NULL, 0 }, {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, @@ -1627,6 +1631,68 @@ DictGetCmd( /* *---------------------------------------------------------------------- * + * DictGetWithDefaultCmd -- + * + * This function implements the "dict getwithdefault" Tcl command. See + * the user documentation for details on what it does, and TIP#342 for + * the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictGetWithDefaultCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr; + Tcl_Obj *const *keyPath; + int numKeys; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key value"); + return TCL_ERROR; + } + + /* + * Give the bits of arguments names for clarity. + */ + + dictPtr = objv[1]; + keyPath = &objv[2]; + numKeys = objc - 4; + keyPtr = objv[objc - 2]; + defaultPtr = objv[objc - 1]; + + /* + * Implement the getting-with-default operation. + */ + + dictPtr = TclTraceDictPath(interp, dictPtr, numKeys, keyPath, + DICT_PATH_READ); + if (dictPtr == NULL) { + return TCL_ERROR; + } else if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) { + return TCL_ERROR; + } else if (valuePtr == NULL) { + Tcl_SetObjResult(interp, defaultPtr); + } else { + Tcl_SetObjResult(interp, valuePtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * DictReplaceCmd -- * * This function implements the "dict replace" Tcl command. See the user -- cgit v0.12 From 8d4509eafc4ae6d4ebc12d6b08180fca038bdf8f Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 1 Apr 2019 10:38:47 +0000 Subject: Add tests --- generic/tclDictObj.c | 9 ++++++--- tests/dict.test | 28 ++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 3 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index c312242..75dcd09 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -1658,7 +1658,7 @@ DictGetWithDefaultCmd( int numKeys; if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key value"); + Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key default"); return TCL_ERROR; } @@ -1668,7 +1668,8 @@ DictGetWithDefaultCmd( dictPtr = objv[1]; keyPath = &objv[2]; - numKeys = objc - 4; + numKeys = objc - 4; /* Number of keys in keyPath; there's always + * one extra key afterwards too. */ keyPtr = objv[objc - 2]; defaultPtr = objv[objc - 1]; @@ -1677,9 +1678,11 @@ DictGetWithDefaultCmd( */ dictPtr = TclTraceDictPath(interp, dictPtr, numKeys, keyPath, - DICT_PATH_READ); + DICT_PATH_EXISTS); if (dictPtr == NULL) { return TCL_ERROR; + } else if (dictPtr == DICT_PATH_NON_EXISTENT) { + Tcl_SetObjResult(interp, defaultPtr); } else if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) { return TCL_ERROR; } else if (valuePtr == NULL) { diff --git a/tests/dict.test b/tests/dict.test index 904ec53..50e4db7 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -2047,6 +2047,34 @@ test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} dict update item item item two two {} }} } {} + +test dict-26.1 {dict getwithdefault command} -body { + dict getwithdefault {a b} a c +} -result b +test dict-26.2 {dict getwithdefault command} -body { + dict getwithdefault {a b} b c +} -result c +test dict-26.3 {dict getwithdefault command} -body { + dict getwithdefault {a {b c}} a b d +} -result c +test dict-26.4 {dict getwithdefault command} -body { + dict getwithdefault {a {b c}} a c d +} -result d +test dict-26.5 {dict getwithdefault command} -body { + dict getwithdefault {a {b c}} b c d +} -result d +test dict-26.6 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault {a {b c d}} a b d +} -result {missing value to go with key} +test dict-26.7 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault +} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} +test dict-26.8 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault {} +} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} +test dict-26.9 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault {} {} +} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 325bbf57920315a1457d500d5fec8867c0e0744b Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 1 Apr 2019 10:51:33 +0000 Subject: Document --- doc/dict.n | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/doc/dict.n b/doc/dict.n index 1829768..12c9b1a 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -120,6 +120,19 @@ It is an error to attempt to retrieve a value for a key that is not present in the dictionary. .RE .TP +\fBdict getwithdefault \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR +.VS "8.7, TIP342" +This behaves the same as \fBdict get\fR (with at least one \fIkey\fR +argument), returning the value that the key path maps to in the +dictionary \fIdictionaryValue\fR, except that instead of producing an +error because the \fIkey\fR (or one of the \fIkey\fRs on the key path) +is absent, it returns the \fIdefault\fR argument instead. +.RS +.PP +Note that there must always be at least one \fIkey\fR provided. +.RE +.VE "8.7, TIP342" +.TP \fBdict incr \fIdictionaryVariable key \fR?\fIincrement\fR? . This adds the given increment value (an integer that defaults to 1 if -- cgit v0.12 From dab604e786914f07c525dfc438f35b3d860d8261 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 1 Apr 2019 16:15:45 +0000 Subject: typos --- doc/open.n | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/open.n b/doc/open.n index d128512..b0d9781 100644 --- a/doc/open.n +++ b/doc/open.n @@ -280,7 +280,7 @@ been consumed. This may slow down \fBclose\fR noticeably. .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 -the assumption that it is talking to a termina, which controls how interactive +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 @@ -293,7 +293,7 @@ terminal editing capabilities enabled. \fBpassword\fR . indicates that non-echoing input should be used, with standard terminal -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). Some terminals may indicate this specially. .TP \fBraw\fR -- cgit v0.12 From d1069c7b4fe1fb124221c35f0671fc9ed238619e Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 3 Apr 2019 07:58:17 +0000 Subject: Import of TIP 312 implementation --- generic/tcl.decls | 6 + generic/tcl.h | 2 + generic/tclDecls.h | 7 + generic/tclLink.c | 927 ++++++++++++++++++++++++++++++++++++++++++-------- generic/tclStubInit.c | 1 + generic/tclTest.c | 120 +++++++ tests/link.test | 455 ++++++++++++++++++++++++- 7 files changed, 1373 insertions(+), 145 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index d404d25..f2ceeee 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2379,6 +2379,12 @@ declare 643 { int Tcl_IsShared(Tcl_Obj *objPtr) } +# TIP#312 New Tcl_LinkArray() function +declare 644 { + int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr, + int type, int size) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index c287a84..e34a609 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1093,6 +1093,8 @@ typedef struct Tcl_DString { #endif #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 +#define TCL_LINK_CHARS 15 +#define TCL_LINK_BINARY 16 #define TCL_LINK_READ_ONLY 0x80 /* diff --git a/generic/tclDecls.h b/generic/tclDecls.h index c50b41f..e43923b 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1897,6 +1897,10 @@ EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr); EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr); /* 643 */ EXTERN int Tcl_IsShared(Tcl_Obj *objPtr); +/* 644 */ +EXTERN int Tcl_LinkArray(Tcl_Interp *interp, + const char *varName, void *addr, int type, + int size); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2576,6 +2580,7 @@ typedef struct TclStubs { void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */ void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */ int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ + int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, int size); /* 644 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3894,6 +3899,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DecrRefCount) /* 642 */ #define Tcl_IsShared \ (tclStubsPtr->tcl_IsShared) /* 643 */ +#define Tcl_LinkArray \ + (tclStubsPtr->tcl_LinkArray) /* 644 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclLink.c b/generic/tclLink.c index e7dcb8c..fe0785d 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -8,12 +8,14 @@ * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 2008 Rene Zaumseil * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" +#include /* * For each linked variable there is a data structure of the following type, @@ -28,6 +30,9 @@ typedef struct Link { * actual variable may be aliased at that time * via upvar. */ char *addr; /* Location of C variable. */ + int bytes; /* Size of C variable array. This is 0 when + * single variables, and >0 used for array + * variables */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { char c; @@ -44,6 +49,19 @@ typedef struct Link { Tcl_WideUInt uw; float f; double d; + void *aryPtr; + char *pc; + unsigned char *puc; + int *pi; + unsigned int *pui; + short *ps; + unsigned short *pus; + long *pl; + unsigned long *pul; + Tcl_WideInt *pw; + Tcl_WideUInt *puw; + float *pf; + double *pd; } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ int flags; /* Miscellaneous one-bit values; see below for @@ -57,10 +75,16 @@ typedef struct Link { * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is * in progress for this variable, so trace * callbacks on the variable should be ignored. + * LINK_ALLOC_ADDR - 1 means linkPtr->addr was allocated on the + * heap. + * LINK_ALLOC_LAST - 1 means linkPtr->valueLast.p was allocated on + * the heap. */ #define LINK_READ_ONLY 1 #define LINK_BEING_UPDATED 2 +#define LINK_ALLOC_ADDR 4 +#define LINK_ALLOC_LAST 8 /* * Forward references to functions defined later in this file: @@ -69,9 +93,12 @@ typedef struct Link { static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); +static void LinkFree(Link *linkPtr); static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); -static int GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr); -static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr); +static int GetInvalidWideFromObj(Tcl_Obj *objPtr, + Tcl_WideInt *widePtr); +static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, + double *doublePtr); /* * Convenience macro for accessing the value of the C variable pointed to by a @@ -144,11 +171,12 @@ Tcl_LinkVar( } else { linkPtr->flags = 0; } + linkPtr->bytes = 0; objPtr = ObjValue(linkPtr); if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(linkPtr->varName); - ckfree(linkPtr); + LinkFree(linkPtr); return TCL_ERROR; } code = Tcl_TraceVar2(interp, varName, NULL, @@ -156,7 +184,172 @@ Tcl_LinkVar( LinkTraceProc, linkPtr); if (code != TCL_OK) { Tcl_DecrRefCount(linkPtr->varName); - ckfree(linkPtr); + LinkFree(linkPtr); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinkArray -- + * + * Link a C variable array to a Tcl variable so that changes to either + * one causes the other to change. + * + * Results: + * The return value is TCL_OK if everything went well or TCL_ERROR if an + * error occurred (the interp's result is also set after errors). + * + * Side effects: + * The value at *addr is linked to the Tcl variable "varName", using + * "type" to convert between string values for Tcl and binary values for + * *addr. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LinkArray( + Tcl_Interp *interp, /* Interpreter in which varName exists. */ + const char *varName, /* Name of a global variable in interp. */ + void *addr, /* Address of a C variable to be linked to + * varName. If NULL then the necessary space + * will be allocated and returned as the + * interpreter result. */ + int type, /* Type of C variable: TCL_LINK_INT, etc. Also + * may have TCL_LINK_READ_ONLY and + * TCL_LINK_ALLOC OR'ed in. */ + int size) /* Size of C variable array, >1 if array */ +{ + Tcl_Obj *objPtr; + Link *linkPtr; + int code; + + if (size < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong array size given", -1)); + return TCL_ERROR; + } + + linkPtr = ckalloc(sizeof(Link)); + linkPtr->type = type & ~TCL_LINK_READ_ONLY; + if (type & TCL_LINK_READ_ONLY) { + linkPtr->flags = LINK_READ_ONLY; + } else { + linkPtr->flags = 0; + } + + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + linkPtr->bytes = size * sizeof(int); + break; + case TCL_LINK_DOUBLE: + linkPtr->bytes = size * sizeof(double); + break; + case TCL_LINK_WIDE_INT: + linkPtr->bytes = size * sizeof(Tcl_WideInt); + break; + case TCL_LINK_WIDE_UINT: + linkPtr->bytes = size * sizeof(Tcl_WideUInt); + break; + case TCL_LINK_CHAR: + linkPtr->bytes = size * sizeof(char); + break; + case TCL_LINK_UCHAR: + linkPtr->bytes = size * sizeof(unsigned char); + break; + case TCL_LINK_SHORT: + linkPtr->bytes = size * sizeof(short); + break; + case TCL_LINK_USHORT: + linkPtr->bytes = size * sizeof(unsigned short); + break; + 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; + case TCL_LINK_STRING: + linkPtr->bytes = size * sizeof(char); + size = 1; /* This is a variable length string, no need + * to check last value. */ + + /* + * If no address is given create one and use as address the + * not needed linkPtr->lastValue + */ + + if (addr == NULL) { + linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes); + linkPtr->flags |= LINK_ALLOC_LAST; + addr = (char *) &linkPtr->lastValue.pc; + } + break; + case TCL_LINK_CHARS: + case TCL_LINK_BINARY: + linkPtr->bytes = size * sizeof(char); + break; + default: + LinkFree(linkPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad linked array variable type", -1)); + return TCL_ERROR; + } + + /* + * Allocate C variable space in case no address is given + */ + + if (addr == NULL) { + linkPtr->addr = ckalloc(linkPtr->bytes); + linkPtr->flags |= LINK_ALLOC_ADDR; + } else { + linkPtr->addr = addr; + } + + /* + * If necessary create space for last used value. + */ + + if (size > 1) { + linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes); + linkPtr->flags |= LINK_ALLOC_LAST; + } + + /* + * Set common structure values. + */ + + linkPtr->interp = interp; + linkPtr->varName = Tcl_NewStringObj(varName, -1); + Tcl_IncrRefCount(linkPtr->varName); + objPtr = ObjValue(linkPtr); + if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DecrRefCount(linkPtr->varName); + LinkFree(linkPtr); + return TCL_ERROR; + } + + code = Tcl_TraceVar2(interp, varName, NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + LinkTraceProc, linkPtr); + if (code != TCL_OK) { + Tcl_DecrRefCount(linkPtr->varName); + LinkFree(linkPtr); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj((int) linkPtr->addr)); } return code; } @@ -194,7 +387,7 @@ Tcl_UnlinkVar( TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); Tcl_DecrRefCount(linkPtr->varName); - ckfree(linkPtr); + LinkFree(linkPtr); } /* @@ -242,6 +435,44 @@ Tcl_UpdateLinkedVar( } } +static inline int +GetInt( + Tcl_Obj *objPtr, + int *intPtr) +{ + return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK + && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK); +} + +static inline int +GetWide( + Tcl_Obj *objPtr, + Tcl_WideInt *widePtr) +{ + return (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK + && GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK); +} + +static inline int +GetDouble( + Tcl_Obj *objPtr, + double *dblPtr) +{ + if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) { + return 0; + } else { +#ifdef ACCEPT_NAN + Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclDoubleType); + + if (irPtr != NULL) { + *dblPtr = irPtr->doubleValue; + return 0; + } +#endif + return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK; + } +} + /* *---------------------------------------------------------------------- * @@ -273,13 +504,16 @@ LinkTraceProc( { Link *linkPtr = clientData; int changed; - size_t valueLength; + int valueLength; const char *value; char **pp; Tcl_Obj *valueObj; int valueInt; Tcl_WideInt valueWide; double valueDouble; + int objc; + Tcl_Obj **objv; + int i; /* * If the variable is being unset, then just re-create it (with a trace) @@ -289,7 +523,7 @@ LinkTraceProc( if (flags & TCL_TRACE_UNSETS) { if (Tcl_InterpDeleted(interp)) { Tcl_DecrRefCount(linkPtr->varName); - ckfree(linkPtr); + LinkFree(linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -316,51 +550,64 @@ LinkTraceProc( */ if (flags & TCL_TRACE_READS) { - switch (linkPtr->type) { - case TCL_LINK_INT: - case TCL_LINK_BOOLEAN: - changed = (LinkedVar(int) != linkPtr->lastValue.i); - break; - case TCL_LINK_DOUBLE: - changed = (LinkedVar(double) != linkPtr->lastValue.d); - break; - case TCL_LINK_WIDE_INT: - changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); - break; - case TCL_LINK_WIDE_UINT: - changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw); - break; - case TCL_LINK_CHAR: - changed = (LinkedVar(char) != linkPtr->lastValue.c); - break; - case TCL_LINK_UCHAR: - changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc); - break; - case TCL_LINK_SHORT: - changed = (LinkedVar(short) != linkPtr->lastValue.s); - break; - case TCL_LINK_USHORT: - changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us); - break; - case TCL_LINK_UINT: - changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); - break; + /* + * Variable arrays + */ + + if (linkPtr->flags & LINK_ALLOC_LAST) { + changed = memcmp(linkPtr->addr, linkPtr->lastValue.aryPtr, + linkPtr->bytes); + } else { + /* single variables */ + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + changed = (LinkedVar(int) != linkPtr->lastValue.i); + break; + case TCL_LINK_DOUBLE: + changed = (LinkedVar(double) != linkPtr->lastValue.d); + break; + case TCL_LINK_WIDE_INT: + changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); + break; + case TCL_LINK_WIDE_UINT: + changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw); + break; + case TCL_LINK_CHAR: + changed = (LinkedVar(char) != linkPtr->lastValue.c); + break; + case TCL_LINK_UCHAR: + changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc); + break; + case TCL_LINK_SHORT: + changed = (LinkedVar(short) != linkPtr->lastValue.s); + break; + case TCL_LINK_USHORT: + changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us); + break; + 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; + 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 = (LinkedVar(float) != linkPtr->lastValue.f); - break; - case TCL_LINK_STRING: - changed = 1; - break; - default: - return (char *) "internal error: bad linked variable type"; + case TCL_LINK_FLOAT: + changed = (LinkedVar(float) != linkPtr->lastValue.f); + break; + case TCL_LINK_STRING: + case TCL_LINK_CHARS: + case TCL_LINK_BINARY: + changed = 1; + break; + default: + changed = 0; + /* return (char *) "internal error: bad linked variable type"; */ + } } if (changed) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), @@ -392,131 +639,295 @@ LinkTraceProc( return (char *) "internal error: linked variable couldn't be read"; } + /* + * A couple of helper macros. + */ + +#define CheckHaveList(valueObj, underlyingType) \ + if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR \ + || objc != linkPtr->bytes / sizeof(underlyingType)) { \ + return (char *) "wrong dimension"; \ + } +#define InRange(lowerLimit, value, upperLimit) \ + ((value) >= (lowerLimit) && (value) <= (upperLimit)) + switch (linkPtr->type) { case TCL_LINK_INT: - if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK - && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, int); + for (i=0; i < objc; i++) { + int *varPtr = &linkPtr->lastValue.pi[i]; + + if (GetInt(objv[i], varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have integer values"; + } + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + int *varPtr = &linkPtr->lastValue.i; + + if (GetInt(valueObj, varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have integer value"; + } + LinkedVar(int) = *varPtr; } - LinkedVar(int) = linkPtr->lastValue.i; break; case TCL_LINK_WIDE_INT: - if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK - && GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, Tcl_WideInt); + for (i=0; i < objc; i++) { + Tcl_WideInt *varPtr = &linkPtr->lastValue.pw[i]; + + if (GetWide(objv[i], varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have wide integer value"; + } + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + Tcl_WideInt *varPtr = &linkPtr->lastValue.w; + + if (GetWide(valueObj, varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have wide integer value"; + } + LinkedVar(Tcl_WideInt) = *varPtr; } - LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w; break; case TCL_LINK_DOUBLE: - if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { -#ifdef ACCEPT_NAN - Tcl_ObjIntRep *irPtr = TclFetchIntRep(valueObj, &tclDoubleType); - if (irPtr == NULL) { -#endif - if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have real value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, double); + for (i=0; i < objc; i++) { + if (GetDouble(objv[i], &linkPtr->lastValue.pd[i])) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have real value"; } -#ifdef ACCEPT_NAN } - linkPtr->lastValue.d = irPtr->doubleValue; -#endif + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + double *varPtr = &linkPtr->lastValue.d; + + if (GetDouble(valueObj, varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have real value"; + } + LinkedVar(double) = *varPtr; } - LinkedVar(double) = linkPtr->lastValue.d; break; case TCL_LINK_BOOLEAN: - if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have boolean value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, int); + for (i=0; i < objc; i++) { + int *varPtr = &linkPtr->lastValue.pi[i]; + + if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have boolean value"; + } + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + int *varPtr = &linkPtr->lastValue.i; + + if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have boolean value"; + } + LinkedVar(int) = *varPtr; } - LinkedVar(int) = linkPtr->lastValue.i; break; case TCL_LINK_CHAR: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have char value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, char); + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have char value"; + } + linkPtr->lastValue.pc[i] = (char) valueInt; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + break; + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have char value"; + } + LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt; } - LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt; break; case TCL_LINK_UCHAR: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < 0 || valueInt > UCHAR_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned char value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, unsigned char); + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(0, valueInt, UCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned char value"; + } + linkPtr->lastValue.puc[i] = (unsigned char) valueInt; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(0, valueInt, UCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned char value"; + } + LinkedVar(unsigned char) = linkPtr->lastValue.uc = + (unsigned char) valueInt; } - LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt; break; case TCL_LINK_SHORT: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have short value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, short); + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have short value"; + } + linkPtr->lastValue.ps[i] = (short) valueInt; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have short value"; + } + LinkedVar(short) = linkPtr->lastValue.s = (short) valueInt; } - LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt; break; case TCL_LINK_USHORT: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < 0 || valueInt > USHRT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned short value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, unsigned short); + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(0, valueInt, USHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned short value"; + } + linkPtr->lastValue.pus[i] = (unsigned short) valueInt; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(0, valueInt, USHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned short value"; + } + LinkedVar(unsigned short) = linkPtr->lastValue.us = + (unsigned short) valueInt; } - LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt; break; case TCL_LINK_UINT: - if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK - && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) - || valueWide < 0 || valueWide > UINT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned int value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, unsigned int); + for (i=0; i < objc; i++) { + if (GetWide(objv[i], &valueWide) + || !InRange(0, valueWide, UINT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned int value"; + } + linkPtr->lastValue.pui[i] = (unsigned int) valueWide; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + if (GetWide(valueObj, &valueWide) + || !InRange(0, valueWide, UINT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned int value"; + } + LinkedVar(unsigned int) = linkPtr->lastValue.ui = + (unsigned int) valueWide; } - LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide; break; #if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: - if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK - && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) - || valueWide < LONG_MIN || valueWide > LONG_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have long value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, long); + 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.pl[i] = (long) valueWide; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + break; + } 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; } - LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide; break; case TCL_LINK_ULONG: - if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK - && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) - || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned long value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, unsigned long); + for (i=0; i < objc; i++) { + if (GetWide(objv[i], &valueWide) + || !InRange(0, valueWide, ULONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned long value"; + } + linkPtr->lastValue.pul[i] = (unsigned long) valueWide; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + if (GetWide(valueObj, &valueWide) + || !InRange(0, valueWide, 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) valueWide; } - LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide; break; #endif @@ -524,24 +935,54 @@ LinkTraceProc( /* * FIXME: represent as a bignum. */ - if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK - && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned wide int value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, Tcl_WideUInt); + for (i=0; i < objc; i++) { + if (GetWide(objv[i], &valueWide)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned wide int value"; + } + linkPtr->lastValue.puw[i] = (Tcl_WideUInt) valueWide; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + if (GetWide(valueObj, &valueWide)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned wide int value"; + } + LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = + (Tcl_WideUInt) valueWide; } - LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; break; case TCL_LINK_FLOAT: - if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK - && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK) - || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have float value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + CheckHaveList(valueObj, float); + for (i=0; i < objc; i++) { + if (GetDouble(objv[i], &valueDouble) + && !InRange(FLT_MIN, valueDouble, FLT_MAX) + && !TclIsInfinite(valueDouble) + && !TclIsNaN(valueDouble)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have float value"; + } + linkPtr->lastValue.pf[i] = (float) valueDouble; + } + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } else { + if (GetDouble(valueObj, &valueDouble) + && !InRange(FLT_MIN, valueDouble, FLT_MAX) + && !TclIsInfinite(valueDouble) && !TclIsNaN(valueDouble)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have float value"; + } + LinkedVar(float) = linkPtr->lastValue.f = (float) valueDouble; } - LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble; break; case TCL_LINK_STRING: @@ -553,6 +994,35 @@ LinkTraceProc( memcpy(*pp, value, valueLength); break; + case TCL_LINK_CHARS: + value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength); + valueLength++; /* include end of string char */ + if (valueLength > linkPtr->bytes) { + return (char *) "wrong size of char* value"; + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); + memcpy(linkPtr->addr, value, (size_t) valueLength); + } else { + linkPtr->lastValue.c = '\0'; + LinkedVar(char) = linkPtr->lastValue.c; + } + break; + + case TCL_LINK_BINARY: + value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength); + if (valueLength != linkPtr->bytes) { + return (char *) "wrong size of binary value"; + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); + memcpy(linkPtr->addr, value, (size_t) valueLength); + } else { + linkPtr->lastValue.uc = (unsigned char) *value; + LinkedVar(unsigned char) = linkPtr->lastValue.uc; + } + break; + default: return (char *) "internal error: bad linked variable type"; } @@ -583,51 +1053,172 @@ ObjValue( { char *p; Tcl_Obj *resultObj; + int objc; + static Tcl_Obj **objv = NULL; // WTF? + int i; switch (linkPtr->type) { case TCL_LINK_INT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(int); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pi[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.i = LinkedVar(int); return Tcl_NewIntObj(linkPtr->lastValue.i); case TCL_LINK_WIDE_INT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(Tcl_WideInt); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pw[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.w = LinkedVar(Tcl_WideInt); return Tcl_NewWideIntObj(linkPtr->lastValue.w); case TCL_LINK_DOUBLE: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(double); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.pd[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.d = LinkedVar(double); return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes/sizeof(int); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.pi[i] != 0); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.i = LinkedVar(int); return Tcl_NewBooleanObj(linkPtr->lastValue.i); case TCL_LINK_CHAR: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(char); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pc[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.c = LinkedVar(char); return Tcl_NewIntObj(linkPtr->lastValue.c); case TCL_LINK_UCHAR: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(unsigned char); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.puc[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.uc = LinkedVar(unsigned char); return Tcl_NewIntObj(linkPtr->lastValue.uc); case TCL_LINK_SHORT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(short); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj*)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ps[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.s = LinkedVar(short); return Tcl_NewIntObj(linkPtr->lastValue.s); case TCL_LINK_USHORT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(unsigned short); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj*)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pus[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.us = LinkedVar(unsigned short); return Tcl_NewIntObj(linkPtr->lastValue.us); case TCL_LINK_UINT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(unsigned int); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pui[i]); + } + return Tcl_NewListObj(objc, objv); + } 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); + objc = linkPtr->bytes / sizeof(long); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pl[i]); + } + return Tcl_NewListObj(objc, objv); + } 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); + objc = linkPtr->bytes / sizeof(unsigned long); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pul[i]); + } + return Tcl_NewListObj(objc, objv); + } 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); + objc = linkPtr->bytes / sizeof(float); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.pf[i]); + } + return Tcl_NewListObj(objc, objv); + } linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); case TCL_LINK_WIDE_UINT: - linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); /* * FIXME: represent as a bignum. */ + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objc = linkPtr->bytes / sizeof(Tcl_WideUInt); + objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); + for (i=0; i < objc; i++) { + objv[i] = Tcl_NewWideIntObj((Tcl_WideInt) + linkPtr->lastValue.puw[i]); + } + return Tcl_NewListObj(objc, objv); + } + linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); case TCL_LINK_STRING: p = LinkedVar(char *); @@ -637,6 +1228,25 @@ ObjValue( } return Tcl_NewStringObj(p, -1); + case TCL_LINK_CHARS: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + linkPtr->lastValue.pc[linkPtr->bytes-1] = '\0'; + /* take care of proper string end */ + return Tcl_NewStringObj(linkPtr->lastValue.pc, linkPtr->bytes); + } + linkPtr->lastValue.c = '\0'; + return Tcl_NewStringObj(&linkPtr->lastValue.c, 1); + + case TCL_LINK_BINARY: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + return Tcl_NewByteArrayObj((unsigned char *) linkPtr->addr, + linkPtr->bytes); + } + linkPtr->lastValue.uc = LinkedVar(unsigned char); + return Tcl_NewByteArrayObj(&linkPtr->lastValue.uc, 1); + /* * This code only gets executed if the link type is unknown (shouldn't * ever happen). @@ -696,6 +1306,7 @@ SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o" * (upperand lowercase). See bug [39f6304c2e]. */ + int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr) { @@ -730,6 +1341,7 @@ GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr) * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o" * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e]. */ + int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr) { @@ -751,6 +1363,35 @@ GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr) } /* + *---------------------------------------------------------------------- + * + * LinkFree -- + * + * Free's allocated space of given link and link structure. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +LinkFree( + Link *linkPtr) /* Structure describing linked variable. */ +{ + if (linkPtr->flags & LINK_ALLOC_ADDR) { + ckfree(linkPtr->addr); + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + ckfree(linkPtr->lastValue.aryPtr); + } + ckfree((char *) linkPtr); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 197ed84..2eb2259 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1628,6 +1628,7 @@ const TclStubs tclStubs = { Tcl_IncrRefCount, /* 641 */ Tcl_DecrRefCount, /* 642 */ Tcl_IsShared, /* 643 */ + Tcl_LinkArray, /* 644 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 349d935..f075500 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -308,6 +308,8 @@ static int TestinterpdeleteCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestlinkCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestlinkarrayCmd(void *dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); static int TestlocaleCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -665,6 +667,7 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, NULL, NULL); Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); @@ -3283,6 +3286,123 @@ TestlinkCmd( /* *---------------------------------------------------------------------- * + * TestlinkarrayCmd -- + * + * This function is invoked to process the "testlinkarray" Tcl command. + * It is used to test the 'Tcl_LinkArray' function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes variable links. + * + *---------------------------------------------------------------------- + */ + +static int +TestlinkarrayCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *LinkOption[] = { + "update", "remove", "create", NULL + }; + enum LinkOption { LINK_UPDATE, LINK_REMOVE, LINK_CREATE }; + static const char *LinkType[] = { + "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", + "wide", "uwide", "float", "double", "string", "char*", "binary", NULL + }; + /* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */ + static int LinkTypes[] = { + TCL_LINK_CHAR, TCL_LINK_UCHAR, + TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT, + TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT, + TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, + TCL_LINK_BINARY + }; + int optionIndex, typeIndex, readonly, i, addr, size, length; + char *name, *arg; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option args"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0, + &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LinkOption) optionIndex) { + case LINK_UPDATE: + for (i=2; i Date: Wed, 3 Apr 2019 09:08:37 +0000 Subject: Some fixes. Still broken on 64-bit systems --- generic/tclLink.c | 134 ++++++++++-------- tests/link.test | 417 +++++++++++++++++++++++++----------------------------- 2 files changed, 269 insertions(+), 282 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index fe0785d..bc9e6be 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -32,7 +32,9 @@ typedef struct Link { char *addr; /* Location of C variable. */ int bytes; /* Size of C variable array. This is 0 when * single variables, and >0 used for array - * variables */ + * variables. */ + int numElems; /* Number of elements in C variable array. + * Zero for single variables. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { char c; @@ -49,7 +51,7 @@ typedef struct Link { Tcl_WideUInt uw; float f; double d; - void *aryPtr; + void *aryPtr; /* Generic array. */ char *pc; unsigned char *puc; int *pi; @@ -172,6 +174,7 @@ Tcl_LinkVar( linkPtr->flags = 0; } linkPtr->bytes = 0; + linkPtr->numElems = 0; objPtr = ObjValue(linkPtr); if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { @@ -234,6 +237,7 @@ Tcl_LinkArray( linkPtr = ckalloc(sizeof(Link)); linkPtr->type = type & ~TCL_LINK_READ_ONLY; + linkPtr->numElems = size; if (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; } else { @@ -565,6 +569,7 @@ LinkTraceProc( changed = (LinkedVar(int) != linkPtr->lastValue.i); break; case TCL_LINK_DOUBLE: + /* FIXME: handle NaN */ changed = (LinkedVar(double) != linkPtr->lastValue.d); break; case TCL_LINK_WIDE_INT: @@ -597,6 +602,7 @@ LinkTraceProc( break; #endif case TCL_LINK_FLOAT: + /* FIXME: handle NaN */ changed = (LinkedVar(float) != linkPtr->lastValue.f); break; case TCL_LINK_STRING: @@ -645,7 +651,7 @@ LinkTraceProc( #define CheckHaveList(valueObj, underlyingType) \ if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR \ - || objc != linkPtr->bytes / sizeof(underlyingType)) { \ + || objc != linkPtr->numElems) { \ return (char *) "wrong dimension"; \ } #define InRange(lowerLimit, value, upperLimit) \ @@ -1052,117 +1058,124 @@ ObjValue( Link *linkPtr) /* Structure describing linked variable. */ { char *p; - Tcl_Obj *resultObj; - int objc; - static Tcl_Obj **objv = NULL; // WTF? + Tcl_Obj *resultObj, **objv; int i; switch (linkPtr->type) { case TCL_LINK_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(int); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pi[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.i = LinkedVar(int); return Tcl_NewIntObj(linkPtr->lastValue.i); case TCL_LINK_WIDE_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(Tcl_WideInt); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pw[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.w = LinkedVar(Tcl_WideInt); return Tcl_NewWideIntObj(linkPtr->lastValue.w); case TCL_LINK_DOUBLE: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(double); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.pd[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.d = LinkedVar(double); return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes/sizeof(int); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.pi[i] != 0); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.i = LinkedVar(int); return Tcl_NewBooleanObj(linkPtr->lastValue.i); case TCL_LINK_CHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(char); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pc[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.c = LinkedVar(char); return Tcl_NewIntObj(linkPtr->lastValue.c); case TCL_LINK_UCHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(unsigned char); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewIntObj(linkPtr->lastValue.puc[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.uc = LinkedVar(unsigned char); return Tcl_NewIntObj(linkPtr->lastValue.uc); case TCL_LINK_SHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(short); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj*)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ps[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.s = LinkedVar(short); return Tcl_NewIntObj(linkPtr->lastValue.s); case TCL_LINK_USHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(unsigned short); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj*)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pus[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.us = LinkedVar(unsigned short); return Tcl_NewIntObj(linkPtr->lastValue.us); case TCL_LINK_UINT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(unsigned int); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pui[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.ui = LinkedVar(unsigned int); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui); @@ -1170,24 +1183,26 @@ ObjValue( case TCL_LINK_LONG: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(long); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pl[i]); } - return Tcl_NewListObj(objc, objv); + 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); - objc = linkPtr->bytes / sizeof(unsigned long); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pul[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.ul = LinkedVar(unsigned long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); @@ -1195,12 +1210,13 @@ ObjValue( case TCL_LINK_FLOAT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(float); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.pf[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); @@ -1210,16 +1226,18 @@ ObjValue( */ if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objc = linkPtr->bytes / sizeof(Tcl_WideUInt); - objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *)); - for (i=0; i < objc; i++) { + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.puw[i]); } - return Tcl_NewListObj(objc, objv); + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; } linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); + case TCL_LINK_STRING: p = LinkedVar(char *); if (p == NULL) { diff --git a/tests/link.test b/tests/link.test index 1f40189..e0f7e3c 100644 --- a/tests/link.test +++ b/tests/link.test @@ -400,31 +400,27 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { } msg] $msg $int } {0 {} 47} -test link-9.1 {linkarray usage messages} { +test link-9.1 {linkarray usage messages} -setup { set mylist [list] - catch {testlinkarray} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {testlinkarray x} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {testlinkarray update} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {testlinkarray remove} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {testlinkarray create} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {testlinkarray create xx 1 my} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {testlinkarray create char* 0 my} my(msg) - lappend mylist $my(msg) - unset my(msg) +} -body { + catch {testlinkarray} msg + lappend mylist $msg + catch {testlinkarray x} msg + lappend mylist $msg + catch {testlinkarray update} msg + lappend mylist $msg + catch {testlinkarray remove} msg + lappend mylist $msg + catch {testlinkarray create} msg + lappend mylist $msg + catch {testlinkarray create xx 1 my} msg + lappend mylist $msg + catch {testlinkarray create char* 0 my} msg + lappend mylist $msg join $mylist "\n" -} {wrong # args: should be "testlinkarray option args" +} -cleanup { + unset -nocomplain my +} -result {wrong # args: should be "testlinkarray option args" bad option "x": must be update, remove, or create @@ -432,93 +428,87 @@ wrong # args: should be "testlinkarray create ?-readonly? type size name ?addres bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary wrong array size given} -test link-10.1 {linkarray char*} { +test link-10.1 {linkarray char*} -setup { set mylist [list] +} -body { testlinkarray create char* 1 ::my(var) lappend mylist [set ::my(var) ""] - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create char* 4 ::my(var) set ::my(var) x - catch {set ::my(var) xyzz} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) xyzz} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create -r char* 4 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} { +} -cleanup { + unset -nocomplain my +} -result { can't set "::my(var)": wrong size of char* value can't set "::my(var)": wrong size of char* value can't set "::my(var)": linked variable is read-only} -test link-11.1 {linkarray char} { +test link-11.1 {linkarray char} -setup { set mylist [list] +} -body { testlinkarray create char 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1234} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1234} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create char 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r char 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have char value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have char value 120 can't set "::my(var)": variable must have char value can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-12.1 {linkarray unsigned char} { +test link-12.1 {linkarray unsigned char} -setup { set mylist [list] +} -body { testlinkarray create uchar 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1234} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {set ::my(var) -1} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1234} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create uchar 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r uchar 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have unsigned char value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned char value 120 can't set "::my(var)": variable must have unsigned char value can't set "::my(var)": variable must have unsigned char value @@ -526,67 +516,62 @@ can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-13.1 {linkarray short} { +test link-13.1 {linkarray short} -setup { set mylist [list] +} -body { testlinkarray create short 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 123456} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 123456} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create short 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r short 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have short value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have short value 120 can't set "::my(var)": variable must have short value can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-14.1 {linkarray unsigned short} { +test link-14.1 {linkarray unsigned short} -setup { set mylist [list] +} -body { testlinkarray create ushort 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 123456} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {set ::my(var) -1} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 123456} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create ushort 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r ushort 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have unsigned short value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned short value 120 can't set "::my(var)": variable must have unsigned short value can't set "::my(var)": variable must have unsigned short value @@ -594,67 +579,62 @@ can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-15.1 {linkarray int} { +test link-15.1 {linkarray int} -setup { set mylist [list] +} -body { testlinkarray create int 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e3} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1e3} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create int 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r int 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have integer value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have integer value 120 can't set "::my(var)": variable must have integer value can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-16.1 {linkarray unsigned int} { +test link-16.1 {linkarray unsigned int} -setup { set mylist [list] +} -body { testlinkarray create uint 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {set ::my(var) -1} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1e33} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create uint 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r uint 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have unsigned int value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned int value 120 can't set "::my(var)": variable must have unsigned int value can't set "::my(var)": variable must have unsigned int value @@ -662,135 +642,125 @@ can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-17.1 {linkarray long} { +test link-17.1 {linkarray long} -setup { set mylist [list] +} -body { testlinkarray create long 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1e33} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create long 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r long 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have long value +} -cleanup { + unset -nocomplain my +} -match glob -result {can't set "::my(var)": variable must have * value 120 -can't set "::my(var)": variable must have long value +can't set "::my(var)": variable must have * value can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-18.1 {linkarray unsigned long} { +test link-18.1 {linkarray unsigned long} -setup { set mylist [list] +} -body { testlinkarray create ulong 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {set ::my(var) -1} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1e33} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create ulong 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r ulong 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have unsigned long value +} -cleanup { + unset -nocomplain my +} -match glob -result {can't set "::my(var)": variable must have unsigned * value 120 -can't set "::my(var)": variable must have unsigned long value -can't set "::my(var)": variable must have unsigned long value +can't set "::my(var)": variable must have unsigned * value +can't set "::my(var)": variable must have unsigned * value can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-19.1 {linkarray wide} { +test link-19.1 {linkarray wide} -setup { set mylist [list] +} -body { testlinkarray create wide 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1e33} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create wide 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r wide 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have wide integer value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have wide integer value 120 can't set "::my(var)": variable must have wide integer value can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-20.1 {linkarray unsigned wide} { +test link-20.1 {linkarray unsigned wide} -setup { set mylist [list] +} -body { testlinkarray create uwide 1 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg lappend mylist [set ::my(var) 120] - catch {set ::my(var) 1e33} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {set ::my(var) -1} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) 1e33} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg testlinkarray remove ::my(var) testlinkarray create uwide 4 ::my(var) - catch {set ::my(var) {1 2 3}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) testlinkarray remove ::my(var) testlinkarray create -r uwide 2 ::my(var) - catch {set ::my(var) {1 2}} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) {1 2}} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": variable must have unsigned wide int value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned wide int value 120 can't set "::my(var)": variable must have unsigned wide int value can't set "::my(var)": variable must have unsigned wide int value @@ -798,52 +768,51 @@ can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-21.1 {linkarray string} { +test link-21.1 {linkarray string} -setup { set mylist [list] +} -body { testlinkarray create string 1 ::my(var) lappend mylist [set ::my(var) ""] lappend mylist [set ::my(var) "xyz"] lappend mylist $::my(var) testlinkarray remove ::my(var) testlinkarray create -r string 4 ::my(var) - catch {set ::my(var) x} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) x} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} { +} -cleanup { + unset -nocomplain my +} -result { xyz xyz can't set "::my(var)": linked variable is read-only} -test link-22.1 {linkarray binary} { +test link-22.1 {linkarray binary} -setup { set mylist [list] +} -body { testlinkarray create binary 1 ::my(var) set ::my(var) x - catch {set ::my(var) xy} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) xy} msg + lappend mylist $msg lappend mylist $::my(var) testlinkarray remove ::my(var) testlinkarray create binary 4 ::my(var) - catch {set ::my(var) abc} my(msg) - lappend mylist $my(msg) - unset my(msg) - catch {set ::my(var) abcde} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) abc} msg + lappend mylist $msg + catch {set ::my(var) abcde} msg + lappend mylist $msg set ::my(var) abcd lappend mylist $::my(var) testlinkarray remove ::my(var) testlinkarray create -r binary 4 ::my(var) - catch {set ::my(var) xyzv} my(msg) - lappend mylist $my(msg) - unset my(msg) + catch {set ::my(var) xyzv} msg + lappend mylist $msg testlinkarray remove ::my(var) - unset my join $mylist "\n" -} {can't set "::my(var)": wrong size of binary value +} -cleanup { + unset -nocomplain my +} -result {can't set "::my(var)": wrong size of binary value x can't set "::my(var)": wrong size of binary value can't set "::my(var)": wrong size of binary value -- cgit v0.12 From 515da61c9dd1ca932c9bd1cb0c63e49ed26527d0 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 3 Apr 2019 09:36:33 +0000 Subject: refactor; mark broken tests as broken --- generic/tclLink.c | 215 ++++++++++++++++++++++++++---------------------------- tests/link.test | 6 +- 2 files changed, 106 insertions(+), 115 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index bc9e6be..8ba02dd 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -52,18 +52,18 @@ typedef struct Link { float f; double d; void *aryPtr; /* Generic array. */ - char *pc; - unsigned char *puc; - int *pi; - unsigned int *pui; - short *ps; - unsigned short *pus; - long *pl; - unsigned long *pul; - Tcl_WideInt *pw; - Tcl_WideUInt *puw; - float *pf; - double *pd; + char *cPtr; /* char array */ + unsigned char *ucPtr; /* unsigned char array */ + short *sPtr; /* short array */ + unsigned short *usPtr; /* unsigned short array */ + int *iPtr; /* int array */ + unsigned int *uiPtr; /* unsigned int array */ + long *lPtr; /* long array */ + unsigned long *ulPtr; /* unsigned long array */ + Tcl_WideInt *wPtr; /* wide (long long) array */ + Tcl_WideUInt *uwPtr; /* unsigned wide (long long) array */ + float *fPtr; /* float array */ + double *dPtr; /* double array */ } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ int flags; /* Miscellaneous one-bit values; see below for @@ -297,7 +297,7 @@ Tcl_LinkArray( if (addr == NULL) { linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes); linkPtr->flags |= LINK_ALLOC_LAST; - addr = (char *) &linkPtr->lastValue.pc; + addr = (char *) &linkPtr->lastValue.cPtr; } break; case TCL_LINK_CHARS: @@ -646,23 +646,73 @@ LinkTraceProc( } /* - * A couple of helper macros. + * Special cases. */ -#define CheckHaveList(valueObj, underlyingType) \ - if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR \ - || objc != linkPtr->numElems) { \ - return (char *) "wrong dimension"; \ + switch (linkPtr->type) { + case TCL_LINK_STRING: + value = TclGetString(valueObj); + valueLength = valueObj->length + 1; + pp = (char **) linkPtr->addr; + + *pp = ckrealloc(*pp, valueLength); + memcpy(*pp, value, valueLength); + return NULL; + + case TCL_LINK_CHARS: + value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength); + valueLength++; /* include end of string char */ + if (valueLength > linkPtr->bytes) { + return (char *) "wrong size of char* value"; + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); + memcpy(linkPtr->addr, value, (size_t) valueLength); + } else { + linkPtr->lastValue.c = '\0'; + LinkedVar(char) = linkPtr->lastValue.c; + } + return NULL; + + case TCL_LINK_BINARY: + value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength); + if (valueLength != linkPtr->bytes) { + return (char *) "wrong size of binary value"; + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); + memcpy(linkPtr->addr, value, (size_t) valueLength); + } else { + linkPtr->lastValue.uc = (unsigned char) *value; + LinkedVar(unsigned char) = linkPtr->lastValue.uc; + } + return NULL; } -#define InRange(lowerLimit, value, upperLimit) \ + + /* + * A helper macro. Writing this as a function is messy because of type + * variance. + */ + +#define InRange(lowerLimit, value, upperLimit) \ ((value) >= (lowerLimit) && (value) <= (upperLimit)) + /* + * If we're working with an array of numbers, extract the Tcl list. + */ + + if (linkPtr->flags & LINK_ALLOC_LAST) { + if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR + || objc != linkPtr->numElems) { + return (char *) "wrong dimension"; + } + } + switch (linkPtr->type) { case TCL_LINK_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, int); for (i=0; i < objc; i++) { - int *varPtr = &linkPtr->lastValue.pi[i]; + int *varPtr = &linkPtr->lastValue.iPtr[i]; if (GetInt(objv[i], varPtr)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, @@ -670,7 +720,6 @@ LinkTraceProc( return (char *) "variable array must have integer values"; } } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { int *varPtr = &linkPtr->lastValue.i; @@ -685,9 +734,8 @@ LinkTraceProc( case TCL_LINK_WIDE_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, Tcl_WideInt); for (i=0; i < objc; i++) { - Tcl_WideInt *varPtr = &linkPtr->lastValue.pw[i]; + Tcl_WideInt *varPtr = &linkPtr->lastValue.wPtr[i]; if (GetWide(objv[i], varPtr)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, @@ -696,7 +744,6 @@ LinkTraceProc( "variable array must have wide integer value"; } } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { Tcl_WideInt *varPtr = &linkPtr->lastValue.w; @@ -711,15 +758,13 @@ LinkTraceProc( case TCL_LINK_DOUBLE: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, double); for (i=0; i < objc; i++) { - if (GetDouble(objv[i], &linkPtr->lastValue.pd[i])) { + if (GetDouble(objv[i], &linkPtr->lastValue.dPtr[i])) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have real value"; } } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { double *varPtr = &linkPtr->lastValue.d; @@ -734,9 +779,8 @@ LinkTraceProc( case TCL_LINK_BOOLEAN: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, int); for (i=0; i < objc; i++) { - int *varPtr = &linkPtr->lastValue.pi[i]; + int *varPtr = &linkPtr->lastValue.iPtr[i]; if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, @@ -744,7 +788,6 @@ LinkTraceProc( return (char *) "variable array must have boolean value"; } } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { int *varPtr = &linkPtr->lastValue.i; @@ -759,7 +802,6 @@ LinkTraceProc( case TCL_LINK_CHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, char); for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { @@ -767,10 +809,8 @@ LinkTraceProc( ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have char value"; } - linkPtr->lastValue.pc[i] = (char) valueInt; + linkPtr->lastValue.cPtr[i] = (char) valueInt; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); - break; } else { if (GetInt(valueObj, &valueInt) || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { @@ -784,7 +824,6 @@ LinkTraceProc( case TCL_LINK_UCHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, unsigned char); for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(0, valueInt, UCHAR_MAX)) { @@ -793,9 +832,8 @@ LinkTraceProc( return (char *) "variable array must have unsigned char value"; } - linkPtr->lastValue.puc[i] = (unsigned char) valueInt; + linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetInt(valueObj, &valueInt) || !InRange(0, valueInt, UCHAR_MAX)) { @@ -810,7 +848,6 @@ LinkTraceProc( case TCL_LINK_SHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, short); for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { @@ -818,9 +855,8 @@ LinkTraceProc( ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have short value"; } - linkPtr->lastValue.ps[i] = (short) valueInt; + linkPtr->lastValue.sPtr[i] = (short) valueInt; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetInt(valueObj, &valueInt) || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { @@ -834,7 +870,6 @@ LinkTraceProc( case TCL_LINK_USHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, unsigned short); for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) || !InRange(0, valueInt, USHRT_MAX)) { @@ -843,9 +878,8 @@ LinkTraceProc( return (char *) "variable array must have unsigned short value"; } - linkPtr->lastValue.pus[i] = (unsigned short) valueInt; + linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetInt(valueObj, &valueInt) || !InRange(0, valueInt, USHRT_MAX)) { @@ -860,7 +894,6 @@ LinkTraceProc( case TCL_LINK_UINT: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, unsigned int); for (i=0; i < objc; i++) { if (GetWide(objv[i], &valueWide) || !InRange(0, valueWide, UINT_MAX)) { @@ -869,9 +902,8 @@ LinkTraceProc( return (char *) "variable array must have unsigned int value"; } - linkPtr->lastValue.pui[i] = (unsigned int) valueWide; + linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetWide(valueObj, &valueWide) || !InRange(0, valueWide, UINT_MAX)) { @@ -887,7 +919,6 @@ LinkTraceProc( #if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, long); for (i=0; i < objc; i++) { if (GetWide(objv[i], &valueWide) || !InRange(LONG_MIN, valueWide, LONG_MAX)) { @@ -895,10 +926,8 @@ LinkTraceProc( ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have long value"; } - linkPtr->lastValue.pl[i] = (long) valueWide; + linkPtr->lastValue.lPtr[i] = (long) valueWide; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); - break; } else { if (GetWide(valueObj, &valueWide) || !InRange(LONG_MIN, valueWide, LONG_MAX)) { @@ -912,7 +941,6 @@ LinkTraceProc( case TCL_LINK_ULONG: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, unsigned long); for (i=0; i < objc; i++) { if (GetWide(objv[i], &valueWide) || !InRange(0, valueWide, ULONG_MAX)) { @@ -921,9 +949,8 @@ LinkTraceProc( return (char *) "variable array must have unsigned long value"; } - linkPtr->lastValue.pul[i] = (unsigned long) valueWide; + linkPtr->lastValue.ulPtr[i] = (unsigned long) valueWide; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetWide(valueObj, &valueWide) || !InRange(0, valueWide, ULONG_MAX)) { @@ -942,7 +969,6 @@ LinkTraceProc( * FIXME: represent as a bignum. */ if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, Tcl_WideUInt); for (i=0; i < objc; i++) { if (GetWide(objv[i], &valueWide)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, @@ -950,9 +976,8 @@ LinkTraceProc( return (char *) "variable array must have unsigned wide int value"; } - linkPtr->lastValue.puw[i] = (Tcl_WideUInt) valueWide; + linkPtr->lastValue.uwPtr[i] = (Tcl_WideUInt) valueWide; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetWide(valueObj, &valueWide)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, @@ -966,7 +991,6 @@ LinkTraceProc( case TCL_LINK_FLOAT: if (linkPtr->flags & LINK_ALLOC_LAST) { - CheckHaveList(valueObj, float); for (i=0; i < objc; i++) { if (GetDouble(objv[i], &valueDouble) && !InRange(FLT_MIN, valueDouble, FLT_MAX) @@ -976,9 +1000,8 @@ LinkTraceProc( ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have float value"; } - linkPtr->lastValue.pf[i] = (float) valueDouble; + linkPtr->lastValue.fPtr[i] = (float) valueDouble; } - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); } else { if (GetDouble(valueObj, &valueDouble) && !InRange(FLT_MIN, valueDouble, FLT_MAX) @@ -991,47 +1014,13 @@ LinkTraceProc( } break; - case TCL_LINK_STRING: - value = TclGetString(valueObj); - valueLength = valueObj->length + 1; - pp = (char **) linkPtr->addr; - - *pp = ckrealloc(*pp, valueLength); - memcpy(*pp, value, valueLength); - break; - - case TCL_LINK_CHARS: - value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength); - valueLength++; /* include end of string char */ - if (valueLength > linkPtr->bytes) { - return (char *) "wrong size of char* value"; - } - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); - memcpy(linkPtr->addr, value, (size_t) valueLength); - } else { - linkPtr->lastValue.c = '\0'; - LinkedVar(char) = linkPtr->lastValue.c; - } - break; - - case TCL_LINK_BINARY: - value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength); - if (valueLength != linkPtr->bytes) { - return (char *) "wrong size of binary value"; - } - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); - memcpy(linkPtr->addr, value, (size_t) valueLength); - } else { - linkPtr->lastValue.uc = (unsigned char) *value; - LinkedVar(unsigned char) = linkPtr->lastValue.uc; - } - break; - default: return (char *) "internal error: bad linked variable type"; } + + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } return NULL; } @@ -1067,7 +1056,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pi[i]); + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.iPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1080,7 +1069,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pw[i]); + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.wPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1093,7 +1082,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.pd[i]); + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.dPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1106,7 +1095,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.pi[i] != 0); + objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.iPtr[i] != 0); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1119,7 +1108,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pc[i]); + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.cPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1132,7 +1121,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewIntObj(linkPtr->lastValue.puc[i]); + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ucPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1145,7 +1134,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ps[i]); + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.sPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1158,7 +1147,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pus[i]); + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.usPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1171,7 +1160,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pui[i]); + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.uiPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1185,7 +1174,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pl[i]); + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.lPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1198,7 +1187,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pul[i]); + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.ulPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1212,7 +1201,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.pf[i]); + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.fPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1229,7 +1218,7 @@ ObjValue( objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { objv[i] = Tcl_NewWideIntObj((Tcl_WideInt) - linkPtr->lastValue.puw[i]); + linkPtr->lastValue.uwPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1249,9 +1238,9 @@ ObjValue( case TCL_LINK_CHARS: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - linkPtr->lastValue.pc[linkPtr->bytes-1] = '\0'; + linkPtr->lastValue.cPtr[linkPtr->bytes-1] = '\0'; /* take care of proper string end */ - return Tcl_NewStringObj(linkPtr->lastValue.pc, linkPtr->bytes); + return Tcl_NewStringObj(linkPtr->lastValue.cPtr, linkPtr->bytes); } linkPtr->lastValue.c = '\0'; return Tcl_NewStringObj(&linkPtr->lastValue.c, 1); diff --git a/tests/link.test b/tests/link.test index e0f7e3c..0a865d8 100644 --- a/tests/link.test +++ b/tests/link.test @@ -672,9 +672,10 @@ can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-18.1 {linkarray unsigned long} -setup { +test link-18.1 {linkarray unsigned long} -constraints knownBug -setup { set mylist [list] } -body { + # Implementation needs to use bignums on 64-bit platforms testlinkarray create ulong 1 ::my(var) catch {set ::my(var) x} msg lappend mylist $msg @@ -735,9 +736,10 @@ can't set "::my(var)": wrong dimension 1 2 3 4 can't set "::my(var)": linked variable is read-only} -test link-20.1 {linkarray unsigned wide} -setup { +test link-20.1 {linkarray unsigned wide} -constraints knownBug -setup { set mylist [list] } -body { + # Implementation needs to use bignums testlinkarray create uwide 1 ::my(var) catch {set ::my(var) x} msg lappend mylist $msg -- cgit v0.12 From cbb2ececd3a0056acbb5ecdcfa39d7b035ca9b1c Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 3 Apr 2019 12:22:07 +0000 Subject: Docs --- doc/LinkVar.3 | 120 +++++++++++++++++++++++++++++++++++++++++++---------- generic/tcl.decls | 2 +- generic/tclDecls.h | 4 +- generic/tclLink.c | 4 +- 4 files changed, 102 insertions(+), 28 deletions(-) diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index c80d30d..a38610b 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable +Tcl_LinkArray, Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable .SH SYNOPSIS .nf \fB#include \fR @@ -17,27 +17,49 @@ Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variab int \fBTcl_LinkVar\fR(\fIinterp, varName, addr, type\fR) .sp +.VS "TIP 312" +int +\fBTcl_LinkArray\fR(\fIinterp, varName, addr, type, size\fR) +.VE "TIP 312" +.sp \fBTcl_UnlinkVar\fR(\fIinterp, varName\fR) .sp \fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR) .SH ARGUMENTS -.AS Tcl_Interp writable +.AS Tcl_Interp varName in .AP Tcl_Interp *interp in Interpreter that contains \fIvarName\fR. Also used by \fBTcl_LinkVar\fR to return error messages. .AP "const char" *varName in Name of global variable. -.AP char *addr in +.AP void *addr in Address of C variable that is to be linked to \fIvarName\fR. .AP int type in -Type of C variable. Must be one of \fBTCL_LINK_INT\fR, +Type of C variable for \fBTcl_LinkVar\fR or type of array element for +\fBTcl_LinkArray\fR. Must be one of \fBTCL_LINK_INT\fR, \fBTCL_LINK_UINT\fR, \fBTCL_LINK_CHAR\fR, \fBTCL_LINK_UCHAR\fR, \fBTCL_LINK_SHORT\fR, \fBTCL_LINK_USHORT\fR, \fBTCL_LINK_LONG\fR, \fBTCL_LINK_ULONG\fR, \fBTCL_LINK_WIDE_INT\fR, -\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, -\fBTCL_LINK_DOUBLE\fR, \fBTCL_LINK_BOOLEAN\fR, or -\fBTCL_LINK_STRING\fR, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR -to make Tcl variable read-only. +\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, \fBTCL_LINK_DOUBLE\fR, +\fBTCL_LINK_BOOLEAN\fR, or one of the extra ones listed below. +.sp +In \fBTcl_LinkVar\fR, the additional linked type \fBTCL_LINK_STRING\fR may be +used. +.sp +.VS "TIP 312" +In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and +\fBTCL_LINK_BYTES\fR may be used. \fBTCL_LINK_ALLOC\fR may also be OR'ed in +to tell Tcl to manage the storage for the array in the variable (that is, the +C variable is technically a pointer to an array, not the array itself). +.VE "TIP 312" +.sp +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 +.VS "TIP 312" +The number of elements in the C array. Must be greater than zero. +.VE "TIP 312" .BE .SH DESCRIPTION .PP @@ -52,12 +74,22 @@ while setting up the link (e.g. because \fIvarName\fR is the name of array) then \fBTCL_ERROR\fR is returned and the interpreter's result contains an error message. .PP +.VS "TIP 312" +\fBTcl_LinkArray\fR is similar, but for arrays of fixed size (given by +the \fIsize\fR argument). When asked to allocate the backing C array +storage (via the \fBTCL_LINK_ALLOC\fR bit), it writes the address that +it allocated to the Tcl interpreter result in addition to storing the +location of the array in the C variable pointed to by \fIaddr\fR. +.VE "TIP 312" +.PP The \fItype\fR argument specifies the type of the C variable, +or the type of the elements of the C array, and must have one of the following values, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR: .TP \fBTCL_LINK_INT\fR -The C variable is of type \fBint\fR. +. +The C variable, or each element of the C array, is of type \fBint\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with @@ -66,7 +98,8 @@ string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_UINT\fR -The C variable is of type \fBunsigned int\fR. +. +The C variable, or each element of the C array, is of type \fBunsigned int\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned int\fR type; attempts to @@ -76,16 +109,31 @@ representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_CHAR\fR -The C variable is of type \fBchar\fR. +. +The C variable, or each element of the C array, is of type \fBchar\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBchar\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. +.RS +.PP +.VS "TIP 312" +If using an array of these, consider using \fBTCL_LINK_CHARS\fR instead. +.VE "TIP 312" +.RE +.TP +\fBTCL_LINK_CHARS\fR +.VS "TIP 312" +The C array is of type \fBchar *\fR and is mapped into Tcl as a string. +Any value written into the Tcl variable must have the same length as +the underlying storage. Only supported with \fBTcl_LinkArray\fR. +.VE "TIP 312" .TP \fBTCL_LINK_UCHAR\fR -The C variable is of type \fBunsigned char\fR. +. +The C variable, or each element of the C array, is of type \fBunsigned char\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned char\fR type; attempts to @@ -93,9 +141,24 @@ write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. +.RS +.PP +.VS "TIP 312" +If using an array of these, consider using \fBTCL_LINK_BYTES\fR instead. +.VE "TIP 312" +.RE +.TP +\fBTCL_LINK_BYTES\fR +.VS "TIP 312" +The C array is of type \fBunsigned char *\fR and is mapped into Tcl +as a bytearray. +Any value written into the Tcl variable must have the same length as +the underlying storage. Only supported with \fBTcl_LinkArray\fR. +.VE "TIP 312" .TP \fBTCL_LINK_SHORT\fR -The C variable is of type \fBshort\fR. +. +The C variable, or each element of the C array, is of type \fBshort\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBshort\fR datatype; attempts to write non-integer or out-of-range @@ -104,7 +167,8 @@ integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_USHORT\fR -The C variable is of type \fBunsigned short\fR. +. +The C variable, or each element of the C array, is of type \fBunsigned short\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned short\fR type; attempts to @@ -114,7 +178,8 @@ representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_LONG\fR -The C variable is of type \fBlong\fR. +. +The C variable, or each element of the C array, is of type \fBlong\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetLongFromObj\fR; attempts to write non-integer or out-of-range @@ -123,7 +188,8 @@ integer representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_ULONG\fR -The C variable is of type \fBunsigned long\fR. +. +The C variable, or each element of the C array, is of type \fBunsigned long\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned long\fR type; attempts to @@ -133,7 +199,8 @@ representations (like the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_DOUBLE\fR -The C variable is of type \fBdouble\fR. +. +The C variable, or each element of the C array, is of type \fBdouble\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write non-real values into \fIvarName\fR will be rejected with @@ -142,7 +209,8 @@ empty string, '.', '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_FLOAT\fR -The C variable is of type \fBfloat\fR. +. +The C variable, or each element of the C array, is of type \fBfloat\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR and must be within the range acceptable for a \fBfloat\fR; attempts to @@ -152,7 +220,9 @@ or real representations (like the empty string, '.', '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_WIDE_INT\fR -The C variable is of type \fBTcl_WideInt\fR (which is an integer type +. +The C variable, or each element of the C array, is of type \fBTcl_WideInt\fR +(which is an integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetWideIntFromObj\fR; attempts to write @@ -162,9 +232,10 @@ string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_WIDE_UINT\fR -The C variable is of type \fBTcl_WideUInt\fR (which is an unsigned -integer type at least 64-bits wide on all platforms that can support -it.) +. +The C variable, or each element of the C array, is of type \fBTcl_WideUInt\fR +(which is an unsigned integer type at least 64-bits wide on all platforms that +can support it.) Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR (it will be cast to unsigned); @@ -175,7 +246,8 @@ the empty string, '+', '-' or the hex/octal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_BOOLEAN\fR -The C variable is of type \fBint\fR. +. +The C variable, or each element of the C array, is of type \fBint\fR. If its value is zero then it will read from Tcl as .QW 0 ; otherwise it will read from Tcl as @@ -188,6 +260,7 @@ non-boolean values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_STRING\fR +. 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. @@ -197,6 +270,7 @@ new value. If the C variable contains a NULL pointer then the Tcl variable will read as .QW NULL . +This is only supported by \fBTcl_LinkVar\fR. .PP If the \fBTCL_LINK_READ_ONLY\fR flag is present in \fItype\fR then the variable will be read-only from Tcl, so that its value can only be diff --git a/generic/tcl.decls b/generic/tcl.decls index f2ceeee..7d3b535 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -667,7 +667,7 @@ declare 186 { Tcl_DString *resultPtr) } declare 187 { - int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, char *addr, + int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr, int type) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e43923b..3b67796 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -597,7 +597,7 @@ EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, - char *addr, int type); + void *addr, int type); /* Slot 188 is reserved */ /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode); @@ -2123,7 +2123,7 @@ typedef struct TclStubs { int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */ int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */ char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */ - int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, char *addr, int type); /* 187 */ + int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */ void (*reserved188)(void); Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */ int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ diff --git a/generic/tclLink.c b/generic/tclLink.c index 8ba02dd..456f868 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -29,7 +29,7 @@ typedef struct Link { * needed during trace callbacks, since the * actual variable may be aliased at that time * via upvar. */ - char *addr; /* Location of C variable. */ + void *addr; /* Location of C variable. */ int bytes; /* Size of C variable array. This is 0 when * single variables, and >0 used for array * variables. */ @@ -137,7 +137,7 @@ int Tcl_LinkVar( Tcl_Interp *interp, /* Interpreter in which varName exists. */ const char *varName, /* Name of a global variable in interp. */ - char *addr, /* Address of a C variable to be linked to + void *addr, /* Address of a C variable to be linked to * varName. */ int type) /* Type of C variable: TCL_LINK_INT, etc. Also * may have TCL_LINK_READ_ONLY OR'ed in. */ -- cgit v0.12 From c4cf1a4e2ced76f5b42e1f6467a252e101768b3f Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Apr 2019 08:52:43 +0000 Subject: Split up tests to get better focus on what is being tested --- tests/link.test | 357 ++++++++++++++++++++++++++++++++------------------------ 1 file changed, 205 insertions(+), 152 deletions(-) diff --git a/tests/link.test b/tests/link.test index 0a865d8..97bd631 100644 --- a/tests/link.test +++ b/tests/link.test @@ -400,33 +400,27 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { } msg] $msg $int } {0 {} 47} -test link-9.1 {linkarray usage messages} -setup { - set mylist [list] -} -body { - catch {testlinkarray} msg - lappend mylist $msg - catch {testlinkarray x} msg - lappend mylist $msg - catch {testlinkarray update} msg - lappend mylist $msg - catch {testlinkarray remove} msg - lappend mylist $msg - catch {testlinkarray create} msg - lappend mylist $msg - catch {testlinkarray create xx 1 my} msg - lappend mylist $msg - catch {testlinkarray create char* 0 my} msg - lappend mylist $msg - join $mylist "\n" -} -cleanup { - unset -nocomplain my -} -result {wrong # args: should be "testlinkarray option args" -bad option "x": must be update, remove, or create - - -wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?" -bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary -wrong array size given} +test link-9.1 {linkarray usage messages} -returnCodes error -body { + testlinkarray +} -result {wrong # args: should be "testlinkarray option args"} +test link-9.2 {linkarray usage messages} -returnCodes error -body { + testlinkarray x +} -result {bad option "x": must be update, remove, or create} +test link-9.3 {linkarray usage messages} -body { + testlinkarray update +} -result {} +test link-9.4 {linkarray usage messages} -body { + testlinkarray remove +} -result {} +test link-9.5 {linkarray usage messages} -returnCodes error -body { + testlinkarray create +} -result {wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?"} +test link-9.6 {linkarray usage messages} -returnCodes error -body { + testlinkarray create xx 1 my +} -result {bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary} +test link-9.7 {linkarray usage messages} -returnCodes error -body { + testlinkarray create char* 0 my +} -result {wrong array size given} test link-10.1 {linkarray char*} -setup { set mylist [list] @@ -435,23 +429,27 @@ test link-10.1 {linkarray char*} -setup { lappend mylist [set ::my(var) ""] catch {set ::my(var) x} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{} {can't set "::my(var)": wrong size of char* value}} +test link-10.2 {linkarray char*} -body { testlinkarray create char* 4 ::my(var) set ::my(var) x catch {set ::my(var) xyzz} msg - lappend mylist $msg + return $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": wrong size of char* value} +test link-10.3 {linkarray char*} -body { testlinkarray create -r char* 4 ::my(var) catch {set ::my(var) x} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result { -can't set "::my(var)": wrong size of char* value -can't set "::my(var)": wrong size of char* value -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-11.1 {linkarray char} -setup { set mylist [list] @@ -462,26 +460,30 @@ test link-11.1 {linkarray char} -setup { lappend mylist [set ::my(var) 120] catch {set ::my(var) 1234} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have char value} 120 {can't set "::my(var)": variable must have char value}} +test link-11.2 {linkarray char} -setup { + set mylist [list] +} -body { testlinkarray create char 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-11.3 {linkarray char} -body { testlinkarray create -r char 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have char value -120 -can't set "::my(var)": variable must have char value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-12.1 {linkarray unsigned char} -setup { set mylist [list] @@ -494,27 +496,30 @@ test link-12.1 {linkarray unsigned char} -setup { lappend mylist $msg catch {set ::my(var) -1} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned char value} 120 {can't set "::my(var)": variable must have unsigned char value} {can't set "::my(var)": variable must have unsigned char value}} +test link-12.2 {linkarray unsigned char} -setup { + set mylist [list] +} -body { testlinkarray create uchar 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-12.3 {linkarray unsigned char} -body { testlinkarray create -r uchar 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have unsigned char value -120 -can't set "::my(var)": variable must have unsigned char value -can't set "::my(var)": variable must have unsigned char value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-13.1 {linkarray short} -setup { set mylist [list] @@ -525,26 +530,30 @@ test link-13.1 {linkarray short} -setup { lappend mylist [set ::my(var) 120] catch {set ::my(var) 123456} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have short value} 120 {can't set "::my(var)": variable must have short value}} +test link-13.2 {linkarray short} -setup { + set mylist [list] +} -body { testlinkarray create short 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-13.3 {linkarray short} -body { testlinkarray create -r short 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have short value -120 -can't set "::my(var)": variable must have short value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-14.1 {linkarray unsigned short} -setup { set mylist [list] @@ -557,27 +566,30 @@ test link-14.1 {linkarray unsigned short} -setup { lappend mylist $msg catch {set ::my(var) -1} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned short value} 120 {can't set "::my(var)": variable must have unsigned short value} {can't set "::my(var)": variable must have unsigned short value}} +test link-14.2 {linkarray unsigned short} -setup { + set mylist [list] +} -body { testlinkarray create ushort 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-14.3 {linkarray unsigned short} -body { testlinkarray create -r ushort 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have unsigned short value -120 -can't set "::my(var)": variable must have unsigned short value -can't set "::my(var)": variable must have unsigned short value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-15.1 {linkarray int} -setup { set mylist [list] @@ -588,26 +600,30 @@ test link-15.1 {linkarray int} -setup { lappend mylist [set ::my(var) 120] catch {set ::my(var) 1e3} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have integer value} 120 {can't set "::my(var)": variable must have integer value}} +test link-15.2 {linkarray int} -setup { + set mylist [list] +} -body { testlinkarray create int 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-15.3 {linkarray int} -body { testlinkarray create -r int 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have integer value -120 -can't set "::my(var)": variable must have integer value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-16.1 {linkarray unsigned int} -setup { set mylist [list] @@ -620,27 +636,30 @@ test link-16.1 {linkarray unsigned int} -setup { lappend mylist $msg catch {set ::my(var) -1} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain ::my +} -result {{can't set "::my(var)": variable must have unsigned int value} 120 {can't set "::my(var)": variable must have unsigned int value} {can't set "::my(var)": variable must have unsigned int value}} +test link-16.2 {linkarray unsigned int} -setup { + set mylist [list] +} -body { testlinkarray create uint 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain ::my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-16.3 {linkarray unsigned int} -body { testlinkarray create -r uint 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have unsigned int value -120 -can't set "::my(var)": variable must have unsigned int value -can't set "::my(var)": variable must have unsigned int value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-17.1 {linkarray long} -setup { set mylist [list] @@ -651,60 +670,74 @@ test link-17.1 {linkarray long} -setup { lappend mylist [set ::my(var) 120] catch {set ::my(var) 1e33} msg lappend mylist $msg +} -match glob -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have * value} 120 {can't set "::my(var)": variable must have * value}} +test link-17.2 {linkarray long} -setup { + set mylist [list] +} -body { testlinkarray create long 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-17.3 {linkarray long} -body { testlinkarray create -r long 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -match glob -result {can't set "::my(var)": variable must have * value -120 -can't set "::my(var)": variable must have * value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} -test link-18.1 {linkarray unsigned long} -constraints knownBug -setup { +test link-18.1 {linkarray unsigned long} -setup { set mylist [list] } -body { - # Implementation needs to use bignums on 64-bit platforms testlinkarray create ulong 1 ::my(var) catch {set ::my(var) x} msg lappend mylist $msg lappend mylist [set ::my(var) 120] catch {set ::my(var) 1e33} msg lappend mylist $msg +} -match glob -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned * value} 120 {can't set "::my(var)": variable must have unsigned * value}} +test link-18.2 {linkarray unsigned long} -constraints knownBug -body { + # BUG: Implementation needs to use bignums on 64-bit platforms + testlinkarray create ulong 1 ::my(var) + set ::my(var) 120 catch {set ::my(var) -1} msg - lappend mylist $msg + return $msg +} -match glob -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned * value} +test link-18.3 {linkarray unsigned long} -setup { + set mylist [list] +} -body { testlinkarray create ulong 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-18.4 {linkarray unsigned long} -body { testlinkarray create -r ulong 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -match glob -result {can't set "::my(var)": variable must have unsigned * value -120 -can't set "::my(var)": variable must have unsigned * value -can't set "::my(var)": variable must have unsigned * value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-19.1 {linkarray wide} -setup { set mylist [list] @@ -715,60 +748,76 @@ test link-19.1 {linkarray wide} -setup { lappend mylist [set ::my(var) 120] catch {set ::my(var) 1e33} msg lappend mylist $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have wide integer value} 120 {can't set "::my(var)": variable must have wide integer value}} +test link-19.2 {linkarray wide} -setup { + set mylist [list] +} -body { testlinkarray create wide 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-19.3 {linkarray wide} -body { testlinkarray create -r wide 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have wide integer value -120 -can't set "::my(var)": variable must have wide integer value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} -test link-20.1 {linkarray unsigned wide} -constraints knownBug -setup { +test link-20.1 {linkarray unsigned wide} -setup { set mylist [list] } -body { - # Implementation needs to use bignums testlinkarray create uwide 1 ::my(var) catch {set ::my(var) x} msg lappend mylist $msg lappend mylist [set ::my(var) 120] catch {set ::my(var) 1e33} msg lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value}} +test link-20.2 {linkarray unsigned wide} -constraints knownBug -setup { + set mylist [list] +} -body { + # BUG: Implementation needs to use bignums + testlinkarray create uwide 1 ::my(var) + set ::my(var) 120 catch {set ::my(var) -1} msg - lappend mylist $msg + return $msg +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned wide int value} +test link-20.3 {linkarray unsigned wide} -setup { + set mylist [list] +} -body { testlinkarray create uwide 4 ::my(var) catch {set ::my(var) {1 2 3}} msg lappend mylist $msg set ::my(var) {1 2 3 4} lappend mylist $my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-20.4 {linkarray unsigned wide} -body { testlinkarray create -r uwide 2 ::my(var) catch {set ::my(var) {1 2}} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": variable must have unsigned wide int value -120 -can't set "::my(var)": variable must have unsigned wide int value -can't set "::my(var)": variable must have unsigned wide int value -can't set "::my(var)": wrong dimension -1 2 3 4 -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-21.1 {linkarray string} -setup { set mylist [list] @@ -777,18 +826,18 @@ test link-21.1 {linkarray string} -setup { lappend mylist [set ::my(var) ""] lappend mylist [set ::my(var) "xyz"] lappend mylist $::my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{} xyz xyz} +test link-21.2 {linkarray string} -body { testlinkarray create -r string 4 ::my(var) catch {set ::my(var) x} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result { -xyz -xyz -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} test link-22.1 {linkarray binary} -setup { set mylist [list] @@ -798,7 +847,13 @@ test link-22.1 {linkarray binary} -setup { catch {set ::my(var) xy} msg lappend mylist $msg lappend mylist $::my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong size of binary value} x} +test link-22.2 {linkarray binary} -setup { + set mylist [list] +} -body { testlinkarray create binary 4 ::my(var) catch {set ::my(var) abc} msg lappend mylist $msg @@ -806,20 +861,18 @@ test link-22.1 {linkarray binary} -setup { lappend mylist $msg set ::my(var) abcd lappend mylist $::my(var) +} -cleanup { testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong size of binary value} {can't set "::my(var)": wrong size of binary value} abcd} +test link-22.3 {linkarray binary} -body { testlinkarray create -r binary 4 ::my(var) catch {set ::my(var) xyzv} msg - lappend mylist $msg - testlinkarray remove ::my(var) - join $mylist "\n" + return $msg } -cleanup { + testlinkarray remove ::my(var) unset -nocomplain my -} -result {can't set "::my(var)": wrong size of binary value -x -can't set "::my(var)": wrong size of binary value -can't set "::my(var)": wrong size of binary value -abcd -can't set "::my(var)": linked variable is read-only} +} -result {can't set "::my(var)": linked variable is read-only} catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0} catch {testlink delete} -- cgit v0.12 From 3c6834dbe3162f2682b83b0539451b4526dcd2c2 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Apr 2019 22:48:15 +0000 Subject: Fix unsigned wide linking. --- generic/tclLink.c | 106 ++++++++++++++++++++++++++++++++++++++++-------------- tests/link.test | 8 ++--- 2 files changed, 82 insertions(+), 32 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index 456f868..39ddbdd 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -15,6 +15,7 @@ */ #include "tclInt.h" +#include "tommath.h" #include /* @@ -458,6 +459,45 @@ GetWide( } static inline int +GetUWide( + Tcl_Obj *objPtr, + Tcl_WideUInt *uwidePtr) +{ + Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; + ClientData clientData; + int type; + + if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { + if (type == TCL_NUMBER_BIG) { + mp_int num; + Tcl_WideUInt scratch, value = 0; + unsigned long numBytes = sizeof(Tcl_WideUInt); + unsigned char *bytes = (unsigned char *) &scratch; + + Tcl_GetBignumFromObj(NULL, objPtr, &num); + if (num.sign) { + return 1; + } + if (mp_to_unsigned_bin_n(&num, bytes, &numBytes) != MP_OKAY) { + return 1; + } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + *uwidePtr = value; + return 0; + } else { + if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) == TCL_OK + && (*widePtr >= 0)) { + return 0; + } + } + } + + return (GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK); +} + +static inline int GetDouble( Tcl_Obj *objPtr, double *dblPtr) @@ -476,6 +516,29 @@ GetDouble( return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK; } } + +static inline int +EqualDouble( + double a, + double b) +{ + return (a == b) +#ifdef ACCEPT_NAN + || (TclIsNaN(a) && TclIsNaN(b)) +#endif + ; +} + +static inline int +IsSpecial( + double a) +{ + return TclIsInfinite(a) +#ifdef ACCEPT_NAN + || TclIsNaN(a) +#endif + ; +} /* *---------------------------------------------------------------------- @@ -514,6 +577,7 @@ LinkTraceProc( Tcl_Obj *valueObj; int valueInt; Tcl_WideInt valueWide; + Tcl_WideUInt valueUWide; double valueDouble; int objc; Tcl_Obj **objv; @@ -569,8 +633,7 @@ LinkTraceProc( changed = (LinkedVar(int) != linkPtr->lastValue.i); break; case TCL_LINK_DOUBLE: - /* FIXME: handle NaN */ - changed = (LinkedVar(double) != linkPtr->lastValue.d); + changed = !EqualDouble(LinkedVar(double), linkPtr->lastValue.d); break; case TCL_LINK_WIDE_INT: changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); @@ -602,8 +665,7 @@ LinkTraceProc( break; #endif case TCL_LINK_FLOAT: - /* FIXME: handle NaN */ - changed = (LinkedVar(float) != linkPtr->lastValue.f); + changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f); break; case TCL_LINK_STRING: case TCL_LINK_CHARS: @@ -942,50 +1004,46 @@ LinkTraceProc( case TCL_LINK_ULONG: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { - if (GetWide(objv[i], &valueWide) - || !InRange(0, valueWide, ULONG_MAX)) { + if (GetUWide(objv[i], &valueUWide) + || !InRange(0, 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) valueWide; + linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide; } } else { - if (GetWide(valueObj, &valueWide) - || !InRange(0, valueWide, ULONG_MAX)) { + if (GetUWide(valueObj, &valueUWide) + || !InRange(0, 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) valueWide; + (unsigned long) valueUWide; } break; #endif case TCL_LINK_WIDE_UINT: - /* - * FIXME: represent as a bignum. - */ if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { - if (GetWide(objv[i], &valueWide)) { + if (GetUWide(objv[i], &valueUWide)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have unsigned wide int value"; } - linkPtr->lastValue.uwPtr[i] = (Tcl_WideUInt) valueWide; + linkPtr->lastValue.uwPtr[i] = valueUWide; } } else { - if (GetWide(valueObj, &valueWide)) { + if (GetUWide(valueObj, &valueUWide)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned wide int value"; } - LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = - (Tcl_WideUInt) valueWide; + LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide; } break; @@ -993,9 +1051,8 @@ LinkTraceProc( if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetDouble(objv[i], &valueDouble) - && !InRange(FLT_MIN, valueDouble, FLT_MAX) - && !TclIsInfinite(valueDouble) - && !TclIsNaN(valueDouble)) { + && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) + && !IsSpecial(valueDouble)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable array must have float value"; @@ -1004,8 +1061,8 @@ LinkTraceProc( } } else { if (GetDouble(valueObj, &valueDouble) - && !InRange(FLT_MIN, valueDouble, FLT_MAX) - && !TclIsInfinite(valueDouble) && !TclIsNaN(valueDouble)) { + && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) + && !IsSpecial(valueDouble)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have float value"; @@ -1210,9 +1267,6 @@ ObjValue( linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); case TCL_LINK_WIDE_UINT: - /* - * FIXME: represent as a bignum. - */ if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); diff --git a/tests/link.test b/tests/link.test index 97bd631..e04059f 100644 --- a/tests/link.test +++ b/tests/link.test @@ -708,8 +708,7 @@ test link-18.1 {linkarray unsigned long} -setup { testlinkarray remove ::my(var) unset -nocomplain my } -result {{can't set "::my(var)": variable must have unsigned * value} 120 {can't set "::my(var)": variable must have unsigned * value}} -test link-18.2 {linkarray unsigned long} -constraints knownBug -body { - # BUG: Implementation needs to use bignums on 64-bit platforms +test link-18.2 {linkarray unsigned long} -body { testlinkarray create ulong 1 ::my(var) set ::my(var) 120 catch {set ::my(var) -1} msg @@ -786,10 +785,7 @@ test link-20.1 {linkarray unsigned wide} -setup { testlinkarray remove ::my(var) unset -nocomplain my } -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value}} -test link-20.2 {linkarray unsigned wide} -constraints knownBug -setup { - set mylist [list] -} -body { - # BUG: Implementation needs to use bignums +test link-20.2 {linkarray unsigned wide} -body { testlinkarray create uwide 1 ::my(var) set ::my(var) 120 catch {set ::my(var) -1} msg -- cgit v0.12 From 52d83cb65d69a94c36ad6634d568bd97312219db Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Apr 2019 23:08:05 +0000 Subject: Now with fewer memory leaks --- generic/tclLink.c | 39 +++++++++++++++++++++++++++------------ 1 file changed, 27 insertions(+), 12 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index 39ddbdd..616bdaf 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -468,32 +468,47 @@ GetUWide( int type; if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { - if (type == TCL_NUMBER_BIG) { + if (type == TCL_NUMBER_INT) { + *widePtr = *((const Tcl_WideInt *) clientData); + return (*widePtr < 0); + } else if (type == TCL_NUMBER_BIG) { mp_int num; - Tcl_WideUInt scratch, value = 0; + Tcl_WideUInt value = 0; + union { + Tcl_WideUInt value; + unsigned char bytes[sizeof(Tcl_WideUInt)]; + } scratch; unsigned long numBytes = sizeof(Tcl_WideUInt); - unsigned char *bytes = (unsigned char *) &scratch; + unsigned char *bytes = scratch.bytes; Tcl_GetBignumFromObj(NULL, objPtr, &num); - if (num.sign) { - return 1; - } - if (mp_to_unsigned_bin_n(&num, bytes, &numBytes) != MP_OKAY) { + if (num.sign || (MP_OKAY != mp_to_unsigned_bin_n(&num, bytes, + &numBytes))) { + /* + * If the sign bit is set (a negative value) or if the value + * can't possibly fit in the bits of an unsigned wide, there's + * no point in doing further conversion. + */ + mp_clear(&num); return 1; } +#ifdef WORDS_BIGENDIAN while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } +#else /* !WORDS_BIGENDIAN */ + value = scratch.value; +#endif /* WORDS_BIGENDIAN */ *uwidePtr = value; + mp_clear(&num); return 0; - } else { - if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) == TCL_OK - && (*widePtr >= 0)) { - return 0; - } } } + /* + * Evil edge case fallback. + */ + return (GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK); } -- cgit v0.12 From 52458f51bc8ece66942a74305efc875822b1d601 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Apr 2019 23:47:38 +0000 Subject: Clean up and refactor a bit --- generic/tclLink.c | 255 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 142 insertions(+), 113 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index 616bdaf..06a283f 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -9,6 +9,7 @@ * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2008 Rene Zaumseil + * Copyright (c) 2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -98,10 +99,22 @@ static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, static Tcl_Obj * ObjValue(Link *linkPtr); static void LinkFree(Link *linkPtr); static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); -static int GetInvalidWideFromObj(Tcl_Obj *objPtr, - Tcl_WideInt *widePtr); static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr); +static int SetInvalidRealFromAny(Tcl_Interp *interp, + Tcl_Obj *objPtr); + +/* + * A marker type used to flag weirdnesses so we can pass them around right. + */ + +static Tcl_ObjType invalidRealType = { + "invalidReal", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; /* * Convenience macro for accessing the value of the C variable pointed to by a @@ -440,6 +453,17 @@ Tcl_UpdateLinkedVar( } } +/* + *---------------------------------------------------------------------- + * + * GetInt, GetWide, GetUWide, GetDouble, EqualDouble, IsSpecial -- + * + * Helper functions for LinkTraceProc and ObjValue. These are all + * factored out here to make those functions simpler. + * + *---------------------------------------------------------------------- + */ + static inline int GetInt( Tcl_Obj *objPtr, @@ -454,8 +478,15 @@ GetWide( Tcl_Obj *objPtr, Tcl_WideInt *widePtr) { - return (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK - && GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK); + if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) { + int intValue; + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return 1; + } + *widePtr = intValue; + } + return 0; } static inline int @@ -465,7 +496,7 @@ GetUWide( { Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; ClientData clientData; - int type; + int type, intValue; if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { if (type == TCL_NUMBER_INT) { @@ -509,7 +540,11 @@ GetUWide( * Evil edge case fallback. */ - return (GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK); + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return 1; + } + *uwidePtr = intValue; + return 0; } static inline int @@ -527,7 +562,7 @@ GetDouble( *dblPtr = irPtr->doubleValue; return 0; } -#endif +#endif /* ACCEPT_NAN */ return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK; } } @@ -540,7 +575,7 @@ EqualDouble( return (a == b) #ifdef ACCEPT_NAN || (TclIsNaN(a) && TclIsNaN(b)) -#endif +#endif /* ACCEPT_NAN */ ; } @@ -551,9 +586,107 @@ IsSpecial( return TclIsInfinite(a) #ifdef ACCEPT_NAN || TclIsNaN(a) -#endif +#endif /* ACCEPT_NAN */ ; } + +/* + * Mark an object as holding a weird double. + */ + +static int +SetInvalidRealFromAny( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + const char *str; + const char *endPtr; + + str = TclGetString(objPtr); + if ((objPtr->length == 1) && (str[0] == '.')) { + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = 0.0; + return TCL_OK; + } + if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr, + TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { + /* + * If number is followed by [eE][+-]?, then it is an invalid + * double, but it could be the start of a valid double. + */ + + if (*endPtr == 'e' || *endPtr == 'E') { + ++endPtr; + if (*endPtr == '+' || *endPtr == '-') { + ++endPtr; + } + if (*endPtr == 0) { + double doubleValue = 0.0; + + Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); + TclFreeIntRep(objPtr); + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = doubleValue; + return TCL_OK; + } + } + } + return TCL_ERROR; +} + +/* + * This function checks for integer representations, which are valid + * when linking with C variables, but which are invalid in other + * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o" + * (upperand lowercase). See bug [39f6304c2e]. + */ + +static int +GetInvalidIntFromObj( + Tcl_Obj *objPtr, + int *intPtr) +{ + const char *str = TclGetString(objPtr); + + if ((objPtr->length == 0) || ((objPtr->length == 2) && (str[0] == '0') + && strchr("xXbBoOdD", str[1]))) { + *intPtr = 0; + return TCL_OK; + } else if ((objPtr->length == 1) && strchr("+-", str[0])) { + *intPtr = (str[0] == '+'); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + * This function checks for double representations, which are valid + * when linking with C variables, but which are invalid in other + * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o" + * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e]. + */ + +static int +GetInvalidDoubleFromObj( + Tcl_Obj *objPtr, + double *doublePtr) +{ + int intValue; + + if (TclHasIntRep(objPtr, &invalidRealType)) { + goto gotdouble; + } + if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { + *doublePtr = (double) intValue; + return TCL_OK; + } + if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) { + gotdouble: + *doublePtr = objPtr->internalRep.doubleValue; + return TCL_OK; + } + return TCL_ERROR; +} /* *---------------------------------------------------------------------- @@ -1333,110 +1466,6 @@ ObjValue( return resultObj; } } - -static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); - -static Tcl_ObjType invalidRealType = { - "invalidReal", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ -}; - -static int -SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { - const char *str; - const char *endPtr; - - str = TclGetString(objPtr); - if ((objPtr->length == 1) && (str[0] == '.')){ - objPtr->typePtr = &invalidRealType; - objPtr->internalRep.doubleValue = 0.0; - return TCL_OK; - } - if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr, - TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { - /* If number is followed by [eE][+-]?, then it is an invalid - * double, but it could be the start of a valid double. */ - if (*endPtr == 'e' || *endPtr == 'E') { - ++endPtr; - if (*endPtr == '+' || *endPtr == '-') ++endPtr; - if (*endPtr == 0) { - double doubleValue = 0.0; - Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); - TclFreeIntRep(objPtr); - objPtr->typePtr = &invalidRealType; - objPtr->internalRep.doubleValue = doubleValue; - return TCL_OK; - } - } - } - return TCL_ERROR; -} - - -/* - * This function checks for integer representations, which are valid - * when linking with C variables, but which are invalid in other - * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o" - * (upperand lowercase). See bug [39f6304c2e]. - */ - -int -GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr) -{ - const char *str = TclGetString(objPtr); - - if ((objPtr->length == 0) || - ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) { - *intPtr = 0; - return TCL_OK; - } else if ((objPtr->length == 1) && strchr("+-", str[0])) { - *intPtr = (str[0] == '+'); - return TCL_OK; - } - return TCL_ERROR; -} - -int -GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr) -{ - int intValue; - - if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { - return TCL_ERROR; - } - *widePtr = intValue; - return TCL_OK; -} - -/* - * This function checks for double representations, which are valid - * when linking with C variables, but which are invalid in other - * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o" - * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e]. - */ - -int -GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr) -{ - int intValue; - - if (TclHasIntRep(objPtr, &invalidRealType)) { - goto gotdouble; - } - if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { - *doublePtr = (double) intValue; - return TCL_OK; - } - if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) { - gotdouble: - *doublePtr = objPtr->internalRep.doubleValue; - return TCL_OK; - } - return TCL_ERROR; -} /* *---------------------------------------------------------------------- -- cgit v0.12 From b1266f39d8026e65d0947374c988acb459f93c0a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 5 Apr 2019 16:46:14 +0000 Subject: Relax timing for some socket tests a little bit. Hopefully this fixes the spurious hangs on Travis builds there. --- tests/socket.test | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/socket.test b/tests/socket.test index dc3c04a..6579277 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -116,9 +116,9 @@ catch {socket 127.0.0.1 [randport]} set t2 [clock milliseconds] set lat2 [expr {($t2-$t1)*3}] -# Use the maximum of the two latency calculations, but at least 100ms +# Use the maximum of the two latency calculations, but at least 200ms set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}] -set latency [expr {$latency > 100 ? $latency : 1000}] +set latency [expr {$latency > 200 ? $latency : 200}] unset t1 t2 s1 s2 lat1 lat2 server # If remoteServerIP or remoteServerPort are not set, check in the environment @@ -644,7 +644,7 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a vwait sock puts $s2 one flush $s2 - after idle {set x 1} + after $latency {set x 1}; # Spurious failures in Travis CI, if we do [after idle] vwait x fconfigure $sock -blocking 0 set result a:[gets $sock] -- cgit v0.12 From 689987ea924a8fded1801777c1a14ab1205fa826 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 5 Apr 2019 16:58:41 +0000 Subject: Take over improvements from libtommath's development branch (which will appear in next version). - More efficient MP_SET_XLONG() macro. - New internal macro's IS_ZERO/IS_EVEN/IS_ODD - Changed signature for XMALLOC/XREALLOC/XFREE --- libtommath/bn_mp_clear.c | 2 +- libtommath/bn_mp_fwrite.c | 8 ++--- libtommath/bn_mp_get_double.c | 6 ++-- libtommath/bn_mp_get_int.c | 19 +---------- libtommath/bn_mp_get_long.c | 10 +++--- libtommath/bn_mp_get_long_long.c | 8 ++--- libtommath/bn_mp_grow.c | 4 ++- libtommath/bn_mp_init.c | 2 +- libtommath/bn_mp_init_size.c | 2 +- libtommath/bn_mp_is_square.c | 5 ++- libtommath/bn_mp_prime_random_ex.c | 10 +++--- libtommath/bn_mp_read_radix.c | 4 ++- libtommath/bn_mp_set_double.c | 4 +-- libtommath/bn_mp_shrink.c | 4 ++- libtommath/bn_mp_sqrt.c | 2 +- libtommath/tommath_private.h | 67 ++++++++++++++------------------------ 16 files changed, 64 insertions(+), 93 deletions(-) diff --git a/libtommath/bn_mp_clear.c b/libtommath/bn_mp_clear.c index 1f360b2..b8e724c 100644 --- a/libtommath/bn_mp_clear.c +++ b/libtommath/bn_mp_clear.c @@ -25,7 +25,7 @@ void mp_clear(mp_int *a) } /* free ram */ - XFREE(a->dp); + XFREE(a->dp, sizeof (mp_digit) * (size_t)a->alloc); /* reset members to make debugging easier */ a->dp = NULL; diff --git a/libtommath/bn_mp_fwrite.c b/libtommath/bn_mp_fwrite.c index 9f0c3df..85a942f 100644 --- a/libtommath/bn_mp_fwrite.c +++ b/libtommath/bn_mp_fwrite.c @@ -22,24 +22,24 @@ int mp_fwrite(const mp_int *a, int radix, FILE *stream) return err; } - buf = OPT_CAST(char) XMALLOC((size_t)len); + buf = (char *) XMALLOC((size_t)len); if (buf == NULL) { return MP_MEM; } if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) { - XFREE(buf); + XFREE(buf, len); return err; } for (x = 0; x < len; x++) { if (fputc((int)buf[x], stream) == EOF) { - XFREE(buf); + XFREE(buf, len); return MP_VAL; } } - XFREE(buf); + XFREE(buf, len); return MP_OKAY; } #endif diff --git a/libtommath/bn_mp_get_double.c b/libtommath/bn_mp_get_double.c index 3ed5a71..629eae3 100644 --- a/libtommath/bn_mp_get_double.c +++ b/libtommath/bn_mp_get_double.c @@ -19,10 +19,10 @@ double mp_get_double(const mp_int *a) for (i = 0; i < DIGIT_BIT; ++i) { fac *= 2.0; } - for (i = USED(a); i --> 0;) { - d = (d * fac) + (double)DIGIT(a, i); + for (i = a->used; i --> 0;) { + d = (d * fac) + (double)a->dp[i]; } - return (mp_isneg(a) != MP_NO) ? -d : d; + return (a->sign == MP_NEG) ? -d : d; } #endif diff --git a/libtommath/bn_mp_get_int.c b/libtommath/bn_mp_get_int.c index 13eddbf..d9c7a11 100644 --- a/libtommath/bn_mp_get_int.c +++ b/libtommath/bn_mp_get_int.c @@ -15,25 +15,8 @@ /* get the lower 32-bits of an mp_int */ unsigned long mp_get_int(const mp_int *a) { - int i; - mp_min_u32 res; - - if (a->used == 0) { - return 0; - } - - /* get number of digits of the lsb we have to read */ - i = MIN(a->used, ((((int)sizeof(unsigned long) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1; - - /* get most significant digit of result */ - res = DIGIT(a, i); - - while (--i >= 0) { - res = (res << DIGIT_BIT) | DIGIT(a, i); - } - /* force result to 32-bits always so it is consistent on non 32-bit platforms */ - return res & 0xFFFFFFFFUL; + return mp_get_long(a) & 0xFFFFFFFFUL; } #endif diff --git a/libtommath/bn_mp_get_long.c b/libtommath/bn_mp_get_long.c index a4d05d6..b95bb8a 100644 --- a/libtommath/bn_mp_get_long.c +++ b/libtommath/bn_mp_get_long.c @@ -18,19 +18,19 @@ unsigned long mp_get_long(const mp_int *a) int i; unsigned long res; - if (a->used == 0) { + if (IS_ZERO(a)) { return 0; } /* get number of digits of the lsb we have to read */ - i = MIN(a->used, ((((int)sizeof(unsigned long) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1; + i = MIN(a->used, (((CHAR_BIT * (int)sizeof(unsigned long)) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1; /* get most significant digit of result */ - res = DIGIT(a, i); + res = (unsigned long)a->dp[i]; -#if (ULONG_MAX != 0xffffffffuL) || (DIGIT_BIT < 32) +#if (ULONG_MAX != 0xFFFFFFFFUL) || (DIGIT_BIT < 32) while (--i >= 0) { - res = (res << DIGIT_BIT) | DIGIT(a, i); + res = (res << DIGIT_BIT) | (unsigned long)a->dp[i]; } #endif return res; diff --git a/libtommath/bn_mp_get_long_long.c b/libtommath/bn_mp_get_long_long.c index 4201b4d..cafd9a4 100644 --- a/libtommath/bn_mp_get_long_long.c +++ b/libtommath/bn_mp_get_long_long.c @@ -18,19 +18,19 @@ unsigned long long mp_get_long_long(const mp_int *a) int i; unsigned long long res; - if (a->used == 0) { + if (IS_ZERO(a)) { return 0; } /* get number of digits of the lsb we have to read */ - i = MIN(a->used, ((((int)sizeof(unsigned long long) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1; + i = MIN(a->used, (((CHAR_BIT * (int)sizeof(unsigned long long)) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1; /* get most significant digit of result */ - res = DIGIT(a, i); + res = (unsigned long long)a->dp[i]; #if DIGIT_BIT < 64 while (--i >= 0) { - res = (res << DIGIT_BIT) | DIGIT(a, i); + res = (res << DIGIT_BIT) | (unsigned long long)a->dp[i]; } #endif return res; diff --git a/libtommath/bn_mp_grow.c b/libtommath/bn_mp_grow.c index 1d92b29..b120194 100644 --- a/libtommath/bn_mp_grow.c +++ b/libtommath/bn_mp_grow.c @@ -29,7 +29,9 @@ int mp_grow(mp_int *a, int size) * in case the operation failed we don't want * to overwrite the dp member of a. */ - tmp = OPT_CAST(mp_digit) XREALLOC(a->dp, sizeof(mp_digit) * (size_t)size); + tmp = (mp_digit *) XREALLOC(a->dp, + (size_t)a->alloc * sizeof (mp_digit), + (size_t)size * sizeof(mp_digit)); if (tmp == NULL) { /* reallocation failed but "a" is still valid [can be freed] */ return MP_MEM; diff --git a/libtommath/bn_mp_init.c b/libtommath/bn_mp_init.c index 7520089..3c0c489 100644 --- a/libtommath/bn_mp_init.c +++ b/libtommath/bn_mp_init.c @@ -18,7 +18,7 @@ int mp_init(mp_int *a) int i; /* allocate memory required and clear it */ - a->dp = OPT_CAST(mp_digit) XMALLOC(sizeof(mp_digit) * (size_t)MP_PREC); + a->dp = (mp_digit *) XMALLOC(MP_PREC * sizeof(mp_digit)); if (a->dp == NULL) { return MP_MEM; } diff --git a/libtommath/bn_mp_init_size.c b/libtommath/bn_mp_init_size.c index 9b933fb..1becb23 100644 --- a/libtommath/bn_mp_init_size.c +++ b/libtommath/bn_mp_init_size.c @@ -21,7 +21,7 @@ int mp_init_size(mp_int *a, int size) size += (MP_PREC * 2) - (size % MP_PREC); /* alloc mem */ - a->dp = OPT_CAST(mp_digit) XMALLOC(sizeof(mp_digit) * (size_t)size); + a->dp = (mp_digit *) XMALLOC((size_t)size * sizeof(mp_digit)); if (a->dp == NULL) { return MP_MEM; } diff --git a/libtommath/bn_mp_is_square.c b/libtommath/bn_mp_is_square.c index 5363a47..1dd1d6c 100644 --- a/libtommath/bn_mp_is_square.c +++ b/libtommath/bn_mp_is_square.c @@ -49,13 +49,12 @@ int mp_is_square(const mp_int *arg, int *ret) return MP_VAL; } - /* digits used? (TSD) */ - if (arg->used == 0) { + if (IS_ZERO(arg)) { return MP_OKAY; } /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */ - if (rem_128[127u & DIGIT(arg, 0)] == (char)1) { + if (rem_128[127u & arg->dp[0]] == (char)1) { return MP_OKAY; } diff --git a/libtommath/bn_mp_prime_random_ex.c b/libtommath/bn_mp_prime_random_ex.c index b0b4632..0ca29ec 100644 --- a/libtommath/bn_mp_prime_random_ex.c +++ b/libtommath/bn_mp_prime_random_ex.c @@ -46,19 +46,19 @@ int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback bsize = (size>>3) + ((size&7)?1:0); /* we need a buffer of bsize bytes */ - tmp = OPT_CAST(unsigned char) XMALLOC((size_t)bsize); + tmp = (unsigned char *) XMALLOC((size_t)bsize); if (tmp == NULL) { return MP_MEM; } /* calc the maskAND value for the MSbyte*/ - maskAND = ((size&7) == 0) ? 0xFF : (0xFF >> (8 - (size & 7))); + maskAND = ((size&7) == 0) ? 0xFF : (unsigned char)(0xFF >> (8 - (size & 7))); /* calc the maskOR_msb */ maskOR_msb = 0; maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0; if ((flags & LTM_PRIME_2MSB_ON) != 0) { - maskOR_msb |= 0x80 >> ((9 - size) & 7); + maskOR_msb |= (unsigned char)(0x80 >> ((9 - size) & 7)); } /* get the maskOR_lsb */ @@ -76,7 +76,7 @@ int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback /* work over the MSbyte */ tmp[0] &= maskAND; - tmp[0] |= 1 << ((size - 1) & 7); + tmp[0] |= (unsigned char)(1 << ((size - 1) & 7)); /* mix in the maskORs */ tmp[maskOR_msb_offset] |= maskOR_msb; @@ -123,7 +123,7 @@ int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback err = MP_OKAY; error: - XFREE(tmp); + XFREE(tmp, bsize); return err; } diff --git a/libtommath/bn_mp_read_radix.c b/libtommath/bn_mp_read_radix.c index 200601e..a8723b7 100644 --- a/libtommath/bn_mp_read_radix.c +++ b/libtommath/bn_mp_read_radix.c @@ -12,6 +12,8 @@ * SPDX-License-Identifier: Unlicense */ +#define MP_TOUPPER(c) ((((c) >= 'a') && ((c) <= 'z')) ? (((c) + 'A') - 'a') : (c)) + /* read a string [ASCII] in a given radix */ int mp_read_radix(mp_int *a, const char *str, int radix) { @@ -46,7 +48,7 @@ int mp_read_radix(mp_int *a, const char *str, int radix) * this allows numbers like 1AB and 1ab to represent the same value * [e.g. in hex] */ - ch = (radix <= 36) ? (char)toupper((int)*str) : *str; + ch = (radix <= 36) ? (char)MP_TOUPPER((int)*str) : *str; pos = (unsigned)(ch - '('); if (mp_s_rmap_reverse_sz < pos) { break; diff --git a/libtommath/bn_mp_set_double.c b/libtommath/bn_mp_set_double.c index 76f6293..c96a3b3 100644 --- a/libtommath/bn_mp_set_double.c +++ b/libtommath/bn_mp_set_double.c @@ -41,8 +41,8 @@ int mp_set_double(mp_int *a, double b) return res; } - if (((cast.bits >> 63) != 0ULL) && (mp_iszero(a) == MP_NO)) { - SIGN(a) = MP_NEG; + if (((cast.bits >> 63) != 0ULL) && !IS_ZERO(a)) { + a->sign = MP_NEG; } return MP_OKAY; diff --git a/libtommath/bn_mp_shrink.c b/libtommath/bn_mp_shrink.c index ff7905f..fa30184 100644 --- a/libtommath/bn_mp_shrink.c +++ b/libtommath/bn_mp_shrink.c @@ -23,7 +23,9 @@ int mp_shrink(mp_int *a) } if (a->alloc != used) { - if ((tmp = OPT_CAST(mp_digit) XREALLOC(a->dp, sizeof(mp_digit) * (size_t)used)) == NULL) { + if ((tmp = (mp_digit *) XREALLOC(a->dp, + (size_t)a->alloc * sizeof (mp_digit), + (size_t)used * sizeof(mp_digit))) == NULL) { return MP_MEM; } a->dp = tmp; diff --git a/libtommath/bn_mp_sqrt.c b/libtommath/bn_mp_sqrt.c index 55b5c79..397f1b9 100644 --- a/libtommath/bn_mp_sqrt.c +++ b/libtommath/bn_mp_sqrt.c @@ -1,5 +1,5 @@ #include "tommath_private.h" -#ifdef BN_MP_SQRT_C +#ifndef BN_MP_SQRT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision diff --git a/libtommath/tommath_private.h b/libtommath/tommath_private.h index 3546370..057f878 100644 --- a/libtommath/tommath_private.h +++ b/libtommath/tommath_private.h @@ -13,7 +13,6 @@ #define TOMMATH_PRIV_H_ #include "tommath.h" -#include #ifndef MIN #define MIN(x, y) (((x) < (y)) ? (x) : (y)) @@ -25,32 +24,26 @@ #ifdef __cplusplus extern "C" { - -/* C++ compilers don't like assigning void * to mp_digit * */ -#define OPT_CAST(x) (x *) - -#else - -/* C on the other hand doesn't care */ -#define OPT_CAST(x) - #endif /* define heap macros */ #ifndef XMALLOC /* default to libc stuff */ -# define XMALLOC malloc -# define XFREE free -# define XREALLOC realloc -# define XCALLOC calloc +# define XMALLOC(size) malloc(size) +# define XFREE(mem, size) free(mem) +# define XREALLOC(mem, oldsize, newsize) realloc(mem, newsize) #else /* prototypes for our heap functions */ -extern void *XMALLOC(size_t n); -extern void *XREALLOC(void *p, size_t n); -extern void *XCALLOC(size_t n, size_t s); -extern void XFREE(void *p); +extern void *XMALLOC(size_t size); +extern void *XREALLOC(void *mem, size_t oldsize, size_t newsize); +extern void XFREE(void *mem, size_t size); #endif +/* ---> Basic Manipulations <--- */ +#define IS_ZERO(a) ((a)->used == 0) +#define IS_EVEN(a) (((a)->used == 0) || (((a)->dp[0] & 1u) == 0u)) +#define IS_ODD(a) (((a)->used > 0) && (((a)->dp[0] & 1u) == 1u)) + /* lowlevel functions, do not call! */ int s_mp_add(const mp_int *a, const mp_int *b, mp_int *c); int s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c); @@ -78,36 +71,26 @@ extern const size_t mp_s_rmap_reverse_sz; /* Fancy macro to set an MPI from another type. * There are several things assumed: - * x is the counter and unsigned + * x is the counter * a is the pointer to the MPI * b is the original value that should be set in the MPI. */ #define MP_SET_XLONG(func_name, type) \ int func_name (mp_int * a, type b) \ { \ - unsigned int x; \ - int res; \ - \ - mp_zero (a); \ - \ - /* set four bits at a time */ \ - for (x = 0; x < (sizeof(type) * 2u); x++) { \ - /* shift the number up four bits */ \ - if ((res = mp_mul_2d (a, 4, a)) != MP_OKAY) { \ - return res; \ - } \ - \ - /* OR in the top four bits of the source */ \ - a->dp[0] |= (mp_digit)(b >> ((sizeof(type) * 8u) - 4u)) & 15uL;\ - \ - /* shift the source up to the next four bits */ \ - b <<= 4; \ - \ - /* ensure that digits are not clamped off */ \ - a->used += 1; \ - } \ - mp_clamp (a); \ - return MP_OKAY; \ + int x = 0; \ + int new_size = (((CHAR_BIT * sizeof(type)) + DIGIT_BIT) - 1) / DIGIT_BIT; \ + int res = mp_grow(a, new_size); \ + if (res == MP_OKAY) { \ + mp_zero(a); \ + while (b != 0u) { \ + a->dp[x++] = ((mp_digit)b & MP_MASK); \ + if ((CHAR_BIT * sizeof (b)) <= DIGIT_BIT) { break; } \ + b >>= ((CHAR_BIT * sizeof (b)) <= DIGIT_BIT ? 0 : DIGIT_BIT); \ + } \ + a->used = x; \ + } \ + return res; \ } #ifdef __cplusplus -- cgit v0.12 From e0b6a53069be24ac23e8ec3d5390613041d28c44 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 5 Apr 2019 18:37:44 +0000 Subject: More efficient version (after feedback from KBK). Better test too. --- generic/tclInt.h | 25 +++++++++++++++++++++++++ generic/tclLink.c | 12 ++++++------ generic/tclObj.c | 29 +++++++++-------------------- tests/link.test | 3 ++- 4 files changed, 42 insertions(+), 27 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 9fc778b..89d7ff9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4514,6 +4514,31 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, /* *---------------------------------------------------------------- + * Macro used by the Tcl core to get the bignum out of the bignum + * representation of a Tcl_Obj. + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum); + *---------------------------------------------------------------- + */ + +#define TclUnpackBignum(objPtr, bignum) \ + do { \ + register Tcl_Obj *bignumObj = (objPtr); \ + register int bignumPayload = \ + PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \ + if (bignumPayload == -1) { \ + (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \ + } else { \ + (bignum).dp = bignumObj->internalRep.twoPtrValue.ptr1; \ + (bignum).sign = bignumPayload >> 30; \ + (bignum).alloc = (bignumPayload >> 15) & 0x7fff; \ + (bignum).used = bignumPayload & 0x7fff; \ + } \ + } while (0) + +/* + *---------------------------------------------------------------- * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C * "prototype" for this macro is: diff --git a/generic/tclLink.c b/generic/tclLink.c index 06a283f..09ba2ed 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -503,7 +503,7 @@ GetUWide( *widePtr = *((const Tcl_WideInt *) clientData); return (*widePtr < 0); } else if (type == TCL_NUMBER_BIG) { - mp_int num; + mp_int *numPtr = clientData; Tcl_WideUInt value = 0; union { Tcl_WideUInt value; @@ -512,15 +512,13 @@ GetUWide( unsigned long numBytes = sizeof(Tcl_WideUInt); unsigned char *bytes = scratch.bytes; - Tcl_GetBignumFromObj(NULL, objPtr, &num); - if (num.sign || (MP_OKAY != mp_to_unsigned_bin_n(&num, bytes, - &numBytes))) { + if (numPtr->sign || (MP_OKAY != mp_to_unsigned_bin_n(numPtr, + bytes, &numBytes))) { /* * If the sign bit is set (a negative value) or if the value * can't possibly fit in the bits of an unsigned wide, there's * no point in doing further conversion. */ - mp_clear(&num); return 1; } #ifdef WORDS_BIGENDIAN @@ -528,10 +526,12 @@ GetUWide( value = (value << CHAR_BIT) | *bytes++; } #else /* !WORDS_BIGENDIAN */ + /* + * Little-endian can read the value directly. + */ value = scratch.value; #endif /* WORDS_BIGENDIAN */ *uwidePtr = value; - mp_clear(&num); return 0; } } diff --git a/generic/tclObj.c b/generic/tclObj.c index f233038..d329aba 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -191,17 +191,6 @@ static Tcl_ThreadDataKey pendingObjDataKey; | ((bignum).alloc << 15) | ((bignum).used)); \ } -#define UNPACK_BIGNUM(objPtr, bignum) \ - if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \ - (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \ - } else { \ - (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \ - (bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \ - (bignum).alloc = \ - (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7fff; \ - (bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7fff; \ - } - /* * Prototypes for functions defined later in this file: */ @@ -2517,7 +2506,7 @@ Tcl_GetDoubleFromObj( if (objPtr->typePtr == &tclBignumType) { mp_int big; - UNPACK_BIGNUM(objPtr, big); + TclUnpackBignum(objPtr, big); *dblPtr = TclBignumToDouble(&big); return TCL_OK; } @@ -3033,7 +3022,7 @@ Tcl_GetLongFromObj( unsigned long scratch, value = 0, numBytes = sizeof(unsigned long); unsigned char *bytes = (unsigned char *) &scratch; - UNPACK_BIGNUM(objPtr, big); + TclUnpackBignum(objPtr, big); if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; @@ -3273,7 +3262,7 @@ Tcl_GetWideIntFromObj( Tcl_WideInt scratch; unsigned char *bytes = (unsigned char *) &scratch; - UNPACK_BIGNUM(objPtr, big); + TclUnpackBignum(objPtr, big); if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; @@ -3387,7 +3376,7 @@ FreeBignum( { mp_int toFree; /* Bignum to free */ - UNPACK_BIGNUM(objPtr, toFree); + TclUnpackBignum(objPtr, toFree); mp_clear(&toFree); if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) { ckfree(objPtr->internalRep.twoPtrValue.ptr1); @@ -3420,7 +3409,7 @@ DupBignum( mp_int bignumCopy; copyPtr->typePtr = &tclBignumType; - UNPACK_BIGNUM(srcPtr, bignumVal); + TclUnpackBignum(srcPtr, bignumVal); if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { Tcl_Panic("initialization failure in DupBignum"); } @@ -3455,7 +3444,7 @@ UpdateStringOfBignum( int size; char *stringVal; - UNPACK_BIGNUM(objPtr, bignumVal); + TclUnpackBignum(objPtr, bignumVal); if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } @@ -3594,10 +3583,10 @@ GetBignumFromObj( if (copy || Tcl_IsShared(objPtr)) { mp_int temp; - UNPACK_BIGNUM(objPtr, temp); + TclUnpackBignum(objPtr, temp); mp_init_copy(bignumValue, &temp); } else { - UNPACK_BIGNUM(objPtr, *bignumValue); + TclUnpackBignum(objPtr, *bignumValue); /* Optimized TclFreeIntRep */ objPtr->internalRep.twoPtrValue.ptr1 = NULL; objPtr->internalRep.twoPtrValue.ptr2 = NULL; @@ -3838,7 +3827,7 @@ TclGetNumberFromObj( mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int) sizeof(mp_int)); - UNPACK_BIGNUM(objPtr, *bigPtr); + TclUnpackBignum(objPtr, *bigPtr); *typePtr = TCL_NUMBER_BIG; *clientDataPtr = bigPtr; return TCL_OK; diff --git a/tests/link.test b/tests/link.test index e04059f..4c4cf99 100644 --- a/tests/link.test +++ b/tests/link.test @@ -781,10 +781,11 @@ test link-20.1 {linkarray unsigned wide} -setup { lappend mylist [set ::my(var) 120] catch {set ::my(var) 1e33} msg lappend mylist $msg + lappend mylist [set ::my(var) 0xbabed00dbabed00d] } -cleanup { testlinkarray remove ::my(var) unset -nocomplain my -} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value}} +} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value} 0xbabed00dbabed00d} test link-20.2 {linkarray unsigned wide} -body { testlinkarray create uwide 1 ::my(var) set ::my(var) 120 -- cgit v0.12 From f4882bb16f3d05c8b225157bb04d2401224ef23e Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 8 Apr 2019 13:01:18 +0000 Subject: Fix for [45b9faf103f2], [try] interaction with local variable names produces segmentation fault. --- generic/tclCmdMZ.c | 6 ++++++ tests/cmdMZ.test | 18 ++++++++++++++++++ 2 files changed, 24 insertions(+) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 2671d49..5eb854b 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4812,18 +4812,24 @@ TryPostBody( Tcl_Obj *varName; Tcl_ListObjIndex(NULL, info[3], 0, &varName); + Tcl_IncrRefCount(varName); if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj, TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DecrRefCount(varName); Tcl_DecrRefCount(resultObj); goto handlerFailed; } + Tcl_DecrRefCount(varName); Tcl_DecrRefCount(resultObj); if (dummy > 1) { Tcl_ListObjIndex(NULL, info[3], 1, &varName); + Tcl_IncrRefCount(varName); if (Tcl_ObjSetVar2(interp, varName, NULL, options, TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DecrRefCount(varName); goto handlerFailed; } + Tcl_DecrRefCount(varName); } } else { /* diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index d79e9f6..dd299f1 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -409,6 +409,24 @@ test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} { [expr {[lindex $m1 6] <= 0.001}] } {1 1 1 1} +test cmdMZ-try-1.0 { + + fix for issue 45b9faf103f2 + + [try] interaction with local variable names produces segmentation violation + +} -body { + ::apply {{} { + eval { + try { + lindex 5 + } on ok res {} + } + set res + }} +} -result 5 + + # The tests for Tcl_WhileObjCmd are in while.test # cleanup -- cgit v0.12 From c1de90d70a6cac71dc4200eb9d9fb2b08a8f9b1c Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 8 Apr 2019 13:38:19 +0000 Subject: Improve test for last commit fixing [45b9faf103f2]. --- tests/cmdMZ.test | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index dd299f1..80258dc 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -417,11 +417,10 @@ test cmdMZ-try-1.0 { } -body { ::apply {{} { - eval { - try { - lindex 5 - } on ok res {} - } + set cmd try + $cmd { + lindex 5 + } on ok res {} set res }} } -result 5 -- cgit v0.12 From 8e7402f6f2f955fdcb8a9a1035dbae99d5997b5c Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Apr 2019 13:54:04 +0000 Subject: extend comment --- generic/tclStringObj.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 4dd334d..38a8ad7 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3864,7 +3864,8 @@ TclStringReverse( * * TclStringReplace -- * - * Implements the inner engine of the [string replace] command. + * Implements the inner engine of the [string replace] and + * [string insert] commands. * * The result is a concatenation of a prefix from objPtr, characters * 0 through first-1, the insertPtr string value, and a suffix from -- cgit v0.12 From f1eba71130bf1b04e9cd0485f4583f13c94eb4ea Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Apr 2019 14:02:01 +0000 Subject: typo fix --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 38a8ad7..6652f15 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3912,7 +3912,7 @@ TclStringReplace( /* * The caller very likely had to call Tcl_GetCharLength() or similar - * to be able to process index values. This means it is like that + * to be able to process index values. This means it is likely that * objPtr is either a proper "bytearray" or a "string" or else it has * a known and short string rep. */ -- cgit v0.12 From 3a8a841386b2df65eca6c7018106438bc7c6d07d Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 8 Apr 2019 15:03:13 +0000 Subject: closes [45b9faf103f2] (tclVar cached lookup): fixes segfaulting if variable released before set; partially revert [4100488a3ca38abf] --- generic/tclCmdMZ.c | 6 ------ generic/tclVar.c | 11 +++++++++-- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 5eb854b..2671d49 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4812,24 +4812,18 @@ TryPostBody( Tcl_Obj *varName; Tcl_ListObjIndex(NULL, info[3], 0, &varName); - Tcl_IncrRefCount(varName); if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DecrRefCount(varName); Tcl_DecrRefCount(resultObj); goto handlerFailed; } - Tcl_DecrRefCount(varName); Tcl_DecrRefCount(resultObj); if (dummy > 1) { Tcl_ListObjIndex(NULL, info[3], 1, &varName); - Tcl_IncrRefCount(varName); if (Tcl_ObjSetVar2(interp, varName, NULL, options, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DecrRefCount(varName); goto handlerFailed; } - Tcl_DecrRefCount(varName); } } else { /* diff --git a/generic/tclVar.c b/generic/tclVar.c index 3271935..affc848 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -722,7 +722,7 @@ TclObjLookupVarEx( Tcl_Obj *cachedNamePtr = localName(varFramePtr, index); if (part1Ptr == cachedNamePtr) { - cachedNamePtr = NULL; + LocalSetIntRep(part1Ptr, index, NULL); } else { /* * [80304238ac] Trickiness here. We will store and incr the @@ -735,6 +735,14 @@ TclObjLookupVarEx( * cachedNamePtr and leave it as string only. This is * radical and destructive, so a better idea would be welcome. */ + + /* + * Firstly set cached local var reference (avoid free before set, + * see [45b9faf103f2]) + */ + LocalSetIntRep(part1Ptr, index, cachedNamePtr); + + /* Then wipe it */ TclFreeIntRep(cachedNamePtr); /* @@ -744,7 +752,6 @@ TclObjLookupVarEx( */ LocalSetIntRep(cachedNamePtr, index, NULL); } - LocalSetIntRep(part1Ptr, index, cachedNamePtr); } else { /* * At least mark part1Ptr as already parsed. -- cgit v0.12 From 1749b4cc870fc9ff5bdb398dca162d97eed9f28c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 8 Apr 2019 19:31:10 +0000 Subject: Add test-cases for win32/win64 --disable-shared, and put standard --enable-threads --- .travis.yml | 35 +++++++++++++++++++++++++++++++++-- 1 file changed, 33 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 8a7484f..b46bc26 100644 --- a/.travis.yml +++ b/.travis.yml @@ -108,7 +108,23 @@ matrix: - wine env: - BUILD_DIR=win - - CFGOPT=--host=i686-w64-mingw32 + - CFGOPT="--host=i686-w64-mingw32 --enable-threads" + - NO_DIRECT_TEST=1 + - os: linux + dist: xenial + compiler: i686-w64-mingw32-gcc + addons: + apt: + packages: + - gcc-mingw-w64-base + - binutils-mingw-w64-i686 + - gcc-mingw-w64-i686 + - gcc-mingw-w64 + - gcc-multilib + - wine + env: + - BUILD_DIR=win + - CFGOPT="--host=i686-w64-mingw32 --disable-shared --enable-threads" - NO_DIRECT_TEST=1 # Test with mingw-w64 (64 bit) - os: linux @@ -124,7 +140,22 @@ matrix: - wine env: - BUILD_DIR=win - - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit" + - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit --enable-threads" + - NO_DIRECT_TEST=1 + - os: linux + dist: xenial + compiler: x86_64-w64-mingw32-gcc + addons: + apt: + packages: + - gcc-mingw-w64-base + - binutils-mingw-w64-x86-64 + - gcc-mingw-w64-x86-64 + - gcc-mingw-w64 + - wine + env: + - BUILD_DIR=win + - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit --enable-threads --disable-shared" - NO_DIRECT_TEST=1 before_install: -- cgit v0.12 From 6ed025f0c6dbc01511a05bd87be92dc7d3dbb77d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 8 Apr 2019 21:25:33 +0000 Subject: Fix clang compiler warning in tclZlib.c. Clear execute bit in two encodings --- generic/tclZlib.c | 2 +- tools/encoding/ebcdic.txt | 0 tools/encoding/tis-620.txt | 0 3 files changed, 1 insertion(+), 1 deletion(-) mode change 100755 => 100644 tools/encoding/ebcdic.txt mode change 100755 => 100644 tools/encoding/tis-620.txt diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 5a7abec..8dbe807 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -422,7 +422,7 @@ GenerateHeader( { Tcl_Obj *value; int len, result = TCL_ERROR; - Tcl_WideInt wideValue; + Tcl_WideInt wideValue = 0; const char *valueStr; Tcl_Encoding latin1enc; static const char *const types[] = { diff --git a/tools/encoding/ebcdic.txt b/tools/encoding/ebcdic.txt old mode 100755 new mode 100644 diff --git a/tools/encoding/tis-620.txt b/tools/encoding/tis-620.txt old mode 100755 new mode 100644 -- cgit v0.12 From 9b1a75a1ccbda9eaf0bb030215b7e6181d51f487 Mon Sep 17 00:00:00 2001 From: andy Date: Tue, 9 Apr 2019 03:11:14 +0000 Subject: Correct minor documentation typo --- doc/interp.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/interp.n b/doc/interp.n index 92113a6..1c9618a 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -201,7 +201,7 @@ slave interpreter identified by \fIpath\fR. If no arguments are given, option and current setting are returned. If \fB\-frame\fR is given, the debug setting is set to the given boolean if provided and the current setting is returned. -This only effects the output of \fBinfo frame\fR, in that exact +This only affects the output of \fBinfo frame\fR, in that exact frame-level information for command invocation at the bytecode level is only captured with this setting on. .RS -- cgit v0.12 From d96dda52c403f620a9fd1ae77fe07e1505d0efe2 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 9 Apr 2019 09:11:31 +0000 Subject: Added missing test case --- tests/oo.test | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index db5c14f..b0704da 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1480,6 +1480,30 @@ test oo-10.3 {OO: invoke and modify} -setup { oo::define B deletemethod b c lappend result [C a] [C b] [C c] } -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c} +test oo-10.4 {OO: invoke and modify} -setup { + oo::class create A { + method a {} {return A.a} + method b {} {return A.b} + method c {} {return A.c} + } + A create B + oo::objdefine B { + method a {} {return [next],B.a} + method b {} {return [next],B.b} + method c {} {return [next],B.c} + } + set result {} +} -cleanup { + A destroy +} -body { + lappend result [B a] [B b] [B c] - + oo::objdefine B deletemethod b + lappend result [B a] [B b] [B c] - + oo::objdefine B renamemethod a b + lappend result [B a] [B b] [B c] - + oo::objdefine B deletemethod b c + lappend result [B a] [B b] [B c] +} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c} test oo-11.1 {OO: cleanup} { oo::object create foo -- cgit v0.12 From 747b6686767cb90fc12954020dd16855dbb3a885 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 9 Apr 2019 09:18:59 +0000 Subject: Clarified some documentation --- doc/define.n | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/doc/define.n b/doc/define.n index e619728..ad991e1 100644 --- a/doc/define.n +++ b/doc/define.n @@ -55,7 +55,8 @@ string, the constructor will be deleted. This deletes each of the methods called \fIname\fR from a class. The methods 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). +(except when they have a call chain through the class being modified) or the +class object itself. .TP \fBdestructor\fI bodyScript\fR . @@ -135,7 +136,8 @@ This renames the method called \fIfromName\fR in a class to \fItoName\fR. The method must have previously existed in the class, and \fItoName\fR must not previously refer to a method 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). Does +(except when they have a call chain through the class being modified), or the +class object itself. Does not change the export status of the method; if it was exported before, it will be afterwards. .TP @@ -203,8 +205,10 @@ well be in an inconsistent state unless additional configuration work is done. \fBdeletemethod\fI name\fR ?\fIname ...\fR . This deletes each of the methods called \fIname\fR from an object. The methods -must have previously existed in that object. Does not affect the classes that -the object is an instance of. +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. .TP \fBexport\fI name \fR?\fIname ...\fR? . @@ -262,8 +266,10 @@ By default, this slot works by replacement. This renames the method called \fIfromName\fR in an object to \fItoName\fR. The method must have previously existed in the object, and \fItoName\fR must not previously refer to a method in that object. Does not affect the classes -that the object is an instance of. Does not change the export status of the -method; if it was exported before, it will be afterwards. +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. .TP \fBunexport\fI name \fR?\fIname ...\fR? . -- cgit v0.12 From f2c8c6c408d10fd1049ebab13794e83731d7bd90 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 9 Apr 2019 10:31:36 +0000 Subject: closes [1e5e25cf2b] - tests/cmdMZ.test: fixed NRT-related sleeps (and time-related corner cases and test expectations); todo: rewrite several tests if monotonic clock is provided resp. command "after" gets microsecond accuracy (RFE [fdfbd5e10] gets merged) --- tests/cmdMZ.test | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index d1f0a44..2ac74cd 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -321,6 +321,14 @@ test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { # The tests for Tcl_SubstObjCmd are in subst.test # The tests for Tcl_SwitchObjCmd are in switch.test +# todo: rewrite this if monotonic clock is provided resp. command "after" +# gets microsecond accuracy (RFE [fdfbd5e10] gets merged): +proc _nrt_sleep {msec} { + set usec [expr {$msec * 1000}] + set stime [clock microseconds] + while {abs([clock microseconds] - $stime) < $usec} {after 0} +} + test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} { list [catch {time} msg] $msg } {1 {wrong # args: should be "time command ?count?"}} @@ -337,7 +345,7 @@ test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} { regexp {^\d+ microseconds per iteration} [time {format 1}] } 1 test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} { - expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]} + expr {[lindex [time {_nrt_sleep 1}] 0] < [lindex [time {_nrt_sleep 20}] 0]} } 1 test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { list [catch {time {error foo}} msg] $msg $::errorInfo @@ -372,18 +380,18 @@ test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} { regexp {^0 \ws/# 0 # 0 #/sec 0 nett-ms$} [timerate {} 0 0] } 1 test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} { - set m1 [timerate {after 0} 20] - set m2 [timerate {after 1} 20] + set m1 [timerate {_nrt_sleep 0} 20] + set m2 [timerate {_nrt_sleep 0.2} 20] list \ [expr {[lindex $m1 0] < [lindex $m2 0]}] \ [expr {[lindex $m1 0] < 100}] \ - [expr {[lindex $m2 0] >= 500}] \ + [expr {[lindex $m2 0] > 100}] \ [expr {[lindex $m1 2] > 1000}] \ - [expr {[lindex $m2 2] <= 50}] \ - [expr {[lindex $m1 4] > 10000}] \ - [expr {[lindex $m2 4] < 10000}] \ - [expr {[lindex $m1 6] > 10 && [lindex $m1 6] < 50}] \ - [expr {[lindex $m2 6] > 10 && [lindex $m2 6] < 50}] + [expr {[lindex $m2 2] < 1000}] \ + [expr {[lindex $m1 4] > 50000}] \ + [expr {[lindex $m2 4] < 50000}] \ + [expr {[lindex $m1 6] > 10 && [lindex $m1 6] < 100}] \ + [expr {[lindex $m2 6] > 10 && [lindex $m2 6] < 100}] } [lrepeat 9 1] test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} { list [catch {timerate {error foo} 1} msg] $msg $::errorInfo @@ -402,11 +410,11 @@ test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} { } {1 1 1 1} test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} { set m1 [timerate {} 1000 5]; # max-count wins - set m2 [timerate {after 20} 1 5]; # max-time wins + set m2 [timerate {_nrt_sleep 20} 1 5]; # max-time wins list [lindex $m1 2] [lindex $m2 2] } {5 1} test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} { - set m1 [timerate -overhead 1e6 {after 10} 100 1] + set m1 [timerate -overhead 1e6 {_nrt_sleep 10} 100 1] list \ [expr {[lindex $m1 0] == 0.0}] \ [expr {[lindex $m1 2] == 1}] \ -- cgit v0.12 From 6fb4854406b2c9cf6a6496ffaa026fcf0e3e065a Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 9 Apr 2019 19:37:55 +0000 Subject: closes [940ce8f958] - tests/cmdMZ.test: avoid import timerate to global NS in tests (e. g. using tcltest -singleproc 1 -file 'cmdMZ* namespace*') --- tests/cmdMZ.test | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 2ac74cd..4c4f532 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -24,6 +24,10 @@ namespace eval ::tcl::test::cmdMZ { namespace import ::tcltest::temporaryDirectory namespace import ::tcltest::test + if {[namespace which -command ::tcl::unsupported::timerate] ne ""} { + namespace import ::tcl::unsupported::timerate + } + # Tcl_PwdObjCmd test cmdMZ-1.1 {Tcl_PwdObjCmd} { -- cgit v0.12 From 7df97e929223d6b0ff18cbfaad9809c18e11c3ff Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 11 Apr 2019 20:09:27 +0000 Subject: Only use special mp_sqrt() code when double format/tommath format are exactly what's expected. Otherwise, use original always-working tommath code. Simplify overflow check in bignum expononent code, not using bignums where it's not necessary. Don't overallocate bignums when using wideint's only. --- generic/tclExecute.c | 20 ++++++++------------ generic/tclTomMathInterface.c | 6 ++---- libtommath/bn_mp_set_double.c | 4 ++-- libtommath/bn_mp_sqrt.c | 22 +++++++++++++++------- 4 files changed, 27 insertions(+), 25 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4c36123..a4a4646 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6032,7 +6032,7 @@ TEBCresume( /* [string is integer] is -UINT_MAX to UINT_MAX range */ int i; - if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { + if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { type1 = TCL_NUMBER_WIDE; } #ifndef TCL_WIDE_INT_IS_LONG @@ -6040,7 +6040,7 @@ TEBCresume( /* value is between WIDE_MIN and WIDE_MAX */ /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ int i; - if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { + if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { type1 = TCL_NUMBER_LONG; } #endif @@ -6049,7 +6049,7 @@ TEBCresume( /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ Tcl_WideInt w; - if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { + if (TclGetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { type1 = TCL_NUMBER_WIDE; } } @@ -8984,22 +8984,18 @@ ExecuteExtendedBinaryMathOp( #endif overflowExpon: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if ((big2.used > 1) -#if DIGIT_BIT > 28 - || ((big2.used == 1) && (big2.dp[0] >= (1<<28))) -#endif - ) { - mp_clear(&big2); + + if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK) + || (value2Ptr->typePtr != &tclIntType) + || (Tcl_WideUInt)w2 >= (1<<28)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); mp_init(&bigResult); - mp_expt_d(&big1, big2.dp[0], &bigResult); + mp_expt_d(&big1, w2, &bigResult); mp_clear(&big1); - mp_clear(&big2); BIG_RESULT(&bigResult); } diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index d7da4ee..902fd8d 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -119,8 +119,7 @@ TclBNInitBignumFromLong( * Allocate enough memory to hold the largest possible long */ - status = mp_init_size(a, - (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT); + status = mp_init(a); if (status != MP_OKAY) { Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); } @@ -206,8 +205,7 @@ TclBNInitBignumFromWideUInt( * Allocate enough memory to hold the largest possible Tcl_WideUInt. */ - status = mp_init_size(a, - (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT); + status = mp_init(a); if (status != MP_OKAY) { Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); } diff --git a/libtommath/bn_mp_set_double.c b/libtommath/bn_mp_set_double.c index c96a3b3..12f8dad 100644 --- a/libtommath/bn_mp_set_double.c +++ b/libtommath/bn_mp_set_double.c @@ -15,11 +15,11 @@ #if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559) int mp_set_double(mp_int *a, double b) { - uint64_t frac; + unsigned long long frac; int exp, res; union { double dbl; - uint64_t bits; + unsigned long long bits; } cast; cast.dbl = b; diff --git a/libtommath/bn_mp_sqrt.c b/libtommath/bn_mp_sqrt.c index bbca158..116fb14 100644 --- a/libtommath/bn_mp_sqrt.c +++ b/libtommath/bn_mp_sqrt.c @@ -14,6 +14,9 @@ #ifndef NO_FLOATING_POINT #include +#if (DIGIT_BIT != 28) || (FLT_RADIX != 2) || (DBL_MANT_DIG != 53) || (DBL_MAX_EXP != 1024) +#define NO_FLOATING_POINT +#endif #endif /* this function is less generic than mp_n_root, simpler and faster */ @@ -21,8 +24,8 @@ int mp_sqrt(const mp_int *arg, mp_int *ret) { int res; mp_int t1, t2; - int i, j, k; #ifndef NO_FLOATING_POINT + int i, j, k; volatile double d; mp_digit dig; #endif @@ -38,6 +41,8 @@ int mp_sqrt(const mp_int *arg, mp_int *ret) return MP_OKAY; } +#ifndef NO_FLOATING_POINT + i = (arg->used / 2) - 1; j = 2 * i; if ((res = mp_init_size(&t1, i+2)) != MP_OKAY) { @@ -52,8 +57,6 @@ int mp_sqrt(const mp_int *arg, mp_int *ret) t1.dp[k] = (mp_digit) 0; } -#ifndef NO_FLOATING_POINT - /* Estimate the square root using the hardware floating point unit. */ d = 0.0; @@ -96,11 +99,16 @@ int mp_sqrt(const mp_int *arg, mp_int *ret) #else - /* Estimate the square root as having 1 in the most significant place. */ + if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) { + return res; + } + + if ((res = mp_init(&t2)) != MP_OKAY) { + goto E2; + } - t1.used = i + 2; - t1.dp[i+1] = (mp_digit) 1; - t1.dp[i] = (mp_digit) 0; + /* First approx. (not very bad for large arg) */ + mp_rshd(&t1, t1.used/2); #endif -- cgit v0.12 From 1dbc626f0f6dadaa60c8e11a06ca90b5b0eb1c07 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 11 Apr 2019 21:39:50 +0000 Subject: Suggested fix for [60559fd4a6]: put selected tests in child interps --- tests/coroutine.test | 34 ++++++++++++++++++++++------------ 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/tests/coroutine.test b/tests/coroutine.test index 8217a92..3580f94 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -626,19 +626,31 @@ test coroutine-7.5 {return codes} { } set result } {0 1 2 3 4 5} -test coroutine-7.6 {Early yield crashes} { - proc foo args {} - trace add execution foo enter {catch yield} - coroutine demo foo - rename foo {} -} {} +test coroutine-7.6 {Early yield crashes} -setup { + set i [interp create] +} -body { + # Force into a child interpreter [bug 60559fd4a6] + $i eval { + proc foo args {} + trace add execution foo enter {catch yield} + coroutine demo foo + rename foo {} + return ok + } +} -cleanup { + interp delete $i +} -result ok test coroutine-7.7 {Bug 2486550} -setup { - interp hide {} yield + set i [interp create] + $i hide yield } -body { - coroutine demo interp invokehidden {} yield ok + # Force into a child interpreter [bug 60559fd4a6] + $i eval { + coroutine demo interp invokehidden {} yield ok + } } -cleanup { - demo - interp expose {} yield + $i eval demo + interp delete $i } -result ok test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup { namespace eval cotest {} @@ -780,8 +792,6 @@ test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { interp delete slave set result } -result {inject-executed} - - # cleanup unset lambda -- cgit v0.12 From e2dcb521341596da403d0b8796e07c431d933a39 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 14 Apr 2019 07:52:16 +0000 Subject: Removed TCL_LINK_ALLOC; it wasn't used. --- doc/LinkVar.3 | 14 ++++++++------ generic/tclLink.c | 3 +-- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index a38610b..1e42858 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -34,6 +34,11 @@ Also used by \fBTcl_LinkVar\fR to return error messages. Name of global variable. .AP void *addr in Address of C variable that is to be linked to \fIvarName\fR. +.sp +.VS "TIP 312" +In \fBTcl_LinkArray\fR, may be NULL to tell Tcl to create the storage +for the array in the variable. +.VE "TIP 312" .AP int type in Type of C variable for \fBTcl_LinkVar\fR or type of array element for \fBTcl_LinkArray\fR. Must be one of \fBTCL_LINK_INT\fR, @@ -48,9 +53,7 @@ used. .sp .VS "TIP 312" In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and -\fBTCL_LINK_BYTES\fR may be used. \fBTCL_LINK_ALLOC\fR may also be OR'ed in -to tell Tcl to manage the storage for the array in the variable (that is, the -C variable is technically a pointer to an array, not the array itself). +\fBTCL_LINK_BYTES\fR may be used. .VE "TIP 312" .sp All the above for both functions may be @@ -77,9 +80,8 @@ contains an error message. .VS "TIP 312" \fBTcl_LinkArray\fR is similar, but for arrays of fixed size (given by the \fIsize\fR argument). When asked to allocate the backing C array -storage (via the \fBTCL_LINK_ALLOC\fR bit), it writes the address that -it allocated to the Tcl interpreter result in addition to storing the -location of the array in the C variable pointed to by \fIaddr\fR. +storage (via the \fIaddr\fR argument being NULL), it writes the +address that it allocated to the Tcl interpreter result. .VE "TIP 312" .PP The \fItype\fR argument specifies the type of the C variable, diff --git a/generic/tclLink.c b/generic/tclLink.c index 09ba2ed..57735f8 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -235,8 +235,7 @@ Tcl_LinkArray( * will be allocated and returned as the * interpreter result. */ int type, /* Type of C variable: TCL_LINK_INT, etc. Also - * may have TCL_LINK_READ_ONLY and - * TCL_LINK_ALLOC OR'ed in. */ + * may have TCL_LINK_READ_ONLY OR'ed in. */ int size) /* Size of C variable array, >1 if array */ { Tcl_Obj *objPtr; -- cgit v0.12 From 564d3a1a7b42dcff5a8f6c5a5545e19cf58e3617 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 14 Apr 2019 15:14:50 +0000 Subject: Doc tweak --- doc/string.n | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/doc/string.n b/doc/string.n index 13b5969..72c7913 100644 --- a/doc/string.n +++ b/doc/string.n @@ -89,9 +89,9 @@ length of the string then this command returns an empty string. .RE .TP \fBstring insert \fIstring index insertString\fR -. +.VS "TIP 504" Returns a copy of \fIstring\fR with \fIinsertString\fR inserted at the -\fIindex\fR'th character. \fIindex\fR may be specified as described in the +\fIindex\fR'th character. The \fIindex\fR may be specified as described in the \fBSTRING INDICES\fR section. .RS .PP @@ -104,6 +104,7 @@ If \fIindex\fR is at or before the start of \fIstring\fR (e.g., \fIindex\fR is 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" .TP \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR . @@ -291,7 +292,9 @@ the special interpretation of the characters \fB*?[]\e\fR in . Returns a range of consecutive characters from \fIstring\fR, starting with the character whose index is \fIfirst\fR and ending with the -character whose index is \fIlast\fR. An index of 0 refers to the first +character whose index is \fIlast\fR (using the forms described in +\fBSTRING INDICES\fR). An index of \fB0\fR refers to the first +character of the string; an index of \fBend\fR refers to last character of the string. \fIfirst\fR and \fIlast\fR may be specified as for the \fBindex\fR method. If \fIfirst\fR is less than zero then it is treated as if it were zero, and if \fIlast\fR is greater than or @@ -301,13 +304,16 @@ string is returned. .TP \fBstring repeat \fIstring count\fR . -Returns \fIstring\fR repeated \fIcount\fR number of times. +Returns a string consisting of \fIstring\fR concatenated with itself +\fIcount\fR times. If \fIcount\fR is 0, the empty string will be +returned. .TP \fBstring replace \fIstring first last\fR ?\fInewstring\fR? . Removes a range of consecutive characters from \fIstring\fR, starting with the character whose index is \fIfirst\fR and ending with the -character whose index is \fIlast\fR. An index of 0 refers to the +character whose index is \fIlast\fR (using the forms described in +\fBSTRING INDICES\fR). An index of 0 refers to the first character of the string. \fIFirst\fR and \fIlast\fR may be specified as for the \fBindex\fR method. If \fInewstring\fR is specified, then it is placed in the removed character range. If -- cgit v0.12 From bcca980f06d421d332bb5bb34dac1a056681b86a Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 15 Apr 2019 19:57:54 +0000 Subject: Add [dict getdef] alias --- doc/dict.n | 5 ++++- generic/tclDictObj.c | 18 +++++++++--------- tests/dict.test | 46 +++++++++++++++++++++++++++++++++++++--------- 3 files changed, 50 insertions(+), 19 deletions(-) diff --git a/doc/dict.n b/doc/dict.n index 12c9b1a..3475415 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -120,6 +120,8 @@ It is an error to attempt to retrieve a value for a key that is not present in the dictionary. .RE .TP +\fBdict getdef \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR +.TP \fBdict getwithdefault \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR .VS "8.7, TIP342" This behaves the same as \fBdict get\fR (with at least one \fIkey\fR @@ -129,7 +131,8 @@ error because the \fIkey\fR (or one of the \fIkey\fRs on the key path) is absent, it returns the \fIdefault\fR argument instead. .RS .PP -Note that there must always be at least one \fIkey\fR provided. +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" .TP diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 75dcd09..fea4035 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -34,9 +34,8 @@ static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictGetCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int DictGetWithDefaultCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); +static int DictGetDefCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp, @@ -92,7 +91,8 @@ static const EnsembleImplMap implementationMap[] = { {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, - {"getwithdefault", DictGetWithDefaultCmd, NULL, NULL, NULL, 0 }, + {"getdef", DictGetDefCmd, NULL, NULL, NULL, 0 }, + {"getwithdefault", DictGetDefCmd, NULL, NULL, NULL, 0 }, {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, @@ -1631,11 +1631,11 @@ DictGetCmd( /* *---------------------------------------------------------------------- * - * DictGetWithDefaultCmd -- + * DictGetDefCmd -- * - * This function implements the "dict getwithdefault" Tcl command. See - * the user documentation for details on what it does, and TIP#342 for - * the formal specification. + * This function implements the "dict getdef" and "dict getwithdefault" + * Tcl commands. See the user documentation for details on what it does, + * and TIP#342 for the formal specification. * * Results: * A standard Tcl result. @@ -1647,7 +1647,7 @@ DictGetCmd( */ static int -DictGetWithDefaultCmd( +DictGetDefCmd( ClientData dummy, Tcl_Interp *interp, int objc, diff --git a/tests/dict.test b/tests/dict.test index 50e4db7..6d74b96 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -2048,31 +2048,59 @@ test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} }} } {} -test dict-26.1 {dict getwithdefault command} -body { +test dict-26.1 {dict getdef command} -body { + dict getdef {a b} a c +} -result b +test dict-26.2 {dict getdef command} -body { + dict getdef {a b} b c +} -result c +test dict-26.3 {dict getdef command} -body { + dict getdef {a {b c}} a b d +} -result c +test dict-26.4 {dict getdef command} -body { + dict getdef {a {b c}} a c d +} -result d +test dict-26.5 {dict getdef command} -body { + dict getdef {a {b c}} b c d +} -result d +test dict-26.6 {dict getdef command} -returnCodes error -body { + dict getdef {a {b c d}} a b d +} -result {missing value to go with key} +test dict-26.7 {dict getdef command} -returnCodes error -body { + dict getdef +} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} +test dict-26.8 {dict getdef command} -returnCodes error -body { + dict getdef {} +} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} +test dict-26.9 {dict getdef command} -returnCodes error -body { + dict getdef {} {} +} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} + +test dict-27.1 {dict getwithdefault command} -body { dict getwithdefault {a b} a c } -result b -test dict-26.2 {dict getwithdefault command} -body { +test dict-27.2 {dict getwithdefault command} -body { dict getwithdefault {a b} b c } -result c -test dict-26.3 {dict getwithdefault command} -body { +test dict-27.3 {dict getwithdefault command} -body { dict getwithdefault {a {b c}} a b d } -result c -test dict-26.4 {dict getwithdefault command} -body { +test dict-27.4 {dict getwithdefault command} -body { dict getwithdefault {a {b c}} a c d } -result d -test dict-26.5 {dict getwithdefault command} -body { +test dict-27.5 {dict getwithdefault command} -body { dict getwithdefault {a {b c}} b c d } -result d -test dict-26.6 {dict getwithdefault command} -returnCodes error -body { +test dict-27.6 {dict getwithdefault command} -returnCodes error -body { dict getwithdefault {a {b c d}} a b d } -result {missing value to go with key} -test dict-26.7 {dict getwithdefault command} -returnCodes error -body { +test dict-27.7 {dict getwithdefault command} -returnCodes error -body { dict getwithdefault } -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} -test dict-26.8 {dict getwithdefault command} -returnCodes error -body { +test dict-27.8 {dict getwithdefault command} -returnCodes error -body { dict getwithdefault {} } -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} -test dict-26.9 {dict getwithdefault command} -returnCodes error -body { +test dict-27.9 {dict getwithdefault command} -returnCodes error -body { dict getwithdefault {} {} } -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} -- cgit v0.12 From f720f4cad5dc71321f549bcdb10dbb0a312e52e4 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 14:25:59 +0000 Subject: Isolate tests of [info frame] results from testing environment. --- tests/info.test | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/tests/info.test b/tests/info.test index fbc65ba..fb2da75 100644 --- a/tests/info.test +++ b/tests/info.test @@ -773,16 +773,16 @@ test info-22.8 {info frame, basic trace} -constraints {!singleTestInterp} -match ## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0 -test info-23.0 {eval'd info frame} {!singleTestInterp} { - eval {info frame} -} 8 -test info-23.1 {eval'd info frame, semi-dynamic} {!singleTestInterp} { - eval info frame -} 8 -test info-23.2 {eval'd info frame, dynamic} {!singleTestInterp} { - set script {info frame} - eval $script -} 8 +test info-23.0 {eval'd info frame} -constraints {!singleTestInterp} -body { + list [i eval {info frame}] [i eval {eval {info frame}}] +} -setup {interp create i} -cleanup {interp delete i} -result {1 2} +test info-23.1 {eval'd info frame, semi-dynamic} -constraints {!singleTestInterp} -body { + i eval {eval info frame} +} -setup {interp create i} -cleanup {interp delete i} -result 2 +test info-23.2 {eval'd info frame, dynamic} -constraints {!singleTestInterp} -body { + i eval { set script {info frame} + eval $script} +} -setup {interp create i} -cleanup {interp delete i} -result 2 test info-23.3 {eval'd info frame, literal} -match glob -body { eval { info frame 0 -- cgit v0.12 From 05509bdd77f1324b1f0d7c823d04bea37fbcd460 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 14:34:42 +0000 Subject: Revise coroutines tests so they do not leave behind frame footprints that can interfere with other tests. --- tests/coroutine.test | 34 ++++++++++++++++++++++------------ 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/tests/coroutine.test b/tests/coroutine.test index 8a5494d..be2b624 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -626,19 +626,31 @@ test coroutine-7.5 {return codes} { } set result } {0 1 2 3 4 5} -test coroutine-7.6 {Early yield crashes} { - proc foo args {} - trace add execution foo enter {catch yield} - coroutine demo foo - rename foo {} -} {} +test coroutine-7.6 {Early yield crashes} -setup { + set i [interp create] +} -body { + # Force into a child interpreter [bug 60559fd4a6] + $i eval { + proc foo args {} + trace add execution foo enter {catch yield} + coroutine demo foo + rename foo {} + return ok + } +} -cleanup { + interp delete $i +} -result ok test coroutine-7.7 {Bug 2486550} -setup { - interp hide {} yield + set i [interp create] + $i hide yield } -body { - coroutine demo interp invokehidden {} yield ok + # Force into a child interpreter [bug 60559fd4a6] + $i eval { + coroutine demo interp invokehidden {} yield ok + } } -cleanup { - demo - interp expose {} yield + $i eval demo + interp delete $i } -result ok test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup { namespace eval cotest {} @@ -780,8 +792,6 @@ test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { interp delete slave set result } -result {inject-executed} - - # cleanup unset lambda -- cgit v0.12 From 12486f233fe3dee8ac48f4ec6c7c2bb1ea798c88 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 16:26:03 +0000 Subject: The [namespace delete ::httpTest] at the end of httpPipeline.test failed to also undo the custom [::http::Log] command it put in place. This dangling command was left broken and made much failure. Revised httpTest.tcl to use a trace to tidy up after itself. --- tests/httpTest.tcl | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl index 326b361..4345845 100644 --- a/tests/httpTest.tcl +++ b/tests/httpTest.tcl @@ -68,7 +68,11 @@ proc http::Log {args} { } return } - +# The http::Log routine above needs the variable ::httpTest::testOptions +# Set up to destroy it when that variable goes away. +trace add variable ::httpTest::testOptions unset {apply {args { + proc ::http::Log args {} +}}} # Called by http::Log (the "testing" version) to record logs for later analysis. -- cgit v0.12 From d227a324cdc79a735085101a912633df0541c4b9 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 16:32:53 +0000 Subject: Duplicate test names. --- tests/oo.test | 4 ++-- tests/string.test | 42 +++++++++++++++++++++--------------------- tests/utf.test | 6 +++--- 3 files changed, 26 insertions(+), 26 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index b0c5570..c8f4b21 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2549,7 +2549,7 @@ test oo-16.17 {OO: object introspection: creationid #500} -body { test oo-16.18 {OO: object introspection: creationid #500} -body { info object creationid } -returnCodes error -result {wrong # args: should be "info object creationid objName"} -test oo-16.18 {OO: object introspection: creationid #500} -body { +test oo-16.18.1 {OO: object introspection: creationid #500} -body { info object creationid oo::object gorp } -returnCodes error -result {wrong # args: should be "info object creationid objName"} test oo-16.19 {OO: object introspection: creationid #500} -setup { @@ -4095,7 +4095,7 @@ test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { } -cleanup [SampleSlotCleanup { rename sampleSlot {} }] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}} -test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { +test oo-32.7 {TIP 516: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -remove c a] \ diff --git a/tests/string.test b/tests/string.test index e937ab4..f077164 100644 --- a/tests/string.test +++ b/tests/string.test @@ -2415,75 +2415,75 @@ test string-31.25.$noComp {string insert, neither byte array nor Unicode} { run {tcl::string::insert [makeList a b c] 1 zzzzzz} } {azzzzzz b c} -test string-31.1.$noComp {string is dict} { +test string-32.1.$noComp {string is dict} { string is dict {a b c d} } 1 -test string-31.1a.$noComp {string is dict} { +test string-32.1a.$noComp {string is dict} { string is dict {a b c} } 0 -test string-31.2.$noComp {string is dict} { +test string-32.2.$noComp {string is dict} { string is dict "a \{b c" } 0 -test string-31.3.$noComp {string is dict} { +test string-32.3.$noComp {string is dict} { string is dict {a {b c}d e} } 0 -test string-31.4.$noComp {string is dict} { +test string-32.4.$noComp {string is dict} { string is dict {} } 1 -test string-31.5.$noComp {string is dict} { +test string-32.5.$noComp {string is dict} { string is dict -strict {a b c d} } 1 -test string-31.5a.$noComp {string is dict} { +test string-32.5a.$noComp {string is dict} { string is dict -strict {a b c} } 0 -test string-31.6.$noComp {string is dict} { +test string-32.6.$noComp {string is dict} { string is dict -strict "a \{b c" } 0 -test string-31.7.$noComp {string is dict} { +test string-32.7.$noComp {string is dict} { string is dict -strict {a {b c}d e} } 0 -test string-31.8.$noComp {string is dict} { +test string-32.8.$noComp {string is dict} { string is dict -strict {} } 1 -test string-31.9.$noComp {string is dict} { +test string-32.9.$noComp {string is dict} { set x {} list [string is dict -failindex x {a b c d}] $x } {1 {}} -test string-31.9a.$noComp {string is dict} { +test string-32.9a.$noComp {string is dict} { set x {} list [string is dict -failindex x {a b c}] $x } {0 -1} -test string-31.10.$noComp {string is dict} { +test string-32.10.$noComp {string is dict} { set x {} list [string is dict -failindex x "a \{b c d"] $x } {0 2} -test string-31.10a.$noComp {string is dict} { +test string-32.10a.$noComp {string is dict} { set x {} list [string is dict -failindex x "a \{b c"] $x } {0 2} -test string-31.11.$noComp {string is dict} { +test string-32.11.$noComp {string is dict} { set x {} list [string is dict -failindex x {a b {b c}d e}] $x } {0 4} -test string-31.12.$noComp {string is dict} { +test string-32.12.$noComp {string is dict} { set x {} list [string is dict -failindex x {}] $x } {1 {}} -test string-31.13.$noComp {string is dict} { +test string-32.13.$noComp {string is dict} { set x {} list [string is dict -failindex x { {b c}d e}] $x } {0 2} -test string-31.14.$noComp {string is dict} { +test string-32.14.$noComp {string is dict} { set x {} list [string is dict -failindex x "\uabcd {b c}d e"] $x } {0 2} -test string-31.15.$noComp {string is dict, valid dict} { +test string-32.15.$noComp {string is dict, valid dict} { string is dict {a b c d e f} } 1 -test string-31.16.$noComp {string is dict, invalid dict} { +test string-32.16.$noComp {string is dict, invalid dict} { string is dict a } 0 -test string-31.17.$noComp {string is dict, valid dict packed in invalid dict} { +test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} { string is dict {{a b c d e f g h}} } 0 diff --git a/tests/utf.test b/tests/utf.test index 72b8d97..dc1a435 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -161,7 +161,7 @@ test utf-8.4 {Tcl_UniCharAtIndex: index > 0} { test utf-8.5 {Tcl_UniCharAtIndex: high surrogate} { string index \ud842 0 } "\ud842" -test utf-8.5 {Tcl_UniCharAtIndex: low surrogate} { +test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} { string index \udc42 0 } "\udc42" @@ -192,7 +192,7 @@ test utf-10.5 {Tcl_UtfBackslash: stops after 4 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.6 {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 proc bsCheck {char num} { @@ -203,7 +203,7 @@ proc bsCheck {char num} { } $num incr errNum } -set errNum 6 +set errNum 8 bsCheck \b 8 bsCheck \e 101 bsCheck \f 12 -- cgit v0.12 From dadad672afce1ed05c7d18c54545400be87bcefc Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 16:56:55 +0000 Subject: test file hygiene --- tests/process.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/process.test b/tests/process.test index 4c4bc99..229d33c 100644 --- a/tests/process.test +++ b/tests/process.test @@ -332,6 +332,9 @@ test process-7.3 {child killed} -constraints {win} -body { tcl::process autopurge 1 } +removeFile $path(exit) +removeFile $path(sleep) + rename wait_for_file {} rename signal_exit {} ::tcltest::cleanupTests -- cgit v0.12 From 80d050ece42aa1defecb23381684d6dc2445fc41 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 17:45:55 +0000 Subject: Do not access allocated memory before initializing it. --- generic/tclLink.c | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/generic/tclLink.c b/generic/tclLink.c index 57735f8..8096c25 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -345,6 +345,17 @@ Tcl_LinkArray( } /* + * Initialize allocated space. + */ + + if (linkPtr->flags & LINK_ALLOC_ADDR) { + memset(linkPtr->addr, 0, linkPtr->bytes); + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memset(linkPtr->lastValue.aryPtr, 0, linkPtr->bytes); + } + + /* * Set common structure values. */ -- cgit v0.12 From 522f29c7ccb2ac30aa107ce07f227c73eab3f944 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Apr 2019 19:23:56 +0000 Subject: Replace memcpy() calls with memmove() to avoid undefined behavior when source and destination overlap. --- generic/tclUtf.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 53a0fec..86d1913 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1139,7 +1139,7 @@ Tcl_UtfToUpper( */ if ((len < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) { - memcpy(dst, src, len); + memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(upChar, dst); @@ -1201,7 +1201,7 @@ Tcl_UtfToLower( */ if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { - memcpy(dst, src, len); + memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(lowChar, dst); @@ -1260,7 +1260,7 @@ Tcl_UtfToTitle( titleChar = Tcl_UniCharToTitle(titleChar); if ((len < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) { - memcpy(dst, src, len); + memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(titleChar, dst); @@ -1283,7 +1283,7 @@ Tcl_UtfToTitle( } if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { - memcpy(dst, src, len); + memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(lowChar, dst); -- cgit v0.12 From 0cced28f38d76af84c8efcbc519cd5fac4924f2f Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 17 Apr 2019 19:59:13 +0000 Subject: extend performance test-suite, allow several (repeatable) execution of _test_run (if encosed in _test_start/_test_out_total) to produce same summary; provide possibility for measure of single iterators, etc. small code review --- tests-perf/test-performance.tcl | 78 ++++++++++++++++++++++++++++++++--------- 1 file changed, 62 insertions(+), 16 deletions(-) diff --git a/tests-perf/test-performance.tcl b/tests-perf/test-performance.tcl index 4629cd4..99a4e47 100644 --- a/tests-perf/test-performance.tcl +++ b/tests-perf/test-performance.tcl @@ -94,51 +94,97 @@ proc _test_out_total {} { puts [lindex $_(itm) $maxi] puts [string repeat ** 40] puts "" + unset -nocomplain _(itm) _(starttime) +} + +proc _test_start {reptime} { + upvar _ _ + array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 0] +} + +proc _test_iter {args} { + if {[llength $args] > 2} { + return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?level? measure-result\"" + } + set lvl 1 + if {[llength $args] > 1} { + set args [lassign $args lvl] + } + upvar $lvl _ _ + puts [set _(m) {*}$args] + lappend _(itm) $_(m) + puts "" +} + +proc _adjust_maxcount {reptime maxcount} { + if {[llength $reptime] > 1} { + lreplace $reptime 1 1 [expr {min($maxcount,[lindex $reptime 1])}] + } else { + lappend reptime $maxcount + } } proc _test_run {args} { upvar _ _ # parse args: - set _(out-result) 1 - if {[lindex $args 0] eq "-no-result"} { - set _(out-result) 0 + array set _ [set _opts {-no-result 0 -uplevel 0}] + while {[llength $args] > 2} { + if {[set o [lindex $args 0]] ni $_opts || $_($o)} { + break + } + set _($o) 1 set args [lrange $args 1 end] } + unset -nocomplain _opts o if {[llength $args] < 2 || [llength $args] > 3} { return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?-no-result? reptime lst ?outcmd?\"" } - set outcmd {puts $_(r)} + set _(outcmd) {puts} set args [lassign $args reptime lst] if {[llength $args]} { - set outcmd [lindex $args 0] + set _(outcmd) [lindex $args 0] } # avoid output if only once: if {[lindex $reptime 0] <= 1 || ([llength $reptime] > 1 && [lindex $reptime 1] == 1)} { - set _(out-result) 0 + set _(-no-result) 1 + } + if {![info exists _(itm)]} { + array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 1] + } else { + array set _ [list reptime $reptime] } - array set _ [list itm {} reptime $reptime starttime [clock milliseconds]] # process measurement: foreach _(c) [_test_get_commands $lst] { - puts "% [regsub -all {\n[ \t]*} $_(c) {; }]" + {*}$_(outcmd) "% [regsub -all {\n[ \t]*} $_(c) {; }]" if {[regexp {^\s*\#} $_(c)]} continue if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} { - puts [if 1 [lindex $_(c) 1]] + set _(c) [lindex $_(c) 1] + if {$_(-uplevel)} { + set _(c) [list uplevel 1 $_(c)] + } + {*}$_(outcmd) [if 1 $_(c)] continue } + if {$_(-uplevel)} { + set _(c) [list uplevel 1 $_(c)] + } + set _(ittime) $_(reptime) # if output result (and not once): - if {$_(out-result)} { + if {!$_(-no-result)} { set _(r) [if 1 $_(c)] - if {$outcmd ne {}} $outcmd - if {[llength $_(reptime)] > 1} { # decrement max-count - lset _(reptime) 1 [expr {[lindex $_(reptime) 1] - 1}] + if {$_(outcmd) ne {}} {{*}$_(outcmd) $_(r)} + if {[llength $_(ittime)] > 1} { # decrement max-count + lset _(ittime) 1 [expr {[lindex $_(ittime) 1] - 1}] } } - puts [set _(m) [timerate $_(c) {*}$_(reptime)]] + {*}$_(outcmd) [set _(m) [timerate $_(c) {*}$_(ittime)]] lappend _(itm) $_(m) - puts "" + {*}$_(outcmd) "" + } + if {$_(-from-run)} { + _test_out_total } - _test_out_total } }; # end of namespace ::tclTestPerf -- cgit v0.12 From 9cf9c0a5e5c1bc1e2cf81abce0c91a9acd632977 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 18 Apr 2019 08:31:11 +0000 Subject: Style corrections and warning elimination --- generic/tclBasic.c | 4 +- generic/tclCmdIL.c | 2 +- generic/tclCmdMZ.c | 14 +- generic/tclExecute.c | 2 +- generic/tclListObj.c | 2 +- generic/tclPkg.c | 318 ++++++++++++++++++++++++++++++-------------- generic/tclTest.c | 10 +- generic/tclTomMathStubLib.c | 4 +- 8 files changed, 239 insertions(+), 117 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e377951..84c87d0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4925,7 +4925,7 @@ TEOV_Error( int objc = PTR2INT(data[0]); Tcl_Obj **objv = data[1]; - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)){ + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { /* * If there was an error, a command string will be needed for the * error log: get it out of the itemPtr. The details depend on the @@ -5134,7 +5134,7 @@ TEOV_RunLeaveTraces( const char *command = TclGetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 441090c..dd7136c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4318,7 +4318,7 @@ Tcl_LsortObjCmd( elementArray = ckalloc(length * sizeof(SortElement)); - for (i=0; i < length; i++){ + for (i=0; i < length; i++) { idx = groupSize * i + groupOffset; if (indexc) { /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 7532de9..cb96cda 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2010,7 +2010,7 @@ StringMapCmd( */ if (!TclHasStringRep(objv[objc-2]) - && TclHasIntRep(objv[objc-2], &tclDictType)){ + && TclHasIntRep(objv[objc-2], &tclDictType)) { int i, done; Tcl_DictSearch search; @@ -2424,15 +2424,16 @@ StringRplcCmd( end = length - 1; if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ + TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { return TCL_ERROR; } /* - * The following test screens out most empty substrings as - * candidates for replacement. When they are detected, no - * replacement is done, and the result is the original string, + * The following test screens out most empty substrings as candidates for + * replacement. When they are detected, no replacement is done, and the + * result is the original 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 */ @@ -2442,6 +2443,7 @@ StringRplcCmd( * have (first <= end < 0 <= last) and an empty string is permitted * to be replaced. */ + Tcl_SetObjResult(interp, objv[1]); } else { Tcl_Obj *resultPtr; @@ -3623,7 +3625,7 @@ TclNRSwitchObjCmd( Tcl_Obj **listv; blist = objv[0]; - if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ + if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d5dc9e1..2415959 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8348,7 +8348,7 @@ ExecuteExtendedBinaryMathOp( * Reduce small powers of 2 to shifts. */ - if ((Tcl_WideUInt)w2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + if ((Tcl_WideUInt) w2 < CHAR_BIT * sizeof(Tcl_WideInt) - 1) { WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2)); } goto overflowExpon; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 0180920..ad64971 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1105,7 +1105,7 @@ Tcl_ListObjReplace( Tcl_Obj **oldPtrs = elemPtrs; int newMax; - if (needGrow){ + if (needGrow) { newMax = 2 * numRequired; } else { newMax = listRepPtr->maxElemCount; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 95524a7..ed5c57a 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -38,16 +38,18 @@ typedef struct PkgAvail { } PkgAvail; typedef struct PkgName { - struct PkgName *nextPtr; /* Next in list of package names being initialized. */ + struct PkgName *nextPtr; /* Next in list of package names being + * initialized. */ char name[1]; } PkgName; typedef struct PkgFiles { - PkgName *names; /* Package names being initialized. Must be first field*/ - Tcl_HashTable table; /* Table which contains files for each package */ + PkgName *names; /* Package names being initialized. Must be + * first field. */ + Tcl_HashTable table; /* Table which contains files for each + * package. */ } PkgFiles; - /* * For each package that is known in any way to an interpreter, there is one * record of the following type. These records are stored in the @@ -63,7 +65,7 @@ typedef struct Package { } Package; typedef struct Require { - void * clientDataPtr; + void *clientDataPtr; const char *name; Package *pkgPtr; char *versionToProvide; @@ -221,8 +223,10 @@ Tcl_PkgProvideEx( *---------------------------------------------------------------------- */ -static void PkgFilesCleanupProc(ClientData clientData, - Tcl_Interp *interp) +static void +PkgFilesCleanupProc( + ClientData clientData, + Tcl_Interp *interp) { PkgFiles *pkgFiles = (PkgFiles *) clientData; Tcl_HashSearch search; @@ -230,12 +234,14 @@ static void PkgFilesCleanupProc(ClientData clientData, while (pkgFiles->names) { PkgName *name = pkgFiles->names; + pkgFiles->names = name->nextPtr; ckfree(name); } entry = Tcl_FirstHashEntry(&pkgFiles->table, &search); while (entry) { Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry); + Tcl_DecrRefCount(obj); entry = Tcl_NextHashEntry(&search); } @@ -244,10 +250,16 @@ static void PkgFilesCleanupProc(ClientData clientData, return; } -void *TclInitPkgFiles(Tcl_Interp *interp) +void * +TclInitPkgFiles( + Tcl_Interp *interp) { - /* If assocdata "tclPkgFiles" doesn't exist yet, create it */ + /* + * If assocdata "tclPkgFiles" doesn't exist yet, create it. + */ + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (!pkgFiles) { pkgFiles = ckalloc(sizeof(PkgFiles)); pkgFiles->names = NULL; @@ -257,9 +269,14 @@ void *TclInitPkgFiles(Tcl_Interp *interp) return pkgFiles; } -void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName) +void +TclPkgFileSeen( + Tcl_Interp *interp, + const char *fileName) { - PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgFiles *pkgFiles = (PkgFiles *) + Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (pkgFiles && pkgFiles->names) { const char *name = pkgFiles->names->name; Tcl_HashTable *table = &pkgFiles->table; @@ -347,12 +364,12 @@ Tcl_PkgRequireEx( * * Second, how does this work? If we reach this point, then the global * variable tclEmptyStringRep has the value NULL. Compare that with - * the definition of tclEmptyStringRep near the top of this file. - * It clearly should not have the value NULL; it - * should point to the char tclEmptyString. If we see it having the - * value NULL, then somehow we are seeing a Tcl library that isn't - * completely initialized, and that's an indicator for the error - * condition described above. (Further explanation is welcome.) + * the definition of tclEmptyStringRep near the top of this file. It + * clearly should not have the value NULL; it should point to the char + * tclEmptyString. If we see it having the value NULL, then somehow we + * are seeing a Tcl library that isn't completely initialized, and + * that's an indicator for the error condition described above. + * (Further explanation is welcome.) * * Third, so what do we do about it? This situation indicates the * package we just loaded wasn't properly compiled to be stub-enabled, @@ -416,9 +433,11 @@ Tcl_PkgRequireProc( void *clientDataPtr) { RequireProcArgs args; + args.name = name; args.clientDataPtr = clientDataPtr; - return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv); + return Tcl_NRCallObjProc(interp, + TclNRPkgRequireProc, (void *) &args, reqc, reqv); } static int @@ -426,20 +445,28 @@ TclNRPkgRequireProc( ClientData clientData, Tcl_Interp *interp, int reqc, - Tcl_Obj *const reqv[]) { + Tcl_Obj *const reqv[]) +{ RequireProcArgs *args = clientData; - Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr); + + Tcl_NRAddCallback(interp, + PkgRequireCore, (void *) args->name, INT2PTR(reqc), (void *) reqv, + args->clientDataPtr); return TCL_OK; } static int -PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) +PkgRequireCore( + ClientData data[], + Tcl_Interp *interp, + int result) { const char *name = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj *const *reqv = data[2]; int code = CheckAllRequirements(interp, reqc, reqv); Require *reqPtr; + if (code != TCL_OK) { return code; } @@ -449,56 +476,86 @@ PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) reqPtr->name = name; reqPtr->pkgPtr = FindPackage(interp, name); if (reqPtr->pkgPtr->version == NULL) { - Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1); + Tcl_NRAddCallback(interp, + SelectPackage, reqPtr, INT2PTR(reqc), (void *) reqv, + PkgRequireCoreStep1); } else { - Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, + PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *) reqv,NULL); } return TCL_OK; } static int -PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreStep1( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Tcl_DString command; char *script; Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name /* Name of desired package. */; - if (reqPtr->pkgPtr->version == NULL) { - /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it. - */ - script = ((Interp *) interp)->packageUnknown; - if (script == NULL) { - Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - } else { - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); - - Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - Tcl_NREvalObj(interp, - Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), - TCL_EVAL_GLOBAL - ); - Tcl_DStringFree(&command); - } - return TCL_OK; - } else { - Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + /* + * If we've got the package in the DB already, go on to actually loading + * it. + */ + + if (reqPtr->pkgPtr->version != NULL) { + Tcl_NRAddCallback(interp, + PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + return TCL_OK; } + + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ + + script = ((Interp *) interp)->packageUnknown; + if (script == NULL) { + /* + * No package unknown script. Move on to finalizing. + */ + + Tcl_NRAddCallback(interp, + PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + return TCL_OK; + } + + /* + * Invoke the "package unknown" script synchronously. + */ + + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + Tcl_NRAddCallback(interp, + PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL); + Tcl_NREvalObj(interp, + Tcl_NewStringObj(Tcl_DStringValue(&command), + Tcl_DStringLength(&command)), + TCL_EVAL_GLOBAL); + Tcl_DStringFree(&command); return TCL_OK; } static int -PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreStep2( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; - const char *name = reqPtr->name /* Name of desired package. */; + const char *name = reqPtr->name; /* Name of desired package. */ + if ((result != TCL_OK) && (result != TCL_ERROR)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad return code: %d", result)); @@ -511,20 +568,31 @@ PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { return result; } Tcl_ResetResult(interp); - /* pkgPtr may now be invalid, so refresh it. */ + + /* + * pkgPtr may now be invalid, so refresh it. + */ + reqPtr->pkgPtr = FindPackage(interp, name); - Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal); + Tcl_NRAddCallback(interp, + SelectPackage, reqPtr, INT2PTR(reqc), (void *) reqv, + PkgRequireCoreFinal); return TCL_OK; } static int -PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreFinal( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]), satisfies; Tcl_Obj **const reqv = data[2]; char *pkgVersionI; void *clientDataPtr = reqPtr->clientDataPtr; - const char *name = reqPtr->name /* Name of desired package. */; + const char *name = reqPtr->name; /* Name of desired package. */ + if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); @@ -565,14 +633,21 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { } static int -PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreCleanup( + ClientData data[], + Tcl_Interp *interp, + int result) +{ ckfree(data[0]); return result; } - static int -SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { +SelectPackage( + ClientData data[], + Tcl_Interp *interp, + int result) +{ PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ @@ -600,10 +675,10 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { } /* - * The package isn't yet present. Search the list of available - * versions and invoke the script for the best available version. We - * are actually locating the best, and the best stable version. One of - * them is then chosen based on the selection mode. + * The package isn't yet present. Search the list of available versions + * and invoke the script for the best available version. We are actually + * locating the best, and the best stable version. One of them is then + * chosen based on the selection mode. */ bestPtr = NULL; @@ -616,15 +691,19 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { if (CheckVersionAndConvert(interp, availPtr->version, &availVersion, &availStable) != TCL_OK) { /* - * The provided version number has invalid syntax. This - * should not happen. This should have been caught by the - * 'package ifneeded' registering the package. + * The provided version number has invalid syntax. This should not + * happen. This should have been caught by the 'package ifneeded' + * registering the package. */ continue; } - /* Check satisfaction of requirements before considering the current version further. */ + /* + * Check satisfaction of requirements before considering the current + * version further. + */ + if (reqc > 0) { satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { @@ -646,13 +725,16 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { * The version of the package sought is better than the * currently selected version. */ + ckfree(bestVersion); bestVersion = NULL; goto newbest; } } else { newbest: - /* We have found a version which is better than our max. */ + /* + * We have found a version which is better than our max. + */ bestPtr = availPtr; CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); @@ -673,18 +755,24 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { if (res > 0) { /* - * This stable version of the package sought is better - * than the currently selected stable version. + * This stable version of the package sought is better than + * the currently selected stable version. */ + ckfree(bestStableVersion); bestStableVersion = NULL; goto newstable; } } else { newstable: - /* We have found a stable version which is better than our max stable. */ + /* + * We have found a stable version which is better than our max + * stable. + */ + bestStablePtr = availPtr; - CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); + CheckVersionAndConvert(interp, bestStablePtr->version, + &bestStableVersion, NULL); } ckfree(availVersion); @@ -706,9 +794,9 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { } /* - * Now choose a version among the two best. For 'latest' we simply - * take (actually keep) the best. For 'stable' we take the best - * stable, if there is any, or the best if there is nothing stable. + * Now choose a version among the two best. For 'latest' we simply take + * (actually keep) the best. For 'stable' we take the best stable, if + * there is any, or the best if there is nothing stable. */ if ((iPtr->packagePrefer == PKG_PREFER_STABLE) @@ -717,13 +805,14 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { } if (bestPtr == NULL) { - Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, + data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); } else { /* * We found an ifneeded script for the package. Be careful while * executing it: this could cause reentrancy, so (a) protect the - * script itself from deletion and (b) don't assume that bestPtr - * will still exist when the script completes. + * script itself from deletion and (b) don't assume that bestPtr will + * still exist when the script completes. */ char *versionToProvide = bestPtr->version; @@ -734,7 +823,11 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { pkgPtr->clientData = versionToProvide; pkgFiles = TclInitPkgFiles(interp); - /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ + + /* + * Push "ifneeded" package name in "tclPkgFiles" assocdata. + */ + pkgName = ckalloc(sizeof(PkgName) + strlen(name)); pkgName->nextPtr = pkgFiles->names; strcpy(pkgName->name, name); @@ -743,21 +836,31 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { TclPkgFileSeen(interp, bestPtr->pkgIndex); } reqPtr->versionToProvide = versionToProvide; - Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); - Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); + Tcl_NRAddCallback(interp, + SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, + data[3]); + Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), + TCL_EVAL_GLOBAL); } return TCL_OK; } static int -SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { +SelectPackageFinal( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name; char *versionToProvide = reqPtr->versionToProvide; - /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ + /* + * Pop the "ifneeded" package name from "tclPkgFiles" assocdata + */ + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); PkgName *pkgName = pkgFiles->names; pkgFiles->names = pkgName->nextPtr; @@ -822,14 +925,13 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { if (result != TCL_OK) { /* - * Take a non-TCL_OK code from the script as an indication the - * package wasn't loaded properly, so the package system - * should not remember an improper load. + * Take a non-TCL_OK code from the script as an indication the package + * wasn't loaded properly, so the package system should not remember + * an improper load. * - * This is consistent with our returning NULL. If we're not - * willing to tell our caller we got a particular version, we - * shouldn't store that version for telling future callers - * either. + * This is consistent with our returning NULL. If we're not willing to + * tell our caller we got a particular version, we shouldn't store + * that version for telling future callers either. */ if (reqPtr->pkgPtr->version != NULL) { @@ -840,7 +942,8 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { return result; } - Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, + data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL); return TCL_OK; } @@ -1006,7 +1109,8 @@ 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, Tcl_GetString(objv[2])); if (entry) { Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); } @@ -1015,7 +1119,8 @@ TclNRPackageObjCmd( } case PKG_FORGET: { const char *keyString; - PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgFiles *pkgFiles = (PkgFiles *) + Tcl_GetAssocData(interp, "tclPkgFiles", NULL); for (i = 2; i < objc; i++) { keyString = TclGetString(objv[i]); @@ -1088,7 +1193,7 @@ TclNRPackageObjCmd( res = CompareVersions(avi, argv3i, NULL); ckfree(avi); - if (res == 0){ + if (res == 0) { if (objc == 4) { ckfree(argv3i); Tcl_SetObjResult(interp, @@ -1256,12 +1361,16 @@ TclNRPackageObjCmd( Tcl_ListObjAppendElement(interp, objvListPtr, ov); Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL); - Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); + Tcl_NRAddCallback(interp, + TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); + Tcl_NRAddCallback(interp, + PkgRequireCore, (void *) argv3, INT2PTR(newobjc), + newObjvPtr, NULL); return TCL_OK; } else { int i, newobjc = objc-3; Tcl_Obj *const *newobjv = objv + 3; + if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } @@ -1269,17 +1378,20 @@ TclNRPackageObjCmd( Tcl_IncrRefCount(objvListPtr); Tcl_IncrRefCount(objv[2]); for (i = 0; i < newobjc; i++) { - /* * Tcl_Obj structures may have come from another interpreter, * so duplicate them. */ - Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); + Tcl_ListObjAppendElement(interp, objvListPtr, + Tcl_DuplicateObj(newobjv[i])); } Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL); - Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL); + Tcl_NRAddCallback(interp, + TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL); + Tcl_NRAddCallback(interp, + PkgRequireCore, (void *) argv2, INT2PTR(newobjc), + newObjvPtr, NULL); return TCL_OK; } break; @@ -1422,9 +1534,13 @@ TclNRPackageObjCmd( } static int -TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) { - TclDecrRefCount((Tcl_Obj *)data[0]); - TclDecrRefCount((Tcl_Obj *)data[1]); +TclNRPackageObjCmdCleanup( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + TclDecrRefCount((Tcl_Obj *) data[0]); + TclDecrRefCount((Tcl_Obj *) data[1]); return result; } diff --git a/generic/tclTest.c b/generic/tclTest.c index f075500..f301ebc 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3323,8 +3323,12 @@ TestlinkarrayCmd( TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, TCL_LINK_BINARY }; - int optionIndex, typeIndex, readonly, i, addr, size, length; + int optionIndex, typeIndex, readonly, i, size, length; char *name, *arg; + long addr; /* Wrong on Windows, but that's MS's fault for + * not supporting correctly. They + * can suffer the warnings; the rest of us + * shouldn't have to! */ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option args"); @@ -3382,7 +3386,7 @@ TestlinkarrayCmd( */ if (i < objc) { - if (Tcl_GetIntFromObj(interp, objv[i], &addr) == TCL_ERROR) { + if (Tcl_GetLongFromObj(interp, objv[i], &addr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "wrong address value", -1)); return TCL_ERROR; @@ -3390,7 +3394,7 @@ TestlinkarrayCmd( } else { addr = 0; } - return Tcl_LinkArray(interp, name, (char *) addr, + return Tcl_LinkArray(interp, name, (void *) addr, LinkTypes[typeIndex] | readonly, size); } return TCL_OK; diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c index 324f2a3..715904c 100644 --- a/generic/tclTomMathStubLib.c +++ b/generic/tclTomMathStubLib.c @@ -55,9 +55,9 @@ TclTomMathInitializeStubs( } if (stubsPtr == NULL) { errMsg = "missing stub table pointer"; - } else if(stubsPtr->tclBN_epoch() != epoch) { + } else if (stubsPtr->tclBN_epoch() != epoch) { errMsg = "epoch number mismatch"; - } else if(stubsPtr->tclBN_revision() != revision) { + } else if (stubsPtr->tclBN_revision() != revision) { errMsg = "requires a later revision"; } else { tclTomMathStubsPtr = stubsPtr; -- cgit v0.12 From 8b9a3558a42cba96fe30f272517260aef43ec7f8 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 18 Apr 2019 22:57:12 +0000 Subject: Compilation for [dict getwithdefault]. --- generic/tclAssembly.c | 10 ++++- generic/tclCompCmds.c | 32 +++++++++++++++ generic/tclCompile.c | 8 ++++ generic/tclCompile.h | 4 +- generic/tclDictObj.c | 13 +++--- generic/tclExecute.c | 108 ++++++++++++++++++++++++++++++++------------------ generic/tclInt.h | 3 ++ tests/dict.test | 49 +++++++++++++++++++++++ 8 files changed, 179 insertions(+), 48 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 5db2676..47f7100 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -145,6 +145,8 @@ typedef enum TalInstType { * 1 */ ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 * operands, produces 1, N > 0 */ + ASSEM_DICT_GET_DEF, /* 'dict getwithdefault' - consumes N+2 + * operands, produces 1, N > 0 */ ASSEM_DICT_SET, /* specifies key count and LVT index, consumes * N+1 operands, produces 1, N > 0 */ ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes @@ -362,6 +364,7 @@ static const TalInstDesc TalInstructionTable[] = { {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1}, {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, + {"dictGetDef", ASSEM_DICT_GET_DEF, INST_DICT_GET_DEF, INT_MIN,1}, {"dictIncrImm", ASSEM_SINT4_LVT4, INST_DICT_INCR_IMM, 1, 1}, {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, @@ -619,10 +622,14 @@ BBUpdateStackReqs( if (consumed == INT_MIN) { /* - * The instruction is variadic; it consumes 'count' operands. + * The instruction is variadic; it consumes 'count' operands, or + * 'count+1' for ASSEM_DICT_GET_DEF. */ consumed = count; + if (TalInstructionTable[tblIdx].instType == ASSEM_DICT_GET_DEF) { + consumed++; + } } if (produced < 0) { /* @@ -1396,6 +1403,7 @@ AssembleOneLine( break; case ASSEM_DICT_GET: + case ASSEM_DICT_GET_DEF: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c472b8c..4844dd8 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1177,6 +1177,38 @@ TclCompileDictGetCmd( } int +TclCompileDictGetWithDefaultCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int i; + DefineLineInformation; /* TIP #280 */ + + /* + * There must be at least three arguments after the command. + */ + + /* TODO: Consider support for compiling expanded args. */ + if (parsePtr->numWords < 4) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + + for (i=1 ; inumWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr); + TclAdjustStackDepth(-2, envPtr); + return TCL_OK; +} + +int TclCompileDictExistsCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c0e8c62..c53d3ad 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -659,6 +659,14 @@ InstructionDesc const tclInstructionTable[] = { * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds. * Stack: ... => ... time */ + {"dictGetDef", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* The top word is the default, the next op4 words (min 1) are a key + * path into the dictionary just below the keys on the stack, and all + * those values are replaced by the value read out of that key-path + * (like [dict get]) except if there is no such key, when instead the + * default is pushed instead. + * Stack: ... dict key1 ... keyN default => ... value */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cf11e0e..117fa46 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -840,8 +840,10 @@ typedef struct ByteCode { #define INST_CLOCK_READ 189 +#define INST_DICT_GET_DEF 190 + /* The last opcode */ -#define LAST_INST_OPCODE 189 +#define LAST_INST_OPCODE 190 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index fea4035..f3b0981 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -91,8 +91,9 @@ static const EnsembleImplMap implementationMap[] = { {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, - {"getdef", DictGetDefCmd, NULL, NULL, NULL, 0 }, - {"getwithdefault", DictGetDefCmd, NULL, NULL, NULL, 0 }, + {"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0}, + {"getwithdefault", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, + NULL, NULL, 0 }, {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, @@ -2085,11 +2086,9 @@ DictExistsCmd( return TCL_ERROR; } - dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2, - DICT_PATH_EXISTS); - if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT - || Tcl_DictObjGet(interp, dictPtr, objv[objc-1], - &valuePtr) != TCL_OK) { + dictPtr = TclTraceDictPath(NULL, objv[1], objc-3, objv+2,DICT_PATH_EXISTS); + if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT || + Tcl_DictObjGet(NULL, dictPtr, objv[objc-1], &valuePtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } else { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL)); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2415959..ed4fdd7 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6769,55 +6769,23 @@ TEBCresume( TRACE_APPEND(("OK\n")); NEXT_INST_F(1, 1, 0); - case INST_DICT_GET: case INST_DICT_EXISTS: { - register Tcl_Interp *interp2 = interp; register int found; opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = OBJ_AT_DEPTH(opnd); - if (*pc == INST_DICT_EXISTS) { - interp2 = NULL; - } if (opnd > 1) { - dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); - if (dictPtr == NULL) { - if (*pc == INST_DICT_EXISTS) { - found = 0; - goto afterDictExists; - } - TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%.30s\": ", - O2S(OBJ_AT_DEPTH(opnd))), - Tcl_GetObjResult(interp)); - goto gotError; + dictPtr = TclTraceDictPath(NULL, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd-1), DICT_PATH_EXISTS); + if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT) { + found = 0; + goto afterDictExists; } } - if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, + if (Tcl_DictObjGet(NULL, dictPtr, OBJ_AT_TOS, &objResultPtr) == TCL_OK) { - if (*pc == INST_DICT_EXISTS) { - found = (objResultPtr ? 1 : 0); - goto afterDictExists; - } - if (!objResultPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(OBJ_AT_TOS))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } else if (*pc != INST_DICT_EXISTS) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", - O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; + found = (objResultPtr ? 1 : 0); } else { found = 0; } @@ -6833,6 +6801,68 @@ TEBCresume( JUMP_PEEPHOLE_V(found, 5, opnd+1); } + case INST_DICT_GET: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + dictPtr = OBJ_AT_DEPTH(opnd); + if (opnd > 1) { + dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); + if (dictPtr == NULL) { + TRACE_WITH_OBJ(( + "ERROR tracing dictionary path into \"%.30s\": ", + O2S(OBJ_AT_DEPTH(opnd))), + Tcl_GetObjResult(interp)); + goto gotError; + } + } + if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, + &objResultPtr) != TCL_OK) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + if (!objResultPtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + case INST_DICT_GET_DEF: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + dictPtr = OBJ_AT_DEPTH(opnd+1); + if (opnd > 1) { + dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd), DICT_PATH_EXISTS); + if (dictPtr == NULL) { + TRACE_WITH_OBJ(( + "ERROR tracing dictionary path into \"%.30s\": ", + O2S(OBJ_AT_DEPTH(opnd+1))), + Tcl_GetObjResult(interp)); + goto gotError; + } else if (dictPtr == DICT_PATH_NON_EXISTENT) { + goto dictGetDefUseDefault; + } + } + if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, + &objResultPtr) != TCL_OK) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } else if (!objResultPtr) { + dictGetDefUseDefault: + objResultPtr = OBJ_AT_TOS; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+2, 1); case INST_DICT_SET: case INST_DICT_UNSET: diff --git a/generic/tclInt.h b/generic/tclInt.h index 772ff26..3db1264 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3648,6 +3648,9 @@ MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictGetWithDefaultCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/tests/dict.test b/tests/dict.test index 6d74b96..62590e7 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -2048,6 +2048,7 @@ test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} }} } {} +set dict dict; # Used to force interpretation, not compilation test dict-26.1 {dict getdef command} -body { dict getdef {a b} a c } -result b @@ -2075,6 +2076,30 @@ test dict-26.8 {dict getdef command} -returnCodes error -body { test dict-26.9 {dict getdef command} -returnCodes error -body { dict getdef {} {} } -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} +test dict-26.10 {dict getdef command} -returnCodes error -body { + dict getdef {a b c} d e +} -result {missing value to go with key} +test dict-26.11 {dict getdef command} -body { + $dict getdef {a b} a c +} -result b +test dict-26.12 {dict getdef command} -body { + $dict getdef {a b} b c +} -result c +test dict-26.13 {dict getdef command} -body { + $dict getdef {a {b c}} a b d +} -result c +test dict-26.14 {dict getdef command} -body { + $dict getdef {a {b c}} a c d +} -result d +test dict-26.15 {dict getdef command} -body { + $dict getdef {a {b c}} b c d +} -result d +test dict-26.16 {dict getdef command} -returnCodes error -body { + $dict getdef {a {b c d}} a b d +} -result {missing value to go with key} +test dict-26.17 {dict getdef command} -returnCodes error -body { + $dict getdef {a b c} d e +} -result {missing value to go with key} test dict-27.1 {dict getwithdefault command} -body { dict getwithdefault {a b} a c @@ -2103,6 +2128,30 @@ test dict-27.8 {dict getwithdefault command} -returnCodes error -body { test dict-27.9 {dict getwithdefault command} -returnCodes error -body { dict getwithdefault {} {} } -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} +test dict-26.10 {dict getdef command} -returnCodes error -body { + dict getwithdefault {a b c} d e +} -result {missing value to go with key} +test dict-27.11 {dict getwithdefault command} -body { + $dict getwithdefault {a b} a c +} -result b +test dict-27.12 {dict getwithdefault command} -body { + $dict getwithdefault {a b} b c +} -result c +test dict-27.13 {dict getwithdefault command} -body { + $dict getwithdefault {a {b c}} a b d +} -result c +test dict-27.14 {dict getwithdefault command} -body { + $dict getwithdefault {a {b c}} a c d +} -result d +test dict-27.15 {dict getwithdefault command} -body { + $dict getwithdefault {a {b c}} b c d +} -result d +test dict-27.16 {dict getwithdefault command} -returnCodes error -body { + $dict getwithdefault {a {b c d}} a b d +} -result {missing value to go with key} +test dict-26.17 {dict getdef command} -returnCodes error -body { + $dict getwithdefault {a b c} d e +} -result {missing value to go with key} # cleanup ::tcltest::cleanupTests -- cgit v0.12 From e85c55bb57371a522421c9d7e1c1a76e3bbea8b9 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 22 Apr 2019 14:09:48 +0000 Subject: [zipfs mount_data] should not accept three arguments. --- generic/tclZipfs.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index a80968c..ec38c48 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -1911,7 +1911,7 @@ ZipFSMountBufferObjCmd( unsigned char *data; int length; - if (objc > 4) { + if (objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?"); return TCL_ERROR; } -- cgit v0.12 From e240d7269b3b361572433bfb7a49a78eb14f2ac8 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 22 Apr 2019 14:56:31 +0000 Subject: Prevent reads of uninitalized memory. --- generic/tclZipfs.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index ec38c48..b5cf69f 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -1768,6 +1768,7 @@ TclZipfs_MountBuffer( zf->data = data; zf->ptrToFree = NULL; } + zf->passBuf[0] = 0; /* stop valgrind cries */ if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) { return TCL_ERROR; } -- cgit v0.12 From 0f9539f83840432a6d510b8c8afe52e24a11e6b4 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 22 Apr 2019 15:15:47 +0000 Subject: Stop leaking ZipFile in MountBuffer() --- generic/tclZipfs.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index b5cf69f..c3887f0 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -1711,6 +1711,7 @@ TclZipfs_MountBuffer( int copy) { ZipFile *zf; + int result; ReadLock(); if (!ZipFS.initialized) { @@ -1772,8 +1773,10 @@ TclZipfs_MountBuffer( if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) { return TCL_ERROR; } - return ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL, + result = ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL, "Memory Buffer"); + ckfree(zf); + return result; } /* -- cgit v0.12 From 1e9a4512c736103a6d392290d210f2ace698787a Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 23 Apr 2019 06:28:28 +0000 Subject: timerate: code style, doc style --- doc/timerate.n | 111 ++++++++------ generic/tclCmdMZ.c | 443 +++++++++++++++++++++++++++++++++++------------------ 2 files changed, 356 insertions(+), 198 deletions(-) diff --git a/doc/timerate.n b/doc/timerate.n index 3c764c8..636d9de 100644 --- a/doc/timerate.n +++ b/doc/timerate.n @@ -9,16 +9,26 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -timerate \- Time-related execution resp. performance measurement of a script +timerate \- Calibrated performance measurements of script execution time .SH SYNOPSIS -\fBtimerate \fIscript\fR \fI?time ?max-count??\fR +\fBtimerate \fIscript\fR ?\fItime\fR? ?\fImax-count\fR? .sp -\fBtimerate \fI?-direct?\fR \fI?-overhead double?\fR \fIscript\fR \fI?time ?max-count??\fR +\fBtimerate \fR?\fB\-direct\fR? ?\fB\-overhead\fI double\fR? \fIscript\fR ?\fItime\fR? ?\fImax-count\fR? .sp -\fBtimerate \fI?-calibrate?\fR \fI?-direct?\fR \fIscript\fR \fI?time ?max-count??\fR +\fBtimerate \fR?\fB\-calibrate\fR? ?\fB\-direct\fR? \fIscript\fR ?\fItime\fR? ?\fImax-count\fR? .BE .SH DESCRIPTION .PP +The \fBtimerate\fR command does calibrated performance measurement of a Tcl +command or script, \fIscript\fR. The \fIscript\fR should be written so that it +can be executed multiple times during the performance measurement process. +Time is measured in elapsed time using the finest timer resolution as possible, +not CPU time; if \fIscript\fR interacts with the OS, the cost of that +interaction is included. +This command may be used to provide information as to how well a script or +Tcl command is performing, and can help determine bottlenecks and fine-tune +application performance. +.PP 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. @@ -28,47 +38,48 @@ by the maximal number of iterations to evaluate the script. If \fImax-count\fR is specified, the evalution will stop either this count of iterations is reached or the time is exceeded. .sp -It will then return a canonical tcl-list of the form +It will then return a canonical tcl-list of the form: .PP .CS \fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 nett-ms\fR .CE .PP which indicates: -.IP \(bu +.IP \(bu 3 the average amount of time required per iteration, in microseconds ([\fBlindex\fR $result 0]) -.IP \(bu +.IP \(bu 3 the count how many times it was executed ([\fBlindex\fR $result 2]) -.IP \(bu +.IP \(bu 3 the estimated rate per second ([\fBlindex\fR $result 4]) -.IP \(bu +.IP \(bu 3 the estimated real execution time without measurement overhead ([\fBlindex\fR $result 6]) .PP -Time is measured in elapsed time using the finest timer resolution as possible, -not CPU time. -This command may be used to provide information as to how well the script or a -tcl-command is performing and can help determine bottlenecks and fine-tune -application performance. +The following options may be supplied to the \fBtimerate\fR command: .TP -\fI-calibrate\fR +\fB\-calibrate\fR . -To measure very fast scripts as exact as posible the calibration process +To measure very fast scripts as exactly as possible, a calibration process may be required. - -The \fI-calibrate\fR option is used to calibrate timerate, calculating the -estimated overhead of the given script as the default overhead 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. +The \fB\-calibrate\fR option is used to calibrate \fBtimerate\fR itself, +calculating the estimated overhead of the given script as the default overhead +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. +.RE .TP -\fI-overhead double\fR +\fB\-overhead \fIdouble\fR . -The \fI-overhead\fR parameter supplies an estimate (in microseconds) of the +The \fB\-overhead\fR parameter supplies an estimate (in microseconds) of the measurement overhead of each iteration of the tested script. This quantity -will be subtracted from the measured time prior to reporting results. +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. .TP -\fI-direct\fR +\fB\-direct\fR . -The \fI-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. @@ -76,31 +87,33 @@ lists, and of the uncompiled versions of bytecoded commands. As opposed to the \fBtime\fR commmand, which runs the tested script for a fixed number of iterations, the timerate 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 \fI-direct\fR +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 EXAMPLE +.SH EXAMPLES Estimate how fast it takes for a simple Tcl \fBfor\fR loop (including -operations on variable \fIi\fR) to count to a ten: +operations on variable \fIi\fR) to count to ten: .PP .CS -# calibrate: -timerate -calibrate {} -# measure: -timerate { for {set i 0} {$i<10} {incr i} {} } 5000 +\fI# calibrate\fR +\fBtimerate\fR -calibrate {} + +\fI# measure\fR +\fBtimerate\fR { for {set i 0} {$i<10} {incr i} {} } 5000 .CE .PP Estimate how fast it takes for a simple Tcl \fBfor\fR loop, ignoring the -overhead for to perform ten iterations, ignoring the overhead of the management -of the variable that controls the loop: +overhead of the management of the variable that controls the loop: .PP .CS -# calibrate for overhead of variable operations: -set i 0; timerate -calibrate {expr {$i<10}; incr i} 1000 -# measure: -timerate { for {set i 0} {$i<10} {incr i} {} } 5000 +\fI# calibrate for overhead of variable operations\fR +set i 0; \fBtimerate\fR -calibrate {expr {$i<10}; incr i} 1000 + +\fI# measure\fR +\fBtimerate\fR { + for {set i 0} {$i<10} {incr i} {} +} 5000 .CE .PP Estimate the speed of calculating the hour of the day using \fBclock format\fR only, @@ -108,14 +121,18 @@ ignoring overhead of the portion of the script that prepares the time for it to calculate: .PP .CS -# calibrate: -timerate -calibrate {} -# estimate overhead: +\fI# calibrate\fR +\fBtimerate\fR -calibrate {} + +\fI# estimate overhead\fR set tm 0 -set ovh [lindex [timerate { incr tm [expr {24*60*60}] }] 0] -# measure using esimated overhead: +set ovh [lindex [\fBtimerate\fR { + incr tm [expr {24*60*60}] +}] 0] + +\fI# measure using estimated overhead\fR set tm 0 -timerate -overhead $ovh { +\fBtimerate\fR -overhead $ovh { clock format $tm -format %H incr tm [expr {24*60*60}]; # overhead for this is ignored } 5000 @@ -123,7 +140,7 @@ timerate -overhead $ovh { .SH "SEE ALSO" time(n) .SH KEYWORDS -script, timerate, time +performance measurement, script, time .\" Local Variables: .\" mode: nroff .\" End: diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 0cad34f..fe5e51c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3956,12 +3956,13 @@ Tcl_TimeObjCmd( * Tcl_TimeRateObjCmd -- * * This object-based procedure is invoked to process the "timerate" Tcl - * command. - * This is similar to command "time", except the execution limited by + * command. + * + * This is similar to command "time", except the execution limited by * given time (in milliseconds) instead of repetition count. * * Example: - * timerate {after 5} 1000 ; # equivalent for `time {after 5} [expr 1000/5]` + * timerate {after 5} 1000; # equivalent to: time {after 5} [expr 1000/5] * * Results: * A standard Tcl object result. @@ -3979,39 +3980,39 @@ Tcl_TimeRateObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static - double measureOverhead = 0; /* global measure-overhead */ + static double measureOverhead = 0; + /* global measure-overhead */ double overhead = -1; /* given measure-overhead */ register Tcl_Obj *objPtr; register int result, i; Tcl_Obj *calibrate = NULL, *direct = NULL; Tcl_WideUInt count = 0; /* Holds repetition count */ - Tcl_WideInt maxms = WIDE_MIN; + Tcl_WideInt maxms = WIDE_MIN; /* Maximal running time (in milliseconds) */ Tcl_WideUInt maxcnt = WIDE_MAX; /* Maximal count of iterations. */ Tcl_WideUInt threshold = 1; /* Current threshold for check time (faster * repeat count without time check) */ - Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max threshold - * additionally avoid divide to zero (never < 1) */ + Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max + * threshold, additionally avoiding divide to + * zero (i.e., never < 1) */ unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid * growth of execution time. */ register Tcl_WideInt start, middle, stop; #ifndef TCL_WIDE_CLICKS Tcl_Time now; -#endif - +#endif /* !TCL_WIDE_CLICKS */ static const char *const options[] = { "-direct", "-overhead", "-calibrate", "--", NULL }; enum options { TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST }; - - ByteCode *codePtr = NULL; + ByteCode *codePtr = NULL; for (i = 1; i < objc - 1; i++) { - int index; + int index; + if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT, &index) != TCL_OK) { break; @@ -4038,9 +4039,11 @@ Tcl_TimeRateObjCmd( } } - if (i >= objc || i < objc-3) { -usage: - Tcl_WrongNumArgs(interp, 1, objv, "?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"); + if (i >= objc || i < objc - 3) { + usage: + Tcl_WrongNumArgs(interp, 1, objv, + "?-direct? ?-calibrate? ?-overhead double? " + "command ?time ?max-count??"); return TCL_ERROR; } objPtr = objv[i++]; @@ -4051,6 +4054,7 @@ usage: } if (i < objc) { /* max-count*/ Tcl_WideInt v; + result = Tcl_GetWideIntFromObj(interp, objv[i], &v); if (result != TCL_OK) { return result; @@ -4059,30 +4063,41 @@ usage: } } - /* if calibrate */ + /* + * If we are doing calibration. + */ + if (calibrate) { + /* + * If no time specified for the calibration. + */ - /* if no time specified for the calibration */ if (maxms == WIDE_MIN) { Tcl_Obj *clobjv[6]; Tcl_WideInt maxCalTime = 5000; double lastMeasureOverhead = measureOverhead; - - clobjv[0] = objv[0]; + + clobjv[0] = objv[0]; i = 1; if (direct) { - clobjv[i++] = direct; + clobjv[i++] = direct; } - clobjv[i++] = objPtr; + clobjv[i++] = objPtr; + + /* + * Reset last measurement overhead. + */ - /* reset last measurement overhead */ - measureOverhead = (double)0; + measureOverhead = (double) 0; + + /* + * Self-call with 100 milliseconds to warm-up, before entering the + * calibration cycle. + */ - /* self-call with 100 milliseconds to warm-up, - * before entering the calibration cycle */ TclNewLongObj(clobjv[i], 100); Tcl_IncrRefCount(clobjv[i]); - result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv); + result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); Tcl_DecrRefCount(clobjv[i]); if (result != TCL_OK) { return result; @@ -4090,61 +4105,88 @@ usage: i--; clobjv[i++] = calibrate; - clobjv[i++] = objPtr; + clobjv[i++] = objPtr; - /* set last measurement overhead to max */ - measureOverhead = (double)UWIDE_MAX; + /* + * Set last measurement overhead to max. + */ + + measureOverhead = (double) UWIDE_MAX; + + /* + * Run the calibration cycle until it is more precise. + */ - /* calibration cycle until it'll be preciser */ maxms = -1000; do { lastMeasureOverhead = measureOverhead; - TclNewLongObj(clobjv[i], (int)maxms); + TclNewLongObj(clobjv[i], (int) maxms); Tcl_IncrRefCount(clobjv[i]); - result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv); + result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); Tcl_DecrRefCount(clobjv[i]); if (result != TCL_OK) { return result; } maxCalTime += maxms; - /* increase maxms for preciser calibration */ - maxms -= (-maxms / 4); - /* as long as new value more as 0.05% better */ - } while ( (measureOverhead >= lastMeasureOverhead + + /* + * Increase maxms for more precise calibration. + */ + + maxms -= -maxms / 4; + + /* + * As long as new value more as 0.05% better + */ + } while ((measureOverhead >= lastMeasureOverhead || measureOverhead / lastMeasureOverhead <= 0.9995) - && maxCalTime > 0 - ); + && maxCalTime > 0); return result; } if (maxms == 0) { - /* reset last measurement overhead */ + /* + * Reset last measurement overhead + */ + measureOverhead = 0; Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); return TCL_OK; } - /* if time is negative - make current overhead more precise */ + /* + * If time is negative, make current overhead more precise. + */ + if (maxms > 0) { - /* set last measurement overhead to max */ - measureOverhead = (double)UWIDE_MAX; + /* + * Set last measurement overhead to max. + */ + + measureOverhead = (double) UWIDE_MAX; } else { maxms = -maxms; } - } if (maxms == WIDE_MIN) { - maxms = 1000; + maxms = 1000; } if (overhead == -1) { overhead = measureOverhead; } - /* be sure that resetting of result will not smudge the further measurement */ + /* + * Ensure that resetting of result will not smudge the further + * measurement. + */ + Tcl_ResetResult(interp); - /* compile object */ + /* + * Compile object if needed. + */ + if (!direct) { if (TclInterpReady(interp) != TCL_OK) { return TCL_ERROR; @@ -4153,117 +4195,196 @@ usage: TclPreserveByteCode(codePtr); } - /* get start and stop time */ + /* + * Get start and stop time. + */ + #ifdef TCL_WIDE_CLICKS start = middle = TclpGetWideClicks(); - /* time to stop execution (in wide clicks) */ + + /* + * Time to stop execution (in wide clicks). + */ + stop = start + (maxms * 1000 / TclpWideClickInMicrosec()); #else Tcl_GetTime(&now); - start = now.sec; start *= 1000000; start += now.usec; + start = now.sec; + start *= 1000000; + start += now.usec; middle = start; - /* time to stop execution (in microsecs) */ + + /* + * Time to stop execution (in microsecs). + */ + stop = start + maxms * 1000; -#endif +#endif /* TCL_WIDE_CLICKS */ - /* start measurement */ - if (maxcnt > 0) - while (1) { - /* eval single iteration */ - count++; + /* + * Start measurement. + */ - if (!direct) { - /* precompiled */ - result = TclExecuteByteCode(interp, codePtr); - } else { - /* eval */ - result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); - } - if (result != TCL_OK) { - /* allow break from measurement cycle (used for conditional stop) */ - if (result != TCL_BREAK) { - goto done; + if (maxcnt > 0) { + while (1) { + /* + * Evaluate a single iteration. + */ + + count++; + if (!direct) { /* precompiled */ + result = TclExecuteByteCode(interp, codePtr); + } else { /* eval */ + result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); } - /* force stop immediately */ - threshold = 1; - maxcnt = 0; - result = TCL_OK; - } - - /* don't check time up to threshold */ - if (--threshold > 0) continue; - - /* check stop time reached, estimate new threshold */ - #ifdef TCL_WIDE_CLICKS - middle = TclpGetWideClicks(); - #else - Tcl_GetTime(&now); - middle = now.sec; middle *= 1000000; middle += now.usec; - #endif - if (middle >= stop || count >= maxcnt) { - break; - } + if (result != TCL_OK) { + /* + * Allow break from measurement cycle (used for conditional + * stop). + */ - /* don't calculate threshold by few iterations, because sometimes first - * iteration(s) can be too fast or slow (cached, delayed clean up, etc) */ - if (count < 10) { - threshold = 1; continue; - } + if (result != TCL_BREAK) { + goto done; + } - /* average iteration time in microsecs */ - threshold = (middle - start) / count; - if (threshold > maxIterTm) { - maxIterTm = threshold; - /* interations seems to be longer */ - if (threshold > (maxIterTm * 2)) { - if ((factor *= 2) > 50) factor = 50; - } else { - if (factor < 50) factor++; + /* + * Force stop immediately. + */ + + threshold = 1; + maxcnt = 0; + result = TCL_OK; } - } else if (factor > 4) { - /* interations seems to be shorter */ - if (threshold < (maxIterTm / 2)) { - if ((factor /= 2) < 4) factor = 4; - } else { - factor--; + + /* + * Don't check time up to threshold. + */ + + if (--threshold > 0) { + continue; + } + + /* + * Check stop time reached, estimate new threshold. + */ + +#ifdef TCL_WIDE_CLICKS + middle = TclpGetWideClicks(); +#else + Tcl_GetTime(&now); + middle = now.sec; + middle *= 1000000; + middle += now.usec; +#endif /* TCL_WIDE_CLICKS */ + + if (middle >= stop || count >= maxcnt) { + break; + } + + /* + * Don't calculate threshold by few iterations, because sometimes + * first iteration(s) can be too fast or slow (cached, delayed + * clean up, etc). + */ + + if (count < 10) { + threshold = 1; + continue; + } + + /* + * Average iteration time in microsecs. + */ + + threshold = (middle - start) / count; + if (threshold > maxIterTm) { + maxIterTm = threshold; + /* + * Iterations seem to be longer. + */ + if (threshold > maxIterTm * 2) { + factor *= 2; + if (factor > 50) { + factor = 50; + } + } else { + if (factor < 50) { + factor++; + } + } + } else if (factor > 4) { + /* + * Iterations seem to be shorter. + */ + + if (threshold < (maxIterTm / 2)) { + factor /= 2; + if (factor < 4) { + factor = 4; + } + } else { + factor--; + } + } + + /* + * As relation between remaining time and time since last check, + * maximal some % of time (by factor), so avoid growing of the + * execution time if iterations are not consistent, e.g. was + * continuously on time). + */ + + threshold = ((stop - middle) / maxIterTm) / factor + 1; + if (threshold > 100000) { /* fix for too large threshold */ + threshold = 100000; + } + + /* + * Consider max-count + */ + + if (threshold > maxcnt - count) { + threshold = maxcnt - count; } - } - /* as relation between remaining time and time since last check, - * maximal some % of time (by factor), so avoid growing of the execution time - * if iterations are not consistent, e. g. wax continuously on time) */ - threshold = ((stop - middle) / maxIterTm) / factor + 1; - if (threshold > 100000) { /* fix for too large threshold */ - threshold = 100000; - } - /* consider max-count */ - if (threshold > maxcnt - count) { - threshold = maxcnt - count; } } { Tcl_Obj *objarr[8], **objs = objarr; Tcl_WideInt val; - const char *fmt; + int digits; - middle -= start; /* execution time in microsecs */ + middle -= start; /* execution time in microsecs */ + +#ifdef TCL_WIDE_CLICKS + /* + * convert execution time in wide clicks to microsecs. + */ - #ifdef TCL_WIDE_CLICKS - /* convert execution time in wide clicks to microsecs */ middle *= TclpWideClickInMicrosec(); - #endif +#endif /* TCL_WIDE_CLICKS */ - if (!count) { /* no iterations - avoid divide by zero */ + if (!count) { /* no iterations - avoid divide by zero */ objs[0] = objs[2] = objs[4] = Tcl_NewWideIntObj(0); goto retRes; } - /* if not calibrate */ + /* + * If not calibrating... + */ + if (!calibrate) { - /* minimize influence of measurement overhead */ + /* + * Minimize influence of measurement overhead. + */ + if (overhead > 0) { - /* estimate the time of overhead (microsecs) */ + /* + * Estimate the time of overhead (microsecs). + */ + Tcl_WideUInt curOverhead = overhead * count; + if (middle > curOverhead) { middle -= curOverhead; } else { @@ -4271,38 +4392,57 @@ usage: } } } else { - /* calibration - obtaining new measurement overhead */ - if (measureOverhead > (double)middle / count) { - measureOverhead = (double)middle / count; + /* + * Calibration: obtaining new measurement overhead. + */ + + if (measureOverhead > ((double) middle) / count) { + measureOverhead = ((double) middle) / count; } objs[0] = Tcl_NewDoubleObj(measureOverhead); TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */ objs += 2; } - val = middle / count; /* microsecs per iteration */ + val = middle / count; /* microsecs per iteration */ if (val >= 1000000) { objs[0] = Tcl_NewWideIntObj(val); } else { - if (val < 10) { fmt = "%.6f"; } else - if (val < 100) { fmt = "%.4f"; } else - if (val < 1000) { fmt = "%.3f"; } else - if (val < 10000) { fmt = "%.2f"; } else - { fmt = "%.1f"; }; - objs[0] = Tcl_ObjPrintf(fmt, ((double)middle)/count); + if (val < 10) { + digits = 6; + } else if (val < 100) { + digits = 4; + } else if (val < 1000) { + digits = 3; + } else if (val < 10000) { + digits = 2; + } else { + digits = 1; + } + objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) middle)/count); } objs[2] = Tcl_NewWideIntObj(count); /* iterations */ - - /* calculate speed as rate (count) per sec */ - if (!middle) middle++; /* +1 ms, just to avoid divide by zero */ + + /* + * Calculate speed as rate (count) per sec + */ + + if (!middle) { + middle++; /* Avoid divide by zero. */ + } if (count < (WIDE_MAX / 1000000)) { val = (count * 1000000) / middle; if (val < 100000) { - if (val < 100) { fmt = "%.3f"; } else - if (val < 1000) { fmt = "%.2f"; } else - { fmt = "%.1f"; }; - objs[4] = Tcl_ObjPrintf(fmt, ((double)(count * 1000000)) / middle); + if (val < 100) { + digits = 3; + } else if (val < 1000) { + digits = 2; + } else { + digits = 1; + } + objs[4] = Tcl_ObjPrintf("%.*f", + digits, ((double) (count * 1000000)) / middle); } else { objs[4] = Tcl_NewWideIntObj(val); } @@ -4311,7 +4451,10 @@ usage: } retRes: - /* estimated net execution time (in millisecs) */ + /* + * Estimated net execution time (in millisecs). + */ + if (!calibrate) { if (middle >= 1) { objs[6] = Tcl_ObjPrintf("%.3f", (double)middle / 1000); @@ -4322,9 +4465,9 @@ usage: } /* - * Construct the result as a list because many programs have always parsed - * as such (extracting the first element, typically). - */ + * Construct the result as a list because many programs have always + * parsed as such (extracting the first element, typically). + */ TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#"); /* mics/# */ TclNewLiteralStringObj(objs[3], "#"); @@ -4332,12 +4475,10 @@ usage: Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr)); } -done: - + done: if (codePtr != NULL) { TclReleaseByteCode(codePtr); } - return result; } -- cgit v0.12 From 70d68cb355c39d317d984605a623b9d242d0fdc7 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Tue, 23 Apr 2019 11:29:16 +0000 Subject: Fix for [67a5eabbd3d1], refchan, coroutine, and postevent from the "watch" proc. --- generic/tclIORChan.c | 56 ++++++++++++++++++++++++++++++++++++++++++++++------ tests/ioCmd.test | 53 +++++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 95 insertions(+), 14 deletions(-) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index be82b48..8a7a16a 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -54,6 +54,8 @@ static int ReflectGetOption(ClientData clientData, static int ReflectSetOption(ClientData clientData, Tcl_Interp *interp, const char *optionName, const char *newValue); +static void TimerRunRead(ClientData clientData); +static void TimerRunWrite(ClientData clientData); /* * The C layer channel type/driver definition used by the reflection. This is @@ -112,6 +114,17 @@ typedef struct { int dead; /* Boolean signal that some operations * should no longer be attempted. */ + Tcl_TimerToken readTimer; /* + A token for the timer that is scheduled in + order to call Tcl_NotifyChannel when the + channel is readable + */ + Tcl_TimerToken writeTimer; /* + A token for the timer that is scheduled in + order to call Tcl_NotifyChannel when the + channel is writable + */ + /* * Note regarding the usage of timers. * @@ -121,11 +134,9 @@ typedef struct { * * See 'rechan', 'memchan', etc. * - * Here this is _not_ required. Interest in events is posted to the Tcl - * level via 'watch'. And posting of events is possible from the Tcl level - * as well, via 'chan postevent'. This means that the generation of all - * events, fake or not, timer based or not, is completely in the hands of - * the Tcl level. Therefore no timer here. + * A timer is used here as well in order to ensure at least on pass through + * the event loop when a channel becomes ready. See issues 67a5eabbd3d1 and + * ef28eb1f1516. */ } ReflectedChannel; @@ -920,7 +931,14 @@ TclChanPostEventObjCmd( #if TCL_THREADS if (rcPtr->owner == rcPtr->thread) { #endif - Tcl_NotifyChannel(chan, events); + if (events & TCL_READABLE) { + rcPtr->readTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + TimerRunRead, rcPtr); + } + if (events & TCL_WRITABLE) { + rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + TimerRunWrite, rcPtr); + } #if TCL_THREADS } else { ReflectEvent *ev = ckalloc(sizeof(ReflectEvent)); @@ -968,6 +986,24 @@ TclChanPostEventObjCmd( #undef EVENT } +static void +TimerRunRead( + ClientData clientData) +{ + ReflectedChannel *rcPtr = clientData; + rcPtr->readTimer = 0; + Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE); +} + +static void +TimerRunWrite( + ClientData clientData) +{ + ReflectedChannel *rcPtr = clientData; + rcPtr->writeTimer = 0; + Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE); +} + /* * Channel error message marshalling utilities. */ @@ -1161,6 +1197,12 @@ ReflectClose( ckfree(tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } + if (rcPtr->readTimer != NULL) { + Tcl_DeleteTimerHandler(rcPtr->readTimer); + } + if (rcPtr->writeTimer != NULL) { + Tcl_DeleteTimerHandler(rcPtr->writeTimer); + } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -2131,6 +2173,8 @@ NewReflectedChannel( rcPtr->chan = NULL; rcPtr->interp = interp; rcPtr->dead = 0; + rcPtr->readTimer = 0; + rcPtr->writeTimer = 0; #if TCL_THREADS rcPtr->thread = Tcl_GetCurrentThread(); #endif diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 9c93102..b15be21 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -930,6 +930,17 @@ proc onfinal {} { if {[lindex $hargs 0] ne "finalize"} {return} return -code return "" } + +proc onwatch {} { + upvar args hargs + lassign $hargs watch chan eventspec + if {$watch ne "watch"} return + foreach spec $eventspec { + chan postevent $chan $spec + } + return +} + } # Set everything up in the main thread. @@ -2002,28 +2013,29 @@ test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c readable {note TOCK}] - set stop [after 10000 {note TIMEOUT}] + set tock {} + note [fileevent $c readable {lappend res TOCK; set tock 1}] + set stop [after 10000 {lappend res TIMEOUT; set tock 1}] after 1000 {note [chan postevent $c r]} - vwait ::res + vwait ::tock catch {after cancel $stop} close $c rename foo {} set res -} -result {{watch rc* read} {} TOCK {} {watch rc* {}}} +} -result {{watch rc* read} {} {} TOCK {watch rc* {}}} test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c writable {note TOCK}] - set stop [after 10000 {note TIMEOUT}] + note [fileevent $c writable {lappend res TOCK; set tock 1}] + set stop [after 10000 {lappend res TIMEOUT; set tock 1}] after 1000 {note [chan postevent $c w]} - vwait ::res + vwait ::tock catch {after cancel $stop} close $c rename foo {} set res -} -result {{watch rc* write} {} TOCK {} {watch rc* {}}} +} -result {{watch rc* write} {} {} TOCK {watch rc* {}}} test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { proc foo {args} {oninit; onfinal; track; return} proc dummy args { return } @@ -2036,6 +2048,31 @@ test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { rename foo {} rename dummy {} } -returnCodes error -result {can not find reflected channel named "rc*"} +test iocmd-31.9 { + chan postevent + + call to current coroutine + + see 67a5eabbd3d1 +} -match glob -body { + set res {} + proc foo {args} {oninit; onwatch; onfinal; track; return} + set c [chan create {r w} foo] + after 0 [list ::apply [list c { + coroutine c1 ::apply [list c { + chan event $c readable [list [info coroutine]] + yield + set ::done READING + } [namespace current]] $c + } [namespace current]] $c] + set stop [after 10000 {set done TIMEOUT}] + vwait ::done + catch {after cancel $stop} + lappend res $done + close $c + rename foo {} + set res +} -result {{watch rc* read} READING {watch rc* {}}} # --- === *** ########################### # 'Pull the rug' tests. Create channel in a interpreter A, move to -- cgit v0.12 From 2a04ff4dd5c087cfb03656d828ed02be8ddac3d8 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Tue, 23 Apr 2019 12:59:20 +0000 Subject: Ensure that Tcl_CreateTimerHandler is not called if there is an existing timer already scheduled. --- generic/tclIORChan.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 8a7a16a..477452b 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -932,12 +932,16 @@ TclChanPostEventObjCmd( if (rcPtr->owner == rcPtr->thread) { #endif if (events & TCL_READABLE) { + if (rcPtr->readTimer == NULL) { rcPtr->readTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, TimerRunRead, rcPtr); + } } if (events & TCL_WRITABLE) { + if (rcPtr->writeTimer == NULL) { rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, TimerRunWrite, rcPtr); + } } #if TCL_THREADS } else { @@ -991,7 +995,7 @@ TimerRunRead( ClientData clientData) { ReflectedChannel *rcPtr = clientData; - rcPtr->readTimer = 0; + rcPtr->readTimer = NULL; Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE); } @@ -1000,7 +1004,7 @@ TimerRunWrite( ClientData clientData) { ReflectedChannel *rcPtr = clientData; - rcPtr->writeTimer = 0; + rcPtr->writeTimer = NULL; Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE); } -- cgit v0.12 From ba3eca6d7e1ad5c6a643052f7cc496d25272e3a5 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 23 Apr 2019 13:47:52 +0000 Subject: Minor code style cleanup. --- generic/tclBasic.c | 119 +++++++----- generic/tclBinary.c | 5 +- generic/tclOO.c | 167 +++++++++++------ generic/tclOOCall.c | 33 ++-- generic/tclOODefineCmds.c | 98 ++++++---- generic/tclTest.c | 6 +- generic/tclTimer.c | 20 +- win/tclWinFile.c | 309 ++++++++++++++++++++----------- win/tclWinPipe.c | 459 ++++++++++++++++++++++++++++++---------------- 9 files changed, 788 insertions(+), 428 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5480835..d252f00 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2109,14 +2109,16 @@ Tcl_CreateCommand( break; } - /* An existing command conflicts. Try to delete it.. */ + /* + * An existing command conflicts. Try to delete it... + */ + cmdPtr = Tcl_GetHashValue(hPtr); /* - * 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. + * 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. */ cmdPtr->refCount++; @@ -2136,16 +2138,15 @@ Tcl_CreateCommand( if (!isNew) { /* - * If the deletion callback recreated the command, just throw away - * the new command (if we try to delete it again, we could get - * stuck in an infinite loop). + * If the deletion callback recreated the command, just throw away the + * new command (if we try to delete it again, we could get stuck in an + * infinite loop). */ ckfree(Tcl_GetHashValue(hPtr)); } if (!deleted) { - /* * Command resolvers (per-interp, per-namespace) might have resolved * to a command for the given namespace scope with this command not @@ -2324,16 +2325,18 @@ TclCreateObjCommandInNs ( break; } + /* + * An existing command conflicts. Try to delete it... + */ - /* An existing command conflicts. Try to delete it.. */ cmdPtr = 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. + * However, this buggy behavior is kept under particular circumstances + * to accommodate deployed binaries of the "tclcompiler" program + * that crash if the bug is + * fixed. */ if (cmdPtr->objProc == TclInvokeStringCommand @@ -2357,7 +2360,10 @@ TclCreateObjCommandInNs ( cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; } - /* Make sure namespace doesn't get deallocated. */ + /* + * Make sure namespace doesn't get deallocated. + */ + cmdPtr->nsPtr->refCount++; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); @@ -4315,15 +4321,22 @@ EvalObjvCore( reresolve: assert(cmdPtr == NULL); if (preCmdPtr) { - /* Caller gave it to us */ + /* + * Caller gave it to us. + */ + if (!(preCmdPtr->flags & CMD_IS_DELETED)) { - /* So long as it exists, use it. */ + /* + * So long as it exists, use it. + */ + cmdPtr = preCmdPtr; } else if (flags & TCL_EVAL_NORESOLVE) { /* - * When it's been deleted, and we're told not to attempt - * resolving it ourselves, all we can do is raise an error. + * When it's been deleted, and we're told not to attempt resolving + * it ourselves, all we can do is raise an error. */ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to invoke a deleted command")); Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); @@ -4339,14 +4352,12 @@ EvalObjvCore( if (enterTracesDone || iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - Tcl_Obj *commandPtr = TclGetSourceFromFrame( flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, objc, objv); - Tcl_IncrRefCount(commandPtr); + Tcl_IncrRefCount(commandPtr); if (!enterTracesDone) { - int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, objc, objv); @@ -4354,10 +4365,10 @@ EvalObjvCore( * Send any exception from enter traces back as an exception * raised by the traced command. * TODO: Is this a bug? Letting an execution trace BREAK or - * CONTINUE or RETURN in the place of the traced command? - * Would either converting all exceptions to TCL_ERROR, or - * just swallowing them be better? (Swallowing them has the - * problem of permanently hiding program errors.) + * CONTINUE or RETURN in the place of the traced command? Would + * either converting all exceptions to TCL_ERROR, or just + * swallowing them be better? (Swallowing them has the problem of + * permanently hiding program errors.) */ if (code != TCL_OK) { @@ -4366,9 +4377,8 @@ EvalObjvCore( } /* - * If the enter traces made the resolved cmdPtr unusable, go - * back and resolve again, but next time don't run enter - * traces again. + * If the enter traces made the resolved cmdPtr unusable, go back + * and resolve again, but next time don't run enter traces again. */ if (cmdPtr == NULL) { @@ -4379,9 +4389,9 @@ EvalObjvCore( } /* - * Schedule leave traces. Raise the refCount on the resolved - * cmdPtr, so that when it passes to the leave traces we know - * it's still valid. + * Schedule leave traces. Raise the refCount on the resolved cmdPtr, + * so that when it passes to the leave traces we know it's still + * valid. */ cmdPtr->refCount++; @@ -4449,8 +4459,6 @@ TclNRRunCallbacks( * are to be run. */ { Interp *iPtr = (Interp *) interp; - NRE_callback *callbackPtr; - Tcl_NRPostProc *procPtr; /* * If the interpreter has a non-empty string result, the result object is @@ -4466,11 +4474,14 @@ TclNRRunCallbacks( (void) Tcl_GetObjResult(interp); } - /* This is the trampoline. */ + /* + * This is the trampoline. + */ while (TOP_CB(interp) != rootPtr) { - callbackPtr = TOP_CB(interp); - procPtr = callbackPtr->procPtr; + NRE_callback *callbackPtr = TOP_CB(interp); + Tcl_NRPostProc *procPtr = callbackPtr->procPtr; + TOP_CB(interp) = callbackPtr->nextPtr; result = procPtr(callbackPtr->data, interp, result); TCLNR_FREE(interp, callbackPtr); @@ -6676,14 +6687,17 @@ TclNRInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); - /* Avoid the exception-handling brain damage when numLevels == 0 . */ + /* + * Avoid the exception-handling brain damage when numLevels == 0 + */ + iPtr->numLevels++; Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); /* * Normal command resolution of objv[0] isn't going to find cmdPtr. - * That's the whole point of **hidden** commands. So tell the - * Eval core machinery not to even try (and risk finding something wrong). + * That's the whole point of **hidden** commands. So tell the Eval core + * machinery not to even try (and risk finding something wrong). */ return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); @@ -8065,13 +8079,21 @@ TclDTraceInfo( Tcl_DictObjGet(NULL, info, *k++, &val); args[i] = val ? TclGetString(val) : NULL; } - /* no "proc" -> use "lambda" */ + + /* + * no "proc" -> use "lambda" + */ + if (!args[2]) { Tcl_DictObjGet(NULL, info, *k, &val); args[2] = val ? TclGetString(val) : NULL; } k++; - /* no "class" -> use "object" */ + + /* + * no "class" -> use "object" + */ + if (!args[5]) { Tcl_DictObjGet(NULL, info, *k, &val); args[5] = val ? TclGetString(val) : NULL; @@ -8424,8 +8446,10 @@ TclNRTailcallObjCmd( Tcl_Obj *listPtr, *nsObjPtr; Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - /* The tailcall data is in a Tcl list: the first element is the - * namespace, the rest the command to be tailcalled. */ + /* + * The tailcall data is in a Tcl list: the first element is the + * namespace, the rest the command to be tailcalled. + */ nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); listPtr = Tcl_NewListObj(objc, objv); @@ -9108,9 +9132,12 @@ TclNRCoroutineObjCmd( TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); - /* ensure that the command is looked up in the correct namespace */ + /* + * Ensure that the command is looked up in the correct namespace. + */ + iPtr->lookupNsPtr = lookupNsPtr; - Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); + Tcl_NREvalObj(interp, Tcl_NewListObj(objc - 2, objv + 2), 0); iPtr->numLevels--; SAVE_CONTEXT(corPtr->running); diff --git a/generic/tclBinary.c b/generic/tclBinary.c index d810e84..0ef4bda 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -639,7 +639,10 @@ TclAppendBytesToByteArray( "TclAppendBytesToByteArray"); } if (len == 0) { - /* Append zero bytes is a no-op. */ + /* + * Append zero bytes is a no-op. + */ + return; } if (objPtr->typePtr != &tclByteArrayType) { diff --git a/generic/tclOO.c b/generic/tclOO.c index 39d3806..1c2277e 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -365,14 +365,14 @@ InitFoundation( */ Tcl_DStringInit(&buffer); - for (i=0 ; defineCmds[i].name ; i++) { + for (i = 0 ; defineCmds[i].name ; i++) { TclDStringAppendLiteral(&buffer, "::oo::define::"); Tcl_DStringAppend(&buffer, defineCmds[i].name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL); Tcl_DStringFree(&buffer); } - for (i=0 ; objdefCmds[i].name ; i++) { + for (i = 0 ; objdefCmds[i].name ; i++) { TclDStringAppendLiteral(&buffer, "::oo::objdefine::"); Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), @@ -387,30 +387,50 @@ InitFoundation( * spliced manually. */ - /* Stand up a phony class for bootstrapping. */ + /* + * Stand up a phony class for bootstrapping. + */ + fPtr->objectCls = &fakeCls; - /* referenced in TclOOAllocClass to increment the refCount. */ + + /* + * Referenced in TclOOAllocClass to increment the refCount. + */ + fakeCls.thisPtr = &fakeObject; fPtr->objectCls = TclOOAllocClass(interp, AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); - /* Corresponding TclOODecrRefCount in KillFoudation */ + /* + * Corresponding TclOODecrRefCount in KillFoudation. + */ + AddRef(fPtr->objectCls->thisPtr); - /* This is why it is unnecessary in this routine to replace the + /* + * This is why it is unnecessary in this routine to replace the * incremented reference count of fPtr->objectCls that was swallowed by - * fakeObject. */ + * fakeObject. + */ + fPtr->objectCls->superclasses.num = 0; ckfree(fPtr->objectCls->superclasses.list); fPtr->objectCls->superclasses.list = NULL; - /* special initialization for the primordial objects */ + /* + * Special initialization for the primordial objects. + */ + fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; fPtr->classCls = TclOOAllocClass(interp, AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); - /* Corresponding TclOODecrRefCount in KillFoudation */ + + /* + * Corresponding TclOODecrRefCount in KillFoudation. + */ + AddRef(fPtr->classCls->thisPtr); /* @@ -421,7 +441,10 @@ InitFoundation( * KillFoundation. */ - /* Rewire bootstrapped objects. */ + /* + * Rewire bootstrapped objects. + */ + fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; AddRef(fPtr->classCls->thisPtr); TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); @@ -433,17 +456,20 @@ InitFoundation( fPtr->classCls->thisPtr->flags |= ROOT_CLASS; fPtr->classCls->flags |= ROOT_CLASS; - /* Standard initialization for new Objects */ + /* + * Standard initialization for new Objects. + */ + TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); /* * Basic method declarations for the core classes. */ - for (i=0 ; objMethods[i].name ; i++) { + for (i = 0 ; objMethods[i].name ; i++) { TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]); } - for (i=0 ; clsMethods[i].name ; i++) { + for (i = 0 ; clsMethods[i].name ; i++) { TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); } @@ -467,7 +493,7 @@ InitFoundation( TclNewLiteralStringObj(namePtr, "new"); Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, - namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL); + namePtr /* keeps ref */, 0 /* private */, NULL, NULL); fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); @@ -651,10 +677,8 @@ AllocObject( Tcl_ResetResult(interp); } - configNamespace: - - ((Namespace *)oPtr->namespacePtr)->refCount++; + ((Namespace *) oPtr->namespacePtr)->refCount++; /* * Make the namespace know about the helper commands. This grants access @@ -692,7 +716,7 @@ AllocObject( /* * An object starts life with a refCount of 2 to mark the two stages of * destruction it occur: A call to ObjectRenamedTrace(), and a call to - * ObjectNamespaceDeleted(). + * ObjectNamespaceDeleted(). */ oPtr->refCount = 2; @@ -847,10 +871,14 @@ TclOODeleteDescendants( if (clsPtr->mixinSubs.num > 0) { while (clsPtr->mixinSubs.num > 0) { - mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1]; - /* This condition also covers the case where mixinSubclassPtr == + mixinSubclassPtr = + clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1]; + + /* + * This condition also covers the case where mixinSubclassPtr == * clsPtr */ + if (!Deleted(mixinSubclassPtr->thisPtr) && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, @@ -869,7 +897,7 @@ TclOODeleteDescendants( if (clsPtr->subclasses.num > 0) { while (clsPtr->subclasses.num > 0) { - subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1]; + subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1]; if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr) && !(subclassPtr->thisPtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, @@ -890,8 +918,12 @@ TclOODeleteDescendants( if (clsPtr->instances.num > 0) { while (clsPtr->instances.num > 0) { - instancePtr = clsPtr->instances.list[clsPtr->instances.num-1]; - /* This condition also covers the case where instancePtr == oPtr */ + instancePtr = clsPtr->instances.list[clsPtr->instances.num - 1]; + + /* + * This condition also covers the case where instancePtr == oPtr + */ + if (!Deleted(instancePtr) && !IsRoot(instancePtr) && !(instancePtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, instancePtr->command); @@ -905,7 +937,6 @@ TclOODeleteDescendants( clsPtr->instances.size = 0; } } - /* * ---------------------------------------------------------------------- @@ -924,7 +955,7 @@ TclOOReleaseClassContents( Object *oPtr) /* The object representing the class. */ { FOREACH_HASH_DECLS; - int i; + int i; Class *clsPtr = oPtr->classPtr, *tmpClsPtr; Method *mPtr; Foundation *fPtr = oPtr->fPtr; @@ -1065,7 +1096,8 @@ ObjectNamespaceDeleted( int i; if (Deleted(oPtr)) { - /* To do: Can ObjectNamespaceDeleted ever be called twice? If not, + /* + * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, * this guard could be removed. */ return; @@ -1078,7 +1110,10 @@ ObjectNamespaceDeleted( */ oPtr->flags |= OBJECT_DELETED; - /* Let the dominoes fall */ + /* + * Let the dominoes fall! + */ + if (oPtr->classPtr) { TclOODeleteDescendants(interp, oPtr); } @@ -1089,12 +1124,13 @@ ObjectNamespaceDeleted( * in that case when the destructor is partially deleted before the uses * of it have gone. [Bug 2949397] */ + if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); int result; - Tcl_InterpState state; + oPtr->flags |= DESTRUCTOR_CALLED; if (contextPtr != NULL) { @@ -1113,12 +1149,12 @@ ObjectNamespaceDeleted( /* * Instruct everyone to no longer use any allocated fields of the object. - * Also delete the command that refers to the object at this point (if - * it still exists) because otherwise its pointer to the object - * points into freed memory. + * Also delete the command that refers to the object at this point (if it + * still exists) because otherwise its pointer to the object points into + * freed memory. */ - if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) { + if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) { /* * Something has already started the command deletion process. We can * go ahead and clean up the the namespace, @@ -1128,6 +1164,7 @@ ObjectNamespaceDeleted( * The namespace must have been deleted directly. Delete the command * as well. */ + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } @@ -1140,7 +1177,7 @@ ObjectNamespaceDeleted( * methods on the object. */ - /* To do: Should this be protected with a * !IsRoot() condition? */ + /* TODO: Should this be protected with a !IsRoot() condition? */ TclOORemoveFromInstances(oPtr, oPtr->selfCls); if (oPtr->mixins.num > 0) { @@ -1196,7 +1233,7 @@ ObjectNamespaceDeleted( /* * Because an object can be a class that is an instance of itself, the * class object's class structure should only be cleaned after most of - * the cleanup on the object is done. + * the cleanup on the object is done. * * The class of objects needs some special care; if it is deleted (and * we're not killing the whole interpreter) we force the delete of the @@ -1249,10 +1286,13 @@ int TclOODecrRefCount(Object *oPtr) { return 0; } -/* setting the "empty" location to NULL makes debugging a little easier */ -#define REMOVEBODY { \ +/* + * Setting the "empty" location to NULL makes debugging a little easier. + */ + +#define REMOVEBODY { \ for (; idx < num - 1; idx++) { \ - list[idx] = list[idx+1]; \ + list[idx] = list[idx + 1]; \ } \ list[idx] = NULL; \ return; \ @@ -1690,7 +1730,6 @@ TclNRNewObjectInstance( TclPushTailcallPoint(interp); return TclOOInvokeContext(contextPtr, interp, objc, objv); } - Object * TclNewObjectInstanceCommon( @@ -1705,21 +1744,17 @@ TclNewObjectInstanceCommon( const char *simpleName = NULL; Namespace *nsPtr = NULL, *dummy, *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); - int isNew; if (nameStr) { - TclGetNamespaceForQualName(interp, nameStr, inNsPtr, TCL_CREATE_NS_IF_UNKNOWN, - &nsPtr, &dummy, &dummy, &simpleName); + TclGetNamespaceForQualName(interp, nameStr, inNsPtr, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName); /* * Disallow creation of an object over an existing command. */ - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew); - if (isNew) { - /* Just kidding */ - Tcl_DeleteHashEntry(hPtr); - } else { + hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName); + if (hPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create object \"%s\": command already exists with" " that name", nameStr)); @@ -1736,6 +1771,7 @@ TclNewObjectInstanceCommon( oPtr->selfCls = classPtr; AddRef(classPtr->thisPtr); TclOOAddToInstances(oPtr, classPtr); + /* * Check to see if we're really creating a class. If so, allocate the * class structure as well. @@ -1757,8 +1793,6 @@ TclNewObjectInstanceCommon( return oPtr; } - - static int FinalizeAlloc( ClientData data[], @@ -1794,13 +1828,21 @@ FinalizeAlloc( (void) TclOOObjectName(interp, oPtr); Tcl_DeleteCommandFromToken(interp, oPtr->command); } - /* This decrements the refcount of oPtr */ + + /* + * This decrements the refcount of oPtr. + */ + TclOODeleteContext(contextPtr); return TCL_ERROR; } Tcl_RestoreInterpState(interp, state); *objectPtr = (Tcl_Object) oPtr; - /* This decrements the refcount of oPtr */ + + /* + * This decrements the refcount of oPtr. + */ + TclOODeleteContext(contextPtr); return TCL_OK; } @@ -1885,7 +1927,11 @@ Tcl_CopyObjectInstance( if (mixinPtr && mixinPtr != o2Ptr->selfCls) { TclOOAddToInstances(o2Ptr, mixinPtr); } - /* For the reference just created in DUPLICATE */ + + /* + * For the reference just created in DUPLICATE. + */ + AddRef(mixinPtr->thisPtr); } @@ -1915,7 +1961,8 @@ Tcl_CopyObjectInstance( */ o2Ptr->flags = oPtr->flags & ~( - OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); + OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); + /* * Copy the object's metadata. */ @@ -1979,9 +2026,11 @@ Tcl_CopyObjectInstance( FOREACH(superPtr, cls2Ptr->superclasses) { TclOOAddToSubclasses(cls2Ptr, superPtr); - /* For the new item in cls2Ptr->superclasses that memcpy just - * created + /* + * For the new item in cls2Ptr->superclasses that memcpy just + * created. */ + AddRef(superPtr->thisPtr); } @@ -2018,7 +2067,11 @@ Tcl_CopyObjectInstance( DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); FOREACH(mixinPtr, cls2Ptr->mixins) { TclOOAddToMixinSubs(cls2Ptr, mixinPtr); - /* For the copy just created in DUPLICATE */ + + /* + * For the copy just created in DUPLICATE. + */ + AddRef(mixinPtr->thisPtr); } @@ -2619,7 +2672,7 @@ Tcl_ObjectContextInvokeNext( int savedSkip = contextPtr->skip; int result; - if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) { /* * We're at the end of the chain; generate an error message unless the * interpreter is being torn down, in which case we might be getting @@ -2688,7 +2741,7 @@ TclNRObjectContextInvokeNext( { register CallContext *contextPtr = (CallContext *) context; - if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) { /* * We're at the end of the chain; generate an error message unless the * interpreter is being torn down, in which case we might be getting diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index a46b8bc..cc02c68 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -110,7 +110,11 @@ TclOODeleteContext( TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { TclStackFree(oPtr->fPtr->interp, contextPtr); - /* Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore */ + + /* + * Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore + */ + TclOODecrRefCount(oPtr); } } @@ -265,7 +269,7 @@ TclOOInvokeContext( if (contextPtr->index == 0) { int i; - for (i=0 ; icallPtr->numChain ; i++) { + for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { AddRef(contextPtr->callPtr->chain[i].mPtr); } @@ -343,7 +347,7 @@ FinalizeMethodRefs( CallContext *contextPtr = data[0]; int i; - for (i=0 ; icallPtr->numChain ; i++) { + for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr); } return result; @@ -568,7 +572,10 @@ TclOOGetSortedClassMethodList( return i; } -/* Comparator for GetSortedMethodList */ +/* + * Comparator for GetSortedMethodList + */ + static int CmpStr( const void *ptr1, @@ -577,7 +584,7 @@ CmpStr( const char **strPtr1 = (const char **) ptr1; const char **strPtr2 = (const char **) ptr2; - return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1); + return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1) + 1); } /* @@ -824,7 +831,7 @@ AddMethodToCallChain( * any leading filters. */ - for (i=cbPtr->filterLength ; inumChain ; i++) { + for (i = cbPtr->filterLength ; i < callPtr->numChain ; i++) { if (callPtr->chain[i].mPtr == mPtr && callPtr->chain[i].isFilter == (doneFilters != NULL)) { /* @@ -836,8 +843,8 @@ AddMethodToCallChain( Class *declCls = callPtr->chain[i].filterDeclarer; - for (; i+1numChain ; i++) { - callPtr->chain[i] = callPtr->chain[i+1]; + for (; i + 1 < callPtr->numChain ; i++) { + callPtr->chain[i] = callPtr->chain[i + 1]; } callPtr->chain[i].mPtr = mPtr; callPtr->chain[i].isFilter = (doneFilters != NULL); @@ -854,7 +861,7 @@ AddMethodToCallChain( if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) { callPtr->chain = - ckalloc(sizeof(struct MInvoke) * (callPtr->numChain+1)); + ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1)); memcpy(callPtr->chain, callPtr->staticChain, sizeof(struct MInvoke) * callPtr->numChain); } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) { @@ -1172,7 +1179,11 @@ TclOOGetCallContext( returnContext: contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); contextPtr->oPtr = oPtr; - /* Corresponding TclOODecrRefCount() in TclOODeleteContext */ + + /* + * Corresponding TclOODecrRefCount() in TclOODeleteContext + */ + AddRef(oPtr); contextPtr->callPtr = callPtr; contextPtr->skip = 2; @@ -1528,7 +1539,7 @@ TclOORenderCallChain( */ objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *)); - for (i=0 ; inumChain ; i++) { + for (i = 0 ; i < callPtr->numChain ; i++) { struct MInvoke *miPtr = &callPtr->chain[i]; descObjs[0] = miPtr->isFilter diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 0271a43..f02e1d3 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -41,6 +41,12 @@ struct DeclaredSlot { setter, NULL, NULL}} /* + * A [string match] pattern used to determine if a method should be exported. + */ + +#define PUBLIC_PATTERN "[a-z]*" + +/* * Forward declarations. */ @@ -232,7 +238,7 @@ TclOOObjectSetFilters( } else { filtersList = ckrealloc(oPtr->filters.list, size); } - for (i=0 ; ifilters.list, size); } - for (i=0 ; imixins) { if (mixinPtr != oPtr->selfCls) { TclOOAddToInstances(oPtr, mixinPtr); - /* For the new copy created by memcpy */ + + /* + * For the new copy created by memcpy(). + */ + AddRef(mixinPtr->thisPtr); } } @@ -403,7 +413,11 @@ TclOOClassSetMixins( memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, classPtr->mixins) { TclOOAddToMixinSubs(classPtr, mixinPtr); - /* For the new copy created by memcpy */ + + /* + * For the new copy created by memcpy. + */ + AddRef(mixinPtr->thisPtr); } } @@ -556,15 +570,16 @@ TclOOUnknownDefinition( * Got one match, and only one match! */ - Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1)); + Tcl_Obj **newObjv = + TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1)); int result; newObjv[0] = Tcl_NewStringObj(matchedStr, -1); Tcl_IncrRefCount(newObjv[0]); if (objc > 2) { - memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2)); } - result = Tcl_EvalObjv(interp, objc-1, newObjv, 0); + result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0); Tcl_DecrRefCount(newObjv[0]); TclStackFree(interp, newObjv); return result; @@ -666,7 +681,9 @@ InitDefineContext( return TCL_ERROR; } - /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */ + /* + * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules. + */ (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, FRAME_IS_OO_DEFINE); @@ -837,17 +854,20 @@ MagicDefinitionInvoke( obj2Ptr = Tcl_NewObj(); cmd = FindCommand(interp, objv[cmdIndex], nsPtr); if (cmd == NULL) { - /* punt this case! */ + /* + * Punt this case! + */ + Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]); } else { Tcl_GetCommandFullName(interp, cmd, obj2Ptr); } Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); /* TODO: overflow? */ - Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-offset, objv+offset); + Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset); Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); - result = Tcl_EvalObjv(interp, objc-cmdIndex, objs, TCL_EVAL_INVOKE); + result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE); if (isRoot) { TclResetRewriteEnsemble(interp, 1); } @@ -1277,7 +1297,7 @@ TclOODefineDeleteMethodObjCmd( return TCL_ERROR; } - for (i=1 ; iname ; slotInfoPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0); + (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0); if (slotObject == NULL) { continue; @@ -1874,7 +1894,7 @@ ClassFilterSet( int filterc; Tcl_Obj **filterv; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -1957,7 +1977,7 @@ ClassMixinSet( Tcl_Obj **mixinv; Class **mixins; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "mixinList"); return TCL_ERROR; @@ -1978,7 +1998,7 @@ ClassMixinSet( mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); - for (i=0 ; ithisPtr); } else { - for (i=0 ; ithisPtr); } } @@ -2222,7 +2246,7 @@ ClassVarsSet( Tcl_Obj **varv, *variableObj; int i; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2241,7 +2265,7 @@ ClassVarsSet( return TCL_ERROR; } - for (i=0 ; iclassPtr->variables) { @@ -2285,7 +2309,7 @@ ClassVarsSet( Tcl_HashTable uniqueTable; Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; iclassPtr->variables.list[n++] = varv[i]; @@ -2357,7 +2381,7 @@ ObjFilterSet( int filterc; Tcl_Obj **filterv; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "filterList"); return TCL_ERROR; @@ -2430,7 +2454,7 @@ ObjMixinSet( Class **mixins; int i; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "mixinList"); return TCL_ERROR; @@ -2445,7 +2469,7 @@ ObjMixinSet( mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); - for (i=0 ; ivariables.list[n++] = varv[i]; diff --git a/generic/tclTest.c b/generic/tclTest.c index b39ef0a..b16957d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -952,8 +952,10 @@ AsyncHandlerProc( Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; - asyncPtr = asyncPtr->nextPtr) { - if (asyncPtr->id == id) break; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) { + break; + } } Tcl_MutexUnlock(&asyncTestMutex); diff --git a/generic/tclTimer.c b/generic/tclTimer.c index c10986a..5755edc 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -310,8 +310,8 @@ TclCreateAbsoluteTimerHandler( timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId); /* - * Add the event to the queue in the correct position - * (ordered by event firing time). + * Add the event to the queue in the correct position (ordered by event + * firing time). */ for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; @@ -1019,8 +1019,8 @@ AfterDelay( Tcl_GetTime(&now); endTime = now; - endTime.sec += (long)(ms/1000); - endTime.usec += ((int)(ms%1000))*1000; + endTime.sec += (long)(ms / 1000); + endTime.usec += ((int)(ms % 1000)) * 1000; if (endTime.usec >= 1000000) { endTime.sec++; endTime.usec -= 1000000; @@ -1053,11 +1053,17 @@ AfterDelay( if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } - if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) diff = 1; + if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) { + diff = 1; + } if (diff > 0) { Tcl_Sleep((long) diff); - if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) break; - } else break; + if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { + break; + } + } else { + break; + } } else { diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); #ifndef TCL_WIDE_INT_IS_LONG diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 809bcf0..2f35d4a 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -682,7 +682,8 @@ NativeReadReparse( HANDLE hFile; DWORD returnedLength; - hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, OPEN_EXISTING, + hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, + OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile == INVALID_HANDLE_VALUE) { @@ -844,7 +845,7 @@ tclWinDebugPanic( #endif abort(); } - + /* *--------------------------------------------------------------------------- * @@ -1461,11 +1462,16 @@ TclpGetUserHome( if (domain == NULL) { const char *ptr; - /* no domain - firstly check it's the current user */ - if ( (ptr = TclpGetUserName(&ds)) != NULL - && strcasecmp(name, ptr) == 0 - ) { - /* try safest and fastest way to get current user home */ + /* + * No domain. Firstly check it's the current user + */ + + ptr = TclpGetUserName(&ds); + if (ptr != NULL && strcasecmp(name, ptr) == 0) { + /* + * Try safest and fastest way to get current user home + */ + ptr = TclGetEnv("HOME", &ds); if (ptr != NULL) { Tcl_JoinPath(1, &ptr, bufferPtr); @@ -1486,18 +1492,28 @@ TclpGetUserHome( wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) { /* - * user does not exists - if domain was not specified, - * try again using current domain. + * User does not exist; if domain was not specified, try again + * using current domain. */ + rc = 1; - if (domain != NULL) break; - /* get current domain */ + if (domain != NULL) { + break; + } + + /* + * Get current domain + */ + rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain); - if (rc != 0) break; + if (rc != 0) { + break; + } domain = INT2PTR(-1); /* repeat once */ } if (rc == 0) { DWORD i, size = MAX_PATH; + wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { size = lstrlenW(wHomeDir); @@ -1507,15 +1523,22 @@ TclpGetUserHome( * User exists but has no home dir. Return * "{GetProfilesDirectory}/". */ + GetProfilesDirectoryW(buf, &size); Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); Tcl_DStringAppend(bufferPtr, "/", 1); Tcl_DStringAppend(bufferPtr, name, nameLen); } result = Tcl_DStringValue(bufferPtr); - /* be sure we returns normalized path */ - for (i = 0; i < size; ++i){ - if (result[i] == '\\') result[i] = '/'; + + /* + * Be sure we returns normalized path + */ + + for (i = 0; i < size; ++i) { + if (result[i] == '\\') { + result[i] = '/'; + } } NetApiBufferFree((void *) uiPtr); } @@ -1603,48 +1626,72 @@ NativeAccess( /* * If it's not a directory (assume file), do several fast checks: */ + if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) { /* * If the attributes say this is not writable at all. The file is a * regular file (i.e., not a directory), then the file is not - * writable, full stop. For directories, the read-only bit is + * writable, full stop. For directories, the read-only bit is * (mostly) ignored by Windows, so we can't ascertain anything about * directory access from the attrib data. However, if we have the - * advanced 'getFileSecurityProc', then more robust ACL checks - * will be done below. + * advanced 'getFileSecurityProc', then more robust ACL checks will be + * done below. */ + if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) { Tcl_SetErrno(EACCES); return -1; } - /* If doesn't have the correct extension, it can't be executable */ + /* + * If doesn't have the correct extension, it can't be executable + */ + if ((mode & X_OK) && !NativeIsExec(nativePath)) { Tcl_SetErrno(EACCES); return -1; } - /* Special case for read/write/executable check on file */ + + /* + * Special case for read/write/executable check on file + */ + if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) { DWORD mask = 0; HANDLE hFile; - if (mode & R_OK) { mask |= GENERIC_READ; } - if (mode & W_OK) { mask |= GENERIC_WRITE; } - if (mode & X_OK) { mask |= GENERIC_EXECUTE; } + + if (mode & R_OK) { + mask |= GENERIC_READ; + } + if (mode & W_OK) { + mask |= GENERIC_WRITE; + } + if (mode & X_OK) { + mask |= GENERIC_EXECUTE; + } hFile = CreateFile(nativePath, mask, - FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, - OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL); + FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, + NULL, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL); if (hFile != INVALID_HANDLE_VALUE) { CloseHandle(hFile); return 0; } - /* fast exit if access was denied */ + + /* + * Fast exit if access was denied + */ + if (GetLastError() == ERROR_ACCESS_DENIED) { Tcl_SetErrno(EACCES); return -1; } } - /* We cannnot verify the access fast, check it below using security info. */ + + /* + * We cannnot verify the access fast, check it below using security + * info. + */ } /* @@ -2021,13 +2068,12 @@ NativeStat( * 'getFileAttributesExProc', and if that isn't available, then on even * simpler routines. * - * Special consideration must be given to Windows hardcoded names - * like CON, NULL, COM1, LPT1 etc. For these, we still need to - * do the CreateFile as some may not exist (e.g. there is no CON - * in wish by default). However the subsequent GetFileInformationByHandle - * will fail. We do a WinIsReserved to see if it is one of the special - * names, and if successful, mock up a BY_HANDLE_FILE_INFORMATION - * structure. + * Special consideration must be given to Windows hardcoded names like + * CON, NULL, COM1, LPT1 etc. For these, we still need to do the + * CreateFile as some may not exist (e.g. there is no CON in wish by + * default). However the subsequent GetFileInformationByHandle will + * fail. We do a WinIsReserved to see if it is one of the special names, + * and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure. */ fileHandle = CreateFile(nativePath, GENERIC_READ, @@ -2045,7 +2091,11 @@ NativeStat( Tcl_SetErrno(ENOENT); return -1; } - /* Mock up the expected structure */ + + /* + * Mock up the expected structure + */ + memset(&data, 0, sizeof(data)); statPtr->st_atime = 0; statPtr->st_mtime = 0; @@ -2328,7 +2378,7 @@ TclpGetNativeCwd( } if (clientData != NULL) { - if (_tcscmp((const TCHAR*)clientData, buffer) == 0) { + if (_tcscmp((const TCHAR *) clientData, buffer) == 0) { return clientData; } } @@ -2556,10 +2606,12 @@ TclpObjNormalizePath( (int)(sizeof(WCHAR) * len)); lastValidPathEnd = currentPathEndPosition; } else if (nextCheckpoint == 0) { - /* Path starts with a drive designation - * that's not actually on the system. - * We still must normalize up past the - * first separator. [Bug 3603434] */ + /* + * Path starts with a drive designation that's not + * actually on the system. We still must normalize up + * past the first separator. [Bug 3603434] + */ + currentPathEndPosition++; } } @@ -2574,11 +2626,10 @@ TclpObjNormalizePath( */ /* - * Check for symlinks, except at last component of path (we - * don't follow final symlinks). Also a drive (C:/) for - * example, may sometimes have the reparse flag set for some - * reason I don't understand. We therefore don't perform this - * check for drives. + * Check for symlinks, except at last component of path (we don't + * follow final symlinks). Also a drive (C:/) for example, may + * sometimes have the reparse flag set for some reason I don't + * understand. We therefore don't perform this check for drives. */ if (cur != 0 && !isDrive && @@ -2587,8 +2638,8 @@ TclpObjNormalizePath( if (to != NULL) { /* - * Read the reparse point ok. Now, reparse points need - * not be normalized, otherwise we could use: + * Read the reparse point ok. Now, reparse points need not + * be normalized, otherwise we could use: * * Tcl_GetStringFromObj(to, &pathLen); * nextCheckpoint = pathLen; @@ -2628,9 +2679,9 @@ TclpObjNormalizePath( #ifndef TclNORM_LONG_PATH /* - * Now we convert the tail of the current path to its 'long - * form', and append it to 'dsNorm' which holds the current - * normalized path + * Now we convert the tail of the current path to its 'long form', + * and append it to 'dsNorm' which holds the current normalized + * path */ if (isDrive) { @@ -2659,10 +2710,10 @@ TclpObjNormalizePath( int dotLen = currentPathEndPosition-lastValidPathEnd; /* - * Path is just dots. We shouldn't really ever see a - * path like that. However, to be nice we at least - * don't mangle the path - we just add the dots as a - * path segment and continue. + * Path is just dots. We shouldn't really ever see a path + * like that. However, to be nice we at least don't mangle + * the path - we just add the dots as a path segment and + * continue. */ Tcl_DStringAppend(&dsNorm, ((const char *)nativePath) @@ -2680,8 +2731,7 @@ TclpObjNormalizePath( handle = FindFirstFileW((WCHAR *) nativePath, &fData); if (handle == INVALID_HANDLE_VALUE) { /* - * This is usually the '/' in 'c:/' at end of - * string. + * This is usually the '/' in 'c:/' at end of string. */ Tcl_DStringAppend(&dsNorm, (const char *) L"/", @@ -2711,8 +2761,8 @@ TclpObjNormalizePath( } /* - * If we get here, we've got past one directory delimiter, so - * we know it is no longer a drive. + * If we get here, we've got past one directory delimiter, so we + * know it is no longer a drive. */ isDrive = 0; @@ -3007,7 +3057,11 @@ TclNativeCreateNativeRep( if (validPathPtr == NULL) { return NULL; } - /* refCount of validPathPtr was already incremented in Tcl_FSGetTranslatedPath */ + + /* + * refCount of validPathPtr was already incremented in + * Tcl_FSGetTranslatedPath + */ } else { /* * Make sure the normalized path is set. @@ -3017,73 +3071,101 @@ TclNativeCreateNativeRep( if (validPathPtr == NULL) { return NULL; } - /* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, so incr refCount here */ + + /* + * validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, + * so incr refCount here + */ + Tcl_IncrRefCount(validPathPtr); } str = Tcl_GetString(validPathPtr); len = validPathPtr->length; - if (strlen(str)!=(unsigned int)len) { - /* String contains NUL-bytes. This is invalid. */ + if (strlen(str) != (unsigned int) len) { + /* + * String contains NUL-bytes. This is invalid. + */ + goto done; } - /* For a reserved device, strip a possible postfix ':' */ + + /* + * For a reserved device, strip a possible postfix ':' + */ + len = WinIsReserved(str); if (len == 0) { - /* Let MultiByteToWideChar check for other invalid sequences, like - * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */ + /* + * Let MultiByteToWideChar check for other invalid sequences, like + * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames + */ + len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0); if (len==0) { goto done; } } - /* Overallocate 6 chars, making some room for extended paths */ - wp = nativePathPtr = ckalloc( (len+6) * sizeof(WCHAR) ); + + /* + * Overallocate 6 chars, making some room for extended paths + */ + + wp = nativePathPtr = ckalloc((len + 6) * sizeof(WCHAR)); if (nativePathPtr==0) { goto done; } - MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len+1); + MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, + len + 1); + /* - ** If path starts with "//?/" or "\\?\" (extended path), translate - ** any slashes to backslashes but leave the '?' intact - */ - if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/') - && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) { + * If path starts with "//?/" or "\\?\" (extended path), translate any + * slashes to backslashes but leave the '?' intact + */ + + if ((str[0] == '\\' || str[0] == '/') && (str[1] == '\\' || str[1] == '/') + && str[2] == '?' && (str[3] == '\\' || str[3] == '/')) { wp[0] = wp[1] = wp[3] = '\\'; str += 4; wp += 4; } + /* - ** If there is no "\\?\" prefix but there is a drive or UNC - ** path prefix and the path is larger than MAX_PATH chars, - ** no Win32 API function can handle that unless it is - ** prefixed with the extended path prefix. See: - ** - **/ - if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z')) - && str[1]==':') { - if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) { - memmove(wp+4, wp, len*sizeof(WCHAR)); - memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR)); + * If there is no "\\?\" prefix but there is a drive or UNC path prefix + * and the path is larger than MAX_PATH chars, no Win32 API function can + * handle that unless it is prefixed with the extended path prefix. See: + * + */ + + if (((str[0] >= 'A' && str[0] <= 'Z') || (str[0] >= 'a' && str[0] <= 'z')) + && str[1] == ':') { + if (wp == nativePathPtr && len > MAX_PATH + && (str[2] == '\\' || str[2] == '/')) { + memmove(wp + 4, wp, len * sizeof(WCHAR)); + memcpy(wp, L"\\\\?\\", 4 * sizeof(WCHAR)); wp += 4; } + /* - ** If (remainder of) path starts with ":", - ** leave the ':' intact. + * If (remainder of) path starts with ":", leave the ':' + * intact. */ + wp += 2; - } else if (wp==nativePathPtr && len>MAX_PATH - && (str[0]=='\\' || str[0]=='/') - && (str[1]=='\\' || str[1]=='/') && str[2]!='?') { - memmove(wp+6, wp, len*sizeof(WCHAR)); - memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR)); + } else if (wp == nativePathPtr && len > MAX_PATH + && (str[0] == '\\' || str[0] == '/') + && (str[1] == '\\' || str[1] == '/') && str[2] != '?') { + memmove(wp + 6, wp, len * sizeof(WCHAR)); + memcpy(wp, L"\\\\?\\UNC", 7 * sizeof(WCHAR)); wp += 7; } + /* - ** In the remainder of the path, translate invalid characters to - ** characters in the Unicode private use area. - */ + * In the remainder of the path, translate invalid characters to + * characters in the Unicode private use area. + */ + while (*wp != '\0') { if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) { *wp |= 0xF000; @@ -3094,7 +3176,6 @@ TclNativeCreateNativeRep( } done: - TclDecrRefCount(validPathPtr); return nativePathPtr; } @@ -3220,21 +3301,28 @@ TclWinFileOwned( native = Tcl_FSGetNativePath(pathPtr); if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT, - OWNER_SECURITY_INFORMATION, &ownerSid, - NULL, NULL, NULL, &secd) != ERROR_SUCCESS) { - /* Either not a file, or we do not have access to it in which - case we are in all likelihood not the owner */ + OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL, + &secd) != ERROR_SUCCESS) { + /* + * Either not a file, or we do not have access to it in which case we + * are in all likelihood not the owner. + */ + return 0; } /* - * Getting the current process SID is a multi-step process. - * We make the assumption that if a call fails, this process is - * so underprivileged it could not possibly own anything. Normally - * a process can *always* look up its own token. + * Getting the current process SID is a multi-step process. We make the + * assumption that if a call fails, this process is so underprivileged it + * could not possibly own anything. Normally a process can *always* look + * up its own token. */ + if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) { - /* Find out how big the buffer needs to be */ + /* + * Find out how big the buffer needs to be. + */ + bufsz = 0; GetTokenInformation(token, TokenUser, NULL, 0, &bufsz); if (bufsz) { @@ -3246,15 +3334,20 @@ TclWinFileOwned( CloseHandle(token); } - /* Free allocations and be done */ - if (secd) + /* + * Free allocations and be done. + */ + + if (secd) { LocalFree(secd); /* Also frees ownerSid */ - if (buf) + } + if (buf) { ckfree(buf); + } return (owned != 0); /* Convert non-0 to 1 */ } - + /* * Local Variables: * mode: c diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 83bd26e..ce3e746 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -124,8 +124,7 @@ typedef struct PipeInfo { * write. Set to 0 if no error has been * detected. This word is shared with the * writer thread so access must be - * synchronized with the writable object. - */ + * synchronized with the writable object. */ char *writeBuf; /* Current background output buffer. Access is * synchronized with the writable object. */ int writeBufLen; /* Size of write buffer. Access is @@ -218,7 +217,7 @@ static const Tcl_ChannelType pipeChannelType = { NULL, /* handler proc. */ NULL, /* wide seek proc */ PipeThreadActionProc, /* thread action proc */ - NULL /* truncate */ + NULL /* truncate */ }; /* @@ -1445,9 +1444,12 @@ ApplicationType( static const char * BuildCmdLineBypassBS( const char *current, - const char **bspos -) { - /* mark first backslash possition */ + const char **bspos) +{ + /* + * Mark first backslash position. + */ + if (!*bspos) { *bspos = current; } @@ -1462,14 +1464,14 @@ QuoteCmdLineBackslash( Tcl_DString *dsPtr, const char *start, const char *current, - const char *bspos -) { + const char *bspos) +{ if (!bspos) { - if (current > start) { /* part before current (special) */ + if (current > start) { /* part before current (special) */ Tcl_DStringAppend(dsPtr, start, (int) (current - start)); } } else { - if (bspos > start) { /* part before first backslash */ + if (bspos > start) { /* part before first backslash */ Tcl_DStringAppend(dsPtr, start, (int) (bspos - start)); } while (bspos++ < current) { /* each backslash twice */ @@ -1484,38 +1486,59 @@ QuoteCmdLinePart( const char *start, const char *special, const char *specMetaChars, - const char **bspos -) { + const char **bspos) +{ if (!*bspos) { - /* rest before special (before quote) */ + /* + * Rest before special (before quote). + */ + QuoteCmdLineBackslash(dsPtr, start, special, NULL); start = special; } else { - /* rest before first backslash and backslashes into new quoted block */ + /* + * Rest before first backslash and backslashes into new quoted block. + */ + QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL); start = *bspos; } + /* - * escape all special chars enclosed in quotes like `"..."`, note that here we - * don't must escape `\` (with `\`), because it's outside of the main quotes, - * so `\` remains `\`, but important - not at end of part, because results as - * before the quote, so `%\%\` should be escaped as `"%\%"\\`). + * escape all special chars enclosed in quotes like `"..."`, note that + * here we don't must escape `\` (with `\`), because it's outside of the + * main quotes, so `\` remains `\`, but important - not at end of part, + * because results as before the quote, so `%\%\` should be escaped as + * `"%\%"\\`). */ + TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */ do { *bspos = NULL; special++; if (*special == '\\') { - /* bypass backslashes (and mark first backslash possition)*/ + /* + * Bypass backslashes (and mark first backslash position). + */ + special = BuildCmdLineBypassBS(special, bspos); - if (*special == '\0') break; + if (*special == '\0') { + break; + } } } while (*special && strchr(specMetaChars, *special)); if (!*bspos) { - /* unescaped rest before quote */ + /* + * Unescaped rest before quote. + */ + QuoteCmdLineBackslash(dsPtr, start, special, NULL); } else { - /* unescaped rest before first backslash (rather belongs to the main block) */ + /* + * Unescaped rest before first backslash (rather belongs to the main + * block). + */ + QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL); } TclDStringAppendLiteral(dsPtr, "\""); /* closing escape quote-char */ @@ -1534,13 +1557,14 @@ BuildCommandLine( const char *arg, *start, *special, *bspos; int quote = 0, i; Tcl_DString ds; - - /* characters to enclose in quotes if unpaired quote flag set */ static const char specMetaChars[] = "&|^<>!()%"; - /* character to enclose in quotes in any case (regardless unpaired-flag) */ + /* Characters to enclose in quotes if unpaired + * quote flag set. */ static const char specMetaChars2[] = "%"; - - /* Quote flags: + /* Character to enclose in quotes in any case + * (regardless of unpaired-flag). */ + /* + * Quote flags: * CL_ESCAPE - escape argument; * CL_QUOTE - enclose in quotes; * CL_UNPAIRED - previous arguments chain contains unpaired quote-char; @@ -1572,30 +1596,31 @@ BuildCommandLine( quote = CL_QUOTE; } else { for (start = arg; - *start != '\0' && - (quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE); - start++ - ) { - if (*start & 0x80) continue; + *start != '\0' && + (quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE); + start++) { + if (*start & 0x80) { + continue; + } if (TclIsSpaceProc(*start)) { - quote |= CL_QUOTE; /* quote only */ - if (bspos) { /* if backslash found - escape & quote */ + quote |= CL_QUOTE; /* quote only */ + if (bspos) { /* if backslash found, escape & quote */ quote |= CL_ESCAPE; break; } continue; } if (strchr(specMetaChars, *start)) { - quote |= (CL_ESCAPE|CL_QUOTE); /*escape & quote */ + quote |= (CL_ESCAPE|CL_QUOTE); /* escape & quote */ break; } if (*start == '"') { - quote |= CL_ESCAPE; /* escape only */ + quote |= CL_ESCAPE; /* escape only */ continue; } if (*start == '\\') { bspos = start; - if (quote & CL_QUOTE) { /* if quote - escape & quote */ + if (quote & CL_QUOTE) { /* if quote, escape & quote */ quote |= CL_ESCAPE; break; } @@ -1605,56 +1630,116 @@ BuildCommandLine( bspos = NULL; } if (quote & CL_QUOTE) { - /* start of argument (main opening quote-char) */ + /* + * Start of argument (main opening quote-char). + */ + TclDStringAppendLiteral(&ds, "\""); } if (!(quote & CL_ESCAPE)) { - /* nothing to escape */ + /* + * Nothing to escape. + */ + Tcl_DStringAppend(&ds, arg, -1); } else { start = arg; for (special = arg; *special != '\0'; ) { - /* position of `\` is important before quote or at end (equal `\"` because quoted) */ + /* + * Position of `\` is important before quote or at end (equal + * `\"` because quoted). + */ + if (*special == '\\') { - /* bypass backslashes (and mark first backslash possition)*/ + /* + * Bypass backslashes (and mark first backslash position) + */ + special = BuildCmdLineBypassBS(special, &bspos); - if (*special == '\0') break; + if (*special == '\0') { + break; + } } /* ["] */ if (*special == '"') { - quote ^= CL_UNPAIRED; /* invert unpaired flag - observe unpaired quotes */ - /* add part before (and escape backslashes before quote) */ + /* + * Invert the unpaired flag - observe unpaired quotes + */ + + quote ^= CL_UNPAIRED; + + /* + * Add part before (and escape backslashes before quote). + */ + QuoteCmdLineBackslash(&ds, start, special, bspos); bspos = NULL; - /* escape using backslash */ + + /* + * Escape using backslash + */ + TclDStringAppendLiteral(&ds, "\\\""); start = ++special; continue; } - /* unpaired (escaped) quote causes special handling on meta-chars */ + + /* + * Unpaired (escaped) quote causes special handling on + * meta-chars + */ + if ((quote & CL_UNPAIRED) && strchr(specMetaChars, *special)) { - special = QuoteCmdLinePart(&ds, start, special, specMetaChars, &bspos); - /* start to current or first backslash */ + special = QuoteCmdLinePart(&ds, start, special, + specMetaChars, &bspos); + + /* + * Start to current or first backslash + */ + start = !bspos ? special : bspos; continue; } - /* special case for % - should be enclosed always (paired also) */ + + /* + * Special case for % - should be enclosed always (paired + * also) + */ + if (strchr(specMetaChars2, *special)) { - special = QuoteCmdLinePart(&ds, start, special, specMetaChars2, &bspos); - /* start to current or first backslash */ + special = QuoteCmdLinePart(&ds, start, special, + specMetaChars2, &bspos); + + /* + * Start to current or first backslash. + */ + start = !bspos ? special : bspos; continue; } - /* other not special (and not meta) character */ - bspos = NULL; /* reset last backslash possition (not interesting) */ + + /* + * Other not special (and not meta) character + */ + + bspos = NULL; /* reset last backslash position (not + * interesting) */ special++; } - /* rest of argument (and escape backslashes before closing main quote) */ + + /* + * Rest of argument (and escape backslashes before closing main + * quote) + */ + QuoteCmdLineBackslash(&ds, start, special, - (quote & CL_QUOTE) ? bspos : NULL); + (quote & CL_QUOTE) ? bspos : NULL); } if (quote & CL_QUOTE) { - /* end of argument (main closing quote-char) */ + /* + * End of argument (main closing quote-char) + */ + TclDStringAppendLiteral(&ds, "\""); } } @@ -2192,8 +2277,9 @@ PipeOutputProc( *errorCode = 0; /* avoid blocking if pipe-thread exited */ - timeout = ((infoPtr->flags & PIPE_ASYNC) || !TclPipeThreadIsAlive(&infoPtr->writeTI) - || TclInExit() || TclInThreadExit()) ? 0 : INFINITE; + timeout = ((infoPtr->flags & PIPE_ASYNC) + || !TclPipeThreadIsAlive(&infoPtr->writeTI) + || TclInExit() || TclInThreadExit()) ? 0 : INFINITE; if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { /* * The writer thread is blocked waiting for a write to complete and @@ -2379,6 +2465,7 @@ PipeWatchProc( infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; + if (!oldMask) { infoPtr->nextPtr = tsdPtr->firstPipePtr; tsdPtr->firstPipePtr = infoPtr; @@ -2848,7 +2935,7 @@ static DWORD WINAPI PipeReaderThread( LPVOID arg) { - TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; + TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *) arg; PipeInfo *infoPtr = NULL; /* access info only after success init/wait */ HANDLE handle = NULL; DWORD count, err; @@ -2859,13 +2946,14 @@ PipeReaderThread( * Wait for the main thread to signal before attempting to wait on the * pipe becoming readable. */ + if (!TclPipeThreadWaitForSignal(&pipeTI)) { /* exit */ break; } if (!infoPtr) { - infoPtr = (PipeInfo *)pipeTI->clientData; + infoPtr = (PipeInfo *) pipeTI->clientData; handle = ((WinFile *) infoPtr->readFile)->handle; } @@ -3211,7 +3299,7 @@ TclPipeThreadCreateTI( pipeTI = malloc(sizeof(TclPipeThreadInfo)); #else pipeTI = ckalloc(sizeof(TclPipeThreadInfo)); -#endif +#endif /* !_PTI_USE_CKALLOC */ pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL); pipeTI->state = PTI_STATE_IDLE; pipeTI->clientData = clientData; @@ -3250,40 +3338,64 @@ TclPipeThreadWaitForSignal( } wakeEvent = pipeTI->evWakeUp; + /* * Wait for the main thread to signal before attempting to do the work. */ - /* reset work state of thread (idle/waiting) */ - if ((state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_IDLE, PTI_STATE_WORK)) & (PTI_STATE_STOP|PTI_STATE_END)) { - /* end of work, check the owner of structure */ + /* + * Reset work state of thread (idle/waiting) + */ + + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_IDLE, + PTI_STATE_WORK); + if (state & (PTI_STATE_STOP|PTI_STATE_END)) { + /* + * End of work, check the owner of structure. + */ + goto end; } - /* entering wait */ - waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE); - if (waitResult != WAIT_OBJECT_0) { + /* + * Entering wait + */ + waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE); + if (waitResult != WAIT_OBJECT_0) { /* * The control event was not signaled, so end of work (unexpected * behaviour, main thread can be dead?). */ + goto end; } - /* try to set work state of thread */ - if ((state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_WORK, PTI_STATE_IDLE)) & (PTI_STATE_STOP|PTI_STATE_END)) { - /* end of work */ + /* + * Try to set work state of thread + */ + + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_WORK, + PTI_STATE_IDLE); + if (state & (PTI_STATE_STOP|PTI_STATE_END)) { + /* + * End of work + */ + goto end; } - /* signaled to work */ + /* + * Signaled to work. + */ + return 1; -end: - /* end of work, check the owner of the TI structure */ + end: + /* + * End of work, check the owner of the TI structure. + */ + if (state != PTI_STATE_STOP) { *pipeTIPtr = NULL; } else { @@ -3313,7 +3425,8 @@ end: int TclPipeThreadStopSignal( - TclPipeThreadInfo **pipeTIPtr, HANDLE wakeEvent) + TclPipeThreadInfo **pipeTIPtr, + HANDLE wakeEvent) { TclPipeThreadInfo *pipeTI = *pipeTIPtr; HANDLE evControl; @@ -3324,28 +3437,27 @@ TclPipeThreadStopSignal( } evControl = pipeTI->evControl; pipeTI->evWakeUp = wakeEvent; - switch ( - (state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_STOP, PTI_STATE_IDLE)) - ) { - - case PTI_STATE_IDLE: - - /* Thread was idle/waiting, notify it goes teardown */ - SetEvent(evControl); - - *pipeTIPtr = NULL; - - case PTI_STATE_DOWN: + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP, + PTI_STATE_IDLE); + switch (state) { + case PTI_STATE_IDLE: + /* + * Thread was idle/waiting, notify it goes teardown + */ + SetEvent(evControl); + *pipeTIPtr = NULL; + case PTI_STATE_DOWN: return 1; - default: - /* - * Thread works currently, we should try to end it, own the TI structure - * (because of possible sharing the joint structures with thread) - */ - InterlockedExchange(&pipeTI->state, PTI_STATE_END); + default: + /* + * Thread works currently, we should try to end it, own the TI + * structure (because of possible sharing the joint structures with + * thread) + */ + + InterlockedExchange(&pipeTI->state, PTI_STATE_END); break; } @@ -3388,46 +3500,63 @@ TclPipeThreadStop( pipeTI = *pipeTIPtr; evControl = pipeTI->evControl; pipeTI->evWakeUp = NULL; + /* * Try to sane stop the pipe worker, corresponding its current state */ - switch ( - (state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_STOP, PTI_STATE_IDLE)) - ) { - case PTI_STATE_IDLE: + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP, + PTI_STATE_IDLE); + switch (state) { + case PTI_STATE_IDLE: + /* + * Thread was idle/waiting, notify it goes teardown + */ - /* Thread was idle/waiting, notify it goes teardown */ - SetEvent(evControl); + SetEvent(evControl); - /* we don't need to wait for it at all, thread frees himself (owns the TI structure) */ - pipeTI = NULL; + /* + * We don't need to wait for it at all, thread frees himself (owns the + * TI structure) + */ + + pipeTI = NULL; break; - case PTI_STATE_STOP: - /* already stopped, thread frees himself (owns the TI structure) */ - pipeTI = NULL; + case PTI_STATE_STOP: + /* + * Already stopped, thread frees himself (owns the TI structure) + */ + + pipeTI = NULL; break; - case PTI_STATE_DOWN: - /* Thread already down (?), do nothing */ + case PTI_STATE_DOWN: + /* + * Thread already down (?), do nothing + */ - /* we don't need to wait for it, but we should free pipeTI */ - hThread = NULL; + /* + * We don't need to wait for it, but we should free pipeTI + */ + hThread = NULL; break; /* case PTI_STATE_WORK: */ - default: + default: + /* + * Thread works currently, we should try to end it, own the TI + * structure (because of possible sharing the joint structures with + * thread) + */ + + state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_END, + PTI_STATE_WORK); + if (state == PTI_STATE_DOWN) { /* - * Thread works currently, we should try to end it, own the TI structure - * (because of possible sharing the joint structures with thread) + * We don't need to wait for it, but we should free pipeTI */ - if ((state = InterlockedCompareExchange(&pipeTI->state, - PTI_STATE_END, PTI_STATE_WORK)) == PTI_STATE_DOWN - ) { - /* we don't need to wait for it, but we should free pipeTI */ - hThread = NULL; - }; + hThread = NULL; + } break; } @@ -3442,8 +3571,8 @@ TclPipeThreadStop( GetExitCodeThread(hThread, &exitCode); if (exitCode == STILL_ACTIVE) { - int inExit = (TclInExit() || TclInThreadExit()); + /* * Set the stop event so that if the pipe thread is blocked * somewhere, it may hereafter sane exit cleanly. @@ -3454,59 +3583,69 @@ TclPipeThreadStop( /* * Cancel all sync-IO of this thread (may be blocked there). */ + if (tclWinProcs.cancelSynchronousIo) { tclWinProcs.cancelSynchronousIo(hThread); } /* - * Wait at most 20 milliseconds for the reader thread to - * close (regarding TIP#398-fast-exit). + * Wait at most 20 milliseconds for the reader thread to close + * (regarding TIP#398-fast-exit). */ - /* if we want TIP#398-fast-exit. */ - if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) { + /* + * If we want TIP#398-fast-exit. + */ + if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) { /* - * The thread must be blocked waiting for the pipe to - * become readable in ReadFile(). There isn't a clean way - * to exit the thread from this condition. We should - * terminate the child process instead to get the reader - * thread to fall out of ReadFile with a FALSE. (below) is - * not the correct way to do this, but will stay here - * until a better solution is found. + * The thread must be blocked waiting for the pipe to become + * readable in ReadFile(). There isn't a clean way to exit the + * thread from this condition. We should terminate the child + * process instead to get the reader thread to fall out of + * ReadFile with a FALSE. (below) is not the correct way to do + * this, but will stay here until a better solution is found. * - * Note that we need to guard against terminating the - * thread while it is in the middle of Tcl_ThreadAlert - * because it won't be able to release the notifier lock. + * Note that we need to guard against terminating the thread + * while it is in the middle of Tcl_ThreadAlert because it + * won't be able to release the notifier lock. * - * Also note that terminating threads during their initialization or teardown phase - * may result in ntdll.dll's LoaderLock to remain locked indefinitely. - * This causes ntdll.dll's LdrpInitializeThread() to deadlock trying to acquire LoaderLock. - * LdrpInitializeThread() is executed within new threads to perform - * initialization and to execute DllMain() of all loaded dlls. - * As a result, all new threads are deadlocked in their initialization phase and never execute, - * even though CreateThread() reports successful thread creation. - * This results in a very weird process-wide behavior, which is extremely hard to debug. + * Also note that terminating threads during their + * initialization or teardown phase may result in ntdll.dll's + * LoaderLock to remain locked indefinitely. This causes + * ntdll.dll's LdrpInitializeThread() to deadlock trying to + * acquire LoaderLock. LdrpInitializeThread() is executed + * within new threads to perform initialization and to execute + * DllMain() of all loaded dlls. As a result, all new threads + * are deadlocked in their initialization phase and never + * execute, even though CreateThread() reports successful + * thread creation. This results in a very weird process-wide + * behavior, which is extremely hard to debug. * * THREADS SHOULD NEVER BE TERMINATED. Period. * - * But for now, check if thread is exiting, and if so, let it die peacefully. + * But for now, check if thread is exiting, and if so, let it + * die peacefully. * - * Also don't terminate if in exit (otherwise deadlocked in ntdll.dll's). + * Also don't terminate if in exit (otherwise deadlocked in + * ntdll.dll's). */ - if ( pipeTI->state != PTI_STATE_DOWN - && WaitForSingleObject(hThread, - inExit ? 50 : 5000) != WAIT_OBJECT_0 - ) { + if (pipeTI->state != PTI_STATE_DOWN + && WaitForSingleObject(hThread, + inExit ? 50 : 5000) != WAIT_OBJECT_0) { /* BUG: this leaks memory */ if (inExit || !TerminateThread(hThread, 0)) { - /* in exit or terminate fails, just give thread a chance to exit */ + /* + * in exit or terminate fails, just give thread a + * chance to exit + */ + if (InterlockedExchange(&pipeTI->state, PTI_STATE_STOP) != PTI_STATE_DOWN) { pipeTI = NULL; } - }; + } } } } @@ -3518,11 +3657,11 @@ TclPipeThreadStop( SetEvent(pipeTI->evWakeUp); } CloseHandle(pipeTI->evControl); - #ifndef _PTI_USE_CKALLOC +#ifndef _PTI_USE_CKALLOC free(pipeTI); - #else +#else ckfree(pipeTI); - #endif +#endif /* !_PTI_USE_CKALLOC */ } } @@ -3551,28 +3690,30 @@ TclPipeThreadExit( { LONG state; TclPipeThreadInfo *pipeTI = *pipeTIPtr; + /* * If state of thread was set to stop (exactly), we can sane free its info * structure, otherwise it is shared with main thread, so main thread will * own it. */ + if (!pipeTI) { return; } *pipeTIPtr = NULL; - if ((state = InterlockedExchange(&pipeTI->state, - PTI_STATE_DOWN)) == PTI_STATE_STOP) { + state = InterlockedExchange(&pipeTI->state, PTI_STATE_DOWN); + if (state == PTI_STATE_STOP) { CloseHandle(pipeTI->evControl); if (pipeTI->evWakeUp) { SetEvent(pipeTI->evWakeUp); } - #ifndef _PTI_USE_CKALLOC +#ifndef _PTI_USE_CKALLOC free(pipeTI); - #else +#else ckfree(pipeTI); /* be sure all subsystems used are finalized */ Tcl_FinalizeThread(); - #endif +#endif /* !_PTI_USE_CKALLOC */ } } -- cgit v0.12 From e42fbc68b9ea8a6b6209a348830ae0743a020c5c Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 23 Apr 2019 14:24:53 +0000 Subject: Added primitive to allow working coroutine deep introspection --- generic/tclBasic.c | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++ tests/coroutine.test | 75 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 148 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d252f00..1a48f44 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -158,6 +158,7 @@ static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; static Tcl_NRPostProc NRPostInvoke; +static Tcl_ObjCmdProc CoroTypeObjCmd; MODULE_SCOPE const TclStubs tclStubs; @@ -845,8 +846,11 @@ Tcl_CreateInterp(void) TclNRAssembleObjCmd, NULL, NULL); cmdPtr->compileProc = &TclCompileAssembleCmd; + /* Coroutine monkeybusiness */ Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, NRCoroInjectObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype", + CoroTypeObjCmd, NULL, NULL); /* Create an unsupported command for timerate */ Tcl_CreateObjCommand(interp, "::tcl::unsupported::timerate", @@ -8902,6 +8906,75 @@ TclNREvalList( /* *---------------------------------------------------------------------- * + * CoroTypeObjCmd -- + * + * Implementation of [::tcl::unsupported::corotype] command. + * + *---------------------------------------------------------------------- + */ + +static int +CoroTypeObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr; + CoroutineData *corPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "coroName"); + return TCL_ERROR; + } + + /* + * Look up the coroutine. + */ + + 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", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", + TclGetString(objv[1]), NULL); + return TCL_ERROR; + } + + /* + * An active coroutine is "active". Can't tell what it might do in the + * future. + */ + + corPtr = cmdPtr->objClientData; + if (!COR_IS_SUSPENDED(corPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1)); + return TCL_OK; + } + + /* + * Inactive coroutines are classified by the (effective) command used to + * suspend them, which matters when you're injecting a probe. + */ + + switch (corPtr->nargs) { + case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: + Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1)); + return TCL_OK; + case COROUTINE_ARGUMENTS_ARBITRARY: + Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1)); + return TCL_OK; + default: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unknown coroutine type", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * * NRCoroInjectObjCmd -- * * Implementation of [::tcl::unsupported::inject] command. diff --git a/tests/coroutine.test b/tests/coroutine.test index be2b624..df545f5 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -792,6 +792,81 @@ test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { interp delete slave set result } -result {inject-executed} + +test coroutine-9.1 {coro type} { + coroutine demo eval { + yield + yield "PHASE 1" + yieldto string cat "PHASE 2" + ::tcl::unsupported::corotype [info coroutine] + } + list [demo] [::tcl::unsupported::corotype demo] \ + [demo] [::tcl::unsupported::corotype demo] [demo] +} {{PHASE 1} yield {PHASE 2} yieldto active} +test coroutine-9.2 {coro type} -setup { + catch {rename nosuchcommand ""} +} -returnCodes error -body { + ::tcl::unsupported::corotype nosuchcommand +} -result {can only get coroutine type of a coroutine} +test coroutine-9.3 {coro type} -returnCodes error -body { + proc notacoroutine {} {} + ::tcl::unsupported::corotype notacoroutine +} -returnCodes error -cleanup { + rename notacoroutine {} +} -result {can only get coroutine type of a coroutine} + +test coroutine-10.1 {coroutine general introspection} -setup { + set i [interp create] +} -body { + $i eval { + # Make the introspection code + namespace path tcl::unsupported + proc probe {type var} { + upvar 1 $var v + set f [info frame] + incr f -1 + set result [list $v [dict get [info frame $f] proc]] + if {$type eq "yield"} { + tailcall yield $result + } else { + tailcall yieldto string cat $result + } + } + proc pokecoro {c var} { + inject $c probe [corotype $c] $var + $c + } + + # Coroutine implementations + proc cbody1 {} { + set val [info coroutine] + set accum {} + while {[set val [yield $val]] ne ""} { + lappend accum $val + set val ok + } + return $accum + } + proc cbody2 {} { + set val [info coroutine] + set accum {} + while {[llength [set val [yieldto string cat $val]]]} { + lappend accum {*}$val + set val ok + } + return $accum + } + + # Make the coroutines + coroutine c1 cbody1 + coroutine c2 cbody2 + list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \ + [c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \ + [c1] [c2] + } +} -cleanup { + interp delete $i +} -result {ok ok {abc ::cbody1} {{1 2 3} ::cbody2} ok ok {{abc def} ::cbody1} {{1 2 3 4 5 6} ::cbody2} {abc def} {1 2 3 4 5 6}} # cleanup unset lambda -- cgit v0.12 From a0465a4be2fa1aa32512bfe1671d7bd50754031a Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 24 Apr 2019 04:04:46 +0000 Subject: Add missed timer cleanup in tclIORChan.c/ReflectClose. --- generic/tclIORChan.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 477452b..cebc33f 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -1276,6 +1276,12 @@ ReflectClose( ckfree(tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } + if (rcPtr->readTimer != NULL) { + Tcl_DeleteTimerHandler(rcPtr->readTimer); + } + if (rcPtr->writeTimer != NULL) { + Tcl_DeleteTimerHandler(rcPtr->writeTimer); + } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return (result == TCL_OK) ? EOK : EINVAL; } -- cgit v0.12 From b21bc1e84f40c6e09c7d3fc3766a4106eab719d8 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Apr 2019 14:29:41 +0000 Subject: Plug memleak in [lpop] due to mishandling the unconventional recounting practices of TclLsetFlat(). --- generic/tclCmdIL.c | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index dd7136c..ef7a42c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2584,7 +2584,7 @@ Tcl_LpopObjCmd( /* Argument objects. */ { int listLen, result; - Tcl_Obj *elemPtr; + Tcl_Obj *elemPtr, *stored; Tcl_Obj *listPtr, **elemPtrs; if (objc < 2) { @@ -2622,6 +2622,7 @@ Tcl_LpopObjCmd( /* * Second, remove the element. + * TclLsetFlat adds a ref count which is handled. */ if (objc == 2) { @@ -2632,6 +2633,7 @@ Tcl_LpopObjCmd( if (result != TCL_OK) { return result; } + Tcl_IncrRefCount(listPtr); } else { listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); @@ -2640,8 +2642,9 @@ Tcl_LpopObjCmd( } } - listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); - if (listPtr == NULL) { + stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(listPtr); + if (stored == NULL) { return TCL_ERROR; } -- cgit v0.12 From 59a2032b5d7bb96e903eb711f742976d0c7f73db Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Apr 2019 19:29:18 +0000 Subject: Track memory lifetimes in the zip mount/unmount. --- generic/tclZipfs.c | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index c3887f0..4f2e43d 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -381,6 +381,7 @@ static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index, static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); +static void ZipfsExitHandler(ClientData clientData); static void ZipfsSetup(void); static int ZipChannelClose(void *instanceData, Tcl_Interp *interp); @@ -1629,6 +1630,8 @@ TclZipfs_Mount( { ZipFile *zf; +fprintf(stdout, "MOUNT CALLED\n"); fflush(stdout); + ReadLock(); if (!ZipFS.initialized) { ZipfsSetup(); @@ -1671,16 +1674,20 @@ TclZipfs_Mount( } } zf = attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); +fprintf(stdout, "ALLOC %p\n", zf); fflush(stdout); if (!zf) { if (interp) { Tcl_AppendResult(interp, "out of memory", (char *) NULL); Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); } +fprintf(stdout, "MOUNT FAIL A\n"); fflush(stdout); return TCL_ERROR; } if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) { +fprintf(stdout, "MOUNT FAIL B\n"); fflush(stdout); return TCL_ERROR; } +fprintf(stdout, "MOUNT END\n"); fflush(stdout); return ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname); } @@ -1806,8 +1813,11 @@ TclZipfs_Unmount( Tcl_DString dsm; int ret = TCL_OK, unmounted = 0; +fprintf(stdout, "UNMOUNT CALLED\n"); fflush(stdout); WriteLock(); +fprintf(stdout, "A\n"); fflush(stdout); if (!ZipFS.initialized) { +fprintf(stdout, "NOT INIT\n"); fflush(stdout); goto done; } @@ -1816,19 +1826,24 @@ TclZipfs_Unmount( * But an absolute name is needed as mount point here. */ +fprintf(stdout, "B\n"); fflush(stdout); Tcl_DStringInit(&dsm); mountPoint = CanonicalPath("", mountPoint, &dsm, 1); +fprintf(stdout, "C\n"); fflush(stdout); hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); /* don't report no-such-mount as an error */ if (!hPtr) { +fprintf(stdout, "D\n"); fflush(stdout); goto done; } +fprintf(stdout, "E\n"); fflush(stdout); zf = Tcl_GetHashValue(hPtr); if (zf->numOpen > 0) { ZIPFS_ERROR(interp, "filesystem is busy"); ret = TCL_ERROR; +fprintf(stdout, "BUSY\n"); fflush(stdout); goto done; } Tcl_DeleteHashEntry(hPtr); @@ -1844,6 +1859,7 @@ TclZipfs_Unmount( ckfree(z); } ZipFSCloseArchive(interp, zf); +fprintf(stdout, "FREE %p\n", zf); fflush(stdout); ckfree(zf); unmounted = 1; done: @@ -4837,6 +4853,18 @@ ZipfsAppHookFindTclInit( return TCL_ERROR; } +static void +ZipfsExitHandler( + ClientData clientData) +{ + char *mountpoint = (char *)clientData; + +fprintf(stdout, "UNMOUNT\n"); fflush(stdout); + if (TCL_OK != TclZipfs_Unmount(NULL, mountpoint)) { + Tcl_Panic("tried to unmount busy filesystem"); + } +} + /* *------------------------------------------------------------------------- * @@ -4859,19 +4887,26 @@ TclZipfs_AppHook( { char *archive; +fprintf(stdout, "HOOK CALLED\n"); fflush(stdout); Tcl_FindExecutable((*argvPtr)[0]); +fprintf(stdout, "FOUND\n"); fflush(stdout); archive = (char *) Tcl_GetNameOfExecutable(); +fprintf(stdout, "NAME: '%s'\n", archive); fflush(stdout); TclZipfs_Init(NULL); +fprintf(stdout, "INIT\n"); fflush(stdout); /* * Look for init.tcl in one of the locations mounted later in this * function. */ +fprintf(stdout, "START\n"); fflush(stdout); if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { int found; Tcl_Obj *vfsInitScript; +fprintf(stdout, "MOUNTED\n"); fflush(stdout); + TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); Tcl_IncrRefCount(vfsInitScript); if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { @@ -4960,6 +4995,9 @@ TclZipfs_AppHook( #endif /* _WIN32 */ #endif /* SUPPORT_BUILTIN_ZIP_INSTALL */ } +fprintf(stdout, "HANDLE\n"); fflush(stdout); + Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)ZIPFS_APP_MOUNT); +fprintf(stdout, "END\n"); fflush(stdout); return TCL_OK; } -- cgit v0.12 From 36073e502b5ea157b656d98ea6c86287f5fc855d Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 27 Apr 2019 07:19:49 +0000 Subject: Fix for de232b49f2, write-only nonblocking refchan and Tcl internal buffers. --- generic/tclIO.c | 38 +++++++++++++++++++++++++++++----- tests/io.test | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 96 insertions(+), 5 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index cf91307..4775820 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3463,6 +3463,11 @@ Tcl_Close( Tcl_ClearChannelHandlers(chan); /* + * Cancel any outstanding timer. + */ + Tcl_DeleteTimerHandler(statePtr->timer); + + /* * Invoke the registered close callbacks and delete their records. */ @@ -4447,6 +4452,8 @@ Write( } } + UpdateInterest(chanPtr); + return total; } @@ -8475,9 +8482,9 @@ UpdateInterest( * * - Tcl drops READABLE here, because it has data in its own * buffers waiting to be read by the extension. - * - A READABLE event is syntesized via timer. + * - A READABLE event is synthesized via timer. * - The OS still reports the EXCEPTION condition on the file. - * - And the extension gets the EXCPTION event first, and handles + * - And the extension gets the EXCEPTION event first, and handles * this as EOF. * * End result ==> Premature end of reading from a file. @@ -8503,6 +8510,16 @@ UpdateInterest( } } } + + if (statePtr->timer == NULL + && mask & TCL_WRITABLE + && GotFlag(statePtr, CHANNEL_NONBLOCKING)) { + + statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + ChannelTimerProc,chanPtr); + } + + ChanWatch(chanPtr, mask); } @@ -8531,6 +8548,19 @@ ChannelTimerProc( ChannelState *statePtr = chanPtr->state; /* State info for channel */ + Tcl_Preserve(statePtr); + statePtr->timer = NULL; + if (statePtr->interestMask & TCL_WRITABLE + && GotFlag(statePtr, CHANNEL_NONBLOCKING)) { + /* + * Restart the timer in case a channel handler reenters the event loop + * before UpdateInterest gets called by Tcl_NotifyChannel. + */ + statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + ChannelTimerProc,chanPtr); + Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE); + } + if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA) && (statePtr->interestMask & TCL_READABLE) && (statePtr->inQueueHead != NULL) @@ -8542,13 +8572,11 @@ ChannelTimerProc( statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, ChannelTimerProc,chanPtr); - Tcl_Preserve(statePtr); Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); - Tcl_Release(statePtr); } else { - statePtr->timer = NULL; UpdateInterest(chanPtr); } + Tcl_Release(statePtr); } /* diff --git a/tests/io.test b/tests/io.test index d42f59e..6470282 100644 --- a/tests/io.test +++ b/tests/io.test @@ -5963,6 +5963,69 @@ test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fi } {initial foo eof} close $f + +test chan-io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup { +} -constraints {stdio unixExecs fileevent openpipe} -body { + + namespace eval refchan { + namespace ensemble create + namespace export * + + + proc finalize {chan args} { + namespace delete c_$chan + } + + proc initialize {chan args} { + namespace eval c_$chan {} + namespace upvar c_$chan watching watching + set watching {} + list finalize initialize seek watch write + } + + + proc watch {chan args} { + namespace upvar c_$chan watching watching + foreach arg $args { + switch $arg { + write { + if {$arg ni $watching} { + lappend watching $arg + } + chan postevent $chan $arg + } + } + } + } + + + proc write {chan args} { + chan postevent $chan write + return 1 + } + } + set f [chan create w [namespace which refchan]] + chan configure $f -blocking 0 + set data "some data" + set x 0 + chan event $f writable [namespace code { + puts $f $data + incr count [string length $data] + if {$count > 262144} { + chan event $f writable {} + set x done + } + }] + after 10000 [namespace code { + set x timeout + }] + vwait [namespace which -variable x] + return $x +} -cleanup { + catch {chan close $f} +} -result done + + makeFile "foo bar" foo test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} { -- cgit v0.12 From b3676ba87cb737e7954dd8c6ad6515ae6a872674 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 29 Apr 2019 19:26:40 +0000 Subject: more WIP --- generic/tclZipfs.c | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 4f2e43d..0fd65a4 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -997,6 +997,7 @@ ZipFSFindTOC( if (interp) { Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "END_SIG", NULL); } +fprintf(stdout, "TOC FAIL 1\n"); fflush(stdout); goto error; } zf->numFiles = ZipReadShort(p + ZIP_CENTRAL_ENTS_OFFS); @@ -1009,6 +1010,7 @@ ZipFSFindTOC( if (interp) { Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); } +fprintf(stdout, "TOC FAIL 2\n"); fflush(stdout); goto error; } q = zf->data + ZipReadInt(p + ZIP_CENTRAL_DIRSTART_OFFS); @@ -1023,6 +1025,7 @@ ZipFSFindTOC( if (interp) { Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_DIR", NULL); } +fprintf(stdout, "TOC FAIL 3\n"); fflush(stdout); goto error; } zf->baseOffset = zf->passOffset = p - q; @@ -1036,6 +1039,7 @@ ZipFSFindTOC( if (interp) { Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_LEN", NULL); } +fprintf(stdout, "TOC FAIL 4\n"); fflush(stdout); goto error; } if (ZipReadInt(q) != ZIP_CENTRAL_HEADER_SIG) { @@ -1043,6 +1047,7 @@ ZipFSFindTOC( if (interp) { Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_SIG", NULL); } +fprintf(stdout, "TOC FAIL 5\n"); fflush(stdout); goto error; } pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); @@ -1113,6 +1118,7 @@ ZipFSOpenArchive( zf->passBuf[0] = 0; zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0); if (!zf->chan) { +fprintf(stdout, "OA FAIL 1\n"); fflush(stdout); return TCL_ERROR; } if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) { @@ -1189,10 +1195,12 @@ ZipFSOpenArchive( } #endif /* _WIN32 */ } +fprintf(stdout, "OA END\n"); fflush(stdout); return ZipFSFindTOC(interp, needZip, zf); error: ZipFSCloseArchive(interp, zf); +fprintf(stdout, "OA FAIL 2\n"); fflush(stdout); return TCL_ERROR; } @@ -1685,10 +1693,18 @@ fprintf(stdout, "MOUNT FAIL A\n"); fflush(stdout); } if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) { fprintf(stdout, "MOUNT FAIL B\n"); fflush(stdout); + ckfree(zf); + return TCL_ERROR; + } + if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname) + != TCL_OK) { +fprintf(stdout, "MOUNT FAIL C\n"); fflush(stdout); + ckfree(zf); return TCL_ERROR; } fprintf(stdout, "MOUNT END\n"); fflush(stdout); - return ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname); + Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)mountPoint); + return TCL_OK; } /* @@ -4907,6 +4923,8 @@ fprintf(stdout, "START\n"); fflush(stdout); fprintf(stdout, "MOUNTED\n"); fflush(stdout); +// Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)ZIPFS_APP_MOUNT); + TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); Tcl_IncrRefCount(vfsInitScript); if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { @@ -4968,6 +4986,8 @@ fprintf(stdout, "MOUNTED\n"); fflush(stdout); int found; Tcl_Obj *vfsInitScript; +// Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)ZIPFS_APP_MOUNT); + TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); Tcl_IncrRefCount(vfsInitScript); if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { @@ -4995,8 +5015,6 @@ fprintf(stdout, "MOUNTED\n"); fflush(stdout); #endif /* _WIN32 */ #endif /* SUPPORT_BUILTIN_ZIP_INSTALL */ } -fprintf(stdout, "HANDLE\n"); fflush(stdout); - Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)ZIPFS_APP_MOUNT); fprintf(stdout, "END\n"); fflush(stdout); return TCL_OK; } -- cgit v0.12 From 89c677d626e30f3439e20b018fc86d1f5f0c3246 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 1 May 2019 10:44:10 +0000 Subject: Check for BG_FLUSH_SCHEDULED inside ChannelTimerProc --- generic/tclIO.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4775820..118820a 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8511,7 +8511,7 @@ UpdateInterest( } } - if (statePtr->timer == NULL + if (!statePtr->timer && mask & TCL_WRITABLE && GotFlag(statePtr, CHANNEL_NONBLOCKING)) { @@ -8551,7 +8551,9 @@ ChannelTimerProc( Tcl_Preserve(statePtr); statePtr->timer = NULL; if (statePtr->interestMask & TCL_WRITABLE - && GotFlag(statePtr, CHANNEL_NONBLOCKING)) { + && GotFlag(statePtr, CHANNEL_NONBLOCKING) + && !GotFlag(statePtr, BG_FLUSH_SCHEDULED) + ) { /* * Restart the timer in case a channel handler reenters the event loop * before UpdateInterest gets called by Tcl_NotifyChannel. -- cgit v0.12 From d1faa9b2b18b2357320288e318922ba2522289e6 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 1 May 2019 13:52:26 +0000 Subject: now testing.... --- generic/tclZipfs.c | 44 +++++--------------------------------------- 1 file changed, 5 insertions(+), 39 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 0fd65a4..340aa91 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -997,7 +997,6 @@ ZipFSFindTOC( if (interp) { Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "END_SIG", NULL); } -fprintf(stdout, "TOC FAIL 1\n"); fflush(stdout); goto error; } zf->numFiles = ZipReadShort(p + ZIP_CENTRAL_ENTS_OFFS); @@ -1010,7 +1009,6 @@ fprintf(stdout, "TOC FAIL 1\n"); fflush(stdout); if (interp) { Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); } -fprintf(stdout, "TOC FAIL 2\n"); fflush(stdout); goto error; } q = zf->data + ZipReadInt(p + ZIP_CENTRAL_DIRSTART_OFFS); @@ -1025,7 +1023,6 @@ fprintf(stdout, "TOC FAIL 2\n"); fflush(stdout); if (interp) { Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_DIR", NULL); } -fprintf(stdout, "TOC FAIL 3\n"); fflush(stdout); goto error; } zf->baseOffset = zf->passOffset = p - q; @@ -1039,7 +1036,6 @@ fprintf(stdout, "TOC FAIL 3\n"); fflush(stdout); if (interp) { Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_LEN", NULL); } -fprintf(stdout, "TOC FAIL 4\n"); fflush(stdout); goto error; } if (ZipReadInt(q) != ZIP_CENTRAL_HEADER_SIG) { @@ -1047,7 +1043,6 @@ fprintf(stdout, "TOC FAIL 4\n"); fflush(stdout); if (interp) { Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_SIG", NULL); } -fprintf(stdout, "TOC FAIL 5\n"); fflush(stdout); goto error; } pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); @@ -1118,7 +1113,6 @@ ZipFSOpenArchive( zf->passBuf[0] = 0; zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0); if (!zf->chan) { -fprintf(stdout, "OA FAIL 1\n"); fflush(stdout); return TCL_ERROR; } if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) { @@ -1195,12 +1189,10 @@ fprintf(stdout, "OA FAIL 1\n"); fflush(stdout); } #endif /* _WIN32 */ } -fprintf(stdout, "OA END\n"); fflush(stdout); return ZipFSFindTOC(interp, needZip, zf); error: ZipFSCloseArchive(interp, zf); -fprintf(stdout, "OA FAIL 2\n"); fflush(stdout); return TCL_ERROR; } @@ -1295,6 +1287,7 @@ ZipFSCatalogFilesystem( *zf = *zf0; zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr); + Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)zf); zf->mountPointLen = strlen(zf->mountPoint); zf->nameLength = strlen(zipname); zf->name = ckalloc(zf->nameLength + 1); @@ -1638,8 +1631,6 @@ TclZipfs_Mount( { ZipFile *zf; -fprintf(stdout, "MOUNT CALLED\n"); fflush(stdout); - ReadLock(); if (!ZipFS.initialized) { ZipfsSetup(); @@ -1682,28 +1673,23 @@ fprintf(stdout, "MOUNT CALLED\n"); fflush(stdout); } } zf = attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); -fprintf(stdout, "ALLOC %p\n", zf); fflush(stdout); if (!zf) { if (interp) { Tcl_AppendResult(interp, "out of memory", (char *) NULL); Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); } -fprintf(stdout, "MOUNT FAIL A\n"); fflush(stdout); return TCL_ERROR; } if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) { -fprintf(stdout, "MOUNT FAIL B\n"); fflush(stdout); ckfree(zf); return TCL_ERROR; } if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname) != TCL_OK) { -fprintf(stdout, "MOUNT FAIL C\n"); fflush(stdout); ckfree(zf); return TCL_ERROR; } -fprintf(stdout, "MOUNT END\n"); fflush(stdout); - Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)mountPoint); + ckfree(zf); return TCL_OK; } @@ -1829,11 +1815,8 @@ TclZipfs_Unmount( Tcl_DString dsm; int ret = TCL_OK, unmounted = 0; -fprintf(stdout, "UNMOUNT CALLED\n"); fflush(stdout); WriteLock(); -fprintf(stdout, "A\n"); fflush(stdout); if (!ZipFS.initialized) { -fprintf(stdout, "NOT INIT\n"); fflush(stdout); goto done; } @@ -1842,24 +1825,19 @@ fprintf(stdout, "NOT INIT\n"); fflush(stdout); * But an absolute name is needed as mount point here. */ -fprintf(stdout, "B\n"); fflush(stdout); Tcl_DStringInit(&dsm); mountPoint = CanonicalPath("", mountPoint, &dsm, 1); -fprintf(stdout, "C\n"); fflush(stdout); hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); /* don't report no-such-mount as an error */ if (!hPtr) { -fprintf(stdout, "D\n"); fflush(stdout); goto done; } -fprintf(stdout, "E\n"); fflush(stdout); zf = Tcl_GetHashValue(hPtr); if (zf->numOpen > 0) { ZIPFS_ERROR(interp, "filesystem is busy"); ret = TCL_ERROR; -fprintf(stdout, "BUSY\n"); fflush(stdout); goto done; } Tcl_DeleteHashEntry(hPtr); @@ -1875,7 +1853,7 @@ fprintf(stdout, "BUSY\n"); fflush(stdout); ckfree(z); } ZipFSCloseArchive(interp, zf); -fprintf(stdout, "FREE %p\n", zf); fflush(stdout); + Tcl_DeleteExitHandler(ZipfsExitHandler, (ClientData)zf); ckfree(zf); unmounted = 1; done: @@ -4873,10 +4851,9 @@ static void ZipfsExitHandler( ClientData clientData) { - char *mountpoint = (char *)clientData; + ZipFile *zf = (ZipFile *)clientData; -fprintf(stdout, "UNMOUNT\n"); fflush(stdout); - if (TCL_OK != TclZipfs_Unmount(NULL, mountpoint)) { + if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) { Tcl_Panic("tried to unmount busy filesystem"); } } @@ -4903,27 +4880,19 @@ TclZipfs_AppHook( { char *archive; -fprintf(stdout, "HOOK CALLED\n"); fflush(stdout); Tcl_FindExecutable((*argvPtr)[0]); -fprintf(stdout, "FOUND\n"); fflush(stdout); archive = (char *) Tcl_GetNameOfExecutable(); -fprintf(stdout, "NAME: '%s'\n", archive); fflush(stdout); TclZipfs_Init(NULL); -fprintf(stdout, "INIT\n"); fflush(stdout); /* * Look for init.tcl in one of the locations mounted later in this * function. */ -fprintf(stdout, "START\n"); fflush(stdout); if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { int found; Tcl_Obj *vfsInitScript; -fprintf(stdout, "MOUNTED\n"); fflush(stdout); - -// Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)ZIPFS_APP_MOUNT); TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); Tcl_IncrRefCount(vfsInitScript); @@ -4986,8 +4955,6 @@ fprintf(stdout, "MOUNTED\n"); fflush(stdout); int found; Tcl_Obj *vfsInitScript; -// Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)ZIPFS_APP_MOUNT); - TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); Tcl_IncrRefCount(vfsInitScript); if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { @@ -5015,7 +4982,6 @@ fprintf(stdout, "MOUNTED\n"); fflush(stdout); #endif /* _WIN32 */ #endif /* SUPPORT_BUILTIN_ZIP_INSTALL */ } -fprintf(stdout, "END\n"); fflush(stdout); return TCL_OK; } -- cgit v0.12 From 057bc4e6404514a4256888ccfa1fa139e5276057 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 1 May 2019 14:25:40 +0000 Subject: duplicate test names --- tests/dict.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/dict.test b/tests/dict.test index 62590e7..e5284fc 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -2128,7 +2128,7 @@ test dict-27.8 {dict getwithdefault command} -returnCodes error -body { test dict-27.9 {dict getwithdefault command} -returnCodes error -body { dict getwithdefault {} {} } -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} -test dict-26.10 {dict getdef command} -returnCodes error -body { +test dict-27.10 {dict getdef command} -returnCodes error -body { dict getwithdefault {a b c} d e } -result {missing value to go with key} test dict-27.11 {dict getwithdefault command} -body { @@ -2149,7 +2149,7 @@ test dict-27.15 {dict getwithdefault command} -body { test dict-27.16 {dict getwithdefault command} -returnCodes error -body { $dict getwithdefault {a {b c d}} a b d } -result {missing value to go with key} -test dict-26.17 {dict getdef command} -returnCodes error -body { +test dict-27.17 {dict getdef command} -returnCodes error -body { $dict getwithdefault {a b c} d e } -result {missing value to go with key} -- cgit v0.12 From 915cd6b66789a552437299e9047e9997c61461ca Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 1 May 2019 22:37:36 +0000 Subject: WIP --- generic/tclInt.h | 1 + generic/tclLink.c | 12 ++++++++++++ generic/tclNamesp.c | 7 +++++++ 3 files changed, 20 insertions(+) diff --git a/generic/tclInt.h b/generic/tclInt.h index 3db1264..ed087fe 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3105,6 +3105,7 @@ MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); +MODULE_SCOPE int TclNamespaceDeleted(Tcl_Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, const char *reason, int index); diff --git a/generic/tclLink.c b/generic/tclLink.c index 8096c25..1ebfe6a 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -27,6 +27,7 @@ typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ + Tcl_Namespace *nsPtr; /* Namespace containing Tcl variable */ Tcl_Obj *varName; /* Name of variable (must be global). This is * needed during trace callbacks, since the * actual variable may be aliased at that time @@ -170,6 +171,7 @@ Tcl_LinkVar( linkPtr = ckalloc(sizeof(Link)); linkPtr->interp = interp; + linkPtr->nsPtr = NULL; linkPtr->varName = Tcl_NewStringObj(varName, -1); Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; @@ -196,6 +198,11 @@ Tcl_LinkVar( LinkFree(linkPtr); return TCL_ERROR; } + + TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY, + &(linkPtr->nsPtr), + + code = Tcl_TraceVar2(interp, varName, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); @@ -362,6 +369,8 @@ Tcl_LinkArray( linkPtr->interp = interp; linkPtr->varName = Tcl_NewStringObj(varName, -1); Tcl_IncrRefCount(linkPtr->varName); + + objPtr = ObjValue(linkPtr); if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { @@ -1497,6 +1506,9 @@ static void LinkFree( Link *linkPtr) /* Structure describing linked variable. */ { + if (linkPtr->nsPtr) { + TclNsDecrRefCount((Namespace *)(linkPtr->nsPtr)); + } if (linkPtr->flags & LINK_ALLOC_ADDR) { ckfree(linkPtr->addr); } diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index b553880..7e18568 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1086,6 +1086,13 @@ Tcl_DeleteNamespace( } TclNsDecrRefCount(nsPtr); } + +int +TclNamespaceDeleted( + Tcl_Namespace *nsPtr) +{ + return (((Namespace *) nsPtr)->flags & NS_DYING) ? 1 : 0; +} /* *---------------------------------------------------------------------- -- cgit v0.12 From 7a0e892768a898897815256772a48fe456fb9e62 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 3 May 2019 14:57:04 +0000 Subject: leak plug completed --- generic/tclInt.h | 2 +- generic/tclLink.c | 17 ++++++++++++----- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index ed087fe..8453fba 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3105,7 +3105,7 @@ MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); -MODULE_SCOPE int TclNamespaceDeleted(Tcl_Namespace *nsPtr); +MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, const char *reason, int index); diff --git a/generic/tclLink.c b/generic/tclLink.c index 1ebfe6a..3bcfb72 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -27,7 +27,7 @@ typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ - Tcl_Namespace *nsPtr; /* Namespace containing Tcl variable */ + Namespace *nsPtr; /* Namespace containing Tcl variable */ Tcl_Obj *varName; /* Name of variable (must be global). This is * needed during trace callbacks, since the * actual variable may be aliased at that time @@ -159,6 +159,8 @@ Tcl_LinkVar( { Tcl_Obj *objPtr; Link *linkPtr; + Namespace *dummy; + const char *name; int code; linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, @@ -200,8 +202,8 @@ Tcl_LinkVar( } TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY, - &(linkPtr->nsPtr), - + &(linkPtr->nsPtr), &dummy, &dummy, &name); + linkPtr->nsPtr->refCount++; code = Tcl_TraceVar2(interp, varName, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, @@ -247,6 +249,8 @@ Tcl_LinkArray( { Tcl_Obj *objPtr; Link *linkPtr; + Namespace *dummy; + const char *name; int code; if (size < 1) { @@ -370,6 +374,9 @@ Tcl_LinkArray( linkPtr->varName = Tcl_NewStringObj(varName, -1); Tcl_IncrRefCount(linkPtr->varName); + TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY, + &(linkPtr->nsPtr), &dummy, &dummy, &name); + linkPtr->nsPtr->refCount++; objPtr = ObjValue(linkPtr); if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, @@ -756,7 +763,7 @@ LinkTraceProc( */ if (flags & TCL_TRACE_UNSETS) { - if (Tcl_InterpDeleted(interp)) { + if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) { Tcl_DecrRefCount(linkPtr->varName); LinkFree(linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { @@ -1507,7 +1514,7 @@ LinkFree( Link *linkPtr) /* Structure describing linked variable. */ { if (linkPtr->nsPtr) { - TclNsDecrRefCount((Namespace *)(linkPtr->nsPtr)); + TclNsDecrRefCount(linkPtr->nsPtr); } if (linkPtr->flags & LINK_ALLOC_ADDR) { ckfree(linkPtr->addr); -- cgit v0.12 From 8510dda2accfa5d28aadbf328145c295db975815 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 3 May 2019 15:15:21 +0000 Subject: missed bit of type revision. --- generic/tclNamesp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 7e18568..bbe357d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1089,9 +1089,9 @@ Tcl_DeleteNamespace( int TclNamespaceDeleted( - Tcl_Namespace *nsPtr) + Namespace *nsPtr) { - return (((Namespace *) nsPtr)->flags & NS_DYING) ? 1 : 0; + return (nsPtr->flags & NS_DYING) ? 1 : 0; } /* -- cgit v0.12 From 5ee08fdf00619e1d0d4852f2219e985b8c15f3b6 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 3 May 2019 18:50:13 +0000 Subject: memleak demo test --- tests/link.test | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/tests/link.test b/tests/link.test index 22a1fc2..96ebb4d 100644 --- a/tests/link.test +++ b/tests/link.test @@ -21,6 +21,17 @@ testConstraint testlink [llength [info commands testlink]] foreach i {int real bool string} { catch {unset $i} } + +test link-0.1 {leak test} {testlink} { + interp create i + load {} Tcltest i + i eval { + testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0 + namespace delete :: + } + interp delete i +} {} + test link-1.1 {reading C variables from Tcl} {testlink} { testlink delete testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 -- cgit v0.12 From cd6fdc6976b48b0fc7342a7aa28974a2794d802a Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 4 May 2019 07:10:34 +0000 Subject: Make sure we test [2c154a40be] explicitly. Part of [cc191552c] --- tests/basic.test | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/tests/basic.test b/tests/basic.test index 089a62b..0202679 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -968,6 +968,18 @@ test basic-48.24.$noComp {expansion: empty not canonical list, regression test, run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]} } -result [lrepeat 3 {}] -cleanup {unset -nocomplain a} +test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -setup { + unset -nocomplain ::CRLF + set ::CRLF "\r\n" +} -body { + # Force variant that turned up in Bug 2c154a40be as that's externally + # noticeable in an important downstream project. + run {scan [list {*}$::CRLF]x %c%c%c} +} -cleanup { + unset -nocomplain ::CRLF +} -result {120 {} {}} + + } ;# End of noComp loop test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { -- cgit v0.12 From 55b6550aaaa24d97ad6841977887a26b1ee8ea27 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 4 May 2019 14:49:58 +0000 Subject: =?UTF-8?q?Japanese=20Reiwa=20(=E4=BB=A4=E5=92=8C)=20era?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- library/msgs/ja.msg | 2 +- tests/clock.test | 22 ++++++++++++---------- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/library/msgs/ja.msg b/library/msgs/ja.msg index 2767665..cf70c2f 100644 --- a/library/msgs/ja.msg +++ b/library/msgs/ja.msg @@ -40,5 +40,5 @@ namespace eval ::tcl::clock { ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY\u5e74%m\u6708%d\u65e5" ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H\u6642%M\u5206%S\u79d2" ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY\u5e74%m\u6708%d\u65e5 (%a) %H\u6642%M\u5206%S\u79d2 %z" - ::msgcat::mcset ja LOCALE_ERAS "\u007b-9223372036854775808 \u897f\u66a6 0\u007d \u007b-3061011600 \u660e\u6cbb 1867\u007d \u007b-1812186000 \u5927\u6b63 1911\u007d \u007b-1357635600 \u662d\u548c 1925\u007d \u007b600220800 \u5e73\u6210 1988\u007d" + ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 \u897f\u66a6 0} {-3061011600 \u660e\u6cbb 1867} {-1812186000 \u5927\u6b63 1911} {-1357635600 \u662d\u548c 1925} {600220800 \u5e73\u6210 1988} {1556668800 \u4ee4\u548c 2018}" } diff --git a/tests/clock.test b/tests/clock.test index b17c543..8d73bf2 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -36707,16 +36707,18 @@ test clock-58.1 {clock l10n - Japanese localisation} {*}{ } -body { set trouble {} - foreach {date jdate} [list \ - 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 \ - 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 \ - 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 \ - 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 \ - 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 \ - 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 \ - 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 \ - 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 \ - ] { + foreach {date jdate} { + 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 + 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 + 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 + 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 + 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 + 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 + 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 + 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 + 2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5 + 2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5 + } { set status [catch { set secs [clock scan $date \ -timezone +0900 \ -- cgit v0.12 From 951df2e52aa490d31e63ab402c038a8f3370a904 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 4 May 2019 14:58:11 +0000 Subject: =?UTF-8?q?Japanese=20Reiwa=20(=E4=BB=A4=E5=92=8C)=20era?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- library/msgs/ja.msg | 2 +- tests/clock.test | 22 ++++++++++++---------- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/library/msgs/ja.msg b/library/msgs/ja.msg index 76b5fa4..dac690b 100644 --- a/library/msgs/ja.msg +++ b/library/msgs/ja.msg @@ -40,5 +40,5 @@ namespace eval ::tcl::clock { ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日" ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒" ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z" - ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988}" + ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988} {1556668800 令和 2018}" } diff --git a/tests/clock.test b/tests/clock.test index b17c543..8d73bf2 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -36707,16 +36707,18 @@ test clock-58.1 {clock l10n - Japanese localisation} {*}{ } -body { set trouble {} - foreach {date jdate} [list \ - 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 \ - 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 \ - 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 \ - 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 \ - 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 \ - 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 \ - 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 \ - 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 \ - ] { + foreach {date jdate} { + 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 + 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 + 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 + 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 + 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 + 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 + 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 + 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 + 2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5 + 2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5 + } { set status [catch { set secs [clock scan $date \ -timezone +0900 \ -- cgit v0.12 From 4909a5cc242fe037cd6318457a6219dd63e3f2a6 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 4 May 2019 18:25:40 +0000 Subject: Plug memleak when deleting a namespace destroys a linked Tcl var. --- generic/tclInt.h | 2 ++ generic/tclLink.c | 18 +++++++++++++++++- generic/tclNamesp.c | 34 ++++++++++++++++++++++++++++++++++ 3 files changed, 53 insertions(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index e37727d..57367fa 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2638,6 +2638,8 @@ MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); MODULE_SCOPE int TclNokia770Doubles(); +MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); +MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, const char *reason, int index); diff --git a/generic/tclLink.c b/generic/tclLink.c index 2dc2e47..7283d78 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -23,6 +23,7 @@ typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ + Namespace *nsPtr; /* Namespace containing Tcl variable */ Tcl_Obj *varName; /* Name of variable (must be global). This is * needed during trace callbacks, since the * actual variable may be aliased at that time @@ -114,6 +115,8 @@ Tcl_LinkVar( { Tcl_Obj *objPtr; Link *linkPtr; + Namespace *dummy; + const char *name; int code; linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, @@ -126,6 +129,7 @@ Tcl_LinkVar( linkPtr = (Link *) ckalloc(sizeof(Link)); linkPtr->interp = interp; + linkPtr->nsPtr = NULL; linkPtr->varName = Tcl_NewStringObj(varName, -1); Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; @@ -142,11 +146,17 @@ Tcl_LinkVar( ckfree((char *) linkPtr); return TCL_ERROR; } + + TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY, + &(linkPtr->nsPtr), &dummy, &dummy, &name); + linkPtr->nsPtr->refCount++; + code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); if (code != TCL_OK) { Tcl_DecrRefCount(linkPtr->varName); + TclNsDecrRefCount(linkPtr->nsPtr); ckfree((char *) linkPtr); } return code; @@ -186,6 +196,9 @@ Tcl_UnlinkVar( TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); Tcl_DecrRefCount(linkPtr->varName); + if (linkPtr->nsPtr) { + TclNsDecrRefCount(linkPtr->nsPtr); + } ckfree((char *) linkPtr); } @@ -279,8 +292,11 @@ LinkTraceProc( */ if (flags & TCL_TRACE_UNSETS) { - if (Tcl_InterpDeleted(interp)) { + if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) { Tcl_DecrRefCount(linkPtr->varName); + if (linkPtr->nsPtr) { + TclNsDecrRefCount(linkPtr->nsPtr); + } ckfree((char *) linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index a2e625e..a476b4e 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1060,6 +1060,13 @@ Tcl_DeleteNamespace( } } } + +int +TclNamespaceDeleted( + Namespace *nsPtr) +{ + return (nsPtr->flags & NS_DYING) ? 1 : 0; +} /* *---------------------------------------------------------------------- @@ -1240,6 +1247,33 @@ NamespaceFree( /* *---------------------------------------------------------------------- * + * TclNsDecrRefCount -- + * + * Drops a reference to a namespace and frees it if the namespace has + * been deleted and the last reference has just been dropped. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclNsDecrRefCount( + Namespace *nsPtr) +{ + nsPtr->refCount--; + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + NamespaceFree(nsPtr); + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_Export -- * * Makes all the commands matching a pattern available to later be -- cgit v0.12 From f218c1f1ebf34e6f5820d88789b16104c954a071 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 7 May 2019 07:19:10 +0000 Subject: =?UTF-8?q?(cherry-pick=20from8.6):=20Japanese=20Reiwa=20(?= =?UTF-8?q?=E4=BB=A4=E5=92=8C)=20era?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- library/msgs/ja.msg | 2 +- tests/clock.test | 22 ++++++++++++---------- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/library/msgs/ja.msg b/library/msgs/ja.msg index 2767665..cf70c2f 100644 --- a/library/msgs/ja.msg +++ b/library/msgs/ja.msg @@ -40,5 +40,5 @@ namespace eval ::tcl::clock { ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY\u5e74%m\u6708%d\u65e5" ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H\u6642%M\u5206%S\u79d2" ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY\u5e74%m\u6708%d\u65e5 (%a) %H\u6642%M\u5206%S\u79d2 %z" - ::msgcat::mcset ja LOCALE_ERAS "\u007b-9223372036854775808 \u897f\u66a6 0\u007d \u007b-3061011600 \u660e\u6cbb 1867\u007d \u007b-1812186000 \u5927\u6b63 1911\u007d \u007b-1357635600 \u662d\u548c 1925\u007d \u007b600220800 \u5e73\u6210 1988\u007d" + ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 \u897f\u66a6 0} {-3061011600 \u660e\u6cbb 1867} {-1812186000 \u5927\u6b63 1911} {-1357635600 \u662d\u548c 1925} {600220800 \u5e73\u6210 1988} {1556668800 \u4ee4\u548c 2018}" } diff --git a/tests/clock.test b/tests/clock.test index a697714..f6cba28 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -36699,16 +36699,18 @@ test clock-58.1 {clock l10n - Japanese localisation} {*}{ } -body { set trouble {} - foreach {date jdate} [list \ - 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 \ - 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 \ - 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 \ - 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 \ - 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 \ - 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 \ - 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 \ - 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 \ - ] { + foreach {date jdate} { + 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 + 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 + 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 + 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 + 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 + 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 + 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 + 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 + 2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5 + 2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5 + } { set status [catch { set secs [clock scan $date \ -timezone +0900 \ -- cgit v0.12 From 9d68b2dbd19c376370345b938be80f15aab880d4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 May 2019 06:53:00 +0000 Subject: Make more clear that TCL_INDEX_END|TCL_INDEX_NONE not necessary are int's (in Tcl 9 they are not). Eliminate use of (local) list_index_t type --- generic/tclCmdIL.c | 40 +++++++++++++++++++--------------------- generic/tclCompCmdsGR.c | 48 ++++++++++++++++++++++++------------------------ generic/tclCompCmdsSZ.c | 36 ++++++++++++++++++------------------ generic/tclIORChan.c | 8 ++++---- generic/tclInt.h | 2 +- 5 files changed, 66 insertions(+), 68 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index ef7a42c..c11534e 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -56,7 +56,7 @@ typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t); * The following structure is used to pass this information. */ -typedef struct SortInfo { +typedef struct { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* values * defined below. */ @@ -566,7 +566,7 @@ InfoBodyCmd( * the object do not invalidate the internal rep. */ - bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes); + bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes); Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes)); return TCL_OK; } @@ -1047,7 +1047,7 @@ InfoErrorStackCmd( target = interp; if (objc == 2) { - target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); + target = Tcl_GetSlave(interp, TclGetString(objv[1])); if (target == NULL) { return TCL_ERROR; } @@ -2155,7 +2155,7 @@ InfoCmdTypeCmd( Tcl_WrongNumArgs(interp, 1, objv, "commandName"); return TCL_ERROR; } - command = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, + command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL, TCL_LEAVE_ERR_MSG); if (command == NULL) { return TCL_ERROR; @@ -2231,7 +2231,7 @@ Tcl_JoinObjCmd( joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); - (void) Tcl_GetStringFromObj(joinObjPtr, &length); + (void) TclGetStringFromObj(joinObjPtr, &length); if (length == 0) { resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); } else { @@ -2721,15 +2721,13 @@ Tcl_LrangeObjCmd( *---------------------------------------------------------------------- */ -typedef int list_index_t; - static int LremoveIndexCompare( const void *el1Ptr, const void *el2Ptr) { - list_index_t idx1 = *((const list_index_t *) el1Ptr); - list_index_t idx2 = *((const list_index_t *) el2Ptr); + int idx1 = *((const int *) el1Ptr); + int idx2 = *((const int *) el2Ptr); /* * This will put the larger element first. @@ -2746,7 +2744,7 @@ Tcl_LremoveObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int i, idxc; - list_index_t listLen, *idxv, prevIdx, first, num; + int listLen, *idxv, prevIdx, first, num; Tcl_Obj *listObj; /* @@ -2768,7 +2766,7 @@ Tcl_LremoveObjCmd( Tcl_SetObjResult(interp, listObj); return TCL_OK; } - idxv = ckalloc((objc - 2) * sizeof(list_index_t)); + idxv = ckalloc((objc - 2) * sizeof(int)); for (i = 2; i < objc; i++) { if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1, &idxv[i - 2]) != TCL_OK) { @@ -2783,7 +2781,7 @@ Tcl_LremoveObjCmd( */ if (idxc > 1) { - qsort(idxv, idxc, sizeof(list_index_t), LremoveIndexCompare); + qsort(idxv, idxc, sizeof(int), LremoveIndexCompare); } /* @@ -2796,7 +2794,7 @@ Tcl_LremoveObjCmd( num = 0; first = listLen; for (i = 0, prevIdx = -1 ; i < idxc ; i++) { - list_index_t idx = idxv[i]; + int idx = idxv[i]; /* * Repeated index and sanity check. @@ -3003,7 +3001,7 @@ Tcl_LreplaceObjCmd( return result; } - if (first < 0) { + if (first == TCL_INDEX_NONE) { first = 0; } if (first > listLen) { @@ -3382,10 +3380,10 @@ Tcl_LsearchObjCmd( TCL_INDEX_NONE, &encoded) != TCL_OK) { result = TCL_ERROR; } - if (encoded == TCL_INDEX_NONE) { + if (encoded == (int)TCL_INDEX_NONE) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" cannot select an element " - "from any list", Tcl_GetString(indices[j]))); + "from any list", TclGetString(indices[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" "OUTOFRANGE", NULL); result = TCL_ERROR; @@ -3515,8 +3513,8 @@ Tcl_LsearchObjCmd( if (result != TCL_OK) { goto done; } - if (start < 0) { - start = 0; + if (start == TCL_INDEX_NONE) { + start = TCL_INDEX_START; } /* @@ -4099,10 +4097,10 @@ Tcl_LsortObjCmd( int result = TclIndexEncode(interp, indexv[j], TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded); - if ((result == TCL_OK) && (encoded == TCL_INDEX_NONE)) { + if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" cannot select an element " - "from any list", Tcl_GetString(indexv[j]))); + "from any list", TclGetString(indexv[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" "OUTOFRANGE", NULL); result = TCL_ERROR; @@ -4859,7 +4857,7 @@ SelectObjFromSublist( return NULL; } if (currentObj == NULL) { - if (index == TCL_INDEX_NONE) { + if (index == (int)TCL_INDEX_NONE) { index = TCL_INDEX_END - infoPtr->indexv[i]; Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( "element end-%d missing from sublist \"%s\"", diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 441611e..a8a85f8 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -433,7 +433,7 @@ TclCompileIfCmd( jumpFalseDist += 3; TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else { - Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); + Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode); } } } @@ -606,7 +606,7 @@ TclCompileInfoCommandsCmd( if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { goto notCompilable; } - bytes = Tcl_GetString(objPtr); + bytes = TclGetString(objPtr); /* * We require that the argument start with "::" and not have any of "*\[?" @@ -1038,7 +1038,7 @@ TclCompileLassignCmd( */ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; } @@ -1243,7 +1243,7 @@ TclCompileListCmd( if (concat && numWords == 2) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); } return TCL_OK; } @@ -1319,7 +1319,7 @@ TclCompileLrangeCmd( tokenPtr = TokenAfter(listTokenPtr); if ((TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, - &idx1) != TCL_OK) || (idx1 == TCL_INDEX_NONE)) { + &idx1) != TCL_OK) || (idx1 == (int)TCL_INDEX_NONE)) { return TCL_ERROR; } /* @@ -1408,7 +1408,7 @@ TclCompileLinsertCmd( CompileWord(envPtr, listTokenPtr, interp, 1); if (parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; } @@ -1418,10 +1418,10 @@ TclCompileLinsertCmd( } TclEmitInstInt4( INST_LIST, i - 3, envPtr); - if (idx == TCL_INDEX_START) { + if (idx == (int)TCL_INDEX_START) { TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else if (idx == TCL_INDEX_END) { + } else if (idx == (int)TCL_INDEX_END) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { /* @@ -1436,7 +1436,7 @@ TclCompileLinsertCmd( * differ in their interpretation of the "end" index. */ - if (idx < TCL_INDEX_END) { + if (idx < (int)TCL_INDEX_END) { idx++; } TclEmitInstInt4( INST_OVER, 1, envPtr); @@ -1444,7 +1444,7 @@ TclCompileLinsertCmd( TclEmitInt4( idx - 1, envPtr); TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); } @@ -1505,14 +1505,14 @@ TclCompileLreplaceCmd( * we must defer to direct evaluation. */ - if (idx1 == TCL_INDEX_NONE) { - suffixStart = TCL_INDEX_NONE; - } else if (idx2 == TCL_INDEX_NONE) { + if (idx1 == (int)TCL_INDEX_NONE) { + suffixStart = (int)TCL_INDEX_NONE; + } else if (idx2 == (int)TCL_INDEX_NONE) { suffixStart = idx1; - } else if (idx2 == TCL_INDEX_END) { - suffixStart = TCL_INDEX_NONE; - } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END)) - || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) { + } else if (idx2 == (int)TCL_INDEX_END) { + suffixStart = (int)TCL_INDEX_NONE; + } else if (((idx2 < (int)TCL_INDEX_END) && (idx1 <= (int)TCL_INDEX_END)) + || ((idx2 >= (int)TCL_INDEX_START) && (idx1 >= (int)TCL_INDEX_START))) { suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1; } else { return TCL_ERROR; @@ -1546,11 +1546,11 @@ TclCompileLreplaceCmd( * and canonicalization side effects. */ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; } - if (idx1 != TCL_INDEX_START) { + if (idx1 != (int)TCL_INDEX_START) { /* Prefix may not be empty; generate bytecode to push it */ if (emptyPrefix) { TclEmitOpcode( INST_DUP, envPtr); @@ -1570,7 +1570,7 @@ TclCompileLreplaceCmd( TclEmitInstInt4( INST_REVERSE, 2, envPtr); } - if (suffixStart == TCL_INDEX_NONE) { + if (suffixStart == (int)TCL_INDEX_NONE) { TclEmitOpcode( INST_POP, envPtr); if (emptyPrefix) { PushStringLiteral(envPtr, ""); @@ -1578,7 +1578,7 @@ TclCompileLreplaceCmd( } else { /* Suffix may not be empty; generate bytecode to push it */ TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); if (!emptyPrefix) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } @@ -2295,8 +2295,8 @@ TclCompileRegsubCmd( if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } - if (Tcl_GetString(patternObj)[0] == '-') { - if (strcmp(Tcl_GetString(patternObj), "--") != 0 + if (TclGetString(patternObj)[0] == '-') { + if (strcmp(TclGetString(patternObj), "--") != 0 || parsePtr->numWords == 5) { goto done; } @@ -2361,7 +2361,7 @@ TclCompileRegsubCmd( bytes++; } isSimpleGlob: - for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { + for (bytes = TclGetString(replacementObj); *bytes; bytes++) { switch (*bytes) { case '\\': case '&': goto done; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 4663fac..83ade0b 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -482,16 +482,16 @@ TclCompileStringInsertCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 3); - if (idx == TCL_INDEX_START) { + if (idx == (int)TCL_INDEX_START) { /* Prepend the insertion string */ OP4( REVERSE, 2); OP1( STR_CONCAT1, 2); - } else if (idx == TCL_INDEX_END) { + } else if (idx == (int)TCL_INDEX_END) { /* Append the insertion string */ OP1( STR_CONCAT1, 2); } else { /* Prefix + insertion + suffix */ - if (idx < TCL_INDEX_END) { + if (idx < (int)TCL_INDEX_END) { /* See comments in compiler for [linsert]. */ idx++; } @@ -821,7 +821,7 @@ TclCompileStringMatchCmd( } str = tokenPtr[1].start; length = tokenPtr[1].size; - if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) { + if ((length <= 1) || strncmp(str, "-nocase", length)) { /* * Fail at run time, not in compilation. */ @@ -1012,7 +1012,7 @@ TclCompileStringRangeCmd( * the string the same as the start of the string. */ - if (idx1 == TCL_INDEX_NONE) { + if (idx1 == (int)TCL_INDEX_NONE) { /* [string range $s end+1 $last] must be empty string */ OP( POP); PUSH( ""); @@ -1027,7 +1027,7 @@ TclCompileStringRangeCmd( * Token parsed as an index expression. We treat all indices after * the string the same as the end of the string. */ - if (idx2 == TCL_INDEX_NONE) { + if (idx2 == (int)TCL_INDEX_NONE) { /* [string range $s $first -1] must be empty string */ OP( POP); PUSH( ""); @@ -1105,8 +1105,8 @@ TclCompileStringReplaceCmd( * compile direct to bytecode implementing the no-op. */ - if ((last == TCL_INDEX_NONE) /* Know (last < 0) */ - || (first == TCL_INDEX_NONE) /* Know (first > end) */ + if ((last == (int)TCL_INDEX_NONE) /* Know (last < 0) */ + || (first == (int)TCL_INDEX_NONE) /* Know (first > end) */ /* * Tricky to determine when runtime (last < first) can be @@ -1117,7 +1117,7 @@ TclCompileStringReplaceCmd( * (last <= TCL_INDEX END) && (last < first) => ACCEPT * else => cannot tell REJECT */ - || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END) + || ((first <= (int)TCL_INDEX_END) && (last <= (int)TCL_INDEX_END) && (last < first)) /* Know (last < first) */ /* * (first == TCL_INDEX_NONE) && @@ -1128,7 +1128,7 @@ TclCompileStringReplaceCmd( * (last <= TCL_INDEX_END) => cannot tell REJECT * else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT */ - || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START) + || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START) && (last < first))) { /* Know (last < first) */ if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); @@ -1179,7 +1179,7 @@ TclCompileStringReplaceCmd( * getting a guarantee that first <= last. */ - if ((first == TCL_INDEX_START) && (last >= TCL_INDEX_START)) { + if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) { /* empty prefix */ tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); @@ -1187,13 +1187,13 @@ TclCompileStringReplaceCmd( if (last == INT_MAX) { OP( POP); /* Pop original */ } else { - OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); OP1( STR_CONCAT1, 2); } return TCL_OK; } - if ((last == TCL_INDEX_NONE) && (first <= TCL_INDEX_END)) { + if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) { OP44( STR_RANGE_IMM, 0, first-1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); @@ -1210,19 +1210,19 @@ TclCompileStringReplaceCmd( * are harmless when they are replaced by another empty string. */ - if (first == TCL_INDEX_START) { + if (first == (int)TCL_INDEX_START) { /* empty prefix - build suffix only */ - if (last == TCL_INDEX_END) { + if (last == (int)TCL_INDEX_END) { /* empty suffix too => empty result */ OP( POP); /* Pop original */ PUSH ( ""); return TCL_OK; } - OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); return TCL_OK; } else { - if (last == TCL_INDEX_END) { + if (last == (int)TCL_INDEX_END) { /* empty suffix - build prefix only */ OP44( STR_RANGE_IMM, 0, first-1); return TCL_OK; @@ -1230,7 +1230,7 @@ TclCompileStringReplaceCmd( OP( DUP); OP44( STR_RANGE_IMM, 0, first-1); OP4( REVERSE, 2); - OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); OP1( STR_CONCAT1, 2); return TCL_OK; } diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index cebc33f..23049fb 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -114,15 +114,15 @@ typedef struct { int dead; /* Boolean signal that some operations * should no longer be attempted. */ - Tcl_TimerToken readTimer; /* + Tcl_TimerToken readTimer; /* A token for the timer that is scheduled in order to call Tcl_NotifyChannel when the - channel is readable + channel is readable */ - Tcl_TimerToken writeTimer; /* + Tcl_TimerToken writeTimer; /* A token for the timer that is scheduled in order to call Tcl_NotifyChannel when the - channel is writable + channel is writable */ /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 8453fba..e76b2a8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4545,7 +4545,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (bignum).alloc = (bignumPayload >> 15) & 0x7fff; \ (bignum).used = bignumPayload & 0x7fff; \ } \ - } while (0) + } while (0) /* *---------------------------------------------------------------- -- cgit v0.12 From 5419f8e0ba508cfedb5c68a88aee618e25e17983 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 8 May 2019 18:06:23 +0000 Subject: For historical/hysterical reasons, the (unused??) public routines Tcl_UpVar() and Tcl_UpVar2() accept random garbage for a level argument (treat it as 1) while the [upvar] command has come to reject such values as bad levels. Add a test to call it to our attention if we ever change that disparity so we do so only on purpose. --- tests/upvar.test | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/upvar.test b/tests/upvar.test index 5ea870d..437f422 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -356,6 +356,10 @@ test upvar-8.11 {upvar will not create a variable that looks like an array} -set test upvar-9.1 {Tcl_UpVar2 procedure} testupvar { list [catch {testupvar xyz a {} x global} msg] $msg } {1 {bad level "xyz"}} +test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar { + apply {{} {testupvar xyz a {} x local; set x foo}} + set a +} foo test upvar-9.2 {Tcl_UpVar2 procedure} testupvar { catch {unset a} catch {unset x} -- cgit v0.12 From b1139d3d2099aad8ad1981deaa0f689e1b4c322a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 May 2019 20:06:34 +0000 Subject: If compiling with -DTCL_NO_DEPRECATED, make Tcl_GetStringResult() a macro. This opens up one more simplification for Tcl 9. Compile the load-test dll's/so's with -DTCL_NO_DEPRECATED --- generic/tclDecls.h | 2 ++ generic/tclResult.c | 6 +----- generic/tclStubInit.c | 2 ++ unix/dltest/Makefile.in | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3b67796..3d40bef 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3986,6 +3986,8 @@ extern const TclStubs *tclStubsPtr; #define Tcl_AddObjErrorInfo(interp, message, length) \ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) #ifdef TCL_NO_DEPRECATED +#undef Tcl_GetStringResult +#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) #undef Tcl_Eval #define Tcl_Eval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, -1, 0) diff --git a/generic/tclResult.c b/generic/tclResult.c index 5a03421..4d14f01 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -464,7 +464,6 @@ Tcl_SetResult( ResetObjResult(iPtr); } -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -488,9 +487,6 @@ Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { Interp *iPtr = (Interp *) interp; -#ifdef TCL_NO_DEPRECATED - return Tcl_GetString(iPtr->objResultPtr); -#else /* * If the string result is empty, move the object result to the string * result, then reset the object result. @@ -501,8 +497,8 @@ Tcl_GetStringResult( TCL_VOLATILE); } return iPtr->result; -#endif } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2eb2259..8945e0b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -368,6 +368,8 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig # define Tcl_Eval 0 # undef Tcl_GlobalEval # define Tcl_GlobalEval 0 +# undef Tcl_GetStringResult +# define Tcl_GetStringResult 0 # undef Tcl_SaveResult # define Tcl_SaveResult 0 # undef Tcl_RestoreResult diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 25b9376..500bf97 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -17,7 +17,7 @@ TCL_VERSION= @TCL_VERSION@ CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ -CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ +CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ -DTCL_NO_DEPRECATED=1 LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ -- cgit v0.12