diff options
| -rw-r--r-- | ChangeLog | 18 | ||||
| -rw-r--r-- | doc/RegExp.3 | 6 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 21 | ||||
| -rw-r--r-- | generic/tclFileName.c | 48 | ||||
| -rw-r--r-- | generic/tclStringObj.c | 6 | ||||
| -rw-r--r-- | tests/fileName.test | 9 | ||||
| -rw-r--r-- | tests/stringObj.test | 13 | ||||
| -rw-r--r-- | tests/trace.test | 159 |
8 files changed, 261 insertions, 19 deletions
@@ -1,3 +1,21 @@ +2002-11-13 Vince Darley <vincentdarley@users.sourceforge.net> + + * generic/tclCmdMZ.c: + * tests/trace.test: applied patch from Hemang Levana to fix + [Bug #615043] in execution traces with 'return -code error'. + + * generic/tclTestObj.c: + * tests/stringObj.test: added 'knownBug' test for [Bug 635200] + * generic/tclStringObj.c: corrected typos in comments + + * generic/tclFileName.c: + * tests/fileName.test: applied patch for bug reported against + tclvfs concerning handling of Windows serial ports like 'com1', + 'lpt3' by the virtual filesystem code. + + * doc/RegExp.3: clarification of the 'extendMatch' return + values. + 2002-11-11 Jeff Hobbs <jeffh@ActiveState.com> * generic/tclUtil.c (Tcl_Backslash): use TclUtfToUniChar. diff --git a/doc/RegExp.3 b/doc/RegExp.3 index 0fd550f..07cf6c8 100644 --- a/doc/RegExp.3 +++ b/doc/RegExp.3 @@ -6,7 +6,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: RegExp.3,v 1.12 2002/07/01 18:24:39 jenglish Exp $ +'\" RCS: @(#) $Id: RegExp.3,v 1.13 2002/11/13 22:11:40 vincentdarley Exp $ '\" .so man.macros .TH Tcl_RegExpMatch 3 8.1 Tcl "Tcl Library Procedures" @@ -340,7 +340,9 @@ The \fIextendStart\fR field in \fBTcl_RegExpInfo\fR is only set if the character in the string where a match could occur. If a match was found, this will be the same as the beginning of the current match. If no match was found, then it indicates the earliest point at which a -match might occur if additional text is appended to the string. +match might occur if additional text is appended to the string. If it +is no match is possible even with further text, this field will be set +to -1. .VE 8.1 .SH "SEE ALSO" re_syntax(n) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 8243790..0b2903e 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.78 2002/11/12 02:25:24 hobbs Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.79 2002/11/13 22:11:40 vincentdarley Exp $ */ #include "tclInt.h" @@ -3955,6 +3955,8 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) int flags; /* OR-ed bits giving operation and other * information. */ { + Interp *iPtr = (Interp *) interp; + int stateCode; Tcl_SavedResult state; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; int code; @@ -3979,8 +3981,10 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) } /* - * Execute the command. Save the interp's result used for - * the command. We discard any object result the command returns. + * Execute the command. Save the interp's result used for the + * command, including the value of iPtr->returnCode which may be + * modified when Tcl_Eval is invoked. We discard any object + * result the command returns. * * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to * other areas that this will be destroyed by us, otherwise a @@ -3988,6 +3992,7 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) */ Tcl_SaveResult(interp, &state); + stateCode = iPtr->returnCode; if (flags & TCL_TRACE_DESTROYED) { tcmdPtr->flags |= TCL_TRACE_DESTROYED; } @@ -3999,7 +4004,8 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) } Tcl_RestoreResult(interp, &state); - + iPtr->returnCode = stateCode; + Tcl_DStringFree(&cmd); } /* @@ -4358,6 +4364,7 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, */ if (call) { Tcl_SavedResult state; + int stateCode; Tcl_DString cmd; Tcl_DString sub; int i; @@ -4406,10 +4413,13 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, /* * Execute the command. Save the interp's result used for - * the command. We discard any object result the command returns. + * the command, including the value of iPtr->returnCode which + * may be modified when Tcl_Eval is invoked. We discard any + * object result the command returns. */ Tcl_SaveResult(interp, &state); + stateCode = iPtr->returnCode; tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; iPtr->flags |= INTERP_TRACE_IN_PROGRESS; @@ -4429,6 +4439,7 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, if (traceCode == TCL_OK) { /* Restore result if trace execution was successful */ Tcl_RestoreResult(interp, &state); + iPtr->returnCode = stateCode; } Tcl_DStringFree(&cmd); diff --git a/generic/tclFileName.c b/generic/tclFileName.c index e3ec128..fc0dbcd 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.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: tclFileName.c,v 1.38 2002/09/27 00:50:10 hobbs Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.39 2002/11/13 22:11:40 vincentdarley Exp $ */ #include "tclInt.h" @@ -243,9 +243,51 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) return tail; } } else { - *typePtr = TCL_PATH_RELATIVE; - return path; + int abs = 0; + if (path[0] == 'c' && path[1] == 'o') { + if (path[2] == 'm' && path[3] >= '1' && path[3] <= '9') { + /* May have match for 'com[1-9]:?', which is a serial port */ + if (path[4] == '\0') { + abs = 4; + } else if (path [4] == ':' && path[5] == '\0') { + abs = 5; + } + } else if (path[2] == 'n' && path[3] == '\0') { + /* Have match for 'con' */ + abs = 3; + } + } else if (path[0] == 'l' && path[1] == 'p' && path[2] == 't') { + if (path[3] >= '1' && path[3] <= '9') { + /* May have match for 'lpt[1-9]:?' */ + if (path[4] == '\0') { + abs = 4; + } else if (path [4] == ':' && path[5] == '\0') { + abs = 5; + } + } + } else if (path[0] == 'p' && path[1] == 'r' + && path[2] == 'n' && path[3] == '\0') { + /* Have match for 'prn' */ + abs = 3; + } else if (path[0] == 'n' && path[1] == 'u' + && path[2] == 'l' && path[3] == '\0') { + /* Have match for 'nul' */ + abs = 3; + } else if (path[0] == 'a' && path[1] == 'u' + && path[2] == 'x' && path[3] == '\0') { + /* Have match for 'aux' */ + abs = 3; + } + if (abs != 0) { + *typePtr = TCL_PATH_ABSOLUTE; + Tcl_DStringSetLength(resultPtr, offset); + Tcl_DStringAppend(resultPtr, path, abs); + return path + abs; + } } + /* Anything else is treated as relative */ + *typePtr = TCL_PATH_RELATIVE; + return path; } /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 47d0388..c951ae5 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -11,7 +11,7 @@ * of properly formed UTF-8 characters. There is a one-to-one map between * Unicode and UTF characters. Because Unicode characters have a fixed * width, operations such as indexing operate on Unicode data. The String - * ojbect is opitmized for the case where each UTF char in a string is + * object is optimized for the case where each UTF char in a string is * only one byte. In this case, we store the value of numChars, but we * don't store the Unicode data (unless Tcl_GetUnicode is explicitly * called). @@ -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.25 2002/11/12 02:26:15 hobbs Exp $ */ + * RCS: @(#) $Id: tclStringObj.c,v 1.26 2002/11/13 22:11:41 vincentdarley Exp $ */ #include "tclInt.h" @@ -1695,7 +1695,7 @@ SetStringFromAny(interp, objPtr) register Tcl_Obj *objPtr; /* The object to convert. */ { /* - * The Unicode object is opitmized for the case where each UTF char + * The Unicode object is optimized for the case where each UTF char * in a string is only one byte. In this case, we store the value of * numChars, but we don't copy the bytes to the unicodeObj->unicode. */ diff --git a/tests/fileName.test b/tests/fileName.test index d9dd9d4..580ec90 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -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: fileName.test,v 1.26 2002/07/10 13:08:20 dkf Exp $ +# RCS: @(#) $Id: fileName.test,v 1.27 2002/11/13 22:11:41 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1816,6 +1816,13 @@ test filename-16.16 {windows specific globbing} {pcOnly} { file tail [lindex [glob "[lindex [glob -types d -dir C:/ *] 0]/.."] 0] } {..} +test filename-17.1 {windows specific special files} {testsetplatform} { + testsetplatform win + list [file pathtype com1] [file pathtype con] [file pathtype lpt3] \ + [file pathtype prn] [file pathtype nul] [file pathtype aux] \ + [file pathtype foo] +} {absolute absolute absolute absolute absolute absolute relative} + # cleanup catch {file delete -force C:/globTest} file delete -force globTest diff --git a/tests/stringObj.test b/tests/stringObj.test index 115ba2c..c2db812 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.11 2000/06/28 18:11:21 ericm Exp $ +# RCS: @(#) $Id: stringObj.test,v 1.12 2002/11/13 22:11:41 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -415,6 +415,17 @@ test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} { list [string length $a] [string length $a] } {10 10} +test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} {knownBug} { + teststringobj set 1 foo + teststringobj getunicode 1 + teststringobj append 1 bar -1 + teststringobj getunicode 1 + teststringobj append 1 bar -1 + teststringobj setlength 1 0 + teststringobj append 1 bar -1 + teststringobj get 1 +} {bar} + testobj freeallvars # cleanup diff --git a/tests/trace.test b/tests/trace.test index f72b0bd..2e8b61b 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -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: trace.test,v 1.23 2002/10/15 16:13:47 vincentdarley Exp $ +# RCS: @(#) $Id: trace.test,v 1.24 2002/11/13 22:11:41 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1850,24 +1850,175 @@ test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} trace add execution foo {enter enterstep leavestep leave} \ [list traceExecute foo] update - after idle {puts idle} + after idle {set a "idle"} foo trace remove execution foo {enter enterstep leavestep leave} \ [list traceExecute foo] rename foo {} + catch {unset a} join $info "\n" } {foo foo enter foo {set a 1} enterstep foo {set a 1} 0 1 leavestep foo {update idletasks} enterstep -foo {puts idle} enterstep -foo {puts idle} 0 {} leavestep +foo {set a idle} enterstep +foo {set a idle} 0 idle leavestep foo {update idletasks} 0 {} leavestep foo {set b 1} enterstep foo {set b 1} 0 1 leavestep foo foo 0 1 leave} +test trace-28.2 {exec traces with 'error'} { + set info {} + set res {} + + proc foo {} { + if {[catch {bar}]} { + return "error" + } else { + return "ok" + } + } + + proc bar {} { error "msg" } + + lappend res [foo] + + trace add execution foo {enter enterstep leave leavestep} \ + [list traceExecute foo] + + # With the trace active + + lappend res [foo] + + trace remove execution foo {enter enterstep leave leavestep} \ + [list traceExecute foo] + + list $res [join $info \n] +} {{error error} {foo foo enter +foo {if {[catch {bar}]} { + return "error" + } else { + return "ok" + }} enterstep +foo {catch bar} enterstep +foo bar enterstep +foo {error msg} enterstep +foo {error msg} 1 msg leavestep +foo bar 1 msg leavestep +foo {catch bar} 0 1 leavestep +foo {return error} enterstep +foo {return error} 2 error leavestep +foo {if {[catch {bar}]} { + return "error" + } else { + return "ok" + }} 2 error leavestep +foo foo 0 error leave}} + +test trace-28.3 {exec traces with 'return -code error'} { + set info {} + set res {} + + proc foo {} { + if {[catch {bar}]} { + return "error" + } else { + return "ok" + } + } + + proc bar {} { return -code error "msg" } + + lappend res [foo] + + trace add execution foo {enter enterstep leave leavestep} \ + [list traceExecute foo] + + # With the trace active + + lappend res [foo] + + trace remove execution foo {enter enterstep leave leavestep} \ + [list traceExecute foo] + + list $res [join $info \n] +} {{error error} {foo foo enter +foo {if {[catch {bar}]} { + return "error" + } else { + return "ok" + }} enterstep +foo {catch bar} enterstep +foo bar enterstep +foo {return -code error msg} enterstep +foo {return -code error msg} 2 msg leavestep +foo bar 1 msg leavestep +foo {catch bar} 0 1 leavestep +foo {return error} enterstep +foo {return error} 2 error leavestep +foo {if {[catch {bar}]} { + return "error" + } else { + return "ok" + }} 2 error leavestep +foo foo 0 error leave}} + +test trace-28.4 {exec traces in slave with 'return -code error'} {knownBug} { + interp create slave + interp alias slave traceExecute {} traceExecute + set res [interp eval slave { + set info {} + set res {} + + proc foo {} { + if {[catch {bar}]} { + return "error" + } else { + return "ok" + } + } + + proc bar {} { return -code error "msg" } + + lappend res [foo] + + trace add execution foo {enter enterstep leave leavestep} \ + [list traceExecute foo] + + # With the trace active + + lappend res [foo] + + trace remove execution foo {enter enterstep leave leavestep} \ + [list traceExecute foo] + + list $res [join $info \n] + }] + interp delete slave + set res +} {{error error} {foo foo enter +foo {if {[catch {bar}]} { + return "error" + } else { + return "ok" + }} enterstep +foo {catch bar} enterstep +foo bar enterstep +foo {return -code error msg} enterstep +foo {return -code error msg} 2 msg leavestep +foo bar 1 msg leavestep +foo {catch bar} 0 1 leavestep +foo {return error} enterstep +foo {return error} 2 error leavestep +foo {if {[catch {bar}]} { + return "error" + } else { + return "ok" + }} 2 error leavestep +foo foo 0 error leave}} + # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). catch {rename foobar {}} |