diff options
| -rw-r--r-- | generic/tcl.h | 2 | ||||
| -rw-r--r-- | generic/tclTrace.c | 44 | ||||
| -rw-r--r-- | tests/trace.test | 14 |
3 files changed, 38 insertions, 22 deletions
diff --git a/generic/tcl.h b/generic/tcl.h index ff86949..2f1f793 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1110,7 +1110,7 @@ typedef struct Tcl_DString { #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED /* Required to support old variable/vdelete/vinfo traces. */ #define TCL_TRACE_OLD_STYLE 0x1000 #endif diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 586c4e9..a718c86 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -95,7 +95,7 @@ typedef struct { /* 'OLD' options are pre-Tcl-8.4 style */ enum traceOptionsEnum { TRACE_ADD, TRACE_INFO, TRACE_REMOVE -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED ,TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO #endif }; @@ -195,29 +195,43 @@ Tcl_TraceObjCmd( Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED const char *name; const char *flagOps, *p; #endif /* Main sub commands to 'trace' */ static const char *const traceOptions[] = { "add", "info", "remove", -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED "variable", "vdelete", "vinfo", #endif NULL }; int optionIndex; +#ifndef TCL_NO_DEPRECATED + static const char *const traceShortOptions[] = { + "add", "info", "remove", NULL + }; +#endif if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } +#ifdef TCL_NO_DEPRECATED if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } +#else + if (Tcl_GetIndexFromObj(NULL, objv[1], traceOptions, "option", 0, + &optionIndex) != TCL_OK) { + Tcl_GetIndexFromObj(interp, objv[1], traceShortOptions, "option", 0, + &optionIndex); + return TCL_ERROR; + } +#endif switch ((enum traceOptionsEnum) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { @@ -264,7 +278,7 @@ Tcl_TraceObjCmd( break; } -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED case TRACE_OLD_VARIABLE: case TRACE_OLD_VDELETE: { Tcl_Obj *copyObjv[6]; @@ -361,11 +375,11 @@ Tcl_TraceObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } -#endif /* TCL_REMOVE_OBSOLETE_TRACES */ +#endif /* TCL_NO_DEPRECATED */ } return TCL_OK; -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED badVarOps: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad operations \"%s\": should be one or more of rwua", @@ -619,7 +633,7 @@ TraceExecutionObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED default: break; #endif @@ -818,7 +832,7 @@ TraceCommandObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED default: break; #endif @@ -923,7 +937,7 @@ TraceVariableObjCmd( + 1 + length); ctvarPtr->traceCmdInfo.flags = flags; -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED if (objv[0] == NULL) { ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE; } @@ -953,7 +967,7 @@ TraceVariableObjCmd( if ((tvarPtr->length == length) && ((tvarPtr->flags -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED & ~TCL_TRACE_OLD_STYLE #endif )==flags) @@ -1016,7 +1030,7 @@ TraceVariableObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED default: break; #endif @@ -2010,7 +2024,7 @@ TraceVarProc( Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { if (flags & TCL_TRACE_ARRAY) { TclDStringAppendLiteral(&cmd, " a"); @@ -2032,7 +2046,7 @@ TraceVarProc( } else if (flags & TCL_TRACE_UNSETS) { TclDStringAppendLiteral(&cmd, " unset"); } -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED } #endif @@ -2946,7 +2960,7 @@ Tcl_UntraceVar2( flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED flagMask |= TCL_TRACE_OLD_STYLE; #endif flags &= flagMask; @@ -3297,7 +3311,7 @@ TraceVarEx( flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; -#ifndef TCL_REMOVE_OBSOLETE_TRACES +#ifndef TCL_NO_DEPRECATED flagMask |= TCL_TRACE_OLD_STYLE; #endif tracePtr->flags = tracePtr->flags & flagMask; diff --git a/tests/trace.test b/tests/trace.test index d3c2dad..c95379d 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -19,6 +19,8 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] +source [file join [file dirname [info script]] tcltests.tcl] + testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testevalobjv [llength [info commands testevalobjv]] @@ -871,7 +873,7 @@ test trace-14.4 "trace command, wrong # args errors" { test trace-14.5 {trace command, invalid option} { list [catch {trace gorp} msg] $msg -} [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"] +} [list 1 "bad option \"gorp\": must be add, info, or remove"] # Again, [trace ... command] and [trace ... variable] share syntax and # error message styles for their opList options; these loops test those @@ -898,19 +900,19 @@ foreach type {variable command execution} err $errs abbvlist $abbvs { } rename x {} -test trace-14.7 {trace command, "trace variable" errors} { +test trace-14.7 {trace command, "trace variable" errors} deprecated { list [catch {trace variable} msg] $msg } [list 1 "wrong # args: should be \"trace variable name ops command\""] -test trace-14.8 {trace command, "trace variable" errors} { +test trace-14.8 {trace command, "trace variable" errors} deprecated { list [catch {trace variable x} msg] $msg } [list 1 "wrong # args: should be \"trace variable name ops command\""] -test trace-14.9 {trace command, "trace variable" errors} { +test trace-14.9 {trace command, "trace variable" errors} deprecated { list [catch {trace variable x y} msg] $msg } [list 1 "wrong # args: should be \"trace variable name ops command\""] -test trace-14.10 {trace command, "trace variable" errors} { +test trace-14.10 {trace command, "trace variable" errors} deprecated { list [catch {trace variable x y z w} msg] $msg } [list 1 "wrong # args: should be \"trace variable name ops command\""] -test trace-14.11 {trace command, "trace variable" errors} { +test trace-14.11 {trace command, "trace variable" errors} deprecated { list [catch {trace variable x y z} msg] $msg } [list 1 "bad operations \"y\": should be one or more of rwua"] |