From dfc1f4c5ee46a899d3a2fb497635ecc525d30e30 Mon Sep 17 00:00:00 2001 From: stanton Date: Wed, 2 Dec 1998 01:46:06 +0000 Subject: * generic/tclTest.c (TestevalobjvObjCmd): Updated for EvalObjv change. * tests/parse.test: Updated tests for EvalObjv change. * generic/tclParse.c (EvalObjv, Tcl_EvalObjv): Changed Tcl_EvalObjv interface to remove string and length arguments, preserved original interface as EvalObjv for internal use. * generic/tcl.h: Changed Tcl_EvalObjv interface to remove string and length arguments. * doc/Eval.3: Updated documentation for Tcl_EvalObjv to remove string and length arguments. --- doc/Eval.3 | 16 ++----- generic/tcl.h | 5 +- generic/tclParse.c | 134 +++++++++++++++++++++++++++++++++++++++++++++-------- generic/tclTest.c | 15 ++---- tests/parse.test | 24 +++++----- 5 files changed, 136 insertions(+), 58 deletions(-) diff --git a/doc/Eval.3 b/doc/Eval.3 index b343264..7330c7d 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Eval.3,v 1.1.2.2 1998/09/24 23:58:23 stanton Exp $ +'\" RCS: @(#) $Id: Eval.3,v 1.1.2.3 1998/12/02 01:46:06 stanton Exp $ '\" .so man.macros .TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" @@ -24,7 +24,7 @@ int \fBTcl_EvalFile\fR(\fIinterp, fileName\fR) .sp int -\fBTcl_EvalObjv\fR(\fIinterp, objc, objv, command, numBytes, flags\fR) +\fBTcl_EvalObjv\fR(\fIinterp, objc, objv, flags\fR) .sp int \fBTcl_Eval\fR(\fIinterp, script\fR) @@ -55,13 +55,8 @@ this is also the number of words in the command. .AP Tcl_Obj **objv in Points to an array of pointers to objects; each object holds the value of a single word in the command to execute. -.AP char *command in -Points to the beginning of the string representation of the -command, if there is one. If the string representation of the -command is unknown then an empty string should be supplied. -This information is used for command tracing. .AP int numBytes in -The number of bytes in \fIcommand\fR or \fIscript\fR, not including any +The number of bytes in \fIscript\fR, not including any null terminating character. If \-1, then all characters up to the first null byte are used. .AP char *script in @@ -103,11 +98,6 @@ script. The \fIobjc\fR and \fIobjv\fR arguments contain the values of the words for the Tcl command, one word in each object in \fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns a completion code and result just like \fBTcl_EvalObj\fR. -The \fIcommand\fR argument is used only to provide contextual information -to command traces. Note: unlike the other procedures described here, -\fBTcl_EvalObjv\fR does not add any information to the \fBerrorInfo\fR -variable after an error. It is up to the caller to do this, if it -wishes. .PP \fBTcl_Eval\fR is similar to \fBTcl_EvalObj\fR except that the script to be executed is supplied as a string instead of an diff --git a/generic/tcl.h b/generic/tcl.h index 783246e..17f66a6 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.1.2.5 1998/11/11 04:08:15 stanton Exp $ + * RCS: @(#) $Id: tcl.h,v 1.1.2.6 1998/12/02 01:46:06 stanton Exp $ */ #ifndef _TCL @@ -1430,8 +1430,7 @@ EXTERN int Tcl_Eval2 _ANSI_ARGS_((Tcl_Interp *interp, EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp, char *fileName)); EXTERN int Tcl_EvalObjv _ANSI_ARGS_ ((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], char *string, - int length, int flags)); + int objc, Tcl_Obj *CONST objv[], int flags)); EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)); EXTERN void Tcl_EventuallyFree _ANSI_ARGS_((ClientData clientData, diff --git a/generic/tclParse.c b/generic/tclParse.c index f7eff3a..7e8f9f4 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParse.c,v 1.1.2.4 1998/11/11 04:54:18 stanton Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.1.2.5 1998/12/02 01:46:07 stanton Exp $ */ #include "tclInt.h" @@ -178,6 +178,9 @@ static int CommandComplete _ANSI_ARGS_((char *script, int length)); static int ParseTokens _ANSI_ARGS_((char *src, int mask, Tcl_Parse *parsePtr)); +static int EvalObjv _ANSI_ARGS_((Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[], char *command, int length, + int flags)); /* *---------------------------------------------------------------------- @@ -734,7 +737,7 @@ TclExpandTokenArray(parsePtr) /* *---------------------------------------------------------------------- * - * Tcl_EvalObjv -- + * EvalObjv -- * * This procedure evaluates a Tcl command that has already been * parsed into words, with one Tcl_Obj holding each word. @@ -751,8 +754,8 @@ TclExpandTokenArray(parsePtr) *---------------------------------------------------------------------- */ -int -Tcl_EvalObjv(interp, objc, objv, command, length, flags) +static int +EvalObjv(interp, objc, objv, command, length, flags) Tcl_Interp *interp; /* Interpreter in which to evaluate the * command. Also used for error * reporting. */ @@ -848,7 +851,7 @@ Tcl_EvalObjv(interp, objc, objv, command, length, flags) (char *) NULL); code = TCL_ERROR; } else { - code = Tcl_EvalObjv(interp, objc+1, newObjv, command, length, 0); + code = EvalObjv(interp, objc+1, newObjv, command, length, 0); } Tcl_DecrRefCount(newObjv[0]); ckfree((char *) newObjv); @@ -859,6 +862,9 @@ Tcl_EvalObjv(interp, objc, objv, command, length, flags) * Call trace procedures if needed. */ + argv = NULL; + commandCopy = command; + for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) { nextPtr = tracePtr->nextPtr; if (iPtr->numLevels > tracePtr->level) { @@ -867,25 +873,32 @@ Tcl_EvalObjv(interp, objc, objv, command, length, flags) /* * This is a bit messy because we have to emulate the old trace - * interface, which uses strings for everything. This can lose - * information if some of the words contain null characters. + * interface, which uses strings for everything. */ - argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *)); - for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); - } - argv[objc] = 0; - if (length < 0) { - length = strlen(command); + if (argv == NULL) { + argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *)); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); + } + argv[objc] = 0; + + if (length < 0) { + length = strlen(command); + } else if (length < strlen(command)) { + commandCopy = (char *) ckalloc((unsigned) (length + 1)); + strncpy(commandCopy, command, (size_t) length); + commandCopy[length] = 0; + } } - commandCopy = (char *) ckalloc((unsigned) (length + 1)); - strncpy(commandCopy, command, (size_t) length); - commandCopy[length] = 0; (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, commandCopy, cmdPtr->proc, cmdPtr->clientData, objc, argv); + } + if (argv != NULL) { ckfree((char *) argv); + } + if (commandCopy != command) { ckfree((char *) commandCopy); } @@ -923,6 +936,89 @@ Tcl_EvalObjv(interp, objc, objv, command, length, flags) /* *---------------------------------------------------------------------- * + * Tcl_EvalObjv -- + * + * This procedure evaluates a Tcl command that has already been + * parsed into words, with one Tcl_Obj holding each word. + * + * Results: + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR. A result or error message is left in + * interp's result. + * + * Side effects: + * Depends on the command. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalObjv(interp, objc, objv, flags) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * command. Also used for error + * reporting. */ + int objc; /* Number of words in command. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are + * the words that make up the command. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently + * supported. */ +{ + Interp *iPtr = (Interp *)interp; + Trace *tracePtr; + Tcl_DString cmdBuf; + char cmdString[] = ""; + int cmdLen = 0; + int code = TCL_OK; + + for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { + /* + * EvalObjv will increment numLevels so use "<" rather than "<=" + */ + if (iPtr->numLevels < tracePtr->level) { + int i; + /* + * The command will be needed for an execution trace or stack trace + * generate a command string. + */ + cmdtraced: + Tcl_DStringInit(&cmdBuf); + for (i = 0; i < objc; i++) { + Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); + } + cmdString = Tcl_DStringValue(&cmdBuf); + cmdLen = Tcl_DStringLength(&cmdBuf); + break; + } + } + + /* + * Execute the command if we have not done so already + */ + switch (code) { + case TCL_OK: + code = EvalObjv(interp, objc, objv, cmdString, cmdLen, flags); + if (code == TCL_ERROR && cmdLen == 0) + goto cmdtraced; + break; + case TCL_ERROR: + Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); + break; + default: + /*NOTREACHED*/ + break; + } + + if (cmdLen != 0) { + Tcl_DStringFree(&cmdBuf); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_LogCommandInfo -- * * This procedure is invoked after an error occurs in an interpreter. @@ -1174,7 +1270,7 @@ Tcl_EvalTokens(interp, tokenPtr, count) * * This procedure evaluates a Tcl script without using the compiler * or byte-code interpreter. It just parses the script, creates - * values for each word of each command, then calls Tcl_EvalObjv + * values for each word of each command, then calls EvalObjv * to execute each command. * * Results: @@ -1276,7 +1372,7 @@ Tcl_Eval2(interp, script, numBytes, flags) * Execute the command and free the objects for its words. */ - code = Tcl_EvalObjv(interp, objectsUsed, objv, p, bytesLeft, 0); + code = EvalObjv(interp, objectsUsed, objv, p, bytesLeft, 0); if (code != TCL_OK) { goto error; } diff --git a/generic/tclTest.c b/generic/tclTest.c index 709883a..3d5324d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.1.2.6 1998/11/11 04:54:19 stanton Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.1.2.7 1998/12/02 01:46:07 stanton Exp $ */ #define TCL_TEST @@ -1560,19 +1560,14 @@ TestevalobjvObjCmd(dummy, interp, objc, objv) int length, evalGlobal; char *command; - if (objc < 5) { - Tcl_WrongNumArgs(interp, 1, objv, - "command length global word ?word ...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?"); return TCL_ERROR; } - command = Tcl_GetString(objv[1]); - if (Tcl_GetIntFromObj(interp, objv[2], &length) != TCL_OK) { - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[3], &evalGlobal) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) { return TCL_ERROR; } - return Tcl_EvalObjv(interp, objc-4, objv+4, command, length, + return Tcl_EvalObjv(interp, objc-2, objv+2, command, length, (evalGlobal) ? TCL_EVAL_GLOBAL : 0); } diff --git a/tests/parse.test b/tests/parse.test index 3f8ae88..34f7250 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: parse.test,v 1.1.2.3 1998/11/11 04:08:33 stanton Exp $ +# RCS: @(#) $Id: parse.test,v 1.1.2.4 1998/12/02 01:46:08 stanton Exp $ if {[info commands testparser] == {}} { puts "This application hasn't been compiled with the \"testparser\"" @@ -203,11 +203,11 @@ test parse-7.1 {Tcl_FreeParse and ExpandTokenArray procedures} { } {- {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 16 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 {}} test parse-8.1 {Tcl_EvalObjv procedure} { - testevalobjv "test command" 20 0 concat this is a test + testevalobjv 0 concat this is a test } {this is a test} test parse-8.2 {Tcl_EvalObjv procedure, unknown commands} { rename unknown unknown.old - set x [catch {testevalobjv "test command" 0 10 asdf poiu} msg] + set x [catch {testevalobjv 10 asdf poiu} msg] rename unknown.old unknown list $x $msg } {1 {invalid command name "asdf"}} @@ -216,7 +216,7 @@ test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} { proc unknown args { return "unknown $args" } - set x [catch {testevalobjv "test command" 10 0 asdf poiu} msg] + set x [catch {testevalobjv 0 asdf poiu} msg] rename unknown {} rename unknown.old unknown list $x $msg @@ -226,21 +226,19 @@ test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} { proc unknown args { error "I don't like that command" } - set x [catch {testevalobjv "test command" 10 0 asdf poiu} msg] + set x [catch {testevalobjv 0 asdf poiu} msg] rename unknown {} rename unknown.old unknown list $x $msg } {1 {I don't like that command}} test parse-8.5 {Tcl_EvalObjv procedure, command traces} { - testcmdtrace tracetest {testevalobjv "test command" 10 0 set x 123} -} {{testevalobjv "test command" 10 0 set x 123} {testevalobjv {test command} 10 0 set x 123} {test comma} {set x 123}} -test parse-8.6 {Tcl_EvalObjv procedure, command traces} { - testcmdtrace tracetest {testevalobjv "" 0 0 set x 123} -} {{testevalobjv "" 0 0 set x 123} {testevalobjv {} 0 0 set x 123} {} {set x 123}} + testevalobjv 0 set x 123 + testcmdtrace tracetest {testevalobjv 0 set x $x} +} {{testevalobjv 0 set x $x} {testevalobjv 0 set x 123} {set x 123} {set x 123}} test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} { proc x {} { set y 23 - set z [testevalobjv "test command" 10 1 set y] + set z [testevalobjv 1 set y] return [list $z $y] } catch {unset y} @@ -257,12 +255,12 @@ test parse-8.8 {Tcl_EvalObjv procedure, async handlers} { set handler1 [testasync create async1] set aresult xxx set acode yyy - set x [list [catch [list testevalobjv "test command" 10 0 testasync mark $handler1 original 0] msg] $msg $acode $aresult] + set x [list [catch [list testevalobjv 0 testasync mark $handler1 original 0] msg] $msg $acode $aresult] testasync delete set x } {0 {new result} 0 original} test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} { - list [catch {testevalobjv "test command" 10 0 error message} msg] $msg + list [catch {testevalobjv 0 error message} msg] $msg } {1 message} test parse-9.1 {Tcl_LogCommandInfo, line numbers} { -- cgit v0.12