summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/GetInt.37
-rw-r--r--doc/copy.n22
-rw-r--r--doc/define.n15
-rw-r--r--doc/expr.n3
-rw-r--r--doc/format.n2
-rw-r--r--doc/regsub.n74
-rw-r--r--generic/tclCmdMZ.c126
-rw-r--r--generic/tclLink.c4
-rw-r--r--generic/tclOO.c1
-rw-r--r--generic/tclOO.h2
-rw-r--r--generic/tclOOBasic.c32
-rw-r--r--generic/tclOODefineCmds.c43
-rw-r--r--generic/tclOOInt.h3
-rw-r--r--generic/tclStrToD.c17
-rw-r--r--generic/tclStringObj.c4
-rw-r--r--library/init.tcl50
-rw-r--r--tests/cmdIL.test4
-rw-r--r--tests/format.test21
-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/util.test18
-rw-r--r--unix/tclooConfig.sh2
-rw-r--r--win/tclooConfig.sh2
26 files changed, 621 insertions, 73 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/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/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/tclCmdMZ.c b/generic/tclCmdMZ.c
index b81b6e5..32d4523 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, *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/tclLink.c b/generic/tclLink.c
index 02abfa0..9c698a0 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -693,7 +693,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
@@ -702,7 +702,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/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 70a0a32..b0bfd9c 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -1015,16 +1015,16 @@ TclOODefineSelfObjCmd(
Object *oPtr;
int result;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
- return TCL_ERROR;
- }
-
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).
@@ -1061,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/tclStrToD.c b/generic/tclStrToD.c
index 57c24ac..a5d1f30 100644
--- 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:
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 92cb137..e1b1942 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -2039,6 +2039,10 @@ Tcl_AppendFormatToObj(
Tcl_AppendToObj(segment, "0b", 2);
segmentLimit -= 2;
break;
+ case 'd':
+ Tcl_AppendToObj(segment, "0d", 2);
+ segmentLimit -= 2;
+ break;
}
}
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/format.test b/tests/format.test
index 7fa6a72..094b7b3 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -79,24 +79,15 @@ 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} longIs32bit {
+test format-1.13 {integer formatting} {
format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1
-} {0 6 34 16923 -12}
-test format-1.13.1 {integer formatting} longIs64bit {
- format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1
-} {0 6 34 16923 -12}
-test format-1.14 {integer formatting} longIs32bit {
- format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1
-} { 0 6 34 16923 -12}
-test format-1.14.1 {integer formatting} longIs64bit {
+} {0d0 0d6 0d34 0d16923 -0d12}
+test format-1.14 {integer formatting} {
format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1
-} { 0 6 34 16923 -12}
-test format-1.15 {integer formatting} longIs32bit {
- format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1
-} {0 6 34 16923 -12 }
-test format-1.15.1 {integer formatting} longIs64bit {
+} { 0d0 0d6 0d34 0d16923 -0d12}
+test format-1.15 {integer formatting} {
format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1
-} {0 6 34 16923 -12 }
+} {0d0 0d6 0d34 0d16923 -0d12 }
test format-2.1 {string formatting} {
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/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/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/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
generated by cgit v0.12 at 2025-12-16 04:17:00 (GMT)