summaryrefslogtreecommitdiff
path: root/systems/mac/support/alpha/tcl/extensions/trace.c
diff options
context:
space:
mode:
Diffstat (limited to 'systems/mac/support/alpha/tcl/extensions/trace.c')
-rw-r--r--systems/mac/support/alpha/tcl/extensions/trace.c282
1 files changed, 282 insertions, 0 deletions
diff --git a/systems/mac/support/alpha/tcl/extensions/trace.c b/systems/mac/support/alpha/tcl/extensions/trace.c
new file mode 100644
index 0000000000..f66c51a908
--- /dev/null
+++ b/systems/mac/support/alpha/tcl/extensions/trace.c
@@ -0,0 +1,282 @@
+/*
+ * trace.c --
+ *
+ * Copyright (c) 1999 Vince Darley
+ *
+ * This file is distributed under the same license as Tcl.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * Note: It would be relatively easy to take this code and use it
+ * to extend Tcl's current 'trace' command to perform both variable
+ * and command tracing. It would make a nice addition to the Tcl core.
+ *
+ * Notice that I didn't think it sensible to implement the idea of
+ * calling a Tcl proc with each traced command (as is done with
+ * variable traces). This seemed likely to (i) lead to nasty
+ * recursions which would have to be worked around, and (ii) be
+ * unnecessary, since the primary use of this code would seem to be
+ * debugging -- 'my proc foo doesn't do what I think it should, give me
+ * a dump of everything that's happening inside it'.
+ *
+ * Basic use is:
+ *
+ * # register trace
+ * tracecommand on foo
+ * # now call some code which uses 'foo'
+ * foo arg1 arg2 arg3
+ * # now see what happened inside foo
+ * tracecommand dump foo
+ * # now get rid of the trace and free associated memory
+ * tracecommand off foo
+ *
+ */
+
+#define TCL_USE_STUBS
+#include <tcl.h>
+
+/* For Tcl_GetCommandFromObj, Tcl_GetCommandFullName */
+#include <tclInt.h>
+#include <string.h>
+
+extern Tcl_ObjCmdProc Trace_ObjCmd;
+DLLEXPORT int Trace_Init(Tcl_Interp* interp);
+
+static Tcl_CmdTraceObjProc traceCmd;
+static Tcl_InterpDeleteProc traceCleanup;
+static void addIndentTruncate(Tcl_DString *ds, int indent, int truncate, Tcl_DString *add);
+
+typedef struct traceInfo {
+ Tcl_DString traceDetails;
+ Tcl_Trace tracePtr;
+ Tcl_Command cmdPtr;
+ int truncationLength;
+ int relativeDepth;
+ struct traceInfo* nextPtr;
+} traceInfo;
+
+typedef struct interpTraceInfo {
+ traceInfo* traces;
+} interpTraceInfo;
+
+int Trace_Init(Tcl_Interp* interp) {
+ interpTraceInfo* traceInfoPtr;
+ Tcl_InitStubs(interp,TCL_VERSION,0);
+
+ traceInfoPtr = (interpTraceInfo*) ckalloc(sizeof(interpTraceInfo));
+ traceInfoPtr->traces = NULL;
+
+ Tcl_CallWhenDeleted(interp, traceCleanup, (ClientData) traceInfoPtr);
+ Tcl_CreateObjCommand(interp, "tracecommand", Trace_ObjCmd,
+ (ClientData)traceInfoPtr, (Tcl_CmdDeleteProc*) NULL);
+ return TCL_OK;
+}
+
+int Trace_ObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Trace info */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int index;
+ int flags, min, max, truncate, relativeDepth, c;
+ traceInfo *loopPtr, *prevPtr;
+ interpTraceInfo *traceInfoPtr = (interpTraceInfo*)clientData;
+ Tcl_Command cmdPtr;
+
+ static char *optionStrings[] = {
+ "dump", "list", "off", "on", NULL
+ };
+ enum options {
+ TRACE_DUMP, TRACE_LIST, TRACE_OFF, TRACE_ON
+ };
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if ((enum options) index == TRACE_LIST) {
+ Tcl_Obj *resObj = Tcl_NewListObj(0,NULL);
+ for(loopPtr = traceInfoPtr->traces; loopPtr != NULL; loopPtr = loopPtr->nextPtr) {
+ Tcl_Obj *objPtr = Tcl_NewObj();
+ Tcl_GetCommandFullName(interp, loopPtr->cmdPtr, objPtr);
+ Tcl_ListObjAppendElement(interp,resObj,objPtr);
+ }
+ Tcl_SetObjResult(interp,resObj);
+ return TCL_OK;
+ }
+
+ if(objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "command");
+ return TCL_ERROR;
+ }
+ cmdPtr = Tcl_GetCommandFromObj(interp, objv[2]);
+ if(cmdPtr == NULL) {
+ Tcl_AppendResult(interp, "Bad argument \"", Tcl_GetString(objv[2]),
+ "\": must be the name of an existing command or procedure",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ switch ((enum options) index) {
+ case TRACE_DUMP:
+ for(loopPtr = traceInfoPtr->traces; loopPtr != NULL; loopPtr = loopPtr->nextPtr) {
+ if(loopPtr->cmdPtr == cmdPtr) {
+ Tcl_DStringResult(interp,&loopPtr->traceDetails);
+ return TCL_OK;
+ }
+ }
+ Tcl_AppendResult(interp, "There is no existing trace on \"", Tcl_GetString(objv[2]),
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+ break;
+ case TRACE_ON:
+ flags = min = max = truncate = relativeDepth = 0;
+ c = 3;
+ while(c < objc) {
+ int len;
+ char* str = Tcl_GetStringFromObj(objv[c],&len);
+ if(str[0] == '-' && c != objc-1) {
+ if (len == 9 && !strncmp(str,"-minlevel",9)) {
+ if (Tcl_GetIntFromObj(interp,objv[c+1],&min) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ c++;
+ } else if (len == 9 && !strncmp(str,"-maxlevel",9)) {
+ if (Tcl_GetIntFromObj(interp,objv[c+1],&max) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ c++;
+ } else if (len == 9 && !strncmp(str,"-truncate",9)) {
+ if (Tcl_GetIntFromObj(interp,objv[c+1],&truncate) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ c++;
+ } else if (len == 6 && !strncmp(str,"-depth",6)) {
+ if (Tcl_GetIntFromObj(interp,objv[c+1],&relativeDepth) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ c++;
+ } else {
+ goto bad_args;
+ }
+ } else if (len == 6 && !strncmp(str,"before",6)) {
+ flags |= TCL_CMD_TRACE_BEFORE;
+ } else if (len == 5 && !strncmp(str,"after",5)) {
+ flags |= TCL_CMD_TRACE_AFTER;
+ } else {
+ bad_args:
+ Tcl_AppendResult(interp, "Bad argument \"", Tcl_GetString(objv[c]),
+ "\": should be before, after -minlevel n, -maxlevel n, -depth n or -truncate n",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ c++;
+ }
+ loopPtr = (traceInfo*) ckalloc(sizeof(traceInfo));
+ loopPtr->cmdPtr = cmdPtr;
+ Tcl_DStringInit(&loopPtr->traceDetails);
+ loopPtr->tracePtr = Tcl_CreateTraceObj(interp,objv[2],flags,max,min,traceCmd,(ClientData)loopPtr);
+ loopPtr->truncationLength = truncate;
+ loopPtr->relativeDepth = relativeDepth;
+ loopPtr->nextPtr = traceInfoPtr->traces;
+ traceInfoPtr->traces = loopPtr;
+ break;
+ case TRACE_OFF:
+ prevPtr = NULL;
+ for(loopPtr = traceInfoPtr->traces; loopPtr != NULL; loopPtr = loopPtr->nextPtr) {
+ if(loopPtr->cmdPtr == cmdPtr) {
+ Tcl_DeleteTrace(interp,loopPtr->tracePtr);
+ Tcl_DStringFree(&loopPtr->traceDetails);
+ if(prevPtr != NULL) {
+ prevPtr->nextPtr = loopPtr->nextPtr;
+ } else {
+ traceInfoPtr->traces = NULL;
+ }
+ ckfree((char*)loopPtr);
+ return TCL_OK;
+ }
+ prevPtr = loopPtr;
+ }
+ Tcl_AppendResult(interp, "There is no existing trace on \"", Tcl_GetString(objv[2]),
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+ break;
+ }
+ return TCL_OK;
+}
+
+void traceCleanup(ClientData clientData, Tcl_Interp *interp) {
+ traceInfo *loopPtr, *prevPtr;
+ interpTraceInfo *traceInfoPtr = (interpTraceInfo*)clientData;
+ for(loopPtr = traceInfoPtr->traces; loopPtr != NULL; loopPtr = loopPtr->nextPtr) {
+ Tcl_DStringFree(&loopPtr->traceDetails);
+ Tcl_DeleteTrace(interp,loopPtr->tracePtr);
+ prevPtr= loopPtr;
+ loopPtr = loopPtr->nextPtr;
+ ckfree((char*)prevPtr);
+ }
+ ckfree((char*)traceInfoPtr);
+}
+
+void traceCmd(ClientData clientData, Tcl_Interp *interp,
+ int level, int startLevel, int flags, int code,
+ char* command, int length, Tcl_Command cmdInfo,
+ int objc, struct Tcl_Obj *CONST objv[]) {
+ Tcl_DString ds;
+ traceInfo* traceInfoPtr = (traceInfo*)clientData;
+ /* Cut-off anything deeper than this */
+ if (traceInfoPtr->relativeDepth > 0 && (level-startLevel > traceInfoPtr->relativeDepth)) {
+ return;
+ }
+ if (flags & TCL_CMD_TRACE_BEFORE) {
+ Tcl_DStringInit(&ds);
+ Tcl_DStringAppend(&ds, "'", 1);
+ Tcl_DStringAppend(&ds, command, length);
+ Tcl_DStringAppend(&ds, "'", 1);
+ Tcl_DStringAppend(&ds, "\n", 1);
+ addIndentTruncate(&traceInfoPtr->traceDetails,level-startLevel,traceInfoPtr->truncationLength,&ds);
+ Tcl_DStringFree(&ds);
+ }
+ if (flags & TCL_CMD_TRACE_AFTER) {
+ int i;
+ Tcl_DStringInit(&ds);
+ for (i = 0; i < objc; i++) {
+ char* str;
+ int len;
+ str = Tcl_GetStringFromObj(objv[i],&len);
+ Tcl_DStringAppend(&ds, str, len);
+ Tcl_DStringAppend(&ds, " ", 1);
+ }
+ Tcl_DStringAppend(&ds, "\n", 1);
+ addIndentTruncate(&traceInfoPtr->traceDetails,level-startLevel,traceInfoPtr->truncationLength,&ds);
+ Tcl_DStringFree(&ds);
+ }
+ if (flags & TCL_CMD_TRACE_AFTER) {
+ Tcl_DStringInit(&ds);
+ Tcl_DStringAppend(&ds, code == TCL_ERROR ? "ERROR: " : "OK: ", -1);
+ Tcl_DStringAppend(&ds, Tcl_GetStringResult(interp), -1);
+ Tcl_DStringAppend(&ds, "\n", 1);
+ addIndentTruncate(&traceInfoPtr->traceDetails,level-startLevel,traceInfoPtr->truncationLength,&ds);
+ Tcl_DStringFree(&ds);
+ }
+}
+
+void addIndentTruncate(Tcl_DString *ds, int indent, int truncate, Tcl_DString *add) {
+ int i;
+ for (i = 1; i < indent; i++) {
+ Tcl_DStringAppend(ds, " ", 1);
+ }
+ if(truncate > 0 && (truncate - indent < Tcl_DStringLength(add))) {
+ Tcl_DStringAppend(ds, Tcl_DStringValue(add), truncate - indent);
+ Tcl_DStringAppend(ds,"...\n",4);
+ } else {
+ Tcl_DStringAppend(ds, Tcl_DStringValue(add), Tcl_DStringLength(add));
+ }
+}
+
+