Merge commit 'c8bc058c566bbcbcd23e732197d64fecc739008f' as 'tcl8.6'

1 files changed, 230 insertions, 0 deletions

diff --git a/tcl8.6/generic/tclHistory.c b/tcl8.6/generic/tclHistory.c
new file mode 100644
index 0000000..b08e352
--- /dev/null
+++ b/tcl8.6/generic/tclHistory.c
@@ -0,0 +1,230 @@
+/*
+ * tclHistory.c --
+ *
+ *	This module and the Tcl library file history.tcl together implement
+ *	Tcl command history. Tcl_RecordAndEval(Obj) can be called to record
+ *	commands ("events") before they are executed. Commands defined in
+ *	history.tcl may be used to perform history substitutions.
+ *
+ * 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.
+ */
+
+#include "tclInt.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;
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RecordAndEval --
+ *
+ *	This procedure adds its command argument to the current list of
+ *	recorded events and then executes the command by calling Tcl_Eval.
+ *
+ * Results:
+ *	The return value is a standard Tcl return value, the result of
+ *	executing cmd.
+ *
+ * Side effects:
+ *	The command is recorded and executed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+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. */
+{
+    register Tcl_Obj *cmdPtr;
+    int length = strlen(cmd);
+    int result;
+
+    if (length > 0) {
+	/*
+	 * Call Tcl_RecordAndEvalObj to do the actual work.
+	 */
+
+	cmdPtr = Tcl_NewStringObj(cmd, length);
+	Tcl_IncrRefCount(cmdPtr);
+	result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags);
+
+	/*
+	 * Move the interpreter's object result to the string result, then
+	 * reset the object result.
+	 */
+
+	(void) Tcl_GetStringResult(interp);
+
+	/*
+	 * Discard the Tcl object created to hold the command.
+	 */
+
+	Tcl_DecrRefCount(cmdPtr);
+    } else {
+	/*
+	 * An empty string. Just reset the interpreter's result.
+	 */
+
+	Tcl_ResetResult(interp);
+	result = TCL_OK;
+    }
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RecordAndEvalObj --
+ *
+ *	This procedure adds the command held in its argument object to the
+ *	current list of recorded events and then executes the command by
+ *	calling Tcl_EvalObj.
+ *
+ * Results:
+ *	The return value is a standard Tcl return value, the result of
+ *	executing the command.
+ *
+ * Side effects:
+ *	The command is recorded and executed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+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 result, call = 1;
+    Tcl_CmdInfo info;
+    HistoryObjs *histObjsPtr =
+	    Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
+
+    /*
+     * Create the references to the [::history add] command if necessary.
+     */
+
+    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.
+     */
+
+    result = TCL_OK;
+    if (!(flags & TCL_NO_EVAL)) {
+	result = Tcl_EvalObjEx(interp, cmdPtr, flags & TCL_EVAL_GLOBAL);
+    }
+    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:
+ */