diff options
Diffstat (limited to 'generic/tclHistory.c')
| -rw-r--r-- | generic/tclHistory.c | 167 |
1 files changed, 126 insertions, 41 deletions
diff --git a/generic/tclHistory.c b/generic/tclHistory.c index 20ccb7c..b10d423 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -1,4 +1,4 @@ -/* +/* * tclHistory.c -- * * This module and the Tcl library file history.tcl together implement @@ -9,15 +9,29 @@ * Copyright (c) 1990-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclHistory.c,v 1.4 2002/01/16 06:02:34 dgp Exp $ + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tclPort.h" +/* + * Type of the assocData structure used to hold the reference to the [history + * add] subcommand, used in Tcl_RecordAndEvalObj. + */ + +typedef struct { + Tcl_Obj *historyObj; /* == "::history" */ + Tcl_Obj *addObj; /* == "add" */ +} HistoryObjs; + +#define HISTORY_OBJS_KEY "::tcl::HistoryObjs" + +/* + * Static functions in this file. + */ + +static Tcl_InterpDeleteProc DeleteHistoryObjs; /* *---------------------------------------------------------------------- @@ -25,8 +39,7 @@ * Tcl_RecordAndEval -- * * This procedure adds its command argument to the current list of - * recorded events and then executes the command by calling - * Tcl_Eval. + * recorded events and then executes the command by calling Tcl_Eval. * * Results: * The return value is a standard Tcl return value, the result of @@ -39,12 +52,12 @@ */ int -Tcl_RecordAndEval(interp, cmd, flags) - Tcl_Interp *interp; /* Token for interpreter in which command - * will be executed. */ - CONST char *cmd; /* Command to record. */ - int flags; /* Additional flags. TCL_NO_EVAL means - * only record: don't execute command. +Tcl_RecordAndEval( + Tcl_Interp *interp, /* Token for interpreter in which command will + * be executed. */ + const char *cmd, /* Command to record. */ + int flags) /* Additional flags. TCL_NO_EVAL means only + * record: don't execute command. * TCL_EVAL_GLOBAL means use Tcl_GlobalEval * instead of Tcl_Eval. */ { @@ -62,18 +75,17 @@ Tcl_RecordAndEval(interp, cmd, flags) result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); /* - * Move the interpreter's object result to the string result, - * then reset the object result. + * Move the interpreter's object result to the string result, then + * reset the object result. */ - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); + (void) Tcl_GetStringResult(interp); /* * Discard the Tcl object created to hold the command. */ - - Tcl_DecrRefCount(cmdPtr); + + Tcl_DecrRefCount(cmdPtr); } else { /* * An empty string. Just reset the interpreter's result. @@ -105,33 +117,69 @@ Tcl_RecordAndEval(interp, cmd, flags) */ int -Tcl_RecordAndEvalObj(interp, cmdPtr, flags) - Tcl_Interp *interp; /* Token for interpreter in which command - * will be executed. */ - Tcl_Obj *cmdPtr; /* Points to object holding the command to +Tcl_RecordAndEvalObj( + Tcl_Interp *interp, /* Token for interpreter in which command will + * be executed. */ + Tcl_Obj *cmdPtr, /* Points to object holding the command to * record and execute. */ - int flags; /* Additional flags. TCL_NO_EVAL means - * record only: don't execute the command. - * TCL_EVAL_GLOBAL means evaluate the - * script in global variable context instead - * of the current procedure. */ + int flags) /* Additional flags. TCL_NO_EVAL means record + * only: don't execute the command. + * TCL_EVAL_GLOBAL means evaluate the script + * in global variable context instead of the + * current procedure. */ { - int result; - Tcl_Obj *list[3]; - register Tcl_Obj *objPtr; + int result, call = 1; + Tcl_CmdInfo info; + HistoryObjs *histObjsPtr = + Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL); /* - * Do recording by eval'ing a tcl history command: history add $cmd. + * Create the references to the [::history add] command if necessary. */ - list[0] = Tcl_NewStringObj("history", -1); - list[1] = Tcl_NewStringObj("add", -1); - list[2] = cmdPtr; - - objPtr = Tcl_NewListObj(3, list); - Tcl_IncrRefCount(objPtr); - (void) Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(objPtr); + if (histObjsPtr == NULL) { + histObjsPtr = ckalloc(sizeof(HistoryObjs)); + TclNewLiteralStringObj(histObjsPtr->historyObj, "::history"); + TclNewLiteralStringObj(histObjsPtr->addObj, "add"); + Tcl_IncrRefCount(histObjsPtr->historyObj); + Tcl_IncrRefCount(histObjsPtr->addObj); + Tcl_SetAssocData(interp, HISTORY_OBJS_KEY, DeleteHistoryObjs, + histObjsPtr); + } + + /* + * Do not call [history] if it has been replaced by an empty proc + */ + + result = Tcl_GetCommandInfo(interp, "::history", &info); + if (result && (info.deleteProc == TclProcDeleteProc)) { + Proc *procPtr = (Proc *) info.objClientData; + call = (procPtr->cmdPtr->compileProc != TclCompileNoOp); + } + + if (call) { + Tcl_Obj *list[3]; + + /* + * Do recording by eval'ing a tcl history command: history add $cmd. + */ + + list[0] = histObjsPtr->historyObj; + list[1] = histObjsPtr->addObj; + list[2] = cmdPtr; + + Tcl_IncrRefCount(cmdPtr); + (void) Tcl_EvalObjv(interp, 3, list, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(cmdPtr); + + /* + * One possible failure mode above: exceeding a resource limit. + */ + + if (Tcl_LimitExceeded(interp)) { + return TCL_ERROR; + } + } /* * Execute the command. @@ -143,3 +191,40 @@ Tcl_RecordAndEvalObj(interp, cmdPtr, flags) } return result; } + +/* + *---------------------------------------------------------------------- + * + * DeleteHistoryObjs -- + * + * Called to delete the references to the constant words used when adding + * to the history. + * + * Results: + * None. + * + * Side effects: + * The constant words may be deleted. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteHistoryObjs( + ClientData clientData, + Tcl_Interp *interp) +{ + register HistoryObjs *histObjsPtr = clientData; + + TclDecrRefCount(histObjsPtr->historyObj); + TclDecrRefCount(histObjsPtr->addObj); + ckfree(histObjsPtr); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |