From f316d7539c5bb69dc519fc27be251c9ba056c189 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 17 Apr 2018 18:34:41 +0000 Subject: [array set] must fire array traces. Don't disrupt that by reporting argument errors too early. --- generic/tclCompCmds.c | 11 +++++++++++ tests/var.test | 9 +++++++++ 2 files changed, 20 insertions(+) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c2b4bdb..9a15ee0 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -322,11 +322,22 @@ TclCompileArraySetCmd( */ if (isDataValid && !isDataEven) { + /* Abandon compile and let direct eval raise the error */ + code = TCL_ERROR; + goto done; + + /* + * We used to compile to the bytecode that would throw the error, + * but that was wrong because it would not invoke the array trace + * on the variable. + * PushStringLiteral(envPtr, "list must have an even number of elements"); PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); goto done; + * + */ } /* diff --git a/tests/var.test b/tests/var.test index a9d93ac..d1340f6 100644 --- a/tests/var.test +++ b/tests/var.test @@ -930,6 +930,15 @@ test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup { test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body { apply {{} {set name foo(bar); array set $name {a 1}}} } -returnCodes error -match glob -result * +test var-20.11 {array set don't compile bad initializer} -setup { + unset -nocomplain foo + trace add variable foo array {set foo(bar) baz;#} +} -body { + catch {array set foo bad} + set foo(bar) +} -cleanup { + unset -nocomplain foo +} -result baz test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { proc linenumber {} {dict get [info frame -1] line} -- cgit v0.12 From 5dff80f2fe38009bc7e7c6b3f74033a8a05a59a1 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 17 Apr 2018 18:54:36 +0000 Subject: Gentler fallback. --- generic/tclCompCmds.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9a15ee0..22bbca0 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -322,8 +322,8 @@ TclCompileArraySetCmd( */ if (isDataValid && !isDataEven) { - /* Abandon compile and let direct eval raise the error */ - code = TCL_ERROR; + /* Abandon custom compile and let invocation raise the error */ + code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); goto done; /* -- cgit v0.12 From 62ea5e49a10037bf3a3896a933db4951ff0b15bc Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 17 Apr 2018 19:14:01 +0000 Subject: Array trace firing must come before argument checking might raise error. --- generic/tclCompCmds.c | 7 ++++--- tests/var.test | 13 +++++++++++++ 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 22bbca0..838e9d7 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -415,6 +415,10 @@ TclCompileArraySetCmd( * Start issuing instructions to write to the array. */ + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + CompileWord(envPtr, dataTokenPtr, interp, 2); if (!isDataLiteral || !isDataValid) { /* @@ -439,9 +443,6 @@ TclCompileArraySetCmd( TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); } - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); offsetBack = CurrentOffset(envPtr); Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); diff --git a/tests/var.test b/tests/var.test index d1340f6..01080bc 100644 --- a/tests/var.test +++ b/tests/var.test @@ -939,6 +939,19 @@ test var-20.11 {array set don't compile bad initializer} -setup { } -cleanup { unset -nocomplain foo } -result baz +test var-20.12 {array set don't compile bad initializer} -setup { + unset -nocomplain ::foo + trace add variable ::foo array {set ::foo(bar) baz;#} +} -body { + catch {apply {{} { + set value bad + array set ::foo $value + + }}} + set ::foo(bar) +} -cleanup { + unset -nocomplain ::foo +} -result baz test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { proc linenumber {} {dict get [info frame -1] line} -- cgit v0.12 From 6b8039a9524bb88679e0d837a5345f26c8654a52 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 17 Apr 2018 20:29:02 +0000 Subject: Refactor array trace handling into a common routine TclCheckArrayTraces(). --- generic/tclExecute.c | 17 ++--- generic/tclInt.h | 2 + generic/tclTrace.c | 41 ++++++++++++ generic/tclVar.c | 180 +++++++++++---------------------------------------- 4 files changed, 86 insertions(+), 154 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index aab9092..5bc5c2d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4294,17 +4294,12 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, /*createPart1*/0, /*createPart2*/0, &arrayPtr); doArrayExists: - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - DECACHE_STACK_INFO(); - result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, - NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY| - TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); - CACHE_STACK_INFO(); - if (result == TCL_ERROR) { - TRACE_ERROR(interp); - goto gotError; - } + DECACHE_STACK_INFO(); + result = TclCheckArrayTraces(interp, varPtr, arrayPtr, part1Ptr, opnd); + CACHE_STACK_INFO(); + if (result == TCL_ERROR) { + TRACE_ERROR(interp); + goto gotError; } if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { objResultPtr = TCONST(1); diff --git a/generic/tclInt.h b/generic/tclInt.h index dc7909c..371e3fa 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2873,6 +2873,8 @@ MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, MODULE_SCOPE double TclCeil(const mp_int *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); +MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, Tcl_Obj *name, int index); MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, const char *value); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 958399a..d48761b 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -2478,6 +2478,47 @@ TclVarTraceExists( /* *---------------------------------------------------------------------- * + * TclCheckArrayTraces -- + * + * This function is invoked to when we operate on an array variable, + * to allow any array traces to fire. + * + * Results: + * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if + * invocation of a trace function indicated an error. When TCL_ERROR is + * returned, then error information is left in interp. + * + * Side effects: + * Almost anything can happen, depending on trace; this function itself + * doesn't have any side effects. + * + *---------------------------------------------------------------------- + */ + +int +TclCheckArrayTraces( + Tcl_Interp *interp, + Var *varPtr, + Var *arrayPtr, + Tcl_Obj *name, + int index) +{ + int code = TCL_OK; + + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + Interp *iPtr = (Interp *)interp; + + code = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, name, NULL, + (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY), + /* leaveErrMsg */ 1, index); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * * TclCallVarTraces -- * * This function is invoked to find and invoke relevant trace functions diff --git a/generic/tclVar.c b/generic/tclVar.c index 3dd6790..e07d39a 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3121,7 +3121,7 @@ ArrayStartSearchCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; Var *varPtr, *arrayPtr; Tcl_HashEntry *hPtr; Tcl_Obj *varNameObj; @@ -3143,18 +3143,9 @@ ArrayStartSearchCmd( /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); varName = TclGetString(varNameObj); - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) + == TCL_ERROR) { + return TCL_ERROR; } /* @@ -3219,7 +3210,7 @@ ArrayAnyMoreCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; Var *varPtr, *arrayPtr; Tcl_Obj *varNameObj, *searchObj; int gotValue; @@ -3239,18 +3230,9 @@ ArrayAnyMoreCmd( varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) + == TCL_ERROR) { + return TCL_ERROR; } /* @@ -3326,7 +3308,6 @@ ArrayNextElementCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; Tcl_Obj *varNameObj, *searchObj; ArraySearch *searchPtr; @@ -3345,18 +3326,9 @@ ArrayNextElementCmd( varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) + == TCL_ERROR) { + return TCL_ERROR; } /* @@ -3435,7 +3407,7 @@ ArrayDoneSearchCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; Var *varPtr, *arrayPtr; Tcl_HashEntry *hPtr; Tcl_Obj *varNameObj, *searchObj; @@ -3455,18 +3427,9 @@ ArrayDoneSearchCmd( varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) + == TCL_ERROR) { + return TCL_ERROR; } /* @@ -3543,7 +3506,7 @@ ArrayExistsCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; Var *varPtr, *arrayPtr; Tcl_Obj *arrayNameObj; int notArray; @@ -3561,18 +3524,9 @@ ArrayExistsCmd( varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, arrayNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, arrayNameObj, -1) + == TCL_ERROR) { + return TCL_ERROR; } /* @@ -3610,7 +3564,6 @@ ArrayGetCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr, *varPtr2; Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj; Tcl_Obj **nameObjPtr, *patternObj; @@ -3639,18 +3592,9 @@ ArrayGetCmd( varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) + == TCL_ERROR) { + return TCL_ERROR; } /* @@ -3798,7 +3742,6 @@ ArrayNamesCmd( "-exact", "-glob", "-regexp", NULL }; enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; - Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr, *varPtr2; Tcl_Obj *varNameObj, *nameObj, *resultObj, *patternObj; Tcl_HashSearch search; @@ -3819,18 +3762,9 @@ ArrayNamesCmd( varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) + == TCL_ERROR) { + return TCL_ERROR; } /* @@ -3986,7 +3920,6 @@ ArraySetCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; if (objc != 3) { @@ -4001,18 +3934,9 @@ ArraySetCmd( varPtr = TclObjLookupVarEx(interp, objv[1], NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, objv[1], NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, objv[1], -1) + == TCL_ERROR) { + return TCL_ERROR; } return TclArraySet(interp, objv[1], objv[2]); @@ -4043,7 +3967,6 @@ ArraySizeCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; Tcl_Obj *varNameObj; Tcl_HashSearch search; @@ -4063,18 +3986,9 @@ ArraySizeCmd( varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) + == TCL_ERROR) { + return TCL_ERROR; } /* @@ -4127,7 +4041,6 @@ ArrayStatsCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; Tcl_Obj *varNameObj; char *stats; @@ -4145,18 +4058,9 @@ ArrayStatsCmd( varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) + == TCL_ERROR) { + return TCL_ERROR; } /* @@ -4210,7 +4114,6 @@ ArrayUnsetCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr, *varPtr2, *protectedVarPtr; Tcl_Obj *varNameObj, *patternObj, *nameObj; Tcl_HashSearch search; @@ -4238,18 +4141,9 @@ ArrayUnsetCmd( varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) + == TCL_ERROR) { + return TCL_ERROR; } /* -- cgit v0.12 From 327595170bbc91997186ac34d44238537e330cd5 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 18 Apr 2018 11:59:57 +0000 Subject: http::geturl now returns full error stack information if the initial socket command fails Ticket [ff82755e15] --- library/http/http.tcl | 7 ++++--- library/http/pkgIndex.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 9 insertions(+), 8 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 9f5310b..186d067 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.8.12 +package provide http 2.8.13 namespace eval http { # Allow resourcing to not clobber existing data @@ -602,7 +602,7 @@ proc http::geturl {url args} { if {[info exists state(-myaddr)]} { lappend sockopts -myaddr $state(-myaddr) } - if {[catch {eval $defcmd $sockopts $targetAddr} sock]} { + if {[catch {eval $defcmd $sockopts $targetAddr} sock errdict]} { # something went wrong while trying to establish the connection. # Clean up after events and such, but DON'T call the command # callback (if available) because we're going to throw an @@ -611,7 +611,8 @@ proc http::geturl {url args} { set state(sock) $sock Finish $token "" 1 cleanup $token - return -code error $sock + dict unset errdict -level + return -options $errdict $sock } } set state(sock) $sock diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index d3fc7af..3324af9 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.8.12 [list tclPkgSetup $dir http 2.8.12 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.8.13 [list tclPkgSetup $dir http 2.8.13 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/unix/Makefile.in b/unix/Makefile.in index 29c051d..4277fad 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -840,8 +840,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; - @echo "Installing package http 2.8.12 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.12.tm; + @echo "Installing package http 2.8.13 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.13.tm; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ diff --git a/win/Makefile.in b/win/Makefile.in index 633a9f5..f063da1 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -651,8 +651,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.8.12 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.12.tm; + @echo "Installing package http 2.8.13 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.13.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12 From fb91d4b68b081abb8ff689ed624a567c1a27a260 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 18 Apr 2018 19:21:33 +0000 Subject: Refactor the common operations of looking up and checking traces on an array variable into a single routine LocateArray(). --- generic/tclVar.c | 152 +++++++++++++++---------------------------------------- 1 file changed, 41 insertions(+), 111 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index e07d39a..a4cd62b 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -176,6 +176,8 @@ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags, int index); +static int LocateArray(Tcl_Interp *interp, Tcl_Obj *name, + Var **varPtrPtr); static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr, int flags); @@ -269,6 +271,22 @@ TclVarHashCreateVar( return varPtr; } + +static int +LocateArray( + Tcl_Interp *interp, + Tcl_Obj *name, + Var **varPtrPtr) +{ + Var *arrayPtr, *varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, name, -1) == TCL_ERROR) { + return TCL_ERROR; + } + *varPtrPtr = varPtr; + return TCL_OK; +} /* *---------------------------------------------------------------------- @@ -3122,7 +3140,7 @@ ArrayStartSearchCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *)interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_HashEntry *hPtr; Tcl_Obj *varNameObj; int isNew; @@ -3135,16 +3153,7 @@ ArrayStartSearchCmd( } varNameObj = objv[1]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - varName = TclGetString(varNameObj); - - if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) - == TCL_ERROR) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { return TCL_ERROR; } @@ -3154,6 +3163,7 @@ ArrayStartSearchCmd( * traces. */ + varName = TclGetString(varNameObj); if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3211,7 +3221,7 @@ ArrayAnyMoreCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *)interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj, *searchObj; int gotValue; ArraySearch *searchPtr; @@ -3223,15 +3233,7 @@ ArrayAnyMoreCmd( varNameObj = objv[1]; searchObj = objv[2]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) - == TCL_ERROR) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { return TCL_ERROR; } @@ -3308,7 +3310,7 @@ ArrayNextElementCmd( int objc, Tcl_Obj *const objv[]) { - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj, *searchObj; ArraySearch *searchPtr; @@ -3319,15 +3321,7 @@ ArrayNextElementCmd( varNameObj = objv[1]; searchObj = objv[2]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) - == TCL_ERROR) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { return TCL_ERROR; } @@ -3408,7 +3402,7 @@ ArrayDoneSearchCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *)interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_HashEntry *hPtr; Tcl_Obj *varNameObj, *searchObj; ArraySearch *searchPtr, *prevPtr; @@ -3420,15 +3414,7 @@ ArrayDoneSearchCmd( varNameObj = objv[1]; searchObj = objv[2]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) - == TCL_ERROR) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { return TCL_ERROR; } @@ -3507,7 +3493,7 @@ ArrayExistsCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *)interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *arrayNameObj; int notArray; @@ -3517,15 +3503,7 @@ ArrayExistsCmd( } arrayNameObj = objv[1]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - if (TclCheckArrayTraces(interp, varPtr, arrayPtr, arrayNameObj, -1) - == TCL_ERROR) { + if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr)) { return TCL_ERROR; } @@ -3564,7 +3542,7 @@ ArrayGetCmd( int objc, Tcl_Obj *const objv[]) { - Var *varPtr, *arrayPtr, *varPtr2; + Var *varPtr, *varPtr2; Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj; Tcl_Obj **nameObjPtr, *patternObj; Tcl_HashSearch search; @@ -3585,15 +3563,7 @@ ArrayGetCmd( return TCL_ERROR; } - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) - == TCL_ERROR) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { return TCL_ERROR; } @@ -3742,7 +3712,7 @@ ArrayNamesCmd( "-exact", "-glob", "-regexp", NULL }; enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; - Var *varPtr, *arrayPtr, *varPtr2; + Var *varPtr, *varPtr2; Tcl_Obj *varNameObj, *nameObj, *resultObj, *patternObj; Tcl_HashSearch search; const char *pattern = NULL; @@ -3755,15 +3725,7 @@ ArrayNamesCmd( varNameObj = objv[1]; patternObj = (objc > 2 ? objv[objc-1] : NULL); - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) - == TCL_ERROR) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { return TCL_ERROR; } @@ -3920,22 +3882,14 @@ ArraySetCmd( int objc, Tcl_Obj *const objv[]) { - Var *varPtr, *arrayPtr; + Var *varPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName list"); return TCL_ERROR; } - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, objv[1], NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - if (TclCheckArrayTraces(interp, varPtr, arrayPtr, objv[1], -1) - == TCL_ERROR) { + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) { return TCL_ERROR; } @@ -3967,7 +3921,7 @@ ArraySizeCmd( int objc, Tcl_Obj *const objv[]) { - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj; Tcl_HashSearch search; Var *varPtr2; @@ -3979,15 +3933,7 @@ ArraySizeCmd( } varNameObj = objv[1]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) - == TCL_ERROR) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { return TCL_ERROR; } @@ -4041,7 +3987,7 @@ ArrayStatsCmd( int objc, Tcl_Obj *const objv[]) { - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj; char *stats; @@ -4051,15 +3997,7 @@ ArrayStatsCmd( } varNameObj = objv[1]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) - == TCL_ERROR) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { return TCL_ERROR; } @@ -4114,7 +4052,7 @@ ArrayUnsetCmd( int objc, Tcl_Obj *const objv[]) { - Var *varPtr, *arrayPtr, *varPtr2, *protectedVarPtr; + Var *varPtr, *varPtr2, *protectedVarPtr; Tcl_Obj *varNameObj, *patternObj, *nameObj; Tcl_HashSearch search; const char *pattern; @@ -4134,15 +4072,7 @@ ArrayUnsetCmd( return TCL_ERROR; } - /* - * Locate the array variable - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1) - == TCL_ERROR) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { return TCL_ERROR; } -- cgit v0.12 From 08c1a8dd343c7b9f2f21daf4b03894a3d28e1c47 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 18 Apr 2018 21:03:53 +0000 Subject: cleanup of refactor --- generic/tclVar.c | 19 ++++++------------- 1 file changed, 6 insertions(+), 13 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index a4cd62b..d954f0a 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3142,7 +3142,6 @@ ArrayStartSearchCmd( Interp *iPtr = (Interp *)interp; Var *varPtr; Tcl_HashEntry *hPtr; - Tcl_Obj *varNameObj; int isNew; ArraySearch *searchPtr; const char *varName; @@ -3151,9 +3150,8 @@ ArrayStartSearchCmd( Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - varNameObj = objv[1]; - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) { return TCL_ERROR; } @@ -3163,7 +3161,7 @@ ArrayStartSearchCmd( * traces. */ - varName = TclGetString(varNameObj); + varName = TclGetString(objv[1]); if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3494,16 +3492,14 @@ ArrayExistsCmd( { Interp *iPtr = (Interp *)interp; Var *varPtr; - Tcl_Obj *arrayNameObj; int notArray; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - arrayNameObj = objv[1]; - if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr)) { + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) { return TCL_ERROR; } @@ -3713,7 +3709,7 @@ ArrayNamesCmd( }; enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; Var *varPtr, *varPtr2; - Tcl_Obj *varNameObj, *nameObj, *resultObj, *patternObj; + Tcl_Obj *nameObj, *resultObj, *patternObj; Tcl_HashSearch search; const char *pattern = NULL; int mode = OPT_GLOB; @@ -3722,10 +3718,9 @@ ArrayNamesCmd( Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); return TCL_ERROR; } - varNameObj = objv[1]; patternObj = (objc > 2 ? objv[objc-1] : NULL); - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) { return TCL_ERROR; } @@ -3922,7 +3917,6 @@ ArraySizeCmd( Tcl_Obj *const objv[]) { Var *varPtr; - Tcl_Obj *varNameObj; Tcl_HashSearch search; Var *varPtr2; int size = 0; @@ -3931,9 +3925,8 @@ ArraySizeCmd( Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - varNameObj = objv[1]; - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) { return TCL_ERROR; } -- cgit v0.12 From 61f580bd36bb6b0f50e0d0735c1b72459434c8f5 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 18 Apr 2018 23:31:07 +0000 Subject: Refactor to bring the test for existence of an array variable into LocateArray(). --- generic/tclVar.c | 132 +++++++++++++++++++------------------------------------ 1 file changed, 44 insertions(+), 88 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index d954f0a..f1c8669 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -177,7 +177,7 @@ static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags, int index); static int LocateArray(Tcl_Interp *interp, Tcl_Obj *name, - Var **varPtrPtr); + Var **varPtrPtr, int *isArrayPtr); static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr, int flags); @@ -276,7 +276,8 @@ static int LocateArray( Tcl_Interp *interp, Tcl_Obj *name, - Var **varPtrPtr) + Var **varPtrPtr, + int *isArrayPtr) { Var *arrayPtr, *varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); @@ -284,7 +285,13 @@ LocateArray( if (TclCheckArrayTraces(interp, varPtr, arrayPtr, name, -1) == TCL_ERROR) { return TCL_ERROR; } - *varPtrPtr = varPtr; + if (varPtrPtr) { + *varPtrPtr = varPtr; + } + if (isArrayPtr) { + *isArrayPtr = varPtr && !TclIsVarUndefined(varPtr) + && TclIsVarArray(varPtr); + } return TCL_OK; } @@ -3142,7 +3149,7 @@ ArrayStartSearchCmd( Interp *iPtr = (Interp *)interp; Var *varPtr; Tcl_HashEntry *hPtr; - int isNew; + int isNew, isArray; ArraySearch *searchPtr; const char *varName; @@ -3151,19 +3158,12 @@ ArrayStartSearchCmd( return TCL_ERROR; } - if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) { + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) { return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - varName = TclGetString(objv[1]); - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + if (!isArray) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't an array", varName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); @@ -3221,7 +3221,7 @@ ArrayAnyMoreCmd( Interp *iPtr = (Interp *)interp; Var *varPtr; Tcl_Obj *varNameObj, *searchObj; - int gotValue; + int gotValue, isArray; ArraySearch *searchPtr; if (objc != 3) { @@ -3231,18 +3231,11 @@ ArrayAnyMoreCmd( varNameObj = objv[1]; searchObj = objv[2]; - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + if (!isArray) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", @@ -3311,6 +3304,7 @@ ArrayNextElementCmd( Var *varPtr; Tcl_Obj *varNameObj, *searchObj; ArraySearch *searchPtr; + int isArray; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); @@ -3319,7 +3313,7 @@ ArrayNextElementCmd( varNameObj = objv[1]; searchObj = objv[2]; - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { return TCL_ERROR; } @@ -3328,9 +3322,7 @@ ArrayNextElementCmd( * traces - the variable may actually become an array as an effect of said * traces. */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + if (!isArray) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", @@ -3404,6 +3396,7 @@ ArrayDoneSearchCmd( Tcl_HashEntry *hPtr; Tcl_Obj *varNameObj, *searchObj; ArraySearch *searchPtr, *prevPtr; + int isArray; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); @@ -3412,7 +3405,7 @@ ArrayDoneSearchCmd( varNameObj = objv[1]; searchObj = objv[2]; - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { return TCL_ERROR; } @@ -3422,8 +3415,7 @@ ArrayDoneSearchCmd( * traces. */ - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + if (!isArray) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", @@ -3491,25 +3483,18 @@ ArrayExistsCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *)interp; - Var *varPtr; - int notArray; + int isArray; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) { + if (TCL_ERROR == LocateArray(interp, objv[1], NULL, &isArray)) { return TCL_ERROR; } - /* - * Check whether we've actually got an array variable. - */ - - notArray = ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)); - Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]); + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[isArray]); return TCL_OK; } @@ -3543,7 +3528,7 @@ ArrayGetCmd( Tcl_Obj **nameObjPtr, *patternObj; Tcl_HashSearch search; const char *pattern; - int i, count, result; + int i, count, result, isArray; switch (objc) { case 2: @@ -3559,18 +3544,12 @@ ArrayGetCmd( return TCL_ERROR; } - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. If not an array, it's an empty result. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + /* If not an array, it's an empty result. */ + if (!isArray) { return TCL_OK; } @@ -3712,7 +3691,7 @@ ArrayNamesCmd( Tcl_Obj *nameObj, *resultObj, *patternObj; Tcl_HashSearch search; const char *pattern = NULL; - int mode = OPT_GLOB; + int isArray, mode = OPT_GLOB; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); @@ -3720,7 +3699,7 @@ ArrayNamesCmd( } patternObj = (objc > 2 ? objv[objc-1] : NULL); - if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) { + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) { return TCL_ERROR; } @@ -3733,14 +3712,9 @@ ArrayNamesCmd( return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. If not an array, the result is empty. - */ + /* If not an array, the result is empty. */ - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + if (!isArray) { return TCL_OK; } @@ -3877,14 +3851,12 @@ ArraySetCmd( int objc, Tcl_Obj *const objv[]) { - Var *varPtr; - if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName list"); return TCL_ERROR; } - if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) { + if (TCL_ERROR == LocateArray(interp, objv[1], NULL, NULL)) { return TCL_ERROR; } @@ -3919,24 +3891,20 @@ ArraySizeCmd( Var *varPtr; Tcl_HashSearch search; Var *varPtr2; - int size = 0; + int isArray, size = 0; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) { + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) { return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. We can only iterate over the array if it exists... - */ + /* We can only iterate over the array if it exists... */ - if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + if (isArray) { /* * Must iterate in order to get chance to check for present but * "undefined" entries. @@ -3983,6 +3951,7 @@ ArrayStatsCmd( Var *varPtr; Tcl_Obj *varNameObj; char *stats; + int isArray; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); @@ -3990,18 +3959,11 @@ ArrayStatsCmd( } varNameObj = objv[1]; - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + if (!isArray) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't an array", TclGetString(varNameObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", @@ -4050,6 +4012,7 @@ ArrayUnsetCmd( Tcl_HashSearch search; const char *pattern; const int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ + int isArray; switch (objc) { case 2: @@ -4065,18 +4028,11 @@ ArrayUnsetCmd( return TCL_ERROR; } - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) { + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + if (!isArray) { return TCL_OK; } -- cgit v0.12 From 8d0340e39e077c5577acacc1a175b5c412c8905b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 18 Apr 2018 23:41:48 +0000 Subject: Refactor error reporting when value is not an expected array variable name. --- generic/tclVar.c | 56 ++++++++++++++++++++------------------------------------ 1 file changed, 20 insertions(+), 36 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index f1c8669..92ae183 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -178,6 +178,7 @@ static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags, int index); static int LocateArray(Tcl_Interp *interp, Tcl_Obj *name, Var **varPtrPtr, int *isArrayPtr); +static int NotArrayError(Tcl_Interp *interp, Tcl_Obj *name); static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr, int flags); @@ -294,6 +295,19 @@ LocateArray( } return TCL_OK; } + +static int +NotArrayError( + Tcl_Interp *interp, + Tcl_Obj *name) +{ + const char *nameStr = Tcl_GetString(name); + + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("\"%s\" isn't an array", nameStr)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, NULL); + return TCL_ERROR; +} /* *---------------------------------------------------------------------- @@ -3162,18 +3176,15 @@ ArrayStartSearchCmd( return TCL_ERROR; } - varName = TclGetString(objv[1]); if (!isArray) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", varName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); - return TCL_ERROR; + return NotArrayError(interp, objv[1]); } /* * Make a new array search with a free name. */ + varName = TclGetString(objv[1]); searchPtr = ckalloc(sizeof(ArraySearch)); hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); if (isNew) { @@ -3236,11 +3247,7 @@ ArrayAnyMoreCmd( } if (!isArray) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; + return NotArrayError(interp, varNameObj); } /* @@ -3317,17 +3324,8 @@ ArrayNextElementCmd( return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ if (!isArray) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; + return NotArrayError(interp, varNameObj); } /* @@ -3409,18 +3407,8 @@ ArrayDoneSearchCmd( return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - if (!isArray) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; + return NotArrayError(interp, varNameObj); } /* @@ -3964,11 +3952,7 @@ ArrayStatsCmd( } if (!isArray) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; + return NotArrayError(interp, varNameObj); } stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr); -- cgit v0.12 From df94eecf119611a2fa8de1abb3abe59269be7550 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Apr 2018 01:39:38 +0000 Subject: An [array set] from a dict can only take shortcuts when the dict is "pure", that is, has no string rep. --- generic/tclVar.c | 2 +- tests/var.test | 12 ++++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index e540c49..d4e5339 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3411,7 +3411,7 @@ TclArraySet( * Install the contents of the dictionary or list into the array. */ - if (arrayElemObj->typePtr == &tclDictType) { + if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done; diff --git a/tests/var.test b/tests/var.test index 30e340e..aadeb34 100644 --- a/tests/var.test +++ b/tests/var.test @@ -761,6 +761,18 @@ test var-17.1 {TclArraySet [Bug 1669489]} -setup { } -cleanup { unset -nocomplain ::a ::elements } -result {} +test var-17.2 {TclArraySet Dict shortcut only on pure value} -setup { + unset -nocomplain a d + set d {p 1 p 2} + dict get $d p + set foo 0 +} -body { + trace add variable a write "[list incr [namespace which -variable foo]];#" + array set a $d + set foo +} -cleanup { + unset -nocomplain a d foo +} -result 2 test var-18.1 {array unset and unset traces: Bug 2939073} -setup { set already 0 -- cgit v0.12 From 75bd116527ce94efc1c14c6dc82c526614ed6c7f Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Apr 2018 02:01:29 +0000 Subject: Fold TclArraySet() into its only caller. tclEnv.c no longer calls it --- generic/tclInt.h | 2 - generic/tclVar.c | 311 +++++++++++++++++++++++++------------------------------ 2 files changed, 141 insertions(+), 172 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 371e3fa..4db4576 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2864,8 +2864,6 @@ MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); -MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, - Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj); MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, int strLen, const unsigned char *pattern, diff --git a/generic/tclVar.c b/generic/tclVar.c index 84f2d7b..c4952be 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -2968,175 +2968,6 @@ Tcl_LappendObjCmd( /* *---------------------------------------------------------------------- * - * TclArraySet -- - * - * Set the elements of an array. If there are no elements to set, create - * an empty array. This routine is used by the Tcl_ArrayObjCmd and by the - * TclSetupEnv routine. - * - * Results: - * A standard Tcl result object. - * - * Side effects: - * A variable will be created if one does not already exist. - * Callers must Incr arrayNameObj if they pland to Decr it. - * - *---------------------------------------------------------------------- - */ - -int -TclArraySet( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *arrayNameObj, /* The array name. */ - Tcl_Obj *arrayElemObj) /* The array elements list or dict. If this is - * NULL, create an empty array. */ -{ - Var *varPtr, *arrayPtr; - int result, i; - - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, - /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, - /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - return TCL_ERROR; - } - if (arrayPtr) { - CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(arrayNameObj), NULL); - return TCL_ERROR; - } - - if (arrayElemObj == NULL) { - goto ensureArray; - } - - /* - * Install the contents of the dictionary or list into the array. - */ - - if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) { - Tcl_Obj *keyPtr, *valuePtr; - Tcl_DictSearch search; - int done; - - if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { - return TCL_ERROR; - } - if (done == 0) { - /* - * Empty, so we'll just force the array to be properly existing - * instead. - */ - - goto ensureArray; - } - - /* - * Don't need to look at result of Tcl_DictObjFirst as we've just - * successfully used a dictionary operation on the same object. - */ - - for (Tcl_DictObjFirst(interp, arrayElemObj, &search, - &keyPtr, &valuePtr, &done) ; !done ; - Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) { - /* - * At this point, it would be nice if the key was directly usable - * by the array. This isn't the case though. - */ - - Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, - keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); - - if ((elemVarPtr == NULL) || - (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, - keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) { - Tcl_DictObjDone(&search); - return TCL_ERROR; - } - } - return TCL_OK; - } else { - /* - * Not a dictionary, so assume (and convert to, for backward- - * -compatibility reasons) a list. - */ - - int elemLen; - Tcl_Obj **elemPtrs, *copyListObj; - - result = TclListObjGetElements(interp, arrayElemObj, - &elemLen, &elemPtrs); - if (result != TCL_OK) { - return result; - } - if (elemLen & 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "list must have an even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL); - return TCL_ERROR; - } - if (elemLen == 0) { - goto ensureArray; - } - - /* - * We needn't worry about traces invalidating arrayPtr: should that be - * the case, TclPtrSetVarIdx will return NULL so that we break out of - * the loop and return an error. - */ - - copyListObj = TclListObjCopy(NULL, arrayElemObj); - for (i=0 ; ivalue.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * ArrayStartSearchCmd -- * * This object-based function is invoked to process the "array @@ -3839,6 +3670,11 @@ ArraySetCmd( int objc, Tcl_Obj *const objv[]) { + Tcl_Obj *arrayNameObj; + Tcl_Obj *arrayElemObj; + Var *varPtr, *arrayPtr; + int result, i; + if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName list"); return TCL_ERROR; @@ -3848,7 +3684,142 @@ ArraySetCmd( return TCL_ERROR; } - return TclArraySet(interp, objv[1], objv[2]); + arrayNameObj = objv[1]; + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, + /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + if (arrayPtr) { + CleanupVar(varPtr, arrayPtr); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", + TclGetString(arrayNameObj), NULL); + return TCL_ERROR; + } + + /* + * Install the contents of the dictionary or list into the array. + */ + + arrayElemObj = objv[2]; + if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) { + Tcl_Obj *keyPtr, *valuePtr; + Tcl_DictSearch search; + int done; + + if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { + return TCL_ERROR; + } + if (done == 0) { + /* + * Empty, so we'll just force the array to be properly existing + * instead. + */ + + goto ensureArray; + } + + /* + * Don't need to look at result of Tcl_DictObjFirst as we've just + * successfully used a dictionary operation on the same object. + */ + + for (Tcl_DictObjFirst(interp, arrayElemObj, &search, + &keyPtr, &valuePtr, &done) ; !done ; + Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) { + /* + * At this point, it would be nice if the key was directly usable + * by the array. This isn't the case though. + */ + + Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, + keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); + + if ((elemVarPtr == NULL) || + (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, + keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) { + Tcl_DictObjDone(&search); + return TCL_ERROR; + } + } + return TCL_OK; + } else { + /* + * Not a dictionary, so assume (and convert to, for backward- + * -compatibility reasons) a list. + */ + + int elemLen; + Tcl_Obj **elemPtrs, *copyListObj; + + result = TclListObjGetElements(interp, arrayElemObj, + &elemLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (elemLen & 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "list must have an even number of elements", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL); + return TCL_ERROR; + } + if (elemLen == 0) { + goto ensureArray; + } + + /* + * We needn't worry about traces invalidating arrayPtr: should that be + * the case, TclPtrSetVarIdx will return NULL so that we break out of + * the loop and return an error. + */ + + copyListObj = TclListObjCopy(NULL, arrayElemObj); + for (i=0 ; ivalue.tablePtr = ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); + return TCL_OK; } /* -- cgit v0.12