summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2017-08-25 13:46:25 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2017-08-25 13:46:25 (GMT)
commitbeea0edb4db4751be42b6fbfb15df659cf6d0811 (patch)
tree5170c634166badec669e789ebd2b48f705ee443f
parentc2902c7efda7db40404c0773b45dd56c7c653442 (diff)
parent1dac20d62e354430a8f82e46bf0805c70cdde4e3 (diff)
downloadtcl-beea0edb4db4751be42b6fbfb15df659cf6d0811.zip
tcl-beea0edb4db4751be42b6fbfb15df659cf6d0811.tar.gz
tcl-beea0edb4db4751be42b6fbfb15df659cf6d0811.tar.bz2
Merge trunk
-rw-r--r--doc/GetInt.37
-rw-r--r--doc/continue.n2
-rw-r--r--doc/copy.n22
-rw-r--r--doc/define.n15
-rw-r--r--doc/dict.n2
-rw-r--r--doc/expr.n3
-rw-r--r--doc/format.n2
-rw-r--r--doc/regsub.n74
-rw-r--r--generic/tclCmdIL.c2
-rw-r--r--generic/tclCmdMZ.c126
-rw-r--r--generic/tclCompExpr.c2
-rw-r--r--generic/tclEncoding.c10
-rw-r--r--generic/tclIORChan.c4
-rw-r--r--generic/tclIOUtil.c4
-rw-r--r--generic/tclInt.h2
-rw-r--r--generic/tclLink.c4
-rw-r--r--generic/tclLoad.c2
-rw-r--r--generic/tclOO.c1
-rw-r--r--generic/tclOO.h2
-rw-r--r--generic/tclOOBasic.c32
-rw-r--r--generic/tclOODefineCmds.c243
-rw-r--r--generic/tclOOInt.h3
-rw-r--r--generic/tclPanic.c2
-rw-r--r--generic/tclPathObj.c64
-rw-r--r--generic/tclPipe.c8
-rw-r--r--generic/tclPkg.c17
-rwxr-xr-xgeneric/tclStrToD.c71
-rw-r--r--generic/tclStringObj.c126
-rw-r--r--generic/tclUtf.c27
-rw-r--r--generic/tclUtil.c2
-rw-r--r--library/auto.tcl4
-rw-r--r--library/init.tcl50
-rw-r--r--tests/cmdIL.test4
-rw-r--r--tests/exec.test8
-rw-r--r--tests/format.test10
-rw-r--r--tests/http.test43
-rw-r--r--tests/httpd9
-rw-r--r--tests/httpold.test17
-rw-r--r--tests/init.test10
-rw-r--r--tests/link.test21
-rw-r--r--tests/oo.test142
-rw-r--r--tests/regexp.test67
-rw-r--r--tests/regexpComp.test2
-rw-r--r--tests/string.test15
-rw-r--r--tests/util.test18
-rw-r--r--unix/tclLoadDyld.c2
-rw-r--r--unix/tclUnixPort.h8
-rw-r--r--unix/tclUnixSock.c12
-rw-r--r--unix/tclooConfig.sh2
-rw-r--r--win/makefile.vc13
-rw-r--r--win/tclWin32Dll.c4
-rw-r--r--win/tclWinFile.c2
-rw-r--r--win/tclWinPipe.c2
-rw-r--r--win/tclooConfig.sh2
54 files changed, 993 insertions, 355 deletions
diff --git a/doc/GetInt.3 b/doc/GetInt.3
index 5a3304a..eba549d 100644
--- a/doc/GetInt.3
+++ b/doc/GetInt.3
@@ -57,6 +57,9 @@ after the optional white space and sign are
.QW \fB0x\fR
then \fIsrc\fR is expected to be in hexadecimal form; otherwise,
if the first such characters are
+.QW \fB0d\fR
+then \fIsrc\fR is expected to be in decimal form; otherwise,
+if the first such characters are
.QW \fB0o\fR
then \fIsrc\fR is expected to be in octal form; otherwise,
if the first such characters are
@@ -65,8 +68,8 @@ then \fIsrc\fR is expected to be in binary form; otherwise,
if the first such character is
.QW \fB0\fR
then \fIsrc\fR
-is expected to be in octal form; otherwise, \fIsrc\fR is
-expected to be in decimal form.
+is expected to be in octal form; otherwise, \fIsrc\fR
+is expected to be in decimal form.
.PP
\fBTcl_GetDouble\fR expects \fIsrc\fR to consist of a floating-point
number, which is: white space; a sign; a sequence of digits; a
diff --git a/doc/continue.n b/doc/continue.n
index 92ff3b4..5eca861 100644
--- a/doc/continue.n
+++ b/doc/continue.n
@@ -23,7 +23,7 @@ exception to occur.
The exception causes the current script to be aborted
out to the innermost containing loop command, which then
continues with the next iteration of the loop.
-Catch exceptions are also handled in a few other situations, such
+Continue exceptions are also handled in a few other situations, such
as the \fBcatch\fR command and the outermost scripts of procedure
bodies.
.SH EXAMPLE
diff --git a/doc/copy.n b/doc/copy.n
index 100d564..706be54 100644
--- a/doc/copy.n
+++ b/doc/copy.n
@@ -14,7 +14,7 @@ oo::copy \- create copies of objects and classes
.nf
package require TclOO
-\fBoo::copy\fI sourceObject \fR?\fItargetObject\fR?
+\fBoo::copy\fI sourceObject \fR?\fItargetObject\fR? ?\fItargetNamespace\fR?
.fi
.BE
.SH DESCRIPTION
@@ -22,11 +22,21 @@ package require TclOO
The \fBoo::copy\fR command creates a copy of an object or class. It takes the
name of the object or class to be copied, \fIsourceObject\fR, and optionally
the name of the object or class to create, \fItargetObject\fR, which will be
-resolved relative to the current namespace if not an absolute qualified name.
-If \fItargetObject\fR is omitted, a new name is chosen. The copied object will
-be of the same class as the source object, and will have all its per-object
-methods copied. If it is a class, it will also have all the class methods in
-the class copied, but it will not have any of its instances copied.
+resolved relative to the current namespace if not an absolute qualified name
+and
+.VS TIP473
+\fItargetNamespace\fR which is the name of the namespace that will hold the
+internal state of the object (\fBmy\fR command, etc.); it \fImust not\fR
+refer to an existing namespace.
+If either \fItargetObject\fR or \fItargetNamespace\fR is omitted or is given
+as the empty string, a new name is chosen. Names, unless specified, are
+chosen with the same algorithm used by the \fBnew\fR method of
+\fBoo::class\fR.
+.VE TIP473
+The copied object will be of the same class as the source object, and will have
+all its per-object methods copied. If it is a class, it will also have all the
+class methods in the class copied, but it will not have any of its instances
+copied.
.PP
.VS
After the \fItargetObject\fR has been created and all definitions of its
diff --git a/doc/define.n b/doc/define.n
index 7599ec0..1692c94 100644
--- a/doc/define.n
+++ b/doc/define.n
@@ -142,6 +142,8 @@ be afterwards.
\fBself\fI subcommand arg ...\fR
.TP
\fBself\fI script\fR
+.TP
+\fBself\fR
.
This command is equivalent to calling \fBoo::objdefine\fR on the class being
defined (see \fBCONFIGURING OBJECTS\fR below for a description of the
@@ -151,6 +153,13 @@ and
.QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR"
operates identically to
.QW "\fBoo::objdefine \fIcls subcommand ...\fR" .
+.RS
+.PP
+.VS TIP470
+If no arguments at all are used, this gives the name of the class currently
+being configured.
+.VE TIP470
+.RE
.TP
\fBsuperclass\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
.VS
@@ -265,6 +274,12 @@ not previously refer to a method in that object. Does not affect the classes
that the object is an instance of. Does not change the export status of the
method; if it was exported before, it will be afterwards.
.TP
+\fBself \fR
+.
+.VS TIP470
+This gives the name of the object currently being configured.
+.VE TIP470
+.TP
\fBunexport\fI name \fR?\fIname ...\fR?
.
This arranges for each of the named methods, \fIname\fR, to be not exported
diff --git a/doc/dict.n b/doc/dict.n
index fecad85..cd7e94c 100644
--- a/doc/dict.n
+++ b/doc/dict.n
@@ -437,7 +437,7 @@ puts $foo
# prints: \fIa b foo {a b} bar 2 baz 3\fR
.CE
.SH "SEE ALSO"
-append(n), array(n), foreach(n), mapeach(n), incr(n), list(n), lappend(n), set(n)
+append(n), array(n), foreach(n), incr(n), list(n), lappend(n), lmap(n), set(n)
.SH KEYWORDS
dictionary, create, update, lookup, iterate, filter, map
'\" Local Variables:
diff --git a/doc/expr.n b/doc/expr.n
index cbb2395..d33623c 100644
--- a/doc/expr.n
+++ b/doc/expr.n
@@ -46,7 +46,8 @@ value is the form produced by the \fB%g\fR format specifier of Tcl's
An expression consists of a combination of operands, operators, parentheses and
commas, possibly with whitespace between any of these elements, which is
ignored.
-An integer operand may be specified in decimal, binary
+An integer operand may be specified in decimal (the normal case, the optional
+first two characters are \fB0d\fR), binary
(the first two characters are \fB0b\fR), octal
(the first two characters are \fB0o\fR), or hexadecimal
(the first two characters are \fB0x\fR) form. For
diff --git a/doc/format.n b/doc/format.n
index ba044f2..4eb566d 100644
--- a/doc/format.n
+++ b/doc/format.n
@@ -89,6 +89,8 @@ For \fBx\fR or \fBX\fR conversions, \fB0x\fR or \fB0X\fR (respectively)
will be added to the beginning of the result unless it is zero.
For \fBb\fR conversions, \fB0b\fR
will be added to the beginning of the result unless it is zero.
+For \fBd\fR conversions, \fB0d\fR will be added to the beginning
+of the result unless it is zero.
For all floating-point conversions (\fBe\fR, \fBE\fR, \fBf\fR,
\fBg\fR, and \fBG\fR) it guarantees that the result always
has a decimal point.
diff --git a/doc/regsub.n b/doc/regsub.n
index a5b79de..29c118a 100644
--- a/doc/regsub.n
+++ b/doc/regsub.n
@@ -68,6 +68,33 @@ and
sequences are handled for each substitution using the information
from the corresponding match.
.TP
+\fB\-command\fR
+.VS 8.7
+Changes the handling of \fIsubSpec\fR so that it is not treated
+as a template for a substitution string and the substrings
+.QW &
+and
+.QW \e\fIn\fR
+no longer have special meaning. Instead \fIsubSpec\fR must be a
+command prefix, that is, a non-empty list. The substring of \fIstring\fR
+that matches \fIexp\fR, and then each substring that matches each
+capturing sub-RE within \fIexp\fR are appended as additional elements
+to that list. (The items appended to the list are much like what
+\fBregexp\fR \fB-inline\fR would return). The completed list is then
+evaluated as a Tcl command, and the result of that command is the
+substitution string. Any error or exception from command evaluation
+becomes an error or exception from the \fBregsub\fR command.
+.RS
+.PP
+If \fB\-all\fR is not also given, the command callback will be invoked at most
+once (exactly when the regular expression matches). If \fB\-all\fR is given,
+the command callback will be invoked for each matched location, in sequence.
+The exact location indices that matched are not made available to the script.
+.PP
+See \fBEXAMPLES\fR below for illustrative cases.
+.RE
+.VE 8.7
+.TP
\fB\-expanded\fR
.
Enables use of the expanded regular expression syntax where
@@ -183,6 +210,53 @@ set substitution {[format \e\e\e\eu%04x [scan "\e\e&" %c]]}
set quoted [subst [string map {\en {\e\eu000a}} \e
[\fBregsub\fR -all $RE $string $substitution]]]
.CE
+.PP
+.VS 8.7
+The above operation can be done using \fBregsub \-command\fR instead, which is
+often faster. (A full pre-computed \fBstring map\fR would be faster still, but
+the cost of computing the map for a transformation as complex as this can be
+quite large.)
+.PP
+.CS
+# This RE is just a character class for everything "bad"
+set RE {[][{};#\e\e\e$\es\eu0080-\euffff]}
+
+# This encodes what the RE described above matches
+proc encodeChar {ch} {
+ # newline is handled specially since backslash-newline is a
+ # special sequence.
+ if {$ch eq "\en"} {
+ return "\e\eu000a"
+ }
+ # No point in writing this as a one-liner
+ scan $ch %c charNumber
+ format "\e\eu%04x" $charNumber
+}
+
+set quoted [\fBregsub\fR -all -command $RE $string encodeChar]
+.CE
+.PP
+Decoding a URL-encoded string using \fBregsub \-command\fR, a lambda term and
+the \fBapply\fR command.
+.PP
+.CS
+# Match one of the sequences in a URL-encoded string that needs
+# fixing, converting + to space and %XX to the right character
+# (e.g., %7e becomes ~)
+set RE {(\e+)|%([0-9A-Fa-f]{2})}
+
+# Note that -command uses a command prefix, not a command name
+set decoded [\fBregsub\fR -all -command $RE $string {apply {{- p h} {
+ # + is a special case; handle directly
+ if {$p eq "+"} {
+ return " "
+ }
+ # convert hex to a char
+ scan $h %x charNumber
+ format %c $charNumber
+}}}]
+.CE
+.VE 8.7
.SH "SEE ALSO"
regexp(n), re_syntax(n), subst(n), string(n)
.SH KEYWORDS
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 4a11c3b..47076ec 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -4370,7 +4370,7 @@ static int
DictionaryCompare(
const char *left, const char *right) /* The strings to compare. */
{
- Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower;
+ Tcl_UniChar uniLeft = 0, uniRight = 0, uniLeftLower, uniRightLower;
int diff, zeros;
int secondaryDiff = 0;
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index d283e6a..f28af78 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -487,26 +487,27 @@ Tcl_RegsubObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
- int start, end, subStart, subEnd, match;
+ int start, end, subStart, subEnd, match, command, numParts;
Tcl_RegExp regExpr;
Tcl_RegExpInfo info;
Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
Tcl_UniChar ch = 0, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
static const char *const options[] = {
- "-all", "-nocase", "-expanded",
- "-line", "-linestop", "-lineanchor", "-start",
+ "-all", "-command", "-expanded", "-line",
+ "-linestop", "-lineanchor", "-nocase", "-start",
"--", NULL
};
enum options {
- REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED,
- REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START,
+ REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE,
+ REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START,
REGSUB_LAST
};
cflags = TCL_REG_ADVANCED;
all = 0;
offset = 0;
+ command = 0;
resultPtr = NULL;
for (idx = 1; idx < objc; idx++) {
@@ -528,6 +529,9 @@ Tcl_RegsubObjCmd(
case REGSUB_NOCASE:
cflags |= TCL_REG_NOCASE;
break;
+ case REGSUB_COMMAND:
+ command = 1;
+ break;
case REGSUB_EXPANDED:
cflags |= TCL_REG_EXPANDED;
break;
@@ -585,7 +589,7 @@ Tcl_RegsubObjCmd(
}
}
- if (all && (offset == 0)
+ if (all && (offset == 0) && (command == 0)
&& (strpbrk(TclGetString(objv[2]), "&\\") == NULL)
&& (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
/*
@@ -661,6 +665,28 @@ Tcl_RegsubObjCmd(
return TCL_ERROR;
}
+ if (command) {
+ /*
+ * In command-prefix mode, we require that the third non-option
+ * argument be a list, so we enforce that here. Afterwards, we fetch
+ * the RE compilation again in case objv[0] and objv[2] are the same
+ * object. (If they aren't, that's cheap to do.)
+ */
+
+ if (Tcl_ListObjLength(interp, objv[2], &numParts) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (numParts < 1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command prefix must be a list of at least one element",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGSUB",
+ "CMDEMPTY", NULL);
+ return TCL_ERROR;
+ }
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
+ }
+
/*
* Make sure to avoid problems where the objects are shared. This can
* cause RegExpObj <> UnicodeObj shimmering that causes data corruption.
@@ -678,7 +704,9 @@ Tcl_RegsubObjCmd(
} else {
subPtr = objv[2];
}
- wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
+ if (!command) {
+ wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
+ }
result = TCL_OK;
@@ -737,6 +765,90 @@ Tcl_RegsubObjCmd(
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);
/*
+ * In command-prefix mode, the substitutions are added as quoted
+ * arguments to the subSpec to form a command, that is then executed
+ * and the result used as the string to substitute in. Actually,
+ * everything is passed through Tcl_EvalObjv, as that's much faster.
+ */
+
+ if (command) {
+ Tcl_Obj **args = NULL, **parts;
+ int numArgs;
+
+ Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts);
+ numArgs = numParts + info.nsubs + 1;
+ args = ckalloc(sizeof(Tcl_Obj*) * numArgs);
+ memcpy(args, parts, sizeof(Tcl_Obj*) * numParts);
+
+ for (idx = 0 ; idx <= info.nsubs ; idx++) {
+ subStart = info.matches[idx].start;
+ subEnd = info.matches[idx].end;
+ if ((subStart >= 0) && (subEnd >= 0)) {
+ args[idx + numParts] = Tcl_NewUnicodeObj(
+ wstring + offset + subStart, subEnd - subStart);
+ } else {
+ args[idx + numParts] = Tcl_NewObj();
+ }
+ Tcl_IncrRefCount(args[idx + numParts]);
+ }
+
+ /*
+ * At this point, we're locally holding the references to the
+ * argument words we added for this time round the loop, and the
+ * subPtr is holding the references to the words that the user
+ * supplied directly. None are zero-refcount, which is important
+ * because Tcl_EvalObjv is "hairy monster" in terms of refcount
+ * handling, being able to optionally add references to any of its
+ * argument words. We'll drop the local refs immediately
+ * afterwards; subPtr is handled in the main exit stanza.
+ */
+
+ result = Tcl_EvalObjv(interp, numArgs, args, 0);
+ for (idx = 0 ; idx <= info.nsubs ; idx++) {
+ TclDecrRefCount(args[idx + numParts]);
+ }
+ ckfree(args);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (%s substitution computation script)",
+ options[REGSUB_COMMAND]));
+ }
+ goto done;
+ }
+
+ Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));
+ Tcl_ResetResult(interp);
+
+ /*
+ * Refetch the unicode, in case the representation was smashed by
+ * the user code.
+ */
+
+ wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
+
+ offset += end;
+ if (end == 0 || start == end) {
+ /*
+ * Always consume at least one character of the input string
+ * in order to prevent infinite loops, even when we
+ * technically matched the empty string; we must not match
+ * again at the same spot.
+ */
+
+ if (offset < wlen) {
+ Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
+ }
+ offset++;
+ }
+ if (all) {
+ continue;
+ } else {
+ break;
+ }
+ }
+
+ /*
* Append the subSpec argument to the variable, making appropriate
* substitutions. This code is a bit hairy because of the backslash
* conventions and because the code saves up ranges of characters in
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 24c8896..b854b0f 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -1885,7 +1885,7 @@ ParseLexeme(
{
const char *end;
int scanned;
- Tcl_UniChar ch;
+ Tcl_UniChar ch = 0;
Tcl_Obj *literal = NULL;
unsigned char byte;
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 35cbfc9..8147242 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -2345,8 +2345,8 @@ UtfToUtfProc(
} else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
/*
* Always check before using TclUtfToUniChar. Not doing can so
- * cause it run beyond the endof the buffer! If we happen such an
- * incomplete char its byts are made to represent themselves.
+ * cause it run beyond the end of the buffer! If we happen such an
+ * incomplete char its bytes are made to represent themselves.
*/
*chPtr = (unsigned char) *src;
@@ -2866,7 +2866,7 @@ Iso88591ToUtfProc(
result = TCL_OK;
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
- Tcl_UniChar ch;
+ Tcl_UniChar ch = 0;
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
@@ -2952,7 +2952,7 @@ Iso88591FromUtfProc(
dstEnd = dst + dstLen - 1;
for (numChars = 0; src < srcEnd; numChars++) {
- Tcl_UniChar ch;
+ Tcl_UniChar ch = 0;
int len;
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
@@ -3339,7 +3339,7 @@ EscapeFromUtfProc(
for (numChars = 0; src < srcEnd; numChars++) {
unsigned len;
int word;
- Tcl_UniChar ch;
+ Tcl_UniChar ch = 0;
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index aefa104..8e1496d 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -41,6 +41,8 @@ static void ReflectWatch(ClientData clientData, int mask);
static int ReflectBlock(ClientData clientData, int mode);
#ifdef TCL_THREADS
static void ReflectThread(ClientData clientData, int action);
+static int ReflectEventRun(Tcl_Event *ev, int flags);
+static int ReflectEventDelete(Tcl_Event *ev, ClientData cd);
#endif
static Tcl_WideInt ReflectSeekWide(ClientData clientData,
Tcl_WideInt offset, int mode, int *errorCodePtr);
@@ -748,6 +750,7 @@ TclChanCreateObjCmd(
*----------------------------------------------------------------------
*/
+#ifdef TCL_THREADS
typedef struct {
Tcl_Event header;
ReflectedChannel *rcPtr;
@@ -791,6 +794,7 @@ ReflectEventDelete(
}
return 1;
}
+#endif
int
TclChanPostEventObjCmd(
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index ea407ab..2c389c6 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1764,7 +1764,7 @@ Tcl_FSEvalFileEx(
* this cross-platform to allow for scripted documents. [Bug: 2040]
*/
- Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");
+ Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}");
/*
* If the encoding is specified, set it for the channel. Else don't touch
@@ -1899,7 +1899,7 @@ TclNREvalFile(
* this cross-platform to allow for scripted documents. [Bug: 2040]
*/
- Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");
+ Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}");
/*
* If the encoding is specified, set it for the channel. Else don't touch
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3aaff6d..118af85 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4408,7 +4408,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
#define TclUtfToUniChar(str, chPtr) \
((((unsigned char) *(str)) < 0xC0) ? \
- ((*(chPtr) = (Tcl_UniChar) *(str)), 1) \
+ ((*(chPtr) = (unsigned char) *(str)), 1) \
: Tcl_UtfToUniChar(str, chPtr))
/*
diff --git a/generic/tclLink.c b/generic/tclLink.c
index a39dfcd..7366acc 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -692,7 +692,7 @@ SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) {
/*
* This function checks for integer representations, which are valid
* when linking with C variables, but which are invalid in other
- * contexts in Tcl. Handled are "+", "-", "", "0x", "0b" and "0o"
+ * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o"
* (upperand lowercase). See bug [39f6304c2e].
*/
int
@@ -701,7 +701,7 @@ GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr)
const char *str = TclGetString(objPtr);
if ((objPtr->length == 0) ||
- ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1]))) {
+ ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) {
*intPtr = 0;
return TCL_OK;
} else if ((objPtr->length == 1) && strchr("+-", str[0])) {
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 66637da..e0bb5ef 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -130,7 +130,7 @@ Tcl_LoadObjCmd(
Tcl_PackageInitProc *initProc;
const char *p, *fullFileName, *packageName;
Tcl_LoadHandle loadHandle;
- Tcl_UniChar ch;
+ Tcl_UniChar ch = 0;
unsigned len;
int index, flags = 0;
Tcl_Obj *const *savedobjv = objv;
diff --git a/generic/tclOO.c b/generic/tclOO.c
index ef0c987..73acce8 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -41,6 +41,7 @@ static const struct {
{"forward", TclOODefineForwardObjCmd, 1},
{"method", TclOODefineMethodObjCmd, 1},
{"renamemethod", TclOODefineRenameMethodObjCmd, 1},
+ {"self", TclOODefineObjSelfObjCmd, 0},
{"unexport", TclOODefineUnexportObjCmd, 1},
{NULL, NULL, 0}
};
diff --git a/generic/tclOO.h b/generic/tclOO.h
index 696908a..d051e79 100644
--- a/generic/tclOO.h
+++ b/generic/tclOO.h
@@ -24,7 +24,7 @@
* win/tclooConfig.sh
*/
-#define TCLOO_VERSION "1.0.4"
+#define TCLOO_VERSION "1.2.0"
#define TCLOO_PATCHLEVEL TCLOO_VERSION
#include "tcl.h"
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 8cb80e5..b2c06a7 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -1183,8 +1183,9 @@ TclOOCopyObjectCmd(
{
Tcl_Object oPtr, o2Ptr;
- if (objc < 2 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?");
+ if (objc < 2 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "sourceName ?targetName? ?targetNamespace?");
return TCL_ERROR;
}
@@ -1204,12 +1205,14 @@ TclOOCopyObjectCmd(
if (objc == 2) {
o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL);
} else {
- const char *name;
+ const char *name, *namespaceName;
Tcl_DString buffer;
name = TclGetString(objv[2]);
Tcl_DStringInit(&buffer);
- if (name[0]!=':' || name[1]!=':') {
+ if (name[0] == '\0') {
+ name = NULL;
+ } else if (name[0]!=':' || name[1]!=':') {
Interp *iPtr = (Interp *) interp;
if (iPtr->varFramePtr != NULL) {
@@ -1220,7 +1223,26 @@ TclOOCopyObjectCmd(
Tcl_DStringAppend(&buffer, name, -1);
name = Tcl_DStringValue(&buffer);
}
- o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, NULL);
+
+ /*
+ * Choose a unique namespace name if the user didn't supply one.
+ */
+
+ namespaceName = NULL;
+ if (objc == 4) {
+ namespaceName = TclGetString(objv[3]);
+
+ if (namespaceName[0] == '\0') {
+ namespaceName = NULL;
+ } else if (Tcl_FindNamespace(interp, namespaceName, NULL,
+ 0) != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s refers to an existing namespace", namespaceName));
+ return TCL_ERROR;
+ }
+ }
+
+ o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName);
Tcl_DStringFree(&buffer);
}
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 5b0dfc3..b0bfd9c 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -47,8 +47,11 @@ struct DeclaredSlot {
static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr);
-static void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
+static inline void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
Tcl_Obj *savedNameObj, const char *typeOfSubject);
+static inline int MagicDefinitionInvoke(Tcl_Interp *interp,
+ Tcl_Namespace *nsPtr, int cmdIndex,
+ int objc, Tcl_Obj *const *objv);
static inline Class * GetClassInOuterContext(Tcl_Interp *interp,
Tcl_Obj *className, const char *errMsg);
static inline int InitDefineContext(Tcl_Interp *interp,
@@ -755,7 +758,7 @@ GetClassInOuterContext(
* ----------------------------------------------------------------------
*/
-static void
+static inline void
GenerateErrorInfo(
Tcl_Interp *interp, /* Where to store the error info trace. */
Object *oPtr, /* What object (or class) was being configured
@@ -787,6 +790,69 @@ GenerateErrorInfo(
/*
* ----------------------------------------------------------------------
*
+ * MagicDefinitionInvoke --
+ * Part of the implementation of the "oo::define" and "oo::objdefine"
+ * commands that is used to implement the more-than-one-argument case,
+ * applying ensemble-like tricks with dispatch so that error messages are
+ * clearer. Doesn't handle the management of the stack frame.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+MagicDefinitionInvoke(
+ Tcl_Interp *interp,
+ Tcl_Namespace *nsPtr,
+ int cmdIndex,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *objPtr, *obj2Ptr, **objs;
+ Tcl_Command cmd;
+ int isRoot, dummy, result, offset = cmdIndex + 1;
+
+ /*
+ * More than one argument: fire them through the ensemble processing
+ * engine so that everything appears to be good and proper in error
+ * messages. Note that we cannot just concatenate and send through
+ * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we cannot go
+ * through Tcl_EvalObjv without the extra work to pre-find the command, as
+ * that finds command names in the wrong namespace at the moment. Ugly!
+ */
+
+ isRoot = TclInitRewriteEnsemble(interp, offset, 1, objv);
+
+ /*
+ * Build the list of arguments using a Tcl_Obj as a workspace. See
+ * comments above for why these contortions are necessary.
+ */
+
+ objPtr = Tcl_NewObj();
+ obj2Ptr = Tcl_NewObj();
+ cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
+ if (cmd == NULL) {
+ /* punt this case! */
+ Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
+ } else {
+ Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+ }
+ Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+ /* TODO: overflow? */
+ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-offset, objv+offset);
+ Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+ result = Tcl_EvalObjv(interp, objc-cmdIndex, objs, TCL_EVAL_INVOKE);
+ if (isRoot) {
+ TclResetRewriteEnsemble(interp, 1);
+ }
+ Tcl_DecrRefCount(objPtr);
+
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOODefineObjCmd --
* Implementation of the "oo::define" command. Works by effectively doing
* the same as 'namespace eval', but with extra magic applied so that the
@@ -805,8 +871,8 @@ TclOODefineObjCmd(
Tcl_Obj *const *objv)
{
Foundation *fPtr = TclOOGetFoundation(interp);
- int result;
Object *oPtr;
+ int result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?");
@@ -846,46 +912,7 @@ TclOODefineObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- Tcl_Obj *objPtr, *obj2Ptr, **objs;
- Tcl_Command cmd;
- int isRoot, dummy;
-
- /*
- * More than one argument: fire them through the ensemble processing
- * engine so that everything appears to be good and proper in error
- * messages. Note that we cannot just concatenate and send through
- * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
- * cannot go through Tcl_EvalObjv without the extra work to pre-find
- * the command, as that finds command names in the wrong namespace at
- * the moment. Ugly!
- */
-
- isRoot = TclInitRewriteEnsemble(interp, 3, 1, objv);
-
- /*
- * Build the list of arguments using a Tcl_Obj as a workspace. See
- * comments above for why these contortions are necessary.
- */
-
- objPtr = Tcl_NewObj();
- obj2Ptr = Tcl_NewObj();
- cmd = FindCommand(interp, objv[2], fPtr->defineNs);
- if (cmd == NULL) {
- /* punt this case! */
- Tcl_AppendObjToObj(obj2Ptr, objv[2]);
- } else {
- Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
- }
- Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
- /* TODO: overflow? */
- Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
- Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
-
- result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
- if (isRoot) {
- TclResetRewriteEnsemble(interp, 1);
- }
- Tcl_DecrRefCount(objPtr);
+ result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv);
}
DelRef(oPtr);
@@ -918,8 +945,8 @@ TclOOObjDefObjCmd(
Tcl_Obj *const *objv)
{
Foundation *fPtr = TclOOGetFoundation(interp);
- int isRoot, result;
Object *oPtr;
+ int result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?");
@@ -952,47 +979,7 @@ TclOOObjDefObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- Tcl_Obj *objPtr, *obj2Ptr, **objs;
- Tcl_Command cmd;
- int dummy;
-
- /*
- * More than one argument: fire them through the ensemble processing
- * engine so that everything appears to be good and proper in error
- * messages. Note that we cannot just concatenate and send through
- * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
- * cannot go through Tcl_EvalObjv without the extra work to pre-find
- * the command, as that finds command names in the wrong namespace at
- * the moment. Ugly!
- */
-
- isRoot = TclInitRewriteEnsemble(interp, 3, 1, objv);
-
- /*
- * Build the list of arguments using a Tcl_Obj as a workspace. See
- * comments above for why these contortions are necessary.
- */
-
- objPtr = Tcl_NewObj();
- obj2Ptr = Tcl_NewObj();
- cmd = FindCommand(interp, objv[2], fPtr->objdefNs);
- if (cmd == NULL) {
- /* punt this case! */
- Tcl_AppendObjToObj(obj2Ptr, objv[2]);
- } else {
- Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
- }
- Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
- /* TODO: overflow? */
- Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
- Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
-
- result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
-
- if (isRoot) {
- TclResetRewriteEnsemble(interp, 1);
- }
- Tcl_DecrRefCount(objPtr);
+ result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv);
}
DelRef(oPtr);
@@ -1025,19 +1012,19 @@ TclOODefineSelfObjCmd(
Tcl_Obj *const *objv)
{
Foundation *fPtr = TclOOGetFoundation(interp);
- int result;
Object *oPtr;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
- return TCL_ERROR;
- }
+ int result;
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
+ if (objc < 2) {
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+ return TCL_OK;
+ }
+
/*
* Make the oo::objdefine namespace the current namespace and evaluate the
* command(s).
@@ -1059,46 +1046,7 @@ TclOODefineSelfObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- Tcl_Obj *objPtr, *obj2Ptr, **objs;
- Tcl_Command cmd;
- int isRoot, dummy;
-
- /*
- * More than one argument: fire them through the ensemble processing
- * engine so that everything appears to be good and proper in error
- * messages. Note that we cannot just concatenate and send through
- * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
- * cannot go through Tcl_EvalObjv without the extra work to pre-find
- * the command, as that finds command names in the wrong namespace at
- * the moment. Ugly!
- */
-
- isRoot = TclInitRewriteEnsemble(interp, 2, 1, objv);
-
- /*
- * Build the list of arguments using a Tcl_Obj as a workspace. See
- * comments above for why these contortions are necessary.
- */
-
- objPtr = Tcl_NewObj();
- obj2Ptr = Tcl_NewObj();
- cmd = FindCommand(interp, objv[1], fPtr->objdefNs);
- if (cmd == NULL) {
- /* punt this case! */
- Tcl_AppendObjToObj(obj2Ptr, objv[1]);
- } else {
- Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
- }
- Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
- /* TODO: overflow? */
- Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-2, objv+2);
- Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
-
- result = Tcl_EvalObjv(interp, objc-1, objs, TCL_EVAL_INVOKE);
- if (isRoot) {
- TclResetRewriteEnsemble(interp, 1);
- }
- Tcl_DecrRefCount(objPtr);
+ result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv);
}
DelRef(oPtr);
@@ -1113,6 +1061,39 @@ TclOODefineSelfObjCmd(
/*
* ----------------------------------------------------------------------
*
+ * TclOODefineObjSelfObjCmd --
+ * Implementation of the "self" subcommand of the "oo::objdefine"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineObjSelfObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOODefineClassObjCmd --
* Implementation of the "class" subcommand of the "oo::objdefine"
* command.
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index ae24dee..476446d 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -431,6 +431,9 @@ MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData,
MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineObjSelfObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
diff --git a/generic/tclPanic.c b/generic/tclPanic.c
index b032449..b03ad41 100644
--- a/generic/tclPanic.c
+++ b/generic/tclPanic.c
@@ -111,7 +111,7 @@ Tcl_PanicVA(
__builtin_trap();
# elif defined(_WIN64)
__debugbreak();
-# elif defined(_MSC_VER)
+# elif defined(_MSC_VER) && defined (_M_IX86)
_asm {int 3}
# else
DebugBreak();
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 5984c16..49d62dc 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -13,6 +13,7 @@
#include "tclInt.h"
#include "tclFileSystem.h"
+#include <assert.h>
/*
* Prototypes for functions defined later in this file.
@@ -849,18 +850,20 @@ TclJoinPath(
int elements,
Tcl_Obj * const objv[])
{
- Tcl_Obj *res;
+ Tcl_Obj *res = NULL;
int i;
const Tcl_Filesystem *fsPtr = NULL;
- res = NULL;
+ assert ( elements >= 0 );
- for (i = 0; i < elements; i++) {
- int driveNameLength, strEltLen, length;
- Tcl_PathType type;
- char *strElt, *ptr;
- Tcl_Obj *driveName = NULL;
- Tcl_Obj *elt = objv[i];
+ if (elements == 0) {
+ return Tcl_NewObj();
+ }
+
+ assert ( elements > 0 );
+
+ if (elements == 2) {
+ Tcl_Obj *elt = objv[0];
/*
* This is a special case where we can be much more efficient, where
@@ -869,18 +872,17 @@ TclJoinPath(
* object which can be normalized more efficiently. Currently we only
* use the special case when we have exactly two elements, but we
* could expand that in the future.
- *
- * Bugfix [a47641a0]. TclNewFSPathObj requires first argument
- * to be an absolute path. Added a check for that elt is absolute.
+ *
+ * Bugfix [a47641a0]. TclNewFSPathObj requires first argument
+ * to be an absolute path. Added a check for that elt is absolute.
*/
- if ((i == (elements-2)) && (i == 0)
- && (elt->typePtr == &tclFsPathType)
+ if ((elt->typePtr == &tclFsPathType)
&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
&& TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
- Tcl_Obj *tailObj = objv[i+1];
+ Tcl_Obj *tailObj = objv[1];
+ Tcl_PathType type = TclGetPathType(tailObj, NULL, NULL, NULL);
- type = TclGetPathType(tailObj, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
const char *str;
int len;
@@ -893,9 +895,6 @@ TclJoinPath(
* the base itself is just fine!
*/
- if (res != NULL) {
- TclDecrRefCount(res);
- }
return elt;
}
@@ -918,9 +917,6 @@ TclJoinPath(
if ((tclPlatform != TCL_PLATFORM_WINDOWS)
|| (strchr(Tcl_GetString(elt), '\\') == NULL)) {
- if (res != NULL) {
- TclDecrRefCount(res);
- }
if (PATHFLAGS(elt)) {
return TclNewFSPathObj(elt, str, len);
@@ -940,23 +936,28 @@ TclJoinPath(
* more general code below handle things.
*/
} else if (tclPlatform == TCL_PLATFORM_UNIX) {
- if (res != NULL) {
- TclDecrRefCount(res);
- }
return tailObj;
} else {
const char *str = TclGetString(tailObj);
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
if (strchr(str, '\\') == NULL) {
- if (res != NULL) {
- TclDecrRefCount(res);
- }
return tailObj;
}
}
}
}
+ }
+
+ assert ( res == NULL );
+
+ for (i = 0; i < elements; i++) {
+ int driveNameLength, strEltLen, length;
+ Tcl_PathType type;
+ char *strElt, *ptr;
+ Tcl_Obj *driveName = NULL;
+ Tcl_Obj *elt = objv[i];
+
strElt = TclGetStringFromObj(elt, &strEltLen);
driveNameLength = 0;
type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
@@ -1051,10 +1052,8 @@ TclJoinPath(
noQuickReturn:
if (res == NULL) {
res = Tcl_NewObj();
- ptr = TclGetStringFromObj(res, &length);
- } else {
- ptr = TclGetStringFromObj(res, &length);
}
+ ptr = TclGetStringFromObj(res, &length);
/*
* Strip off any './' before a tilde, unless this is the beginning of
@@ -1087,6 +1086,7 @@ TclJoinPath(
if (sep != NULL) {
separator = TclGetString(sep)[0];
+ TclDecrRefCount(sep);
}
/* Safety check in case the VFS driver caused sharing */
if (Tcl_IsShared(res)) {
@@ -1122,9 +1122,7 @@ TclJoinPath(
Tcl_SetObjLength(res, length);
}
}
- if (res == NULL) {
- res = Tcl_NewObj();
- }
+ assert ( res != NULL );
return res;
}
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index d6cd188..b679ec4 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -668,7 +668,13 @@ TclCreatePipeline(
if (*p == '>') {
p++;
atOK = 0;
- flags = O_WRONLY | O_CREAT;
+
+ /*
+ * Note that the O_APPEND flag only has an effect on POSIX
+ * platforms. On Windows, we just have to carry on regardless.
+ */
+
+ flags = O_WRONLY | O_CREAT | O_APPEND;
}
if (errorClose != 0) {
errorClose = 0;
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 3b0554a..eb4dc9b 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -331,8 +331,8 @@ Tcl_PkgRequireEx(
*
* Second, how does this work? If we reach this point, then the global
* variable tclEmptyStringRep has the value NULL. Compare that with
- * the definition of tclEmptyStringRep near the top of the file
- * generic/tclObj.c. It clearly should not have the value NULL; it
+ * the definition of tclEmptyStringRep near the top of this file.
+ * It clearly should not have the value NULL; it
* should point to the char tclEmptyString. If we see it having the
* value NULL, then somehow we are seeing a Tcl library that isn't
* completely initialized, and that's an indicator for the error
@@ -348,18 +348,11 @@ Tcl_PkgRequireEx(
* After all, two Tcl libraries can't be a good thing!)
*
* Trouble is that's going to be tricky. We're now using a Tcl library
- * that's not fully initialized. In particular, it doesn't have a
- * proper value for tclEmptyStringRep. The Tcl_Obj system heavily
- * depends on the value of tclEmptyStringRep and all of Tcl depends
- * (increasingly) on the Tcl_Obj system, we need to correct that flaw
- * before making the calls to set the interpreter result to the error
- * message. That's the only flaw corrected; other problems with
- * initialization of the Tcl library are not remedied, so be very
- * careful about adding any other calls here without checking how they
- * behave when initialization is incomplete.
+ * that's not fully initialized. Functions in it may not work
+ * reliably, so be very careful about adding any other calls here
+ * without checking how they behave when initialization is incomplete.
*/
- tclEmptyStringRep = &tclEmptyString;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Cannot load package \"%s\" in standalone executable:"
" This package is not compiled with stub support", name));
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index c7fdc5a..539a92c 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -482,7 +482,7 @@ TclParseNumber(
{
enum State {
INITIAL, SIGNUM, ZERO, ZERO_X,
- ZERO_O, ZERO_B, BINARY,
+ ZERO_O, ZERO_B, ZERO_D, BINARY,
HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL,
LEADING_RADIX_POINT, FRACTION,
EXPONENT_START, EXPONENT_SIGNUM, EXPONENT,
@@ -664,6 +664,10 @@ TclParseNumber(
state = ZERO_O;
break;
}
+ if (c == 'd' || c == 'D') {
+ state = ZERO_D;
+ break;
+ }
#ifdef TCL_NO_DEPRECATED
goto decimal;
#endif
@@ -880,6 +884,16 @@ TclParseNumber(
state = BINARY;
break;
+ case ZERO_D:
+ if (c == '0') {
+ numTrailZeros++;
+ } else if ( ! isdigit(UCHAR(c))) {
+ goto endgame;
+ }
+ state = DECIMAL;
+ flags |= TCL_PARSE_INTEGER_ONLY;
+ /* FALLTHROUGH */
+
case DECIMAL:
/*
* Scanned an optional + or - followed by a string of decimal
@@ -1176,6 +1190,7 @@ TclParseNumber(
case ZERO_X:
case ZERO_O:
case ZERO_B:
+ case ZERO_D:
case LEADING_RADIX_POINT:
case EXPONENT_START:
case EXPONENT_SIGNUM:
@@ -1190,9 +1205,9 @@ TclParseNumber(
case sNA:
case sNANPAREN:
case sNANHEX:
+#endif
Tcl_Panic("TclParseNumber: bad acceptState %d parsing '%s'",
acceptState, bytes);
-#endif
case BINARY:
shift = numTrailZeros;
if (!significandOverflow && significandWide != 0 &&
@@ -1980,7 +1995,7 @@ RefineApproximation(
*----------------------------------------------------------------------
*/
-inline static void
+static inline void
MulPow5(
mp_int *base, /* Number to multiply. */
unsigned n, /* Power of 5 to multiply by. */
@@ -2025,7 +2040,7 @@ MulPow5(
*----------------------------------------------------------------------
*/
-inline static int
+static inline int
NormalizeRightward(
Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */
{
@@ -2116,7 +2131,7 @@ RequiredPrecision(
*----------------------------------------------------------------------
*/
-inline static void
+static inline void
DoubleToExpAndSig(
double dv, /* Number to convert. */
Tcl_WideUInt *significand, /* OUTPUT: Significand of the number. */
@@ -2164,7 +2179,7 @@ DoubleToExpAndSig(
*----------------------------------------------------------------------
*/
-inline static void
+static inline void
TakeAbsoluteValue(
Double *d, /* Number to replace with absolute value. */
int *sign) /* Place to put the signum. */
@@ -2195,7 +2210,7 @@ TakeAbsoluteValue(
*----------------------------------------------------------------------
*/
-inline static char *
+static inline char *
FormatInfAndNaN(
Double *d, /* Exceptional number to format. */
int *decpt, /* Decimal point to set to a bogus value. */
@@ -2237,7 +2252,7 @@ FormatInfAndNaN(
*----------------------------------------------------------------------
*/
-inline static char *
+static inline char *
FormatZero(
int *decpt, /* Location of the decimal point. */
char **endPtr) /* Pointer to the end of the formatted data */
@@ -2267,7 +2282,7 @@ FormatZero(
*----------------------------------------------------------------------
*/
-inline static int
+static inline int
ApproximateLog10(
Tcl_WideUInt bw, /* Integer significand of the number. */
int be, /* Power of two to scale bw. */
@@ -2315,7 +2330,7 @@ ApproximateLog10(
*----------------------------------------------------------------------
*/
-inline static int
+static inline int
BetterLog10(
double d, /* Original number to format. */
int k, /* Characteristic(Log base 10) of the
@@ -2358,7 +2373,7 @@ BetterLog10(
*----------------------------------------------------------------------
*/
-inline static void
+static inline void
ComputeScale(
int be, /* Exponent part of number: d = bw * 2**be. */
int k, /* Characteristic of log10(number). */
@@ -2421,7 +2436,7 @@ ComputeScale(
*----------------------------------------------------------------------
*/
-inline static void
+static inline void
SetPrecisionLimits(
int convType, /* Type of conversion: TCL_DD_SHORTEST,
* TCL_DD_STEELE0, TCL_DD_E_FMT,
@@ -2482,7 +2497,7 @@ SetPrecisionLimits(
*----------------------------------------------------------------------
*/
-inline static char *
+static inline char *
BumpUp(
char *s, /* Cursor pointing one past the end of the
* string. */
@@ -2516,7 +2531,7 @@ BumpUp(
*----------------------------------------------------------------------
*/
-inline static int
+static inline int
AdjustRange(
double *dPtr, /* INOUT: Number to adjust. */
int k) /* IN: floor(log10(d)) */
@@ -2589,7 +2604,7 @@ AdjustRange(
*----------------------------------------------------------------------
*/
-inline static char *
+static inline char *
ShorteningQuickFormat(
double d, /* Number to convert. */
int k, /* floor(log10(d)) */
@@ -2664,7 +2679,7 @@ ShorteningQuickFormat(
*----------------------------------------------------------------------
*/
-inline static char *
+static inline char *
StrictQuickFormat(
double d, /* Number to convert. */
int k, /* floor(log10(d)) */
@@ -2738,7 +2753,7 @@ StrictQuickFormat(
*----------------------------------------------------------------------
*/
-inline static char *
+static inline char *
QuickConversion(
double e, /* Number to format. */
int k, /* floor(log10(d)), approximately. */
@@ -2843,7 +2858,7 @@ QuickConversion(
*----------------------------------------------------------------------
*/
-inline static void
+static inline void
CastOutPowersOf2(
int *b2, /* Power of 2 to multiply the significand. */
int *m2, /* Power of 2 to multiply 1/2 ulp. */
@@ -2887,7 +2902,7 @@ CastOutPowersOf2(
*----------------------------------------------------------------------
*/
-inline static char *
+static inline char *
ShorteningInt64Conversion(
Double *dPtr, /* Original number to convert. */
int convType, /* Type of conversion (shortest, Steele,
@@ -3056,7 +3071,7 @@ ShorteningInt64Conversion(
*----------------------------------------------------------------------
*/
-inline static char *
+static inline char *
StrictInt64Conversion(
Double *dPtr, /* Original number to convert. */
int convType, /* Type of conversion (shortest, Steele,
@@ -3162,7 +3177,7 @@ StrictInt64Conversion(
*----------------------------------------------------------------------
*/
-inline static int
+static inline int
ShouldBankerRoundUpPowD(
mp_int *b, /* Numerator of the fraction. */
int sd, /* Denominator is 2**(sd*DIGIT_BIT). */
@@ -3200,7 +3215,7 @@ ShouldBankerRoundUpPowD(
*----------------------------------------------------------------------
*/
-inline static int
+static inline int
ShouldBankerRoundUpToNextPowD(
mp_int *b, /* Numerator of the fraction. */
mp_int *m, /* Numerator of the rounding tolerance. */
@@ -3263,7 +3278,7 @@ ShouldBankerRoundUpToNextPowD(
*----------------------------------------------------------------------
*/
-inline static char *
+static inline char *
ShorteningBignumConversionPowD(
Double *dPtr, /* Original number to convert. */
int convType, /* Type of conversion (shortest, Steele,
@@ -3456,7 +3471,7 @@ ShorteningBignumConversionPowD(
*----------------------------------------------------------------------
*/
-inline static char *
+static inline char *
StrictBignumConversionPowD(
Double *dPtr, /* Original number to convert. */
int convType, /* Type of conversion (shortest, Steele,
@@ -3572,7 +3587,7 @@ StrictBignumConversionPowD(
*----------------------------------------------------------------------
*/
-inline static int
+static inline int
ShouldBankerRoundUp(
mp_int *twor, /* 2x the remainder from thd division that
* produced the last digit. */
@@ -3607,7 +3622,7 @@ ShouldBankerRoundUp(
*----------------------------------------------------------------------
*/
-inline static int
+static inline int
ShouldBankerRoundUpToNext(
mp_int *b, /* Remainder from the division that produced
* the last digit. */
@@ -3661,7 +3676,7 @@ ShouldBankerRoundUpToNext(
*----------------------------------------------------------------------
*/
-inline static char *
+static inline char *
ShorteningBignumConversion(
Double *dPtr, /* Original number being converted. */
int convType, /* Conversion type. */
@@ -3877,7 +3892,7 @@ ShorteningBignumConversion(
*----------------------------------------------------------------------
*/
-inline static char *
+static inline char *
StrictBignumConversion(
Double *dPtr, /* Original number being converted. */
int convType, /* Conversion type. */
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 27a0d9c..75638cf 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -2040,9 +2040,12 @@ Tcl_AppendFormatToObj(
segmentLimit -= 1;
precision--;
break;
+ case 'X':
+ Tcl_AppendToObj(segment, "0X", 2);
+ segmentLimit -= 2;
+ break;
case 'p':
case 'x':
- case 'X':
Tcl_AppendToObj(segment, "0x", 2);
segmentLimit -= 2;
break;
@@ -2050,6 +2053,10 @@ Tcl_AppendFormatToObj(
Tcl_AppendToObj(segment, "0b", 2);
segmentLimit -= 2;
break;
+ case 'd':
+ Tcl_AppendToObj(segment, "0d", 2);
+ segmentLimit -= 2;
+ break;
}
}
@@ -2207,7 +2214,11 @@ Tcl_AppendFormatToObj(
}
digitOffset = (int) (bits % base);
if (digitOffset > 9) {
- bytes[numDigits] = 'a' + digitOffset - 10;
+ if (ch == 'X') {
+ bytes[numDigits] = 'A' + digitOffset - 10;
+ } else {
+ bytes[numDigits] = 'a' + digitOffset - 10;
+ }
} else {
bytes[numDigits] = '0' + digitOffset;
}
@@ -2329,14 +2340,6 @@ Tcl_AppendFormatToObj(
goto error;
}
- switch (ch) {
- case 'E':
- case 'G':
- case 'X': {
- Tcl_SetObjLength(segment, Tcl_UtfToUpper(TclGetString(segment)));
- }
- }
-
if (width>0 && numChars<0) {
numChars = Tcl_GetCharLength(segment);
}
@@ -2858,9 +2861,11 @@ TclStringCatObjv(
Tcl_Obj * const objv[],
Tcl_Obj **objPtrPtr)
{
- Tcl_Obj *objPtr, *objResultPtr, * const *ov;
- int oc, length = 0, binary = 1, first = 0, last = 0;
+ Tcl_Obj *objResultPtr, * const *ov;
+ int oc, length = 0, binary = 1;
int allowUniChar = 1, requestUniChar = 0;
+ int first = objc - 1; /* Index of first value possibly not empty */
+ int last = 0; /* Index of last value possibly not empty */
/* assert ( objc >= 0 ) */
@@ -2881,7 +2886,7 @@ TclStringCatObjv(
ov = objv, oc = objc;
do {
- objPtr = *ov++;
+ Tcl_Obj *objPtr = *ov++;
if (objPtr->bytes) {
/* Value has a string rep. */
@@ -2917,7 +2922,7 @@ TclStringCatObjv(
/* Result will be pure byte array. Pre-size it */
ov = objv; oc = objc;
do {
- objPtr = *ov++;
+ Tcl_Obj *objPtr = *ov++;
if (objPtr->bytes == NULL) {
int numBytes;
@@ -2938,7 +2943,7 @@ TclStringCatObjv(
/* Result will be pure Tcl_UniChar array. Pre-size it. */
ov = objv; oc = objc;
do {
- objPtr = *ov++;
+ Tcl_Obj *objPtr = *ov++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
int numChars;
@@ -2956,45 +2961,94 @@ TclStringCatObjv(
}
} while (--oc);
} else {
- Tcl_Obj *pendingPtr = NULL;
-
/* Result will be concat of string reps. Pre-size it. */
ov = objv; oc = objc;
do {
- int numBytes;
+ Tcl_Obj *pendingPtr = NULL;
- objPtr = *ov++;
+ /*
+ * Loop until a possibly non-empty value is reached.
+ * Keep string rep generation pending when possible.
+ */
- if ((length == 0) && (objPtr->bytes == NULL) && !pendingPtr) {
- /* No string rep; Take the chance we can avoid making it */
+ do {
+ /* assert ( pendingPtr == NULL ) */
+ /* assert ( length == 0 ) */
- last = objc - oc;
- first = last;
- pendingPtr = objPtr;
- } else {
+ Tcl_Obj *objPtr = *ov++;
- Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
- if (numBytes == 0) {
- continue;
+ if (objPtr->bytes == NULL) {
+ /* No string rep; Take the chance we can avoid making it */
+ pendingPtr = objPtr;
+ } else {
+ Tcl_GetStringFromObj(objPtr, &length); /* PANIC? */
}
- last = objc - oc;
- if (pendingPtr) {
- Tcl_GetStringFromObj(pendingPtr, &length); /* PANIC? */
- pendingPtr = NULL;
+ } while (--oc && (length == 0) && (pendingPtr == NULL));
+
+ /*
+ * Either we found a possibly non-empty value, and we
+ * remember this index as the first and last such value so
+ * far seen, or (oc == 0) and all values are known empty,
+ * so first = last = objc - 1 signals the right quick return.
+ */
+
+ first = last = objc - oc - 1;
+
+ if (oc && (length == 0)) {
+ int numBytes;
+
+ /* assert ( pendingPtr != NULL ) */
+
+ /*
+ * There's a pending value followed by more values.
+ * Loop over remaining values generating strings until
+ * a non-empty value is found, or the pending value gets
+ * its string generated.
+ */
+
+ do {
+ Tcl_Obj *objPtr = *ov++;
+ Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
+ } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL);
+
+ if (numBytes) {
+ last = objc -oc -1;
+ }
+ if (oc || numBytes) {
+ Tcl_GetStringFromObj(pendingPtr, &length);
}
if (length == 0) {
- first = last;
+ if (numBytes) {
+ first = last;
+ }
} else if (numBytes > INT_MAX - length) {
goto overflow;
}
length += numBytes;
}
- } while (--oc);
+ } while (oc && (length == 0));
+
+ while (oc) {
+ int numBytes;
+ Tcl_Obj *objPtr = *ov++;
+
+ /* assert ( length > 0 && pendingPtr == NULL ) */
+
+ Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
+ if (numBytes) {
+ last = objc - oc;
+ if (numBytes > INT_MAX - length) {
+ goto overflow;
+ }
+ length += numBytes;
+ }
+ --oc;
+ }
}
- if (last == first /*|| length == 0 */) {
+ if (last <= first /*|| length == 0 */) {
/* Only one non-empty value or zero length; return first */
- /* NOTE: (length == 0) implies (last == first) */
+ /* NOTE: (length == 0) implies (last <= first) */
*objPtrPtr = objv[first];
return TCL_OK;
}
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index f2f2bc6..ae00f5e 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -253,6 +253,15 @@ Tcl_UniCharToUtfDString(
* Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
+ * If TCL_UTF_MAX == 4, special handling of Surrogate pairs is done:
+ * For any UTF-8 string containing a character outside of the BMP, the
+ * first call to this function will fill *chPtr with the high surrogate
+ * and generate a return value of 0. Calling Tcl_UtfToUniChar again
+ * will produce the low surrogate and a return value of 4. Because *chPtr
+ * is used to remember whether the high surrogate is already produced, it
+ * is recommended to initialize the variable it points to as 0 before
+ * the first call to Tcl_UtfToUniChar is done.
+ *
* Results:
* *chPtr is filled with the Tcl_UniChar, and the return value is the
* number of bytes from the UTF-8 string that were consumed.
@@ -282,7 +291,7 @@ Tcl_UtfToUniChar(
register int byte;
/*
- * Unroll 1 to 3 byte UTF-8 sequences, use loop to handle longer ones.
+ * Unroll 1 to 3 (or 4) byte UTF-8 sequences.
*/
byte = *((unsigned char *) src);
@@ -456,10 +465,7 @@ Tcl_UtfCharComplete(
* a complete UTF-8 character. */
int length) /* Length of above string in bytes. */
{
- int ch;
-
- ch = *((unsigned char *) src);
- return length >= totalBytes[ch];
+ return length >= totalBytes[(unsigned char)*src];
}
/*
@@ -638,8 +644,14 @@ Tcl_UtfNext(
const char *src) /* The current location in the string. */
{
Tcl_UniChar ch = 0;
+ int len = TclUtfToUniChar(src, &ch);
- return src + TclUtfToUniChar(src, &ch);
+#if TCL_UTF_MAX == 4
+ if (len == 0) {
+ len = TclUtfToUniChar(src, &ch);
+ }
+#endif
+ return src + len;
}
/*
@@ -672,8 +684,7 @@ Tcl_UtfPrev(
const char *look;
int i, byte;
- src--;
- look = src;
+ look = --src;
for (i = 0; i < TCL_UTF_MAX; i++) {
if (look < start) {
if (src < start) {
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 91cc3b4..608cd15 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1646,7 +1646,7 @@ Tcl_Backslash(
* src, unless NULL. */
{
char buf[TCL_UTF_MAX];
- Tcl_UniChar ch;
+ Tcl_UniChar ch = 0;
Tcl_UtfBackslash(src, readPtr, buf);
TclUtfToUniChar(buf, &ch);
diff --git a/library/auto.tcl b/library/auto.tcl
index 97ea8af..a7a8979 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -203,7 +203,7 @@ proc auto_mkindex {dir args} {
}
auto_mkindex_parser::init
- foreach file [glob -- {*}$args] {
+ foreach file [lsort [glob -- {*}$args]] {
try {
append index [auto_mkindex_parser::mkindex $file]
} on error {msg opts} {
@@ -236,7 +236,7 @@ proc auto_mkindex_old {dir args} {
if {![llength $args]} {
set args *.tcl
}
- foreach file [glob -- {*}$args] {
+ foreach file [lsort [glob -- {*}$args]] {
set f ""
set error [catch {
set f [open $file]
diff --git a/library/init.tcl b/library/init.tcl
index 5cedd14..ece1e44 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -286,14 +286,9 @@ proc unknown args {
}
append cinfo ...
}
- append cinfo "\"\n (\"uplevel\" body line 1)"
- append cinfo "\n invoked from within"
- append cinfo "\n\"uplevel 1 \$args\""
- #
- # Try each possible form of the stack trace
- # and trim the extra contribution from the matching case
- #
- set expect "$msg\n while executing\n\"$cinfo"
+ set tail "\n (\"uplevel\" body line 1)\n invoked\
+ from within\n\"uplevel 1 \$args\""
+ set expect "$msg\n while executing\n\"$cinfo\"$tail"
if {$errInfo eq $expect} {
#
# The stack has only the eval from the expanded command
@@ -307,21 +302,32 @@ proc unknown args {
# Stack trace is nested, trim off just the contribution
# from the extra "eval" of $args due to the "catch" above.
#
- set expect "\n invoked from within\n\"$cinfo"
- set exlen [string length $expect]
- set eilen [string length $errInfo]
- set i [expr {$eilen - $exlen - 1}]
- set einfo [string range $errInfo 0 $i]
- #
- # For now verify that $errInfo consists of what we are about
- # to return plus what we expected to trim off.
- #
- if {$errInfo ne "$einfo$expect"} {
- error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
- [list CORE UNKNOWN BADTRACE $einfo $expect $errInfo]
+ set last [string last $tail $errInfo]
+ if {$last + [string length $tail] != [string length $errInfo]} {
+ # Very likely cannot happen
+ return -options $opts $msg
}
- return -code error -errorcode $errCode \
- -errorinfo $einfo $msg
+ set errInfo [string range $errInfo 0 $last-1]
+ set tail "\"$cinfo\""
+ set last [string last $tail $errInfo]
+ if {$last + [string length $tail] != [string length $errInfo]} {
+ return -code error -errorcode $errCode \
+ -errorinfo $errInfo $msg
+ }
+ set errInfo [string range $errInfo 0 $last-1]
+ set tail "\n invoked from within\n"
+ set last [string last $tail $errInfo]
+ if {$last + [string length $tail] == [string length $errInfo]} {
+ return -code error -errorcode $errCode \
+ -errorinfo [string range $errInfo 0 $last-1] $msg
+ }
+ set tail "\n while executing\n"
+ set last [string last $tail $errInfo]
+ if {$last + [string length $tail] == [string length $errInfo]} {
+ return -code error -errorcode $errCode \
+ -errorinfo [string range $errInfo 0 $last-1] $msg
+ }
+ return -options $opts $msg
} else {
dict incr opts -level
return -options $opts $msg
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index 23a5f96..70ac6bb 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -219,8 +219,8 @@ test cmdIL-3.10 {SortCompare procedure, -integer option} -body {
lsort -integer {3 q}
} -returnCodes error -result {expected integer but got "q"}
test cmdIL-3.11 {SortCompare procedure, -integer option} {
- lsort -integer {35 21 0x20 30 0o23 100 8}
-} {8 0o23 21 30 0x20 35 100}
+ lsort -integer {35 21 0x20 0d30 0o23 100 8}
+} {8 0o23 21 0d30 0x20 35 100}
test cmdIL-3.12 {SortCompare procedure, -real option} -body {
lsort -real {6...4 3}
} -returnCodes error -result {expected floating-point number but got "6...4"}
diff --git a/tests/exec.test b/tests/exec.test
index 2a4b31e..dffd960 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -671,8 +671,12 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup {
exec /bin/sh -c \
{for a in 1 2 3; do sleep 1; echo $a; done} >>$tmpfile &
exec /bin/sh -c \
+ {for a in 4 5 6; do sleep 1; echo $a >&2; done} 2>>$tmpfile &
+ exec /bin/sh -c \
{for a in a b c; do sleep 1; echo $a; done} >>$tmpfile &
- # The above two shell invokations take about 3 seconds to finish, so allow
+ exec /bin/sh -c \
+ {for a in d e f; do sleep 1; echo $a >&2; done} 2>>$tmpfile &
+ # The above four shell invokations take about 3 seconds to finish, so allow
# 5s (in case the machine is busy)
after 5000
# Check that no bytes have got lost through mixups with overlapping
@@ -681,7 +685,7 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup {
file size $tmpfile
} -cleanup {
removeFile $tmpfile
-} -result 14
+} -result 26
# Tests to ensure batch files and .CMD (Bug 9ece99d58b)
# can be executed on Windows
diff --git a/tests/format.test b/tests/format.test
index 722ad21..094b7b3 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -79,6 +79,16 @@ test format-1.11.1 {integer formatting} longIs64bit {
test format-1.12 {integer formatting} {
format "%b %#b %#b %llb" 5 0 5 [expr {2**100}]
} {101 0b0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
+test format-1.13 {integer formatting} {
+ format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1
+} {0d0 0d6 0d34 0d16923 -0d12}
+test format-1.14 {integer formatting} {
+ format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1
+} { 0d0 0d6 0d34 0d16923 -0d12}
+test format-1.15 {integer formatting} {
+ format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1
+} {0d0 0d6 0d34 0d16923 -0d12 }
+
test format-2.1 {string formatting} {
format "%s %s %c %s" abcd {This is a very long test string.} 120 x
diff --git a/tests/http.test b/tests/http.test
index 210c2fb..e165804 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -36,6 +36,13 @@ proc bgerror {args} {
puts stderr $errorInfo
}
+if {$::tcl_platform(os) eq "Darwin"} {
+ # Name resolution often a problem on OSX; not focus of HTTP package anyway
+ set HOST localhost
+} else {
+ set HOST [info hostname]
+}
+
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}
@@ -114,8 +121,8 @@ test http-3.1 {http::geturl} -returnCodes error -body {
test http-3.2 {http::geturl} -returnCodes error -body {
http::geturl http:junk
} -result {Unsupported URL: http:junk}
-set url //[info hostname]:$port
-set badurl //[info hostname]:[expr $port+1]
+set url //${::HOST}:$port
+set badurl //${::HOST}:[expr $port+1]
test http-3.3 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
@@ -126,13 +133,13 @@ test http-3.3 {http::geturl} -body {
<h2>GET /</h2>
</body></html>"
set tail /a/b/c
-set url //[info hostname]:$port/a/b/c
-set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c
-set binurl //[info hostname]:$port/binary
-set xmlurl //[info hostname]:$port/xml
-set posturl //[info hostname]:$port/post
-set badposturl //[info hostname]:$port/droppost
-set authorityurl //[info hostname]:$port
+set url //${::HOST}:$port/a/b/c
+set fullurl HTTP://user:pass@${::HOST}:$port/a/b/c
+set binurl //${::HOST}:$port/binary
+set xmlurl //${::HOST}:$port/xml
+set posturl //${::HOST}:$port/post
+set badposturl //${::HOST}:$port/droppost
+set authorityurl //${::HOST}:$port
set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
@@ -145,7 +152,7 @@ test http-3.4 {http::geturl} -body {
</body></html>"
proc selfproxy {host} {
global port
- return [list [info hostname] $port]
+ return [list ${::HOST} $port]
}
test http-3.5 {http::geturl} -body {
http::config -proxyfilter selfproxy
@@ -588,14 +595,20 @@ test http-4.15 {http::Event} -body {
} -cleanup {
catch {http::cleanup $token}
} -returnCodes 1 -match glob -result "couldn't open socket*"
-test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -body {
+test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup {
+ proc list-difference {l1 l2} {
+ lmap item $l2 {if {$item in $l1} continue; set item}
+ }
+} -body {
set before [chan names]
set token [http::geturl $url -headers {X-Connection keep-alive}]
http::cleanup $token
update
- set after [chan names]
- expr {$before eq $after}
-} -result 1
+ # Compute what channels have been unexpectedly leaked past cleanup
+ list-difference $before [chan names]
+} -cleanup {
+ rename list-difference {}
+} -result {}
test http-5.1 {http::formatQuery} {
http::formatQuery name1 value1 name2 "value two"
@@ -616,7 +629,7 @@ test http-5.5 {http::formatQuery} {
} {name1=~bwelch&name2=%A1%A2%A2}
test http-6.1 {http::ProxyRequired} -body {
- http::config -proxyhost [info hostname] -proxyport $port
+ http::config -proxyhost ${::HOST} -proxyport $port
set token [http::geturl $url]
http::wait $token
upvar #0 $token data
diff --git a/tests/httpd b/tests/httpd
index f15d71b..982f3b8 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -10,6 +10,13 @@
#set httpLog 1
+if {$::tcl_platform(os) eq "Darwin"} {
+ # Name resolution often a problem on OSX; not focus of HTTP package anyway
+ set HOST localhost
+} else {
+ set HOST [info hostname]
+}
+
proc httpd_init {{port 8015}} {
set s [socket -server httpdAccept $port]
# Save the actual port number in a global variable.
@@ -173,7 +180,7 @@ proc httpdRespond { sock } {
switch -glob -- $data(url) {
*binary* {
- set html "$bindata[info hostname]:$port$data(url)"
+ set html "$bindata${::HOST}:$port$data(url)"
set type application/octet-stream
}
*xml* {
diff --git a/tests/httpold.test b/tests/httpold.test
index ab26613..dda0189 100644
--- a/tests/httpold.test
+++ b/tests/httpold.test
@@ -34,6 +34,13 @@ if {[catch {package require http 1.0}]} {
}
}
+if {$::tcl_platform(os) eq "Darwin"} {
+ # Name resolution often a problem on OSX; not focus of HTTP package anyway
+ set HOST localhost
+} else {
+ set HOST [info hostname]
+}
+
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}
@@ -85,7 +92,7 @@ test httpold-3.2 {http_get} {
set err
} {Unsupported URL: http:junk}
-set url [info hostname]:$port
+set url ${::HOST}:$port
test httpold-3.3 {http_get} {
set token [http_get $url]
http_data $token
@@ -95,8 +102,8 @@ test httpold-3.3 {http_get} {
</body></html>"
set tail /a/b/c
-set url [info hostname]:$port/a/b/c
-set binurl [info hostname]:$port/binary
+set url ${::HOST}:$port/a/b/c
+set binurl ${::HOST}:$port/binary
test httpold-3.4 {http_get} {
set token [http_get $url]
@@ -108,7 +115,7 @@ test httpold-3.4 {http_get} {
proc selfproxy {host} {
global port
- return [list [info hostname] $port]
+ return [list ${::HOST} $port]
}
test httpold-3.5 {http_get} {
http_config -proxyfilter selfproxy
@@ -273,7 +280,7 @@ test httpold-5.3 {http_formatQuery} {
test httpold-6.1 {httpProxyRequired} {
update
- http_config -proxyhost [info hostname] -proxyport $port
+ http_config -proxyhost ${::HOST} -proxyport $port
set token [http_get $url]
http_wait $token
http_config -proxyhost {} -proxyport {}
diff --git a/tests/init.test b/tests/init.test
index 0241283..2a81b52 100644
--- a/tests/init.test
+++ b/tests/init.test
@@ -168,6 +168,16 @@ foreach arg [subst -nocommands -novariables {
incr count
}
+test init-4.$count {[Bug 46f801ed5a]} -setup {
+ auto_reset
+ array set auto_index {demo {proc demo {} {tailcall error foo}}}
+} -body {
+ demo
+} -cleanup {
+ array unset auto_index demo
+ rename demo {}
+} -returnCodes error -result foo
+
test init-5.0 {return options passed through ::unknown} -setup {
catch {rename xxx {}}
set ::auto_index(::xxx) {proc ::xxx {} {
diff --git a/tests/link.test b/tests/link.test
index 6bff356..a12759d 100644
--- a/tests/link.test
+++ b/tests/link.test
@@ -173,6 +173,27 @@ test link-2.9 {writing C variables from Tcl} -constraints {testlink} -setup {
set uwide 0
concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
} -result {0 5000.0 0 0 0 0 0 0 0 0 0 0 -60.0 0 | 0 5000e 0 0 0 0 0 0 0 0 0 0 -60.00e+ 0}
+test link-2.10 {writing C variables from Tcl} -constraints {testlink} -setup {
+ testlink delete
+} -body {
+ testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
+ testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ set int "0x"
+ set real "0b"
+ set bool 0
+ set string "0"
+ set wide "0D"
+ set char "0X"
+ set uchar "0B"
+ set short "0D"
+ set ushort "0x"
+ set uint "0b"
+ set long "0d"
+ set ulong "0X"
+ set float "0B"
+ set uwide "0D"
+ concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
+} -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0D 0X 0B 0D 0x 0b 0d 0X 0B 0D}
test link-3.1 {read-only variables} -constraints {testlink} -setup {
testlink delete
diff --git a/tests/oo.test b/tests/oo.test
index e03911b..5f87837 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2013,6 +2013,41 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup {
} -cleanup {
FooClass destroy
} -result {foo bar grill bar}
+test oo-15.11 {OO: object cloning} -returnCodes error -body {
+ oo::copy
+} -result {wrong # args: should be "oo::copy sourceName ?targetName? ?targetNamespace?"}
+test oo-15.12 {OO: object cloning with target NS} -setup {
+ oo::class create Super
+ oo::class create Cls {superclass Super}
+} -body {
+ namespace eval ::existing {}
+ oo::copy Cls {} ::existing
+} -returnCodes error -cleanup {
+ Super destroy
+ catch {namespace delete ::existing}
+} -result {::existing refers to an existing namespace}
+test oo-15.13 {OO: object cloning with target NS} -setup {
+ oo::class create Super
+ oo::class create Cls {superclass Super}
+} -body {
+ list [namespace exist ::dupens] [oo::copy Cls Cls2 ::dupens] [namespace exist ::dupens]
+} -cleanup {
+ Super destroy
+} -result {0 ::Cls2 1}
+test oo-15.14 {OO: object cloning with target NS} -setup {
+ oo::class create Cls {export eval}
+ set result {}
+} -body {
+ Cls create obj
+ obj eval {
+ proc test-15.14 {} {}
+ }
+ lappend result [info commands ::dupens::t*]
+ oo::copy obj obj2 ::dupens
+ lappend result [info commands ::dupens::t*]
+} -cleanup {
+ Cls destroy
+} -result {{} ::dupens::test-15.14}
test oo-16.1 {OO: object introspection} -body {
info object
@@ -3766,6 +3801,113 @@ test oo-35.4 {Bug 593baa032c: mixins list teardown} {
namespace eval [info object namespace D] [list [namespace which B] destroy]
} {}
+test oo-36.1 {TIP #470: introspection within oo::define} {
+ oo::define oo::object self
+} ::oo::object
+test oo-36.2 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Cls
+} -body {
+ oo::define Cls self
+} -cleanup {
+ Cls destroy
+} -result ::Cls
+test oo-36.3 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Super
+ set result uncalled
+} -body {
+ oo::class create Sub {
+ superclass Super
+ ::set ::result [self]
+ }
+ return $result
+} -cleanup {
+ Super destroy
+} -result ::Sub
+test oo-36.4 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Super
+ set result uncalled
+} -body {
+ oo::class create Sub {
+ superclass Super
+ ::set ::result [self {}]
+ }
+ return $result
+} -cleanup {
+ Super destroy
+} -result {}
+test oo-36.5 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Super
+ set result uncalled
+} -body {
+ oo::class create Sub {
+ superclass Super
+ ::set ::result [self self]
+ }
+} -cleanup {
+ Super destroy
+} -result ::Sub
+test oo-36.6 {TIP #470: introspection within oo::objdefine} -setup {
+ oo::class create Cls
+ set result uncalled
+} -body {
+ Cls create obj
+ oo::objdefine obj {
+ ::set ::result [self]
+ }
+} -cleanup {
+ Cls destroy
+} -result ::obj
+test oo-36.7 {TIP #470: introspection within oo::objdefine} -setup {
+ oo::class create Cls
+} -body {
+ Cls create obj
+ oo::objdefine obj {
+ self
+ }
+} -cleanup {
+ Cls destroy
+} -result ::obj
+test oo-36.8 {TIP #470: introspection within oo::objdefine} -setup {
+ oo::class create Cls
+} -body {
+ Cls create obj
+ oo::objdefine obj {
+ self anything
+ }
+} -returnCodes error -cleanup {
+ Cls destroy
+} -result {wrong # args: should be "self"}
+test oo-36.9 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Cls
+ set result uncalled
+} -body {
+ proc oo::define::testself {} {
+ global result
+ set result [list [catch {self} msg] $msg \
+ [catch {uplevel 1 self} msg] $msg]
+ return
+ }
+ list [oo::define Cls testself] $result
+} -cleanup {
+ Cls destroy
+ catch {rename oo::define::testself {}}
+} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::Cls}}
+test oo-36.10 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Cls
+ set result uncalled
+} -body {
+ proc oo::objdefine::testself {} {
+ global result
+ set result [list [catch {self} msg] $msg \
+ [catch {uplevel 1 self} msg] $msg]
+ return
+ }
+ Cls create obj
+ list [oo::objdefine obj testself] $result
+} -cleanup {
+ Cls destroy
+ catch {rename oo::objdefine::testself {}}
+} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}}
cleanupTests
return
diff --git a/tests/regexp.test b/tests/regexp.test
index 4ffdbdb..7367af7 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -19,6 +19,20 @@ if {"::tcltest" ni [namespace children]} {
unset -nocomplain foo
testConstraint exec [llength [info commands exec]]
+
+# Used for constraining memory leak tests
+testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+ proc memtest 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 regexp-1.1 {basic regexp operation} {
regexp ab*c abbbc
@@ -453,7 +467,7 @@ test regexp-11.4 {regsub errors} {
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} {
list [catch {regsub -gorp a b c} msg] $msg
-} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexp-11.6 {regsub errors} {
list [catch {regsub -nocase a( b c d} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
@@ -1123,6 +1137,57 @@ test regexp-26.12 {regexp with -line option} {
test regexp-26.13 {regexp without -line option} {
regexp -all -inline -- {a*} "b\n"
} {{} {}}
+
+test regexp-27.1 {regsub -command} {
+ regsub -command {.x.} {abcxdef} {string length}
+} ab3ef
+test regexp-27.2 {regsub -command} {
+ regsub -command {.x.} {abcxdefxghi} {string length}
+} ab3efxghi
+test regexp-27.3 {regsub -command} {
+ set x 0
+ regsub -all -command {(?=.)} abcde {apply {args {incr ::x}}}
+} 1a2b3c4d5e
+test regexp-27.4 {regsub -command} -body {
+ regsub -command {.x.} {abcxdef} error
+} -returnCodes error -result cxd
+test regexp-27.5 {regsub -command} {
+ regsub -command {(.)(.)} {abcdef} {list ,}
+} {, ab a bcdef}
+test regexp-27.6 {regsub -command} {
+ regsub -command -all {(.)(.)} {abcdef} {list ,}
+} {, ab a b, cd c d, ef e f}
+test regexp-27.7 {regsub -command representation smash} {
+ set ::s {123=456 789}
+ regsub -command -all {\d+} $::s {apply {n {
+ expr {[llength $::s] + $n}
+ }}}
+} {125=458 791}
+test regexp-27.8 {regsub -command representation smash} {
+ set ::t {apply {n {
+ expr {[llength [lindex $::t 1 1 1]] + $n}
+ }}}
+ regsub -command -all {\d+} "123=456 789" $::t
+} {131=464 797}
+test regexp-27.9 {regsub -command memory leak testing} memory {
+ set ::s "123=456 789"
+ set ::t {apply {n {
+ expr {[llength [lindex $::t 1 1 1]] + [llength $::s] + $n}
+ }}}
+ memtest {
+ regsub -command -all {\d+} $::s $::t
+ }
+} 0
+test regexp-27.10 {regsub -command error cases} -returnCodes error -body {
+ regsub -command . abc "def \{ghi"
+} -result {unmatched open brace in list}
+test regexp-27.11 {regsub -command error cases} -returnCodes error -body {
+ regsub -command . abc {}
+} -result {command prefix must be a list of at least one element}
+test regexp-27.12 {regsub -command representation smash} {
+ set s {list (.+)}
+ regsub -command $s {list list} $s
+} {(.+) {list list} list}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/regexpComp.test b/tests/regexpComp.test
index b8e64b6..fbf8012 100644
--- a/tests/regexpComp.test
+++ b/tests/regexpComp.test
@@ -587,7 +587,7 @@ test regexpComp-11.5 {regsub errors} {
evalInProc {
list [catch {regsub -gorp a b c} msg] $msg
}
-} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-11.6 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a( b c d} msg] $msg
diff --git a/tests/string.test b/tests/string.test
index 9c43f29..7b02928 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -2024,6 +2024,21 @@ test string-29.13 {string cat, efficiency} -body {
tcl::unsupported::representation [string cat \
[encoding convertto utf-8 {}] [encoding convertto utf-8 {}] [list x]]
} -match glob -result {*, string representation "x"}
+test string-29.14 {string cat, efficiency} -setup {
+ set e [encoding convertto utf-8 {}]
+} -cleanup {
+ unset e
+} -body {
+ tcl::unsupported::representation [string cat $e $e [list x]]
+} -match glob -result {*no string representation}
+test string-29.15 {string cat, efficiency} -setup {
+ set e [encoding convertto utf-8 {}]
+ set f [encoding convertto utf-8 {}]
+} -cleanup {
+ unset e f
+} -body {
+ tcl::unsupported::representation [string cat $e $f $e $f [list x]]
+} -match glob -result {*no string representation}
diff --git a/tests/util.test b/tests/util.test
index 22d120b..35fc642 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -553,6 +553,12 @@ test util-9.0.6 {TclGetIntForIndex} {
test util-9.0.7 {TclGetIntForIndex} {
string index abcd { 01 }
} b
+test util-9.0.8 {TclGetIntForIndex} {
+ string index abcd { 0d0 }
+} a
+test util-9.0.9 {TclGetIntForIndex} {
+ string index abcd { -0d0 }
+} a
test util-9.1.0 {TclGetIntForIndex} {
string index abcd 3
} d
@@ -565,6 +571,12 @@ test util-9.1.2 {TclGetIntForIndex} {
test util-9.1.3 {TclGetIntForIndex} {
string index abcdefghijk { 0xa }
} k
+test util-9.1.4 {TclGetIntForIndex} {
+ string index abcdefghijk 0d10
+} k
+test util-9.1.5 {TclGetIntForIndex} {
+ string index abcdefghijk { 0d10 }
+} k
test util-9.2.0 {TclGetIntForIndex} {
string index abcd end
} d
@@ -672,12 +684,18 @@ test util-9.30 {TclGetIntForIndex} -body {
test util-9.31 {TclGetIntForIndex} -body {
string index a 0x
} -returnCodes error -match glob -result *
+test util-9.31.1 {TclGetIntForIndex} -body {
+ string index a 0d
+} -returnCodes error -match glob -result *
test util-9.32 {TclGetIntForIndex} -body {
string index a 0x1FFFFFFFF+0
} -returnCodes error -match glob -result *
test util-9.33 {TclGetIntForIndex} -body {
string index a 100000000000+0
} -returnCodes error -match glob -result *
+test util-9.33.1 {TclGetIntForIndex} -body {
+ string index a 0d100000000000+0
+} -returnCodes error -match glob -result *
test util-9.34 {TclGetIntForIndex} -body {
string index a 1.0
} -returnCodes error -match glob -result *
diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c
index 8b7dc58..e998bf9 100644
--- a/unix/tclLoadDyld.c
+++ b/unix/tclLoadDyld.c
@@ -48,7 +48,9 @@
#endif /* TCL_DYLD_USE_DLFCN */
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
+#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#endif
#include <mach-o/dyld.h>
#include <mach-o/fat.h>
#include <mach-o/swap.h>
diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h
index 2728957..ba56089 100644
--- a/unix/tclUnixPort.h
+++ b/unix/tclUnixPort.h
@@ -125,11 +125,11 @@ typedef off_t Tcl_SeekOffset;
# include <sys/select.h>
#endif
#include <sys/stat.h>
-#if TIME_WITH_SYS_TIME
+#ifdef TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
#else
-#if HAVE_SYS_TIME_H
+#ifdef HAVE_SYS_TIME_H
# include <sys/time.h>
#else
# include <time.h>
@@ -138,11 +138,11 @@ typedef off_t Tcl_SeekOffset;
#ifndef NO_SYS_WAIT_H
# include <sys/wait.h>
#endif
-#if HAVE_INTTYPES_H
+#ifdef HAVE_INTTYPES_H
# include <inttypes.h>
#endif
#include <limits.h>
-#if HAVE_STDINT_H
+#ifdef HAVE_STDINT_H
# include <stdint.h>
#endif
#ifdef HAVE_UNISTD_H
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 2353f94..45abc01 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -646,7 +646,7 @@ TcpCloseProc(
while (fds != NULL) {
TcpFdList *next = fds->next;
- ckfree(fds);
+ ckfree(fds);
fds = next;
}
if (statePtr->addrlist != NULL) {
@@ -730,6 +730,10 @@ TcpClose2Proc(
*/
#ifndef NEED_FAKE_RFC2553
+#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wstrict-aliasing"
+#endif
static inline int
IPv6AddressNeedsNumericRendering(
struct in6_addr addr)
@@ -743,16 +747,16 @@ IPv6AddressNeedsNumericRendering(
* at least some versions of OSX.
*/
-#pragma GCC diagnostic push
-#pragma GCC diagnostic ignored "-Wstrict-aliasing"
if (!IN6_IS_ADDR_V4MAPPED(&addr)) {
-#pragma GCC diagnostic pop
return 0;
}
return (addr.s6_addr[12] == 0 && addr.s6_addr[13] == 0
&& addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0);
}
+#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
+#pragma GCC diagnostic pop
+#endif
#endif /* NEED_FAKE_RFC2553 */
static void
diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh
index ee10b81..4c2068c 100644
--- a/unix/tclooConfig.sh
+++ b/unix/tclooConfig.sh
@@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC=""
TCLOO_INCLUDE_SPEC=""
TCLOO_PRIVATE_INCLUDE_SPEC=""
TCLOO_CFLAGS=""
-TCLOO_VERSION=1.0.4
+TCLOO_VERSION=1.2.0
diff --git a/win/makefile.vc b/win/makefile.vc
index 18f691b..5566df2 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -121,7 +121,7 @@ the build instructions.
# nodep = Turns off compatibility macros to ensure the core
# isn't being built with deprecated functions.
#
-# MACHINE=(ALPHA|AMD64|IA64|IX86)
+# MACHINE=(ARM|AMD64|IA64|IX86)
# Set the machine type used for the compiler, linker, and
# resource compiler. This hook is needed to tell the tools
# when alternate platforms are requested. IX86 is the default
@@ -485,9 +485,16 @@ cdebug = -Zi -Od $(DEBUGFLAGS)
cdebug = -Zi -WX $(DEBUGFLAGS)
!endif
+### Common compiler options that are architecture specific
+!if "$(MACHINE)" == "ARM"
+carch = -D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE
+!else
+carch =
+!endif
+
### Declarations common to all compiler options
cwarn = $(WARNINGS) -D _CRT_SECURE_NO_DEPRECATE -D _CRT_NONSTDC_NO_DEPRECATE
-cflags = -nologo -c $(COMPILERFLAGS) $(cwarn) -Fp$(TMP_DIR)^\
+cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\
!if $(MSVCRT)
!if $(DEBUG) && !$(UNCHECKED)
@@ -1223,6 +1230,8 @@ clean: clean-pkgs
@if exist $(WINDIR)\nmakehlp.obj del $(WINDIR)\nmakehlp.obj
@echo Cleaning $(WINDIR)\nmakehlp.exe ...
@if exist $(WINDIR)\nmakehlp.exe del $(WINDIR)\nmakehlp.exe
+ @echo Cleaning $(WINDIR)\nmhlp-out.txt ...
+ @if exist $(WINDIR)\nmhlp-out.txt del $(WINDIR)\nmhlp-out.txt
@echo Cleaning $(WINDIR)\_junk.pch ...
@if exist $(WINDIR)\_junk.pch del $(WINDIR)\_junk.pch
@echo Cleaning $(WINDIR)\vercl.x ...
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index e4adb1d..1d6cb2b 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -29,7 +29,7 @@ static int platformId; /* Running under NT, or 95/98? */
* VC++ 5.x has no 'cpuid' assembler instruction, so we must emulate it
*/
-#if defined(_MSC_VER) && (_MSC_VER <= 1100)
+#if defined(_MSC_VER) && (_MSC_VER <= 1100) && defined (_M_IX86)
#define cpuid __asm __emit 0fh __asm __emit 0a2h
#endif
@@ -735,7 +735,7 @@ TclWinCPUID(
__cpuid(regsPtr, index);
status = TCL_OK;
-# else
+# elif defined (_M_IX86)
/*
* Define a structure in the stack frame to hold the registers.
*/
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index e61d619..700e3c8 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -828,7 +828,7 @@ tclWinDebugPanic(
__builtin_trap();
#elif defined(_WIN64)
__debugbreak();
-#elif defined(_MSC_VER)
+#elif defined(_MSC_VER) && defined (_M_IX86)
_asm {int 3}
#else
DebugBreak();
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index fe0ed2d..4b372a5 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -1479,7 +1479,7 @@ BuildCommandLine(
quote = 1;
} else {
int count;
- Tcl_UniChar ch;
+ Tcl_UniChar ch = 0;
for (start = arg; *start != '\0'; start += count) {
count = TclUtfToUniChar(start, &ch);
diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh
index ee10b81..4c2068c 100644
--- a/win/tclooConfig.sh
+++ b/win/tclooConfig.sh
@@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC=""
TCLOO_INCLUDE_SPEC=""
TCLOO_PRIVATE_INCLUDE_SPEC=""
TCLOO_CFLAGS=""
-TCLOO_VERSION=1.0.4
+TCLOO_VERSION=1.2.0