diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/doc/info.n tcl8.4.6.new/doc/info.n --- tcl8.4.6/doc/info.n Thu Feb 12 17:29:16 2004 +++ tcl8.4.6.new/doc/info.n Mon Jun 14 08:29:25 2004 @@ -124,6 +124,52 @@ variable and may be changed by setting \fBtcl_library\fR. See the \fBtclvars\fR manual entry for more information. .TP +\fBinfo line \fISUBCOMMAND ARGS\fR +The \fBline\fR subcommands access line number information +for procs that were defined via the source command. +Five subcommands are currently defined: line, file and find. +.TP +.RS +.TP +\fBinfo line file \fIprocname \fR?\fIfileName\fR? +For procedures defined via the \fBsource\fR command, +returns the file name that the procedure \fIprocname\fR was sourced +from. If \fIfileName\fR is provided, this is used as the new value. +For procedures not defined via the \fBsource\fR command, +this function does nothing and returns nothing. +.VE +.TP +\fBinfo line find \fIfileName lineNum \fR?\fInamespace\fR? +For procedures defined via the \fBsource\fR command, +find the procedure name defined at line \fIlineNum\fR in file path +\fIfileName\fR. +If found, returns fully namespace qualified procedure name. +This will find only procedures defined via the \fBsource\fR command. +.VE +.TP +\fBinfo line level \fInumber\fR +Like the \fIinfo level\fR command, but returns the line number +and file name from which +the call at level \fInumber\fR originates, when using \fItrace execution\fR. +.VE +.TP +\fBinfo line number \fIprocname \fR?\fIlineNum\fR? +For procedures defined via the \fBsource\fR command, +the line number that a procedure \fIprocname\fR +was defined on. +If \fIlineNum\fR is provided, it is used as the new value. +For procedures not defined via the \fBsource\fR command, +this function does nothing and returns nothing. +.VE +.TP +\fBinfo line relativeerror \fR?\fIBOOL\fR +Set to 1 to disable absolute line number and file path +on a procedure error. This demotes procedure traceback errors +to the same format as all other traceback errors, that is, +using the relative the line number and file name. +.VE +.RE +.TP \fBinfo loaded \fR?\fIinterp\fR? Returns a list describing all of the packages that have been loaded into \fIinterp\fR with the \fBload\fR command. @@ -164,6 +210,12 @@ Matching is determined using the same rules as for \fBstring match\fR. .TP +\fBinfo return\fR +If in \fBtrace execution\fR mode, returns the saved last result of the +previously executed command. Otherwise returns an empty string. +Commands executed as part of a trace handler do not affect or change +the saved last result. +.TP \fBinfo script\fR ?\fIfilename\fR? If a Tcl script file is currently being evaluated (i.e. there is a call to \fBTcl_EvalFile\fR active or there is an active invocation diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/doc/trace.n tcl8.4.6.new/doc/trace.n --- tcl8.4.6/doc/trace.n Wed Oct 8 10:51:07 2003 +++ tcl8.4.6.new/doc/trace.n Thu Jun 17 12:42:28 2004 @@ -201,6 +201,9 @@ are unset). Variables are also unset when interpreters are deleted, but traces will not be invoked because there is no interpreter in which to execute them. +.TP +\fBdebug\fR +Prevent execution trace from triggering during a variable trace. .PP When the trace triggers, three arguments are appended to \fIcommand\fR so that the actual command is as follows: @@ -334,6 +337,67 @@ have any traces set, then the result of the command will be an empty string. .RE +.TP +\fBtrace execution ?\fItarget ?level??\fR +Arrange for an execution trace to be setup for commands at +nesting \fBlevel\fR or above, +thereby providing a simple Tcl interface to trace +commands say, to implement a debugger. +With no arguments, the current \fItarget\fR is returned. +If \fItarget\fR is the empty string, the execution trace is removed. +If the argument \fItarget\fR is not an output \fBchannel\fR name such as +\fBstdout\fR, it is assumed to be a \fBcommand\fR string. +\fBLevel\fR defaults to 0 if not specified, meaning trace all commands. +The following list of arguments are appended before the call: +.RS +.TP +\fBlinenumber\fR + The line number the instruction begins on. +.TP +\fBfilename\fR + The fully normalized file name. +.TP +\fBnestlevel\fR + The nesting level of the command. +.TP +\fBstacklevel\fR + The stack call level as per [info level]. +.TP +\fBcurnsfunc\fR + The current fully qualified namespace/function +.TP +\fBcmdname\fR + The fully qualified command name of the command to be invoked. +.TP +\fBcommand\fR + The command and arguments as a list. +.TP +\fBflags\fR + The bit flags. Bit 0 set indicates this was a breakpoint. +.RE +.PP +.RS +If \fItarget\fR is a valid Tcl channel opened for output, the trace data is +written out to it with an appended newline. +Otherwise \fItarget\fR is presumed to be a valid Tcl command +onto which is appended the above arguments before evaluation. +For channels, an error on output will cause the trace to be removed and +a Tcl error to be generated. +For commands, any return from the command other than a normal return +results in the command not being executed. +.RE +.TP +\fBtrace breakpoint ??\fIline file ?state? ...?\fR +The \fItrace breakpoint\fR manages a list of breakpoints that cause an +\fIexecution trace\fR to trigger, even when the nestlevel is exceeded. +With no arguments it returns a ternery list of all breakpoints in sets +of the triples: line, file, and state. With two arguments, the +current state for the breakpoint is returned. With three or more arguments, +new breakpoints are created. If created with a state <= zero, +the breakpoint is considered inactive. Setting the state of a +breakpoint to the empty string effectively deletes the breakpoint. +A state to \fIN\fR greater than zero triggers every \fINth\fR time. +.RE .PP For backwards compatibility, three other subcommands are available: .RS diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tcl.h tcl8.4.6.new/generic/tcl.h --- tcl8.4.6/generic/tcl.h Thu Feb 12 17:38:00 2004 +++ tcl8.4.6.new/generic/tcl.h Thu Jun 17 12:48:02 2004 @@ -912,6 +912,8 @@ char *dummy8; int dummy9; char* dummy10; + int lineNum; + Tcl_Obj *fileName; } Tcl_CallFrame; @@ -1049,6 +1051,7 @@ #define TCL_TRACE_DELETE 0x4000 #define TCL_ALLOW_INLINE_COMPILATION 0x20000 +#define TCL_TRACE_LINE_NUMBERS 0x40000 /* * Flag values passed to Tcl_CreateObjTrace, and used internally @@ -2131,9 +2134,39 @@ * accommodate most commands; dynamic * space is allocated for very large * commands that don't fit here. */ + int lineNum; /* Line number for start of string. */ + int lineCnt; /* Number of lines in parse. */ + Tcl_Obj *fileName; /* File name of parse string. */ } Tcl_Parse; /* + * Breakpoint support for [trace execution]. + */ +typedef struct Tcl_Breakpoint { + Tcl_Obj *fileName; /* Object containing the file name. */ + int lineNum; /* Line number within file of statement. */ + int state; /* 0=disabled, N=trigger every Nth time.*/ + int counter; /* Counter for when state>1. */ + struct Tcl_Breakpoint *next;/* Pointer to next breakpoint in list. */ +} Tcl_Breakpoint; + +/* + * File and line number information maintained during TRACE_LINE_NUMBERS. + * Retrievable with Tcl_GetSourceInfo() in the Stubs 'C' interface. + */ +typedef struct { + Tcl_Obj *curFileName; /* Object containing the file name. */ + int curLineNum; /* Line number within file of statement. */ + int lastTracedLine; /* Line number of last traced statement. */ + int curCharPos; /* Char position in line, or -1 if unknown. */ + int commandLen; /* Length of command string for cmd trace. */ + int stackLevel; /* The current stacklevel as per [info level] */ + Tcl_Obj* lastResultPtr; /* Result from the last executed command. */ + int flags; /* Bit flags: bit 0 = breakpoint. */ + Tcl_Breakpoint *breakpoints; /* List of breakpoints. */ +} Tcl_SourceInfo; + +/* * The following definitions are the error codes returned by the conversion * routines: * diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclBasic.c tcl8.4.6.new/generic/tclBasic.c --- tcl8.4.6/generic/tclBasic.c Wed Oct 8 16:18:17 2003 +++ tcl8.4.6.new/generic/tclBasic.c Mon Jun 21 12:01:47 2004 @@ -363,6 +363,16 @@ iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ Tcl_IncrRefCount(iPtr->emptyObjPtr); iPtr->resultSpace[0] = 0; + iPtr->lineNum=0; + iPtr->relError = 0; + iPtr->traceExecCmd = NULL; + iPtr->traceExecId = NULL; + iPtr->sourceInfo.curFileName = NULL; + iPtr->sourceInfo.lastResultPtr = NULL; + iPtr->sourceInfo.curCharPos = -1; + iPtr->sourceInfo.flags = 0; + iPtr->sourceInfo.breakpoints = NULL; + Tcl_InitHashTable(&iPtr->sourcedFiles, TCL_STRING_KEYS); iPtr->globalNsPtr = NULL; /* force creation of global ns below */ iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", @@ -1020,6 +1030,16 @@ ckfree((char *) Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(&iPtr->mathFuncTable); + /* + * Tear down the sourced files table. + */ + + for (hPtr = Tcl_FirstHashEntry(&iPtr->sourcedFiles, &search); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + Tcl_DecrRefCount((Tcl_Obj *) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(&iPtr->sourcedFiles); /* * Invoke deletion callbacks; note that a callback can create new @@ -1082,6 +1102,10 @@ } Tcl_DecrRefCount(iPtr->emptyObjPtr); iPtr->emptyObjPtr = NULL; + if (iPtr->sourceInfo.lastResultPtr != NULL) { + Tcl_DecrRefCount(iPtr->sourceInfo.lastResultPtr); + iPtr->sourceInfo.lastResultPtr = NULL; + } resPtr = iPtr->resolverPtr; while (resPtr) { @@ -3086,6 +3110,21 @@ } code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); iPtr->varFramePtr = savedVarFramePtr; + + /* + * When in [trace execution], make copy of result for [info return], + * except when this is inside a trace callback. + */ + if (!(iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { + if (iPtr->sourceInfo.lastResultPtr != NULL) { + Tcl_DecrRefCount(iPtr->sourceInfo.lastResultPtr); + iPtr->sourceInfo.lastResultPtr = NULL; + } + if (iPtr->flags&TRACE_LINE_NUMBERS) { + iPtr->sourceInfo.lastResultPtr = iPtr->objResultPtr; + Tcl_IncrRefCount(iPtr->sourceInfo.lastResultPtr); + } + } } if (Tcl_AsyncReady()) { code = Tcl_AsyncInvoke(interp, code); @@ -3594,7 +3633,7 @@ #define NUM_STATIC_OBJS 20 Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; Tcl_Token *tokenPtr; - int i, code, commandLength, bytesLeft, nested; + int i, code, commandLength, bytesLeft, nested, lineNum; CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr * in case TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); @@ -3631,6 +3670,7 @@ nested = 0; } iPtr->evalFlags = 0; + do { if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) { @@ -3638,6 +3678,8 @@ goto error; } gotParse = 1; + parse.lineNum = iPtr->lineNum; + lineNum = iPtr->sourceInfo.curLineNum; /* Save lineNum subeval may change it. */ if (nested && parse.term == (script + numBytes)) { /* @@ -3673,15 +3715,17 @@ goto error; } } - + /* * Execute the command and free the objects for its words. */ iPtr->numLevels++; + iPtr->sourceInfo.curFileName = parse.fileName; + iPtr->sourceInfo.curLineNum = parse.lineNum; code = TclEvalObjvInternal(interp, objectsUsed, objv, parse.commandStart, parse.commandSize, 0); - iPtr->numLevels--; + iPtr->numLevels--; if (code != TCL_OK) { if (iPtr->numLevels == 0) { if (code == TCL_RETURN) { @@ -3704,6 +3748,9 @@ objv = staticObjArray; } } + if (iPtr != NULL) { + iPtr->lineNum = parse.lineNum + parse.lineCnt; + } /* * Advance to the next command in the script. @@ -4895,6 +4942,10 @@ } iPtr->tracesForbiddingInline++; } + if (flags & TCL_TRACE_LINE_NUMBERS) { + iPtr->flags |= USE_EVAL_DIRECT|TRACE_LINE_NUMBERS; + } + tracePtr = (Trace *) ckalloc(sizeof(Trace)); tracePtr->level = level; @@ -5091,6 +5142,11 @@ } (*tracePtr2) = (*tracePtr2)->nextPtr; + /* Remove global line number trace. */ + if (tracePtr->flags & TCL_TRACE_LINE_NUMBERS) { + iPtr->flags &= ~(USE_EVAL_DIRECT|TRACE_LINE_NUMBERS); + } + /* * If the trace forbids bytecode compilation, change the interpreter's * state. If bytecode compilation is now permitted, flag the fact and @@ -5120,6 +5176,21 @@ } /* + * Tcl_GetSourceInfo -- + * Stubbed interface to get source info associated with a command trace. + */ +Tcl_SourceInfo * +Tcl_GetSourceInfo(interp) + Tcl_Interp *interp; /* Interpreter for traced command. */ +{ + Interp *iPtr = (Interp*) interp; + if (iPtr == NULL) + return NULL; + return &iPtr->sourceInfo; +} + + +/* *---------------------------------------------------------------------- * * Tcl_AddErrorInfo -- diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclCmdAH.c tcl8.4.6.new/generic/tclCmdAH.c --- tcl8.4.6/generic/tclCmdAH.c Fri Dec 12 08:47:47 2003 +++ tcl8.4.6.new/generic/tclCmdAH.c Mon Jun 14 08:29:25 2004 @@ -1615,19 +1615,23 @@ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int result, value; + int result, value, lineNum, curLine; + Interp *iPtr = (Interp*)interp; if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); return TCL_ERROR; } + lineNum = iPtr->lineNum; + iPtr->lineNum = curLine = iPtr->sourceInfo.curLineNum; + result = Tcl_EvalObjEx(interp, objv[1], 0); if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); } - return result; + goto doreturn; } while (1) { /* @@ -1637,9 +1641,10 @@ */ Tcl_ResetResult(interp); + iPtr->lineNum = curLine; result = Tcl_ExprBooleanObj(interp, objv[2], &value); if (result != TCL_OK) { - return result; + goto doreturn; } if (!value) { break; @@ -1654,6 +1659,7 @@ } break; } + iPtr->lineNum = curLine; result = Tcl_EvalObjEx(interp, objv[3], 0); if (result == TCL_BREAK) { break; @@ -1661,7 +1667,7 @@ if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); } - return result; + goto doreturn; } } if (result == TCL_BREAK) { @@ -1670,6 +1676,10 @@ if (result == TCL_OK) { Tcl_ResetResult(interp); } + +doreturn: + iPtr->lineNum = lineNum; + iPtr->sourceInfo.curLineNum = curLine; return result; } @@ -1704,6 +1714,7 @@ int v; /* v selects a loop variable */ int numLists; /* Count of value lists */ Tcl_Obj *bodyPtr; + Interp *iPtr = (Interp*)interp; /* * We copy the argument object pointers into a local array to avoid @@ -1728,6 +1739,7 @@ Tcl_Obj ***varvList = varvListArray; /* Array of var name lists */ int *argcList = argcListArray; /* Array of value list sizes */ Tcl_Obj ***argvList = argvListArray; /* Array of value lists */ + int lineNum; if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1810,6 +1822,7 @@ */ bodyPtr = argObjv[objc-1]; + lineNum = iPtr->lineNum; for (j = 0; j < maxj; j++) { for (i = 0; i < numLists; i++) { /* @@ -1860,6 +1873,7 @@ } } + iPtr->lineNum = lineNum; result = Tcl_EvalObjEx(interp, bodyPtr, 0); if (result != TCL_OK) { if (result == TCL_CONTINUE) { diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclCmdIL.c tcl8.4.6.new/generic/tclCmdIL.c --- tcl8.4.6/generic/tclCmdIL.c Tue Jul 15 08:44:52 2003 +++ tcl8.4.6.new/generic/tclCmdIL.c Mon Jun 14 13:08:34 2004 @@ -124,6 +124,9 @@ static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int InfoLineCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -139,6 +142,9 @@ static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int InfoReturnCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -188,8 +194,12 @@ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int thenScriptIndex = 0; /* then script to be evaled after syntax check */ - int i, result, value; + int i, result, value, lineNum, curLine; char *clause; + Interp *iPtr = (Interp *)interp; + + curLine = iPtr->sourceInfo.curLineNum; + lineNum = iPtr->lineNum; i = 1; while (1) { /* @@ -240,7 +250,8 @@ i++; if (i >= objc) { if (thenScriptIndex) { - return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); + i = thenScriptIndex; + goto doeval; } return TCL_OK; } @@ -274,9 +285,26 @@ return TCL_ERROR; } if (thenScriptIndex) { - return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); + i = thenScriptIndex; + } +doeval: + if (iPtr->flags&TRACE_LINE_NUMBERS) { + int n; + unsigned int nl=0; + for (n=0; nlineNum = curLine + nl; } - return Tcl_EvalObjEx(interp, objv[i], 0); + result = Tcl_EvalObjEx(interp, objv[i], 0); + iPtr->lineNum = lineNum; + iPtr->sourceInfo.curLineNum = curLine; + return result; } /* @@ -399,16 +427,17 @@ static CONST char *subCmds[] = { "args", "body", "cmdcount", "commands", "complete", "default", "exists", "functions", "globals", - "hostname", "level", "library", "loaded", + "hostname", "level", "library", "line", "loaded", "locals", "nameofexecutable", "patchlevel", "procs", - "script", "sharedlibextension", "tclversion", "vars", + "return", "script", "sharedlibextension", "tclversion", "vars", (char *) NULL}; enum ISubCmdIdx { IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx, - IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, + IHostnameIdx, ILevelIdx, ILibraryIdx, ILineIdx, ILoadedIdx, ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, - IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx + IReturnIdx, IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, + IVarsIdx }; int index, result; @@ -460,6 +489,9 @@ case ILibraryIdx: result = InfoLibraryCmd(clientData, interp, objc, objv); break; + case ILineIdx: + result = InfoLineCmd(clientData, interp, objc, objv); + break; case ILoadedIdx: result = InfoLoadedCmd(clientData, interp, objc, objv); break; @@ -475,6 +507,9 @@ case IProcsIdx: result = InfoProcsCmd(clientData, interp, objc, objv); break; + case IReturnIdx: + result = InfoReturnCmd(clientData, interp, objc, objv); + break; case IScriptIdx: result = InfoScriptCmd(clientData, interp, objc, objv); break; @@ -1242,6 +1277,338 @@ /* *---------------------------------------------------------------------- * + * InfoLineCmd -- + * + * Called to implement the "info line" command that accesses the line + * information for procedures created via the source command. + * + * info line SUBCOMMAND ARGS + * + * Current subcommands include: + * info line number PROC ?LINE? + * info line file ?PROC ?FILE?? + * info line find FILE LINE + * info line relerror ?BOOL? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoLineCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + char *subCmd, *procName, *fileName; + Proc *procPtr; + Tcl_Obj *resultPtr, *listPtr, *fileNamePtr = NULL, *nsObj; + char iBuf[50]; + int len, lineNum=0, index, level, i; + Namespace *nsPtr=0; + CallFrame *framePtr = NULL, *callerPtr; + + static CONST char *options[] = { + "current", "number", "find", "file", "files", "level", "relerror", + (char*)NULL + }; + enum options { + ILINE_CURRENT, ILINE_NUMBER, ILINE_FIND, ILINE_FILE, ILINE_FILES, + ILINE_LEVEL, ILINE_RELERROR + }; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "line"); + return TCL_ERROR; + } + + subCmd = Tcl_GetString(objv[2]); + if (Tcl_GetIndexFromObj(interp, objv[2], options, "line", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + + case ILINE_CURRENT: + if (objc != 3) { + Tcl_WrongNumArgs(interp, objc, objv, subCmd); + return TCL_ERROR; + } + resultPtr = Tcl_NewListObj(0, 0); + Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewIntObj(iPtr->sourceInfo.curLineNum)); + Tcl_ListObjAppendElement(interp, resultPtr, + iPtr->sourceInfo.curFileName ? iPtr->sourceInfo.curFileName + : Tcl_NewStringObj("",0)); + Tcl_SetObjResult(interp, resultPtr); + break; + + case ILINE_NUMBER: + + /* + * Get/Set the line number + */ + if (objc < 3 && objc > 5) { + Tcl_WrongNumArgs(interp, objc, objv, subCmd); + return TCL_ERROR; + } + + if (objc == 3) { + resultPtr = Tcl_NewIntObj(iPtr->sourceInfo.curLineNum); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + procName = Tcl_GetString(objv[3]); + procPtr = TclFindProc(iPtr, procName); + if (procPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", procName, "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; + } + if (procPtr->fileName == NULL) { + return TCL_OK; + } + + if (objc >= 5) { + if (Tcl_GetIntFromObj(interp, objv[4], &lineNum) + != TCL_OK) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", Tcl_GetString(objv[4]), + "\" isn't a number", (char *) NULL); + return TCL_ERROR; + } + if ((enum options) index == ILINE_NUMBER) { + procPtr->lineNum=lineNum; + } + } + resultPtr = Tcl_NewIntObj(procPtr->lineNum); + Tcl_SetObjResult(interp, resultPtr); + + return TCL_OK; + + + case ILINE_FILES: + + if (objc != 3) { + Tcl_WrongNumArgs(interp, objc, objv, "line files"); + return TCL_ERROR; + } else { + Tcl_HashEntry *entry; + Tcl_HashSearch se; + Tcl_Obj *cp; + entry=Tcl_FirstHashEntry(&iPtr->sourcedFiles, &se); + resultPtr=Tcl_NewListObj(0,0); + while (entry) { + if ((cp=(Tcl_Obj*)Tcl_GetHashValue(entry))) { + Tcl_ListObjAppendElement(interp,resultPtr, cp); + } + entry=Tcl_NextHashEntry(&se); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + case ILINE_FILE: + /* + * Set/Get the filename a the given PROC + */ + if (objc < 3 && objc > 5) { + Tcl_WrongNumArgs(interp, objc, objv, "line file"); + return TCL_ERROR; + } + + if (objc == 3) { + resultPtr = iPtr->sourceInfo.curFileName; + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + procName = Tcl_GetString(objv[3]); + procPtr = TclFindProc(iPtr, procName); + if (procPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", procName, "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; + } + + if (procPtr->fileName == NULL) { + return TCL_OK; + } + if (objc == 4) { + resultPtr = procPtr->fileName; + Tcl_IncrRefCount(resultPtr); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + fileName=Tcl_GetStringFromObj(objv[5],&len); + Tcl_SetStringObj(procPtr->fileName,fileName,len); + return TCL_OK; + + + case ILINE_FIND: + + /* + * Find a proc given the filename and line number + optional namespace + * that can reduce the cost of the search. + */ + + if (objc != 5) { + Tcl_WrongNumArgs(interp, objc, objv, "line find fileName lineNum"); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[4], &lineNum) != TCL_OK) { + return TCL_ERROR; + } + if (TclFindProcByLine(iPtr, objv[3], lineNum, nsPtr, &resultPtr)) { + Tcl_SetObjResult(interp, resultPtr); + } + + return TCL_OK; + + + /* + * Set to 0 to report relative line number/filename on proc error. + * tcltest needs this to avoid breaking tests. + */ + + case ILINE_RELERROR: + + if (objc < 4 && objc > 5) { + Tcl_WrongNumArgs(interp, objc, objv, subCmd); + return TCL_ERROR; + } + + if (objc >= 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &iPtr->relError) + != TCL_OK) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", Tcl_GetString(objv[4]), + "\" isn't a number", (char *) NULL); + return TCL_ERROR; + } + } + sprintf(iBuf,"%d", iPtr->relError); + resultPtr = Tcl_NewStringObj(iBuf,-1); + Tcl_SetObjResult(interp, resultPtr); + + return TCL_OK; + + case ILINE_LEVEL: + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "?level?"); + return TCL_ERROR; + } + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level > 0) { + goto levelError; + } + } else { + level = 0; + } + + listPtr = resultPtr = Tcl_NewListObj(0,0); + i = 0; + while (1) { + if (i == 0) { + lineNum = iPtr->sourceInfo.lastTracedLine; + fileNamePtr = iPtr->sourceInfo.curFileName; + callerPtr = iPtr->varFramePtr; + } else { + if (i == -1) { + framePtr = iPtr->varFramePtr; + } else { + framePtr = framePtr->callerVarPtr; + } + if (framePtr == NULL) { + if (objc == 4) + goto levelError; + else + break; + } + + lineNum = framePtr->lineNum; + fileNamePtr = framePtr->fileName; + callerPtr = (framePtr?framePtr->callerVarPtr:NULL); + } + if (objc == 3) { + listPtr = Tcl_NewListObj(0,0); + } + if (objc == 3 || level == i) { + /* Append the following: line, file, level, proc, fullcmd */ + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewIntObj(lineNum)); + Tcl_ListObjAppendElement(interp, listPtr, + fileNamePtr ? fileNamePtr : Tcl_NewStringObj("",0)); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewIntObj(callerPtr?callerPtr->level:0)); + + /* Append the current fully namespace qualified function. */ + if (callerPtr == NULL) { + nsObj = Tcl_NewStringObj("::",-1); + } else if (callerPtr->isProcCallFrame) { + Tcl_Command f = Tcl_GetCommandFromObj(interp, + callerPtr->objv[0]); + nsObj = Tcl_NewStringObj("", 0); + Tcl_GetCommandFullName(interp, f, nsObj); + } else if (callerPtr->nsPtr && callerPtr->nsPtr->fullName) { + nsObj = Tcl_NewStringObj(callerPtr->nsPtr->fullName,-1); + Tcl_AppendToObj(nsObj, "::", 2); + } else { + nsObj = Tcl_NewStringObj("", 0); + } + Tcl_ListObjAppendElement(interp, listPtr, nsObj); + + if (callerPtr == NULL) { + nsObj = Tcl_NewStringObj("", 0); + } else { + nsObj = Tcl_NewListObj(callerPtr->objc, callerPtr->objv); + } + Tcl_ListObjAppendElement(interp, listPtr, nsObj); + + if (objc == 4) { + break; + } + } + if (objc == 3) { + Tcl_ListObjAppendElement(interp, resultPtr, listPtr); + } + i--; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + + levelError: + if (resultPtr != NULL) { + Tcl_DecrRefCount(resultPtr); + } + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad level \"", + Tcl_GetString(objv[3]), + "\"", (char *) NULL); + return TCL_ERROR; + + } + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown subcommand: ", + "\"", subCmd, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * InfoLoadedCmd -- * * Called to implement the "info loaded" command that returns the @@ -1660,6 +2027,45 @@ /* *---------------------------------------------------------------------- * + * InfoReturnCmd -- + * + * Called to implement the "info return" command that returns the + * value returned by the previous command when in [trace execution]. + * + * info return + * + * Results: + * Returns TCL_OK. + * + * Side effects: + * Sets the interpreter's result object to the results of the + * previous command. + * + *---------------------------------------------------------------------- + */ + +static int +InfoReturnCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return TCL_ERROR; + } + + if (iPtr->sourceInfo.lastResultPtr != NULL && iPtr->flags&TRACE_LINE_NUMBERS) { + Tcl_SetObjResult(interp, iPtr->sourceInfo.lastResultPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * InfoScriptCmd -- * * Called to implement the "info script" command that returns the @@ -1700,6 +2106,8 @@ } iPtr->scriptFile = objv[2]; Tcl_IncrRefCount(iPtr->scriptFile); + iPtr->sourceInfo.curFileName = + TclFSGetSourceFile(interp, iPtr->scriptFile); } if (iPtr->scriptFile != NULL) { Tcl_SetObjResult(interp, iPtr->scriptFile); diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclCmdMZ.c tcl8.4.6.new/generic/tclCmdMZ.c --- tcl8.4.6/generic/tclCmdMZ.c Mon Mar 1 12:18:46 2004 +++ tcl8.4.6.new/generic/tclCmdMZ.c Mon Jun 21 14:39:01 2004 @@ -131,6 +131,151 @@ Tcl_Interp *interp, CONST char *oldName, CONST char *newName, int flags)); static Tcl_CmdObjTraceProc TraceExecutionProc; +static int TraceExecProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp* interp, + int level, + CONST char* command, + Tcl_Command commandInfo, + int objc, + Tcl_Obj *CONST objv[])); + +/* + * TraceExecProc -- + * Trace handler for the "trace execution TARGET" command. + * The handler produces the following list: + * + * - The line number the current instruction begins on. + * - The fully normalized file name. + * - The nesting level of the command. + * - The stack call level as per [info level]. + * - The fully qualified command name of the command being invoked. + * - The command to be invoked including arguments. + * - The current fully namespace:: qualified function + * + * If TARGET is a valid Tcl channel opened for output, the list + nl is + * output to it, otherwise TARGET is presumed to be a valid Tcl command + * to which the list elements are appended as arguments before eval. + */ +static int +TraceExecProc (clientData, interp, level, command, commandInfo, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int level; + CONST char *command; + Tcl_Command commandInfo; + int objc; + struct Tcl_Obj * CONST * objv; +{ + Interp *iPtr = (Interp *)interp; + Tcl_SourceInfo *srcInfo; + Tcl_Obj *obj, *nobj, *nsObj = NULL; + Tcl_Obj **listv; + int len, lineNum, curLine, mode = 0, result = TCL_OK; + Tcl_Channel channel = NULL; + CONST char *cmdName; + + srcInfo = &iPtr->sourceInfo; + srcInfo->lastTracedLine = srcInfo->curLineNum; + if (iPtr->traceExecCmd == NULL) + return TCL_OK; + cmdName = Tcl_GetString(iPtr->traceExecCmd); + if (*cmdName == '1' && cmdName[1] == 0) { + return TCL_OK; + } + if (Tcl_ListObjGetElements(interp, iPtr->traceExecCmd, &len, &listv) + != TCL_OK) { + return TCL_ERROR; + } + if (len == 1 && ((channel=Tcl_GetChannel(interp, Tcl_GetString(listv[0]), + &mode)) != NULL) && (mode&TCL_WRITABLE)) { + obj = Tcl_NewListObj(0, 0); + } else { + obj = Tcl_NewListObj(len, listv); + } + Tcl_IncrRefCount(obj); + Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(srcInfo->curLineNum)); + Tcl_ListObjAppendElement(interp, obj, + srcInfo->curFileName?srcInfo->curFileName: + Tcl_NewStringObj("",0)); + + Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(level)); + Tcl_ListObjAppendElement(interp, obj, + Tcl_NewIntObj(iPtr->sourceInfo.stackLevel)); + + /* Append the current fully namespace qualified function. */ + if (iPtr->varFramePtr == NULL) { + nsObj = Tcl_NewStringObj("::",-1); + } else if (iPtr->varFramePtr->isProcCallFrame) { + Tcl_Command f = Tcl_GetCommandFromObj(interp, + iPtr->varFramePtr->objv[0]); + nsObj = Tcl_NewStringObj("", 0); + Tcl_GetCommandFullName(interp, f, nsObj); + } else if (iPtr->varFramePtr->nsPtr && iPtr->varFramePtr->nsPtr->fullName) { + nsObj = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName,-1); + Tcl_AppendToObj(nsObj, "::", 2); + } else { + nsObj = Tcl_NewStringObj("", 0); + } + Tcl_ListObjAppendElement(interp, obj, nsObj); + nobj = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, commandInfo, nobj); + Tcl_ListObjAppendElement(interp, obj, nobj); + Tcl_ListObjAppendElement(interp, obj, Tcl_NewListObj(objc, objv)); + + /* Set the breakpoint flag if necessary. */ + if ((!(iPtr->sourceInfo.flags&1)) && iPtr->sourceInfo.breakpoints != NULL) { + Tcl_Breakpoint *curBP = iPtr->sourceInfo.breakpoints; + + while (curBP != NULL) { + if (curBP->state>0 && + curBP->lineNum == iPtr->sourceInfo.curLineNum && + curBP->fileName == iPtr->sourceInfo.curFileName) { + if ((curBP->counter=(curBP->counter+1)%curBP->state)==0) { + break; + } + } + curBP = curBP->next; + } + if (curBP != NULL) { + iPtr->sourceInfo.flags |= 1; + } + } + Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(srcInfo->flags)); + iPtr->sourceInfo.flags &= ~1; /* Clear the breakpoint flag. */ + + + lineNum = iPtr->lineNum; + curLine = iPtr->sourceInfo.curLineNum; + iPtr->flags |= INTERP_TRACE_IN_PROGRESS; + if (channel != NULL) { + if (Tcl_WriteObj(channel, obj) <0 || Tcl_Write(channel, "\n", 1) <0) { + /* If closed or an IO error occurred, remove the trace. */ + Tcl_GlobalEval(interp, "trace executon {}"); + Tcl_AddErrorInfo(interp, "Execution trace error writing channel: "); + Tcl_BackgroundError( interp ); + } + } else { + Tcl_SavedResult state; + + Tcl_SaveResult(interp, &state); + + result = Tcl_EvalObjEx(interp, obj, TCL_EVAL_DIRECT); + if (result == TCL_OK) { + /* Restore result if trace execution was successful */ + Tcl_RestoreResult(interp, &state); + } else { + Tcl_DiscardResult(&state); + } + + } + Tcl_DecrRefCount(obj); + iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS; + iPtr->lineNum = lineNum; + iPtr->sourceInfo.curLineNum = curLine; + + return result; +} + /* *---------------------------------------------------------------------- @@ -2696,8 +2841,10 @@ { int i, j, index, mode, matched, result, splitObjs; char *string, *pattern; - Tcl_Obj *stringObj; + Tcl_Obj *stringObj, *bodyObj; Tcl_Obj *CONST *savedObjv = objv; + Interp *iPtr = (Interp *)interp; + int lineNum, curLine; static CONST char *options[] = { "-exact", "-glob", "-regexp", "--", NULL @@ -2706,6 +2853,9 @@ OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST }; + curLine = iPtr->sourceInfo.curLineNum; + lineNum = iPtr->lineNum; + mode = OPT_EXACT; for (i = 1; i < objc; i++) { string = Tcl_GetString(objv[i]); @@ -2742,6 +2892,7 @@ if (objc == 1) { Tcl_Obj **listv; + bodyObj = objv[0]; if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -2854,7 +3005,49 @@ break; } } + if (iPtr->flags&TRACE_LINE_NUMBERS) { + CONST char *cp, *match; + int n; + unsigned int mLen, nl=0; + + /* Count the newlines in the preceding code. */ + if (splitObjs) { + /* Search body for matching strings, counting \n as we go. */ + cp = string; + while (*cp) { + if (*cp++ == '\n') + nl++; + } + cp = Tcl_GetString(bodyObj); + for (n=0; n= (j-1)) + break; + while (*cp && mLen-- > 0) { + if (*cp++ == '\n') + nl++; + } + } + } else { + for (n=0; nlineNum = curLine + nl; + } result = Tcl_EvalObjEx(interp, objv[j], 0); + iPtr->lineNum = lineNum; + iPtr->sourceInfo.curLineNum = curLine; if (result == TCL_ERROR) { char msg[100 + TCL_INTEGER_SPACE]; @@ -2965,7 +3158,7 @@ size_t length; /* Main sub commands to 'trace' */ static CONST char *traceOptions[] = { - "add", "info", "remove", + "add", "info", "remove", "execution", "breakpoint", #ifndef TCL_REMOVE_OBSOLETE_TRACES "variable", "vdelete", "vinfo", #endif @@ -2973,7 +3166,7 @@ }; /* 'OLD' options are pre-Tcl-8.4 style */ enum traceOptions { - TRACE_ADD, TRACE_INFO, TRACE_REMOVE, + TRACE_ADD, TRACE_INFO, TRACE_REMOVE, TRACE_EXECUTION, TRACE_BREAKPOINT, #ifndef TCL_REMOVE_OBSOLETE_TRACES TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO #endif @@ -3008,6 +3201,124 @@ } return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); } + case TRACE_EXECUTION: { + Interp *iPtr = (Interp *)interp; + int strLen, level=0; + + if (objc == 2) { + if (iPtr->traceExecCmd != NULL) { + Tcl_SetObjResult(interp, iPtr->traceExecCmd); + } + return TCL_OK; + } + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "command ?level?"); + return TCL_ERROR; + } + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { + return TCL_ERROR; + } + } + if (iPtr->traceExecCmd != NULL) { + Tcl_DecrRefCount(iPtr->traceExecCmd); + iPtr->traceExecCmd = NULL; + } + p = Tcl_GetStringFromObj(objv[2], &strLen); + if (iPtr->traceExecId != NULL) { + Tcl_DeleteTrace(interp, iPtr->traceExecId); + iPtr->traceExecId = NULL; + } + if (strLen>0 && (strcmp(p,"0"))) { + iPtr->traceExecCmd = objv[2]; + Tcl_IncrRefCount(objv[2]); + iPtr->traceExecId = Tcl_CreateObjTrace(interp, level, TCL_TRACE_LINE_NUMBERS, TraceExecProc, 0, 0); + } + return TCL_OK; + break; + } + case TRACE_BREAKPOINT: { + Interp *iPtr = (Interp *)interp; + Tcl_Breakpoint *curBP = iPtr->sourceInfo.breakpoints; + Tcl_Obj *listPtr; + int idx; + + if (objc == 2) { + if (!curBP) { + return TCL_OK; + } + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + while (curBP) { + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewIntObj(curBP->lineNum)); + Tcl_ListObjAppendElement(NULL, listPtr, curBP->fileName); + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewIntObj(curBP->state)); + curBP = curBP->next; + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + if ((objc%3) == 0) { + Tcl_WrongNumArgs(interp, 2, objv, "line file ?state ...?"); + return TCL_ERROR; + } + idx = 2; + while ((idx+1)sourceInfo.breakpoints; + while (curBP != NULL) { + if (curBP->lineNum == lineNum + && (!strcmp(Tcl_GetString(fileName), + Tcl_GetString(curBP->fileName)))) { + break; + } + curBP = curBP->next; + } + if ((idx+2)>objc) { + if (curBP == NULL) { + Tcl_AppendResult(interp, "Breakpoint not found", 0); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(curBP->state)); + return TCL_OK; + } + if (curBP == NULL) { + curBP = (Tcl_Breakpoint*) ckalloc(sizeof(Tcl_Breakpoint)); + curBP->next = iPtr->sourceInfo.breakpoints; + iPtr->sourceInfo.breakpoints = curBP; + curBP->lineNum = lineNum; + curBP->fileName = TclFSGetSourceFile(interp, fileName); + } + curBP->counter = 0; + /* The empty state means delete the breakpoint. */ + if (strlen(Tcl_GetString(objv[idx+2])) == 0) { + Tcl_Breakpoint *prevBP = iPtr->sourceInfo.breakpoints; + + while (prevBP != NULL && prevBP->next != curBP) { + prevBP = prevBP->next; + } + if (prevBP != NULL) { + prevBP->next = curBP->next; + } else { + iPtr->sourceInfo.breakpoints = curBP->next; + } + ckfree((char*) curBP); + } else if (Tcl_GetIntFromObj(interp, objv[idx+2], + &curBP->state) != TCL_OK) { + return TCL_ERROR; + } + idx += 3; + } + break; + } + #ifndef TCL_REMOVE_OBSOLETE_TRACES case TRACE_OLD_VARIABLE: { int flags; @@ -3647,9 +3958,10 @@ size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; static CONST char *opStrings[] = { "array", "read", "unset", "write", + "debug", (char *) NULL }; enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, - TRACE_VAR_WRITE }; + TRACE_VAR_WRITE, TRACE_VAR_DEBUG }; switch ((enum traceOptions) optionIndex) { case TRACE_ADD: @@ -3673,7 +3985,7 @@ } if (listLen == 0) { Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of array, read, unset, or write", + "one or more of array, read, unset, write, or debug", TCL_STATIC); return TCL_ERROR; } @@ -3695,6 +4007,9 @@ case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; + case TRACE_VAR_DEBUG: + flags |= TCL_TRACE_LINE_NUMBERS; + break; } } command = Tcl_GetStringFromObj(objv[5], &commandLength); @@ -3781,6 +4096,10 @@ Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("unset", 5)); } + if (tvarPtr->flags & TCL_TRACE_LINE_NUMBERS) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("debug", 5)); + } eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); @@ -4333,7 +4652,26 @@ active.nextTracePtr = tracePtr->nextPtr; } if (tracePtr->level > 0 && curLevel > tracePtr->level) { - continue; + Tcl_Breakpoint *curBP = iPtr->sourceInfo.breakpoints; + + if ((!(tracePtr->flags&TCL_TRACE_LINE_NUMBERS)) || curBP == NULL) { + continue; + } + /* Determine we are at a breakpoint. */ + while (curBP != NULL) { + if (curBP->state>0 && + curBP->lineNum == iPtr->sourceInfo.curLineNum && + curBP->fileName == iPtr->sourceInfo.curFileName) { + if ((curBP->counter=(curBP->counter+1)%curBP->state)==0) { + break; + } + } + curBP = curBP->next; + } + if (curBP == NULL) { + continue; + } + iPtr->sourceInfo.flags |= 1; } if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) { /* @@ -4412,26 +4750,35 @@ Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; - char *commandCopy; + char *commandCopy = NULL; int traceCode; - /* - * Copy the command characters into a new string. - */ - - commandCopy = (char *) ckalloc((unsigned) (numChars + 1)); - memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars); - commandCopy[numChars] = '\0'; + if (tracePtr->flags&TCL_TRACE_LINE_NUMBERS) { + iPtr->sourceInfo.commandLen = numChars; + iPtr->sourceInfo.stackLevel = iPtr->varFramePtr==NULL ? 0 : + iPtr->varFramePtr->level; + } else { + /* + * Copy the command characters into a new string. + */ + + commandCopy = (char *) ckalloc((unsigned) (numChars + 1)); + memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars); + commandCopy[numChars] = '\0'; + command = commandCopy; + } /* * Call the trace procedure then free allocated storage. */ traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr, - iPtr->numLevels, commandCopy, + iPtr->numLevels, command, (Tcl_Command) cmdPtr, objc, objv ); - ckfree((char *) commandCopy); + if (commandCopy != NULL) { + ckfree((char *) commandCopy); + } return(traceCode); } @@ -4702,8 +5049,9 @@ Tcl_SavedResult state; TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; char *result; - int code; + int code, setTrace = 0; Tcl_DString cmd; + Interp *iPtr = (Interp *)interp; /* * We might call Tcl_Eval() below, and that might evaluate @@ -4737,6 +5085,8 @@ Tcl_DStringAppend(&cmd, " w", 2); } else if (flags & TCL_TRACE_UNSETS) { Tcl_DStringAppend(&cmd, " u", 2); + } else if (flags & TCL_TRACE_LINE_NUMBERS) { + Tcl_DStringAppend(&cmd, " d", 2); } } else { #endif @@ -4748,6 +5098,8 @@ Tcl_DStringAppend(&cmd, " write", 6); } else if (flags & TCL_TRACE_UNSETS) { Tcl_DStringAppend(&cmd, " unset", 6); + } else if (flags & TCL_TRACE_LINE_NUMBERS) { + Tcl_DStringAppend(&cmd, " debug", 6); } #ifndef TCL_REMOVE_OBSOLETE_TRACES } @@ -4767,8 +5119,17 @@ tvarPtr->flags |= TCL_TRACE_DESTROYED; } - code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), - Tcl_DStringLength(&cmd), 0); + if (flags&TCL_TRACE_LINE_NUMBERS && + (!(iPtr->flags&INTERP_TRACE_IN_PROGRESS))) { + iPtr->flags |= INTERP_TRACE_IN_PROGRESS; + setTrace = 1; + } + code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), + Tcl_DStringLength(&cmd), 0); + if (setTrace) { + iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS; + } + if (code != TCL_OK) { /* copy error msg to result */ register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errMsgObj); @@ -4822,14 +5183,18 @@ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int result, value; + int result, value, lineNum, oldLine; + Interp *iPtr = (Interp*)interp; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "test command"); return TCL_ERROR; } + oldLine = iPtr->lineNum; + lineNum = iPtr->sourceInfo.curLineNum; while (1) { + iPtr->lineNum = lineNum; result = Tcl_ExprBooleanObj(interp, objv[1], &value); if (result != TCL_OK) { return result; @@ -4849,6 +5214,7 @@ break; } } + iPtr->lineNum = oldLine; if (result == TCL_BREAK) { result = TCL_OK; } diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclCompile.c tcl8.4.6.new/generic/tclCompile.c --- tcl8.4.6/generic/tclCompile.c Fri Jul 18 16:35:38 2003 +++ tcl8.4.6.new/generic/tclCompile.c Mon Jun 14 08:47:05 2004 @@ -286,7 +286,7 @@ int numSrcBytes, int numCodeBytes)); static void EnterCmdStartData _ANSI_ARGS_(( CompileEnv *envPtr, int cmdNumber, - int srcOffset, int codeOffset)); + int srcOffset, int codeOffset, Interp *iPtr)); static void FreeByteCodeInternalRep _ANSI_ARGS_(( Tcl_Obj *objPtr)); static int GetCmdLocEncodingSize _ANSI_ARGS_(( @@ -845,10 +845,12 @@ bytesLeft = numBytes; gotParse = 0; do { + envPtr->startLine = iPtr->lineNum; if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) { code = TCL_ERROR; goto error; } + parse.lineNum = iPtr->lineNum; /* Save lineNum subeval may change it. */ gotParse = 1; if (nested) { /* @@ -951,7 +953,8 @@ } startCodeOffset = (envPtr->codeNext - envPtr->codeStart); EnterCmdStartData(envPtr, currCmdIndex, - (parse.commandStart - envPtr->source), startCodeOffset); + (parse.commandStart - envPtr->source), startCodeOffset, + iPtr); for (wordIdx = 0, tokenPtr = parse.tokenPtr; wordIdx < parse.numWords; @@ -1076,6 +1079,9 @@ next = parse.commandStart + parse.commandSize; bytesLeft -= (next - p); p = next; + if (iPtr != NULL) { + iPtr->lineNum = parse.lineNum + parse.lineCnt; + } Tcl_FreeParse(&parse); gotParse = 0; if (nested && (*parse.term == ']')) { @@ -2026,7 +2032,7 @@ */ static void -EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) +EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset, iPtr) CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ @@ -2034,6 +2040,7 @@ * is being set. */ int srcOffset; /* Offset of first char of the command. */ int codeOffset; /* Offset of first byte of command code. */ + Interp *iPtr; /* Interpreter for line number info. */ { CmdLocation *cmdLocPtr; @@ -2079,6 +2086,9 @@ cmdLocPtr->srcOffset = srcOffset; cmdLocPtr->numSrcBytes = -1; cmdLocPtr->numCodeBytes = -1; + cmdLocPtr->numCodeBytes = -1; + cmdLocPtr->srcLineNum = iPtr->lineNum; + cmdLocPtr->fileName = iPtr->sourceInfo.curFileName; } /* @@ -2854,6 +2864,8 @@ int codeDelta, codeLen, srcDelta, srcLen, prevOffset; register int i; + codePtr->startLineNum = envPtr->startLine; + codePtr->fileName = envPtr->iPtr->sourceInfo.curFileName; /* * Encode the code offset for each command as a sequence of deltas. */ diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclCompile.h tcl8.4.6.new/generic/tclCompile.h --- tcl8.4.6/generic/tclCompile.h Wed Oct 9 04:54:05 2002 +++ tcl8.4.6.new/generic/tclCompile.h Mon Jun 14 08:47:49 2004 @@ -119,6 +119,8 @@ int numCodeBytes; /* Number of bytes for command's code. */ int srcOffset; /* Offset of first char of the command. */ int numSrcBytes; /* Number of command source chars. */ + int srcLineNum; /* The line number in the source. */ + Tcl_Obj *fileName; /* File containing source, if any. */ } CmdLocation; /* @@ -264,6 +266,7 @@ /* Initial storage for cmd location map. */ AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; /* Initial storage for aux data array. */ + int startLine; } CompileEnv; /* @@ -377,6 +380,8 @@ * are always positive. This sequence is * just after the last byte in the source * delta sequence. */ + int startLineNum; /* The line number of the first instruction. */ + Tcl_Obj *fileName; /* Source file. */ #ifdef TCL_COMPILE_STATS Tcl_Time createTime; /* Absolute time when the ByteCode was * created. */ diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclExecute.c tcl8.4.6.new/generic/tclExecute.c --- tcl8.4.6/generic/tclExecute.c Fri Sep 19 11:43:00 2003 +++ tcl8.4.6.new/generic/tclExecute.c Mon Jun 21 09:56:54 2004 @@ -362,7 +362,7 @@ static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc, int catchOnly, ByteCode* codePtr)); static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, - ByteCode* codePtr, int *lengthPtr)); + ByteCode* codePtr, int *lengthPtr, Interp *iPtr)); static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); static void IllegalExprOperandType _ANSI_ARGS_(( Tcl_Interp *interp, unsigned char *pc, @@ -1366,12 +1366,13 @@ tracePtr = nextTracePtr) { nextTracePtr = tracePtr->nextPtr; if (tracePtr->level == 0 || - iPtr->numLevels <= tracePtr->level) { + iPtr->numLevels <= tracePtr->level || + iPtr->sourceInfo.breakpoints != NULL) { /* * Traces will be called: get command string */ - bytes = GetSrcInfoForPc(pc, codePtr, &length); + bytes = GetSrcInfoForPc(pc, codePtr, &length, iPtr); break; } } @@ -1379,7 +1380,7 @@ Command *cmdPtr; cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - bytes = GetSrcInfoForPc(pc, codePtr, &length); + bytes = GetSrcInfoForPc(pc, codePtr, &length, iPtr); } } @@ -4121,7 +4122,7 @@ checkForCatch: if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - bytes = GetSrcInfoForPc(pc, codePtr, &length); + bytes = GetSrcInfoForPc(pc, codePtr, &length, iPtr); if (bytes != NULL) { DECACHE_STACK_INFO(); Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); @@ -4327,7 +4328,7 @@ } if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) { int numChars; - char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, iPtr); char *ellipsis = ""; fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)", @@ -4509,7 +4510,7 @@ */ static char * -GetSrcInfoForPc(pc, codePtr, lengthPtr) +GetSrcInfoForPc(pc, codePtr, lengthPtr, iPtr) unsigned char *pc; /* The program counter value for which to * return the closest command's source info. * This points to a bytecode instruction @@ -4519,6 +4520,7 @@ int *lengthPtr; /* If non-NULL, the location where the * length of the command's source should be * stored. If NULL, no length is stored. */ + Interp *iPtr; { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; @@ -4603,6 +4605,13 @@ if (lengthPtr != NULL) { *lengthPtr = bestSrcLength; } + if (iPtr != NULL) { + iPtr->sourceInfo.curLineNum = iPtr->lineNum; + for (i=0; isource[i] == '\n') + iPtr->sourceInfo.curLineNum++; + } + } return (codePtr->source + bestSrcOffset); } diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclIOUtil.c tcl8.4.6.new/generic/tclIOUtil.c --- tcl8.4.6/generic/tclIOUtil.c Tue Feb 17 17:59:09 2004 +++ tcl8.4.6.new/generic/tclIOUtil.c Mon Jun 14 08:59:32 2004 @@ -121,6 +121,7 @@ extern CONST char * tclpFileAttrStrings[]; extern CONST TclFileAttrProcs tclpFileAttrProcs[]; + /* * The following functions are obsolete string based APIs, and should * be removed in a future release (Tcl 9 would be a good time). @@ -1667,6 +1668,30 @@ return mode; } +Tcl_Obj* +TclFSGetSourceFile(interp, pathPtr) + Tcl_Interp *interp; + Tcl_Obj *pathPtr; +{ + int isnew; + Tcl_HashEntry *entry; + Interp *iPtr = (Interp *)interp; + Tcl_Obj *newPtr; + + if (!pathPtr) + return NULL; + entry=Tcl_CreateHashEntry(&iPtr->sourcedFiles, + Tcl_GetString(iPtr->scriptFile), &isnew); + if (isnew) { + newPtr = Tcl_DuplicateObj(iPtr->scriptFile); + Tcl_IncrRefCount(newPtr); + Tcl_SetHashValue(entry, newPtr); + } else { + newPtr = (Tcl_Obj*)Tcl_GetHashValue(entry); + } + return newPtr; +} + /* *---------------------------------------------------------------------- * @@ -1701,6 +1726,7 @@ char *string; Tcl_Channel chan; Tcl_Obj *objPtr; + int lineNum; if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { return TCL_ERROR; @@ -1744,6 +1770,9 @@ iPtr = (Interp *) interp; oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; + iPtr->sourceInfo.curFileName = TclFSGetSourceFile(interp, pathPtr); + lineNum = iPtr->lineNum; + iPtr->lineNum = 1; Tcl_IncrRefCount(iPtr->scriptFile); string = Tcl_GetStringFromObj(objPtr, &length); result = Tcl_EvalEx(interp, string, length, 0); @@ -1756,6 +1785,7 @@ Tcl_DecrRefCount(iPtr->scriptFile); } iPtr->scriptFile = oldScriptFile; + iPtr->sourceInfo.curFileName = TclFSGetSourceFile(interp, oldScriptFile); if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); @@ -1770,6 +1800,7 @@ interp->errorLine); Tcl_AddErrorInfo(interp, msg); } + iPtr->lineNum = lineNum; end: Tcl_DecrRefCount(objPtr); diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclInt.h tcl8.4.6.new/generic/tclInt.h --- tcl8.4.6/generic/tclInt.h Wed Apr 16 16:31:44 2003 +++ tcl8.4.6.new/generic/tclInt.h Mon Jun 14 08:57:49 2004 @@ -648,6 +648,8 @@ CompiledLocal *lastLocalPtr; /* Pointer to the last allocated local * variable or NULL if none. This has * frame index (numCompiledLocals-1). */ + Tcl_Obj *fileName; /* File command is defined in. */ + int lineNum; /* Line number of proc definition. */ } Proc; /* @@ -756,6 +758,8 @@ * recognized by the compiler. The compiler * emits code that refers to these variables * using an index into this array. */ + int lineNum; /* Line number: meaningful only in "source" */ + Tcl_Obj *fileName; /* Object containing the file name. */ } CallFrame; /* @@ -1239,6 +1243,13 @@ * aren't described in packageTable. * Malloc'ed, may be NULL. */ + int lineNum; /* Line number: meaningfull only in "source" */ + Tcl_SourceInfo sourceInfo; /* Source file/line info. */ + int relError; /* Use relative line # on procedure error. */ + Tcl_HashTable sourcedFiles; /* List of paths for "source"d files */ + Tcl_Obj *traceExecCmd; /* A single command for tracing execution. */ + Tcl_Trace traceExecId; /* Trace associated with traceExecCmd. */ + /* * Miscellaneous information: */ @@ -1318,6 +1329,17 @@ } Interp; /* + * Stores the file name and newline map for a file. + * Eventually will be used as a symbol table. + */ +typedef struct SourceFileInfo { + Tcl_Obj *fileName; /* Object containing the file name. */ + Tcl_Obj *fileBody; /* Contents of the file.*/ + int *newlineMap; /* Newline map.*/ + int mapSize; /* Map size. */ +} SourceFiles; + +/* * EvalFlag bits for Interp structures: * * TCL_BRACKET_TERM 1 means that the current script is terminated by @@ -1367,6 +1389,7 @@ * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently * active; so no further trace callbacks should be * invoked. + * TRACE_LINE_NUMBERS: Tracing line numbers in switch/if/for/while/etc. */ #define DELETED 1 @@ -1379,6 +1402,7 @@ #define SAFE_INTERP 0x80 #define USE_EVAL_DIRECT 0x100 #define INTERP_TRACE_IN_PROGRESS 0x200 +#define TRACE_LINE_NUMBERS 0x400 /* * Maximum number of levels of nesting permitted in Tcl commands (used @@ -1672,7 +1696,7 @@ Tcl_Obj* valuePtr )); EXTERN int TclParseBackslash _ANSI_ARGS_((CONST char *src, - int numBytes, int *readPtr, char *dst)); + int numBytes, int *readPtr, char *dst, Tcl_Parse *parsePtr)); EXTERN int TclParseHex _ANSI_ARGS_((CONST char *src, int numBytes, Tcl_UniChar *resultPtr)); EXTERN int TclParseInteger _ANSI_ARGS_((CONST char *string, @@ -1697,6 +1721,9 @@ Tcl_ThreadDataKey *keyPtr)); EXTERN char * TclpFindExecutable _ANSI_ARGS_(( CONST char *argv0)); +EXTERN Proc * TclFindProcByLine _ANSI_ARGS_((Interp *iPtr, + Tcl_Obj *fileName, int lineNum, Namespace *nsPtr, + Tcl_Obj **procName)); EXTERN int TclpFindVariable _ANSI_ARGS_((CONST char *name, int *lengthPtr)); EXTERN void TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0)); @@ -2268,5 +2295,6 @@ # undef TCL_STORAGE_CLASS # define TCL_STORAGE_CLASS DLLIMPORT +Tcl_Obj* TclFSGetSourceFile _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *obj)); #endif /* _TCLINT */ diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclNamesp.c tcl8.4.6.new/generic/tclNamesp.c --- tcl8.4.6/generic/tclNamesp.c Wed Jun 18 11:34:19 2003 +++ tcl8.4.6.new/generic/tclNamesp.c Mon Jun 14 08:29:25 2004 @@ -322,6 +322,8 @@ iPtr->framePtr = framePtr; iPtr->varFramePtr = framePtr; + framePtr->lineNum = iPtr->sourceInfo.curLineNum; + framePtr->fileName = iPtr->sourceInfo.curFileName; return TCL_OK; } diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclObj.c tcl8.4.6.new/generic/tclObj.c --- tcl8.4.6/generic/tclObj.c Fri May 23 14:29:11 2003 +++ tcl8.4.6.new/generic/tclObj.c Mon Jun 14 09:03:02 2004 @@ -173,6 +173,12 @@ SetCmdNameFromAny /* setFromAnyProc */ }; +typedef struct ProcLineInfo { + int lineNum; /* Line Number for proc definitions */ + int lineFeeds; /* New lines in proc body */ + struct ProcLineInfo *next; +} ProcLineInfo; + /* * Structure containing a cached pointer to a command that is the result @@ -207,6 +213,7 @@ * ResolvedCmdName structure as its internal * rep. This structure can be freed when * refCount becomes zero. */ + ProcLineInfo * lineInfo; } ResolvedCmdName; @@ -2934,6 +2941,24 @@ cmdPtr = resPtr->cmdPtr; } } + if (resPtr != NULL && resPtr->lineInfo) { + + /* + * Restore saved line number information for proc's. + */ + ProcLineInfo *lineLast, *lineInfo=resPtr->lineInfo; + while (lineInfo->next != (ProcLineInfo *)NULL) { + lineLast = lineInfo; + lineInfo = lineInfo->next; + } + iPtr->lineNum = lineInfo->lineNum; + if (lineInfo == resPtr->lineInfo) { + resPtr->lineInfo=0; + } else { + lineLast->next=0; + } + ckfree((char *)lineInfo); + } iPtr->varFramePtr = savedFramePtr; return (Tcl_Command) cmdPtr; } @@ -2971,9 +2996,11 @@ register ResolvedCmdName *resPtr; Tcl_ObjType *oldTypePtr = objPtr->typePtr; register Namespace *currNsPtr; + ProcLineInfo *lineInfo; if (oldTypePtr == &tclCmdNameType) { - return; + resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + goto setlineinfo; } /* @@ -2994,6 +3021,7 @@ resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; + resPtr->lineInfo = NULL; if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { oldTypePtr->freeIntRepProc(objPtr); @@ -3001,6 +3029,18 @@ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; +setlineinfo: + if (cmdPtr->objProc != Tcl_ProcObjCmd) { + return; + } + + /* + * Save line number information for proc's + */ + lineInfo = (ProcLineInfo *)ckalloc(sizeof(ProcLineInfo)); + lineInfo->lineNum = iPtr->lineNum; + lineInfo->next = resPtr->lineInfo; + resPtr->lineInfo = lineInfo; } /* @@ -3048,6 +3088,16 @@ Command *cmdPtr = resPtr->cmdPtr; TclCleanupCommand(cmdPtr); + + if (resPtr->lineInfo != NULL) { + ProcLineInfo *lineLast, *lineInfo=resPtr->lineInfo; + while (lineInfo->next != NULL) { + lineLast = lineInfo; + lineInfo = lineInfo->next; + ckfree((char*) lineLast); + } + ckfree((char*) lineInfo); + } ckfree((char *) resPtr); } } @@ -3161,6 +3211,7 @@ resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; + resPtr->lineInfo = NULL; } else { resPtr = NULL; /* no command named "name" was found */ } diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclParse.c tcl8.4.6.new/generic/tclParse.c --- tcl8.4.6/generic/tclParse.c Sat Feb 15 17:36:32 2003 +++ tcl8.4.6.new/generic/tclParse.c Mon Jun 14 09:04:48 2004 @@ -237,6 +237,7 @@ CONST char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to * point to char after terminating one. */ int scanned; + Interp *iPtr = (Interp *) interp; if ((string == NULL) && (numBytes>0)) { if (interp != NULL) { @@ -247,6 +248,11 @@ if (numBytes < 0) { numBytes = strlen(string); } + parsePtr->lineCnt = 0; + if (iPtr != NULL && nested == 0) { + parsePtr->lineNum = iPtr->lineNum; + parsePtr->fileName = TclFSGetSourceFile(interp, iPtr->scriptFile); + } parsePtr->commentStart = NULL; parsePtr->commentSize = 0; parsePtr->commandStart = NULL; @@ -273,6 +279,10 @@ */ scanned = ParseComment(string, numBytes, parsePtr); + if (iPtr != NULL && parsePtr->lineCnt) { + iPtr->lineNum += parsePtr->lineCnt; + parsePtr->lineCnt = 0; + } src = (string + scanned); numBytes -= scanned; if (numBytes == 0) { if (nested) { @@ -311,6 +321,9 @@ } if ((type & terminators) != 0) { parsePtr->term = src; + if (*src == '\n') { + parsePtr->lineCnt++; + } src++; break; } @@ -382,6 +395,9 @@ } if ((type & terminators) != 0) { parsePtr->term = src; + if (*src == '\n') { + parsePtr->lineCnt++; + } src++; break; } @@ -401,7 +417,6 @@ parsePtr->term = src; goto error; } - parsePtr->commandSize = src - parsePtr->commandStart; return TCL_OK; @@ -460,6 +475,8 @@ } if (p[1] != '\n') { break; + } else { + parsePtr->lineCnt++; } p+=2; if (--numBytes == 0) { @@ -552,7 +569,7 @@ *---------------------------------------------------------------------- */ int -TclParseBackslash(src, numBytes, readPtr, dst) +TclParseBackslash(src, numBytes, readPtr, dst, parsePtr) CONST char * src; /* Points to the backslash character of a * a backslash sequence */ int numBytes; /* Max number of bytes to scan */ @@ -562,6 +579,7 @@ * encoding of the backslash sequence is to be * written. At most TCL_UTF_MAX bytes will be * written there. */ + Tcl_Parse *parsePtr; { register CONST char *p = src+1; Tcl_UniChar result; @@ -635,6 +653,7 @@ } break; case '\n': + if (parsePtr) parsePtr->lineCnt++; count--; do { p++; count++; @@ -723,6 +742,7 @@ do { scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type); p += scanned; numBytes -= scanned; + if (*p == '\n') parsePtr->lineCnt++; } while (numBytes && (*p == '\n') && (p++,numBytes--)); if ((numBytes == 0) || (*p != '#')) { break; @@ -742,12 +762,13 @@ * and history indicate that it has been the de facto * rule. Don't change it now. */ - TclParseBackslash(p, numBytes, &scanned, NULL); + TclParseBackslash(p, numBytes, &scanned, NULL, parsePtr); p += scanned; numBytes -= scanned; } } else { p++; numBytes--; if (p[-1] == '\n') { + parsePtr->lineCnt++; break; } } @@ -822,10 +843,15 @@ * This is a simple range of characters. Scan to find the end * of the range. */ + if (*src == '\n') { + parsePtr->lineCnt++; + } while ((++src, --numBytes) && !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) { - /* empty loop */ + if (*src == '\n') { + parsePtr->lineCnt++; + } } tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = src - tokenPtr->start; @@ -859,6 +885,7 @@ parsePtr->incomplete = nested.incomplete; return TCL_ERROR; } + parsePtr->lineCnt += nested.lineCnt; src = nested.commandStart + nested.commandSize; numBytes = parsePtr->end - src; @@ -899,7 +926,7 @@ /* * Backslash substitution. */ - TclParseBackslash(src, numBytes, &tokenPtr->size, NULL); + TclParseBackslash(src, numBytes, &tokenPtr->size, NULL, parsePtr); if (tokenPtr->size == 1) { /* Just a backslash, due to end of string */ @@ -910,6 +937,7 @@ } if (src[1] == '\n') { + parsePtr->lineCnt++; if (numBytes == 2) { parsePtr->incomplete = 1; } @@ -1496,7 +1524,7 @@ } break; case '\\': - TclParseBackslash(src, numBytes, &length, NULL); + TclParseBackslash(src, numBytes, &length, NULL, parsePtr); if ((length > 1) && (src[1] == '\n')) { /* * A backslash-newline sequence must be collapsed, even @@ -1533,6 +1561,9 @@ numBytes -= length - 1; } break; + case '\n': + parsePtr->lineCnt++; + break; } } } @@ -1782,3 +1813,5 @@ return 1; } + + diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclProc.c tcl8.4.6.new/generic/tclProc.c --- tcl8.4.6/generic/tclProc.c Fri Jul 18 16:35:39 2003 +++ tcl8.4.6.new/generic/tclProc.c Mon Jun 14 09:13:57 2004 @@ -132,6 +132,8 @@ Tcl_DStringAppend(&ds, "::", 2); } Tcl_DStringAppend(&ds, procName, -1); + procPtr->lineNum = iPtr->lineNum; + procPtr->fileName = iPtr->sourceInfo.curFileName; Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc, (ClientData) procPtr, TclProcDeleteProc); @@ -747,6 +749,74 @@ return (Proc *) cmdPtr->clientData; } + +/* + *---------------------------------------------------------------------- + * + * TclFindProcByLine -- + * + * Given a file name and a line number, return a pointer to the + * record describing the procedure, if one exists at that line. + * + * Results: + * NULL is returned if no procedure is found at that line number. + * Otherwise, the return value is a pointer to the procedure's record. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +Proc * +TclFindProcByLine(iPtr, fileName, lineNum, nsPtr, procName) + Interp *iPtr; /* Interpreter in which to look. */ + Tcl_Obj *fileName; /* The file name */ + int lineNum; /* Line number within file. */ + Namespace *nsPtr; /* The namespace to start search from. */ + Tcl_Obj **procName; /* Name of the procedure to call. */ +{ + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Command *cmdPtr; + Namespace *childNsPtr; + Proc *procPtr; + char *fname=Tcl_GetString(fileName); + + if (nsPtr == (Namespace *)NULL) { + nsPtr=iPtr->globalNsPtr; + } + if (nsPtr == (Namespace *)NULL) { + return (Proc *)NULL; + } + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + if ((procPtr=TclIsProc(cmdPtr)) != (Proc *)NULL) { + if (procPtr->fileName && + (!strcmp(fname,Tcl_GetString(procPtr->fileName)))) { + if (lineNum>=procPtr->lineNum /* ??? && + lineNum<=(procPtr->lineNum+procPtr->lineFeeds)*/) { + *procName=Tcl_NewStringObj(nsPtr->fullName,-1); + Tcl_AppendStringsToObj(*procName, + (char*)Tcl_GetHashKey(&nsPtr->cmdTable,entryPtr),0); + return procPtr; + } + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); + if ((procPtr=TclFindProcByLine(iPtr, fileName, lineNum, childNsPtr, + procName))) + return procPtr; + } + return (Proc *)NULL; +} + /* *---------------------------------------------------------------------- * @@ -909,8 +979,8 @@ register Var *varPtr; register CompiledLocal *localPtr; char *procName; - int nameLen, localCt, numArgs, argCt, i, result; - Tcl_Obj *objResult = Tcl_GetObjResult(interp); + int nameLen, localCt, numArgs, argCt, i, result, lineNum; + Tcl_Obj *objResult = Tcl_GetObjResult(interp), *fileName; /* * This procedure generates an array "compiledLocals" that holds the @@ -922,6 +992,10 @@ Var localStorage[NUM_LOCALS]; Var *compiledLocals = localStorage; + lineNum = iPtr->lineNum; + fileName = iPtr->sourceInfo.curFileName; + iPtr->lineNum = procPtr->lineNum; + iPtr->sourceInfo.curFileName = procPtr->fileName; /* * Get the procedure's name. */ @@ -938,7 +1012,7 @@ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, "body of proc", procName); - + if (result != TCL_OK) { return result; } @@ -966,8 +1040,10 @@ (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1); if (result != TCL_OK) { - return result; + goto procExit; } + iPtr->lineNum = iPtr->sourceInfo.curLineNum = procPtr->lineNum; + iPtr->sourceInfo.curFileName = procPtr->fileName; framePtr->objc = objc; framePtr->objv = objv; /* ref counts for args are incremented below */ @@ -997,11 +1073,13 @@ if (!TclIsVarArgument(localPtr)) { panic("TclObjInterpProc: local variable %s is not argument but should be", localPtr->name); - return TCL_ERROR; + result = TCL_ERROR; + goto procExit; } if (TclIsVarTemporary(localPtr)) { panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i); - return TCL_ERROR; + result = TCL_ERROR; + goto procExit; } /* @@ -1099,6 +1177,10 @@ if (compiledLocals != localStorage) { ckfree((char *) compiledLocals); } + + procExit: + iPtr->lineNum = lineNum; + iPtr->sourceInfo.curFileName = fileName; return result; #undef NUM_LOCALS } @@ -1213,6 +1295,8 @@ (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); if (result == TCL_OK) { + procPtr->lineNum = iPtr->lineNum; + procPtr->fileName = iPtr->sourceInfo.curFileName; result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); Tcl_PopCallFrame(interp); } @@ -1221,6 +1305,8 @@ if (result != TCL_OK) { if (result == TCL_ERROR) { + int errorLine; + Proc *procPtr; char buf[100 + TCL_INTEGER_SPACE]; numChars = strlen(procName); @@ -1237,9 +1323,15 @@ numChars--; ellipsis = "..."; } + procPtr=TclFindProc(iPtr, procName); + errorLine = interp->errorLine; + if (procPtr && procPtr->fileName && (!iPtr->relError)) { + procName = Tcl_GetString(procPtr->fileName); + errorLine = procPtr->lineNum; + } sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)", description, numChars, procName, ellipsis, - interp->errorLine); + errorLine); Tcl_AddObjErrorInfo(interp, buf, -1); } return result; diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclTimer.c tcl8.4.6.new/generic/tclTimer.c --- tcl8.4.6/generic/tclTimer.c Thu Feb 28 22:22:31 2002 +++ tcl8.4.6.new/generic/tclTimer.c Mon Jun 14 08:29:25 2004 @@ -53,6 +53,9 @@ * timer handler. */ struct AfterInfo *nextPtr; /* Next in list of all "after" commands for * this interpreter. */ + int lineNum; /* Line number of after event. */ + int curLine; /* Line number of after event. */ + Tcl_Obj *fileName; /* Source filename. */ } AfterInfo; /* @@ -752,6 +755,7 @@ }; enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; ThreadSpecificData *tsdPtr = InitTimer(); + Interp *iPtr = (Interp*)interp; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); @@ -823,6 +827,9 @@ tsdPtr->afterId += 1; afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc, (ClientData) afterPtr); + afterPtr->lineNum = iPtr->lineNum; + afterPtr->curLine = iPtr->sourceInfo.curLineNum; + afterPtr->fileName = iPtr->sourceInfo.curFileName; afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; sprintf(buf, "after#%d", afterPtr->id); @@ -899,6 +906,9 @@ afterPtr->id = tsdPtr->afterId; tsdPtr->afterId += 1; afterPtr->token = NULL; + afterPtr->lineNum = iPtr->lineNum; + afterPtr->curLine = iPtr->sourceInfo.curLineNum; + afterPtr->fileName = iPtr->sourceInfo.curFileName; afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); @@ -1018,10 +1028,12 @@ AfterInfo *afterPtr = (AfterInfo *) clientData; AfterAssocData *assocPtr = afterPtr->assocPtr; AfterInfo *prevPtr; - int result; + int result, lineNum, curLine; Tcl_Interp *interp; char *script; int numBytes; + Tcl_Obj *fileName; + Interp *iPtr; /* * First remove the callback from our list of callbacks; otherwise @@ -1044,9 +1056,21 @@ */ interp = assocPtr->interp; + iPtr = (Interp*)interp; Tcl_Preserve((ClientData) interp); + /* Save/restore file/line number in case of trace. */ + lineNum = iPtr->lineNum; + curLine = iPtr->sourceInfo.curLineNum; + fileName = iPtr->sourceInfo.curFileName; + iPtr->sourceInfo.curFileName = afterPtr->fileName; + iPtr->lineNum = afterPtr->lineNum; + iPtr->sourceInfo.curLineNum = afterPtr->curLine; script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes); result = Tcl_EvalEx(interp, script, numBytes, TCL_EVAL_GLOBAL); + iPtr->sourceInfo.curFileName = fileName; + iPtr->lineNum = lineNum; + iPtr->sourceInfo.curLineNum = curLine; + script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes); if (result != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); Tcl_BackgroundError(interp); diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/generic/tclUtf.c tcl8.4.6.new/generic/tclUtf.c --- tcl8.4.6/generic/tclUtf.c Wed Oct 8 07:21:20 2003 +++ tcl8.4.6.new/generic/tclUtf.c Mon Jun 14 08:29:25 2004 @@ -788,10 +788,10 @@ int numRead; int result; - result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst); + result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst, NULL); if (numRead == LINE_LENGTH) { /* We ate a whole line. Pay the price of a strlen() */ - result = TclParseBackslash(src, (int)strlen(src), &numRead, dst); + result = TclParseBackslash(src, (int)strlen(src), &numRead, dst, NULL); } if (readPtr != NULL) { *readPtr = numRead; diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/library/tcltest/tcltest.tcl tcl8.4.6.new/library/tcltest/tcltest.tcl --- tcl8.4.6/library/tcltest/tcltest.tcl Tue Feb 17 17:43:49 2004 +++ tcl8.4.6.new/library/tcltest/tcltest.tcl Mon Jun 14 08:29:25 2004 @@ -18,6 +18,9 @@ # # RCS: @(#) $Id: tcltest.tcl,v 1.78.2.8 2004/02/18 01:43:49 dgp Exp $ +# Disable absolute line number/filename in proc error. +info line relerror 1 + package require Tcl 8.3 ;# uses [glob -directory] namespace eval tcltest { diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/library/tcltest/tcltest.tcl.orig tcl8.4.6.new/library/tcltest/tcltest.tcl.orig --- tcl8.4.6/library/tcltest/tcltest.tcl.orig Wed Dec 31 16:00:00 1969 +++ tcl8.4.6.new/library/tcltest/tcltest.tcl.orig Tue Feb 17 17:43:49 2004 @@ -0,0 +1,3336 @@ +# tcltest.tcl -- +# +# This file contains support code for the Tcl test suite. It +# defines the tcltest namespace and finds and defines the output +# directory, constraints available, output and error channels, +# etc. used by Tcl tests. See the tcltest man page for more +# details. +# +# This design was based on the Tcl testing approach designed and +# initially implemented by Mary Ann May-Pumphrey of Sun +# Microsystems. +# +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2000 by Ajuba Solutions +# Contributions from Don Porter, NIST, 2002. (not subject to US copyright) +# All rights reserved. +# +# RCS: @(#) $Id: tcltest.tcl,v 1.78.2.8 2004/02/18 01:43:49 dgp Exp $ + +package require Tcl 8.3 ;# uses [glob -directory] +namespace eval tcltest { + + # When the version number changes, be sure to update the pkgIndex.tcl file, + # and the install directory in the Makefiles. When the minor version + # changes (new feature) be sure to update the man page as well. + variable Version 2.2.5 + + # Compatibility support for dumb variables defined in tcltest 1 + # Do not use these. Call [package provide Tcl] and [info patchlevel] + # yourself. You don't need tcltest to wrap it for you. + variable version [package provide Tcl] + variable patchLevel [info patchlevel] + +##### Export the public tcltest procs; several categories + # + # Export the main functional commands that do useful things + namespace export cleanupTests loadTestedCommands makeDirectory \ + makeFile removeDirectory removeFile runAllTests test + + # Export configuration commands that control the functional commands + namespace export configure customMatch errorChannel interpreter \ + outputChannel testConstraint + + # Export commands that are duplication (candidates for deprecation) + namespace export bytestring ;# dups [encoding convertfrom identity] + namespace export debug ;# [configure -debug] + namespace export errorFile ;# [configure -errfile] + namespace export limitConstraints ;# [configure -limitconstraints] + namespace export loadFile ;# [configure -loadfile] + namespace export loadScript ;# [configure -load] + namespace export match ;# [configure -match] + namespace export matchFiles ;# [configure -file] + namespace export matchDirectories ;# [configure -relateddir] + namespace export normalizeMsg ;# application of [customMatch] + namespace export normalizePath ;# [file normalize] (8.4) + namespace export outputFile ;# [configure -outfile] + namespace export preserveCore ;# [configure -preservecore] + namespace export singleProcess ;# [configure -singleproc] + namespace export skip ;# [configure -skip] + namespace export skipFiles ;# [configure -notfile] + namespace export skipDirectories ;# [configure -asidefromdir] + namespace export temporaryDirectory ;# [configure -tmpdir] + namespace export testsDirectory ;# [configure -testdir] + namespace export verbose ;# [configure -verbose] + namespace export viewFile ;# binary encoding [read] + namespace export workingDirectory ;# [cd] [pwd] + + # Export deprecated commands for tcltest 1 compatibility + namespace export getMatchingFiles mainThread restoreState saveState \ + threadReap + + # tcltest::normalizePath -- + # + # This procedure resolves any symlinks in the path thus creating + # a path without internal redirection. It assumes that the + # incoming path is absolute. + # + # Arguments + # pathVar - name of variable containing path to modify. + # + # Results + # The path is modified in place. + # + # Side Effects: + # None. + # + proc normalizePath {pathVar} { + upvar $pathVar path + set oldpwd [pwd] + catch {cd $path} + set path [pwd] + cd $oldpwd + return $path + } + +##### Verification commands used to test values of variables and options + # + # Verification command that accepts everything + proc AcceptAll {value} { + return $value + } + + # Verification command that accepts valid Tcl lists + proc AcceptList { list } { + return [lrange $list 0 end] + } + + # Verification command that accepts a glob pattern + proc AcceptPattern { pattern } { + return [AcceptAll $pattern] + } + + # Verification command that accepts integers + proc AcceptInteger { level } { + return [incr level 0] + } + + # Verification command that accepts boolean values + proc AcceptBoolean { boolean } { + return [expr {$boolean && $boolean}] + } + + # Verification command that accepts (syntactically) valid Tcl scripts + proc AcceptScript { script } { + if {![info complete $script]} { + return -code error "invalid Tcl script: $script" + } + return $script + } + + # Verification command that accepts (converts to) absolute pathnames + proc AcceptAbsolutePath { path } { + return [file join [pwd] $path] + } + + # Verification command that accepts existing readable directories + proc AcceptReadable { path } { + if {![file readable $path]} { + return -code error "\"$path\" is not readable" + } + return $path + } + proc AcceptDirectory { directory } { + set directory [AcceptAbsolutePath $directory] + if {![file exists $directory]} { + return -code error "\"$directory\" does not exist" + } + if {![file isdir $directory]} { + return -code error "\"$directory\" is not a directory" + } + return [AcceptReadable $directory] + } + +##### Initialize internal arrays of tcltest, but only if the caller + # has not already pre-initialized them. This is done to support + # compatibility with older tests that directly access internals + # rather than go through command interfaces. + # + proc ArrayDefault {varName value} { + variable $varName + if {[array exists $varName]} { + return + } + if {[info exists $varName]} { + # Pre-initialized value is a scalar: destroy it! + unset $varName + } + array set $varName $value + } + + # save the original environment so that it can be restored later + ArrayDefault originalEnv [array get ::env] + + # initialize numTests array to keep track of the number of tests + # that pass, fail, and are skipped. + ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0] + + # createdNewFiles will store test files as indices and the list of + # files (that should not have been) left behind by the test files + # as values. + ArrayDefault createdNewFiles {} + + # initialize skippedBecause array to keep track of constraints that + # kept tests from running; a constraint name of "userSpecifiedSkip" + # means that the test appeared on the list of tests that matched the + # -skip value given to the flag; "userSpecifiedNonMatch" means that + # the test didn't match the argument given to the -match flag; both + # of these constraints are counted only if tcltest::debug is set to + # true. + ArrayDefault skippedBecause {} + + # initialize the testConstraints array to keep track of valid + # predefined constraints (see the explanation for the + # InitConstraints proc for more details). + ArrayDefault testConstraints {} + +##### Initialize internal variables of tcltest, but only if the caller + # has not already pre-initialized them. This is done to support + # compatibility with older tests that directly access internals + # rather than go through command interfaces. + # + proc Default {varName value {verify AcceptAll}} { + variable $varName + if {![info exists $varName]} { + variable $varName [$verify $value] + } else { + variable $varName [$verify [set $varName]] + } + } + + # Save any arguments that we might want to pass through to other + # programs. This is used by the -args flag. + # FINDUSER + Default parameters {} + + # Count the number of files tested (0 if runAllTests wasn't called). + # runAllTests will set testSingleFile to false, so stats will + # not be printed until runAllTests calls the cleanupTests proc. + # The currentFailure var stores the boolean value of whether the + # current test file has had any failures. The failFiles list + # stores the names of test files that had failures. + Default numTestFiles 0 AcceptInteger + Default testSingleFile true AcceptBoolean + Default currentFailure false AcceptBoolean + Default failFiles {} AcceptList + + # Tests should remove all files they create. The test suite will + # check the current working dir for files created by the tests. + # filesMade keeps track of such files created using the makeFile and + # makeDirectory procedures. filesExisted stores the names of + # pre-existing files. + # + # Note that $filesExisted lists only those files that exist in + # the original [temporaryDirectory]. + Default filesMade {} AcceptList + Default filesExisted {} AcceptList + proc FillFilesExisted {} { + variable filesExisted + + # Save the names of files that already exist in the scratch directory. + foreach file [glob -nocomplain -directory [temporaryDirectory] *] { + lappend filesExisted [file tail $file] + } + + # After successful filling, turn this into a no-op. + proc FillFilesExisted args {} + } + + # Kept only for compatibility + Default constraintsSpecified {} AcceptList + trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \ + [array names ::tcltest::testConstraints] ;# } + + # tests that use threads need to know which is the main thread + Default mainThread 1 + variable mainThread + if {[info commands thread::id] != {}} { + set mainThread [thread::id] + } elseif {[info commands testthread] != {}} { + set mainThread [testthread id] + } + + # Set workingDirectory to [pwd]. The default output directory for + # Tcl tests is the working directory. Whenever this value changes + # change to that directory. + variable workingDirectory + trace variable workingDirectory w \ + [namespace code {cd $workingDirectory ;#}] + + Default workingDirectory [pwd] AcceptAbsolutePath + proc workingDirectory { {dir ""} } { + variable workingDirectory + if {[llength [info level 0]] == 1} { + return $workingDirectory + } + set workingDirectory [AcceptAbsolutePath $dir] + } + + # Set the location of the execuatble + Default tcltest [info nameofexecutable] + trace variable tcltest w [namespace code {testConstraint stdio \ + [eval [ConstraintInitializer stdio]] ;#}] + + # save the platform information so it can be restored later + Default originalTclPlatform [array get ::tcl_platform] + + # If a core file exists, save its modification time. + if {[file exists [file join [workingDirectory] core]]} { + Default coreModTime \ + [file mtime [file join [workingDirectory] core]] + } + + # stdout and stderr buffers for use when we want to store them + Default outData {} + Default errData {} + + # keep track of test level for nested test commands + variable testLevel 0 + + # the variables and procs that existed when saveState was called are + # stored in a variable of the same name + Default saveState {} + + # Internationalization support -- used in [SetIso8859_1_Locale] and + # [RestoreLocale]. Those commands are used in cmdIL.test. + + if {![info exists [namespace current]::isoLocale]} { + variable isoLocale fr + switch -- $::tcl_platform(platform) { + "unix" { + + # Try some 'known' values for some platforms: + + switch -exact -- $::tcl_platform(os) { + "FreeBSD" { + set isoLocale fr_FR.ISO_8859-1 + } + HP-UX { + set isoLocale fr_FR.iso88591 + } + Linux - + IRIX { + set isoLocale fr + } + default { + + # Works on SunOS 4 and Solaris, and maybe + # others... Define it to something else on your + # system if you want to test those. + + set isoLocale iso_8859_1 + } + } + } + "windows" { + set isoLocale French + } + } + } + + variable ChannelsWeOpened; array set ChannelsWeOpened {} + # output goes to stdout by default + Default outputChannel stdout + proc outputChannel { {filename ""} } { + variable outputChannel + variable ChannelsWeOpened + + # This is very subtle and tricky, so let me try to explain. + # (Hopefully this longer comment will be clear when I come + # back in a few months, unlike its predecessor :) ) + # + # The [outputChannel] command (and underlying variable) have to + # be kept in sync with the [configure -outfile] configuration + # option ( and underlying variable Option(-outfile) ). This is + # accomplished with a write trace on Option(-outfile) that will + # update [outputChannel] whenver a new value is written. That + # much is easy. + # + # The trick is that in order to maintain compatibility with + # version 1 of tcltest, we must allow every configuration option + # to get its inital value from command line arguments. This is + # accomplished by setting initial read traces on all the + # configuration options to parse the command line option the first + # time they are read. These traces are cancelled whenever the + # program itself calls [configure]. + # + # OK, then so to support tcltest 1 compatibility, it seems we want + # to get the return from [outputFile] to trigger the read traces, + # just in case. + # + # BUT! A little known feature of Tcl variable traces is that + # traces are disabled during the handling of other traces. So, + # if we trigger read traces on Option(-outfile) and that triggers + # command line parsing which turns around and sets an initial + # value for Option(-outfile) -- -- the write trace that + # would keep [outputChannel] in sync with that new initial value + # would not fire! + # + # SO, finally, as a workaround, instead of triggering read traces + # by invoking [outputFile], we instead trigger the same set of + # read traces by invoking [debug]. Any command that reads a + # configuration option would do. [debug] is just a handy one. + # The end result is that we support tcltest 1 compatibility and + # keep outputChannel and -outfile in sync in all cases. + debug + + if {[llength [info level 0]] == 1} { + return $outputChannel + } + if {[info exists ChannelsWeOpened($outputChannel)]} { + close $outputChannel + unset ChannelsWeOpened($outputChannel) + } + switch -exact -- $filename { + stderr - + stdout { + set outputChannel $filename + } + default { + set outputChannel [open $filename a] + set ChannelsWeOpened($outputChannel) 1 + + # If we created the file in [temporaryDirectory], then + # [cleanupTests] will delete it, unless we claim it was + # already there. + set outdir [normalizePath [file dirname \ + [file join [pwd] $filename]]] + if {[string equal $outdir [temporaryDirectory]]} { + variable filesExisted + FillFilesExisted + set filename [file tail $filename] + if {[lsearch -exact $filesExisted $filename] == -1} { + lappend filesExisted $filename + } + } + } + } + return $outputChannel + } + + # errors go to stderr by default + Default errorChannel stderr + proc errorChannel { {filename ""} } { + variable errorChannel + variable ChannelsWeOpened + + # This is subtle and tricky. See the comment above in + # [outputChannel] for a detailed explanation. + debug + + if {[llength [info level 0]] == 1} { + return $errorChannel + } + if {[info exists ChannelsWeOpened($errorChannel)]} { + close $errorChannel + unset ChannelsWeOpened($errorChannel) + } + switch -exact -- $filename { + stderr - + stdout { + set errorChannel $filename + } + default { + set errorChannel [open $filename a] + set ChannelsWeOpened($errorChannel) 1 + + # If we created the file in [temporaryDirectory], then + # [cleanupTests] will delete it, unless we claim it was + # already there. + set outdir [normalizePath [file dirname \ + [file join [pwd] $filename]]] + if {[string equal $outdir [temporaryDirectory]]} { + variable filesExisted + FillFilesExisted + set filename [file tail $filename] + if {[lsearch -exact $filesExisted $filename] == -1} { + lappend filesExisted $filename + } + } + } + } + return $errorChannel + } + +##### Set up the configurable options + # + # The configurable options of the package + variable Option; array set Option {} + + # Usage strings for those options + variable Usage; array set Usage {} + + # Verification commands for those options + variable Verify; array set Verify {} + + # Initialize the default values of the configurable options that are + # historically associated with an exported variable. If that variable + # is already set, support compatibility by accepting its pre-set value. + # Use [trace] to establish ongoing connection between the deprecated + # exported variable and the modern option kept as a true internal var. + # Also set up usage string and value testing for the option. + proc Option {option value usage {verify AcceptAll} {varName {}}} { + variable Option + variable Verify + variable Usage + variable OptionControlledVariables + set Usage($option) $usage + set Verify($option) $verify + if {[catch {$verify $value} msg]} { + return -code error $msg + } else { + set Option($option) $msg + } + if {[string length $varName]} { + variable $varName + if {[info exists $varName]} { + if {[catch {$verify [set $varName]} msg]} { + return -code error $msg + } else { + set Option($option) $msg + } + unset $varName + } + namespace eval [namespace current] \ + [list upvar 0 Option($option) $varName] + # Workaround for Bug (now Feature Request) 572889. Grrrr.... + # Track all the variables tied to options + lappend OptionControlledVariables $varName + # Later, set auto-configure read traces on all + # of them, since a single trace on Option does not work. + proc $varName {{value {}}} [subst -nocommands { + if {[llength [info level 0]] == 2} { + Configure $option [set value] + } + return [Configure $option] + }] + } + } + + proc MatchingOption {option} { + variable Option + set match [array names Option $option*] + switch -- [llength $match] { + 0 { + set sorted [lsort [array names Option]] + set values [join [lrange $sorted 0 end-1] ", "] + append values ", or [lindex $sorted end]" + return -code error "unknown option $option: should be\ + one of $values" + } + 1 { + return [lindex $match 0] + } + default { + # Exact match trumps ambiguity + if {[lsearch -exact $match $option] >= 0} { + return $option + } + set values [join [lrange $match 0 end-1] ", "] + append values ", or [lindex $match end]" + return -code error "ambiguous option $option:\ + could match $values" + } + } + } + + proc EstablishAutoConfigureTraces {} { + variable OptionControlledVariables + foreach varName [concat $OptionControlledVariables Option] { + variable $varName + trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}] + } + } + + proc RemoveAutoConfigureTraces {} { + variable OptionControlledVariables + foreach varName [concat $OptionControlledVariables Option] { + variable $varName + foreach pair [trace vinfo $varName] { + foreach {op cmd} $pair break + if {[string equal r $op] + && [string match *ProcessCmdLineArgs* $cmd]} { + trace vdelete $varName $op $cmd + } + } + } + # Once the traces are removed, this can become a no-op + proc RemoveAutoConfigureTraces {} {} + } + + proc Configure args { + variable Option + variable Verify + set n [llength $args] + if {$n == 0} { + return [lsort [array names Option]] + } + if {$n == 1} { + if {[catch {MatchingOption [lindex $args 0]} option]} { + return -code error $option + } + return $Option($option) + } + while {[llength $args] > 1} { + if {[catch {MatchingOption [lindex $args 0]} option]} { + return -code error $option + } + if {[catch {$Verify($option) [lindex $args 1]} value]} { + return -code error "invalid $option\ + value \"[lindex $args 1]\": $value" + } + set Option($option) $value + set args [lrange $args 2 end] + } + if {[llength $args]} { + if {[catch {MatchingOption [lindex $args 0]} option]} { + return -code error $option + } + return -code error "missing value for option $option" + } + } + proc configure args { + RemoveAutoConfigureTraces + set code [catch {eval Configure $args} msg] + return -code $code $msg + } + + proc AcceptVerbose { level } { + set level [AcceptList $level] + if {[llength $level] == 1} { + if {![regexp {^(pass|body|skip|start|error)$} $level]} { + # translate single characters abbreviations to expanded list + set level [string map {p pass b body s skip t start e error} \ + [split $level {}]] + } + } + set valid [list] + foreach v $level { + if {[regexp {^(pass|body|skip|start|error)$} $v]} { + lappend valid $v + } + } + return $valid + } + + proc IsVerbose {level} { + variable Option + return [expr {[lsearch -exact $Option(-verbose) $level] != -1}] + } + + # Default verbosity is to show bodies of failed tests + Option -verbose {body error} { + Takes any combination of the values 'p', 's', 'b', 't' and 'e'. + Test suite will display all passed tests if 'p' is specified, all + skipped tests if 's' is specified, the bodies of failed tests if + 'b' is specified, and when tests start if 't' is specified. + ErrorInfo is displayed if 'e' is specified. + } AcceptVerbose verbose + + # Match and skip patterns default to the empty list, except for + # matchFiles, which defaults to all .test files in the + # testsDirectory and matchDirectories, which defaults to all + # directories. + Option -match * { + Run all tests within the specified files that match one of the + list of glob patterns given. + } AcceptList match + + Option -skip {} { + Skip all tests within the specified tests (via -match) and files + that match one of the list of glob patterns given. + } AcceptList skip + + Option -file *.test { + Run tests in all test files that match the glob pattern given. + } AcceptPattern matchFiles + + # By default, skip files that appear to be SCCS lock files. + Option -notfile l.*.test { + Skip all test files that match the glob pattern given. + } AcceptPattern skipFiles + + Option -relateddir * { + Run tests in directories that match the glob pattern given. + } AcceptPattern matchDirectories + + Option -asidefromdir {} { + Skip tests in directories that match the glob pattern given. + } AcceptPattern skipDirectories + + # By default, don't save core files + Option -preservecore 0 { + If 2, save any core files produced during testing in the directory + specified by -tmpdir. If 1, notify the user if core files are + created. + } AcceptInteger preserveCore + + # debug output doesn't get printed by default; debug level 1 spits + # up only the tests that were skipped because they didn't match or + # were specifically skipped. A debug level of 2 would spit up the + # tcltest variables and flags provided; a debug level of 3 causes + # some additional output regarding operations of the test harness. + # The tcltest package currently implements only up to debug level 3. + Option -debug 0 { + Internal debug level + } AcceptInteger debug + + proc SetSelectedConstraints args { + variable Option + foreach c $Option(-constraints) { + testConstraint $c 1 + } + } + Option -constraints {} { + Do not skip the listed constraints listed in -constraints. + } AcceptList + trace variable Option(-constraints) w \ + [namespace code {SetSelectedConstraints ;#}] + + # Don't run only the "-constraint" specified tests by default + proc ClearUnselectedConstraints args { + variable Option + variable testConstraints + if {!$Option(-limitconstraints)} {return} + foreach c [array names testConstraints] { + if {[lsearch -exact $Option(-constraints) $c] == -1} { + testConstraint $c 0 + } + } + } + Option -limitconstraints false { + whether to run only tests with the constraints + } AcceptBoolean limitConstraints + trace variable Option(-limitconstraints) w \ + [namespace code {ClearUnselectedConstraints ;#}] + + # A test application has to know how to load the tested commands + # into the interpreter. + Option -load {} { + Specifies the script to load the tested commands. + } AcceptScript loadScript + + # Default is to run each test file in a separate process + Option -singleproc 0 { + whether to run all tests in one process + } AcceptBoolean singleProcess + + proc AcceptTemporaryDirectory { directory } { + set directory [AcceptAbsolutePath $directory] + if {![file exists $directory]} { + file mkdir $directory + } + set directory [AcceptDirectory $directory] + if {![file writable $directory]} { + if {[string equal [workingDirectory] $directory]} { + # Special exception: accept the default value + # even if the directory is not writable + return $directory + } + return -code error "\"$directory\" is not writeable" + } + return $directory + } + + # Directory where files should be created + Option -tmpdir [workingDirectory] { + Save temporary files in the specified directory. + } AcceptTemporaryDirectory temporaryDirectory + trace variable Option(-tmpdir) w \ + [namespace code {normalizePath Option(-tmpdir) ;#}] + + # Tests should not rely on the current working directory. + # Files that are part of the test suite should be accessed relative + # to [testsDirectory] + Option -testdir [workingDirectory] { + Search tests in the specified directory. + } AcceptDirectory testsDirectory + trace variable Option(-testdir) w \ + [namespace code {normalizePath Option(-testdir) ;#}] + + proc AcceptLoadFile { file } { + if {[string equal "" $file]} {return $file} + set file [file join [temporaryDirectory] $file] + return [AcceptReadable $file] + } + proc ReadLoadScript {args} { + variable Option + if {[string equal "" $Option(-loadfile)]} {return} + set tmp [open $Option(-loadfile) r] + loadScript [read $tmp] + close $tmp + } + Option -loadfile {} { + Read the script to load the tested commands from the specified file. + } AcceptLoadFile loadFile + trace variable Option(-loadfile) w [namespace code ReadLoadScript] + + proc AcceptOutFile { file } { + if {[string equal stderr $file]} {return $file} + if {[string equal stdout $file]} {return $file} + return [file join [temporaryDirectory] $file] + } + + # output goes to stdout by default + Option -outfile stdout { + Send output from test runs to the specified file. + } AcceptOutFile outputFile + trace variable Option(-outfile) w \ + [namespace code {outputChannel $Option(-outfile) ;#}] + + # errors go to stderr by default + Option -errfile stderr { + Send errors from test runs to the specified file. + } AcceptOutFile errorFile + trace variable Option(-errfile) w \ + [namespace code {errorChannel $Option(-errfile) ;#}] + +} + +##################################################################### + +# tcltest::Debug* -- +# +# Internal helper procedures to write out debug information +# dependent on the chosen level. A test shell may overide +# them, f.e. to redirect the output into a different +# channel, or even into a GUI. + +# tcltest::DebugPuts -- +# +# Prints the specified string if the current debug level is +# higher than the provided level argument. +# +# Arguments: +# level The lowest debug level triggering the output +# string The string to print out. +# +# Results: +# Prints the string. Nothing else is allowed. +# +# Side Effects: +# None. +# + +proc tcltest::DebugPuts {level string} { + variable debug + if {$debug >= $level} { + puts $string + } + return +} + +# tcltest::DebugPArray -- +# +# Prints the contents of the specified array if the current +# debug level is higher than the provided level argument +# +# Arguments: +# level The lowest debug level triggering the output +# arrayvar The name of the array to print out. +# +# Results: +# Prints the contents of the array. Nothing else is allowed. +# +# Side Effects: +# None. +# + +proc tcltest::DebugPArray {level arrayvar} { + variable debug + + if {$debug >= $level} { + catch {upvar $arrayvar $arrayvar} + parray $arrayvar + } + return +} + +# Define our own [parray] in ::tcltest that will inherit use of the [puts] +# defined in ::tcltest. NOTE: Ought to construct with [info args] and +# [info default], but can't be bothered now. If [parray] changes, then +# this will need changing too. +auto_load ::parray +proc tcltest::parray {a {pattern *}} [info body ::parray] + +# tcltest::DebugDo -- +# +# Executes the script if the current debug level is greater than +# the provided level argument +# +# Arguments: +# level The lowest debug level triggering the execution. +# script The tcl script executed upon a debug level high enough. +# +# Results: +# Arbitrary side effects, dependent on the executed script. +# +# Side Effects: +# None. +# + +proc tcltest::DebugDo {level script} { + variable debug + + if {$debug >= $level} { + uplevel 1 $script + } + return +} + +##################################################################### + +proc tcltest::Warn {msg} { + puts [outputChannel] "WARNING: $msg" +} + +# tcltest::mainThread +# +# Accessor command for tcltest variable mainThread. +# +proc tcltest::mainThread { {new ""} } { + variable mainThread + if {[llength [info level 0]] == 1} { + return $mainThread + } + set mainThread $new +} + +# tcltest::testConstraint -- +# +# sets a test constraint to a value; to do multiple constraints, +# call this proc multiple times. also returns the value of the +# named constraint if no value was supplied. +# +# Arguments: +# constraint - name of the constraint +# value - new value for constraint (should be boolean) - if not +# supplied, this is a query +# +# Results: +# content of tcltest::testConstraints($constraint) +# +# Side effects: +# none + +proc tcltest::testConstraint {constraint {value ""}} { + variable testConstraints + variable Option + DebugPuts 3 "entering testConstraint $constraint $value" + if {[llength [info level 0]] == 2} { + return $testConstraints($constraint) + } + # Check for boolean values + if {[catch {expr {$value && $value}} msg]} { + return -code error $msg + } + if {[limitConstraints] + && [lsearch -exact $Option(-constraints) $constraint] == -1} { + set value 0 + } + set testConstraints($constraint) $value +} + +# tcltest::interpreter -- +# +# the interpreter name stored in tcltest::tcltest +# +# Arguments: +# executable name +# +# Results: +# content of tcltest::tcltest +# +# Side effects: +# None. + +proc tcltest::interpreter { {interp ""} } { + variable tcltest + if {[llength [info level 0]] == 1} { + return $tcltest + } + if {[string equal {} $interp]} { + set tcltest {} + } else { + set tcltest $interp + } +} + +##################################################################### + +# tcltest::AddToSkippedBecause -- +# +# Increments the variable used to track how many tests were +# skipped because of a particular constraint. +# +# Arguments: +# constraint The name of the constraint to be modified +# +# Results: +# Modifies tcltest::skippedBecause; sets the variable to 1 if +# didn't previously exist - otherwise, it just increments it. +# +# Side effects: +# None. + +proc tcltest::AddToSkippedBecause { constraint {value 1}} { + # add the constraint to the list of constraints that kept tests + # from running + variable skippedBecause + + if {[info exists skippedBecause($constraint)]} { + incr skippedBecause($constraint) $value + } else { + set skippedBecause($constraint) $value + } + return +} + +# tcltest::PrintError -- +# +# Prints errors to tcltest::errorChannel and then flushes that +# channel, making sure that all messages are < 80 characters per +# line. +# +# Arguments: +# errorMsg String containing the error to be printed +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::PrintError {errorMsg} { + set InitialMessage "Error: " + set InitialMsgLen [string length $InitialMessage] + puts -nonewline [errorChannel] $InitialMessage + + # Keep track of where the end of the string is. + set endingIndex [string length $errorMsg] + + if {$endingIndex < (80 - $InitialMsgLen)} { + puts [errorChannel] $errorMsg + } else { + # Print up to 80 characters on the first line, including the + # InitialMessage. + set beginningIndex [string last " " [string range $errorMsg 0 \ + [expr {80 - $InitialMsgLen}]]] + puts [errorChannel] [string range $errorMsg 0 $beginningIndex] + + while {![string equal end $beginningIndex]} { + puts -nonewline [errorChannel] \ + [string repeat " " $InitialMsgLen] + if {($endingIndex - $beginningIndex) + < (80 - $InitialMsgLen)} { + puts [errorChannel] [string trim \ + [string range $errorMsg $beginningIndex end]] + break + } else { + set newEndingIndex [expr {[string last " " \ + [string range $errorMsg $beginningIndex \ + [expr {$beginningIndex + + (80 - $InitialMsgLen)}] + ]] + $beginningIndex}] + if {($newEndingIndex <= 0) + || ($newEndingIndex <= $beginningIndex)} { + set newEndingIndex end + } + puts [errorChannel] [string trim \ + [string range $errorMsg \ + $beginningIndex $newEndingIndex]] + set beginningIndex $newEndingIndex + } + } + } + flush [errorChannel] + return +} + +# tcltest::SafeFetch -- +# +# The following trace procedure makes it so that we can safely +# refer to non-existent members of the testConstraints array +# without causing an error. Instead, reading a non-existent +# member will return 0. This is necessary because tests are +# allowed to use constraint "X" without ensuring that +# testConstraints("X") is defined. +# +# Arguments: +# n1 - name of the array (testConstraints) +# n2 - array key value (constraint name) +# op - operation performed on testConstraints (generally r) +# +# Results: +# none +# +# Side effects: +# sets testConstraints($n2) to 0 if it's referenced but never +# before used + +proc tcltest::SafeFetch {n1 n2 op} { + variable testConstraints + DebugPuts 3 "entering SafeFetch $n1 $n2 $op" + if {[string equal {} $n2]} {return} + if {![info exists testConstraints($n2)]} { + if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} { + testConstraint $n2 0 + } + } +} + +# tcltest::ConstraintInitializer -- +# +# Get or set a script that when evaluated in the tcltest namespace +# will return a boolean value with which to initialize the +# associated constraint. +# +# Arguments: +# constraint - name of the constraint initialized by the script +# script - the initializer script +# +# Results +# boolean value of the constraint - enabled or disabled +# +# Side effects: +# Constraint is initialized for future reference by [test] +proc tcltest::ConstraintInitializer {constraint {script ""}} { + variable ConstraintInitializer + DebugPuts 3 "entering ConstraintInitializer $constraint $script" + if {[llength [info level 0]] == 2} { + return $ConstraintInitializer($constraint) + } + # Check for boolean values + if {![info complete $script]} { + return -code error "ConstraintInitializer must be complete script" + } + set ConstraintInitializer($constraint) $script +} + +# tcltest::InitConstraints -- +# +# Call all registered constraint initializers to force initialization +# of all known constraints. +# See the tcltest man page for the list of built-in constraints defined +# in this procedure. +# +# Arguments: +# none +# +# Results: +# The testConstraints array is reset to have an index for each +# built-in test constraint. +# +# Side Effects: +# None. +# + +proc tcltest::InitConstraints {} { + variable ConstraintInitializer + initConstraintsHook + foreach constraint [array names ConstraintInitializer] { + testConstraint $constraint + } +} + +proc tcltest::DefineConstraintInitializers {} { + ConstraintInitializer singleTestInterp {singleProcess} + + # All the 'pc' constraints are here for backward compatibility and + # are not documented. They have been replaced with equivalent 'win' + # constraints. + + ConstraintInitializer unixOnly \ + {string equal $::tcl_platform(platform) unix} + ConstraintInitializer macOnly \ + {string equal $::tcl_platform(platform) macintosh} + ConstraintInitializer pcOnly \ + {string equal $::tcl_platform(platform) windows} + ConstraintInitializer winOnly \ + {string equal $::tcl_platform(platform) windows} + + ConstraintInitializer unix {testConstraint unixOnly} + ConstraintInitializer mac {testConstraint macOnly} + ConstraintInitializer pc {testConstraint pcOnly} + ConstraintInitializer win {testConstraint winOnly} + + ConstraintInitializer unixOrPc \ + {expr {[testConstraint unix] || [testConstraint pc]}} + ConstraintInitializer macOrPc \ + {expr {[testConstraint mac] || [testConstraint pc]}} + ConstraintInitializer unixOrWin \ + {expr {[testConstraint unix] || [testConstraint win]}} + ConstraintInitializer macOrWin \ + {expr {[testConstraint mac] || [testConstraint win]}} + ConstraintInitializer macOrUnix \ + {expr {[testConstraint mac] || [testConstraint unix]}} + + ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"} + ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"} + ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"} + + # The following Constraints switches are used to mark tests that + # should work, but have been temporarily disabled on certain + # platforms because they don't and we haven't gotten around to + # fixing the underlying problem. + + ConstraintInitializer tempNotPc {expr {![testConstraint pc]}} + ConstraintInitializer tempNotWin {expr {![testConstraint win]}} + ConstraintInitializer tempNotMac {expr {![testConstraint mac]}} + ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}} + + # The following Constraints switches are used to mark tests that + # crash on certain platforms, so that they can be reactivated again + # when the underlying problem is fixed. + + ConstraintInitializer pcCrash {expr {![testConstraint pc]}} + ConstraintInitializer winCrash {expr {![testConstraint win]}} + ConstraintInitializer macCrash {expr {![testConstraint mac]}} + ConstraintInitializer unixCrash {expr {![testConstraint unix]}} + + # Skip empty tests + + ConstraintInitializer emptyTest {format 0} + + # By default, tests that expose known bugs are skipped. + + ConstraintInitializer knownBug {format 0} + + # By default, non-portable tests are skipped. + + ConstraintInitializer nonPortable {format 0} + + # Some tests require user interaction. + + ConstraintInitializer userInteraction {format 0} + + # Some tests must be skipped if the interpreter is not in + # interactive mode + + ConstraintInitializer interactive \ + {expr {[info exists ::tcl_interactive] && $::tcl_interactive}} + + # Some tests can only be run if the installation came from a CD + # image instead of a web image. Some tests must be skipped if you + # are running as root on Unix. Other tests can only be run if you + # are running as root on Unix. + + ConstraintInitializer root {expr \ + {[string equal unix $::tcl_platform(platform)] + && ([string equal root $::tcl_platform(user)] + || [string equal "" $::tcl_platform(user)])}} + ConstraintInitializer notRoot {expr {![testConstraint root]}} + + # Set nonBlockFiles constraint: 1 means this platform supports + # setting files into nonblocking mode. + + ConstraintInitializer nonBlockFiles { + set code [expr {[catch {set f [open defs r]}] + || [catch {fconfigure $f -blocking off}]}] + catch {close $f} + set code + } + + # Set asyncPipeClose constraint: 1 means this platform supports + # async flush and async close on a pipe. + # + # Test for SCO Unix - cannot run async flushing tests because a + # potential problem with select is apparently interfering. + # (Mark Diekhans). + + ConstraintInitializer asyncPipeClose {expr { + !([string equal unix $::tcl_platform(platform)] + && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}} + + # Test to see if we have a broken version of sprintf with respect + # to the "e" format of floating-point numbers. + + ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} + + # Test to see if execed commands such as cat, echo, rm and so forth + # are present on this machine. + + ConstraintInitializer unixExecs { + set code 1 + if {[string equal macintosh $::tcl_platform(platform)]} { + set code 0 + } + if {[string equal windows $::tcl_platform(platform)]} { + if {[catch { + set file _tcl_test_remove_me.txt + makeFile {hello} $file + }]} { + set code 0 + } elseif { + [catch {exec cat $file}] || + [catch {exec echo hello}] || + [catch {exec sh -c echo hello}] || + [catch {exec wc $file}] || + [catch {exec sleep 1}] || + [catch {exec echo abc > $file}] || + [catch {exec chmod 644 $file}] || + [catch {exec rm $file}] || + [llength [auto_execok mkdir]] == 0 || + [llength [auto_execok fgrep]] == 0 || + [llength [auto_execok grep]] == 0 || + [llength [auto_execok ps]] == 0 + } { + set code 0 + } + removeFile $file + } + set code + } + + ConstraintInitializer stdio { + set code 0 + if {![catch {set f [open "|[list [interpreter]]" w]}]} { + if {![catch {puts $f exit}]} { + if {![catch {close $f}]} { + set code 1 + } + } + } + set code + } + + # Deliberately call socket with the wrong number of arguments. The + # error message you get will indicate whether sockets are available + # on this system. + + ConstraintInitializer socket { + catch {socket} msg + string compare $msg "sockets are not available on this system" + } + + # Check for internationalization + ConstraintInitializer hasIsoLocale { + if {[llength [info commands testlocale]] == 0} { + set code 0 + } else { + set code [string length [SetIso8859_1_Locale]] + RestoreLocale + } + set code + } + +} +##################################################################### + +# Usage and command line arguments processing. + +# tcltest::PrintUsageInfo +# +# Prints out the usage information for package tcltest. This can +# be customized with the redefinition of [PrintUsageInfoHook]. +# +# Arguments: +# none +# +# Results: +# none +# +# Side Effects: +# none +proc tcltest::PrintUsageInfo {} { + puts [Usage] + PrintUsageInfoHook +} + +proc tcltest::Usage { {option ""} } { + variable Usage + variable Verify + if {[llength [info level 0]] == 1} { + set msg "Usage: [file tail [info nameofexecutable]] script " + append msg "?-help? ?flag value? ... \n" + append msg "Available flags (and valid input values) are:" + + set max 0 + set allOpts [concat -help [Configure]] + foreach opt $allOpts { + set foo [Usage $opt] + foreach [list x type($opt) usage($opt)] $foo break + set line($opt) " $opt $type($opt) " + set length($opt) [string length $line($opt)] + if {$length($opt) > $max} {set max $length($opt)} + } + set rest [expr {72 - $max}] + foreach opt $allOpts { + append msg \n$line($opt) + append msg [string repeat " " [expr {$max - $length($opt)}]] + set u [string trim $usage($opt)] + catch {append u " (default: \[[Configure $opt]])"} + regsub -all {\s*\n\s*} $u " " u + while {[string length $u] > $rest} { + set break [string wordstart $u $rest] + if {$break == 0} { + set break [string wordend $u 0] + } + append msg [string range $u 0 [expr {$break - 1}]] + set u [string trim [string range $u $break end]] + append msg \n[string repeat " " $max] + } + append msg $u + } + return $msg\n + } elseif {[string equal -help $option]} { + return [list -help "" "Display this usage information."] + } else { + set type [lindex [info args $Verify($option)] 0] + return [list $option $type $Usage($option)] + } +} + +# tcltest::ProcessFlags -- +# +# process command line arguments supplied in the flagArray - this +# is called by processCmdLineArgs. Modifies tcltest variables +# according to the content of the flagArray. +# +# Arguments: +# flagArray - array containing name/value pairs of flags +# +# Results: +# sets tcltest variables according to their values as defined by +# flagArray +# +# Side effects: +# None. + +proc tcltest::ProcessFlags {flagArray} { + # Process -help first + if {[lsearch -exact $flagArray {-help}] != -1} { + PrintUsageInfo + exit 1 + } + + if {[llength $flagArray] == 0} { + RemoveAutoConfigureTraces + } else { + set args $flagArray + while {[llength $args]>1 && [catch {eval configure $args} msg]} { + + # Something went wrong parsing $args for tcltest options + # Check whether the problem is "unknown option" + if {[regexp {^unknown option (\S+):} $msg -> option]} { + # Could be this is an option the Hook knows about + set moreOptions [processCmdLineArgsAddFlagsHook] + if {[lsearch -exact $moreOptions $option] == -1} { + # Nope. Report the error, including additional options, + # but keep going + if {[llength $moreOptions]} { + append msg ", " + append msg [join [lrange $moreOptions 0 end-1] ", "] + append msg "or [lindex $moreOptions end]" + } + Warn $msg + } + } else { + # error is something other than "unknown option" + # notify user of the error; and exit + puts [errorChannel] $msg + exit 1 + } + + # To recover, find that unknown option and remove up to it. + # then retry + while {![string equal [lindex $args 0] $option]} { + set args [lrange $args 2 end] + } + set args [lrange $args 2 end] + } + if {[llength $args] == 1} { + puts [errorChannel] \ + "missing value for option [lindex $args 0]" + exit 1 + } + } + + # Call the hook + array set flag $flagArray + processCmdLineArgsHook [array get flag] + return +} + +# tcltest::ProcessCmdLineArgs -- +# +# This procedure must be run after constraint initialization is +# set up (by [DefineConstraintInitializers]) because some constraints +# can be overridden. +# +# Perform configuration according to the command-line options. +# +# Arguments: +# none +# +# Results: +# Sets the above-named variables in the tcltest namespace. +# +# Side Effects: +# None. +# + +proc tcltest::ProcessCmdLineArgs {} { + variable originalEnv + variable testConstraints + + # The "argv" var doesn't exist in some cases, so use {}. + if {![info exists ::argv]} { + ProcessFlags {} + } else { + ProcessFlags $::argv + } + + # Spit out everything you know if we're at a debug level 2 or + # greater + DebugPuts 2 "Flags passed into tcltest:" + if {[info exists ::env(TCLTEST_OPTIONS)]} { + DebugPuts 2 \ + " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" + } + if {[info exists argv]} { + DebugPuts 2 " argv: $argv" + } + DebugPuts 2 "tcltest::debug = [debug]" + DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]" + DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]" + DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]" + DebugPuts 2 "tcltest::outputChannel = [outputChannel]" + DebugPuts 2 "tcltest::errorChannel = [errorChannel]" + DebugPuts 2 "Original environment (tcltest::originalEnv):" + DebugPArray 2 originalEnv + DebugPuts 2 "Constraints:" + DebugPArray 2 testConstraints +} + +##################################################################### + +# Code to run the tests goes here. + +# tcltest::TestPuts -- +# +# Used to redefine puts in test environment. Stores whatever goes +# out on stdout in tcltest::outData and stderr in errData before +# sending it on to the regular puts. +# +# Arguments: +# same as standard puts +# +# Results: +# none +# +# Side effects: +# Intercepts puts; data that would otherwise go to stdout, stderr, +# or file channels specified in outputChannel and errorChannel +# does not get sent to the normal puts function. +namespace eval tcltest::Replace { + namespace export puts +} +proc tcltest::Replace::puts {args} { + variable [namespace parent]::outData + variable [namespace parent]::errData + switch [llength $args] { + 1 { + # Only the string to be printed is specified + append outData [lindex $args 0]\n + return + # return [Puts [lindex $args 0]] + } + 2 { + # Either -nonewline or channelId has been specified + if {[string equal -nonewline [lindex $args 0]]} { + append outData [lindex $args end] + return + # return [Puts -nonewline [lindex $args end]] + } else { + set channel [lindex $args 0] + set newline \n + } + } + 3 { + if {[string equal -nonewline [lindex $args 0]]} { + # Both -nonewline and channelId are specified, unless + # it's an error. -nonewline is supposed to be argv[0]. + set channel [lindex $args 1] + set newline "" + } + } + } + + if {[info exists channel]} { + if {[string equal $channel [[namespace parent]::outputChannel]] + || [string equal $channel stdout]} { + append outData [lindex $args end]$newline + return + } elseif {[string equal $channel [[namespace parent]::errorChannel]] + || [string equal $channel stderr]} { + append errData [lindex $args end]$newline + return + } + } + + # If we haven't returned by now, we don't know how to handle the + # input. Let puts handle it. + return [eval Puts $args] +} + +# tcltest::Eval -- +# +# Evaluate the script in the test environment. If ignoreOutput is +# false, store data sent to stderr and stdout in outData and +# errData. Otherwise, ignore this output altogether. +# +# Arguments: +# script Script to evaluate +# ?ignoreOutput? Indicates whether or not to ignore output +# sent to stdout & stderr +# +# Results: +# result from running the script +# +# Side effects: +# Empties the contents of outData and errData before running a +# test if ignoreOutput is set to 0. + +proc tcltest::Eval {script {ignoreOutput 1}} { + variable outData + variable errData + DebugPuts 3 "[lindex [info level 0] 0] called" + if {!$ignoreOutput} { + set outData {} + set errData {} + rename ::puts [namespace current]::Replace::Puts + namespace eval :: \ + [list namespace import [namespace origin Replace::puts]] + namespace import Replace::puts + } + set result [uplevel 1 $script] + if {!$ignoreOutput} { + namespace forget puts + namespace eval :: namespace forget puts + rename [namespace current]::Replace::Puts ::puts + } + return $result +} + +# tcltest::CompareStrings -- +# +# compares the expected answer to the actual answer, depending on +# the mode provided. Mode determines whether a regexp, exact, +# glob or custom comparison is done. +# +# Arguments: +# actual - string containing the actual result +# expected - pattern to be matched against +# mode - type of comparison to be done +# +# Results: +# result of the match +# +# Side effects: +# None. + +proc tcltest::CompareStrings {actual expected mode} { + variable CustomMatch + if {![info exists CustomMatch($mode)]} { + return -code error "No matching command registered for `-match $mode'" + } + set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]] + if {[catch {expr {$match && $match}} result]} { + return -code error "Invalid result from `-match $mode' command: $result" + } + return $match +} + +# tcltest::customMatch -- +# +# registers a command to be called when a particular type of +# matching is required. +# +# Arguments: +# nickname - Keyword for the type of matching +# cmd - Incomplete command that implements that type of matching +# when completed with expected string and actual string +# and then evaluated. +# +# Results: +# None. +# +# Side effects: +# Sets the variable tcltest::CustomMatch + +proc tcltest::customMatch {mode script} { + variable CustomMatch + if {![info complete $script]} { + return -code error \ + "invalid customMatch script; can't evaluate after completion" + } + set CustomMatch($mode) $script +} + +# tcltest::SubstArguments list +# +# This helper function takes in a list of words, then perform a +# substitution on the list as though each word in the list is a separate +# argument to the Tcl function. For example, if this function is +# invoked as: +# +# SubstArguments {$a {$a}} +# +# Then it is as though the function is invoked as: +# +# SubstArguments $a {$a} +# +# This code is adapted from Paul Duffin's function "SplitIntoWords". +# The original function can be found on: +# +# http://purl.org/thecliff/tcl/wiki/858.html +# +# Results: +# a list containing the result of the substitution +# +# Exceptions: +# An error may occur if the list containing unbalanced quote or +# unknown variable. +# +# Side Effects: +# None. +# + +proc tcltest::SubstArguments {argList} { + + # We need to split the argList up into tokens but cannot use list + # operations as they throw away some significant quoting, and + # [split] ignores braces as it should. Therefore what we do is + # gradually build up a string out of whitespace seperated strings. + # We cannot use [split] to split the argList into whitespace + # separated strings as it throws away the whitespace which maybe + # important so we have to do it all by hand. + + set result {} + set token "" + + while {[string length $argList]} { + # Look for the next word containing a quote: " { } + if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ + $argList all]} { + # Get the text leading up to this word, but not including + # this word, from the argList. + set text [string range $argList 0 \ + [expr {[lindex $all 0] - 1}]] + # Get the word with the quote + set word [string range $argList \ + [lindex $all 0] [lindex $all 1]] + + # Remove all text up to and including the word from the + # argList. + set argList [string range $argList \ + [expr {[lindex $all 1] + 1}] end] + } else { + # Take everything up to the end of the argList. + set text $argList + set word {} + set argList {} + } + + if {$token != {}} { + # If we saw a word with quote before, then there is a + # multi-word token starting with that word. In this case, + # add the text and the current word to this token. + append token $text $word + } else { + # Add the text to the result. There is no need to parse + # the text because it couldn't be a part of any multi-word + # token. Then start a new multi-word token with the word + # because we need to pass this token to the Tcl parser to + # check for balancing quotes + append result $text + set token $word + } + + if { [catch {llength $token} length] == 0 && $length == 1} { + # The token is a valid list so add it to the result. + # lappend result [string trim $token] + append result \{$token\} + set token {} + } + } + + # If the last token has not been added to the list then there + # is a problem. + if { [string length $token] } { + error "incomplete token \"$token\"" + } + + return $result +} + + +# tcltest::test -- +# +# This procedure runs a test and prints an error message if the test +# fails. If verbose has been set, it also prints a message even if the +# test succeeds. The test will be skipped if it doesn't match the +# match variable, if it matches an element in skip, or if one of the +# elements of "constraints" turns out not to be true. +# +# If testLevel is 1, then this is a top level test, and we record +# pass/fail information; otherwise, this information is not logged and +# is not added to running totals. +# +# Attributes: +# Only description is a required attribute. All others are optional. +# Default values are indicated. +# +# constraints - A list of one or more keywords, each of which +# must be the name of an element in the array +# "testConstraints". If any of these elements is +# zero, the test is skipped. This attribute is +# optional; default is {} +# body - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. This attribute is optional; +# default is {} +# result - Expected result from script. This attribute is +# optional; default is {}. +# output - Expected output sent to stdout. This attribute +# is optional; default is {}. +# errorOutput - Expected output sent to stderr. This attribute +# is optional; default is {}. +# returnCodes - Expected return codes. This attribute is +# optional; default is {0 2}. +# setup - Code to run before $script (above). This +# attribute is optional; default is {}. +# cleanup - Code to run after $script (above). This +# attribute is optional; default is {}. +# match - specifies type of matching to do on result, +# output, errorOutput; this must be a string +# previously registered by a call to [customMatch]. +# The strings exact, glob, and regexp are pre-registered +# by the tcltest package. Default value is exact. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# +# Results: +# None. +# +# Side effects: +# Just about anything is possible depending on the test. +# + +proc tcltest::test {name description args} { + global tcl_platform + variable testLevel + variable coreModTime + DebugPuts 3 "test $name $args" + DebugDo 1 { + variable TestNames + catch { + puts "test name '$name' re-used; prior use in $TestNames($name)" + } + set TestNames($name) [info script] + } + + FillFilesExisted + incr testLevel + + # Pre-define everything to null except output and errorOutput. We + # determine whether or not to trap output based on whether or not + # these variables (output & errorOutput) are defined. + foreach item {constraints setup cleanup body result returnCodes + match} { + set $item {} + } + + # Set the default match mode + set match exact + + # Set the default match values for return codes (0 is the standard + # expected return value if everything went well; 2 represents + # 'return' being used in the test script). + set returnCodes [list 0 2] + + # The old test format can't have a 3rd argument (constraints or + # script) that starts with '-'. + if {[string match -* [lindex $args 0]] + || ([llength $args] <= 1)} { + if {[llength $args] == 1} { + set list [SubstArguments [lindex $args 0]] + foreach {element value} $list { + set testAttributes($element) $value + } + foreach item {constraints match setup body cleanup \ + result returnCodes output errorOutput} { + if {[info exists testAttributes(-$item)]} { + set testAttributes(-$item) [uplevel 1 \ + ::concat $testAttributes(-$item)] + } + } + } else { + array set testAttributes $args + } + + set validFlags {-setup -cleanup -body -result -returnCodes \ + -match -output -errorOutput -constraints} + + foreach flag [array names testAttributes] { + if {[lsearch -exact $validFlags $flag] == -1} { + incr testLevel -1 + set sorted [lsort $validFlags] + set options [join [lrange $sorted 0 end-1] ", "] + append options ", or [lindex $sorted end]" + return -code error "bad option \"$flag\": must be $options" + } + } + + # store whatever the user gave us + foreach item [array names testAttributes] { + set [string trimleft $item "-"] $testAttributes($item) + } + + # Check the values supplied for -match + variable CustomMatch + if {[lsearch [array names CustomMatch] $match] == -1} { + incr testLevel -1 + set sorted [lsort [array names CustomMatch]] + set values [join [lrange $sorted 0 end-1] ", "] + append values ", or [lindex $sorted end]" + return -code error "bad -match value \"$match\":\ + must be $values" + } + + # Replace symbolic valies supplied for -returnCodes + foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { + set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] + } + } else { + # This is parsing for the old test command format; it is here + # for backward compatibility. + set result [lindex $args end] + if {[llength $args] == 2} { + set body [lindex $args 0] + } elseif {[llength $args] == 3} { + set constraints [lindex $args 0] + set body [lindex $args 1] + } else { + incr testLevel -1 + return -code error "wrong # args:\ + should be \"test name desc ?options?\"" + } + } + + if {[Skipped $name $constraints]} { + incr testLevel -1 + return + } + + # Save information about the core file. + if {[preserveCore]} { + if {[file exists [file join [workingDirectory] core]]} { + set coreModTime [file mtime [file join [workingDirectory] core]] + } + } + + # First, run the setup script + set code [catch {uplevel 1 $setup} setupMsg] + set setupFailure [expr {$code != 0}] + + # Only run the test body if the setup was successful + if {!$setupFailure} { + + # Verbose notification of $body start + if {[IsVerbose start]} { + puts [outputChannel] "---- $name start" + flush [outputChannel] + } + + set command [list [namespace origin RunTest] $name $body] + if {[info exists output] || [info exists errorOutput]} { + set testResult [uplevel 1 [list [namespace origin Eval] $command 0]] + } else { + set testResult [uplevel 1 [list [namespace origin Eval] $command 1]] + } + foreach {actualAnswer returnCode} $testResult break + } + + # Always run the cleanup script + set code [catch {uplevel 1 $cleanup} cleanupMsg] + set cleanupFailure [expr {$code != 0}] + + set coreFailure 0 + set coreMsg "" + # check for a core file first - if one was created by the test, + # then the test failed + if {[preserveCore]} { + if {[file exists [file join [workingDirectory] core]]} { + # There's only a test failure if there is a core file + # and (1) there previously wasn't one or (2) the new + # one is different from the old one. + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join [workingDirectory] core]]} { + set coreFailure 1 + } + } else { + set coreFailure 1 + } + + if {([preserveCore] > 1) && ($coreFailure)} { + append coreMsg "\nMoving file to:\ + [file join [temporaryDirectory] core-$name]" + catch {file rename -force \ + [file join [workingDirectory] core] \ + [file join [temporaryDirectory] core-$name] + } msg + if {[string length $msg] > 0} { + append coreMsg "\nError:\ + Problem renaming core file: $msg" + } + } + } + } + + # check if the return code matched the expected return code + set codeFailure 0 + if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} { + set codeFailure 1 + } + + # If expected output/error strings exist, we have to compare + # them. If the comparison fails, then so did the test. + set outputFailure 0 + variable outData + if {[info exists output] && !$codeFailure} { + if {[set outputCompare [catch { + CompareStrings $outData $output $match + } outputMatch]] == 0} { + set outputFailure [expr {!$outputMatch}] + } else { + set outputFailure 1 + } + } + + set errorFailure 0 + variable errData + if {[info exists errorOutput] && !$codeFailure} { + if {[set errorCompare [catch { + CompareStrings $errData $errorOutput $match + } errorMatch]] == 0} { + set errorFailure [expr {!$errorMatch}] + } else { + set errorFailure 1 + } + } + + # check if the answer matched the expected answer + # Only check if we ran the body of the test (no setup failure) + if {$setupFailure || $codeFailure} { + set scriptFailure 0 + } elseif {[set scriptCompare [catch { + CompareStrings $actualAnswer $result $match + } scriptMatch]] == 0} { + set scriptFailure [expr {!$scriptMatch}] + } else { + set scriptFailure 1 + } + + # if we didn't experience any failures, then we passed + variable numTests + if {!($setupFailure || $cleanupFailure || $coreFailure + || $outputFailure || $errorFailure || $codeFailure + || $scriptFailure)} { + if {$testLevel == 1} { + incr numTests(Passed) + if {[IsVerbose pass]} { + puts [outputChannel] "++++ $name PASSED" + } + } + incr testLevel -1 + return + } + + # We know the test failed, tally it... + if {$testLevel == 1} { + incr numTests(Failed) + } + + # ... then report according to the type of failure + variable currentFailure true + if {![IsVerbose body]} { + set body "" + } + puts [outputChannel] "\n==== $name\ + [string trim $description] FAILED" + if {[string length $body]} { + puts [outputChannel] "==== Contents of test case:" + puts [outputChannel] $body + } + if {$setupFailure} { + puts [outputChannel] "---- Test setup\ + failed:\n$setupMsg" + } + if {$scriptFailure} { + if {$scriptCompare} { + puts [outputChannel] "---- Error testing result: $scriptMatch" + } else { + puts [outputChannel] "---- Result was:\n$actualAnswer" + puts [outputChannel] "---- Result should have been\ + ($match matching):\n$result" + } + } + if {$codeFailure} { + switch -- $returnCode { + 0 { set msg "Test completed normally" } + 1 { set msg "Test generated error" } + 2 { set msg "Test generated return exception" } + 3 { set msg "Test generated break exception" } + 4 { set msg "Test generated continue exception" } + default { set msg "Test generated exception" } + } + puts [outputChannel] "---- $msg; Return code was: $returnCode" + puts [outputChannel] "---- Return code should have been\ + one of: $returnCodes" + if {[IsVerbose error]} { + if {[info exists ::errorInfo]} { + puts [outputChannel] "---- errorInfo: $::errorInfo" + puts [outputChannel] "---- errorCode: $::errorCode" + } + } + } + if {$outputFailure} { + if {$outputCompare} { + puts [outputChannel] "---- Error testing output: $outputMatch" + } else { + puts [outputChannel] "---- Output was:\n$outData" + puts [outputChannel] "---- Output should have been\ + ($match matching):\n$output" + } + } + if {$errorFailure} { + if {$errorCompare} { + puts [outputChannel] "---- Error testing errorOutput: $errorMatch" + } else { + puts [outputChannel] "---- Error output was:\n$errData" + puts [outputChannel] "---- Error output should have\ + been ($match matching):\n$errorOutput" + } + } + if {$cleanupFailure} { + puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" + } + if {$coreFailure} { + puts [outputChannel] "---- Core file produced while running\ + test! $coreMsg" + } + puts [outputChannel] "==== $name FAILED\n" + + incr testLevel -1 + return +} + +# Skipped -- +# +# Given a test name and it constraints, returns a boolean indicating +# whether the current configuration says the test should be skipped. +# +# Side Effects: Maintains tally of total tests seen and tests skipped. +# +proc tcltest::Skipped {name constraints} { + variable testLevel + variable numTests + variable testConstraints + + if {$testLevel == 1} { + incr numTests(Total) + } + # skip the test if it's name matches an element of skip + foreach pattern [skip] { + if {[string match $pattern $name]} { + if {$testLevel == 1} { + incr numTests(Skipped) + DebugDo 1 {AddToSkippedBecause userSpecifiedSkip} + } + return 1 + } + } + # skip the test if it's name doesn't match any element of match + set ok 0 + foreach pattern [match] { + if {[string match $pattern $name]} { + set ok 1 + break + } + } + if {!$ok} { + if {$testLevel == 1} { + incr numTests(Skipped) + DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch} + } + return 1 + } + if {[string equal {} $constraints]} { + # If we're limited to the listed constraints and there aren't + # any listed, then we shouldn't run the test. + if {[limitConstraints]} { + AddToSkippedBecause userSpecifiedLimitConstraint + if {$testLevel == 1} { + incr numTests(Skipped) + } + return 1 + } + } else { + # "constraints" argument exists; + # make sure that the constraints are satisfied. + + set doTest 0 + if {[string match {*[$\[]*} $constraints] != 0} { + # full expression, e.g. {$foo > [info tclversion]} + catch {set doTest [uplevel #0 expr $constraints]} + } elseif {[regexp {[^.a-zA-Z0-9 \n\r\t]+} $constraints] != 0} { + # something like {a || b} should be turned into + # $testConstraints(a) || $testConstraints(b). + regsub -all {[.\w]+} $constraints {$testConstraints(&)} c + catch {set doTest [eval expr $c]} + } elseif {![catch {llength $constraints}]} { + # just simple constraints such as {unixOnly fonts}. + set doTest 1 + foreach constraint $constraints { + if {(![info exists testConstraints($constraint)]) \ + || (!$testConstraints($constraint))} { + set doTest 0 + + # store the constraint that kept the test from + # running + set constraints $constraint + break + } + } + } + + if {$doTest == 0} { + if {[IsVerbose skip]} { + puts [outputChannel] "++++ $name SKIPPED: $constraints" + } + + if {$testLevel == 1} { + incr numTests(Skipped) + AddToSkippedBecause $constraints + } + return 1 + } + } + return 0 +} + +# RunTest -- +# +# This is where the body of a test is evaluated. The combination of +# [RunTest] and [Eval] allows the output and error output of the test +# body to be captured for comparison against the expected values. + +proc tcltest::RunTest {name script} { + DebugPuts 3 "Running $name {$script}" + + # If there is no "memory" command (because memory debugging isn't + # enabled), then don't attempt to use the command. + + if {[llength [info commands memory]] == 1} { + memory tag $name + } + + set code [catch {uplevel 1 $script} actualAnswer] + + return [list $actualAnswer $code] +} + +##################################################################### + +# tcltest::cleanupTestsHook -- +# +# This hook allows a harness that builds upon tcltest to specify +# additional things that should be done at cleanup. +# + +if {[llength [info commands tcltest::cleanupTestsHook]] == 0} { + proc tcltest::cleanupTestsHook {} {} +} + +# tcltest::cleanupTests -- +# +# Remove files and dirs created using the makeFile and makeDirectory +# commands since the last time this proc was invoked. +# +# Print the names of the files created without the makeFile command +# since the tests were invoked. +# +# Print the number tests (total, passed, failed, and skipped) since the +# tests were invoked. +# +# Restore original environment (as reported by special variable env). +# +# Arguments: +# calledFromAllFile - if 0, behave as if we are running a single +# test file within an entire suite of tests. if we aren't running +# a single test file, then don't report status. check for new +# files created during the test run and report on them. if 1, +# report collated status from all the test file runs. +# +# Results: +# None. +# +# Side Effects: +# None +# + +proc tcltest::cleanupTests {{calledFromAllFile 0}} { + variable filesMade + variable filesExisted + variable createdNewFiles + variable testSingleFile + variable numTests + variable numTestFiles + variable failFiles + variable skippedBecause + variable currentFailure + variable originalEnv + variable originalTclPlatform + variable coreModTime + + FillFilesExisted + set testFileName [file tail [info script]] + + # Call the cleanup hook + cleanupTestsHook + + # Remove files and directories created by the makeFile and + # makeDirectory procedures. Record the names of files in + # workingDirectory that were not pre-existing, and associate them + # with the test file that created them. + + if {!$calledFromAllFile} { + foreach file $filesMade { + if {[file exists $file]} { + DebugDo 1 {Warn "cleanupTests deleting $file..."} + catch {file delete -force $file} + } + } + set currentFiles {} + foreach file [glob -nocomplain \ + -directory [temporaryDirectory] *] { + lappend currentFiles [file tail $file] + } + set newFiles {} + foreach file $currentFiles { + if {[lsearch -exact $filesExisted $file] == -1} { + lappend newFiles $file + } + } + set filesExisted $currentFiles + if {[llength $newFiles] > 0} { + set createdNewFiles($testFileName) $newFiles + } + } + + if {$calledFromAllFile || $testSingleFile} { + + # print stats + + puts -nonewline [outputChannel] "$testFileName:" + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + puts -nonewline [outputChannel] \ + "\t$index\t$numTests($index)" + } + puts [outputChannel] "" + + # print number test files sourced + # print names of files that ran tests which failed + + if {$calledFromAllFile} { + puts [outputChannel] \ + "Sourced $numTestFiles Test Files." + set numTestFiles 0 + if {[llength $failFiles] > 0} { + puts [outputChannel] \ + "Files with failing tests: $failFiles" + set failFiles {} + } + } + + # if any tests were skipped, print the constraints that kept + # them from running. + + set constraintList [array names skippedBecause] + if {[llength $constraintList] > 0} { + puts [outputChannel] \ + "Number of tests skipped for each constraint:" + foreach constraint [lsort $constraintList] { + puts [outputChannel] \ + "\t$skippedBecause($constraint)\t$constraint" + unset skippedBecause($constraint) + } + } + + # report the names of test files in createdNewFiles, and reset + # the array to be empty. + + set testFilesThatTurded [lsort [array names createdNewFiles]] + if {[llength $testFilesThatTurded] > 0} { + puts [outputChannel] "Warning: files left behind:" + foreach testFile $testFilesThatTurded { + puts [outputChannel] \ + "\t$testFile:\t$createdNewFiles($testFile)" + unset createdNewFiles($testFile) + } + } + + # reset filesMade, filesExisted, and numTests + + set filesMade {} + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + set numTests($index) 0 + } + + # exit only if running Tk in non-interactive mode + # This should be changed to determine if an event + # loop is running, which is the real issue. + # Actually, this doesn't belong here at all. A package + # really has no business [exit]-ing an application. + if {![catch {package present Tk}] && ![testConstraint interactive]} { + exit + } + } else { + + # if we're deferring stat-reporting until all files are sourced, + # then add current file to failFile list if any tests in this + # file failed + + incr numTestFiles + if {$currentFailure \ + && ([lsearch -exact $failFiles $testFileName] == -1)} { + lappend failFiles $testFileName + } + set currentFailure false + + # restore the environment to the state it was in before this package + # was loaded + + set newEnv {} + set changedEnv {} + set removedEnv {} + foreach index [array names ::env] { + if {![info exists originalEnv($index)]} { + lappend newEnv $index + unset ::env($index) + } else { + if {$::env($index) != $originalEnv($index)} { + lappend changedEnv $index + set ::env($index) $originalEnv($index) + } + } + } + foreach index [array names originalEnv] { + if {![info exists ::env($index)]} { + lappend removedEnv $index + set ::env($index) $originalEnv($index) + } + } + if {[llength $newEnv] > 0} { + puts [outputChannel] \ + "env array elements created:\t$newEnv" + } + if {[llength $changedEnv] > 0} { + puts [outputChannel] \ + "env array elements changed:\t$changedEnv" + } + if {[llength $removedEnv] > 0} { + puts [outputChannel] \ + "env array elements removed:\t$removedEnv" + } + + set changedTclPlatform {} + foreach index [array names originalTclPlatform] { + if {$::tcl_platform($index) \ + != $originalTclPlatform($index)} { + lappend changedTclPlatform $index + set ::tcl_platform($index) $originalTclPlatform($index) + } + } + if {[llength $changedTclPlatform] > 0} { + puts [outputChannel] "tcl_platform array elements\ + changed:\t$changedTclPlatform" + } + + if {[file exists [file join [workingDirectory] core]]} { + if {[preserveCore] > 1} { + puts "rename core file (> 1)" + puts [outputChannel] "produced core file! \ + Moving file to: \ + [file join [temporaryDirectory] core-$testFileName]" + catch {file rename -force \ + [file join [workingDirectory] core] \ + [file join [temporaryDirectory] core-$testFileName] + } msg + if {[string length $msg] > 0} { + PrintError "Problem renaming file: $msg" + } + } else { + # Print a message if there is a core file and (1) there + # previously wasn't one or (2) the new one is different + # from the old one. + + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join [workingDirectory] core]]} { + puts [outputChannel] "A core file was created!" + } + } else { + puts [outputChannel] "A core file was created!" + } + } + } + } + flush [outputChannel] + flush [errorChannel] + return +} + +##################################################################### + +# Procs that determine which tests/test files to run + +# tcltest::GetMatchingFiles +# +# Looks at the patterns given to match and skip files and uses +# them to put together a list of the tests that will be run. +# +# Arguments: +# directory to search +# +# Results: +# The constructed list is returned to the user. This will +# primarily be used in 'all.tcl' files. It is used in +# runAllTests. +# +# Side Effects: +# None + +# a lower case version is needed for compatibility with tcltest 1.0 +proc tcltest::getMatchingFiles args {eval GetMatchingFiles $args} + +proc tcltest::GetMatchingFiles { args } { + if {[llength $args]} { + set dirList $args + } else { + # Finding tests only in [testsDirectory] is normal operation. + # This procedure is written to accept multiple directory arguments + # only to satisfy version 1 compatibility. + set dirList [list [testsDirectory]] + } + + set matchingFiles [list] + foreach directory $dirList { + + # List files in $directory that match patterns to run. + set matchFileList [list] + foreach match [matchFiles] { + set matchFileList [concat $matchFileList \ + [glob -directory $directory -nocomplain -- $match]] + } + + # List files in $directory that match patterns to skip. + set skipFileList [list] + foreach skip [skipFiles] { + set skipFileList [concat $skipFileList \ + [glob -directory $directory -nocomplain -- $skip]] + } + + # Add to result list all files in match list and not in skip list + foreach file $matchFileList { + if {[lsearch -exact $skipFileList $file] == -1} { + lappend matchingFiles $file + } + } + } + + if {[llength $matchingFiles] == 0} { + PrintError "No test files remain after applying your match and\ + skip patterns!" + } + return $matchingFiles +} + +# tcltest::GetMatchingDirectories -- +# +# Looks at the patterns given to match and skip directories and +# uses them to put together a list of the test directories that we +# should attempt to run. (Only subdirectories containing an +# "all.tcl" file are put into the list.) +# +# Arguments: +# root directory from which to search +# +# Results: +# The constructed list is returned to the user. This is used in +# the primary all.tcl file. +# +# Side Effects: +# None. + +proc tcltest::GetMatchingDirectories {rootdir} { + + # Determine the skip list first, to avoid [glob]-ing over subdirectories + # we're going to throw away anyway. Be sure we skip the $rootdir if it + # comes up to avoid infinite loops. + set skipDirs [list $rootdir] + foreach pattern [skipDirectories] { + foreach path [glob -directory $rootdir -nocomplain -- $pattern] { + if {[file isdirectory $path]} { + lappend skipDirs $path + } + } + } + + # Now step through the matching directories, prune out the skipped ones + # as you go. + set matchDirs [list] + foreach pattern [matchDirectories] { + foreach path [glob -directory $rootdir -nocomplain -- $pattern] { + if {[file isdirectory $path]} { + if {[lsearch -exact $skipDirs $path] == -1} { + set matchDirs [concat $matchDirs \ + [GetMatchingDirectories $path]] + if {[file exists [file join $path all.tcl]]} { + lappend matchDirs $path + } + } + } + } + } + + if {[llength $matchDirs] == 0} { + DebugPuts 1 "No test directories remain after applying match\ + and skip patterns!" + } + return $matchDirs +} + +# tcltest::runAllTests -- +# +# prints output and sources test files according to the match and +# skip patterns provided. after sourcing test files, it goes on +# to source all.tcl files in matching test subdirectories. +# +# Arguments: +# shell being tested +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::runAllTests { {shell ""} } { + variable testSingleFile + variable numTestFiles + variable numTests + variable failFiles + + FillFilesExisted + if {[llength [info level 0]] == 1} { + set shell [interpreter] + } + + set testSingleFile false + + puts [outputChannel] "Tests running in interp: $shell" + puts [outputChannel] "Tests located in: [testsDirectory]" + puts [outputChannel] "Tests running in: [workingDirectory]" + puts [outputChannel] "Temporary files stored in\ + [temporaryDirectory]" + + # [file system] first available in Tcl 8.4 + if {![catch {file system [testsDirectory]} result] + && ![string equal native [lindex $result 0]]} { + # If we aren't running in the native filesystem, then we must + # run the tests in a single process (via 'source'), because + # trying to run then via a pipe will fail since the files don't + # really exist. + singleProcess 1 + } + + if {[singleProcess]} { + puts [outputChannel] \ + "Test files sourced into current interpreter" + } else { + puts [outputChannel] \ + "Test files run in separate interpreters" + } + if {[llength [skip]] > 0} { + puts [outputChannel] "Skipping tests that match: [skip]" + } + puts [outputChannel] "Running tests that match: [match]" + + if {[llength [skipFiles]] > 0} { + puts [outputChannel] \ + "Skipping test files that match: [skipFiles]" + } + if {[llength [matchFiles]] > 0} { + puts [outputChannel] \ + "Only running test files that match: [matchFiles]" + } + + set timeCmd {clock format [clock seconds]} + puts [outputChannel] "Tests began at [eval $timeCmd]" + + # Run each of the specified tests + foreach file [lsort [GetMatchingFiles]] { + set tail [file tail $file] + puts [outputChannel] $tail + flush [outputChannel] + + if {[singleProcess]} { + incr numTestFiles + uplevel 1 [list ::source $file] + } else { + # Pass along our configuration to the child processes. + # EXCEPT for the -outfile, because the parent process + # needs to read and process output of children. + set childargv [list] + foreach opt [Configure] { + if {[string equal $opt -outfile]} {continue} + lappend childargv $opt [Configure $opt] + } + set cmd [linsert $childargv 0 | $shell $file] + if {[catch { + incr numTestFiles + set pipeFd [open $cmd "r"] + while {[gets $pipeFd line] >= 0} { + if {[regexp [join { + {^([^:]+):\t} + {Total\t([0-9]+)\t} + {Passed\t([0-9]+)\t} + {Skipped\t([0-9]+)\t} + {Failed\t([0-9]+)} + } ""] $line null testFile \ + Total Passed Skipped Failed]} { + foreach index {Total Passed Skipped Failed} { + incr numTests($index) [set $index] + } + if {$Failed > 0} { + lappend failFiles $testFile + } + } elseif {[regexp [join { + {^Number of tests skipped } + {for each constraint:} + {|^\t(\d+)\t(.+)$} + } ""] $line match skipped constraint]} { + if {[string match \t* $match]} { + AddToSkippedBecause $constraint $skipped + } + } else { + puts [outputChannel] $line + } + } + close $pipeFd + } msg]} { + puts [outputChannel] "Test file error: $msg" + # append the name of the test to a list to be reported + # later + lappend testFileFailures $file + } + } + } + + # cleanup + puts [outputChannel] "\nTests ended at [eval $timeCmd]" + cleanupTests 1 + if {[info exists testFileFailures]} { + puts [outputChannel] "\nTest files exiting with errors: \n" + foreach file $testFileFailures { + puts [outputChannel] " [file tail $file]\n" + } + } + + # Checking for subdirectories in which to run tests + foreach directory [GetMatchingDirectories [testsDirectory]] { + set dir [file tail $directory] + puts [outputChannel] [string repeat ~ 44] + puts [outputChannel] "$dir test began at [eval $timeCmd]\n" + + uplevel 1 [list ::source [file join $directory all.tcl]] + + set endTime [eval $timeCmd] + puts [outputChannel] "\n$dir test ended at $endTime" + puts [outputChannel] "" + puts [outputChannel] [string repeat ~ 44] + } + return +} + +##################################################################### + +# Test utility procs - not used in tcltest, but may be useful for +# testing. + +# tcltest::loadTestedCommands -- +# +# Uses the specified script to load the commands to test. Allowed to +# be empty, as the tested commands could have been compiled into the +# interpreter. +# +# Arguments +# none +# +# Results +# none +# +# Side Effects: +# none. + +proc tcltest::loadTestedCommands {} { + variable l + if {[string equal {} [loadScript]]} { + return + } + + return [uplevel 1 [loadScript]] +} + +# tcltest::saveState -- +# +# Save information regarding what procs and variables exist. +# +# Arguments: +# none +# +# Results: +# Modifies the variable saveState +# +# Side effects: +# None. + +proc tcltest::saveState {} { + variable saveState + uplevel 1 [list ::set [namespace which -variable saveState]] \ + {[::list [::info procs] [::info vars]]} + DebugPuts 2 "[lindex [info level 0] 0]: $saveState" + return +} + +# tcltest::restoreState -- +# +# Remove procs and variables that didn't exist before the call to +# [saveState]. +# +# Arguments: +# none +# +# Results: +# Removes procs and variables from your environment if they don't +# exist in the saveState variable. +# +# Side effects: +# None. + +proc tcltest::restoreState {} { + variable saveState + foreach p [uplevel 1 {::info procs}] { + if {([lsearch [lindex $saveState 0] $p] < 0) + && ![string equal [namespace current]::$p \ + [uplevel 1 [list ::namespace origin $p]]]} { + + DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p" + uplevel 1 [list ::catch [list ::rename $p {}]] + } + } + foreach p [uplevel 1 {::info vars}] { + if {[lsearch [lindex $saveState 1] $p] < 0} { + DebugPuts 2 "[lindex [info level 0] 0]:\ + Removing variable $p" + uplevel 1 [list ::catch [list ::unset $p]] + } + } + return +} + +# tcltest::normalizeMsg -- +# +# Removes "extra" newlines from a string. +# +# Arguments: +# msg String to be modified +# +# Results: +# string with extra newlines removed +# +# Side effects: +# None. + +proc tcltest::normalizeMsg {msg} { + regsub "\n$" [string tolower $msg] "" msg + set msg [string map [list "\n\n" "\n"] $msg] + return [string map [list "\n\}" "\}"] $msg] +} + +# tcltest::makeFile -- +# +# Create a new file with the name , and write to it. +# +# If this file hasn't been created via makeFile since the last time +# cleanupTests was called, add it to the $filesMade list, so it will be +# removed by the next call to cleanupTests. +# +# Arguments: +# contents content of the new file +# name name of the new file +# directory directory name for new file +# +# Results: +# absolute path to the file created +# +# Side effects: +# None. + +proc tcltest::makeFile {contents name {directory ""}} { + variable filesMade + FillFilesExisted + + if {[llength [info level 0]] == 3} { + set directory [temporaryDirectory] + } + + set fullName [file join $directory $name] + + DebugPuts 3 "[lindex [info level 0] 0]:\ + putting ``$contents'' into $fullName" + + set fd [open $fullName w] + fconfigure $fd -translation lf + if {[string equal [string index $contents end] \n]} { + puts -nonewline $fd $contents + } else { + puts $fd $contents + } + close $fd + + if {[lsearch -exact $filesMade $fullName] == -1} { + lappend filesMade $fullName + } + return $fullName +} + +# tcltest::removeFile -- +# +# Removes the named file from the filesystem +# +# Arguments: +# name file to be removed +# directory directory from which to remove file +# +# Results: +# return value from [file delete] +# +# Side effects: +# None. + +proc tcltest::removeFile {name {directory ""}} { + variable filesMade + FillFilesExisted + if {[llength [info level 0]] == 2} { + set directory [temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" + set idx [lsearch -exact $filesMade $fullName] + set filesMade [lreplace $filesMade $idx $idx] + if {$idx == -1} { + DebugDo 1 { + Warn "removeFile removing \"$fullName\":\n not created by makeFile" + } + } + if {![file isfile $fullName]} { + DebugDo 1 { + Warn "removeFile removing \"$fullName\":\n not a file" + } + } + return [file delete $fullName] +} + +# tcltest::makeDirectory -- +# +# Create a new dir with the name . +# +# If this dir hasn't been created via makeDirectory since the last time +# cleanupTests was called, add it to the $directoriesMade list, so it +# will be removed by the next call to cleanupTests. +# +# Arguments: +# name name of the new directory +# directory directory in which to create new dir +# +# Results: +# absolute path to the directory created +# +# Side effects: +# None. + +proc tcltest::makeDirectory {name {directory ""}} { + variable filesMade + FillFilesExisted + if {[llength [info level 0]] == 2} { + set directory [temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName" + file mkdir $fullName + if {[lsearch -exact $filesMade $fullName] == -1} { + lappend filesMade $fullName + } + return $fullName +} + +# tcltest::removeDirectory -- +# +# Removes a named directory from the file system. +# +# Arguments: +# name Name of the directory to remove +# directory Directory from which to remove +# +# Results: +# return value from [file delete] +# +# Side effects: +# None + +proc tcltest::removeDirectory {name {directory ""}} { + variable filesMade + FillFilesExisted + if {[llength [info level 0]] == 2} { + set directory [temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName" + set idx [lsearch -exact $filesMade $fullName] + set filesMade [lreplace $filesMade $idx $idx] + if {$idx == -1} { + DebugDo 1 { + Warn "removeDirectory removing \"$fullName\":\n not created\ + by makeDirectory" + } + } + if {![file isdirectory $fullName]} { + DebugDo 1 { + Warn "removeDirectory removing \"$fullName\":\n not a directory" + } + } + return [file delete -force $fullName] +} + +# tcltest::viewFile -- +# +# reads the content of a file and returns it +# +# Arguments: +# name of the file to read +# directory in which file is located +# +# Results: +# content of the named file +# +# Side effects: +# None. + +proc tcltest::viewFile {name {directory ""}} { + FillFilesExisted + if {[llength [info level 0]] == 2} { + set directory [temporaryDirectory] + } + set fullName [file join $directory $name] + set f [open $fullName] + set data [read -nonewline $f] + close $f + return $data +} + +# tcltest::bytestring -- +# +# Construct a string that consists of the requested sequence of bytes, +# as opposed to a string of properly formed UTF-8 characters. +# This allows the tester to +# 1. Create denormalized or improperly formed strings to pass to C +# procedures that are supposed to accept strings with embedded NULL +# bytes. +# 2. Confirm that a string result has a certain pattern of bytes, for +# instance to confirm that "\xe0\0" in a Tcl script is stored +# internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". +# +# Generally, it's a bad idea to examine the bytes in a Tcl string or to +# construct improperly formed strings in this manner, because it involves +# exposing that Tcl uses UTF-8 internally. +# +# Arguments: +# string being converted +# +# Results: +# result fom encoding +# +# Side effects: +# None + +proc tcltest::bytestring {string} { + return [encoding convertfrom identity $string] +} + +# tcltest::OpenFiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::OpenFiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +# tcltest::LeakFiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::LeakFiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {[lsearch $old $p] < 0} { + lappend leak $p + } + } + return $leak +} + +# +# Internationalization / ISO support procs -- dl +# + +# tcltest::SetIso8859_1_Locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::SetIso8859_1_Locale {} { + variable previousLocale + variable isoLocale + if {[info commands testlocale] != ""} { + set previousLocale [testlocale ctype] + testlocale ctype $isoLocale + } + return +} + +# tcltest::RestoreLocale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::RestoreLocale {} { + variable previousLocale + if {[info commands testlocale] != ""} { + testlocale ctype $previousLocale + } + return +} + +# tcltest::threadReap -- +# +# Kill all threads except for the main thread. +# Do nothing if testthread is not defined. +# +# Arguments: +# none. +# +# Results: +# Returns the number of existing threads. +# +# Side Effects: +# none. +# + +proc tcltest::threadReap {} { + if {[info commands testthread] != {}} { + + # testthread built into tcltest + + testthread errorproc ThreadNullError + while {[llength [testthread names]] > 1} { + foreach tid [testthread names] { + if {$tid != [mainThread]} { + catch { + testthread send -async $tid {testthread exit} + } + } + } + ## Enter a bit a sleep to give the threads enough breathing + ## room to kill themselves off, otherwise the end up with a + ## massive queue of repeated events + after 1 + } + testthread errorproc ThreadError + return [llength [testthread names]] + } elseif {[info commands thread::id] != {}} { + + # Thread extension + + thread::errorproc ThreadNullError + while {[llength [thread::names]] > 1} { + foreach tid [thread::names] { + if {$tid != [mainThread]} { + catch {thread::send -async $tid {thread::exit}} + } + } + ## Enter a bit a sleep to give the threads enough breathing + ## room to kill themselves off, otherwise the end up with a + ## massive queue of repeated events + after 1 + } + thread::errorproc ThreadError + return [llength [thread::names]] + } else { + return 1 + } + return 0 +} + +# Initialize the constraints and set up command line arguments +namespace eval tcltest { + # Define initializers for all the built-in contraint definitions + DefineConstraintInitializers + + # Set up the constraints in the testConstraints array to be lazily + # initialized by a registered initializer, or by "false" if no + # initializer is registered. + trace variable testConstraints r [namespace code SafeFetch] + + # Only initialize constraints at package load time if an + # [initConstraintsHook] has been pre-defined. This is only + # for compatibility support. The modern way to add a custom + # test constraint is to just call the [testConstraint] command + # straight away, without all this "hook" nonsense. + if {[string equal [namespace current] \ + [namespace qualifiers [namespace which initConstraintsHook]]]} { + InitConstraints + } else { + proc initConstraintsHook {} {} + } + + # Define the standard match commands + customMatch exact [list string equal] + customMatch glob [list string match] + customMatch regexp [list regexp --] + + # If the TCLTEST_OPTIONS environment variable exists, configure + # tcltest according to the option values it specifies. This has + # the effect of resetting tcltest's default configuration. + proc ConfigureFromEnvironment {} { + upvar #0 env(TCLTEST_OPTIONS) options + if {[catch {llength $options} msg]} { + Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\ + Tcl list: $msg" + return + } + if {[llength $::env(TCLTEST_OPTIONS)] < 2} { + Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\ + -option value ?-option value ...?" + return + } + if {[catch {eval Configure $::env(TCLTEST_OPTIONS)} msg]} { + Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg" + return + } + } + if {[info exists ::env(TCLTEST_OPTIONS)]} { + ConfigureFromEnvironment + } + + proc LoadTimeCmdLineArgParsingRequired {} { + set required false + if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} { + # The command line asks for -help, so give it (and exit) + # right now. ([configure] does not process -help) + set required true + } + foreach hook { PrintUsageInfoHook processCmdLineArgsHook + processCmdLineArgsAddFlagsHook } { + if {[string equal [namespace current] [namespace qualifiers \ + [namespace which $hook]]]} { + set required true + } else { + proc $hook args {} + } + } + return $required + } + + # Only initialize configurable options from the command line arguments + # at package load time if necessary for backward compatibility. This + # lets the tcltest user call [configure] for themselves if they wish. + # Traces are established for auto-configuration from the command line + # if any configurable options are accessed before the user calls + # [configure]. + if {[LoadTimeCmdLineArgParsingRequired]} { + ProcessCmdLineArgs + } else { + EstablishAutoConfigureTraces + } + + package provide [namespace tail [namespace current]] $Version +} diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/tests/info.test tcl8.4.6.new/tests/info.test --- tcl8.4.6/tests/info.test Thu Mar 27 05:11:14 2003 +++ tcl8.4.6.new/tests/info.test Mon Jun 14 08:29:25 2004 @@ -628,16 +628,16 @@ } {1 {wrong # args: should be "info option ?arg arg ...?"}} test info-21.2 {miscellaneous error conditions} { list [catch {info gorp} msg] $msg -} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, line, loaded, locals, nameofexecutable, patchlevel, procs, return, script, sharedlibextension, tclversion, or vars}} test info-21.3 {miscellaneous error conditions} { list [catch {info c} msg] $msg -} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, line, loaded, locals, nameofexecutable, patchlevel, procs, return, script, sharedlibextension, tclversion, or vars}} test info-21.4 {miscellaneous error conditions} { list [catch {info l} msg] $msg -} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, line, loaded, locals, nameofexecutable, patchlevel, procs, return, script, sharedlibextension, tclversion, or vars}} test info-21.5 {miscellaneous error conditions} { list [catch {info s} msg] $msg -} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, line, loaded, locals, nameofexecutable, patchlevel, procs, return, script, sharedlibextension, tclversion, or vars}} # cleanup catch {namespace delete test_ns_info1 test_ns_info2} diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/tests/trace.test tcl8.4.6.new/tests/trace.test --- tcl8.4.6/tests/trace.test Mon Sep 29 15:03:44 2003 +++ tcl8.4.6.new/tests/trace.test Mon Jun 14 11:43:00 2004 @@ -784,14 +784,14 @@ 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, remove, execution, variable, vdelete, or vinfo"] # Again, [trace ... command] and [trace ... variable] share syntax and # error message styles for their opList options; these loops test those # error messages. set i 0 -set errs [list "array, read, unset, or write" "delete or rename" "enter, leave, enterstep, or leavestep"] +set errs [list "array, read, unset, write, or debug" "delete or rename" "enter, leave, enterstep, or leavestep"] set abbvs [list {a r u w} {d r} {}] proc x {} {} foreach type {variable command execution} err $errs abbvlist $abbvs { @@ -2141,6 +2141,17 @@ # Unset the varaible when done catch {unset info} +test trace-33.1 { + Line number verification using "trace execution" +} { + set dir [file join [pwd] [file dirname [info script]]] + foreach i {1 2 3} { + set result [exec [info nameofexecutable] ../tools/trcline.tcl ../tests/trcline/trcln$i.tcl] + lappend rc [lindex [lindex [split $result \n] end] end] + } + set rc +} [list 3 0 0] + # cleanup ::tcltest::cleanupTests return diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/tests/trcline/trcln1.tcl tcl8.4.6.new/tests/trcline/trcln1.tcl --- tcl8.4.6/tests/trcline/trcln1.tcl Wed Dec 31 16:00:00 1969 +++ tcl8.4.6.new/tests/trcline/trcln1.tcl Mon Jun 14 11:43:24 2004 @@ -0,0 +1,77 @@ +# This is line 1. +# And 2 \ +3 is continue. +proc ::Echo args { + puts "> $args" +} +#trace execution ::Echo +set i \ +1 +set str { + set x 1 + incr x + incr x $i +} +incr i +puts "i=$i" +eval $str +eval { + set l [expr {$i+1}] + puts $l +} +namespace eval y { + #source /tmp/t +} +proc b args { + puts "HI: $args" +} +namespace eval xx { + set j 1 + incr j + proc a args { + set k 1 + if {$k<1} { + set x 0 + } else { + set x 1 + } + incr k + b aa + } + a + uplevel #0 { + set z 0 + } +} +puts $xx::j +xx::a +foreach f {xx::a b} { + puts "$f: FILE=[info line file $f] LINE=[info line number $f]" +} +proc XX args { +set i 1 +set j 0 +while {[incr i]<6} { + incr j + if {$j>4} break + if {$j>2} continue + incr j 2 +} +for {set i 1} {$i<3} {incr i} { + incr j +} +switch y { + x { + set i 1 + } + y { + set i 2 + } + z { + set i 2 + } +} +set q 1 +} +XX +puts DONE diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/tests/trcline/trcln2.tcl tcl8.4.6.new/tests/trcline/trcln2.tcl --- tcl8.4.6/tests/trcline/trcln2.tcl Wed Dec 31 16:00:00 1969 +++ tcl8.4.6.new/tests/trcline/trcln2.tcl Mon Jun 14 08:29:25 2004 @@ -0,0 +1,11 @@ +proc Echo args { + puts stderr "> $args" +} +#trace execution ::Echo +proc foo args { + puts "FOO: $args" + set ::forever 1 +} + +after idle foo +catch {vwait forever} diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/tests/trcline/trcln3.tcl tcl8.4.6.new/tests/trcline/trcln3.tcl --- tcl8.4.6/tests/trcline/trcln3.tcl Wed Dec 31 16:00:00 1969 +++ tcl8.4.6.new/tests/trcline/trcln3.tcl Mon Jun 14 08:29:25 2004 @@ -0,0 +1,20 @@ +#trace execution stdout + proc a args { + set k 1 + if {$k<1} { + set x 0 + } else { + set x 1 + } + incr k + set j 1 + if {$j<1} { + set y 0 + } else { + set y 1 + } + incr j + } +a +a +set z 1 diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/tools/trcline.tcl tcl8.4.6.new/tools/trcline.tcl --- tcl8.4.6/tools/trcline.tcl Wed Dec 31 16:00:00 1969 +++ tcl8.4.6.new/tools/trcline.tcl Mon Jun 14 11:53:15 2004 @@ -0,0 +1,63 @@ +#!./tclsh +# This utility runs a script using the new Tcl feature "execution trace". +# It is useful for testing the accuracy of the line numbers reported by Tcl. +# It counts the number of traced lines that do not seem to match the reported +# file/line number. Lines that absolutely do not seem to match are echoed. +# The final output line contains the five numeric counters: +# +# lines - all lines where filenames were not null. +# matched - matched perfectly. +# submatch - matched a substring in the file/line. +# matchcmd - matched only the cmd or first token. +# nomatch - did not even match the cmd. +# +# The "nomatch" metric in particular counts when Tcl probably got it wrong. +# However, one case where this is currently occurs is "eval $str". +# But in the future, evaling a variable should be detected and return 0. +# +# Copyright (c) 2004 PDQ Interfaces Inc. http://pdqi.com +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: trcline.tcl,v 1.0 2004/04/01 17:33:45 pmacdonald Exp $ + +array set pc {matched 0 nomatch 0 matchcmd 0 submatch 0 lines 0} + +# Run the specified script in a sub-interp. +set file [lindex $argv 0] +set i [interp create] +$i eval [list set argv0 $file] +$i eval [list set argv [lrange $argv 1 end]] + +proc CheckTrace {line file nest stack nsfunc fcmd ecmd} { + variable pc + # puts "> $line $file $nest $stack $fcmd $ecmd" + if {![string length $file] || $line == {0}} return + incr pc(lines) + if {![file exists pc(file:$file)]} { + set data [read [set fp [open $file]]] + close $fp + set pc(file:$file) [split $data \n] + } + set mline [string trim [lindex $pc(file:$file) [expr {$line-1}]]] + set eline [string trim [lindex [split $ecmd \n] 0]] + set eword [lindex [split $eline { }] 0] + if {$mline == $eline} { + incr pc(matched) + } else { + if {[string first $eline $mline]>=0} { + incr pc(submatch) + } elseif {[string first $eword $mline]<0} { + incr pc(nomatch) + puts "# MISMATCH: <$mline> <$eline>" + } else { + incr pc(matchcmd) + } + } +} +interp alias $i __ExecTrace__ {} CheckTrace +$i eval trace execution __ExecTrace__ +$i eval source $file +puts "$pc(lines) $pc(matched) $pc(submatch) $pc(matchcmd) $pc(nomatch)" + diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl8.4.6/unix/.tdbcnf tcl8.4.6.new/unix/.tdbcnf --- tcl8.4.6/unix/.tdbcnf Wed Dec 31 16:00:00 1969 +++ tcl8.4.6.new/unix/.tdbcnf Mon Jun 14 08:29:25 2004 @@ -0,0 +1 @@ +tdb:showtoolbar 1 tdb:cmdbgcolor white autoload:project 1 debug:trcback 1 tdb:synmax 50000 tdb:bgcolor white tdb:xterm {xterm -bg black} tdb:winstderr 0 tdb:cmdfont {} tdb:types {} tdb:syntax 1 tdb:font {} tdb:cmdforeground {} tdb:geom 620x665 tdb:gdbpath /usr/bin/gdb tdb:foreground {} tdb:vikeys 0