summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--doc/string.n8
-rw-r--r--generic/tclCmdMZ.c71
-rw-r--r--generic/tclCompCmdsSZ.c33
-rw-r--r--generic/tclInt.h3
-rw-r--r--tests/string.test34
-rw-r--r--tests/stringComp.test38
6 files changed, 180 insertions, 7 deletions
diff --git a/doc/string.n b/doc/string.n
index 72a69ff..9108e7c 100644
--- a/doc/string.n
+++ b/doc/string.n
@@ -19,6 +19,14 @@ string \- Manipulate strings
Performs one of several string operations, depending on \fIoption\fR.
The legal \fIoption\fRs (which may be abbreviated) are:
.TP
+\fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR?
+.
+Concatenate the given strings just like direct juxtaposition
+would. This primitive is occasionally handier than juxtaposition when
+mixed quoting is wanted, or when the aim is to return the result of a
+concatenation without resorting to \fB[return -level 0]\fR. If no arg
+is present, an empty string is returned.
+.TP
\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR
.
Perform a character-by-character comparison of strings \fIstring1\fR
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 0f7f20a..ea5d7a4 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -2838,6 +2838,76 @@ StringCmpCmd(
/*
*----------------------------------------------------------------------
*
+ * StringCatCmd --
+ *
+ * This procedure is invoked to process the "string cat" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+StringCatCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ int tot, i, length;
+ char *bytes, *p;
+ Tcl_Obj *objResultPtr;
+
+ /*
+ * NOTE: this implementation aims for simplicity, not speed, because all
+ * speed-critical uses of [string cat] will involve the compiled variant
+ * anyway. Thus we avoid code duplication (from TEBC/INST_CONCAT1) without
+ * sacrificing perf.
+ */
+
+ if (objc < 2) {
+ /*
+ * If there are no args, the result is an empty object.
+ * Just leave the preset empty interp result.
+ */
+ return TCL_OK;
+ }
+ tot = 0;
+ for(i = 1;i < objc;i++) {
+ bytes = TclGetStringFromObj(objv[i], &length);
+ if (bytes != NULL) {
+ tot += length;
+ }
+ }
+ if (tot < 0) {
+ /* TODO: convert panic to error ? */
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+ p = ckalloc(tot + 1);
+ TclNewObj(objResultPtr);
+ objResultPtr->bytes = p;
+ objResultPtr->length = tot;
+ for (i = 1;i < objc;i++) {
+ bytes = TclGetStringFromObj(objv[i], &length);
+ if (bytes != NULL) {
+ memcpy(p, bytes, (size_t) length);
+ p += length;
+ }
+ }
+ *p = '\0';
+ Tcl_SetObjResult(interp,objResultPtr);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* StringBytesCmd --
*
* This procedure is invoked to process the "string bytelength" Tcl
@@ -3330,6 +3400,7 @@ TclInitStringCmd(
{
static const EnsembleImplMap stringImplMap[] = {
{"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0},
{"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0},
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
{"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index e6ec0a6..8ade6a5 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -269,6 +269,39 @@ TclCompileSetCmd(
*/
int
+TclCompileStringCatCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ int numWords = parsePtr->numWords;
+ Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ DefineLineInformation; /* TIP #280 */
+
+ if (numWords>=2) {
+ int i;
+
+ for (i = 1; i < numWords; i++) {
+ CompileWord(envPtr, wordTokenPtr, interp, i);
+ wordTokenPtr = TokenAfter(wordTokenPtr);
+ }
+ while (numWords > 256) {
+ TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr);
+ numWords -= 254; /* concat pushes 1 obj, the result */
+ }
+ if (numWords > 2) {
+ TclEmitInstInt1(INST_STR_CONCAT1, numWords - 1, envPtr);
+ }
+ } else {
+ PushStringLiteral(envPtr, "");
+ }
+ return TCL_OK;
+}
+
+int
TclCompileStringCmpCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1bb2103..6bf1ef9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3646,6 +3646,9 @@ MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileSetCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringCatCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
diff --git a/tests/string.test b/tests/string.test
index a8a83d9..54d02e8 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -30,7 +30,7 @@ testConstraint memory [llength [info commands memory]]
test string-1.1 {error conditions} {
list [catch {string gorp a b} msg] $msg
-} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2 {error conditions} {
list [catch {string} msg] $msg
} {1 {wrong # args: should be "string subcommand ?arg ...?"}}
@@ -54,7 +54,7 @@ test string-2.6 {string compare} {
string compare abcde abdef
} -1
test string-2.7 {string compare, shortest method name} {
- string c abcde ABCDE
+ string co abcde ABCDE
} 1
test string-2.8 {string compare} {
string compare abcde abcde
@@ -81,7 +81,7 @@ test string-2.13 {string compare -nocase} {
string compare -nocase abcde abdef
} -1
test string-2.14 {string compare -nocase} {
- string c -nocase abcde ABCDE
+ string compare -nocase abcde ABCDE
} 0
test string-2.15 {string compare -nocase} {
string compare -nocase abcde abcde
@@ -1513,7 +1513,7 @@ test string-20.1 {string trimright errors} {
} {1 {wrong # args: should be "string trimright string ?chars?"}}
test string-20.2 {string trimright errors} {
list [catch {string trimg a} msg] $msg
-} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-20.3 {string trimright} {
string trimright " XYZ "
} { XYZ}
@@ -1572,7 +1572,7 @@ test string-21.14 {string wordend, unicode} {
test string-22.1 {string wordstart} {
list [catch {string word a} msg] $msg
-} {1 {unknown or ambiguous subcommand "word": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2 {string wordstart} {
list [catch {string wordstart a} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
@@ -1969,6 +1969,30 @@ test string-28.13 {tcl::prefix longest} {
tcl::prefix longest {ax\x90 bep ax\x91} a
} ax
+test string-29.1 {string cat, no arg} {
+ string cat
+} ""
+test string-29.2 {string cat, single arg} {
+ set x [pid]
+ string compare $x [string cat $x]
+} 0
+test string-29.3 {string cat, two args} {
+ set x [pid]
+ string compare $x$x [string cat $x $x]
+} 0
+test string-29.4 {string cat, many args} {
+ set x [pid]
+ set n 260
+ set xx [string repeat $x $n]
+ set vv [string repeat {$x} $n]
+ set vvs [string repeat {$x } $n]
+ set r1 [string compare $xx [subst $vv]]
+ set r2 [string compare $xx [eval "string cat $vvs"]]
+ list $r1 $r2
+} {0 0}
+
+
+
# cleanup
rename MemStress {}
catch {rename foo {}}
diff --git a/tests/stringComp.test b/tests/stringComp.test
index 165ef20..083399b 100644
--- a/tests/stringComp.test
+++ b/tests/stringComp.test
@@ -46,7 +46,7 @@ if {[testConstraint memory]} {
test stringComp-1.1 {error conditions} {
proc foo {} {string gorp a b}
list [catch {foo} msg] $msg
-} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test stringComp-1.2 {error conditions} {
proc foo {} {string}
list [catch {foo} msg] $msg
@@ -210,7 +210,7 @@ foreach {tname tbody tresult tcode} {
# need a few extra tests short abbr cmd
test stringComp-3.1 {string compare, shortest method name} {
- proc foo {} {string c abcde ABCDE}
+ proc foo {} {string co abcde ABCDE}
foo
} 1
test stringComp-3.2 {string equal, shortest method name} {
@@ -735,6 +735,40 @@ test stringComp-14.2 {Bug 82e7f67325} memory {
## string word*
## not yet bc
+
+## string cat
+test stringComp-29.1 {string cat, no arg} {
+ proc foo {} {string cat}
+ foo
+} ""
+test stringComp-29.2 {string cat, single arg} {
+ proc foo {} {
+ set x [pid]
+ string compare $x [string cat $x]
+ }
+ foo
+} 0
+test stringComp-29.3 {string cat, two args} {
+ proc foo {} {
+ set x [pid]
+ string compare $x$x [string cat $x $x]
+ }
+ foo
+} 0
+test stringComp-29.4 {string cat, many args} {
+ proc foo {} {
+ set x [pid]
+ set n 260
+ set xx [string repeat $x $n]
+ set vv [string repeat {$x} $n]
+ set vvs [string repeat {$x } $n]
+ set r1 [string compare $xx [subst $vv]]
+ set r2 [string compare $xx [eval "string cat $vvs"]]
+ list $r1 $r2
+ }
+ foo
+} {0 0}
+
# cleanup
catch {rename foo {}}