Index: generic/nsf.c =================================================================== diff -u -r7ca41c65294c91734558ea49037af2e5ff362e8a -rdadf28efd0707ae40076f49837e6b45ad5b2a989 --- generic/nsf.c (.../nsf.c) (revision 7ca41c65294c91734558ea49037af2e5ff362e8a) +++ generic/nsf.c (.../nsf.c) (revision dadf28efd0707ae40076f49837e6b45ad5b2a989) @@ -403,7 +403,7 @@ nonnull(1) returns_nonnull; /* misc prototypes */ -static int SetInstVar(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *nameObj, Tcl_Obj *valueObj) +static int SetInstVar(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *nameObj, Tcl_Obj *valueObj, unsigned int flags) nonnull(1) nonnull(2) nonnull(3); static int ListDefinedMethods(Tcl_Interp *interp, NsfObject *object, const char *pattern, @@ -515,7 +515,7 @@ Tcl_InterpState state; NsfRuntimeState *rst; int result, prevDoProfile; - unsigned int prevPreventRecursionFlags; + unsigned int prevPreventRecursionFlags = 0u; nonnull_assert(interp != NULL); nonnull_assert(dsPtr != NULL); @@ -9053,11 +9053,13 @@ nonnull_assert(cmdListPtr != NULL); if (cmd != NULL) { - for (; likely(cmdListPtr != NULL); cmdListPtr = cmdListPtr->nextPtr) { + do { if (cmdListPtr->cmdPtr == cmd) { return cmdListPtr->nextPtr; } - } + cmdListPtr = cmdListPtr->nextPtr; + } while likely(cmdListPtr != NULL); + return NULL; } return cmdListPtr; @@ -13339,7 +13341,7 @@ * Resetting mixin and filter stacks */ - if (unlikely((flags & NSF_CSC_MIXIN_STACK_PUSHED) && object->mixinStack) != 0u) { + if (unlikely((flags & NSF_CSC_MIXIN_STACK_PUSHED) && object->mixinStack != NULL) != 0u) { /* fprintf(stderr, "MixinStackPop %s.%s %p %s\n", ObjectName(object), methodName, object->mixinStack, msg);*/ MixinStackPop(object); @@ -17482,7 +17484,7 @@ } if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER) { methodName = MethodName(cscPtr->filterStackEntry->calledProc); - } else if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_MIXIN && object->mixinStack) { + } else if (cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_MIXIN && object->mixinStack != NULL) { methodName = Tcl_GetCommandName(interp, cscPtr->cmdPtr); } else { return NULL; @@ -17554,7 +17556,7 @@ } if ((objflags & NSF_FILTER_ORDER_VALID) != 0u - && object->filterStack + && (object->filterStack != NULL) && object->filterStack->currentCmdPtr) { *cmdPtr = FilterSearchProc(interp, object, currentCmdPtr, clPtr); @@ -18719,11 +18721,11 @@ #endif CleanupDestroyObject(interp, object, 0); - while (object->mixinStack) { + while (object->mixinStack != NULL) { MixinStackPop(object); } - while (object->filterStack) { + while (object->filterStack != NULL) { FilterStackPop(object); } @@ -20045,30 +20047,67 @@ *---------------------------------------------------------------------- */ static int -SetInstVar(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *nameObj, Tcl_Obj *valueObj) { +SetInstVar(Tcl_Interp *interp, NsfObject *object, Tcl_Obj *nameObj, Tcl_Obj *valueObj, unsigned int flags) { CallFrame frame, *framePtr = &frame; Tcl_Obj *resultObj; - unsigned int flags; nonnull_assert(interp != NULL); nonnull_assert(object != NULL); nonnull_assert(nameObj != NULL); - flags = (object->nsPtr) ? TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY : TCL_LEAVE_ERR_MSG; Nsf_PushFrameObj(interp, object, framePtr); - if (likely(valueObj == NULL)) { - resultObj = Tcl_ObjGetVar2(interp, nameObj, NULL, flags); + if ((flags & NSF_VAR_TRIGGER_TRACE) != 0u) { + int tclVarFlags; + /* + * The command should trigger traces, use therefore the high-level Tcl_Obj* + * interface. + */ + + tclVarFlags = (object->nsPtr) ? TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY : TCL_LEAVE_ERR_MSG; + if (likely(valueObj == NULL)) { + resultObj = Tcl_ObjGetVar2(interp, nameObj, NULL, tclVarFlags); + } else { + resultObj = Tcl_ObjSetVar2(interp, nameObj, NULL, valueObj, tclVarFlags); + } } else { - /*fprintf(stderr, "setvar in obj %s: name %s = %s\n", ObjectName(object), ObjStr(nameObj), ObjStr(value));*/ - resultObj = Tcl_ObjSetVar2(interp, nameObj, NULL, valueObj, flags); + /* + * The command should not trigger traces, use the low-level TclLookupVar() + * interface. + */ + Var *arrayPtr, *varPtr; + + if (likely(valueObj == NULL)) { + + varPtr = TclLookupVar(interp, ObjStr(nameObj), NULL, TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1, "access", + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + if (likely(varPtr != NULL)) { + resultObj = varPtr->value.objPtr; + } else { + resultObj = NULL; + } + + } else { + Tcl_Obj *oldValuePtr; + + varPtr = TclLookupVar(interp, ObjStr(nameObj), NULL, TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1, "access", + /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); + oldValuePtr = varPtr->value.objPtr; + INCR_REF_COUNT(valueObj); + varPtr->value.objPtr = valueObj; + if (oldValuePtr != NULL) { + DECR_REF_COUNT(oldValuePtr); + } + resultObj = valueObj; + } } Nsf_PopFrameObj(interp, framePtr); if (likely(resultObj != NULL)) { Tcl_SetObjResult(interp, resultObj); return TCL_OK; } + return TCL_ERROR; } @@ -20216,7 +20255,7 @@ &flags, &checkedData, &outObjPtr); if (likely(result == TCL_OK)) { - result = SetInstVar(interp, object, objv[0], outObjPtr); + result = SetInstVar(interp, object, objv[0], outObjPtr, NSF_VAR_TRIGGER_TRACE); } if ((flags & NSF_PC_MUST_DECR) != 0u) { @@ -20225,7 +20264,7 @@ return result; } else { - return SetInstVar(interp, object, objv[0], objc == 2 ? objv[1] : NULL); + return SetInstVar(interp, object, objv[0], objc == 2 ? objv[1] : NULL, NSF_VAR_TRIGGER_TRACE); } } @@ -27302,16 +27341,17 @@ /* cmd var::get NsfVarGetCmd { - {-argName "-array" -required 0 -nrargs 0} + {-argName "-array" -required 0 -nrargs 0 -type switch} + {-argName "-notrace" -required 0 -nrargs 0 -type switch} {-argName "object" -required 1 -type object} {-argName "varName" -required 1 -type tclobj} } */ static int -NsfVarGetCmd(Tcl_Interp *interp, int withArray, +NsfVarGetCmd(Tcl_Interp *interp, int withArray, int withNotrace, NsfObject *object, Tcl_Obj *varName) { - return NsfVarSetCmd(interp, withArray, object, varName, NULL); + return NsfVarSetCmd(interp, withArray, withNotrace, object, varName, NULL); } /* @@ -27366,14 +27406,15 @@ /* cmd var::set NsfVarSetCmd { - {-argName "-array" -required 0 -nrargs 0} + {-argName "-array" -required 0 -nrargs 0 -type switch} + {-argName "-notrace" -required 0 -nrargs 0 -type switch} {-argName "object" -required 1 -type object} {-argName "varName" -required 1 -type tclobj} {-argName "value" -required 0 -type tclobj} } */ static int -NsfVarSetCmd(Tcl_Interp *interp, int withArray, +NsfVarSetCmd(Tcl_Interp *interp, int withArray, int withNotrace, NsfObject *object, Tcl_Obj *varName, Tcl_Obj *valueObj) { nonnull_assert(interp != NULL); @@ -27383,10 +27424,11 @@ if (unlikely(CheckVarName(interp, ObjStr(varName)) != TCL_OK)) { return TCL_ERROR; } + if (withArray != 0) { return SetInstArray(interp, object, varName, valueObj); } else { - return SetInstVar(interp, object, varName, valueObj); + return SetInstVar(interp, object, varName, valueObj, withNotrace ? 0 : NSF_VAR_TRIGGER_TRACE); } } @@ -28563,7 +28605,7 @@ nonnull_assert(interp != NULL); nonnull_assert(object != NULL); - if (object->filterStack || object->mixinStack) { + if ((object->filterStack != NULL) || (object->mixinStack != NULL)) { CallStackUseActiveFrame(interp, &ctx); } @@ -28862,7 +28904,7 @@ i = 1; } - if (object->filterStack || object->mixinStack) { + if ((object->filterStack != NULL) || (object->mixinStack != NULL)) { CallStackUseActiveFrame(interp, &ctx); } Index: generic/nsfAPI.decls =================================================================== diff -u -r183cd0a9a3d2a37133ac51bb86952e1b522dbf6f -rdadf28efd0707ae40076f49837e6b45ad5b2a989 --- generic/nsfAPI.decls (.../nsfAPI.decls) (revision 183cd0a9a3d2a37133ac51bb86952e1b522dbf6f) +++ generic/nsfAPI.decls (.../nsfAPI.decls) (revision dadf28efd0707ae40076f49837e6b45ad5b2a989) @@ -310,6 +310,7 @@ } {-nxdoc 1} cmd "var::get" NsfVarGetCmd { {-argName "-array" -required 0 -nrargs 0 -type switch} + {-argName "-notrace" -required 0 -nrargs 0 -type switch} {-argName "object" -required 1 -type object} {-argName "varName" -required 1 -type tclobj} } {-nxdoc 1} @@ -320,6 +321,7 @@ } {-nxdoc 1} cmd "var::set" NsfVarSetCmd { {-argName "-array" -required 0 -nrargs 0 -type switch} + {-argName "-notrace" -required 0 -nrargs 0 -type switch} {-argName "object" -required 1 -type object} {-argName "varName" -required 1 -type tclobj} {-argName "value" -required 0 -type tclobj} Index: generic/nsfAPI.h =================================================================== diff -u -r183cd0a9a3d2a37133ac51bb86952e1b522dbf6f -rdadf28efd0707ae40076f49837e6b45ad5b2a989 --- generic/nsfAPI.h (.../nsfAPI.h) (revision 183cd0a9a3d2a37133ac51bb86952e1b522dbf6f) +++ generic/nsfAPI.h (.../nsfAPI.h) (revision dadf28efd0707ae40076f49837e6b45ad5b2a989) @@ -662,12 +662,12 @@ NSF_nonnull(1); static int NsfVarExistsCmd(Tcl_Interp *interp, int withArray, NsfObject *object, const char *varName) NSF_nonnull(1) NSF_nonnull(3) NSF_nonnull(4); -static int NsfVarGetCmd(Tcl_Interp *interp, int withArray, NsfObject *object, Tcl_Obj *varName) - NSF_nonnull(1) NSF_nonnull(3) NSF_nonnull(4); +static int NsfVarGetCmd(Tcl_Interp *interp, int withArray, int withNotrace, NsfObject *object, Tcl_Obj *varName) + NSF_nonnull(1) NSF_nonnull(4) NSF_nonnull(5); static int NsfVarImportCmd(Tcl_Interp *interp, NsfObject *object, int nobjc, Tcl_Obj *CONST* nobjv) NSF_nonnull(1) NSF_nonnull(2); -static int NsfVarSetCmd(Tcl_Interp *interp, int withArray, NsfObject *object, Tcl_Obj *varName, Tcl_Obj *value) - NSF_nonnull(1) NSF_nonnull(3) NSF_nonnull(4); +static int NsfVarSetCmd(Tcl_Interp *interp, int withArray, int withNotrace, NsfObject *object, Tcl_Obj *varName, Tcl_Obj *value) + NSF_nonnull(1) NSF_nonnull(4) NSF_nonnull(5); static int NsfVarUnsetCmd(Tcl_Interp *interp, int withNocomplain, NsfObject *object, Tcl_Obj *varName) NSF_nonnull(1) NSF_nonnull(3) NSF_nonnull(4); static int NsfOAutonameMethod(Tcl_Interp *interp, NsfObject *obj, int withInstance, int withReset, Tcl_Obj *name) @@ -2442,11 +2442,12 @@ method_definitions[NsfVarGetCmdIdx].nrParameters, 0, NSF_ARGPARSE_BUILTIN, &pc) == TCL_OK)) { int withArray = (int )PTR2INT(pc.clientData[0]); - NsfObject *object = (NsfObject *)pc.clientData[1]; - Tcl_Obj *varName = (Tcl_Obj *)pc.clientData[2]; + int withNotrace = (int )PTR2INT(pc.clientData[1]); + NsfObject *object = (NsfObject *)pc.clientData[2]; + Tcl_Obj *varName = (Tcl_Obj *)pc.clientData[3]; assert(pc.status == 0); - return NsfVarGetCmd(interp, withArray, object, varName); + return NsfVarGetCmd(interp, withArray, withNotrace, object, varName); } else { @@ -2484,12 +2485,13 @@ method_definitions[NsfVarSetCmdIdx].nrParameters, 0, NSF_ARGPARSE_BUILTIN, &pc) == TCL_OK)) { int withArray = (int )PTR2INT(pc.clientData[0]); - NsfObject *object = (NsfObject *)pc.clientData[1]; - Tcl_Obj *varName = (Tcl_Obj *)pc.clientData[2]; - Tcl_Obj *value = (Tcl_Obj *)pc.clientData[3]; + int withNotrace = (int )PTR2INT(pc.clientData[1]); + NsfObject *object = (NsfObject *)pc.clientData[2]; + Tcl_Obj *varName = (Tcl_Obj *)pc.clientData[3]; + Tcl_Obj *value = (Tcl_Obj *)pc.clientData[4]; assert(pc.status == 0); - return NsfVarSetCmd(interp, withArray, object, varName, value); + return NsfVarSetCmd(interp, withArray, withNotrace, object, varName, value); } else { @@ -3795,17 +3797,19 @@ {"object", NSF_ARG_REQUIRED, 1, Nsf_ConvertTo_Object, NULL,NULL,"object",NULL,NULL,NULL,NULL,NULL}, {"varName", NSF_ARG_REQUIRED, 1, Nsf_ConvertTo_String, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}} }, -{"::nsf::var::get", NsfVarGetCmdStub, 3, { +{"::nsf::var::get", NsfVarGetCmdStub, 4, { {"-array", 0, 0, Nsf_ConvertTo_Boolean, NULL,NULL,"switch",NULL,NULL,NULL,NULL,NULL}, + {"-notrace", 0, 0, Nsf_ConvertTo_Boolean, NULL,NULL,"switch",NULL,NULL,NULL,NULL,NULL}, {"object", NSF_ARG_REQUIRED, 1, Nsf_ConvertTo_Object, NULL,NULL,"object",NULL,NULL,NULL,NULL,NULL}, {"varName", NSF_ARG_REQUIRED, 1, Nsf_ConvertTo_Tclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}} }, {"::nsf::var::import", NsfVarImportCmdStub, 2, { {"object", NSF_ARG_REQUIRED, 1, Nsf_ConvertTo_Object, NULL,NULL,"object",NULL,NULL,NULL,NULL,NULL}, {"args", 0, 1, ConvertToNothing, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}} }, -{"::nsf::var::set", NsfVarSetCmdStub, 4, { +{"::nsf::var::set", NsfVarSetCmdStub, 5, { {"-array", 0, 0, Nsf_ConvertTo_Boolean, NULL,NULL,"switch",NULL,NULL,NULL,NULL,NULL}, + {"-notrace", 0, 0, Nsf_ConvertTo_Boolean, NULL,NULL,"switch",NULL,NULL,NULL,NULL,NULL}, {"object", NSF_ARG_REQUIRED, 1, Nsf_ConvertTo_Object, NULL,NULL,"object",NULL,NULL,NULL,NULL,NULL}, {"varName", NSF_ARG_REQUIRED, 1, Nsf_ConvertTo_Tclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, {"value", 0, 1, Nsf_ConvertTo_Tclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}} Index: generic/nsfCmdPtr.c =================================================================== diff -u -r183cd0a9a3d2a37133ac51bb86952e1b522dbf6f -rdadf28efd0707ae40076f49837e6b45ad5b2a989 --- generic/nsfCmdPtr.c (.../nsfCmdPtr.c) (revision 183cd0a9a3d2a37133ac51bb86952e1b522dbf6f) +++ generic/nsfCmdPtr.c (.../nsfCmdPtr.c) (revision dadf28efd0707ae40076f49837e6b45ad5b2a989) @@ -37,8 +37,10 @@ */ static NSF_INLINE NsfObject* NsfGetObjectFromCmdPtr(Tcl_Command cmd) nonnull(1); -static NSF_INLINE NsfClass* NsfGetClassFromCmdPtr(Tcl_Command cmd) nonnull(1); static NSF_INLINE ClientData NsfGetClientDataFromCmdPtr(Tcl_Command cmd) nonnull(1); +#ifdef NSF_C +static NSF_INLINE NsfClass* NsfGetClassFromCmdPtr(Tcl_Command cmd) nonnull(1); +#endif static NSF_INLINE ClientData NsfGetClientDataFromCmdPtr(Tcl_Command cmd) { @@ -59,6 +61,7 @@ } } +#ifdef NSF_C static NSF_INLINE NsfClass* NsfGetClassFromCmdPtr(Tcl_Command cmd) { ClientData cd; @@ -73,6 +76,7 @@ return NULL; } } +#endif static NSF_INLINE NsfObject* NsfGetObjectFromCmdPtr(Tcl_Command cmd) { Index: library/nx/nx.tcl =================================================================== diff -u -rccca1a502b5c9b77ecfd8ce16c59d77b14f0ccfd -rdadf28efd0707ae40076f49837e6b45ad5b2a989 --- library/nx/nx.tcl (.../nx.tcl) (revision ccca1a502b5c9b77ecfd8ce16c59d77b14f0ccfd) +++ library/nx/nx.tcl (.../nx.tcl) (revision dadf28efd0707ae40076f49837e6b45ad5b2a989) @@ -38,7 +38,7 @@ # SOFTWARE. # package require nsf -package provide nx 2.0.0 +package provide nx 2.1.0 namespace eval ::nx { @@ -1117,7 +1117,7 @@ } set slotObj [::nx::slotObj -container $container $target $slotname] - #puts stderr "[self] *** [list $class create $slotObj] {*}$opts <$initblock>" + #puts stderr "SLOTCREATE [self] *** [list $class create $slotObj] {*}$opts <$initblock>" set r [$class create $slotObj {*}$opts $initblock] #puts stderr "*** returned $r" return $r @@ -1267,6 +1267,7 @@ {positional} {elementtype} {multiplicity 1..1} + {trace} } # TODO: check, if substdefault/default could work with e.g. alias; otherwise, move substdefault down @@ -1817,9 +1818,7 @@ {accessor public} {type} {settername} - valuecmd - defaultcmd - valuechangedcmd + {trace none} } ::nx::VariableSlot public method setCheckedInstVar {-nocomplain:switch object value} { @@ -1840,8 +1839,13 @@ } ::nx::VariableSlot protected method setterRedefinedOptions {} { - if {[:info lookup method value=set] ne "::nsf::classes::nx::VariableSlot::value=set"} { - # In case the "set" method was provided on the slot, ask nsf to call it directly + # + # In the :trace = "set" case, the slot will be set via the trace + # triggered from the direct assingment. Otherwise, when the + # "value=set" method is provided, tell nsf ot call it (e.g. in + # configure). + # + if {${:trace} ne "set" && [:info lookup method value=set] ne "::nsf::classes::nx::VariableSlot::value=set"} { return [list slot=[::nsf::self] slotset] } if {[:info lookup method value=get] ne "::nsf::classes::nx::VariableSlot::value=get"} { @@ -2063,38 +2067,44 @@ # creation time of instances, or immediately for per-object slots. # set __initblock "" - set trace {::nsf::directdispatch [::nsf::self] -frame object ::trace} + set traceCmd {::nsf::directdispatch [::nsf::self] -frame object ::trace} + #puts stderr "instance variable trace has value <${:trace}>" + if {"default" in ${:trace}} { + if {"get" in ${:trace}} { + return -code error \ + "'-trace default' and '-trace get' can't be used together" + } + } # There might be already default values registered on the - # class. If so, defaultcmd is ignored. + # class. If so, the default trace is ignored. if {[info exists :default]} { - if {[info exists :defaultcmd]} { - return -code error \ - "defaultcmd can't be used together with default value" + if {"default" in ${:trace}} { + return -code error \ + "'-trace default' can't be used together with default value" } - if {[info exists :valuecmd]} { - return -code error \ - "valuecmd can't be used together with default value" + if {"get" in ${:trace}} { + return -code error \ + "'trace get' can't be used together with default value" } - } elseif [info exists :defaultcmd] { - if {[info exists :valuecmd]} { - return -code error \ - "valuecmd can't be used together with defaultcmd" - } + } + if {"default" in ${:trace}} { + #puts stderr "DEFAULTCMD [self] trace=${:trace}" append __initblock "::nsf::directdispatch [::nsf::self] -frame object :removeTraces \[::nsf::self\] read\n" - append __initblock "$trace add variable [list ${:name}] read \ - \[list [::nsf::self] __default_from_cmd \[::nsf::self\] [list [set :defaultcmd]]\]\n" - - } elseif [info exists :valuecmd] { + append __initblock "$traceCmd add variable [list ${:name}] read \ + \[list [::nsf::self] __trace_default \[::nsf::self\]\]\n" + } + if {"get" in ${:trace}} { + #puts stderr "VALUECMD [self] trace=${:trace}" append __initblock "::nsf::directdispatch [::nsf::self] -frame object :removeTraces \[::nsf::self\] read\n" - append __initblock "$trace add variable [list ${:name}] read \ - \[list [::nsf::self] __value_from_cmd \[::nsf::self\] [list [set :valuecmd]]\]\n" + append __initblock "$traceCmd add variable [list ${:name}] read \ + \[list [::nsf::self] __trace_get \[::nsf::self\]\]\n" } - - if {[info exists :valuechangedcmd]} { + if {"set" in ${:trace}} { + #puts stderr "VALUECHANGED [self] trace=${:trace}" append __initblock "::nsf::directdispatch [::nsf::self] -frame object :removeTraces \[::nsf::self\] write\n" - append __initblock "$trace add variable [list ${:name}] write \ - \[list [::nsf::self] __value_changed_cmd \[::nsf::self\] [list [set :valuechangedcmd]]\]" + append __initblock "$traceCmd add variable [list ${:name}] write \ + \[list [::nsf::self] __trace_set \[::nsf::self\]\]\n" } if {$__initblock ne ""} { @@ -2115,14 +2125,30 @@ ::trace remove variable $var $op [list [::nsf::self] [::nsf::current method] $obj $cmd] ::nsf::var::set $obj $var [$obj eval $cmd] } - ::nx::VariableSlot method __value_from_cmd {obj cmd var sub op} { - #puts stderr "GETVAR [::nsf::current method] obj=$obj cmd=$cmd, var=$var, op=$op" - ::nsf::var::set $obj [string trimleft $var :] [$obj eval $cmd] + # TODO: remove me + # ::nx::VariableSlot method __value_from_cmd {obj cmd var sub op} { + # #puts stderr "GETVAR [::nsf::current method] obj=$obj cmd=$cmd, var=$var, op=$op" + # ::nsf::var::set $obj [string trimleft $var :] [$obj eval $cmd] + # } + #::nx::VariableSlot method __value_changed_cmd {obj method var sub op} { + # #puts "valuechanged obj=$obj cmd=$cmd, var=$var, op=$op" + # eval $cmd + #} + ::nx::VariableSlot method __trace_default {obj var sub op} { + #puts stderr "trace_default call obj=$obj var=$var, sub=<$sub> op=$op" + ::nsf::directdispatch $obj -frame object \ + ::trace remove variable $var $op [list [::nsf::self] [::nsf::current method] $obj] + ::nsf::var::set $obj $var [:value=default $obj $var] } - ::nx::VariableSlot method __value_changed_cmd {obj cmd var sub op} { - #puts "valuechanged obj=$obj cmd=$cmd, var=$var, op=$op" - eval $cmd + ::nx::VariableSlot method __trace_get {obj var sub op} { + #puts stderr "trace_get call obj=$obj var=$var, sub=<$sub> op=$op" + :value=get $obj [string trimleft $var :] } + ::nx::VariableSlot method __trace_set {obj var sub op} { + #puts stderr "trace_set call obj=$obj var=$var, sub=<$sub> op=$op" + set var [string trimleft $var :] + :value=set $obj $var [::nsf::var::get $obj $var] + } ###################################################################### # Implementation of (incremental) forwarder operations for @@ -2167,11 +2193,12 @@ nx::Object method "object variable" { {-accessor "none"} - {-incremental:switch} {-class ""} {-configurable:boolean false} + {-incremental:switch} {-initblock ""} {-nocomplain:switch} + {-trace} spec:parameter defaultValue:optional } { @@ -2195,10 +2222,13 @@ set configurable $opts(-configurable) } - #if {$initblock eq "" && $accessor eq "none" && !$incremental} - if {$initblock eq "" && !$configurable && $accessor eq "none" && !$incremental} { + if {![info exists trace] && [info exists :trace] && ${:trace} ne "none"} { + set trace ${:trace} + } + if {$initblock eq "" && !$configurable && !$incremental + && $accessor eq "none" && ![info exists trace]} { # - # we can build a slot-less variable + # Slot-less variable # #puts "... slotless variable $spec" @@ -2235,13 +2265,15 @@ # # create variable via a slot object # + set defaultopts [list -accessor $accessor] + if {[info exists trace]} {lappend defaultopts -trace $trace} set slot [::nx::MetaSlot createFromParameterSpec [self] \ -per-object \ -class $class \ -initblock $initblock \ -incremental=$incremental \ -private=[expr {$accessor eq "private"}] \ - -defaultopts [list -accessor $accessor] \ + -defaultopts $defaultopts \ $spec \ {*}[expr {[info exists defaultValue] ? [list $defaultValue] : ""}]] @@ -2265,18 +2297,20 @@ Object method "object property" { {-accessor ""} + {-class ""} {-configurable:boolean true} {-incremental:switch} - {-class ""} {-nocomplain:switch} + {-trace} spec:parameter {initblock ""} } { - if {${accessor} eq ""} { + if {$accessor eq ""} { set accessor [::nsf::dispatch [self] __default_accessor] #puts stderr "OBJECT [self] got default accessor ${accessor}" } + set traceSpec [expr {[info exists trace] ? [list -trace $trace] : ""}] set r [[self] object variable \ -accessor $accessor \ @@ -2285,25 +2319,36 @@ -initblock $initblock \ -configurable $configurable \ -nocomplain=$nocomplain \ + {*}$traceSpec \ {*}$spec] return $r } nx::Class method variable { {-accessor "none"} - {-incremental:switch} {-class ""} {-configurable:boolean false} + {-incremental:switch} {-initblock ""} + {-trace} spec:parameter defaultValue:optional } { + set defaultopts [list -accessor $accessor -configurable $configurable] + if {[info exists trace]} { + foreach t $trace { + if {$t ni {none get set default}} { + return -code error "invalid value '$t' for trace: '$trace'" + } + } + lappend defaultopts -trace $trace + } set slot [::nx::MetaSlot createFromParameterSpec [::nsf::self] \ -class $class \ -initblock $initblock \ -incremental=$incremental \ -private=[expr {$accessor eq "private"}] \ - -defaultopts [list -accessor $accessor -configurable $configurable] \ + -defaultopts $defaultopts \ $spec \ {*}[expr {[info exists defaultValue] ? [list $defaultValue] : ""}]] if {[$slot eval {info exists :settername}]} { @@ -2317,23 +2362,25 @@ nx::Class method property { {-accessor ""} + {-class ""} {-configurable:boolean true} {-incremental:switch} - {-class ""} + {-trace} spec:parameter {initblock ""} } { - - if {${accessor} eq ""} { + if {$accessor eq ""} { set accessor [::nsf::dispatch [self] __default_accessor] - #puts stderr "CLASS [self] got default accessor ${accessor}" } + set traceSpec [expr {[info exists trace] ? [list -trace $trace] : ""}] + set r [[self] ::nsf::classes::nx::Class::variable \ -accessor $accessor \ -incremental=$incremental \ -class $class \ -configurable $configurable \ -initblock $initblock \ + {*}$traceSpec \ {*}$spec] return $r } Index: library/nx/pkgIndex.tcl =================================================================== diff -u -r96a1e6b90fb931aa05ae49d96f328bf74e552d65 -rdadf28efd0707ae40076f49837e6b45ad5b2a989 --- library/nx/pkgIndex.tcl (.../pkgIndex.tcl) (revision 96a1e6b90fb931aa05ae49d96f328bf74e552d65) +++ library/nx/pkgIndex.tcl (.../pkgIndex.tcl) (revision dadf28efd0707ae40076f49837e6b45ad5b2a989) @@ -1,3 +1,3 @@ -package ifneeded nx 2.0.0 [list source [file join $dir nx.tcl]] +package ifneeded nx 2.1.0 [list source [file join $dir nx.tcl]] package ifneeded nx::class-method 1.0 [list source [file join $dir class-method.tcl]] package ifneeded nx::plain-object-method 1.0 [list source [file join $dir plain-object-method.tcl]] Index: library/xotcl/tests/slottest.xotcl =================================================================== diff -u -r6a55e4e48e5431b7b76916a8dbfb550b4cdc6edb -rdadf28efd0707ae40076f49837e6b45ad5b2a989 --- library/xotcl/tests/slottest.xotcl (.../slottest.xotcl) (revision 6a55e4e48e5431b7b76916a8dbfb550b4cdc6edb) +++ library/xotcl/tests/slottest.xotcl (.../slottest.xotcl) (revision dadf28efd0707ae40076f49837e6b45ad5b2a989) @@ -33,9 +33,18 @@ proc T2 {var sub op} {c1 set $var t2} Class C -slots { - Attribute create x -defaultcmd {set x 1} - Attribute create y -defaultcmd {incr ::hu} - Attribute create z -defaultcmd {my trace add variable z read T1} + #Attribute create x -defaultcmd {set x 1} + #Attribute create y -defaultcmd {incr ::hu} + #Attribute create z -defaultcmd {my trace add variable z read T1} + + Attribute create x -trace default + x object method value=default {obj property} { return 1 } + + Attribute create y -trace default + y object method value=default {obj property} { incr ::hu } + + Attribute create z -trace default + z object method value=default {obj property} { $obj trace add variable z read T1 } } C create c1 @@ -60,8 +69,14 @@ } Class D -slots { - Attribute create x -defaultcmd {set x 2} - Attribute create z -defaultcmd {my trace add variable z read T2} + # Attribute create x -defaultcmd {set x 2} + # Attribute create z -defaultcmd {my trace add variable z read T2} + Attribute create x -trace default + x object method value=default {obj property} { return 2 } + + Attribute create z -trace default + z object method value=default {obj property} { $obj trace add variable z read T2 } + ?? self ::D ?? {namespace current} ::D::slot } -superclass C @@ -499,7 +514,9 @@ nx::test case defaultcmd set ::hu 0 Class C -slots { - Attribute create x -defaultcmd {incr ::hu; set x 101} + # Attribute create x -defaultcmd {incr ::hu; set x 101} + Attribute create x -trace default + x object method value=default {obj property} { incr ::hu; return 101 } } C c1 ? {c1 info vars} "__initcmd" @@ -583,7 +600,11 @@ # test case (bug) posted by Neil Hampton # -Class Fred -slots { Attribute create a -defaultcmd { set _ 4 } } +Class Fred -slots { + #Attribute create a -defaultcmd { set _ 4 } + Attribute create a -trace default + a object method value=default {obj property} { return 4 } +} ? {Fred x} ::x ? {x a 4} 4 x move y @@ -689,118 +710,7 @@ ? {::nsf::method::property o obar debug} 1 } - - -exit - -###################################################################### # -# Obsolete content -# -###################################################################### -#puts [Person array get __defaults] -#puts [Person serialize] -puts [Serializer all] -eval [Serializer all] - -? {p2 salary} 1009 -? {catch {p2 append salary b}} 1 -? {p2 salary} 1009 -#p2 projects add ::o1 -exit -p1 set x 0 -t {p1 set x} "get instvar value via set" -t {p1 set x 1} "set instvar value via set" - - - -Object o1 -proc f {x} {return $x} -o1 forward myf -earlybinding f -? {o1 myf abc} abc - -rename f "" -proc f {x} {return 11} -? {o1 myf abc} 11 - -Object o2 -o2 proc f {x} {expr {$x*2}} -o1 forward myf -earlybinding o2 f - -? {o1 myf 100} 200 - -o1 set x 42 -o1 forward x -earlybinding ::nsf::var::set %self %proc -? [list o1 x] 42 -? [list o1 x 41] 41 -? {o1 x} "get parametercmd via forward (earlybinding)" -? {o1 x 41} "set parametercmd via forward (earlybinding)" - -#obj forward Mixin -default {getter setter} mixin %1 %self -o1 forward z -default {getter setter} %self - -o1 forward myfset -objscope set -o1 myfset y 102 -? {o1 myfset y} 102 - -? {o1 myfset y} "get instvar value via forward" -? {o1 myfset y 122} "set instvar value via forward" - -o1 forward myfdset -earlybinding -objscope set -o1 myfdset y 103 -? {o1 myfdset y} 103 - -? {o1 myfdset y} "get instvar value via forward -earlybinding" -? {o1 myfdset y 123} "set instvar value via forward -earlybinding" - -::nsf::method::alias o1 myset -frame object ::set -o1 myset x 101 -? {o1 myset x} 101 - -? {o1 myset x} "get instvar value via set alias" -? {o1 myset x 123} "set instvar value via set alias" - - -? {p1 age} "slot read" -Class P -parameter {age {s -setter sets}} -P instproc sets {var value} { - my set $var $value -} -P create p2 -age 345 -s 567 - -? {p2 age} "parametercmd read" -? {::nsf::var::set p2 age} "via setinstvar" -? {p2 s} "parameter read with setter" - - - - -Slot create Project::fullbudget \ - -defaultcmd {$obj set __x 100} \ - -valuechangedcmd { - puts "budget is now [$obj set fullbudget]" - $obj set __x [$obj set fullbudget] - } - -Slot create Project::currentbudget -valuecmd {$obj incr __x -1} - -Person p2 -name gustaf -Person p3 -name frido -Article a1 -title "My life as a saint" -date "1.1.2006" -publishes new -written_by p1 -has_published a1 -set p [Project new -name icamp -manager p2 -member add p1 -member add p3] -$p member add X end -puts [$p member] - -? [list $p fullbudget] 100 -? [list $p fullbudget] 100 -? [list $p currentbudget] 99 -? [list $p currentbudget] 98 -? [list $p fullbudget 200] 200 -? [list $p currentbudget] 199 - - -# # Local variables: # mode: tcl # tcl-indent-level: 2 Index: tests/accessor.test =================================================================== diff -u -r0a38046eb4aac6c36ac7c72dc8b0fe6da43f7c6e -rdadf28efd0707ae40076f49837e6b45ad5b2a989 --- tests/accessor.test (.../accessor.test) (revision 0a38046eb4aac6c36ac7c72dc8b0fe6da43f7c6e) +++ tests/accessor.test (.../accessor.test) (revision dadf28efd0707ae40076f49837e6b45ad5b2a989) @@ -60,7 +60,7 @@ ? {c1 cget -p3a} 3 ? {c1 p3a get} 3 ? {c1 configure -p3a 3} "" - ? {c1 p3a get 3} {invalid argument '3', maybe too many arguments; should be "value=get ?-array? /object/ /varName/"} + ? {c1 p3a get 3} {invalid argument '3', maybe too many arguments; should be "value=get ?-array? ?-notrace? /object/ /varName/"} ? {c1 p3a set 3} 3 ? {c1 p3a unset} "" ? {c1 cget -p3a} {can't read "p3a": no such variable} Index: tests/cget.test =================================================================== diff -u -r3946480dcc906b5004bf18ee49b49054fa400e0d -rdadf28efd0707ae40076f49837e6b45ad5b2a989 --- tests/cget.test (.../cget.test) (revision 3946480dcc906b5004bf18ee49b49054fa400e0d) +++ tests/cget.test (.../cget.test) (revision dadf28efd0707ae40076f49837e6b45ad5b2a989) @@ -235,10 +235,9 @@ # class case with no default # nx::Class create C - C property p { - set :valuechangedcmd { - #puts stderr "==== C.p valuechangedcmd $obj $var +1" - ::nsf::var::set $obj $var [expr {[::nsf::var::set $obj $var] + 1}] + C property -trace set p { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] } } @@ -253,10 +252,9 @@ # # class case with default # - C property {q 100} { - set :valuechangedcmd { - #puts stderr "C.q valuechangedcmd $obj $var +1" - ::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]] + C property -trace set {q 100} { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] } } C create c2 @@ -274,10 +272,9 @@ nx::Object create o ? {o eval {info exists :A}} 0 - o object property A { - set :valuechangedcmd { - #puts stderr "o.A valuechangedcmd $obj $var +1" - ::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]] + o object property -trace set A { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] } } # puts [o info object variables A] @@ -294,9 +291,10 @@ # ? {o eval {info exists :B}} 0 - o object property {B 1000} { - #puts stderr "o.B valuechangedcmd $obj $var +1" - set :valuechangedcmd {::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]]} + o object property -trace set {B 1000} { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] + } } ? {o eval {info exists :B}} 1 @@ -313,10 +311,9 @@ # class case with type and no default # nx::Class create C - C property p:integer { - set :valuechangedcmd { - #puts stderr "C.p valuechangedcmd $obj $var +1" - ::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]] + C property -trace set p:integer { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] } } @@ -334,20 +331,18 @@ # class case with type and default # - ? {C property {q:integer aaa} { - set :valuechangedcmd { - #puts stderr "C.q valuechangedcmd $obj $var +1" - ::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]] + ? {C property -trace set {q:integer aaa} { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] } }} {expected integer but got "aaa" for parameter "q"} # slot should no exist ? {C info slots q} "" - ? {C property {q:integer 99} { - set :valuechangedcmd { - #puts stderr "C.q valuechangedcmd $obj $var +1" - ::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]] + ? {C property -trace set {q:integer 99} { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] } }} "" @@ -370,10 +365,9 @@ nx::Object create o ? {o eval {info exists :A}} 0 - o object property A:integer { - set :valuechangedcmd { - #puts stderr "o.A valuechangedcmd $obj $var +1" - ::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]] + o object property -trace set A:integer { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] } } # puts [o info object variables A] @@ -392,17 +386,19 @@ # ? {o eval {info exists :B}} 0 - ? {o object property {B:integer x} { - #puts stderr "o.B valuechangedcmd $obj $var +1" - set :valuechangedcmd {::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]]} + ? {o object property -trace set {B:integer x} { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] + } }} {expected integer but got "x" for parameter "B"} ? {o eval {info exists :B}} 0 ? {o info object slots B} "" - ? {o object property {B:integer 1000} { - #puts stderr "o.B valuechangedcmd $obj $var +1" - set :valuechangedcmd {::nsf::var::set $obj $var [expr [list [::nsf::var::set $obj $var] + 1]]} + ? {o object property -trace set {B:integer 1000} { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] + } }} {} ? {o info object slots B} {::o::per-object-slot::B} Index: tests/parameters.test =================================================================== diff -u -r183cd0a9a3d2a37133ac51bb86952e1b522dbf6f -rdadf28efd0707ae40076f49837e6b45ad5b2a989 --- tests/parameters.test (.../parameters.test) (revision 183cd0a9a3d2a37133ac51bb86952e1b522dbf6f) +++ tests/parameters.test (.../parameters.test) (revision dadf28efd0707ae40076f49837e6b45ad5b2a989) @@ -35,7 +35,7 @@ ? {::nsf::method::alias C foo ::set 1} \ {invalid argument '1', maybe too many arguments; should be "::nsf::method::alias /object/ ?-per-object? /methodName/ ?-frame method|object|default? ?-protection call-protected|redefine-protected|none? /cmdName/"} - ? {C eval {:property x -class D}} {invalid argument 'D', maybe too many arguments; should be "::C property ?-accessor /value/? ?-configurable /boolean/? ?-incremental? ?-class /value/? /spec/ ?/initblock/?"} "Test whether the colon prefix is suppressed" + ? {C eval {:property x -class D}} {invalid argument 'D', maybe too many arguments; should be "::C property ?-accessor /value/? ?-class /value/? ?-configurable /boolean/? ?-incremental? ?-trace /value/? /spec/ ?/initblock/?"} "Test whether the colon prefix is suppressed" } ####################################################### @@ -1328,14 +1328,21 @@ nx::test case slot-traces { ::nx::Object create o { - :object property -accessor public a {set :defaultcmd { set _ 4 } } - :object property -accessor public b {set :valuecmd { set _ 44 } } - :object property -accessor public c {set :valuechangedcmd { ::nsf::var::set $obj $var 999 }} + :object property -accessor public -trace default a { + :public object method value=default {obj var} {puts stderr V=DEFAULT; return 4 } + } + :object property -accessor public -trace get b { + :public object method value=get {obj var} { return 44 } + } + :object property -accessor public -trace set c { + :public object method value=set {obj var value} { ::nsf::var::set $obj $var 999 } + } } ? {o a get} 4 ? {o b get} 44 ? {o c set 5} 999 + ? {::nsf::object::property o hasperobjectslots} 1 o copy o2 @@ -1346,9 +1353,15 @@ ? {::nsf::object::property o2 hasperobjectslots} 1 ::nx::Class create C { - :property -accessor public a {set :defaultcmd { set _ 4 } } - :property -accessor public b {set :valuecmd { set _ 44 } } - :property -accessor public c {set :valuechangedcmd { ::nsf::var::set $obj $var 999 }} + :property -accessor public -trace default a { + :public object method value=default {obj var} { return 4 } + } + :property -accessor public -trace get b { + :public object method value=get {obj property} { return 44 } + } + :property -accessor public -trace set c { + :public object method value=set {obj property value} { ::nsf::var::set $obj $property 999 } + } :create c1 } ? {c1 a get} 4 @@ -1381,33 +1394,29 @@ Object create o ? {o eval {info exists :a}} 0 - ? {o object property {a 0} { - set :defaultcmd {set _ 4} - }} "defaultcmd can't be used together with default value" + ? {o object property -trace default {a 0} { }} "'-trace default' can't be used together with default value" ? {o eval {info exists :a}} 0 ? {o eval {info exists :b}} 0 - ? {o object property {b 0} { - set :valuecmd {set _ 44} - }} "valuecmd can't be used together with default value" + ? {o object property -trace get {b 0} { }} "'trace get' can't be used together with default value" ? {o eval {info exists :b}} 0 ? {o eval {info exists :c}} 0 - ? {o object property c { - set :defaultcmd {set _ 4} - set :valuecmd {set _ 44} - }} "valuecmd can't be used together with defaultcmd" + ? {o object property -trace {default get} c { }} "'-trace default' and '-trace get' can't be used together" ? {o eval {info exists :c}} 0 # # valuechangedcmd + default value are allowed # ? {o eval {info exists :a}} 0 - o object property -accessor public {a 0} { - set :valuechangedcmd {::nsf::var::set $obj $var [expr {[::nsf::var::set $obj $var] + 1}]} + o object property -accessor public -trace set {a 0} { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] + } } + ? {o eval {info exists :a}} 1 ? {o a get} 0 @@ -1416,8 +1425,10 @@ ? {o a set 2} 3 ? {o eval {info exists :A}} 0 - o object property {A 0} { - set :valuechangedcmd {::nsf::var::set $obj $var [expr {[::nsf::var::set $obj $var] + 1}]} + o object property -trace set {A 0} { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] + } } ? {o eval {info exists :A}} 1 ? {o cget -A} 0 @@ -1427,21 +1438,16 @@ # per-class: Class create Klass - ? {Klass property {a 0} { - set :defaultcmd {set _ 4} - }} "defaultcmd can't be used together with default value" + ? {Klass property -trace default {a 0} { }} "'-trace default' can't be used together with default value" - ? {Klass property {b 0} { - set :valuecmd {set _ 44} - }} "valuecmd can't be used together with default value" + ? {Klass property -trace get {b 0} { }} "'trace get' can't be used together with default value" - ? {Klass property c { - set :defaultcmd {set _ 4} - set :valuecmd {set _ 44} - }} "valuecmd can't be used together with defaultcmd" + ? {Klass property -trace {default get} c { }} "'-trace default' and '-trace get' can't be used together" - Klass property -accessor public {a 0} { - set :valuechangedcmd {::nsf::var::set $obj $var [expr {[::nsf::var::set $obj $var] + 1}]} + Klass property -accessor public -trace set {a 0} { + :public object method value=set {obj var value} { + ::nsf::var::set -notrace $obj $var [expr {$value + 1}] + } } Klass create k @@ -1457,12 +1463,14 @@ # # a) against scalar checkers (as a simplistic case) - Klass property b:boolean { - set :valuechangedcmd {set _ tr1e} + Klass property -trace set b:boolean { + :public object method value=set {obj property value} { + return tr1e + } + } ? {catch {Klass create kk}} 0 - # # b) Structured trace scripts, containing lists. Check for # brace balancedness ... @@ -1481,18 +1489,15 @@ # evaluated right away and not fiddled through the parameter handling # infrastructure. ::nx::Class create CC { - :property a:0..n { - set :defaultcmd { - set _ 4 - } + :property -trace default a:0..n { + :public object method value=default {obj property} { return 4 } } - - :property b:0..n {set :valuecmd {set _ 44} } - :property -accessor public c:0..n { - set :valuechangedcmd { - ::nsf::var::set $obj $var 999 - } + :property -trace get b:0..n { + :public object method value=get {obj property} { return 44 } } + :property -accessor public -trace set c:0..n { + :public object method value=set {obj property value} { ::nsf::var::set $obj $property 999 } + } :create ::cc } @@ -2993,6 +2998,157 @@ ? {$::o1 cget -childof} y } + +nx::test case value=changed { + + nx::Class create C { + + :property a { + :public object method value=set {object property value} { + incr ::slotset_$property + nsf::var::set $object $property [expr {$value + 1}] + } + } + + :property -trace set b { + :public object method value=set {object property value} { + incr ::slotset_$property + nsf::var::set -notrace $object $property [expr {$value + 1}] + } + } + + :property -accessor public -trace set c { + :public object method value=set {object property value} { + incr ::slotset_$property + nsf::var::set -notrace $object $property [expr {$value + 1}] + } + } + + :public method foo {} { + set :a 100 + set :b 100 + set :c 100 + } + } + set ::slotset_a 0 + set ::slotset_b 0 + set ::slotset_c 0 + + ? {C create c1} ::c1 + ? {set ::slotset_a} 0 + ? {set ::slotset_b} 0 + ? {set ::slotset_c} 0 + + c1 configure + ? {set ::slotset_a} 0 + ? {set ::slotset_b} 0 + ? {set ::slotset_c} 0 + + c1 configure -a 1 -b 1 -c 1 + ? {set ::slotset_a} 1 + ? {set ::slotset_b} 1 + ? {set ::slotset_c} 1 + ? {c1 cget -a} 2 + ? {c1 cget -b} 2 + ? {c1 cget -c} 2 + + ? {c1 cget -a} 2 + ? {c1 cget -b} 2 + ? {c1 cget -c} 2 + + + set ::slotset_a 0 + set ::slotset_b 0 + set ::slotset_c 0 + c1 foo + ? {set ::slotset_a} 0 + ? {set ::slotset_b} 1 + ? {set ::slotset_c} 1 + ? {c1 cget -a} 100 + ? {c1 cget -b} 101 + ? {c1 cget -c} 101 + + set ::slotset_a 0 + set ::slotset_b 0 + set ::slotset_c 0 + + ? {c1 a set 200} {::c1: unable to dispatch method 'a'} + ? {c1 b set 200} {::c1: unable to dispatch method 'b'} + ? {c1 c set 200} 201 + ? {set ::slotset_a} 0 + ? {set ::slotset_b} 0 + ? {set ::slotset_c} 1 +} + +nx::test case trace-meta-slot { + + ::nx::MetaSlot create ::nsv::TraceVariableSlot -superclass ::nx::VariableSlot { + :property {trace {get set}} + :public method value=set {obj varName value} { + incr ::trace_set + #puts stderr "SET nsv_set $obj $varName $value" + next + } + :public method value=get {obj varName} { + incr ::trace_get + #puts stderr "GET nsv_set $obj $varName" + next + } + } + + set ::trace_set 0 + set ::trace_get 0 + nx::Class create Foo { + + :property -class ::nsv::TraceVariableSlot x + + :public method exists {var} { info exists :$var } + :public method get {var} { set :$var } + :public method foo {} { incr :x } + + :create ::f1 + } + + # + # Change the value of ::f1.x via configure + # + ? {set ::trace_set} 0 + ? {set ::trace_get} 0 + + ? {::f1 configure -x "1"} "" + + ? {set ::trace_set} 2 ;# 2, since the next triggers the default setter, which has no "-notrace" + ? {set ::trace_get} 0 + + ? {::f1 exists x} 1 + ? {set ::trace_set} 2 + ? {set ::trace_get} 1 + + ? {::f1 cget -x} "1" + + ? {set ::trace_set} 2 + ? {set ::trace_get} 3 ;# 3, since the next triggers the default setter, which has no "-notrace" + + + # + # Change the value of ::f1.x via configure again + # + ? {::f1 configure -x 2} "" + ? {::f1 cget -x} "2" + + # + # Change the value of ::f1.x via variable changes + # + set ::trace_set 0 + set ::trace_get 0 + + ? {::f1 foo} "3" + ? {set ::trace_set} 1 + ? {set ::trace_get} 1 + + ? {::f1 cget -x} "3" +} + # # Local variables: # mode: tcl