diff options
| -rw-r--r-- | generic/tclParseExpr.c | 4 | ||||
| -rw-r--r-- | generic/tclProc.c | 25 | ||||
| -rw-r--r-- | generic/tclStringObj.c | 11 | ||||
| -rw-r--r-- | tests/stringObj.test | 19 |
4 files changed, 43 insertions, 16 deletions
diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c index 819628c..ced85d7 100644 --- a/generic/tclParseExpr.c +++ b/generic/tclParseExpr.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParseExpr.c,v 1.4 1999/04/21 21:50:28 rjohnson Exp $ + * RCS: @(#) $Id: tclParseExpr.c,v 1.5 1999/09/02 16:26:33 hobbs Exp $ */ #include "tclInt.h" @@ -1589,7 +1589,7 @@ GetLexeme(infoPtr) infoPtr->lexeme = DOLLAR; return TCL_OK; - case '"': + case '\"': infoPtr->lexeme = QUOTE; return TCL_OK; diff --git a/generic/tclProc.c b/generic/tclProc.c index 3609d16..ac07cae 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.19 1999/04/16 00:46:52 stanton Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.20 1999/09/02 16:26:33 hobbs Exp $ */ #include "tclInt.h" @@ -135,6 +135,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); + Tcl_DStringFree(&ds); /* * Now initialize the new procedure's cmdPtr field. This will be used * later when the procedure is called to determine what namespace the @@ -265,7 +266,7 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) if (precompiled) { if (numArgs > procPtr->numArgs) { - char buf[128]; + char buf[64 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE]; sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d", numArgs, procPtr->numArgs); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -351,7 +352,7 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) && (fieldCount == 2)) || ((localPtr->defValuePtr != NULL) && (fieldCount != 2))) { - char buf[128]; + char buf[80 + TCL_INTEGER_SPACE]; sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body", i); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -1087,7 +1088,6 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) } } if (bodyPtr->typePtr != &tclByteCodeType) { - char buf[100]; int numChars; char *ellipsis; @@ -1133,6 +1133,8 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) if (result != TCL_OK) { if (result == TCL_ERROR) { + char buf[100 + TCL_INTEGER_SPACE]; + numChars = strlen(procName); ellipsis = ""; if (numChars > 50) { @@ -1201,13 +1203,20 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode) int returnCode; /* The unexpected result code. */ { Interp *iPtr = (Interp *) interp; - char msg[100 + TCL_INTEGER_SPACE]; - + if (returnCode == TCL_RETURN) { returnCode = TclUpdateReturnInfo(iPtr); } else if (returnCode == TCL_ERROR) { - sprintf(msg, "\n (procedure \"%.*s\" line %d)", - nameLen, procName, iPtr->errorLine); + char msg[100 + TCL_INTEGER_SPACE]; + char *ellipsis = ""; + int numChars = nameLen; + + if (numChars > 60) { + numChars = 60; + ellipsis = "..."; + } + sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", + numChars, procName, ellipsis, iPtr->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } else if (returnCode == TCL_BREAK) { Tcl_ResetResult(interp); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 95e83dc..bc18fb3 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -33,7 +33,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStringObj.c,v 1.12 1999/06/16 00:47:56 hershey Exp $ */ + * RCS: @(#) $Id: tclStringObj.c,v 1.13 1999/09/02 16:26:34 hobbs Exp $ */ #include "tclInt.h" @@ -334,7 +334,7 @@ Tcl_GetCharLength(objPtr) if (stringPtr->numChars == objPtr->length) { /* - * Since we've just calucalated the number of chars, and all + * Since we've just calculated the number of chars, and all * UTF chars are 1-byte long, we don't need to store the * unicode string. */ @@ -916,17 +916,18 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr) * number of characters in the final (appended-to) object. */ + bytes = Tcl_GetStringFromObj(appendObjPtr, &length); + allOneByteChars = 0; numChars = stringPtr->numChars; if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) { stringPtr = GET_STRING(appendObjPtr); - if (stringPtr->numChars >= 0) { + if ((stringPtr->numChars >= 0) && (stringPtr->numChars == length)) { numChars += stringPtr->numChars; allOneByteChars = 1; } } - - bytes = Tcl_GetStringFromObj(appendObjPtr, &length); + AppendUtfToUtfRep(objPtr, bytes, length); if (allOneByteChars) { diff --git a/tests/stringObj.test b/tests/stringObj.test index 257aa9a..cc991d3 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: stringObj.test,v 1.8 1999/06/26 20:55:14 rjohnson Exp $ +# RCS: @(#) $Id: stringObj.test,v 1.9 1999/09/02 16:26:38 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -299,6 +299,23 @@ test stringObj-9.10 {TclAppendObjToObj, integer src & mixed dest} { list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] } {string int abcï¿®ghi9 9 string int} +test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} { + # bug 2678, in <=8.2.0, the second obj (the one to append) in + # Tcl_AppendObjToObj was not correctly checked to see if it was + # all one byte chars, so a unicode string would be added as one + # byte chars. + set x abcdef + set len [string length $x] + set y aübåcï + set len [string length $y] + append x $y + string length $x + set q {} + for {set i 0} {$i < 12} {incr i} { + lappend q [string index $x $i] + } + set q +} {a b c d e f a ü b å c ï} test stringObj-10.1 {Tcl_GetRange with all byte-size chars} { set x "abcdef" |