summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclExecute.c17
-rw-r--r--generic/tclInt.h2
-rw-r--r--generic/tclTrace.c41
-rw-r--r--generic/tclVar.c180
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;
}
/*
generated by cgit v0.12 at 2024-11-16 15:27:17 (GMT)