diff options
61 files changed, 1465 insertions, 498 deletions
diff --git a/doc/BoolObj.3 b/doc/BoolObj.3 index c05048c..47a2189 100644 --- a/doc/BoolObj.3 +++ b/doc/BoolObj.3 @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- store/retrieve boolean value in a Tcl_Obj +Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj, Tcl_GetBoolFromObj \- store/retrieve boolean value in a Tcl_Obj .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -21,6 +21,9 @@ Tcl_Obj * .sp int \fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, intPtr\fR) +.sp +int +\fBTcl_GetBoolFromObj\fR(\fIinterp, objPtr, flags. charPtr\fR) .SH ARGUMENTS .AS Tcl_Interp intValue in/out .AP int intValue in @@ -35,6 +38,13 @@ unless \fIinterp\fR is NULL. .AP int *intPtr out Points to place where \fBTcl_GetBooleanFromObj\fR stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. +.AP char *charPtr out +Points to place where \fBTcl_GetBoolFromObj\fR +stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. +.AP int flags in +0 or TCL_NULL_OK. If TCL_NULL_OK +is used, then the empty string or NULL will result in \fBTcl_GetBoolFromObj\fR +return TCL_OK, the *charPtr filled with the value \fB'\exFF'\fR; .BE .SH DESCRIPTION @@ -76,6 +86,11 @@ fields of \fI*objPtr\fR so that future calls to \fBTcl_GetBooleanFromObj\fR on the same \fIobjPtr\fR can be performed more efficiently. .PP +\fBTcl_GetBoolFromObj\fR functions almost the same as +\fBTcl_GetBooleanFromObj\fR, but it has an additional parameter +\fBflags\fR, which can be used to specify whether the empty +string or NULL is accepted as valid. +.PP Note that the routines \fBTcl_GetBooleanFromObj\fR and \fBTcl_GetBoolean\fR are not functional equivalents. The set of values for which \fBTcl_GetBooleanFromObj\fR diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index 1169c6c..176b0b2 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -54,7 +54,7 @@ Null-terminated string describing what is being looked up, such as .AP int flags in OR-ed combination of bits providing additional information for operation. The only bits that are currently defined are \fBTCL_EXACT\fR -, \fBTCL_INDEX_TEMP_TABLE\fR, and \fBTCL_INDEX_NULL_OK\fR. +, \fBTCL_INDEX_TEMP_TABLE\fR, and \fBTCL_NULL_OK\fR. .AP enum|char|short|int|long *indexPtr out If not (int *)NULL, the index of the string in \fItablePtr\fR that matches the value of \fIobjPtr\fR is returned here. The variable can @@ -93,7 +93,7 @@ operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries in \fItablePtr\fR are static: they must not change between invocations. This caching mechanism can be disallowed by specifying the \fBTCL_INDEX_TEMP_TABLE\fR flag. -If the \fBTCL_INDEX_NULL_OK\fR flag was specified, objPtr is allowed +If the \fBTCL_NULL_OK\fR flag was specified, objPtr is allowed to be NULL or the empty string. The resulting index is -1. Otherwise, if the value of \fIobjPtr\fR is the empty string, \fBTcl_GetIndexFromObj\fR will treat it as a non-matching value diff --git a/doc/GetInt.3 b/doc/GetInt.3 index 4b486de..f15c12d 100644 --- a/doc/GetInt.3 +++ b/doc/GetInt.3 @@ -22,6 +22,9 @@ int .sp int \fBTcl_GetBoolean\fR(\fIinterp, src, intPtr\fR) +.sp +int +\fBTcl_GetBool\fR(\fIinterp, src, flags, charPtr\fR) .SH ARGUMENTS .AS Tcl_Interp *doublePtr out .AP Tcl_Interp *interp in @@ -33,6 +36,12 @@ Points to place to store integer value converted from \fIsrc\fR. .AP double *doublePtr out Points to place to store double-precision floating-point value converted from \fIsrc\fR. +.AP char *charPtr out +Points to place to store boolean value (0 or 1) value converted from \fIsrc\fR. +.AP int flags in +0 or TCL_NULL_OK. If TCL_NULL_OK +is used, then the empty string or NULL will result in \fBTcl_GetBool\fR +return TCL_OK, the *charPtr filled with the value \fB'\exFF'\fR; .BE .SH DESCRIPTION @@ -97,6 +106,10 @@ If \fIsrc\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR, then 1 is stored at \fI*intPtr\fR. Any of these values may be abbreviated, and upper-case spellings are also acceptable. +.PP +\fBTcl_GetBool\fR functions almost the same as \fBTcl_GetBoolean\fR, +but it has an additional parameter \fBflags\fR, which can be used +to specify whether the empty string or NULL is accepted as valid. .SH KEYWORDS boolean, conversion, double, floating-point, integer diff --git a/doc/SaveResult.3 b/doc/SaveInterpState.3 index 804f9ec..804f9ec 100644 --- a/doc/SaveResult.3 +++ b/doc/SaveInterpState.3 diff --git a/doc/filename.n b/doc/filename.n index 7b9d6fa..335d8c7 100644 --- a/doc/filename.n +++ b/doc/filename.n @@ -47,7 +47,8 @@ absolute, and file names may contain any character other than slash. The file names \fB\&.\fR and \fB\&..\fR are special and refer to the current directory and the parent of the current directory respectively. Multiple adjacent slash characters are interpreted as a single -separator. Any number of trailing slash characters at the end of a +separator, except for the first double slash \fB//\fR in absolute paths. +Any number of trailing slash characters at the end of a path are simply ignored, so the paths \fBfoo\fR, \fBfoo/\fR and \fBfoo//\fR are all identical, and in particular \fBfoo/\fR does not necessarily mean a directory is being referred. diff --git a/doc/interp.n b/doc/interp.n index 2943404..08bed1c 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -591,16 +591,16 @@ built-in commands: \fBflush\fR \fBfor\fR \fBforeach\fR \fBformat\fR \fBgets\fR \fBglobal\fR \fBif\fR \fBincr\fR \fBinfo\fR \fBinterp\fR \fBjoin\fR \fBlappend\fR -\fBlassign\fR \fBlindex\fR \fBlinsert\fR \fBlist\fR -\fBllength\fR \fBlrange\fR \fBlrepeat\fR \fBlreplace\fR -\fBlsearch\fR \fBlset\fR \fBlsort\fR \fBnamespace\fR -\fBpackage\fR \fBpid\fR \fBproc\fR \fBputs\fR -\fBread\fR \fBregexp\fR \fBregsub\fR \fBrename\fR -\fBreturn\fR \fBscan\fR \fBseek\fR \fBset\fR -\fBsplit\fR \fBstring\fR \fBsubst\fR \fBswitch\fR -\fBtell\fR \fBtime\fR \fBtrace\fR \fBunset\fR -\fBupdate\fR \fBuplevel\fR \fBupvar\fR \fBvariable\fR -\fBvwait\fR \fBwhile\fR +\fBlassign\fR \fBledit\fR \fBlindex\fR \fBlinsert\fR +\fBlist\fR \fBllength\fR \fBlrange\fR \fBlrepeat\fR +\fBlreplace\fR \fBlsearch\fR \fBlseq\fR \fBlset\fR +\fBlsort\fR \fBnamespace\fR \fBpackage\fR \fBpid\fR +\fBproc\fR \fBputs\fR \fBread\fR \fBregexp\fR +\fBregsub\fR \fBrename\fR \fBreturn\fR \fBscan\fR +\fBseek\fR \fBset\fR \fBsplit\fR \fBstring\fR +\fBsubst\fR \fBswitch\fR \fBtell\fR \fBtime\fR +\fBtrace\fR \fBunset\fR \fBupdate\fR \fBuplevel\fR +\fBupvar\fR \fBvariable\fR \fBvwait\fR \fBwhile\fR .DE The following commands are hidden by \fBinterp create\fR when it creates a safe interpreter: diff --git a/doc/lappend.n b/doc/lappend.n index 89b6909..3fbda79 100644 --- a/doc/lappend.n +++ b/doc/lappend.n @@ -49,9 +49,9 @@ Using \fBlappend\fR to build up a list of numbers. 1 2 3 4 5 .CE .SH "SEE ALSO" -list(n), lassign(n), lindex(n), linsert(n), llength(n), +list(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), -lreverse(n), lsearch(n), lset(n), lsort(n) +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n) .SH KEYWORDS append, element, list, variable .\" Local variables: diff --git a/doc/lassign.n b/doc/lassign.n index 67048ba..d23509a 100644 --- a/doc/lassign.n +++ b/doc/lassign.n @@ -52,9 +52,9 @@ command in many shell languages like this: set ::argv [\fBlassign\fR $::argv argumentToReadOff] .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), llength(n), +list(n), lappend(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), -lreverse(n), lsearch(n), lset(n), lsort(n) +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n) .SH KEYWORDS assign, element, list, multiple, set, variable '\"Local Variables: diff --git a/doc/ledit.n b/doc/ledit.n new file mode 100644 index 0000000..70e0bf3 --- /dev/null +++ b/doc/ledit.n @@ -0,0 +1,91 @@ +'\" +'\" Copyright (c) 2022 Ashok P. Nadkarni <apnmbx-public@yahoo.com>. All rights reserved. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH ledit n 8.7 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +ledit \- Replace elements of a list stored in variable +.SH SYNOPSIS +\fBledit \fIlistVar first last \fR?\fIvalue value ...\fR? +.BE +.SH DESCRIPTION +.PP +The command fetches the list value in variable \fIlistVar\fR and replaces the +elements in the range given by indices \fIfirst\fR to \fIlast\fR (inclusive) +with the \fIvalue\fR arguments. The resulting list is then stored back in +\fIlistVar\fR and returned as the result of the command. +.PP +Arguments \fIfirst\fR and \fIlast\fR are index values specifying the first and +last elements of the range to replace. They 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. The index 0 refers to the first element of the +list, and \fBend\fR refers to the last element of the list. +.PP +If either \fIfirst\fR or \fIlast\fR is less than zero, it is considered to +refer to the position before the first element of the list. This allows +elements to be prepended. +.PP +If either \fIfirst\fR or \fIlast\fR indicates a position greater than the +index of the last element of the list, it is treated as if it is an +index one greater than the last element. This allows elements to be appended. +.PP +If \fIlast\fR is less than \fIfirst\fR, then any specified elements +will be inserted into the list before the element specified by \fIfirst\fR +with no elements being deleted. +.PP +The \fIvalue\fR arguments specify zero or more new elements to +be added to the list in place of those that were deleted. +Each \fIvalue\fR argument will become a separate element of +the list. If no \fIvalue\fR arguments are specified, then the elements +between \fIfirst\fR and \fIlast\fR are simply deleted. +.SH EXAMPLES +.PP +Prepend to a list. +.PP +.CS +% set lst {c d e f g} +c d e f g +% ledit lst -1 -1 a b +a b c d e f g +.CE +.PP +Append to the list. +.PP +.CS +% ledit lst end+1 end+1 h i +a b c d e f g h i +.CE +.PP +Delete third and fourth elements. +.PP +.CS +% ledit lst 2 3 +a b e f g h i +.CE +.PP +Replace two elements with three. +.PP +.CS +% ledit lst 2 3 x y z +a b x y z g h i +% set lst +a b x y z g h i +.CE +.PP +.SH "SEE ALSO" +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n), +string(n) +.SH KEYWORDS +element, list, replace +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/lindex.n b/doc/lindex.n index 75fe5e8..d4d845d 100644 --- a/doc/lindex.n +++ b/doc/lindex.n @@ -115,9 +115,9 @@ set idx 3 \fI\(-> f\fR .CE .SH "SEE ALSO" -list(n), lappend(n), lassign(n), linsert(n), llength(n), +list(n), lappend(n), lassign(n), ledit(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), -lreverse(n), lsearch(n), lset(n), lsort(n), +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, index, list diff --git a/doc/linsert.n b/doc/linsert.n index 3179256..014f9cd 100644 --- a/doc/linsert.n +++ b/doc/linsert.n @@ -45,9 +45,9 @@ set newList [\fBlinsert\fR $midList end-1 lazy] set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy] .CE .SH "SEE ALSO" -list(n), lappend(n), lassign(n), lindex(n), llength(n), +list(n), lappend(n), lassign(n), ledit(n), lindex(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), -lreverse(n), lsearch(n), lset(n), lsort(n), +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, insert, list @@ -46,9 +46,9 @@ while \fBconcat\fR with the same arguments will return \fBa b c d e f {g h}\fR .CE .SH "SEE ALSO" -lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), -lreverse(n), lsearch(n), lset(n), lsort(n) +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n) .SH KEYWORDS element, list, quoting '\"Local Variables: diff --git a/doc/llength.n b/doc/llength.n index 26824a0..574834f 100644 --- a/doc/llength.n +++ b/doc/llength.n @@ -49,9 +49,9 @@ An empty list is not necessarily an empty string: 1,0 .CE .SH "SEE ALSO" -list(n), lappend(n), lassign(n), lindex(n), linsert(n), +list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), -lreverse(n), lsearch(n), lset(n), lsort(n) +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n) .SH KEYWORDS element, list, length '\" Local Variables: @@ -78,9 +78,9 @@ set prefix [\fBlmap\fR x $values {expr { .CE .SH "SEE ALSO" break(n), continue(n), for(n), foreach(n), while(n), -list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), -lreverse(n), lsearch(n), lset(n), lsort(n) +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n) .SH KEYWORDS foreach, iteration, list, loop, map '\" Local Variables: @@ -86,9 +86,9 @@ The indicated value becomes the new value of \fIx\fR. \fI\(-> {{a b} {c d}} {{e f} h}\fR .CE .SH "SEE ALSO" -list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), -lreverse(n), lsearch(n), lset(n), lsort(n), +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, index, list, remove, pop, stack, queue diff --git a/doc/lrange.n b/doc/lrange.n index 0d4b261..38c4abf 100644 --- a/doc/lrange.n +++ b/doc/lrange.n @@ -71,9 +71,9 @@ elements to {elements to} .CE .SH "SEE ALSO" -list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lremove(n), lrepeat(n), lreplace(n), -lreverse(n), lsearch(n), lset(n), lsort(n), +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, list, range, sublist diff --git a/doc/lremove.n b/doc/lremove.n index 59d261b..8763ea6 100644 --- a/doc/lremove.n +++ b/doc/lremove.n @@ -46,9 +46,9 @@ Removing the same element indicated in two different ways: a b d e .CE .SH "SEE ALSO" -list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lrepeat(n), lreplace(n), -lreverse(n), lsearch(n), lset(n), lsort(n) +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n) .SH KEYWORDS element, list, remove .\" Local variables: diff --git a/doc/lrepeat.n b/doc/lrepeat.n index 9a3fc88..cd672db 100644 --- a/doc/lrepeat.n +++ b/doc/lrepeat.n @@ -32,9 +32,9 @@ is identical to \fBlist element ...\fR. \fI\(-> {a a} b c {a a} b c {a a} b c\fR .CE .SH "SEE ALSO" -list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n), -lreverse(n), lsearch(n), lset(n), lsort(n) +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n) .SH KEYWORDS element, index, list '\" Local Variables: diff --git a/doc/lreplace.n b/doc/lreplace.n index bc9d7ca..47d33f9 100644 --- a/doc/lreplace.n +++ b/doc/lreplace.n @@ -95,9 +95,9 @@ a b c d e f g h i .CE .VE TIP505 .SH "SEE ALSO" -list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), -lreverse(n), lsearch(n), lset(n), lsort(n), +lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, list, replace diff --git a/doc/lreverse.n b/doc/lreverse.n index e2e3b69..bb0703d 100644 --- a/doc/lreverse.n +++ b/doc/lreverse.n @@ -25,9 +25,9 @@ input list, \fIlist\fR, except with the elements in the reverse order. \fI\(-> f e {c d} b a\fR .CE .SH "SEE ALSO" -list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), -lsearch(n), lset(n), lsort(n) +lsearch(n), lseq(n), lset(n), lsort(n) .SH KEYWORDS element, list, reverse '\" Local Variables: diff --git a/doc/lsearch.n b/doc/lsearch.n index c5dc98f..dc6d1f7 100644 --- a/doc/lsearch.n +++ b/doc/lsearch.n @@ -229,9 +229,9 @@ The same thing for a flattened list: .CE .SH "SEE ALSO" foreach(n), -list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), -lreverse(n), lset(n), lsort(n), +lreverse(n), lseq(n), lset(n), lsort(n), string(n) .SH KEYWORDS binary search, linear search, @@ -81,8 +81,8 @@ must be numeric; a non-numeric string will result in an error. .\" .CE .SH "SEE ALSO" -foreach(n), list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), -lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n), +foreach(n), list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), +llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n), lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, index, list @@ -136,9 +136,9 @@ The indicated return value also becomes the new value of \fIx\fR. \fI\(-> {{a b} {c d}} {{e f} {j h}}\fR .CE .SH "SEE ALSO" -list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), -lreverse(n), lsearch(n), lsort(n) +lreverse(n), lsearch(n), lseq(n), lsort(n) string(n) .SH KEYWORDS element, index, list, replace, set diff --git a/doc/lsort.n b/doc/lsort.n index 2018e30..1695ea8 100644 --- a/doc/lsort.n +++ b/doc/lsort.n @@ -264,9 +264,9 @@ More complex sorting using a comparison function: {1 dingo} {2 banana} {0x2 carrot} {3 apple} .CE .SH "SEE ALSO" -list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), -lreverse(n), lsearch(n), lset(n) +lreverse(n), lsearch(n), lseq(n), lset(n) .SH KEYWORDS element, list, order, sort '\" Local Variables: diff --git a/generic/tcl.decls b/generic/tcl.decls index aab5cb5..95cecdf 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1043,7 +1043,7 @@ declare 288 { declare 289 { void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData) } -declare 290 { +declare 290 {deprecated {Use Tcl_DiscardInterpState}} { void Tcl_DiscardResult(Tcl_SavedResult *statePtr) } declare 291 { @@ -1126,10 +1126,10 @@ declare 313 { int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag) } -declare 314 { +declare 314 {deprecated {Use Tcl_RestoreInterpState}} { void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) } -declare 315 { +declare 315 {deprecated {Use Tcl_SaveInterpState}} { void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) } declare 316 { @@ -2502,8 +2502,14 @@ declare 673 { int TclGetUniChar(Tcl_Obj *objPtr, int index) } -# slot 674 and 675 are reserved for TIP #618 - +declare 674 { + int Tcl_GetBool(Tcl_Interp *interp, const char *src, int flags, + char *charPtr) +} +declare 675 { + int Tcl_GetBoolFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + int flags, char *charPtr) +} declare 676 { Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp, const char *cmdName, diff --git a/generic/tcl.h b/generic/tcl.h index f17d43e..43975a3 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -817,6 +817,7 @@ typedef struct Tcl_Obj { * typically allocated on the stack. */ +#ifndef TCL_NO_DEPRECATED typedef struct Tcl_SavedResult { char *result; Tcl_FreeProc *freeProc; @@ -826,6 +827,7 @@ typedef struct Tcl_SavedResult { int appendUsed; char resultSpace[200+1]; } Tcl_SavedResult; +#endif /* *---------------------------------------------------------------------------- @@ -989,14 +991,14 @@ typedef struct Tcl_DString { /* * Flags that may be passed to Tcl_GetIndexFromObj. * TCL_EXACT disallows abbreviated strings. - * TCL_INDEX_NULL_OK allows the empty string or NULL to return TCL_OK. + * TCL_NULL_OK allows the empty string or NULL to return TCL_OK. * The returned value will be -1; * TCL_INDEX_TEMP_TABLE disallows caching of lookups. A possible use case is * a table that will not live long enough to make it worthwhile. */ #define TCL_EXACT 1 -#define TCL_INDEX_NULL_OK 32 +#define TCL_NULL_OK 32 #define TCL_INDEX_TEMP_TABLE 64 /* @@ -2118,6 +2120,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_CHAR_LIMIT 0x10 #define TCL_ENCODING_MODIFIED 0x20 #define TCL_ENCODING_NOCOMPLAIN 0x40 +#define TCL_ENCODING_STRICT 0x44 /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 93177a7..11a4254 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -106,8 +106,10 @@ ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) { Tcl_WideInt len; - if (step == 0) return 0; - len = (step ? (1 + (((end-start))/step)) : 0); + if (step == 0) { + return 0; + } + len = 1 + ((end-start)/step); return (len < 0) ? -1 : len; } @@ -227,26 +229,24 @@ TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) static void assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tcl_Obj *numberObj) { - union { - double d; - Tcl_WideInt i; - } *number; + void *clientData; int tcl_number_type; - if (TclGetNumberFromObj(NULL, numberObj, (ClientData*)&number, &tcl_number_type) != TCL_OK) { + if (TclGetNumberFromObj(NULL, numberObj, &clientData, &tcl_number_type) != TCL_OK + || tcl_number_type == TCL_NUMBER_BIG) { return; } if (useDoubles) { - if (tcl_number_type == TCL_NUMBER_DOUBLE) { - *dblNumberPtr = number->d; + if (tcl_number_type != TCL_NUMBER_INT) { + *dblNumberPtr = *(double *)clientData; } else { - *dblNumberPtr = (double)number->i; + *dblNumberPtr = (double)*(Tcl_WideInt *)clientData; } } else { if (tcl_number_type == TCL_NUMBER_INT) { - *intNumberPtr = number->i; + *intNumberPtr = *(Tcl_WideInt *)clientData; } else { - *intNumberPtr = (Tcl_WideInt)number->d; + *intNumberPtr = (Tcl_WideInt)*(double *)clientData; } } } @@ -270,8 +270,16 @@ assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tc * None. *---------------------------------------------------------------------- */ -Tcl_Obj * -TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj) +int +TclNewArithSeriesObj( + Tcl_Interp *interp, /* For error reporting */ + Tcl_Obj **arithSeriesObj, /* return value */ + int useDoubles, /* Flag indicates values start, + ** end, step, are treated as doubles */ + Tcl_Obj *startObj, /* Starting value */ + Tcl_Obj *endObj, /* Ending limit */ + Tcl_Obj *stepObj, /* increment value */ + Tcl_Obj *lenObj) /* Number of elements */ { double dstart, dend, dstep; Tcl_WideInt start, end, step, len; @@ -290,14 +298,17 @@ TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj dstep = step; } if (dstep == 0) { - return Tcl_NewObj(); + *arithSeriesObj = Tcl_NewObj(); + return TCL_OK; } } if (endObj) { assignNumber(useDoubles, &end, &dend, endObj); } if (lenObj) { - Tcl_GetWideIntFromObj(NULL, lenObj, &len); + if (TCL_OK != Tcl_GetWideIntFromObj(interp, lenObj, &len)) { + return TCL_ERROR; + } } if (startObj && endObj) { @@ -330,11 +341,20 @@ TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj } } - if (useDoubles) { - return TclNewArithSeriesDbl(dstart, dend, dstep, len); - } else { - return TclNewArithSeriesInt(start, end, step, len); + if (TCL_MAJOR_VERSION < 9 && len > ListSizeT_MAX) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + return TCL_ERROR; } + + if (arithSeriesObj) { + *arithSeriesObj = (useDoubles) + ? TclNewArithSeriesDbl(dstart, dend, dstep, len) + : TclNewArithSeriesInt(start, end, step, len); + } + return TCL_OK; } /* @@ -684,6 +704,7 @@ TclArithSeriesObjCopy( Tcl_Obj * TclArithSeriesObjRange( + Tcl_Interp *interp, /* For error message(s) */ Tcl_Obj *arithSeriesPtr, /* List object to take a range from. */ int fromIdx, /* Index of first element to include. */ int toIdx) /* Index of last element to include. */ @@ -711,8 +732,12 @@ TclArithSeriesObjRange( if (Tcl_IsShared(arithSeriesPtr) || ((arithSeriesPtr->refCount > 1))) { - Tcl_Obj *newSlicePtr = TclNewArithSeriesObj(arithSeriesRepPtr->isDouble, - startObj, endObj, stepObj, NULL); + Tcl_Obj *newSlicePtr; + if (TclNewArithSeriesObj(interp, &newSlicePtr, + arithSeriesRepPtr->isDouble, startObj, endObj, + stepObj, NULL) != TCL_OK) { + newSlicePtr = NULL; + } Tcl_DecrRefCount(startObj); Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); @@ -795,7 +820,7 @@ TclArithSeriesGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *objPtr, /* AbstractList object for which an element * array is to be returned. */ - int *objcPtr, /* Where to store the count of objects + ListSizeT *objcPtr, /* Where to store the count of objects * referenced by objv. */ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ @@ -875,6 +900,7 @@ TclArithSeriesGetElements( Tcl_Obj * TclArithSeriesObjReverse( + Tcl_Interp *interp, /* For error message(s) */ Tcl_Obj *arithSeriesPtr) /* List object to reverse. */ { ArithSeries *arithSeriesRepPtr; @@ -890,8 +916,11 @@ TclArithSeriesObjReverse( len = arithSeriesRepPtr->len; TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &startObj); + Tcl_IncrRefCount(startObj); TclArithSeriesObjIndex(arithSeriesPtr, 0, &endObj); + Tcl_IncrRefCount(endObj); TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + Tcl_IncrRefCount(stepObj); if (isDouble) { Tcl_GetDoubleFromObj(NULL, startObj, &dstart); @@ -910,8 +939,10 @@ TclArithSeriesObjReverse( if (Tcl_IsShared(arithSeriesPtr) || ((arithSeriesPtr->refCount > 1))) { Tcl_Obj *lenObj = Tcl_NewWideIntObj(len); - resultObj = TclNewArithSeriesObj(isDouble, - startObj, endObj, stepObj, lenObj); + if (TclNewArithSeriesObj(interp, &resultObj, + isDouble, startObj, endObj, stepObj, lenObj) != TCL_OK) { + resultObj = NULL; + } Tcl_DecrRefCount(lenObj); } else { diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index f855c22..3ace052 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -40,9 +40,10 @@ MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr, MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj); MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr, - int fromIdx, int toIdx); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp, + Tcl_Obj *arithSeriesPtr, int fromIdx, int toIdx); +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp, + Tcl_Obj *arithSeriesPtr); MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr); MODULE_SCOPE Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start, @@ -50,5 +51,7 @@ MODULE_SCOPE Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt len); MODULE_SCOPE Tcl_Obj * TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len); -MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, - Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj); +MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp, + Tcl_Obj **arithSeriesObj, int useDoubles, + Tcl_Obj *startObj, Tcl_Obj *endObj, + Tcl_Obj *stepObj, Tcl_Obj *lenObj); diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 83111b1..73b997d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -325,6 +325,7 @@ static const CmdInfo builtInCmds[] = { {"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 07541bd..26e8824 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -565,8 +565,10 @@ EncodingConvertfromObjCmd( * 2) encoding data -> objc = 3 * 3) -nocomplain data -> objc = 3 * 4) -nocomplain encoding data -> objc = 4 - * 5) -failindex val data -> objc = 4 - * 6) -failindex val encoding data -> objc = 5 + * 5) -strict data -> objc = 3 + * 6) -strict encoding data -> objc = 4 + * 7) -failindex val data -> objc = 4 + * 8) -failindex val encoding data -> objc = 5 */ if (objc == 2) { @@ -580,6 +582,10 @@ EncodingConvertfromObjCmd( && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { flags = TCL_ENCODING_NOCOMPLAIN; objcUnprocessed--; + } else if (bytesPtr[0] == '-' && bytesPtr[1] == 's' + && !strncmp(bytesPtr, "-strict", strlen(bytesPtr))) { + flags = TCL_ENCODING_STRICT; + objcUnprocessed--; } else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { /* at least two additional arguments needed */ @@ -604,7 +610,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"); return TCL_ERROR; } @@ -622,7 +628,7 @@ EncodingConvertfromObjCmd( } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); - if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != TCL_INDEX_NONE)) { + if ((!(flags & TCL_ENCODING_NOCOMPLAIN) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) && (result != TCL_INDEX_NONE)) { if (failVarObj != NULL) { if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; @@ -715,6 +721,10 @@ EncodingConverttoObjCmd( && !strncmp(stringPtr, "-nocomplain", strlen(stringPtr))) { flags = TCL_ENCODING_NOCOMPLAIN; objcUnprocessed--; + } else if (stringPtr[0] == '-' && stringPtr[1] == 's' + && !strncmp(stringPtr, "-strict", strlen(stringPtr))) { + flags = TCL_ENCODING_STRICT; + objcUnprocessed--; } else if (stringPtr[0] == '-' && stringPtr[1] == 'f' && !strncmp(stringPtr, "-failindex", strlen(stringPtr))) { /* at least two additional arguments needed */ @@ -739,7 +749,7 @@ EncodingConverttoObjCmd( } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"); return TCL_ERROR; } @@ -750,7 +760,7 @@ EncodingConverttoObjCmd( stringPtr = TclGetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, flags, &ds); - if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != TCL_INDEX_NONE)) { + if ((!(flags & TCL_ENCODING_NOCOMPLAIN) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) && (result != TCL_INDEX_NONE)) { if (failVarObj != NULL) { /* I hope, wide int will cover size_t data type */ if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { @@ -2866,13 +2876,13 @@ EachloopCmd( /* Values */ if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) { /* Special case for Arith Series */ - statePtr->vCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]); - if (statePtr->vCopyList[i] == NULL) { + statePtr->aCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]); + if (statePtr->aCopyList[i] == NULL) { result = TCL_ERROR; goto done; } /* Don't compute values here, wait until the last momement */ - statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->vCopyList[i]); + statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->aCopyList[i]); } else { /* List values */ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); @@ -3005,12 +3015,12 @@ ForeachAssignments( Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; i<statePtr->numLists ; i++) { - int isarithseries = TclHasInternalRep(statePtr->vCopyList[i],&tclArithSeriesType); + int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType); for (v=0 ; v<statePtr->varcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { if (isarithseries) { - if (TclArithSeriesObjIndex(statePtr->vCopyList[i], k, &valuePtr) != TCL_OK) { + if (TclArithSeriesObjIndex(statePtr->aCopyList[i], k, &valuePtr) != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (setting %s loop variable \"%s\")", (statePtr->resultList != NULL ? "lmap" : "foreach"), diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 9430eb5..62ceeea 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2720,7 +2720,6 @@ Tcl_LrangeObjCmd( /* Argument objects. */ { int listLen, first, last, result; - if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "list first last"); return TCL_ERROR; @@ -2744,7 +2743,13 @@ Tcl_LrangeObjCmd( } if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { - Tcl_SetObjResult(interp, TclArithSeriesObjRange(objv[1], first, last)); + Tcl_Obj *rangeObj; + rangeObj = TclArithSeriesObjRange(interp, objv[1], first, last); + if (rangeObj) { + Tcl_SetObjResult(interp, rangeObj); + } else { + return TCL_ERROR; + } } else { Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); } @@ -3137,8 +3142,13 @@ Tcl_LreverseObjCmd( * just to reverse it. */ if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { - Tcl_SetObjResult(interp, TclArithSeriesObjReverse(objv[1])); - return TCL_OK; + Tcl_Obj *resObj = TclArithSeriesObjReverse(interp, objv[1]); + if (resObj) { + Tcl_SetObjResult(interp, resObj); + return TCL_OK; + } else { + return TCL_ERROR; + } } /* end ArithSeries */ /* True List */ @@ -4067,12 +4077,9 @@ SequenceIdentifyArgument( int status; SequenceOperators opmode; SequenceByMode bymode; - union { - Tcl_WideInt i; - double d; - } nvalue; + void *clientData; - status = TclGetNumberFromObj(NULL, argPtr, (ClientData*)&nvalue, keywordIndexPtr); + status = TclGetNumberFromObj(NULL, argPtr, &clientData, keywordIndexPtr); if (status == TCL_OK) { if (numValuePtr) { *numValuePtr = argPtr; @@ -4422,10 +4429,12 @@ Tcl_LseqObjCmd( /* * Success! Now lets create the series object. */ - arithSeriesPtr = TclNewArithSeriesObj(useDoubles, start, end, step, elementCount); + status = TclNewArithSeriesObj(interp, &arithSeriesPtr, + useDoubles, start, end, step, elementCount); - Tcl_SetObjResult(interp, arithSeriesPtr); - status = TCL_OK; + if (status == TCL_OK) { + Tcl_SetObjResult(interp, arithSeriesPtr); + } done: // Free number arguments. @@ -4961,6 +4970,123 @@ Tcl_LsortObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_LeditObjCmd -- + * + * This procedure is invoked to process the "ledit" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LeditObjCmd( + TCL_UNUSED(ClientData), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ +{ + Tcl_Obj *listPtr; /* Pointer to the list being altered. */ + Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */ + int createdNewObj; + int result; + int first; + int last; + int listLen; + int numToDelete; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "listVar first last ?element ...?"); + return TCL_ERROR; + } + + listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); + if (listPtr == NULL) { + return TCL_ERROR; + } + + /* + * TODO - refactor the index extraction into a common function shared + * by Tcl_{Lrange,Lreplace,Ledit}ObjCmd + */ + + result = TclListObjLengthM(interp, listPtr, &listLen); + if (result != TCL_OK) { + return result; + } + + result = TclGetIntForIndexM(interp, objv[2], /*end*/ listLen-1, &first); + if (result != TCL_OK) { + return result; + } + + result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last); + if (result != TCL_OK) { + return result; + } + + if (first == TCL_INDEX_NONE) { + first = 0; + } else if (first > listLen) { + first = listLen; + } + + if (last >= listLen) { + last = listLen - 1; + } + if (first <= last) { + numToDelete = last - first + 1; + } else { + numToDelete = 0; + } + + if (Tcl_IsShared(listPtr)) { + listPtr = TclListObjCopy(NULL, listPtr); + createdNewObj = 1; + } else { + createdNewObj = 0; + } + + result = + Tcl_ListObjReplace(interp, listPtr, first, numToDelete, objc - 4, objv + 4); + if (result != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(listPtr); + } + return result; + } + + /* + * Tcl_ObjSetVar2 mau return a value different from listPtr in the + * presence of traces etc.. Note that finalValuePtr will always have a + * reference count of at least 1 corresponding to the reference from the + * var. If it is same as listPtr, then ref count will be at least 2 + * since we are incr'ing the latter below (safer when calling + * Tcl_ObjSetVar2 which can release it in some cases). Note that we + * leave the incrref of listPtr this late because we want to pass it as + * unshared to Tcl_ListObjReplace above if possible. + */ + Tcl_IncrRefCount(listPtr); + finalValuePtr = + Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(listPtr); /* safe irrespective of createdNewObj */ + if (finalValuePtr == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, finalValuePtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * MergeLists - * * This procedure combines two sorted lists of SortElement structures diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 562ea1a..80131e8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -14,6 +14,10 @@ #include <stddef.h> /* for size_t */ +#ifdef TCL_NO_DEPRECATED +# define Tcl_SavedResult void +#endif /* TCL_NO_DEPRECATED */ + #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT @@ -900,7 +904,8 @@ EXTERN void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData); /* 290 */ -EXTERN void Tcl_DiscardResult(Tcl_SavedResult *statePtr); +TCL_DEPRECATED("Use Tcl_DiscardInterpState") +void Tcl_DiscardResult(Tcl_SavedResult *statePtr); /* 291 */ EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags); @@ -965,10 +970,12 @@ EXTERN int Tcl_NumUtfChars(const char *src, int length); EXTERN int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag); /* 314 */ -EXTERN void Tcl_RestoreResult(Tcl_Interp *interp, +TCL_DEPRECATED("Use Tcl_RestoreInterpState") +void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */ -EXTERN void Tcl_SaveResult(Tcl_Interp *interp, +TCL_DEPRECATED("Use Tcl_SaveInterpState") +void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 316 */ EXTERN int Tcl_SetSystemEncoding(Tcl_Interp *interp, @@ -1976,8 +1983,12 @@ EXTERN const char * TclUtfAtIndex(const char *src, int index); EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, int first, int last); /* 673 */ EXTERN int TclGetUniChar(Tcl_Obj *objPtr, int index); -/* Slot 674 is reserved */ -/* Slot 675 is reserved */ +/* 674 */ +EXTERN int Tcl_GetBool(Tcl_Interp *interp, const char *src, + int flags, char *charPtr); +/* 675 */ +EXTERN int Tcl_GetBoolFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, int flags, char *charPtr); /* 676 */ EXTERN Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, @@ -2327,7 +2338,7 @@ typedef struct TclStubs { Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */ void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */ void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */ - void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */ + TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */ int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */ int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ @@ -2351,8 +2362,8 @@ typedef struct TclStubs { void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */ int (*tcl_NumUtfChars) (const char *src, int length); /* 312 */ int (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag); /* 313 */ - void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */ - void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */ + TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */ + TCL_DEPRECATED_API("Use Tcl_SaveInterpState") void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */ int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */ Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */ void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ @@ -2711,8 +2722,8 @@ typedef struct TclStubs { const char * (*tclUtfAtIndex) (const char *src, int index); /* 671 */ Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, int first, int last); /* 672 */ int (*tclGetUniChar) (Tcl_Obj *objPtr, int index); /* 673 */ - void (*reserved674)(void); - void (*reserved675)(void); + int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 674 */ + int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); /* 675 */ Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */ Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */ @@ -4098,8 +4109,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclGetRange) /* 672 */ #define TclGetUniChar \ (tclStubsPtr->tclGetUniChar) /* 673 */ -/* Slot 674 is reserved */ -/* Slot 675 is reserved */ +#define Tcl_GetBool \ + (tclStubsPtr->tcl_GetBool) /* 674 */ +#define Tcl_GetBoolFromObj \ + (tclStubsPtr->tcl_GetBoolFromObj) /* 675 */ #define Tcl_CreateObjCommand2 \ (tclStubsPtr->tcl_CreateObjCommand2) /* 676 */ #define Tcl_CreateObjTrace2 \ @@ -4228,22 +4241,8 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GlobalEval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL) #undef Tcl_SaveResult -#define Tcl_SaveResult(interp, statePtr) \ - do { \ - (statePtr)->objResultPtr = Tcl_GetObjResult(interp); \ - Tcl_IncrRefCount((statePtr)->objResultPtr); \ - Tcl_SetObjResult(interp, Tcl_NewObj()); \ - } while(0) #undef Tcl_RestoreResult -#define Tcl_RestoreResult(interp, statePtr) \ - do { \ - Tcl_ResetResult(interp); \ - Tcl_SetObjResult(interp, (statePtr)->objResultPtr); \ - Tcl_DecrRefCount((statePtr)->objResultPtr); \ - } while(0) #undef Tcl_DiscardResult -#define Tcl_DiscardResult(statePtr) \ - Tcl_DecrRefCount((statePtr)->objResultPtr) #undef Tcl_SetResult #define Tcl_SetResult(interp, result, freeProc) \ do { \ @@ -4481,6 +4480,9 @@ extern const TclStubs *tclStubsPtr; * Deprecated Tcl procedures: */ +#ifdef TCL_NO_DEPRECATED +# undef Tcl_SavedResult +#endif /* TCL_NO_DEPRECATED */ #undef Tcl_EvalObj #define Tcl_EvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, 0) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index c795030..55664ce 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -129,7 +129,7 @@ typedef struct Dict { * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ - unsigned int epoch; /* Epoch counter */ + TCL_HASH_TYPE epoch; /* Epoch counter */ size_t refCount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested @@ -231,7 +231,7 @@ AllocChainEntry( cPtr = (ChainEntry *)ckalloc(sizeof(ChainEntry)); cPtr->entry.key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); - cPtr->entry.clientData = NULL; + Tcl_SetHashValue(&cPtr->entry, NULL); cPtr->prevPtr = cPtr->nextPtr = NULL; return &cPtr->entry; @@ -488,7 +488,8 @@ UpdateStringOfDict( Dict *dict; ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; - int i, length, bytesNeeded = 0; + int i, length; + TCL_HASH_TYPE bytesNeeded = 0; const char *elem; char *dst; @@ -530,7 +531,7 @@ UpdateStringOfDict( keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } @@ -538,11 +539,11 @@ UpdateStringOfDict( valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i+1); - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } - if (bytesNeeded > INT_MAX - numElems + 1) { + if (bytesNeeded + numElems > INT_MAX + 1U) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems; @@ -649,7 +650,8 @@ SetDictFromAny( while (nextElem < limit) { Tcl_Obj *keyPtr, *valuePtr; const char *elemStart; - int elemSize, literal; + int elemSize; + int literal; if (TclFindDictElement(interp, nextElem, (limit - nextElem), &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { @@ -1496,7 +1498,7 @@ Tcl_DbNewDictObj( static int DictCreateCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1546,7 +1548,7 @@ DictCreateCmd( static int DictGetCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1639,7 +1641,7 @@ DictGetCmd( static int DictGetDefCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1704,7 +1706,7 @@ DictGetDefCmd( static int DictReplaceCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1752,7 +1754,7 @@ DictReplaceCmd( static int DictRemoveCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1800,7 +1802,7 @@ DictRemoveCmd( static int DictMergeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1887,7 +1889,7 @@ DictMergeCmd( static int DictKeysCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1966,7 +1968,7 @@ DictKeysCmd( static int DictValuesCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2026,12 +2028,13 @@ DictValuesCmd( static int DictSizeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { - int result, size; + int result; + int size; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary"); @@ -2064,7 +2067,7 @@ DictSizeCmd( static int DictExistsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2106,7 +2109,7 @@ DictExistsCmd( static int DictInfoCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2150,7 +2153,7 @@ DictInfoCmd( static int DictIncrCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2271,7 +2274,7 @@ DictIncrCmd( static int DictLappendCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2358,7 +2361,7 @@ DictLappendCmd( static int DictAppendCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2460,7 +2463,7 @@ DictAppendCmd( static int DictForNRCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2469,7 +2472,8 @@ DictForNRCmd( Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj; Tcl_DictSearch *searchPtr; - int varc, done; + int varc; + int done; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -2555,7 +2559,7 @@ DictForNRCmd( static int DictForLoopCallback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -2655,7 +2659,7 @@ DictForLoopCallback( static int DictMapNRCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2663,7 +2667,8 @@ DictMapNRCmd( Interp *iPtr = (Interp *) interp; Tcl_Obj **varv, *keyObj, *valueObj; DictMapStorage *storagePtr; - int varc, done; + int varc; + int done; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -2759,7 +2764,7 @@ DictMapNRCmd( static int DictMapLoopCallback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -2867,7 +2872,7 @@ DictMapLoopCallback( static int DictSetCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2927,7 +2932,7 @@ DictSetCmd( static int DictUnsetCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2986,7 +2991,7 @@ DictUnsetCmd( static int DictFilterCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -3001,7 +3006,8 @@ DictFilterCmd( Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj; Tcl_DictSearch search; - int index, varc, done, result, satisfied; + int index, done, result, satisfied; + int varc; const char *pattern; if (objc < 3) { @@ -3271,14 +3277,15 @@ DictFilterCmd( static int DictUpdateCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Interp *iPtr = (Interp *) interp; Tcl_Obj *dictPtr, *objPtr; - int i, dummy; + int i; + int dummy; if (objc < 5 || !(objc & 1)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -3325,7 +3332,7 @@ DictUpdateCmd( static int FinalizeDictUpdate( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -3429,7 +3436,7 @@ FinalizeDictUpdate( static int DictWithCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -3476,7 +3483,7 @@ DictWithCmd( static int FinalizeDictWith( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 0ce75b4..3d5e474 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2288,7 +2288,7 @@ BinaryProc( */ #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) -# define STOPONERROR !(flags & TCL_ENCODING_NOCOMPLAIN) +# define STOPONERROR (!(flags & TCL_ENCODING_NOCOMPLAIN) || (flags & TCL_ENCODING_STOPONERROR)) #else # define STOPONERROR (flags & TCL_ENCODING_STOPONERROR) #endif @@ -2359,11 +2359,18 @@ UtfToUtfProc( *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) - && (UCHAR(src[1]) == 0x80) && !(flags & TCL_ENCODING_MODIFIED)) { + && (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { /* - * Convert 0xC080 to real nulls when we are in output mode. + * If in input mode, and -strict is specified: This is an error. */ + if (flags & TCL_ENCODING_MODIFIED) { + result = TCL_CONVERT_UNKNOWN; + break; + } + /* + * Convert 0xC080 to real nulls when we are in output mode, with or without '-strict'. + */ *dst++ = 0; src += 2; } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 183ac82..1e2e7bf 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1511,12 +1511,12 @@ Tcl_VwaitObjCmd( Tcl_Channel chan; Tcl_WideInt diff = -1; VwaitItem localItems[32], *vwaitItems = localItems; - static const char *const options[] = { + static const char *const vWaitOptionStrings[] = { "-all", "-extended", "-nofileevents", "-noidleevents", "-notimerevents", "-nowindowevents", "-readable", "-timeout", "-variable", "-writable", "--", NULL }; - enum options { + enum vWaitOptions { OPT_ALL, OPT_EXTD, OPT_NO_FEVTS, OPT_NO_IEVTS, OPT_NO_TEVTS, OPT_NO_WEVTS, OPT_READABLE, OPT_TIMEOUT, OPT_VARIABLE, OPT_WRITABLE, OPT_LAST @@ -1541,7 +1541,7 @@ Tcl_VwaitObjCmd( if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], vWaitOptionStrings, "option", 0, &index) != TCL_OK) { result = TCL_ERROR; goto done; @@ -1570,7 +1570,7 @@ Tcl_VwaitObjCmd( needArg: Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "argument required for \"%s\"", options[index])); + "argument required for \"%s\"", vWaitOptionStrings[index])); Tcl_SetErrorCode(interp, "TCL", "EVENT", "ARGUMENT", NULL); result = TCL_ERROR; goto done; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f8d5493..7c7bbfd 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4883,6 +4883,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } + Tcl_IncrRefCount(objResultPtr); // reference held here goto lindexDone; } @@ -4938,7 +4939,7 @@ TEBCresume( /* Decode end-offset index values. */ - index = TclIndexDecode(opnd, length); + index = TclIndexDecode(opnd, length-1); /* Compute value @ index */ if (index >= 0 && index < length) { @@ -5154,7 +5155,11 @@ TEBCresume( fromIdx = TclIndexDecode(fromIdx, objc - 1); if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { - objResultPtr = TclArithSeriesObjRange(valuePtr, fromIdx, toIdx); + objResultPtr = TclArithSeriesObjRange(interp, valuePtr, fromIdx, toIdx); + if (objResultPtr == NULL) { + TRACE_ERROR(interp); + goto gotError; + } } else { objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx); } @@ -5183,7 +5188,11 @@ TEBCresume( */ do { - Tcl_ListObjIndex(NULL, value2Ptr, i, &o); + if (isArithSeries) { + TclArithSeriesObjIndex(value2Ptr, i, &o); + } else { + Tcl_ListObjIndex(NULL, value2Ptr, i, &o); + } if (o != NULL) { s2 = TclGetStringFromObj(o, &s2len); } else { diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 9620f8c..b553621 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -413,7 +413,6 @@ TclpGetNativePathType( if (path[0] == '/') { ++path; -#if defined(__CYGWIN__) || defined(__QNX__) /* * Check for "//" network path prefix */ @@ -422,22 +421,10 @@ TclpGetNativePathType( while (*path && *path != '/') { ++path; } -#if defined(__CYGWIN__) - /* UNC paths need to be followed by a share name */ - if (*path++ && (*path && *path != '/')) { - ++path; - while (*path && *path != '/') { - ++path; - } - } else { - path = origPath + 1; - } -#endif } -#endif if (driveNameLengthPtr != NULL) { /* - * We need this addition in case the QNX or Cygwin code was used. + * We need this addition in case the "//" code was used. */ *driveNameLengthPtr = (path - origPath); @@ -656,7 +643,6 @@ SplitUnixPath( if (*path == '/') { Tcl_Obj *rootElt; ++path; -#if defined(__CYGWIN__) || defined(__QNX__) /* * Check for "//" network path prefix */ @@ -665,19 +651,7 @@ SplitUnixPath( while (*path && *path != '/') { ++path; } -#if defined(__CYGWIN__) - /* UNC paths need to be followed by a share name */ - if (*path++ && (*path && *path != '/')) { - ++path; - while (*path && *path != '/') { - ++path; - } - } else { - path = origPath + 1; - } -#endif } -#endif rootElt = Tcl_NewStringObj(origPath, path - origPath); Tcl_ListObjAppendElement(NULL, result, rootElt); while (*path == '/') { diff --git a/generic/tclGet.c b/generic/tclGet.c index 905038f..bb3f8f1 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -110,7 +110,7 @@ Tcl_GetDouble( * string. * * Results: - * The return value is normally TCL_OK; in this case *intPtr will be set + * The return value is normally TCL_OK; in this case *charPtr will be set * to the 0/1 value equivalent to src. If src is improperly formed then * TCL_ERROR is returned and an error message will be left in the * interp's result. @@ -121,17 +121,23 @@ Tcl_GetDouble( *---------------------------------------------------------------------- */ +#undef Tcl_GetBool +#undef Tcl_GetBoolFromObj int -Tcl_GetBoolean( +Tcl_GetBool( Tcl_Interp *interp, /* Interpreter used for error reporting. */ const char *src, /* String containing one of the boolean values * 1, 0, true, false, yes, no, on, off. */ - int *intPtr) /* Place to store converted result, which will + int flags, + char *charPtr) /* Place to store converted result, which will * be 0 or 1. */ { Tcl_Obj obj; int code; + if ((src == NULL) || (*src == '\0')) { + return Tcl_GetBoolFromObj(interp, NULL, flags, charPtr); + } obj.refCount = 1; obj.bytes = (char *) src; obj.length = strlen(src); @@ -142,10 +148,22 @@ Tcl_GetBoolean( Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { - TclGetBooleanFromObj(NULL, &obj, intPtr); + Tcl_GetBoolFromObj(NULL, &obj, flags, charPtr); } return code; } + +#undef Tcl_GetBoolean +int +Tcl_GetBoolean( + Tcl_Interp *interp, /* Interpreter used for error reporting. */ + const char *src, /* String containing one of the boolean values + * 1, 0, true, false, yes, no, on, off. */ + int *intPtr) /* Place to store converted result, which will + * be 0 or 1. */ +{ + return Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof(int), (char *)(void *)intPtr); +} /* * Local Variables: diff --git a/generic/tclIO.c b/generic/tclIO.c index 57a3de5..85067f2 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1478,7 +1478,7 @@ Tcl_GetChannel( chanPtr = (Channel *)Tcl_GetHashValue(hPtr); chanPtr = chanPtr->state->bottomChanPtr; if (modePtr != NULL) { - *modePtr = chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE); + *modePtr = GotFlag(chanPtr->state, TCL_READABLE|TCL_WRITABLE); } return (Tcl_Channel) chanPtr; @@ -1572,7 +1572,7 @@ TclGetChannelFromObj( *channelPtr = (Tcl_Channel) statePtr->bottomChanPtr; if (modePtr != NULL) { - *modePtr = statePtr->flags & (TCL_READABLE|TCL_WRITABLE); + *modePtr = GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE); } return TCL_OK; @@ -1877,7 +1877,7 @@ Tcl_StackChannel( * --+---+---+---+----+ */ - if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) { + if ((mask & GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE)) == 0) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "reading and writing both disallowed for channel \"%s\"", @@ -2170,8 +2170,8 @@ Tcl_UnstackChannel( * TIP #220: This is done with maximum privileges (as created). */ - statePtr->flags &= ~(TCL_READABLE|TCL_WRITABLE); - statePtr->flags |= statePtr->maxPerms; + ResetFlag(statePtr, TCL_READABLE|TCL_WRITABLE); + SetFlag(statePtr, statePtr->maxPerms); result = ChanClose(chanPtr, interp); ChannelFree(chanPtr); @@ -2378,7 +2378,7 @@ Tcl_GetChannelMode( ChannelState *statePtr = ((Channel *) chan)->state; /* State of actual channel. */ - return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE)); + return GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE); } /* @@ -2481,12 +2481,12 @@ Tcl_RemoveChannelMode( emsg = "Illegal mode value."; goto error; } - if (0 == (statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & ~mode)) { + if (0 == (GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & ~mode)) { emsg = "Bad mode, would make channel inacessible"; goto error; } - statePtr->flags &= ~mode; + ResetFlag(statePtr, mode); return TCL_OK; error: @@ -3706,7 +3706,7 @@ Tcl_CloseEx( * opened for that direction). */ - if (!(statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & flags)) { + if (!(GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & flags)) { const char *msg; if (flags & TCL_CLOSE_READ) { @@ -4394,6 +4394,14 @@ Write( } /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + statePtr->outputEncodingFlags |= TCL_ENCODING_STRICT; + } + + /* * Write the terminated escape sequence even if srcLen is 0. */ @@ -4709,6 +4717,14 @@ Tcl_GetsObj( } /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } + + /* * Object used by FilterInputBytes to keep track of how much data has been * consumed from the channel buffers. */ @@ -5464,6 +5480,15 @@ FilterInputBytes( *gsPtr->dstPtr = dst; } gsPtr->state = statePtr->inputEncodingState; + + /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } + result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen, statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, &statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead, @@ -6237,6 +6262,14 @@ ReadChars( } /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } + + /* * This routine is burdened with satisfying several constraints. It cannot * append more than 'charsToRead` chars onto objPtr. This is measured * after encoding and translation transformations are completed. There is @@ -6416,7 +6449,7 @@ ReadChars( return 1; } - } else if (statePtr->flags & CHANNEL_EOF) { + } else if (GotFlag(statePtr, CHANNEL_EOF)) { /* * The bare \r is the only char and we will never read a * subsequent char to make the determination. @@ -6682,7 +6715,7 @@ TranslateInputEOL( char *dst = dstStart; int lesser; - if ((statePtr->flags & INPUT_SAW_CR) && srcLen) { + if (GotFlag(statePtr, INPUT_SAW_CR) && srcLen) { if (*src == '\n') { src++; srcLen--; } ResetFlag(statePtr, INPUT_SAW_CR); } @@ -7452,7 +7485,7 @@ CheckChannelErrors( * Fail if the channel is not opened for desired operation. */ - if ((statePtr->flags & direction) == 0) { + if (GotFlag(statePtr, direction) == 0) { Tcl_SetErrno(EACCES); return -1; } @@ -7981,6 +8014,16 @@ Tcl_GetChannelOption( return TCL_OK; } } + if (len == 0 || HaveOpt(1, "-strictencoding")) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-strictencoding"); + } + Tcl_DStringAppendElement(dsPtr, + (flags & CHANNEL_ENCODING_STRICT) ? "1" : "0"); + if (len > 0) { + return TCL_OK; + } + } if (len == 0 || HaveOpt(1, "-translation")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-translation"); @@ -8249,6 +8292,16 @@ Tcl_SetChannelOption( return TCL_ERROR; } return TCL_OK; + } else if (HaveOpt(1, "-strictencoding")) { + int newMode; + + if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newMode) { + statePtr->flags |= CHANNEL_ENCODING_STRICT; + } + return TCL_OK; } else if (HaveOpt(1, "-translation")) { const char *readMode, *writeMode; @@ -9162,7 +9215,7 @@ Tcl_FileEventObjCmd( } chanPtr = (Channel *) chan; statePtr = chanPtr->state; - if ((statePtr->flags & mask) == 0) { + if (GotFlag(statePtr, mask) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("channel is not %s", (mask == TCL_READABLE) ? "readable" : "writable")); return TCL_ERROR; @@ -9329,8 +9382,8 @@ TclCopyChannel( * Make sure the output side is unbuffered. */ - outStatePtr->flags = (outStatePtr->flags & ~CHANNEL_LINEBUFFERED) - | CHANNEL_UNBUFFERED; + ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED); + SetFlag(outStatePtr, CHANNEL_UNBUFFERED); /* * Test for conditions where we know we can just move bytes from input @@ -10109,7 +10162,7 @@ DoRead( * There's no more buffered data... */ - if (statePtr->flags & CHANNEL_EOF) { + if (GotFlag(statePtr, CHANNEL_EOF)) { /* * ...and there never will be. */ @@ -10117,7 +10170,7 @@ DoRead( *p++ = '\r'; bytesToRead--; bufPtr->nextRemoved++; - } else if (statePtr->flags & CHANNEL_BLOCKED) { + } else if (GotFlag(statePtr, CHANNEL_BLOCKED)) { /* * ...and we cannot get more now. */ @@ -10250,20 +10303,20 @@ StopCopy( */ nonBlocking = csPtr->readFlags & CHANNEL_NONBLOCKING; - if (nonBlocking != (inStatePtr->flags & CHANNEL_NONBLOCKING)) { + if (nonBlocking != GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, csPtr->readPtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); } if (csPtr->readPtr != csPtr->writePtr) { nonBlocking = csPtr->writeFlags & CHANNEL_NONBLOCKING; - if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) { + if (nonBlocking != GotFlag(outStatePtr, CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, csPtr->writePtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); } } ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); - outStatePtr->flags |= - csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); + SetFlag(outStatePtr, + csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED)); if (csPtr->cmdPtr) { Tcl_DeleteChannelHandler(inChan, CopyEventProc, csPtr); diff --git a/generic/tclIO.h b/generic/tclIO.h index 3d2b7be..b86dc1d 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -273,7 +273,8 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ - +#define CHANNEL_ENCODING_STRICT (1<<18) /* set if option + * -strictencoding is set to 1 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and * usable, but it may not be closed diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index b564add..70c50cd 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -263,7 +263,7 @@ Tcl_GetIndexFromObjStruct( int offset, /* The number of bytes between entries */ const char *msg, /* Identifying word to use in error * messages. */ - int flags, /* 0, TCL_EXACT, TCL_INDEX_TEMP_TABLE or TCL_INDEX_NULL_OK */ + int flags, /* 0, TCL_EXACT, TCL_NULL_OK or TCL_INDEX_TEMP_TABLE */ void *indexPtr) /* Place to store resulting index. */ { int index, idx, numAbbrev; @@ -304,7 +304,7 @@ Tcl_GetIndexFromObjStruct( index = -1; numAbbrev = 0; - if (!*key && (flags & TCL_INDEX_NULL_OK)) { + if (!*key && (flags & TCL_NULL_OK)) { goto uncachedDone; } /* @@ -412,7 +412,7 @@ Tcl_GetIndexFromObjStruct( *entryPtr, NULL); entryPtr = NEXT_ENTRY(entryPtr, offset); while (*entryPtr != NULL) { - if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_INDEX_NULL_OK)) { + if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_NULL_OK)) { Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""), " or ", *entryPtr, NULL); } else if (**entryPtr) { @@ -421,7 +421,7 @@ Tcl_GetIndexFromObjStruct( } entryPtr = NEXT_ENTRY(entryPtr, offset); } - if ((flags & TCL_INDEX_NULL_OK)) { + if ((flags & TCL_NULL_OK)) { Tcl_AppendStringsToObj(resultPtr, ", or \"\"", NULL); } } diff --git a/generic/tclInt.h b/generic/tclInt.h index db0b4f7..e43e627 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3386,7 +3386,7 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); -MODULE_SCOPE int TclScanElement(const char *string, int length, +MODULE_SCOPE TCL_HASH_TYPE TclScanElement(const char *string, int length, char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); @@ -3689,6 +3689,9 @@ MODULE_SCOPE int Tcl_LappendObjCmd(void *clientData, MODULE_SCOPE int Tcl_LassignObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LeditObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LindexObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 5034174..78eb8a7 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1369,6 +1369,9 @@ TclListObjCopy( Tcl_Obj *copyObj; if (!TclHasInternalRep(listObj, &tclListType)) { + if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + return TclArithSeriesObjCopy(interp, listObj); + } if (SetListFromAny(interp, listObj) != TCL_OK) { return NULL; } @@ -1943,10 +1946,6 @@ Tcl_ListObjIndex( Tcl_Obj **elemObjs; ListSizeT numElems; - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - return TclArithSeriesObjIndex(listObj, index, objPtrPtr); - } - /* * TODO * Unlike the original list code, this does not optimize for lindex'ing @@ -2632,7 +2631,8 @@ TclLindexFlat( /* Handle ArithSeries as special case */ if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - ListSizeT index, listLen = TclArithSeriesObjLength(listObj); + Tcl_WideInt listLen = TclArithSeriesObjLength(listObj); + ListSizeT index; Tcl_Obj *elemObj = NULL; for (i=0 ; i<indexCount && listObj ; i++) { if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1, @@ -2640,8 +2640,8 @@ TclLindexFlat( } if (i==0) { TclArithSeriesObjIndex(listObj, index, &elemObj); - Tcl_IncrRefCount(elemObj); } else if (index > 0) { + /* ArithSeries cannot be a list of lists */ Tcl_DecrRefCount(elemObj); TclNewObj(elemObj); Tcl_IncrRefCount(elemObj); @@ -3303,7 +3303,6 @@ SetListFromAny( if (TclArithSeriesObjIndex(objPtr, j, &elemPtrs[j]) != TCL_OK) { return TCL_ERROR; } - Tcl_IncrRefCount(elemPtrs[j]);/* Since list now holds ref to it. */ } } else { @@ -3418,7 +3417,8 @@ UpdateStringOfList( { # define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - ListSizeT numElems, i, length, bytesNeeded = 0; + ListSizeT numElems, i, length; + TCL_HASH_TYPE bytesNeeded = 0; const char *elem, *start; char *dst; Tcl_Obj **elemPtrs; @@ -3466,11 +3466,11 @@ UpdateStringOfList( flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } - if (bytesNeeded > INT_MAX - numElems + 1) { + if (bytesNeeded + numElems > INT_MAX + 1U) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems - 1; diff --git a/generic/tclObj.c b/generic/tclObj.c index 5726596..4963b22 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -97,7 +97,7 @@ typedef struct { static Tcl_ThreadDataKey dataKey; -static void TclThreadFinalizeContLines(ClientData clientData); +static void TclThreadFinalizeContLines(void *clientData); static ThreadSpecificData *TclGetContLineTable(void); /* @@ -2141,7 +2141,7 @@ Tcl_SetBooleanObj( /* *---------------------------------------------------------------------- * - * Tcl_GetBooleanFromObj -- + * Tcl_GetBoolFromObj, Tcl_GetBooleanFromObj -- * * Attempt to return a boolean from the Tcl object "objPtr". This * includes conversion from any of Tcl's numeric types. @@ -2157,20 +2157,36 @@ Tcl_SetBooleanObj( *---------------------------------------------------------------------- */ +#undef Tcl_GetBoolFromObj int -Tcl_GetBooleanFromObj( +Tcl_GetBoolFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get boolean. */ - int *intPtr) /* Place to store resulting boolean. */ + int flags, + char *charPtr) /* Place to store resulting boolean. */ { + int result; + + if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) { + result = -1; + goto boolEnd; + } else if (objPtr == NULL) { + if (interp) { + TclNewObj(objPtr); + TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK) + ? "boolean value or \"\"" : "boolean value", NULL, -1, NULL, 0); + Tcl_DecrRefCount(objPtr); + } + return TCL_ERROR; + } do { if (objPtr->typePtr == &tclIntType) { - *intPtr = (objPtr->internalRep.wideValue != 0); - return TCL_OK; + result = (objPtr->internalRep.wideValue != 0); + goto boolEnd; } if (objPtr->typePtr == &tclBooleanType) { - *intPtr = objPtr->internalRep.longValue != 0; - return TCL_OK; + result = objPtr->internalRep.longValue != 0; + goto boolEnd; } if (objPtr->typePtr == &tclDoubleType) { /* @@ -2186,18 +2202,43 @@ Tcl_GetBooleanFromObj( if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { return TCL_ERROR; } - *intPtr = (d != 0.0); - return TCL_OK; + result = (d != 0.0); + goto boolEnd; } if (objPtr->typePtr == &tclBignumType) { - *intPtr = 1; + result = 1; + boolEnd: + if (charPtr != NULL) { + flags &= (TCL_NULL_OK-2); + if (flags) { + if (flags == (int)sizeof(int)) { + *(int *)charPtr = result; + return TCL_OK; + } else if (flags == (int)sizeof(short)) { + *(short *)charPtr = result; + return TCL_OK; + } + } + *charPtr = result; + } return TCL_OK; } } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == - TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); + TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK) + ? "boolean value or \"\"" : "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; } +#undef Tcl_GetBooleanFromObj +int +Tcl_GetBooleanFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object from which to get boolean. */ + int *intPtr) /* Place to store resulting boolean. */ +{ + return Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof(int), (char *)(void *)intPtr); +} + /* *---------------------------------------------------------------------- * @@ -3877,7 +3918,7 @@ int TclGetNumberFromObj( Tcl_Interp *interp, Tcl_Obj *objPtr, - ClientData *clientDataPtr, + void **clientDataPtr, int *typePtr) { do { diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index a3c5a49..c7f178f 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2039,8 +2039,8 @@ const TclStubs tclStubs = { TclUtfAtIndex, /* 671 */ TclGetRange, /* 672 */ TclGetUniChar, /* 673 */ - 0, /* 674 */ - 0, /* 675 */ + Tcl_GetBool, /* 674 */ + Tcl_GetBoolFromObj, /* 675 */ Tcl_CreateObjCommand2, /* 676 */ Tcl_CreateObjTrace2, /* 677 */ Tcl_NRCreateCommand2, /* 678 */ diff --git a/generic/tclTest.c b/generic/tclTest.c index dcd86db..95f4d2f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -145,7 +145,9 @@ typedef struct { * was called for a result. */ +#ifndef TCL_NO_DEPRECATED static int freeCount; +#endif /* TCL_NO_DEPRECATED */ /* * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands. @@ -176,6 +178,15 @@ typedef struct TestChannel { static TestChannel *firstDetached; +#ifdef __GNUC__ +/* + * The rest of this file shouldn't warn about deprecated functions; they're + * there because we intend them to be so and know that this file is OK to + * touch those fields. + */ +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif + /* * Forward declarations for procedures defined later in this file: */ @@ -288,8 +299,10 @@ static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); +#ifndef TCL_NO_DEPRECATED static Tcl_ObjCmdProc TestsaveresultCmd; static void TestsaveresultFree(char *blockPtr); +#endif /* TCL_NO_DEPRECATED */ static Tcl_CmdProc TestsetassocdataCmd; static Tcl_CmdProc TestsetCmd; static Tcl_CmdProc Testset2Cmd; @@ -681,8 +694,10 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); +#ifndef TCL_NO_DEPRECATED Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); +#endif Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, @@ -5513,6 +5528,7 @@ Testset2Cmd( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED static int TestsaveresultCmd( TCL_UNUSED(void *), @@ -5626,6 +5642,7 @@ TestsaveresultFree( { freeCount++; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index a03a60a..721237b 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -841,6 +841,35 @@ TestintobjCmd( * test a few possible corner cases in list object manipulation from * C code that cannot occur at the Tcl level. * + * Following new commands are added for 8.7 as regression tests for + * memory leaks and use-after-free. Unlike 8.6, 8.7 has multiple internal + * representations for lists. It has to be ensured that corresponding + * implementations obey the invariants of the C list API. The script + * level tests do not suffice as Tcl list commands do not execute + * the same exact code path as the exported C API. + * + * Note these new commands are only useful when Tcl is compiled with + * TCL_MEM_DEBUG defined. + * + * indexmemcheck - loops calling Tcl_ListObjIndex on each element. This + * is to test that abstract lists returning elements do not depend + * on caller to free them. The test case should check allocated counts + * with the following sequence: + * set before <get memory counts> + * testobj set VARINDEX [list a b c] (or lseq etc.) + * testlistobj indexnoop VARINDEX + * testobj unset VARINDEX + * set after <get memory counts> + * after calling this command AND freeing the passed list. The targeted + * bug is if Tcl_LOI returns a ephemeral Tcl_Obj with no other reference + * resulting in a memory leak. Conversely, the command also checks + * that the Tcl_Obj returned by Tcl_LOI does not have a zero reference + * count since it is supposed to have at least one reference held + * by the list implementation. Returns a message in interp otherwise. + * + * getelementsmemcheck - as above but for Tcl_ListObjGetElements + + * * Results: * A standard Tcl object result. * @@ -858,28 +887,34 @@ TestlistobjCmd( Tcl_Obj *const objv[]) /* Argument objects */ { /* Subcommands supported by this command */ - const char* subcommands[] = { + const char* const subcommands[] = { "set", "get", - "replace" + "replace", + "indexmemcheck", + "getelementsmemcheck", + NULL }; enum listobjCmdIndex { LISTOBJ_SET, LISTOBJ_GET, - LISTOBJ_REPLACE + LISTOBJ_REPLACE, + LISTOBJ_INDEXMEMCHECK, + LISTOBJ_GETELEMENTSMEMCHECK, } cmdIndex; size_t varIndex; /* Variable number converted to binary */ Tcl_WideInt first; /* First index in the list */ Tcl_WideInt count; /* Count of elements in a list */ Tcl_Obj **varPtr; + int i, len; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?"); return TCL_ERROR; } varPtr = GetVarPtr(interp); - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command", @@ -923,6 +958,56 @@ TestlistobjCmd( Tcl_ResetResult(interp); return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count, objc-5, objv+5); + + case LISTOBJ_INDEXMEMCHECK: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varPtr, varIndex)) { + return TCL_ERROR; + } + if (Tcl_ListObjLength(interp, varPtr[varIndex], &len) != TCL_OK) { + return TCL_ERROR; + } + for (i = 0; i < len; ++i) { + Tcl_Obj *objP; + if (Tcl_ListObjIndex(interp, varPtr[varIndex], i, &objP) + != TCL_OK) { + return TCL_ERROR; + } + if (objP->refCount <= 0) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Tcl_ListObjIndex returned object with ref count <= 0", + TCL_INDEX_NONE)); + /* Keep looping since we are also looping for leaks */ + } + } + break; + + case LISTOBJ_GETELEMENTSMEMCHECK: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varPtr, varIndex)) { + return TCL_ERROR; + } else { + Tcl_Obj **elems; + if (Tcl_ListObjGetElements(interp, varPtr[varIndex], &len, &elems) + != TCL_OK) { + return TCL_ERROR; + } + for (i = 0; i < len; ++i) { + if (elems[i]->refCount <= 0) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Tcl_ListObjGetElements element has ref count <= 0", + TCL_INDEX_NONE)); + break; + } + } + } + break; } return TCL_OK; } @@ -953,9 +1038,21 @@ TestobjCmd( { size_t varIndex, destIndex; int i; - const char *subCmd; const Tcl_ObjType *targetType; Tcl_Obj **varPtr; + const char *subcommands[] = { + "freeallvars", "bug3598580", "types", + "objtype", "newobj", "set", + "assign", "convert", "duplicate", + "invalidateStringRep", "refcount", "type", + NULL + }; + enum testobjCmdIndex { + TESTOBJ_FREEALLVARS, TESTOBJ_BUG3598580, TESTOBJ_TYPES, + TESTOBJ_OBJTYPE, TESTOBJ_NEWOBJ, TESTOBJ_SET, + TESTOBJ_ASSIGN, TESTOBJ_CONVERT, TESTOBJ_DUPLICATE, + TESTOBJ_INVALIDATESTRINGREP, TESTOBJ_REFCOUNT, TESTOBJ_TYPE, + } cmdIndex; if (objc < 2) { wrongNumArgs: @@ -964,142 +1061,159 @@ TestobjCmd( } varPtr = GetVarPtr(interp); - subCmd = Tcl_GetString(objv[1]); - if (strcmp(subCmd, "assign") == 0) { - if (objc != 4) { + if (Tcl_GetIndexFromObj( + interp, objv[1], subcommands, "command", 0, &cmdIndex) + != TCL_OK) { + return TCL_ERROR; + } + switch (cmdIndex) { + case TESTOBJ_FREEALLVARS: + if (objc != 2) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; + for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { + if (varPtr[i] != NULL) { + Tcl_DecrRefCount(varPtr[i]); + varPtr[i] = NULL; + } } - if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { - return TCL_ERROR; + return TCL_OK; + case TESTOBJ_BUG3598580: + if (objc != 2) { + goto wrongNumArgs; + } else { + Tcl_Obj *listObjPtr, *elemObjPtr; + elemObjPtr = Tcl_NewWideIntObj(123); + listObjPtr = Tcl_NewListObj(1, &elemObjPtr); + /* Replace the single list element through itself, nonsense but + * legal. */ + Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr); + Tcl_SetObjResult(interp, listObjPtr); } - SetVarToObj(varPtr, destIndex, varPtr[varIndex]); - Tcl_SetObjResult(interp, varPtr[destIndex]); - } else if (strcmp(subCmd, "bug3598580") == 0) { - Tcl_Obj *listObjPtr, *elemObjPtr; + return TCL_OK; + case TESTOBJ_TYPES: if (objc != 2) { goto wrongNumArgs; + } else { + Tcl_Obj *typesObj = Tcl_NewListObj(0, NULL); + Tcl_AppendAllObjTypes(interp, typesObj); + Tcl_SetObjResult(interp, typesObj); } - elemObjPtr = Tcl_NewWideIntObj(123); - listObjPtr = Tcl_NewListObj(1, &elemObjPtr); - /* Replace the single list element through itself, nonsense but legal. */ - Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr); - Tcl_SetObjResult(interp, listObjPtr); return TCL_OK; - } else if (strcmp(subCmd, "convert") == 0) { + case TESTOBJ_OBJTYPE: + /* + * Return an object containing the name of the argument's type of + * internal rep. If none exists, return "none". + */ - if (objc != 4) { + if (objc != 3) { goto wrongNumArgs; + } else { + const char *typeName; + + if (objv[2]->typePtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); + } + else { + typeName = objv[2]->typePtr->name; + if (!strcmp(typeName, "utf32string")) + typeName = "string"; +#ifndef TCL_WIDE_INT_IS_LONG + else if (!strcmp(typeName, "wideInt")) typeName = "int"; +#endif + Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); + } } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } - if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "no type ", Tcl_GetString(objv[3]), " found", NULL); - return TCL_ERROR; + return TCL_OK; + case TESTOBJ_NEWOBJ: + if (objc != 3) { + goto wrongNumArgs; } - if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) - != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } + SetVarToObj(varPtr, varIndex, Tcl_NewObj()); Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "duplicate") == 0) { + return TCL_OK; + case TESTOBJ_SET: if (objc != 4) { goto wrongNumArgs; } if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; + SetVarToObj(varPtr, varIndex, objv[3]); + return TCL_OK; + + default: + break; + } + + /* All further commands expect an occupied varindex argument */ + if (objc < 3) { + goto wrongNumArgs; + } + + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varPtr, varIndex)) { + return TCL_ERROR; + } + + switch (cmdIndex) { + case TESTOBJ_ASSIGN: + if (objc != 4) { + goto wrongNumArgs; } if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { return TCL_ERROR; } - SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varPtr, destIndex, varPtr[varIndex]); Tcl_SetObjResult(interp, varPtr[destIndex]); - } else if (strcmp(subCmd, "freeallvars") == 0) { - if (objc != 2) { - goto wrongNumArgs; - } - for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { - if (varPtr[i] != NULL) { - Tcl_DecrRefCount(varPtr[i]); - varPtr[i] = NULL; - } - } - } else if (strcmp(subCmd, "invalidateStringRep") == 0) { - if (objc != 3) { + break; + case TESTOBJ_CONVERT: + if (objc != 4) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { + if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "no type ", Tcl_GetString(objv[3]), " found", NULL); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) + != TCL_OK) { return TCL_ERROR; } - Tcl_InvalidateStringRep(varPtr[varIndex]); Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "newobj") == 0) { - if (objc != 3) { + break; + case TESTOBJ_DUPLICATE: + if (objc != 4) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { return TCL_ERROR; } - SetVarToObj(varPtr, varIndex, Tcl_NewObj()); - Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "objtype") == 0) { - const char *typeName; - - /* - * Return an object containing the name of the argument's type of - * internal rep. If none exists, return "none". - */ - + SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex])); + Tcl_SetObjResult(interp, varPtr[destIndex]); + break; + case TESTOBJ_INVALIDATESTRINGREP: if (objc != 3) { goto wrongNumArgs; } - if (objv[2]->typePtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); - } else { - typeName = objv[2]->typePtr->name; - if (!strcmp(typeName, "utf32string")) typeName = "string"; -#ifndef TCL_WIDE_INT_IS_LONG - else if (!strcmp(typeName, "wideInt")) typeName = "int"; -#endif - Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); - } - } else if (strcmp(subCmd, "refcount") == 0) { + Tcl_InvalidateStringRep(varPtr[varIndex]); + Tcl_SetObjResult(interp, varPtr[varIndex]); + break; + case TESTOBJ_REFCOUNT: if (objc != 3) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount)); - } else if (strcmp(subCmd, "type") == 0) { + break; + case TESTOBJ_TYPE: if (objc != 3) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); #ifndef TCL_WIDE_INT_IS_LONG @@ -1111,21 +1225,11 @@ TestobjCmd( Tcl_AppendToObj(Tcl_GetObjResult(interp), varPtr[varIndex]->typePtr->name, -1); } - } else if (strcmp(subCmd, "types") == 0) { - if (objc != 2) { - goto wrongNumArgs; - } - if (Tcl_AppendAllObjTypes(interp, - Tcl_GetObjResult(interp)) != TCL_OK) { - return TCL_ERROR; - } - } else { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad option \"", Tcl_GetString(objv[1]), - "\": must be assign, convert, duplicate, freeallvars, " - "newobj, objcount, objtype, refcount, type, or types", NULL); - return TCL_ERROR; + break; + default: + break; } + return TCL_OK; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 7ab6eae..f10187b 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -106,8 +106,8 @@ static Tcl_ThreadDataKey precisionKey; */ static void ClearHash(Tcl_HashTable *tablePtr); -static void FreeProcessGlobalValue(ClientData clientData); -static void FreeThreadHash(ClientData clientData); +static void FreeProcessGlobalValue(void *clientData); +static void FreeThreadHash(void *clientData); static int GetEndOffsetFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, Tcl_WideInt *indexPtr); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); @@ -375,10 +375,10 @@ static const Tcl_ObjType endOffsetType = { * * Given 'bytes' pointing to 'numBytes' bytes, scan through them and * count the number of whitespace runs that could be list element - * separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a - * full list parser. Typically used to get a quick and dirty overestimate - * of length size in order to allocate space for an actual list parser to - * operate with. + * separators. If 'numBytes' is TCL_INDEX_NONE, scan to the terminating + * '\0'. Not a full list parser. Typically used to get a quick and dirty + * overestimate of length size in order to allocate space for an actual + * list parser to operate with. * * Results: * Returns the largest number of list elements that could possibly be in @@ -399,7 +399,7 @@ TclMaxListLength( { int count = 0; - if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { + if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) { /* Empty string case - quick exit */ goto done; } @@ -415,7 +415,7 @@ TclMaxListLength( */ while (numBytes) { - if ((numBytes == -1) && (*bytes == '\0')) { + if ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0')) { break; } if (TclIsSpaceProcM(*bytes)) { @@ -426,9 +426,9 @@ TclMaxListLength( count++; do { bytes++; - numBytes -= (numBytes != -1); + numBytes -= (numBytes != TCL_INDEX_NONE); } while (numBytes && TclIsSpaceProcM(*bytes)); - if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { + if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) { break; } @@ -437,7 +437,7 @@ TclMaxListLength( */ } bytes++; - numBytes -= (numBytes != -1); + numBytes -= (numBytes != TCL_INDEX_NONE); } /* @@ -874,7 +874,7 @@ Tcl_SplitList( * string gets re-purposed to hold '\0' characters in the argv array. */ - size = TclMaxListLength(list, -1, &end) + 1; + size = TclMaxListLength(list, TCL_INDEX_NONE, &end) + 1; length = end - list; argv = (const char **)ckalloc((size * sizeof(char *)) + length + 1); @@ -897,7 +897,7 @@ Tcl_SplitList( ckfree(argv); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "internal error in Tcl_SplitList", -1)); + "internal error in Tcl_SplitList", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", NULL); } @@ -945,9 +945,9 @@ int Tcl_ScanElement( const char *src, /* String to convert to list element. */ int *flagPtr) /* Where to store information to guide - * Tcl_ConvertCountedElement. */ + * Tcl_ConvertCountedElement. */ { - return Tcl_ScanCountedElement(src, -1, flagPtr); + return Tcl_ScanCountedElement(src, TCL_INDEX_NONE, flagPtr); } /* @@ -958,8 +958,8 @@ Tcl_ScanElement( * This function is a companion function to Tcl_ConvertCountedElement. It * scans a string to see what needs to be done to it (e.g. add * backslashes or enclosing braces) to make the string into a valid Tcl - * list element. If length is -1, then the string is scanned from src up - * to the first null byte. + * list element. If length is TCL_INDEX_NONE, then the string is scanned + * from src up to the first null byte. * * Results: * The return value is an overestimate of the number of bytes that will @@ -976,7 +976,7 @@ Tcl_ScanElement( int Tcl_ScanCountedElement( const char *src, /* String to convert to Tcl list element. */ - int length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or TCL_INDEX_NONE. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { @@ -995,7 +995,7 @@ Tcl_ScanCountedElement( * This function is a companion function to TclConvertElement. It scans a * string to see what needs to be done to it (e.g. add backslashes or * enclosing braces) to make the string into a valid Tcl list element. If - * length is -1, then the string is scanned from src up to the first null + * length is TCL_INDEX_NONE, then the string is scanned from src up to the first null * byte. A NULL value for src is treated as an empty string. The incoming * value of *flagPtr is a report from the caller what additional flags it * will pass to TclConvertElement(). @@ -1017,10 +1017,10 @@ Tcl_ScanCountedElement( *---------------------------------------------------------------------- */ -int +TCL_HASH_TYPE TclScanElement( const char *src, /* String to convert to Tcl list element. */ - int length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { @@ -1033,7 +1033,7 @@ TclScanElement( int extra = 0; /* Count of number of extra bytes needed for * formatted element, assuming we use escape * sequences in formatting. */ - int bytesNeeded; /* Buffer length computed to complete the + TCL_HASH_TYPE bytesNeeded; /* Buffer length computed to complete the * element formatting in the selected mode. */ #if COMPAT int preferEscape = 0; /* Use preferences to track whether to use */ @@ -1041,7 +1041,7 @@ TclScanElement( int braceCount = 0; /* Count of all braces '{' '}' seen. */ #endif /* COMPAT */ - if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { + if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == TCL_INDEX_NONE))) { /* * Empty string element must be brace quoted. */ @@ -1124,7 +1124,7 @@ TclScanElement( break; case '\\': /* TYPE_SUBS */ extra++; /* Escape '\' => '\\' */ - if ((length == 1) || ((length == -1) && (p[1] == '\0'))) { + if ((length == 1) || ((length == TCL_INDEX_NONE) && (p[1] == '\0'))) { /* * Final backslash. Cannot format with brace quoting. */ @@ -1155,7 +1155,7 @@ TclScanElement( #endif /* COMPAT */ break; case '\0': /* TYPE_SUBS */ - if (length == -1) { + if (length == TCL_INDEX_NONE) { goto endOfString; } /* TODO: Panic on improper encoding? */ @@ -1297,7 +1297,7 @@ TclScanElement( *flagPtr = CONVERT_NONE; overflowCheck: - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("TclScanElement: string length overflow"); } return bytesNeeded; @@ -1330,7 +1330,7 @@ Tcl_ConvertElement( char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { - return Tcl_ConvertCountedElement(src, -1, dst, flags); + return Tcl_ConvertCountedElement(src, TCL_INDEX_NONE, dst, flags); } /* @@ -1357,7 +1357,7 @@ Tcl_ConvertElement( int Tcl_ConvertCountedElement( const char *src, /* Source information for list element. */ - int length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { @@ -1390,7 +1390,7 @@ Tcl_ConvertCountedElement( int TclConvertElement( const char *src, /* Source information for list element. */ - int length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { @@ -1409,7 +1409,7 @@ TclConvertElement( * No matter what the caller demands, empty string must be braced! */ - if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { + if ((src == NULL) || (length == 0) || (*src == '\0' && length == TCL_INDEX_NONE)) { p[0] = '{'; p[1] = '}'; return 2; @@ -1436,7 +1436,7 @@ TclConvertElement( */ if (conversion == CONVERT_NONE) { - if (length == -1) { + if (length == TCL_INDEX_NONE) { /* TODO: INT_MAX overflow? */ while (*src) { *p++ = *src++; @@ -1455,7 +1455,7 @@ TclConvertElement( if (conversion == CONVERT_BRACE) { *p = '{'; p++; - if (length == -1) { + if (length == TCL_INDEX_NONE) { /* TODO: INT_MAX overflow? */ while (*src) { *p++ = *src++; @@ -1528,7 +1528,7 @@ TclConvertElement( p++; continue; case '\0': - if (length == -1) { + if (length == TCL_INDEX_NONE) { return p - dst; } @@ -1575,7 +1575,8 @@ Tcl_Merge( { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - int i, bytesNeeded = 0; + int i; + unsigned int bytesNeeded = 0; char *result, *dst; /* @@ -1583,7 +1584,10 @@ Tcl_Merge( * simpler. */ - if (argc == 0) { + if (argc <= 0) { + if (argc < 0) { + Tcl_Panic("Tcl_Merge called with negative argc (%d)", argc); + } result = (char *)ckalloc(1); result[0] = '\0'; return result; @@ -1600,12 +1604,12 @@ Tcl_Merge( } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); - bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]); - if (bytesNeeded < 0) { + bytesNeeded += TclScanElement(argv[i], TCL_INDEX_NONE, &flagPtr[i]); + if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } - if (bytesNeeded > INT_MAX - argc + 1) { + if (bytesNeeded + argc > INT_MAX + 1U) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += argc; @@ -1618,7 +1622,7 @@ Tcl_Merge( dst = result; for (i = 0; i < argc; i++) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); - dst += TclConvertElement(argv[i], -1, dst, flagPtr[i]); + dst += TclConvertElement(argv[i], TCL_INDEX_NONE, dst, flagPtr[i]); *dst = ' '; dst++; } @@ -2661,8 +2665,8 @@ Tcl_DStringInit( char * Tcl_DStringAppend( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ - const char *bytes, /* String to append. If length is -1 then this - * must be null-terminated. */ + const char *bytes, /* String to append. If length is + * < 0 then this must be null-terminated. */ int length) /* Number of bytes from "bytes" to append. If * < 0, then append all of bytes, up to null * at end. */ @@ -2688,18 +2692,18 @@ Tcl_DStringAppend( memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { - int offset = -1; + int index = TCL_INDEX_NONE; /* See [16896d49fd] */ if (bytes >= dsPtr->string && bytes <= dsPtr->string + dsPtr->length) { - offset = bytes - dsPtr->string; + index = bytes - dsPtr->string; } dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl); - if (offset >= 0) { - bytes = dsPtr->string + offset; + if (index >= 0) { + bytes = dsPtr->string + index; } } } @@ -2798,7 +2802,7 @@ Tcl_DStringAppendElement( if (!quoteHash) { flags |= TCL_DONT_QUOTE_HASH; } - newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags); + newSize = dsPtr->length + needSpace + TclScanElement(element, TCL_INDEX_NONE, &flags); if (!quoteHash) { flags |= TCL_DONT_QUOTE_HASH; } @@ -2847,7 +2851,7 @@ Tcl_DStringAppendElement( dsPtr->length++; } - dsPtr->length += TclConvertElement(element, -1, dst, flags); + dsPtr->length += TclConvertElement(element, TCL_INDEX_NONE, dst, flags); dsPtr->string[dsPtr->length] = '\0'; return dsPtr->string; } @@ -3259,7 +3263,7 @@ Tcl_PrintDouble( */ if (*precisionPtr == 0) { - digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, + digits = TclDoubleDigits(value, TCL_INDEX_NONE, TCL_DD_SHORTEST, &exponent, &signum, &end); } else { /* @@ -3391,7 +3395,7 @@ Tcl_PrintDouble( #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 char * TclPrecTraceProc( - ClientData clientData, + void *clientData, Tcl_Interp *interp, /* Interpreter containing variable. */ const char *name1, /* Name of variable. */ const char *name2, /* Second part of variable name. */ @@ -3633,17 +3637,17 @@ TclFormatInt( static int GetWideForIndex( Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, then no error message is left after - * errors. */ + * NULL, then no error message is left after + * errors. */ Tcl_Obj *objPtr, /* Points to the value to be parsed */ size_t endValue, /* The value to be stored at *widePtr if - * objPtr holds "end". + * objPtr holds "end". * NOTE: this value may be TCL_INDEX_NONE. */ Tcl_WideInt *widePtr) /* Location filled in with a wide integer * representing an index. */ { int numType; - ClientData cd; + void *cd; int code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType); if (code == TCL_OK) { @@ -3669,21 +3673,26 @@ GetWideForIndex( * * Tcl_GetIntForIndex -- * - * This function returns an integer corresponding to the list index held - * in a Tcl object. The Tcl object's value is expected to be in the - * format integer([+-]integer)? or the format end([+-]integer)?. + * Provides an integer corresponding to the list index held in a Tcl + * object. The string value 'objPtr' is expected have the format + * integer([+-]integer)? or end([+-]integer)?. * - * Results: - * The return value is normally TCL_OK, which means that the index was - * successfully stored into the location referenced by "indexPtr". If the - * Tcl object referenced by "objPtr" has the value "end", the value - * stored is "endValue". If "objPtr"s values is not of one of the - * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, - * an error message is left in the interpreter's result object. + * Value + * TCL_OK * - * Side effects: - * The object referenced by "objPtr" might be converted to an integer, - * wide integer, or end-based-index object. + * The index is stored at the address given by by 'indexPtr'. If + * 'objPtr' has the value "end", the value stored is 'endValue'. + * + * TCL_ERROR + * + * The value of 'objPtr' does not have one of the expected formats. If + * 'interp' is non-NULL, an error message is left in the interpreter's + * result object. + * + * Effect + * + * The object referenced by 'objPtr' is converted, as needed, to an + * integer, wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ @@ -3707,7 +3716,7 @@ Tcl_GetIntForIndex( } if (indexPtr != NULL) { if ((wide < 0) && (endValue >= 0)) { - *indexPtr = -1; + *indexPtr = TCL_INDEX_NONE; } else if (wide > INT_MAX) { *indexPtr = INT_MAX; } else if (wide < INT_MIN) { @@ -3757,7 +3766,7 @@ GetEndOffsetFromObj( { Tcl_ObjInternalRep *irPtr; Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */ - ClientData cd; + void *cd; while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) { Tcl_ObjInternalRep ir; @@ -3784,7 +3793,7 @@ GetEndOffsetFromObj( * Quick scan to see if multi-value list is even possible. * This relies on TclGetString() returning a NUL-terminated string. */ - if ((TclMaxListLength(bytes, -1, NULL) > 1) + if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1) /* If it's possible, do the full list parse. */ && (TCL_OK == TclListObjLengthM(NULL, objPtr, &length)) @@ -3793,7 +3802,7 @@ GetEndOffsetFromObj( } /* Passed the list screen, so parse for index arithmetic expression */ - if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr, + if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE, &opPtr, TCL_PARSE_INTEGER_ONLY)) { Tcl_WideInt w1=0, w2=0; @@ -3809,7 +3818,7 @@ GetEndOffsetFromObj( } if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1, - -1, NULL, TCL_PARSE_INTEGER_ONLY)) { + TCL_INDEX_NONE, NULL, TCL_PARSE_INTEGER_ONLY)) { /* ... value concludes with second valid integer */ /* Save second integer as wide if possible */ @@ -4168,7 +4177,7 @@ TclCheckBadOctal( */ Tcl_AppendToObj(Tcl_GetObjResult(interp), - " (looks like invalid octal number)", -1); + " (looks like invalid octal number)", TCL_INDEX_NONE); } return 1; } @@ -4251,7 +4260,7 @@ GetThreadHash( static void FreeThreadHash( - ClientData clientData) + void *clientData) { Tcl_HashTable *tablePtr = (Tcl_HashTable *)clientData; @@ -4273,7 +4282,7 @@ FreeThreadHash( static void FreeProcessGlobalValue( - ClientData clientData) + void *clientData) { ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *)clientData; @@ -4790,7 +4799,7 @@ TclReToGlob( invalidGlob: if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); } Tcl_DStringFree(dsPtr); diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index 90896e2..4143128 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -376,7 +376,7 @@ F96D3E9108F272A6004A47F5 /* rename.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = rename.n; sourceTree = "<group>"; }; F96D3E9208F272A6004A47F5 /* return.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = return.n; sourceTree = "<group>"; }; F96D3E9308F272A6004A47F5 /* safe.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = safe.n; sourceTree = "<group>"; }; - F96D3E9408F272A6004A47F5 /* SaveResult.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SaveResult.3; sourceTree = "<group>"; }; + F96D3E9408F272A6004A47F5 /* SaveInterpState.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SaveInterpState.3; sourceTree = "<group>"; }; F96D3E9508F272A6004A47F5 /* scan.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = scan.n; sourceTree = "<group>"; }; F96D3E9608F272A6004A47F5 /* seek.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = seek.n; sourceTree = "<group>"; }; F96D3E9708F272A6004A47F5 /* set.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = set.n; sourceTree = "<group>"; }; @@ -1123,7 +1123,7 @@ F96D3E9108F272A6004A47F5 /* rename.n */, F96D3E9208F272A6004A47F5 /* return.n */, F96D3E9308F272A6004A47F5 /* safe.n */, - F96D3E9408F272A6004A47F5 /* SaveResult.3 */, + F96D3E9408F272A6004A47F5 /* SaveInterpState.3 */, F96D3E9508F272A6004A47F5 /* scan.n */, F96D3E9608F272A6004A47F5 /* seek.n */, F93599D80DF1F98300E04F67 /* self.n */, diff --git a/tests/cmdAH.test b/tests/cmdAH.test index a9e199e..cb7e1cf 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -21,6 +21,7 @@ catch [list package require -exact tcl::test [info patchlevel]] testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint time64bit [expr { $::tcl_platform(pointerSize) >= 8 || [llength [info command testsize]] && [testsize st_mtime] >= 8 @@ -178,7 +179,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -200,7 +201,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} @@ -237,10 +238,10 @@ test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.14.1 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertfrom -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.14.2 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertto -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.15.1 {Syntax error, -failindex and -nocomplain, no encoding} -body { encoding convertfrom -failindex 2 -nocomplain ABC } -returnCodes 1 -result {unknown encoding "-nocomplain"} @@ -249,19 +250,19 @@ test cmdAH-4.15.2 {Syntax error, -failindex and -nocomplain, no encoding} -body } -returnCodes 1 -result {unknown encoding "-nocomplain"} test cmdAH-4.16.1 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertfrom -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.16.2 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertto -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.17.1 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertfrom -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.17.2 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertto -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.18.1 {Syntax error, -failindex with no var, no encoding} -body { encoding convertfrom -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertfrom -failindex ABC @@ -269,12 +270,12 @@ test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.18.3 {Syntax error, -failindex with no var, no encoding} -body { encoding convertto -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertto -failindex ABC @@ -282,7 +283,7 @@ test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.19.1 {convertrom -failindex with correct data} -body { @@ -349,6 +350,25 @@ test cmdAH-4.21.2 {convertto -failindex with wrong character (byte compiled)} -s } -returnCodes 0 -result {41 1} -cleanup { rename encoding_test "" } +test cmdAH-4.22 {convertfrom -strict} -body { + encoding convertfrom -strict utf-8 A\x00B +} -result A\x00B + +test cmdAH-4.23 {convertfrom -strict} -body { + encoding convertfrom -strict utf-8 A\xC0\x80B +} -returnCodes error -result {unexpected byte sequence starting at index 1: '\xC0'} + +test cmdAH-4.24 {convertto -strict} -body { + encoding convertto -strict utf-8 A\x00B +} -result A\x00B + +test cmdAH-4.25 {convertfrom -strict} -constraints knownBug -body { + encoding convertfrom -strict utf-8 A\x80B +} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x80'} + +test cmdAH-4.26 {convertto -strict} -constraints {testbytestring knownBug} -body { + encoding convertto -strict utf-8 A[testbytestring \x80]B +} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x80'} test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file @@ -439,19 +459,19 @@ test cmdAH-8.13 {Tcl_FileObjCmd: dirname} testsetplatform { test cmdAH-8.14 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname //foo -} / +} //foo test cmdAH-8.15 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname //foo/bar -} /foo +} //foo test cmdAH-8.16 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname {//foo\/bar/baz} -} {/foo\/bar} +} {//foo\/bar} test cmdAH-8.17 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname {//foo\/bar/baz/blat} -} {/foo\/bar/baz} +} {//foo\/bar/baz} test cmdAH-8.18 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname /foo// @@ -583,7 +603,7 @@ test cmdAH-9.13 {Tcl_FileObjCmd: tail} testsetplatform { test cmdAH-9.14 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail //foo -} foo +} {} test cmdAH-9.15 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail //foo/bar diff --git a/tests/encoding.test b/tests/encoding.test index 6f11968..c8f409e 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -669,10 +669,10 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} file delete [file join [temporaryDirectory] iso2022.txt] diff --git a/tests/fCmd.test b/tests/fCmd.test index 73118f4..8c9f799 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -2598,8 +2598,8 @@ test fCmd-31.6 {file home USER} -body { # Note - as in 8.x this form does NOT necessarily give same result as # env(HOME) even when user is current user. Assume result contains user # name, else not sure how to check - file home $::tcl_platform(user) -} -match glob -result "*$::tcl_platform(user)*" + string tolower [file home $::tcl_platform(user)] +} -match glob -result [string tolower "*$::tcl_platform(user)*"] test fCmd-31.7 {file home UNKNOWNUSER} -body { file home nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} @@ -2640,8 +2640,8 @@ test fCmd-32.5 {file tildeexpand ~USER} -body { # Note - as in 8.x this form does NOT necessarily give same result as # env(HOME) even when user is current user. Assume result contains user # name, else not sure how to check - file tildeexpand ~$::tcl_platform(user) -} -match glob -result "*$::tcl_platform(user)*" + string tolower [file tildeexpand ~$::tcl_platform(user)] +} -match glob -result [string tolower "*$::tcl_platform(user)*"] test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body { file tildeexpand ~nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} @@ -2655,8 +2655,8 @@ test fCmd-32.9 {file tildeexpand ~USER/bar} -body { # Note - as in 8.x this form does NOT necessarily give same result as # env(HOME) even when user is current user. Assume result contains user # name, else not sure how to check - file tildeexpand ~$::tcl_platform(user)/bar -} -match glob -result "*$::tcl_platform(user)*/bar" + string tolower [file tildeexpand ~$::tcl_platform(user)/bar] +} -match glob -result [string tolower "*$::tcl_platform(user)*/bar"] test fCmd-32.10 {file tildeexpand ~UNKNOWNUSER} -body { file tildeexpand ~nosuchuser/foo } -returnCodes error -result {user "nosuchuser" doesn't exist} @@ -2679,8 +2679,8 @@ test fCmd-32.16 {file tildeexpand ~USER\\bar} -body { # Note - as in 8.x this form does NOT necessarily give same result as # env(HOME) even when user is current user. Assume result contains user # name, else not sure how to check - file tildeexpand ~$::tcl_platform(user)\\bar -} -constraints win -match glob -result "*$::tcl_platform(user)*/bar" + string tolower [file tildeexpand ~$::tcl_platform(user)\\bar] +} -constraints win -match glob -result [string tolower "*$::tcl_platform(user)*/bar"] # cleanup diff --git a/tests/fileName.test b/tests/fileName.test index 04273d7..575a17f 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -201,7 +201,7 @@ test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} { test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split //foo -} "/ foo" +} "//foo" test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo//bar @@ -438,14 +438,14 @@ test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join //a b -} "/a/b" +} "//a/b" test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /// a b } "/a/b" test filename-7.19 {[Bug f34cf83dd0]} { file join foo //bar -} /bar +} //bar test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 0b53be5..2bbf981 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -379,13 +379,13 @@ test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} { testPathEqual [file norm /../../] [file norm /] } ok -test filesystem-1.52 {bug f9f390d0fa: file join where strep is not canonical} -constraints unix -body { - set x //foo +test filesystem-1.52 {bug f9f390d0fa: file join where strep is not canonical} -body { + set x ///foo file normalize $x file join $x bar } -result /foo/bar test filesystem-1.52.1 {bug f9f390d0fa: file join where strep is not canonical} -body { - set x //foo + set x ///foo file normalize $x file join $x } -result /foo diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 0af12ce..c5ccb97 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -nocomplainencoding 1 -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -nocomplainencoding 1 -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -1370,7 +1370,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 1 -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 1 -strictencoding 0 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1379,7 +1379,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 1 -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 1 -strictencoding 0 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1391,7 +1391,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 1 -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 1 -strictencoding 0 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/listObj.test b/tests/listObj.test index 0b64635..0f43648 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -20,6 +20,7 @@ if {"::tcltest" ni [namespace children]} { catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] +testConstraint memory [llength [info commands memory]] catch {unset x} test listobj-1.1 {Tcl_GetListObjType} emptyTest { @@ -210,6 +211,73 @@ test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj testobj bug3598580 } 123 +# Stolen from dict.test +proc listobjmemcheck script { + set end [lindex [split [memory info] \n] 3 3] + for {set i 0} {$i < 5} {incr i} { + uplevel 1 $script + set tmp $end + set end [lindex [split [memory info] \n] 3 3] + } + expr {$end - $tmp} +} + +test listobj-12.1 {Tcl_ListObjIndex memory leaks for native lists} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lrepeat 1000 x] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-12.2 {Tcl_ListObjIndex memory leaks for native lists with spans} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [testlistrep new 1000 100 100] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-12.3 {Tcl_ListObjIndex memory leaks for lseq} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lseq 1000] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} + +test listobj-13.1 {Tcl_ListObjGetElements memory leaks for native lists} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lrepeat 1000 x] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-13.2 {Tcl_ListObjElements memory leaks for native lists with spans} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [testlistrep new 1000 100 100] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-13.3 {Tcl_ListObjElements memory leaks for lseq} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lseq 1000] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} + # cleanup ::tcltest::cleanupTests return diff --git a/tests/lreplace.test b/tests/lreplace.test index 0b26e86..2952899 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -236,6 +236,301 @@ apply {{} { } }} +# Essentially same tests as above but for ledit +test ledit-1.1 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 0 0 a] $l +} {{a 2 3 4 5} {a 2 3 4 5}} +test ledit-1.2 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 1 1 a] $l +} {{1 a 3 4 5} {1 a 3 4 5}} +test ledit-1.3 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 2 2 a] $l +} {{1 2 a 4 5} {1 2 a 4 5}} +test ledit-1.4 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 3 3 a] $l +} {{1 2 3 a 5} {1 2 3 a 5}} +test ledit-1.5 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 4 4 a] $l +} {{1 2 3 4 a} {1 2 3 4 a}} +test ledit-1.6 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 4 5 a] $l +} {{1 2 3 4 a} {1 2 3 4 a}} +test ledit-1.7 {ledit command} { + set l {1 2 3 4 5} + list [ledit l -1 -1 a] $l +} {{a 1 2 3 4 5} {a 1 2 3 4 5}} +test ledit-1.8 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 2 end a b c d] $l +} {{1 2 a b c d} {1 2 a b c d}} +test ledit-1.9 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 0 3] $l +} {5 5} +test ledit-1.10 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 0 4] $l +} {{} {}} +test ledit-1.11 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 0 1] $l +} {{3 4 5} {3 4 5}} +test ledit-1.12 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 2 3] $l +} {{1 2 5} {1 2 5}} +test ledit-1.13 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 3 end] $l +} {{1 2 3} {1 2 3}} +test ledit-1.14 {ledit command} { + set l {1 2 3 4 5} + list [ledit l -1 4 a b c] $l +} {{a b c} {a b c}} +test ledit-1.15 {ledit command} { + set l {a b "c c" d e f} + list [ledit l 3 3] $l +} {{a b {c c} e f} {a b {c c} e f}} +test ledit-1.16 {ledit command} { + set l { 1 2 3 4 5} + list [ledit l 0 0 a] $l +} {{a 2 3 4 5} {a 2 3 4 5}} +test ledit-1.17 {ledit command} { + set l {1 2 3 4 "5 6"} + list [ledit l 4 4 a] $l +} {{1 2 3 4 a} {1 2 3 4 a}} +test ledit-1.18 {ledit command} { + set l {1 2 3 4 {5 6}} + list [ledit l 4 4 a] $l +} {{1 2 3 4 a} {1 2 3 4 a}} +test ledit-1.19 {ledit command} { + set l {1 2 3 4} + list [ledit l 2 end x y z] $l +} {{1 2 x y z} {1 2 x y z}} +test ledit-1.20 {ledit command} { + set l {1 2 3 4} + list [ledit l end end a] $l +} {{1 2 3 a} {1 2 3 a}} +test ledit-1.21 {ledit command} { + set l {1 2 3 4} + list [ledit l end 3 a] $l +} {{1 2 3 a} {1 2 3 a}} +test ledit-1.22 {ledit command} { + set l {1 2 3 4} + list [ledit l end end] $l +} {{1 2 3} {1 2 3}} +test ledit-1.23 {ledit command} { + set l {1 2 3 4} + list [ledit l 2 -1 xy] $l +} {{1 2 xy 3 4} {1 2 xy 3 4}} +test ledit-1.24 {ledit command} { + set l {1 2 3 4} + list [ledit l end -1 z] $l +} {{1 2 3 z 4} {1 2 3 z 4}} +test ledit-1.25 {ledit command} { + set l {\}\ hello} + concat \"[ledit l end end]\" $l +} {"\}\ " \}\ } +test ledit-1.26 {ledit command} { + catch {unset foo} + set foo {a b} + list [ledit foo end end] $foo \ + [ledit foo end end] $foo \ + [ledit foo end end] $foo +} {a a {} {} {} {}} +test ledit-1.27 {lsubset command} -body { + set l x + list [ledit l 1 1] $l +} -result {x x} +test ledit-1.28 {ledit command} -body { + set l x + list [ledit l 1 1 y] $l +} -result {{x y} {x y}} +test ledit-1.29 {ledit command} -body { + set l x + ledit l 1 1 [error foo] +} -returnCodes 1 -result {foo} +test ledit-1.30 {ledit command} -body { + set l {not {}alist} + ledit l 0 0 [error foo] +} -returnCodes 1 -result {foo} +test ledit-1.31 {ledit command} -body { + unset -nocomplain arr + set arr(x) {a b} + list [ledit arr(x) 0 0 c] $arr(x) +} -result {{c b} {c b}} + +test ledit-2.1 {ledit errors} -body { + list [catch ledit msg] $msg +} -result {1 {wrong # args: should be "ledit listVar first last ?element ...?"}} +test ledit-2.2 {ledit errors} -body { + unset -nocomplain x + list [catch {ledit l b} msg] $msg +} -result {1 {wrong # args: should be "ledit listVar first last ?element ...?"}} +test ledit-2.3 {ledit errors} -body { + set x {} + list [catch {ledit x a 10} msg] $msg +} -result {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}} +test ledit-2.4 {ledit errors} -body { + set l {} + list [catch {ledit l 10 x} msg] $msg +} -result {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}} +test ledit-2.5 {ledit errors} -body { + set l {} + list [catch {ledit l 10 1x} msg] $msg +} -result {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} +test ledit-2.6 {ledit errors} -body { + set l x + list [catch {ledit l 3 2} msg] $msg +} -result {0 x} +test ledit-2.7 {ledit errors} -body { + set l x + list [catch {ledit l 2 2} msg] $msg +} -result {0 x} +test ledit-2.8 {ledit errors} -body { + unset -nocomplain l + ledit l 0 0 x +} -returnCodes error -result {can't read "l": no such variable} +test ledit-2.9 {ledit errors} -body { + unset -nocomplain arr + ledit arr(x) 0 0 x +} -returnCodes error -result {can't read "arr(x)": no such variable} +test ledit-2.10 {ledit errors} -body { + unset -nocomplain arr + set arr(y) y + ledit arr(x) 0 0 x +} -returnCodes error -result {can't read "arr(x)": no such element in array} + +test ledit-3.1 {ledit won't modify shared argument objects} { + proc p {} { + set l "a b c" + ledit l 1 1 "x y" + # The literal in locals table should be unmodified + return [list "a b c" $l] + } + p +} {{a b c} {a {x y} c}} + +# Following bugs were in lreplace. Make sure ledit does not have them +test ledit-4.1 {Bug ccc2c2cc98: lreplace edge case} { + set l {} + list [ledit l 1 1] $l +} {{} {}} +test ledit-4.2 {Bug ccc2c2cc98: lreplace edge case} { + set l { } + list [ledit l 1 1] $l +} {{} {}} +test ledit-4.3 {lreplace edge case} { + set l {1 2 3} + ledit l 2 0 +} {1 2 3} +test ledit-4.4 {ledit edge case} { + set l {1 2 3 4 5} + list [ledit l 3 1] $l +} {{1 2 3 4 5} {1 2 3 4 5}} +test lreplace-4.5 {lreplace edge case} { + lreplace {1 2 3 4 5} 3 0 _ +} {1 2 3 _ 4 5} +test ledit-4.6 {ledit end-x: bug a4cb3f06c4} { + set l {0 1 2 3 4} + list [ledit l 0 end-2] $l +} {{3 4} {3 4}} +test ledit-4.6.1 {ledit end-x: bug a4cb3f06c4} { + set l {0 1 2 3 4} + list [ledit l 0 end-2 a b c] $l +} {{a b c 3 4} {a b c 3 4}} +test ledit-4.7 {ledit with two end-indexes: increasing} { + set l {0 1 2 3 4} + list [ledit l end-2 end-1] $l +} {{0 1 4} {0 1 4}} +test ledit-4.7.1 {ledit with two end-indexes: increasing} { + set l {0 1 2 3 4} + list [ledit l end-2 end-1 a b c] $l +} {{0 1 a b c 4} {0 1 a b c 4}} +test ledit-4.8 {ledit with two end-indexes: equal} { + set l {0 1 2 3 4} + list [ledit l end-2 end-2] $l +} {{0 1 3 4} {0 1 3 4}} +test ledit-4.8.1 {ledit with two end-indexes: equal} { + set l {0 1 2 3 4} + list [ledit l end-2 end-2 a b c] $l +} {{0 1 a b c 3 4} {0 1 a b c 3 4}} +test ledit-4.9 {ledit with two end-indexes: decreasing} { + set l {0 1 2 3 4} + list [ledit l end-2 end-3] $l +} {{0 1 2 3 4} {0 1 2 3 4}} +test ledit-4.9.1 {ledit with two end-indexes: decreasing} { + set l {0 1 2 3 4} + list [ledit l end-2 end-3 a b c] $l +} {{0 1 a b c 2 3 4} {0 1 a b c 2 3 4}} +test ledit-4.10 {ledit with two equal indexes} { + set l {0 1 2 3 4} + list [ledit l 2 2] $l +} {{0 1 3 4} {0 1 3 4}} +test ledit-4.10.1 {ledit with two equal indexes} { + set l {0 1 2 3 4} + list [ledit l 2 2 a b c] $l +} {{0 1 a b c 3 4} {0 1 a b c 3 4}} +test ledit-4.11 {ledit end index first} { + set l {0 1 2 3 4} + list [ledit l end-2 1 a b c] $l +} {{0 1 a b c 2 3 4} {0 1 a b c 2 3 4}} +test ledit-4.12 {ledit end index first} { + set l {0 1 2 3 4} + list [ledit l end-2 2 a b c] $l +} {{0 1 a b c 3 4} {0 1 a b c 3 4}} +test ledit-4.13 {ledit empty list} { + set l {} + list [ledit l 1 1 1] $l +} {1 1} +test ledit-4.14 {ledit empty list} { + set l {} + list [ledit l 2 2 2] $l +} {2 2} + +test ledit-5.1 {compiled lreplace: Bug 47ac84309b} { + apply {x { + ledit x end 0 + }} {a b c} +} {a b c} +test ledit-5.2 {compiled lreplace: Bug 47ac84309b} { + apply {x { + ledit x end 0 A + }} {a b c} +} {a b A c} + +# Testing for compiled behaviour. Far too many variations to check with +# spelt-out tests. Note that this *just* checks whether the compiled version +# and the interpreted version are the same, not whether the interpreted +# version is correct. +apply {{} { + set lss {{} {a} {a b c} {a b c d}} + set ins {{} A {A B}} + set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2} + set lreplace lreplace + + foreach ls $lss { + foreach a $idxs { + foreach b $idxs { + foreach i $ins { + set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m] + set tester [list ledit ls $a $b {*}$i] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test ledit-6.[incr n] {ledit battery} -body \ + [list apply [list {ls} $script] $ls] -result $expected + } + } + } + } +}} + # cleanup catch {unset foo} ::tcltest::cleanupTests diff --git a/tests/lseq.test b/tests/lseq.test index ffb8a94..2e5d7e1 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { testConstraint arithSeriesDouble 1 testConstraint arithSeriesShimmer 1 -testConstraint arithSeriesShimmerOk 0 +testConstraint arithSeriesShimmerOk 1 ## Arg errors test lseq-1.1 {error cases} -body { @@ -223,6 +223,8 @@ test lseq-3.1 {experiement} { if {$ans eq {}} { set ans OK } + unset factor + unset l set ans } {OK} @@ -376,13 +378,18 @@ test lseq-3.26 {lsort shimmer} arithSeriesShimmer { list ${rep-before} $lexical_sort ${rep-after} } {arithseries {0 1 10 11 12 13 14 15 2 3 4 5 6 7 8 9} arithseries} -test lseq-3.27 {lreplace shimmer} arithSeriesShimmer { +test lseq-3.27 {lreplace shimmer} -constraints arithSeriesShimmer -body { set r [lseq 15 0] set rep-before [lindex [tcl::unsupported::representation $r] 3] set lexical_sort [lreplace $r 3 5 A B C] set rep-after [lindex [tcl::unsupported::representation $r] 3] list ${rep-before} $lexical_sort ${rep-after} -} {arithseries {15 14 13 A B C 9 8 7 6 5 4 3 2 1 0} arithseries} +} -cleanup { + unset r + unset rep-before + unset lexical_sort + unset rep-after +} -result {arithseries {15 14 13 A B C 9 8 7 6 5 4 3 2 1 0} arithseries} test lseq-3.28 {lreverse bug in ArithSeries} {} { set r [lseq -5 17 3] @@ -472,9 +479,41 @@ test lseq-4.3 {TIP examples} { set res } {{10 9 8 7 6 5 4 3 2 1} {1 2 3 4 5 6 7 8 9 10} {} {10 8 6 4 2} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} {5.0 10.0 15.0 20.0 25.0} {} {25.0 20.0 15.0 10.0 5.0} {1 3 5 7 9} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} 5 5 5} +# +# Ticket 9933cc4d88697f05976accebd31c1e3ba6efe9c6 - lseq corner case +test lseq-4.4 {lseq corner case} -body { + set tcmd { + set res {} + set s [catch {lindex [lseq 10 100] 0} e] + lappend res $s $e + set s [catch {lindex [lseq 10 9223372036854775000] 0} e] + lappend res $s $e + set s [catch {llength [lseq 10 9223372036854775000]} e] + lappend res $s $e + set s [catch {lindex [lseq 10 2147483647] 0} e] + lappend res $s $e + set s [catch {llength [lseq 10 2147483647]} e] + lappend res $s $e + } + eval $tcmd +} -cleanup { + unset res +} -result {0 10 1 {max length of a Tcl list exceeded} 1 {max length of a Tcl list exceeded} 0 10 0 2147483638} + + +# Ticket 99e834bf33 - lseq, lindex end off by one + +test lseq-4.5 {lindex off by one} -body { + lappend res [eval {lindex [lseq 1 4] end}] + lappend res [eval {lindex [lseq 1 4] end-1}] +} -cleanup { + unset res +} -result {4 3} + # cleanup ::tcltest::cleanupTests + return # Local Variables: diff --git a/tests/safe.test b/tests/safe.test index fc7c814..148215a 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1269,7 +1269,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1278,7 +1278,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data" while executing "encoding convertfrom" invoked from within @@ -1291,7 +1291,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1300,7 +1300,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data" while executing "encoding convertto" invoked from within diff --git a/tests/zlib.test b/tests/zlib.test index 6d71a81..88c1fd4 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" diff --git a/win/tcl.dsp b/win/tcl.dsp index cc9d173..aff1000 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -760,7 +760,7 @@ SOURCE=..\doc\safe.n # End Source File
# Begin Source File
-SOURCE=..\doc\SaveResult.3
+SOURCE=..\doc\SaveInterpState.3
# End Source File
# Begin Source File
|