Attachment "tip32.patch" to
ticket [502118ffff]
added by
kennykb
2002-01-11 07:13:34.
? doc/html
Index: doc/CrtObjCmd.3
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/CrtObjCmd.3,v
retrieving revision 1.5
diff -u -r1.5 CrtObjCmd.3
--- doc/CrtObjCmd.3 2001/04/24 20:59:17 1.5
+++ doc/CrtObjCmd.3 2002/01/11 00:07:49
@@ -10,7 +10,7 @@
.TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_SetCommandInfo, Tcl_GetCommandName \- implement new commands in C
+Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName \- implement new commands in C
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -31,6 +31,14 @@
\fBTcl_SetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR)
.sp
.VS 8.4
+int
+\fBTcl_GetCommandInfoFromToken\fR(\fItoken, infoPtr\fR)
+.sp
+int
+\fBTcl_SetCommandInfoFromToken\fR(\fItoken, infoPtr\fR)
+.VE
+.sp
+.VS 8.4
CONST char *
.VE
\fBTcl_GetCommandName\fR(\fIinterp, token\fR)
@@ -230,6 +238,12 @@
The field \fInamespacePtr\fR holds a pointer to the
Tcl_Namespace that contains the command.
.PP
+\fBTcl_GetCommandInfoFromToken\fR is identical to
+\fBTcl_GetCommandInfo\fR except that it uses a command token returned
+from \fBTcl_CreateObjCommand\fR in place of the command name. If the
+\fItoken\fR parameter is NULL, it returns 0; otherwise, it returns 1
+and fills in the structure designated by \fIinfoPtr\fR.
+.PP
\fBTcl_SetCommandInfo\fR is used to modify the procedures and
ClientData values associated with a command.
Its \fIcmdName\fR argument is the name of a command in \fIinterp\fR.
@@ -238,11 +252,22 @@
If this command does not exist then \fBTcl_SetCommandInfo\fR returns 0.
Otherwise, it copies the information from \fI*infoPtr\fR to
Tcl's internal structure for the command and returns 1.
-Note that this procedure allows the ClientData for a command's
-deletion procedure to be given a different value than the ClientData
-for its command procedure.
-Note that \fBTcl_SetCmdInfo\fR will not change a command's namespace;
-you must use \fBTcl_RenameCommand\fR to do that.
+.PP
+\fBTcl_SetCommandInfoFromToken\fR is identical to
+\fBTcl_SetCommandInfo\fR except that it takes a command token as
+returned by \fBTcl_CreateObjCommand\fR instead of the command name.
+If the \fItoken\fR parameter is NULL, it returns 0. Otherwise, it
+copies the information from \fI*infoPtr\fR to Tcl's internal structure
+for the command and returns 1.
+.PP
+Note that \fBTcl_SetCommandInfo\fR and
+\fBTcl_SetCommandInfoFromToken\fR both allow the ClientData for a
+command's deletion procedure to be given a different value than the
+ClientData for its command procedure.
+.PP
+Note that neither \fBTcl_SetCommandInfo\fR nor
+\fBTcl_SetCommandInfoFromToken\fR will change a command's namespace.
+You must use \fBTcl_RenameCommand\fR to do that.
.PP
\fBTcl_GetCommandName\fR provides a mechanism for tracking commands
that have been renamed.
Index: doc/CrtTrace.3
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/CrtTrace.3,v
retrieving revision 1.2
diff -u -r1.2 CrtTrace.3
--- doc/CrtTrace.3 1998/09/14 18:39:47 1.2
+++ doc/CrtTrace.3 2002/01/11 00:07:49
@@ -1,6 +1,7 @@
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2002 by Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -11,7 +12,7 @@
.TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_CreateTrace, Tcl_DeleteTrace \- arrange for command execution to be traced
+Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_DeleteTrace \- arrange for command execution to be traced
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -19,9 +20,12 @@
Tcl_Trace
\fBTcl_CreateTrace\fR(\fIinterp, level, proc, clientData\fR)
.sp
+Tcl_Trace
+\fBTcl_CreateObjTrace\fR(\fIinterp, level, flags, objProc, clientData, deleteProc\fR)
+.sp
\fBTcl_DeleteTrace\fR(\fIinterp, trace\fR)
.SH ARGUMENTS
-.AS Tcl_CmdTraceProc (clientData)()
+.AS Tcl_CmdObjTraceDeleteProc (clientData)()
.AP Tcl_Interp *interp in
Interpreter containing command to be traced or untraced.
.AP int level in
@@ -29,63 +33,94 @@
top-level commands only, 2 means top-level commands or those that are
invoked as immediate consequences of executing top-level commands
(procedure bodies, bracketed commands, etc.) and so on.
+.AP int flags in
+Flags governing the trace execution. See below for details.
+.AP Tcl_CmdObjTraceProc *proc in
+Procedure to call for each command that's executed. See below for
+details of the calling sequence.
.AP Tcl_CmdTraceProc *proc in
Procedure to call for each command that's executed. See below for
details on the calling sequence.
.AP ClientData clientData in
-Arbitrary one-word value to pass to \fIproc\fR.
+Arbitrary one-word value to pass to \fIobjProc\fR or \fIproc\fR.
+.AP Tcl_CmdObjTraceDeleteProc *deleteProc
+Procedure to call when the trace is deleted. See below for details of
+the calling sequence. A null pointer is permissible and results in no
+callback when the trace is deleted.
.AP Tcl_Trace trace in
Token for trace to be removed (return value from previous call
to \fBTcl_CreateTrace\fR).
.BE
-
.SH DESCRIPTION
.PP
-\fBTcl_CreateTrace\fR arranges for command tracing. From now on, \fIproc\fR
-will be invoked before Tcl calls command procedures to process
-commands in \fIinterp\fR. The return value from
-\fBTcl_CreateTrace\fR is a token for the trace,
-which may be passed to \fBTcl_DeleteTrace\fR to remove the trace. There may
-be many traces in effect simultaneously for the same command interpreter.
+\fBTcl_CreateObjTrace\fR arranges for command tracing. After it is
+called, \fIobjProc\fR will be invoked before the Tcl interpreter calls
+any command procedure when evaluating commands in \fIinterp\fR.
+The return value from \fBTcl_CreateObjTrace\fR is a token for the trace,
+which may be passed to \fBTcl_DeleteTrace\fR to remove the trace.
+There may be many traces in effect simultaneously for the same
+interpreter.
.PP
-\fIProc\fR should have arguments and result that match the
-type \fBTcl_CmdTraceProc\fR:
+\fIobjProc\fR should have arguments and result that match the type,
+\fBTcl_CmdObjTraceProc\fR:
.CS
-typedef void Tcl_CmdTraceProc(
- ClientData \fIclientData\fR,
- Tcl_Interp *\fIinterp\fR,
- int \fIlevel\fR,
- char *\fIcommand\fR,
- Tcl_CmdProc *\fIcmdProc\fR,
- ClientData \fIcmdClientData\fR,
- int \fIargc\fR,
- char *\fIargv\fR[]);
+typedef int \fBTcl_CmdObjTraceProc\fR(
+ \fBClientData\fR \fIclientData\fR,
+ \fBTcl_Interp\fR* \fIinterp\fR,
+ int \fIlevel\fR,
+ CONST char* \fIcommand\fR,
+ \fBTcl_Command\fR \fIcommandToken\fR,
+ int \fIobjc\fR,
+ \fBTcl_Obj\fR *CONST \fIobjv\fR[] );
.CE
-The \fIclientData\fR and \fIinterp\fR parameters are
-copies of the corresponding arguments given to \fBTcl_CreateTrace\fR.
-\fIClientData\fR typically points to an application-specific
-data structure that describes what to do when \fIproc\fR
-is invoked. \fILevel\fR gives the nesting level of the command
-(1 for top-level commands passed to \fBTcl_Eval\fR by the application,
-2 for the next-level commands passed to \fBTcl_Eval\fR as part of parsing
-or interpreting level-1 commands, and so on). \fICommand\fR
-points to a string containing the text of the
-command, before any argument substitution.
-\fICmdProc\fR contains the address of the command procedure that
-will be called to process the command (i.e. the \fIproc\fR argument
-of some previous call to \fBTcl_CreateCommand\fR) and \fIcmdClientData\fR
-contains the associated client data for \fIcmdProc\fR (the \fIclientData\fR
-value passed to \fBTcl_CreateCommand\fR). \fIArgc\fR and \fIargv\fR give
-the final argument information that will be passed to \fIcmdProc\fR, after
-command, variable, and backslash substitution.
-\fIProc\fR must not modify the \fIcommand\fR or \fIargv\fR strings.
+The \fIclientData\fR and \fIinterp\fR parameters are copies of the
+corresponding arguments given to \fBTcl_CreateTrace\fR.
+\fIClientData\fR typically points to an application-specific data
+structure that describes what to do when \fIobjProc\fR is invoked. The
+\fIlevel\fR parameter gives the nesting level of the command (1 for
+top-level commands passed to \fBTcl_Eval\fR by the application, 2 for
+the next-level commands passed to \fBTcl_Eval\fR as part of parsing or
+interpreting level-1 commands, and so on). The \fIcommand\fR parameter
+points to a string containing the text of the command, before any
+argument substitution. The \fIcommandToken\fR parameter is a Tcl
+command token that identifies the command to be invoked. The token
+may be passed to \fBTcl_GetCommandName\fR,
+\fBTcl_GetCommandTokenInfo\fR, or \fBTcl_SetCommandTokenInfo\fR to
+manipulate the definition of the command. The \fIobjc\fR and \fIobjv\fR
+parameters designate the final parameter count and parameter vector
+that will be passed to the command, and have had all substitutions
+performed.
.PP
+The \fIobjProc\fR callback is expected to return a standard Tcl status
+return code. If this code is \fBTCL_OK\fR (the normal case), then
+the Tcl interpreter will invoke the command. Any other return code
+is treated as if the command returned that status, and the command is
+\fInot\fR invoked.
+.PP
+The \fIobjProc\fR callback must not modify \fIobjv\fR in any way. It
+is, however, permissible to change the command by calling
+\fBTcl_SetCommandTokenInfo\fR prior to returning. Any such change
+takes effect immediately, and the command is invoked with the new
+information.
+.PP
Tracing will only occur for commands at nesting level less than
or equal to the \fIlevel\fR parameter (i.e. the \fIlevel\fR
-parameter to \fIproc\fR will always be less than or equal to the
+parameter to \fIobjProc\fR will always be less than or equal to the
\fIlevel\fR parameter to \fBTcl_CreateTrace\fR).
.PP
-Calls to \fIproc\fR will be made by the Tcl parser immediately before
+Tracing has a significant effect on runtime performance because it
+causes the bytecode compiler to refrain from generating in-line code
+for Tcl commands such as \fBif\fR and \fBwhile\fR in order that they
+may be traced. If traces for the built-in commands are not required,
+the \fIflags\fR parameter may be set to the constant value
+\fBTCL_ALLOW_INLINE_COMPILATION\fR. In this case, traces on built-in
+commands may or may not result in trace callbacks, depending on the
+state of the interpreter, but run-time performance will be improved
+significantly. (This functionality is desirable, for example, when
+using \fBTcl_CreateObjTrace\fR to implement an execution time
+profiler.)
+.PP
+Calls to \fIobjProc\fR will be made by the Tcl parser immediately before
it calls the command procedure for the command (\fIcmdProc\fR). This
occurs after argument parsing and substitution, so tracing for
substituted commands occurs before tracing of the commands
@@ -93,14 +128,59 @@
command, or if there is no command procedure associated with a
command name, then no tracing will occur for that command. If a
string passed to Tcl_Eval contains multiple commands (bracketed, or
-on different lines) then multiple calls to \fIproc\fR will occur,
-one for each command. The \fIcommand\fR string for each of these
-trace calls will reflect only a single command, not the entire string
-passed to Tcl_Eval.
+on different lines) then multiple calls to \fIobjProc\fR will occur,
+one for each command.
.PP
\fBTcl_DeleteTrace\fR removes a trace, so that no future calls will be
made to the procedure associated with the trace. After \fBTcl_DeleteTrace\fR
returns, the caller should never again use the \fItrace\fR token.
-
+.PP
+When \fBTcl_DeleteTrace\fR is called, the interpreter invokes the
+\fIdeleteProc\fR that was passed as a parameter to
+\fBTcl_CreateObjTrace\fR. The \fIdeleteProc\fR must match the type,
+\fBTcl_CmdObjTraceDeleteProc\fR:
+.CS
+typedef void \fBTcl_CmdObjTraceDeleteProc\fR(
+ \fBClientData\fR \fIclientData\fR
+);
+.CE
+The \fIclientData\fR parameter will be the same as the
+\fIclientData\fR parameter that was originally passed to
+\fBTcl_CreateObjTrace\fR.
+.PP
+\fBTcl_CreateTrace\fR is an alternative interface for command tracing,
+\fInot recommended for new applications\fR. It is provided for backward
+compatibility with code that was developed for older versions of the
+Tcl interpreter. It is similar to \fBTcl_CreateObjTrace\fR, except
+that its \fIproc\fR parameter should have arguments and result that
+match the type \fBTcl_CmdTraceProc\fR:
+.CS
+typedef void Tcl_CmdTraceProc(
+ ClientData \fIclientData\fR,
+ Tcl_Interp *\fIinterp\fR,
+ int \fIlevel\fR,
+ char *\fIcommand\fR,
+ Tcl_CmdProc *\fIcmdProc\fR,
+ ClientData \fIcmdClientData\fR,
+ int \fIargc\fR,
+ char *\fIargv\fR[]);
+.CE
+The parameters to the \fIproc\fR callback are similar to those of the
+\fIobjProc\fR callback above. The \fIcommandToken\fR is
+replaced with \fIcmdProc\fR, a pointer to the (string-based) command
+procedure that will be invoked; and \fIcmdClientData\fR, the client
+data that will be passed to the procedure. The \fIobjc\fR parameter
+is replaced with an \fIargv\fR parameter, that gives the arguments to
+the command as character strings.
+\fIProc\fR must not modify the \fIcommand\fR or \fIargv\fR strings.
+.PP
+If a trace created with \fBTcl_CreateTrace\fR is in effect, inline
+compilation of Tcl commands such as \fBif\fR and \fBwhile\fR is always
+disabled. There is no notification when a trace created with
+\fBTcl_CreateTrace\fR is deleted.
+There is no way to be notified when the trace created by
+\fBTcl_CreateTrace\fR is deleted. There is no way for the \fIproc\fR
+associated with a call to \fBTcl_CreateTrace\fR to abort execution of
+\fIcommand\fR.
.SH KEYWORDS
command, create, delete, interpreter, trace
Index: generic/tcl.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.decls,v
retrieving revision 1.68
diff -u -r1.68 tcl.decls
--- generic/tcl.decls 2002/01/09 19:09:28 1.68
+++ generic/tcl.decls 2002/01/11 00:07:49
@@ -7,6 +7,7 @@
#
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
@@ -796,7 +797,7 @@
}
declare 226 generic {
int Tcl_SetCommandInfo(Tcl_Interp *interp, CONST char *cmdName, \
- Tcl_CmdInfo *infoPtr)
+ CONST Tcl_CmdInfo *infoPtr)
}
declare 227 generic {
void Tcl_SetErrno(int err)
@@ -1691,6 +1692,25 @@
# New export due to TIP#73
declare 482 generic {
void Tcl_GetTime( Tcl_Time* timeBuf )
+}
+
+# New exports due to TIP#32
+
+declare 483 generic {
+ Tcl_Trace Tcl_CreateObjTrace( Tcl_Interp* interp,
+ int level,
+ int flags,
+ Tcl_CmdObjTraceProc* objProc,
+ ClientData clientData,
+ Tcl_CmdObjTraceDeleteProc* delProc )
+}
+declare 484 generic {
+ int Tcl_GetCommandInfoFromToken( Tcl_Command token,
+ Tcl_CmdInfo* infoPtr )
+}
+declare 485 generic {
+ int Tcl_SetCommandInfoFromToken( Tcl_Command token,
+ CONST Tcl_CmdInfo* infoPtr )
}
##############################################################################
Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.h,v
retrieving revision 1.107
diff -u -r1.107 tcl.h
--- generic/tcl.h 2001/12/18 15:21:20 1.107
+++ generic/tcl.h 2002/01/11 00:07:50
@@ -8,6 +8,7 @@
* Copyright (c) 1993-1996 Lucent Technologies.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
+ * Copyright (c) 2002 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -574,6 +575,15 @@
typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc,
ClientData cmdClientData, int argc, char *argv[]));
+typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_((
+ ClientData clientData,
+ Tcl_Interp* interp,
+ int level,
+ CONST char* command,
+ Tcl_Command commandInfo,
+ int objc,
+ struct Tcl_Obj *CONST objv[] ));
+typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr,
struct Tcl_Obj *dupPtr));
typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData,
@@ -952,6 +962,8 @@
#define TCL_TRACE_RENAME 0x2000
#define TCL_TRACE_DELETE 0x4000
+
+#define TCL_ALLOW_INLINE_COMPILATION 0x20000
/*
* The TCL_PARSE_PART1 flag is deprecated and has no effect.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.43
diff -u -r1.43 tclBasic.c
--- generic/tclBasic.c 2001/12/14 20:31:22 1.43
+++ generic/tclBasic.c 2002/01/11 00:07:51
@@ -8,7 +8,7 @@
* Copyright (c) 1987-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -32,6 +32,14 @@
static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
static void ProcessUnexpectedResult _ANSI_ARGS_((
Tcl_Interp *interp, int returnCode));
+static int StringTraceProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp* interp,
+ int level,
+ CONST char* command,
+ Tcl_Command commandInfo,
+ int objc,
+ Tcl_Obj *CONST objv[]));
+static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData));
extern TclStubs tclStubs;
@@ -242,6 +250,15 @@
(CompileProc *) NULL, 0}
};
+/*
+ * The following structure holds the client data for string-based
+ * trace procs
+ */
+
+typedef struct StringTraceData {
+ ClientData clientData; /* Client data from Tcl_CreateTrace */
+ Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */
+} StringTraceData;
/*
*----------------------------------------------------------------------
@@ -338,6 +355,7 @@
iPtr->scriptFile = NULL;
iPtr->flags = 0;
iPtr->tracePtr = NULL;
+ iPtr->tracesForbiddingInline = 0;
iPtr->activeCmdTracePtr = NULL;
iPtr->assocData = (Tcl_HashTable *) NULL;
iPtr->execEnvPtr = NULL; /* set after namespaces initialized */
@@ -1053,10 +1071,7 @@
}
TclFreePackageInfo(iPtr);
while (iPtr->tracePtr != NULL) {
- Trace *nextPtr = iPtr->tracePtr->nextPtr;
-
- ckfree((char *) iPtr->tracePtr);
- iPtr->tracePtr = nextPtr;
+ Tcl_DeleteTrace( (Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr );
}
if (iPtr->execEnvPtr != NULL) {
TclDeleteExecEnv(iPtr->execEnvPtr);
@@ -2034,14 +2049,47 @@
Tcl_Interp *interp; /* Interpreter in which to look
* for command. */
CONST char *cmdName; /* Name of desired command. */
- Tcl_CmdInfo *infoPtr; /* Where to find information
+ CONST Tcl_CmdInfo *infoPtr; /* Where to find information
* to store in the command. */
{
Tcl_Command cmd;
- Command *cmdPtr;
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
/*flags*/ 0);
+
+ return Tcl_SetCommandInfoFromToken( cmd, infoPtr );
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetCommandInfoFromToken --
+ *
+ * Modifies various information about a Tcl command. Note that
+ * this procedure will not change a command's namespace; use
+ * Tcl_RenameCommand to do that. Also, the isNativeObjectProc
+ * member of *infoPtr is ignored.
+ *
+ * Results:
+ * If cmdName exists in interp, then the information at *infoPtr
+ * is stored with the command in place of the current information
+ * and 1 is returned. If the command doesn't exist then 0 is
+ * returned.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_SetCommandInfoFromToken( cmd, infoPtr )
+ Tcl_Command cmd;
+ CONST Tcl_CmdInfo* infoPtr;
+{
+ Command* cmdPtr; /* Internal representation of the command */
+
if (cmd == (Tcl_Command) NULL) {
return 0;
}
@@ -2093,11 +2141,41 @@
* command. */
{
Tcl_Command cmd;
- Command *cmdPtr;
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
/*flags*/ 0);
- if (cmd == (Tcl_Command) NULL) {
+
+ return Tcl_GetCommandInfoFromToken( cmd, infoPtr );
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetCommandInfoFromToken --
+ *
+ * Returns various information about a Tcl command.
+ *
+ * Results:
+ * Copies information from the command identified by 'cmd' into
+ * a caller-supplied structure and returns 1. If the 'cmd' is
+ * NULL, leaves the structure untouched and returns 0.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetCommandInfoFromToken( cmd, infoPtr )
+ Tcl_Command cmd;
+ Tcl_CmdInfo* infoPtr;
+{
+
+ Command* cmdPtr; /* Internal representation of the command */
+
+ if ( cmd == (Tcl_Command) NULL ) {
return 0;
}
@@ -2116,7 +2194,9 @@
infoPtr->deleteProc = cmdPtr->deleteProc;
infoPtr->deleteData = cmdPtr->deleteData;
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
+
return 1;
+
}
/*
@@ -2832,11 +2912,12 @@
Command *cmdPtr;
Interp *iPtr = (Interp *) interp;
Tcl_Obj **newObjv;
- int i, code;
+ int i;
Trace *tracePtr, *nextPtr;
- char **argv, *commandCopy;
+ char *commandCopy;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
+ int code = TCL_OK;
if (objc == 0) {
return TCL_OK;
@@ -2881,46 +2962,41 @@
* Call trace procedures if needed.
*/
- if (command != NULL) {
- argv = NULL;
+ if ( command != NULL && iPtr->tracePtr != NULL ) {
commandCopy = command;
+
+ if (length < 0) {
+ length = strlen(command);
+ } else if ((size_t)length < strlen(command)) {
+ commandCopy = (char *) ckalloc((unsigned) (length + 1));
+ strncpy(commandCopy, command, (size_t) length);
+ commandCopy[length] = 0;
+ }
- for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) {
+ for ( tracePtr = iPtr->tracePtr;
+ (code == TCL_OK) && (tracePtr != NULL);
+ tracePtr = nextPtr) {
nextPtr = tracePtr->nextPtr;
if (iPtr->numLevels > tracePtr->level) {
continue;
}
- /*
- * This is a bit messy because we have to emulate the old trace
- * interface, which uses strings for everything.
- */
-
- if (argv == NULL) {
- argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *));
- for (i = 0; i < objc; i++) {
- argv[i] = Tcl_GetString(objv[i]);
- }
- argv[objc] = 0;
-
- if (length < 0) {
- length = strlen(command);
- } else if ((size_t)length < strlen(command)) {
- commandCopy = (char *) ckalloc((unsigned) (length + 1));
- strncpy(commandCopy, command, (size_t) length);
- commandCopy[length] = 0;
- }
- }
- (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
- commandCopy, cmdPtr->proc, cmdPtr->clientData,
- objc, argv);
- }
- if (argv != NULL) {
- ckfree((char *) argv);
+ /* Make a copy of the command if necessary, so that trace
+ * procs will see it. */
+
+ code = (tracePtr->proc)( tracePtr->clientData,
+ (Tcl_Interp*) iPtr,
+ iPtr->numLevels,
+ commandCopy,
+ (Tcl_Command) cmdPtr,
+ objc,
+ objv );
}
+
if (commandCopy != command) {
ckfree((char *) commandCopy);
}
+
}
/*
@@ -2928,12 +3004,14 @@
*/
iPtr->cmdCount++;
- savedVarFramePtr = iPtr->varFramePtr;
- if (flags & TCL_EVAL_GLOBAL) {
- iPtr->varFramePtr = NULL;
+ if ( code == TCL_OK ) {
+ savedVarFramePtr = iPtr->varFramePtr;
+ if (flags & TCL_EVAL_GLOBAL) {
+ iPtr->varFramePtr = NULL;
+ }
+ code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
+ iPtr->varFramePtr = savedVarFramePtr;
}
- code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
- iPtr->varFramePtr = savedVarFramePtr;
if (Tcl_AsyncReady()) {
code = Tcl_AsyncInvoke(interp, code);
}
@@ -4517,6 +4595,114 @@
/*
*----------------------------------------------------------------------
*
+ * Tcl_CreateObjTrace --
+ *
+ * Arrange for a procedure to be called to trace command execution.
+ *
+ * Results:
+ * The return value is a token for the trace, which may be passed
+ * to Tcl_DeleteTrace to eliminate the trace.
+ *
+ * Side effects:
+ * From now on, proc will be called just before a command procedure
+ * is called to execute a Tcl command. Calls to proc will have the
+ * following form:
+ *
+ * void proc( ClientData clientData,
+ * Tcl_Interp* interp,
+ * int level,
+ * CONST char* command,
+ * Tcl_Command commandInfo,
+ * int objc,
+ * Tcl_Obj *CONST objv[] );
+ *
+ * The 'clientData' and 'interp' arguments to 'proc' will be the
+ * same as the arguments to Tcl_CreateObjTrace. The 'level'
+ * argument gives the nesting depth of command interpretation within
+ * the interpreter. The 'command' argument is the ASCII text of
+ * the command being evaluated -- before any substitutions are
+ * performed. The 'commandInfo' argument gives a handle to the
+ * command procedure that will be evaluated. The 'objc' and 'objv'
+ * parameters give the parameter vector that will be passed to the
+ * command procedure. proc does not return a value.
+ *
+ * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo
+ * to change the command procedure or client data for the command
+ * being evaluated, and these changes will take effect with the
+ * current evaluation.
+ *
+ * The 'level' argument specifies the maximum nesting level of calls
+ * to be traced. If the execution depth of the interpreter exceeds
+ * 'level', the trace callback is not executed.
+ *
+ * The 'flags' argument is either zero or the value,
+ * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION
+ * flag is not present, the bytecode compiler will not generate inline
+ * code for Tcl's built-in commands. This behavior will have a significant
+ * impact on performance, but will ensure that all command evaluations are
+ * traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the
+ * bytecode compiler will have its normal behavior of compiling in-line
+ * code for some of Tcl's built-in commands. In this case, the tracing
+ * will be imprecise -- in-line code will not be traced -- but run-time
+ * performance will be improved. The latter behavior is desired for
+ * many applications such as profiling of run time.
+ *
+ * When the trace is deleted, the 'delProc' procedure will be invoked,
+ * passing it the original client data.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Trace
+Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc )
+ Tcl_Interp* interp; /* Tcl interpreter */
+ int level; /* Maximum nesting level */
+ int flags; /* Flags, see above */
+ Tcl_CmdObjTraceProc* proc; /* Trace callback */
+ ClientData clientData; /* Client data for the callback */
+ Tcl_CmdObjTraceDeleteProc* delProc;
+ /* Procedure to call when trace is deleted */
+{
+ register Trace *tracePtr;
+ register Interp *iPtr = (Interp *) interp;
+
+ /* Test if this trace allows inline compilation of commands */
+
+ if ( ! ( flags & TCL_ALLOW_INLINE_COMPILATION ) ) {
+
+ if ( iPtr->tracesForbiddingInline == 0 ) {
+
+ /*
+ * When the first trace forbidding inline compilation is
+ * created, invalidate existing compiled code for this
+ * interpreter and arrange (by setting the
+ * DONT_COMPILE_CMDS_INLINE flag) that when compiling new
+ * code, no commands will be compiled inline (i.e., into
+ * an inline sequence of instructions). We do this because
+ * commands that were compiled inline will never result in
+ * a command trace being called.
+ */
+
+ iPtr->compileEpoch++;
+ iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
+ }
+ ++ iPtr->tracesForbiddingInline;
+ }
+
+ tracePtr = (Trace *) ckalloc(sizeof(Trace));
+ tracePtr->level = level;
+ tracePtr->proc = proc;
+ tracePtr->clientData = clientData;
+ tracePtr->delProc = delProc;
+ tracePtr->nextPtr = iPtr->tracePtr;
+ iPtr->tracePtr = tracePtr;
+
+ return (Tcl_Trace) tracePtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_CreateTrace --
*
* Arrange for a procedure to be called to trace command execution.
@@ -4566,33 +4752,103 @@
* command. */
ClientData clientData; /* Arbitrary value word to pass to proc. */
{
- register Trace *tracePtr;
- register Interp *iPtr = (Interp *) interp;
+
+ StringTraceData* data;
+ data = (StringTraceData*) ckalloc( sizeof( *data ));
+ data->clientData = clientData;
+ data->proc = proc;
+ return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc,
+ (ClientData) data, StringTraceDeleteProc );
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StringTraceProc --
+ *
+ * Invoke a string-based trace procedure from an object-based
+ * callback.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Whatever the string-based trace procedure does.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv )
+ ClientData clientData;
+ Tcl_Interp* interp;
+ int level;
+ CONST char* command;
+ Tcl_Command commandInfo;
+ int objc;
+ Tcl_Obj *CONST *objv;
+{
+ StringTraceData* data = (StringTraceData*) clientData;
+ Command* cmdPtr = (Command*) commandInfo;
+
+ CONST char** argv; /* Args to pass to string trace proc */
+
+ int i;
+
/*
- * Invalidate existing compiled code for this interpreter and arrange
- * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling
- * new code, no commands will be compiled inline (i.e., into an inline
- * sequence of instructions). We do this because commands that were
- * compiled inline will never result in a command trace being called.
+ * This is a bit messy because we have to emulate the old trace
+ * interface, which uses strings for everything.
*/
+
+ argv = (CONST char **) ckalloc((unsigned) ( (objc + 1)
+ * sizeof(CONST char *) ));
+ for (i = 0; i < objc; i++) {
+ argv[i] = Tcl_GetString(objv[i]);
+ }
+ argv[objc] = 0;
- iPtr->compileEpoch++;
- iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
+ /*
+ * Invoke the command procedure. Note that we cast away const-ness
+ * on two parameters for compatibility with legacy code; the code
+ * MUST NOT modify either command or argv.
+ */
+
+ ( data->proc )( data->clientData, interp, level,
+ (char*) command, cmdPtr->proc, cmdPtr->clientData,
+ objc, (char**) argv );
- tracePtr = (Trace *) ckalloc(sizeof(Trace));
- tracePtr->level = level;
- tracePtr->proc = proc;
- tracePtr->clientData = clientData;
- tracePtr->nextPtr = iPtr->tracePtr;
- iPtr->tracePtr = tracePtr;
+ ckfree( (char*) argv );
- return (Tcl_Trace) tracePtr;
+ return TCL_OK;
+
}
/*
*----------------------------------------------------------------------
*
+ * StringTraceDeleteProc --
+ *
+ * Clean up memory when a string-based trace is deleted.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Allocated memory is returned to the system.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+StringTraceDeleteProc( clientData )
+ ClientData clientData;
+{
+ ckfree( (char*) clientData );
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_DeleteTrace --
*
* Remove a trace.
@@ -4613,31 +4869,48 @@
Tcl_Trace trace; /* Token for trace (returned previously by
* Tcl_CreateTrace). */
{
- register Interp *iPtr = (Interp *) interp;
- register Trace *tracePtr = (Trace *) trace;
- register Trace *tracePtr2;
+ Interp *iPtr = (Interp *) interp;
+ Trace *tracePtr = (Trace *) trace;
+ register Trace **tracePtr2 = &( iPtr->tracePtr );
- if (iPtr->tracePtr == tracePtr) {
- iPtr->tracePtr = tracePtr->nextPtr;
- ckfree((char *) tracePtr);
- } else {
- for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
- tracePtr2 = tracePtr2->nextPtr) {
- if (tracePtr2->nextPtr == tracePtr) {
- tracePtr2->nextPtr = tracePtr->nextPtr;
- ckfree((char *) tracePtr);
- break;
- }
+ /*
+ * Locate the trace entry in the interpreter's trace list,
+ * and remove it from the list.
+ */
+
+ while ( (*tracePtr2) != NULL && (*tracePtr2) != tracePtr ) {
+ tracePtr2 = &((*tracePtr2)->nextPtr);
+ }
+ if ( tracePtr2 == NULL ) {
+ return;
+ }
+ (*tracePtr2) = (*tracePtr2)->nextPtr;
+
+ /*
+ * If the trace forbids bytecode compilation, change the interpreter's
+ * state. If bytecode compilation is now permitted, flag the fact and
+ * advance the compilation epoch so that procs will be recompiled to
+ * take advantage of it.
+ */
+
+ if ( ! (tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION ) ) {
+ -- iPtr->tracesForbiddingInline;
+ if ( iPtr->tracesForbiddingInline == 0 ) {
+ iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
+ ++ iPtr->compileEpoch;
}
}
- if (iPtr->tracePtr == NULL) {
- /*
- * When compiling new code, allow commands to be compiled inline.
- */
+ /*
+ * Execute any delete callback.
+ */
- iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
- }
+ ( tracePtr->delProc )( tracePtr->clientData );
+
+ /* Delete the trace object */
+
+ ckfree( (char*) tracePtr );
+
}
/*
Index: generic/tclDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclDecls.h,v
retrieving revision 1.68
diff -u -r1.68 tclDecls.h
--- generic/tclDecls.h 2002/01/09 19:09:28 1.68
+++ generic/tclDecls.h 2002/01/11 00:07:51
@@ -732,7 +732,8 @@
char * optionName, char * newValue));
/* 226 */
EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp,
- CONST char * cmdName, Tcl_CmdInfo * infoPtr));
+ CONST char * cmdName,
+ CONST Tcl_CmdInfo * infoPtr));
/* 227 */
EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err));
/* 228 */
@@ -1510,6 +1511,19 @@
int count));
/* 482 */
EXTERN void Tcl_GetTime _ANSI_ARGS_((Tcl_Time* timeBuf));
+/* 483 */
+EXTERN Tcl_Trace Tcl_CreateObjTrace _ANSI_ARGS_((Tcl_Interp* interp,
+ int level, int flags,
+ Tcl_CmdObjTraceProc* objProc,
+ ClientData clientData,
+ Tcl_CmdObjTraceDeleteProc* delProc));
+/* 484 */
+EXTERN int Tcl_GetCommandInfoFromToken _ANSI_ARGS_((
+ Tcl_Command token, Tcl_CmdInfo* infoPtr));
+/* 485 */
+EXTERN int Tcl_SetCommandInfoFromToken _ANSI_ARGS_((
+ Tcl_Command token,
+ CONST Tcl_CmdInfo* infoPtr));
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -1795,7 +1809,7 @@
void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */
void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */
int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, char * optionName, char * newValue)); /* 225 */
- int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdInfo * infoPtr)); /* 226 */
+ int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */
void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */
void (*tcl_SetErrorCode) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 228 */
void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */
@@ -2052,6 +2066,9 @@
void (*tcl_FSMountsChanged) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 480 */
int (*tcl_EvalTokensStandard) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 481 */
void (*tcl_GetTime) _ANSI_ARGS_((Tcl_Time* timeBuf)); /* 482 */
+ Tcl_Trace (*tcl_CreateObjTrace) _ANSI_ARGS_((Tcl_Interp* interp, int level, int flags, Tcl_CmdObjTraceProc* objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc* delProc)); /* 483 */
+ int (*tcl_GetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, Tcl_CmdInfo* infoPtr)); /* 484 */
+ int (*tcl_SetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, CONST Tcl_CmdInfo* infoPtr)); /* 485 */
} TclStubs;
#ifdef __cplusplus
@@ -4023,6 +4040,18 @@
#ifndef Tcl_GetTime
#define Tcl_GetTime \
(tclStubsPtr->tcl_GetTime) /* 482 */
+#endif
+#ifndef Tcl_CreateObjTrace
+#define Tcl_CreateObjTrace \
+ (tclStubsPtr->tcl_CreateObjTrace) /* 483 */
+#endif
+#ifndef Tcl_GetCommandInfoFromToken
+#define Tcl_GetCommandInfoFromToken \
+ (tclStubsPtr->tcl_GetCommandInfoFromToken) /* 484 */
+#endif
+#ifndef Tcl_SetCommandInfoFromToken
+#define Tcl_SetCommandInfoFromToken \
+ (tclStubsPtr->tcl_SetCommandInfoFromToken) /* 485 */
#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.73
diff -u -r1.73 tclInt.h
--- generic/tclInt.h 2002/01/09 19:09:28 1.73
+++ generic/tclInt.h 2002/01/11 00:07:52
@@ -7,7 +7,7 @@
* Copyright (c) 1993-1997 Lucent Technologies.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -646,9 +646,13 @@
typedef struct Trace {
int level; /* Only trace commands at nesting level
* less than or equal to this. */
- Tcl_CmdTraceProc *proc; /* Procedure to call to trace command. */
+ Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */
ClientData clientData; /* Arbitrary value to pass to proc. */
struct Trace *nextPtr; /* Next in list of traces for this interp. */
+ int flags; /* Flags governing the trace - see
+ * Tcl_CreateObjTrace for details */
+ Tcl_CmdObjTraceDeleteProc* delProc;
+ /* Procedure to call when trace is deleted */
} Trace;
/*
@@ -1301,6 +1305,10 @@
ActiveCommandTrace *activeCmdTracePtr;
/* First in list of active command traces for
* interp, or NULL if no active traces. */
+
+ int tracesForbiddingInline; /* Count of traces (in the list headed by
+ * tracePtr) that forbid inline bytecode
+ * compilation */
/*
* Statistical information about the bytecode compiler and interpreter's
* operation.
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.66
diff -u -r1.66 tclStubInit.c
--- generic/tclStubInit.c 2002/01/05 22:55:52 1.66
+++ generic/tclStubInit.c 2002/01/11 00:07:52
@@ -885,6 +885,9 @@
Tcl_FSMountsChanged, /* 480 */
Tcl_EvalTokensStandard, /* 481 */
Tcl_GetTime, /* 482 */
+ Tcl_CreateObjTrace, /* 483 */
+ Tcl_GetCommandInfoFromToken, /* 484 */
+ Tcl_SetCommandInfoFromToken, /* 485 */
};
/* !END!: Do not edit above this line. */
Index: generic/tclTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTest.c,v
retrieving revision 1.36
diff -u -r1.36 tclTest.c
--- generic/tclTest.c 2002/01/09 17:50:56 1.36
+++ generic/tclTest.c 2002/01/11 00:07:52
@@ -168,8 +168,16 @@
static int NoopObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+static int ObjTraceProc _ANSI_ARGS_(( ClientData clientData,
+ Tcl_Interp* interp,
+ int level,
+ CONST char* command,
+ Tcl_Command commandToken,
+ int objc,
+ Tcl_Obj *CONST objv[] ));
+static void ObjTraceDeleteProc _ANSI_ARGS_(( ClientData ));
static void PrintParse _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Parse *parsePtr));
+ Tcl_Parse *parsePtr));
static void SpecialFree _ANSI_ARGS_((char *blockPtr));
static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));
static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy,
@@ -1003,9 +1011,30 @@
cmdTrace = Tcl_CreateTrace(interp, 50000,
(Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
Tcl_Eval(interp, argv[2]);
+ } else if ( strcmp(argv[1], "resulttest" ) == 0 ) {
+ /* Create an object-based trace, then eval a script. This is used
+ * to test return codes other than TCL_OK from the trace engine.
+ */
+ static int deleteCalled;
+ deleteCalled = 0;
+ cmdTrace = Tcl_CreateObjTrace( interp, 50000,
+ TCL_ALLOW_INLINE_COMPILATION,
+ ObjTraceProc,
+ (ClientData) &deleteCalled,
+ ObjTraceDeleteProc );
+ result = Tcl_Eval( interp, argv[ 2 ] );
+ Tcl_DeleteTrace( interp, cmdTrace );
+ if ( !deleteCalled ) {
+ Tcl_SetResult( interp, "Delete wasn't called", TCL_STATIC );
+ return TCL_ERROR;
+ } else {
+ return result;
+ }
+
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be tracetest or deletetest", (char *) NULL);
+ "\": must be tracetest, deletetest or resulttest",
+ (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1060,6 +1089,41 @@
*/
Tcl_DeleteTrace(interp, cmdTrace);
+}
+
+static int
+ObjTraceProc( clientData, interp, level, command, token, objc, objv )
+ ClientData clientData; /* unused */
+ Tcl_Interp* interp; /* Tcl interpreter */
+ int level; /* Execution level */
+ CONST char* command; /* Command being executed */
+ Tcl_Command token; /* Command information */
+ int objc; /* Parameter count */
+ Tcl_Obj *CONST objv[]; /* Parameter list */
+{
+ CONST char* word = Tcl_GetString( objv[ 0 ] );
+ if ( !strcmp( word, "Error" ) ) {
+ Tcl_SetObjResult( interp, Tcl_NewStringObj( command, -1 ) );
+ return TCL_ERROR;
+ } else if ( !strcmp( word, "Break" ) ) {
+ return TCL_BREAK;
+ } else if ( !strcmp( word, "Continue" ) ) {
+ return TCL_CONTINUE;
+ } else if ( !strcmp( word, "Return" ) ) {
+ return TCL_RETURN;
+ } else if ( !strcmp( word, "OtherStatus" ) ) {
+ return 6;
+ } else {
+ return TCL_OK;
+ }
+}
+
+static void
+ObjTraceDeleteProc( clientData )
+ ClientData clientData;
+{
+ int * intPtr = (int *) clientData;
+ *intPtr = 1; /* Record that the trace was deleted */
}
/*
Index: tests/basic.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/basic.test,v
retrieving revision 1.14
diff -u -r1.14 basic.test
--- tests/basic.test 2002/01/03 18:23:47 1.14
+++ tests/basic.test 2002/01/11 00:07:53
@@ -509,7 +509,38 @@
catch {rename tracer {}}
catch {rename tracedLoop {}}
+test basic-39.5 {Tcl_CreateObjTrace, status return TCL_ERROR} {testcmdtrace} {
+ proc Error { args } { error "Shouldn't get here" }
+ set x 1;
+ list [catch {testcmdtrace resulttest {Error $x}} result] [set result]
+} {1 {Error $x}}
+
+test basic-39.6 {Tcl_CreateObjTrace, status return TCL_RETURN} {testcmdtrace} {
+ proc Return { args } { error "Shouldn't get here" }
+ set x 1;
+ list [catch {testcmdtrace resulttest {Return $x}} result] [set result]
+} {2 {}}
+
+test basic-39.7 {Tcl_CreateObjTrace, status return TCL_BREAK} {testcmdtrace} {
+ proc Break { args } { error "Shouldn't get here" }
+ set x 1;
+ list [catch {testcmdtrace resulttest {Break $x}} result] [set result]
+} {3 {}}
+
+test basic-39.8 {Tcl_CreateObjTrace, status return TCL_CONTINUE} {testcmdtrace} {
+ proc Continue { args } { error "Shouldn't get here" }
+ set x 1;
+ list [catch {testcmdtrace resulttest {Continue $x}} result] [set result]
+} {4 {}}
+
+test basic-39.9 {Tcl_CreateObjTrace, status return unknown} {testcmdtrace} {
+ proc OtherStatus { args } { error "Shouldn't get here" }
+ set x 1;
+ list [catch {testcmdtrace resulttest {OtherStatus $x}} result] [set result]
+} {6 {}}
+
test basic-40.1 {Tcl_DeleteTrace} {emptyTest} {
+ # the above tests have tested Tcl_DeleteTrace
} {}
test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} {
