summaryrefslogtreecommitdiffstats
path: root/generic/tclBasic.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r--generic/tclBasic.c142
1 files changed, 141 insertions, 1 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 3babbf9..f2490ef 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -9,11 +9,12 @@
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.267 2007/09/05 21:31:01 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.268 2007/09/13 15:27:06 das Exp $
*/
#include "tclInt.h"
@@ -93,6 +94,11 @@ static int ExprWideFunc(ClientData clientData, Tcl_Interp *interp,
static void MathFuncWrongNumArgs(Tcl_Interp* interp, int expected,
int actual, Tcl_Obj *const *objv);
+#ifdef USE_DTRACE
+static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+#endif
+
extern TclStubs tclStubs;
/*
@@ -650,6 +656,14 @@ Tcl_CreateInterp(void)
Tcl_CreateObjCommand(interp, "::tcl::Bgerror",
TclDefaultBgErrorHandlerObjCmd, NULL, NULL);
+#ifdef USE_DTRACE
+ /*
+ * Register the tcl::dtrace command.
+ */
+
+ Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
+#endif /* USE_DTRACE */
+
/*
* Register the builtin math functions.
*/
@@ -2908,6 +2922,7 @@ CallCommandTraces(
* command. This insures that traces get a correct nul-terminated command
* string.
*
+ *----------------------------------------------------------------------
*/
static Tcl_Obj *
@@ -3559,6 +3574,25 @@ TclEvalObjvInternal(
}
}
+ if (TCL_DTRACE_CMD_ARGS_ENABLED()) {
+ char *a[10];
+ int i = 0;
+
+ while (i < 10) {
+ a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++;
+ }
+ TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
+ a[8], a[9]);
+ }
+ if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) {
+ Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
+ char *a[4]; int i[2];
+
+ TclDTraceInfo(info, a, i);
+ TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1]);
+ TclDecrRefCount(info);
+ }
+
/*
* Finally, invoke the command's Tcl_ObjCmdProc.
*/
@@ -3566,7 +3600,14 @@ TclEvalObjvInternal(
cmdPtr->refCount++;
iPtr->cmdCount++;
if (code == TCL_OK && traceCode == TCL_OK && !TclLimitExceeded(iPtr->limit)) {
+ if (TCL_DTRACE_CMD_ENTRY_ENABLED()) {
+ TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1,
+ (Tcl_Obj **)(objv + 1));
+ }
code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
+ if (TCL_DTRACE_CMD_RETURN_ENABLED()) {
+ TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code);
+ }
}
if (Tcl_AsyncReady()) {
code = Tcl_AsyncInvoke(interp, code);
@@ -3623,6 +3664,13 @@ TclEvalObjvInternal(
(void) Tcl_GetObjResult(interp);
}
+ if (TCL_DTRACE_CMD_RESULT_ENABLED()) {
+ Tcl_Obj *r;
+
+ r = Tcl_GetObjResult(interp);
+ TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r), r);
+ }
+
done:
if (savedVarFramePtr) {
iPtr->varFramePtr = savedVarFramePtr;
@@ -6362,6 +6410,98 @@ MathFuncWrongNumArgs(
"too %s arguments for math function \"%s\"",
(found < expected ? "few" : "many"), name));
}
+#ifdef USE_DTRACE
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DTraceObjCmd --
+ *
+ * This function is invoked to process the "::tcl::dtrace" Tcl command.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * The 'tcl-probe' DTrace probe is triggered (if it is enabled).
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DTraceObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (TCL_DTRACE_TCL_PROBE_ENABLED()) {
+ char *a[10];
+ int i = 0;
+
+ while (i++ < 10) {
+ a[i-1] = i < objc ? TclGetString(objv[i]) : NULL;
+ }
+ TCL_DTRACE_TCL_PROBE(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
+ a[8], a[9]);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclDTraceInfo --
+ *
+ * Extract information from a TIP280 dict for use by DTrace probes.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclDTraceInfo(
+ Tcl_Obj *info,
+ char **args,
+ int *argsi)
+{
+ static Tcl_Obj *keys[7] = { NULL };
+ Tcl_Obj **k = keys, *val;
+ int i;
+
+ if (!*k) {
+ TclNewLiteralStringObj(keys[0], "cmd");
+ TclNewLiteralStringObj(keys[1], "type");
+ TclNewLiteralStringObj(keys[2], "proc");
+ TclNewLiteralStringObj(keys[3], "file");
+ TclNewLiteralStringObj(keys[4], "lambda");
+ TclNewLiteralStringObj(keys[5], "line");
+ TclNewLiteralStringObj(keys[6], "level");
+ }
+ for (i = 0; i < 4; i++) {
+ Tcl_DictObjGet(NULL, info, *k++, &val);
+ args[i] = val ? TclGetString(val) : NULL;
+ }
+ if (!args[2]) {
+ Tcl_DictObjGet(NULL, info, *k, &val);
+ args[2] = val ? TclGetString(val) : NULL;
+ }
+ k++;
+ for (i = 0; i < 2; i++) {
+ Tcl_DictObjGet(NULL, info, *k++, &val);
+ if (val) {
+ Tcl_GetIntFromObj(NULL, val, &(argsi[i]));
+ } else {
+ argsi[i] = 0;
+ }
+ }
+}
+#endif /* USE_DTRACE */
/*
* Local Variables: