From aff97042289b6c2c5fd35cb8413deca7054ab0a7 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 28 Mar 2011 10:56:38 +0000 Subject: Use the error messages generated by the variable management code rather than creating our own in [regexp] and [regsub]. --- ChangeLog | 8 +++++++- generic/tclCmdMZ.c | 13 ++++--------- tests/regexp.test | 47 ++++++++++++++++++++++++++--------------------- tests/regexpComp.test | 35 ++++++++++++++++++++--------------- 4 files changed, 57 insertions(+), 46 deletions(-) diff --git a/ChangeLog b/ChangeLog index 23b91b7..703dc72 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,10 +1,16 @@ +2011-03-28 Donal K. Fellows + + * generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the + error messages generated by the variable management code rather than + creating our own. + 2011-03-27 Miguel Sofer * generic/tclBasic.c (TclNREvalObjEx): fix performance issue, notably apparent in tclbench's "LIST lset foreach". Many thanks to twylite for patiently researching the issue and explaining it to me: a missing Tcl_ResetObjResult that causes unwanted sharing of - the current result Tcl_Obj. + the current result Tcl_Obj. 2011-03-26 Donal K. Fellows diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 05f2e5d..e39ae06 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -383,12 +383,8 @@ Tcl_RegexpObjCmd( return TCL_ERROR; } } else { - Tcl_Obj *valuePtr; - - valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); - if (valuePtr == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[i]), "\"", NULL); + if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, + TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } } @@ -816,9 +812,8 @@ Tcl_RegsubObjCmd( Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { - if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[3]), "\"", NULL); + if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, + TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; } else { /* diff --git a/tests/regexp.test b/tests/regexp.test index 632a19d..7cafd1b 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -11,12 +11,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } -catch {unset foo} +unset -nocomplain foo testConstraint exec [llength [info commands exec]] @@ -196,7 +196,7 @@ set x $x$x$x$x$x$x$x$x$x$x$x$x test regexp-4.4 {case conversion in regexp} { list [regexp -nocase $x $x foo] $foo } "1 $x" -catch {unset x} +unset -nocomplain x test regexp-5.1 {exercise cache of compiled expressions} { regexp .*a b @@ -260,11 +260,12 @@ test regexp-6.6 {regexp errors} { test regexp-6.7 {regexp errors} { list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg } {0 0} -test regexp-6.8 {regexp errors} { - catch {unset f1} +test regexp-6.8 {regexp errors} -setup { + unset -nocomplain f1 +} -body { set f1 44 - list [catch {regexp abc abc f1(f2)} msg] $msg -} {1 {couldn't set variable "f1(f2)"}} + regexp abc abc f1(f2) +} -returnCodes error -result {can't set "f1(f2)": variable isn't array} test regexp-6.9 {regexp errors, -start bad int check} { list [catch {regexp -start bogus {^$} {}} msg] $msg } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} @@ -456,11 +457,12 @@ test regexp-11.5 {regsub errors} { 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}} -test regexp-11.7 {regsub errors} { - catch {unset f1} +test regexp-11.7 {regsub errors} -setup { + unset -nocomplain f1 +} -body { set f1 44 - list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg -} {1 {couldn't set variable "f1(f2)"}} + regsub -nocase aaa aaa xxx f1(f2) +} -returnCodes error -result {can't set "f1(f2)": variable isn't array} test regexp-11.8 {regsub errors, -start bad int check} { list [catch {regsub -start bogus pattern string rep var} msg] $msg } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} @@ -527,23 +529,23 @@ test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -co } -result 1 test regexp-15.1 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start -10 {\d} 1abc2de3 x] $x } {1 1} test regexp-15.2 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 2 {\d} 1abc2de3 x] $x } {1 2} test regexp-15.3 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 4 {\d} 1abc2de3 x] $x } {1 2} test regexp-15.4 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 5 {\d} 1abc2de3 x] $x } {1 3} test regexp-15.5 {regexp -start, over end of string} { - catch {unset x} + unset -nocomplain x list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x] } {0 0} test regexp-15.6 {regexp -start, loss of ^$ behavior} { @@ -556,11 +558,11 @@ test regexp-15.8 {regexp -start, double option} { regexp -start 0 -start 2 a abc } 0 test regexp-15.9 {regexp -start, end relative index} { - catch {unset x} + unset -nocomplain x list [regexp -start end {\d} 1abc2de3 x] [info exists x] } {0 0} test regexp-15.10 {regexp -start, end relative index} { - catch {unset x} + unset -nocomplain x list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x } {1 1 3} test regexp-15.11 {regexp -start, over end of string} { @@ -569,15 +571,15 @@ test regexp-15.11 {regexp -start, over end of string} { } {1 {}} test regexp-16.1 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x } {4 a1b/2c/3d/4e/5} test regexp-16.2 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start -25 {z} hello {/&} x] $x } {0 hello} test regexp-16.3 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start 3 {z} hello {/&} x] $x } {0 hello} test regexp-16.4 {regsub -start, \A behavior} { @@ -1065,3 +1067,6 @@ test regexp-26.13 {regexp without -line option} { ::tcltest::cleanupTests return +# Local Variables: +# mode: tcl +# End: diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 6f0b688..94fb90e 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -29,7 +29,8 @@ proc evalInProc { script } { #return [list $status $result] } -catch {unset foo} +unset -nocomplain foo + test regexpComp-1.1 {basic regexp operation} { evalInProc { regexp ab*c abbbc @@ -258,7 +259,7 @@ test regexpComp-4.4 {case conversion in regexp} { list [regexp -nocase $::x $::x foo] $foo } } "1 $x" -catch {unset ::x} +unset -nocomplain ::x test regexpComp-5.1 {exercise cache of compiled expressions} { evalInProc { @@ -348,11 +349,11 @@ test regexpComp-6.7 {regexp errors} { } {0 0} test regexpComp-6.8 {regexp errors} { evalInProc { - catch {unset f1} + unset -nocomplain f1 set f1 44 list [catch {regexp abc abc f1(f2)} msg] $msg } -} {1 {couldn't set variable "f1(f2)"}} +} {1 {can't set "f1(f2)": variable isn't array}} test regexpComp-6.9 {regexp errors, -start bad int check} { evalInProc { list [catch {regexp -start bogus {^$} {}} msg] $msg @@ -589,11 +590,11 @@ test regexpComp-11.6 {regsub errors} { } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} test regexpComp-11.7 {regsub errors} { evalInProc { - catch {unset f1} + unset -nocomplain f1 set f1 44 list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg } -} {1 {couldn't set variable "f1(f2)"}} +} {1 {can't set "f1(f2)": variable isn't array}} test regexpComp-11.8 {regsub errors, -start bad int check} { evalInProc { list [catch {regsub -start bogus pattern string rep var} msg] $msg @@ -660,23 +661,23 @@ test regexpComp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} } -result 1 test regexpComp-15.1 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start -10 {\d} 1abc2de3 x] $x } {1 1} test regexpComp-15.2 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 2 {\d} 1abc2de3 x] $x } {1 2} test regexpComp-15.3 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 4 {\d} 1abc2de3 x] $x } {1 2} test regexpComp-15.4 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 5 {\d} 1abc2de3 x] $x } {1 3} test regexpComp-15.5 {regexp -start, over end of string} { - catch {unset x} + unset -nocomplain x list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x] } {0 0} test regexpComp-15.6 {regexp -start, loss of ^$ behavior} { @@ -684,15 +685,15 @@ test regexpComp-15.6 {regexp -start, loss of ^$ behavior} { } {0} test regexpComp-16.1 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x } {4 a1b/2c/3d/4e/5} test regexpComp-16.2 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start -25 {z} hello {/&} x] $x } {0 hello} test regexpComp-16.3 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start 3 {z} hello {/&} x] $x } {0 hello} test regexpComp-16.4 {regsub -start, \A behavior} { @@ -981,7 +982,11 @@ test regexpComp-24.11 {regexp command compiling tests} { regexp -- $re $text } } 1 - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12