/*
|
/*
|
* tclBasic.c --
|
* tclBasic.c --
|
*
|
*
|
* Contains the basic facilities for TCL command interpretation,
|
* Contains the basic facilities for TCL command interpretation,
|
* including interpreter creation and deletion, command creation
|
* including interpreter creation and deletion, command creation
|
* and deletion, and command parsing and execution.
|
* and deletion, and command parsing and execution.
|
*
|
*
|
* Copyright (c) 1987-1994 The Regents of the University of California.
|
* Copyright (c) 1987-1994 The Regents of the University of California.
|
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
* Copyright (c) 1998 by Scriptics Corporation.
|
* Copyright (c) 1998 by Scriptics Corporation.
|
*
|
*
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*
|
*
|
* RCS: @(#) $Id: tclBasic.c,v 1.1.1.1 2002-01-16 10:25:25 markom Exp $
|
* RCS: @(#) $Id: tclBasic.c,v 1.1.1.1 2002-01-16 10:25:25 markom Exp $
|
*/
|
*/
|
|
|
#include "tclInt.h"
|
#include "tclInt.h"
|
#include "tclCompile.h"
|
#include "tclCompile.h"
|
#ifndef TCL_GENERIC_ONLY
|
#ifndef TCL_GENERIC_ONLY
|
# include "tclPort.h"
|
# include "tclPort.h"
|
#endif
|
#endif
|
|
|
/*
|
/*
|
* Static procedures in this file:
|
* Static procedures in this file:
|
*/
|
*/
|
|
|
static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
|
static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
|
static void HiddenCmdsDeleteProc _ANSI_ARGS_((
|
static void HiddenCmdsDeleteProc _ANSI_ARGS_((
|
ClientData clientData, Tcl_Interp *interp));
|
ClientData clientData, Tcl_Interp *interp));
|
|
|
/*
|
/*
|
* The following structure defines the commands in the Tcl core.
|
* The following structure defines the commands in the Tcl core.
|
*/
|
*/
|
|
|
typedef struct {
|
typedef struct {
|
char *name; /* Name of object-based command. */
|
char *name; /* Name of object-based command. */
|
Tcl_CmdProc *proc; /* String-based procedure for command. */
|
Tcl_CmdProc *proc; /* String-based procedure for command. */
|
Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */
|
Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */
|
CompileProc *compileProc; /* Procedure called to compile command. */
|
CompileProc *compileProc; /* Procedure called to compile command. */
|
int isSafe; /* If non-zero, command will be present
|
int isSafe; /* If non-zero, command will be present
|
* in safe interpreter. Otherwise it will
|
* in safe interpreter. Otherwise it will
|
* be hidden. */
|
* be hidden. */
|
} CmdInfo;
|
} CmdInfo;
|
|
|
/*
|
/*
|
* The built-in commands, and the procedures that implement them:
|
* The built-in commands, and the procedures that implement them:
|
*/
|
*/
|
|
|
static CmdInfo builtInCmds[] = {
|
static CmdInfo builtInCmds[] = {
|
/*
|
/*
|
* Commands in the generic core. Note that at least one of the proc or
|
* Commands in the generic core. Note that at least one of the proc or
|
* objProc members should be non-NULL. This avoids infinitely recursive
|
* objProc members should be non-NULL. This avoids infinitely recursive
|
* calls between TclInvokeObjectCommand and TclInvokeStringCommand if a
|
* calls between TclInvokeObjectCommand and TclInvokeStringCommand if a
|
* command name is computed at runtime and results in the name of a
|
* command name is computed at runtime and results in the name of a
|
* compiled command.
|
* compiled command.
|
*/
|
*/
|
|
|
{"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd,
|
{"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd,
|
{"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd,
|
{"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"break", Tcl_BreakCmd, (Tcl_ObjCmdProc *) NULL,
|
{"break", Tcl_BreakCmd, (Tcl_ObjCmdProc *) NULL,
|
TclCompileBreakCmd, 1},
|
TclCompileBreakCmd, 1},
|
{"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd,
|
{"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd,
|
{"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd,
|
TclCompileCatchCmd, 1},
|
TclCompileCatchCmd, 1},
|
{"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd,
|
{"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd,
|
{"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"continue", Tcl_ContinueCmd, (Tcl_ObjCmdProc *) NULL,
|
{"continue", Tcl_ContinueCmd, (Tcl_ObjCmdProc *) NULL,
|
TclCompileContinueCmd, 1},
|
TclCompileContinueCmd, 1},
|
{"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd,
|
{"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd,
|
{"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd,
|
{"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd,
|
{"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd,
|
TclCompileExprCmd, 1},
|
TclCompileExprCmd, 1},
|
{"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd,
|
{"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"fileevent", Tcl_FileEventCmd, (Tcl_ObjCmdProc *) NULL,
|
{"fileevent", Tcl_FileEventCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"for", Tcl_ForCmd, (Tcl_ObjCmdProc *) NULL,
|
{"for", Tcl_ForCmd, (Tcl_ObjCmdProc *) NULL,
|
TclCompileForCmd, 1},
|
TclCompileForCmd, 1},
|
{"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd,
|
{"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd,
|
TclCompileForeachCmd, 1},
|
TclCompileForeachCmd, 1},
|
{"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd,
|
{"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd,
|
{"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL,
|
{"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL,
|
TclCompileIfCmd, 1},
|
TclCompileIfCmd, 1},
|
{"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL,
|
{"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL,
|
TclCompileIncrCmd, 1},
|
TclCompileIncrCmd, 1},
|
{"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd,
|
{"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"interp", (Tcl_CmdProc *) NULL, Tcl_InterpObjCmd,
|
{"interp", (Tcl_CmdProc *) NULL, Tcl_InterpObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd,
|
{"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd,
|
{"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd,
|
{"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd,
|
{"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd,
|
{"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd,
|
{"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"load", Tcl_LoadCmd, (Tcl_ObjCmdProc *) NULL,
|
{"load", Tcl_LoadCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd,
|
{"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd,
|
{"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd,
|
{"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd,
|
{"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd,
|
{"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"package", Tcl_PackageCmd, (Tcl_ObjCmdProc *) NULL,
|
{"package", Tcl_PackageCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd,
|
{"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"regexp", Tcl_RegexpCmd, (Tcl_ObjCmdProc *) NULL,
|
{"regexp", Tcl_RegexpCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"regsub", Tcl_RegsubCmd, (Tcl_ObjCmdProc *) NULL,
|
{"regsub", Tcl_RegsubCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd,
|
{"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd,
|
{"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"scan", Tcl_ScanCmd, (Tcl_ObjCmdProc *) NULL,
|
{"scan", Tcl_ScanCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL,
|
{"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL,
|
TclCompileSetCmd, 1},
|
TclCompileSetCmd, 1},
|
{"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd,
|
{"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd,
|
{"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"subst", Tcl_SubstCmd, (Tcl_ObjCmdProc *) NULL,
|
{"subst", Tcl_SubstCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd,
|
{"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"trace", Tcl_TraceCmd, (Tcl_ObjCmdProc *) NULL,
|
{"trace", Tcl_TraceCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd,
|
{"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd,
|
{"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd,
|
{"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd,
|
{"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"while", Tcl_WhileCmd, (Tcl_ObjCmdProc *) NULL,
|
{"while", Tcl_WhileCmd, (Tcl_ObjCmdProc *) NULL,
|
TclCompileWhileCmd, 1},
|
TclCompileWhileCmd, 1},
|
|
|
/*
|
/*
|
* Commands in the UNIX core:
|
* Commands in the UNIX core:
|
*/
|
*/
|
|
|
#ifndef TCL_GENERIC_ONLY
|
#ifndef TCL_GENERIC_ONLY
|
{"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd,
|
{"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd,
|
{"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd,
|
{"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd,
|
{"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd,
|
{"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL,
|
{"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd,
|
{"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd,
|
{"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd,
|
{"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"glob", Tcl_GlobCmd, (Tcl_ObjCmdProc *) NULL,
|
{"glob", Tcl_GlobCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"open", Tcl_OpenCmd, (Tcl_ObjCmdProc *) NULL,
|
{"open", Tcl_OpenCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd,
|
{"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd,
|
{"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"pwd", Tcl_PwdCmd, (Tcl_ObjCmdProc *) NULL,
|
{"pwd", Tcl_PwdCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd,
|
{"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"seek", Tcl_SeekCmd, (Tcl_ObjCmdProc *) NULL,
|
{"seek", Tcl_SeekCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"socket", Tcl_SocketCmd, (Tcl_ObjCmdProc *) NULL,
|
{"socket", Tcl_SocketCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"tell", Tcl_TellCmd, (Tcl_ObjCmdProc *) NULL,
|
{"tell", Tcl_TellCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd,
|
{"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL,
|
{"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL,
|
{"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
|
|
#ifdef MAC_TCL
|
#ifdef MAC_TCL
|
{"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd,
|
{"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL,
|
{"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"ls", Tcl_LsCmd, (Tcl_ObjCmdProc *) NULL,
|
{"ls", Tcl_LsCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd,
|
{"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd,
|
(CompileProc *) NULL, 1},
|
(CompileProc *) NULL, 1},
|
{"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd,
|
{"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
#else
|
#else
|
{"exec", Tcl_ExecCmd, (Tcl_ObjCmdProc *) NULL,
|
{"exec", Tcl_ExecCmd, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
{"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd,
|
{"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd,
|
(CompileProc *) NULL, 0},
|
(CompileProc *) NULL, 0},
|
#endif /* MAC_TCL */
|
#endif /* MAC_TCL */
|
|
|
#endif /* TCL_GENERIC_ONLY */
|
#endif /* TCL_GENERIC_ONLY */
|
{NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL,
|
{NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL,
|
(CompileProc *) NULL, 0}
|
(CompileProc *) NULL, 0}
|
};
|
};
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_CreateInterp --
|
* Tcl_CreateInterp --
|
*
|
*
|
* Create a new TCL command interpreter.
|
* Create a new TCL command interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a token for the interpreter, which may be
|
* The return value is a token for the interpreter, which may be
|
* used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
|
* used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
|
* Tcl_DeleteInterp.
|
* Tcl_DeleteInterp.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The command interpreter is initialized with an empty variable
|
* The command interpreter is initialized with an empty variable
|
* table and the built-in commands.
|
* table and the built-in commands.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_Interp *
|
Tcl_Interp *
|
Tcl_CreateInterp()
|
Tcl_CreateInterp()
|
{
|
{
|
register Interp *iPtr;
|
register Interp *iPtr;
|
register Command *cmdPtr;
|
register Command *cmdPtr;
|
register CmdInfo *cmdInfoPtr;
|
register CmdInfo *cmdInfoPtr;
|
union {
|
union {
|
char c[sizeof(short)];
|
char c[sizeof(short)];
|
short s;
|
short s;
|
} order;
|
} order;
|
int i;
|
int i;
|
|
|
/*
|
/*
|
* Panic if someone updated the CallFrame structure without
|
* Panic if someone updated the CallFrame structure without
|
* also updating the Tcl_CallFrame structure (or vice versa).
|
* also updating the Tcl_CallFrame structure (or vice versa).
|
*/
|
*/
|
|
|
if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
|
if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
|
/*NOTREACHED*/
|
/*NOTREACHED*/
|
panic("Tcl_CallFrame and CallFrame are not the same size");
|
panic("Tcl_CallFrame and CallFrame are not the same size");
|
}
|
}
|
|
|
/*
|
/*
|
* Initialize support for namespaces and create the global namespace
|
* Initialize support for namespaces and create the global namespace
|
* (whose name is ""; an alias is "::"). This also initializes the
|
* (whose name is ""; an alias is "::"). This also initializes the
|
* Tcl object type table and other object management code.
|
* Tcl object type table and other object management code.
|
*/
|
*/
|
|
|
TclInitNamespaces();
|
TclInitNamespaces();
|
|
|
iPtr = (Interp *) ckalloc(sizeof(Interp));
|
iPtr = (Interp *) ckalloc(sizeof(Interp));
|
iPtr->result = iPtr->resultSpace;
|
iPtr->result = iPtr->resultSpace;
|
iPtr->freeProc = 0;
|
iPtr->freeProc = 0;
|
iPtr->objResultPtr = Tcl_NewObj(); /* an empty object */
|
iPtr->objResultPtr = Tcl_NewObj(); /* an empty object */
|
Tcl_IncrRefCount(iPtr->objResultPtr);
|
Tcl_IncrRefCount(iPtr->objResultPtr);
|
iPtr->errorLine = 0;
|
iPtr->errorLine = 0;
|
Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
|
Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
|
iPtr->numLevels = 0;
|
iPtr->numLevels = 0;
|
iPtr->maxNestingDepth = 1000;
|
iPtr->maxNestingDepth = 1000;
|
iPtr->framePtr = NULL;
|
iPtr->framePtr = NULL;
|
iPtr->varFramePtr = NULL;
|
iPtr->varFramePtr = NULL;
|
iPtr->activeTracePtr = NULL;
|
iPtr->activeTracePtr = NULL;
|
iPtr->returnCode = TCL_OK;
|
iPtr->returnCode = TCL_OK;
|
iPtr->errorInfo = NULL;
|
iPtr->errorInfo = NULL;
|
iPtr->errorCode = NULL;
|
iPtr->errorCode = NULL;
|
iPtr->appendResult = NULL;
|
iPtr->appendResult = NULL;
|
iPtr->appendAvl = 0;
|
iPtr->appendAvl = 0;
|
iPtr->appendUsed = 0;
|
iPtr->appendUsed = 0;
|
for (i = 0; i < NUM_REGEXPS; i++) {
|
for (i = 0; i < NUM_REGEXPS; i++) {
|
iPtr->patterns[i] = NULL;
|
iPtr->patterns[i] = NULL;
|
iPtr->patLengths[i] = -1;
|
iPtr->patLengths[i] = -1;
|
iPtr->regexps[i] = NULL;
|
iPtr->regexps[i] = NULL;
|
}
|
}
|
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
|
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
|
iPtr->packageUnknown = NULL;
|
iPtr->packageUnknown = NULL;
|
iPtr->cmdCount = 0;
|
iPtr->cmdCount = 0;
|
iPtr->termOffset = 0;
|
iPtr->termOffset = 0;
|
iPtr->compileEpoch = 0;
|
iPtr->compileEpoch = 0;
|
iPtr->compiledProcPtr = NULL;
|
iPtr->compiledProcPtr = NULL;
|
iPtr->resolverPtr = NULL;
|
iPtr->resolverPtr = NULL;
|
iPtr->evalFlags = 0;
|
iPtr->evalFlags = 0;
|
iPtr->scriptFile = NULL;
|
iPtr->scriptFile = NULL;
|
iPtr->flags = 0;
|
iPtr->flags = 0;
|
iPtr->tracePtr = NULL;
|
iPtr->tracePtr = NULL;
|
iPtr->assocData = (Tcl_HashTable *) NULL;
|
iPtr->assocData = (Tcl_HashTable *) NULL;
|
iPtr->execEnvPtr = NULL; /* set after namespaces initialized */
|
iPtr->execEnvPtr = NULL; /* set after namespaces initialized */
|
iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
|
iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
|
Tcl_IncrRefCount(iPtr->emptyObjPtr);
|
Tcl_IncrRefCount(iPtr->emptyObjPtr);
|
iPtr->resultSpace[0] = 0;
|
iPtr->resultSpace[0] = 0;
|
|
|
iPtr->globalNsPtr = NULL; /* force creation of global ns below */
|
iPtr->globalNsPtr = NULL; /* force creation of global ns below */
|
iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(
|
iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(
|
(Tcl_Interp *) iPtr, "", (ClientData) NULL,
|
(Tcl_Interp *) iPtr, "", (ClientData) NULL,
|
(Tcl_NamespaceDeleteProc *) NULL);
|
(Tcl_NamespaceDeleteProc *) NULL);
|
if (iPtr->globalNsPtr == NULL) {
|
if (iPtr->globalNsPtr == NULL) {
|
panic("Tcl_CreateInterp: can't create global namespace");
|
panic("Tcl_CreateInterp: can't create global namespace");
|
}
|
}
|
|
|
/*
|
/*
|
* Initialize support for code compilation. Do this after initializing
|
* Initialize support for code compilation. Do this after initializing
|
* namespaces since TclCreateExecEnv will try to reference a Tcl
|
* namespaces since TclCreateExecEnv will try to reference a Tcl
|
* variable (it links to the Tcl "tcl_traceExec" variable).
|
* variable (it links to the Tcl "tcl_traceExec" variable).
|
*/
|
*/
|
|
|
iPtr->execEnvPtr = TclCreateExecEnv((Tcl_Interp *) iPtr);
|
iPtr->execEnvPtr = TclCreateExecEnv((Tcl_Interp *) iPtr);
|
|
|
/*
|
/*
|
* Create the core commands. Do it here, rather than calling
|
* Create the core commands. Do it here, rather than calling
|
* Tcl_CreateCommand, because it's faster (there's no need to check for
|
* Tcl_CreateCommand, because it's faster (there's no need to check for
|
* a pre-existing command by the same name). If a command has a
|
* a pre-existing command by the same name). If a command has a
|
* Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
|
* Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
|
* TclInvokeStringCommand. This is an object-based wrapper procedure
|
* TclInvokeStringCommand. This is an object-based wrapper procedure
|
* that extracts strings, calls the string procedure, and creates an
|
* that extracts strings, calls the string procedure, and creates an
|
* object for the result. Similarly, if a command has a Tcl_ObjCmdProc
|
* object for the result. Similarly, if a command has a Tcl_ObjCmdProc
|
* but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
|
* but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
|
*/
|
*/
|
|
|
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL;
|
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL;
|
cmdInfoPtr++) {
|
cmdInfoPtr++) {
|
int new;
|
int new;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
|
|
if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL)
|
if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL)
|
&& (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)
|
&& (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)
|
&& (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
|
&& (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
|
panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n");
|
panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n");
|
}
|
}
|
|
|
hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
|
hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
|
cmdInfoPtr->name, &new);
|
cmdInfoPtr->name, &new);
|
if (new) {
|
if (new) {
|
cmdPtr = (Command *) ckalloc(sizeof(Command));
|
cmdPtr = (Command *) ckalloc(sizeof(Command));
|
cmdPtr->hPtr = hPtr;
|
cmdPtr->hPtr = hPtr;
|
cmdPtr->nsPtr = iPtr->globalNsPtr;
|
cmdPtr->nsPtr = iPtr->globalNsPtr;
|
cmdPtr->refCount = 1;
|
cmdPtr->refCount = 1;
|
cmdPtr->cmdEpoch = 0;
|
cmdPtr->cmdEpoch = 0;
|
cmdPtr->compileProc = cmdInfoPtr->compileProc;
|
cmdPtr->compileProc = cmdInfoPtr->compileProc;
|
if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) {
|
if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) {
|
cmdPtr->proc = TclInvokeObjectCommand;
|
cmdPtr->proc = TclInvokeObjectCommand;
|
cmdPtr->clientData = (ClientData) cmdPtr;
|
cmdPtr->clientData = (ClientData) cmdPtr;
|
} else {
|
} else {
|
cmdPtr->proc = cmdInfoPtr->proc;
|
cmdPtr->proc = cmdInfoPtr->proc;
|
cmdPtr->clientData = (ClientData) NULL;
|
cmdPtr->clientData = (ClientData) NULL;
|
}
|
}
|
if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
|
if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
|
cmdPtr->objProc = TclInvokeStringCommand;
|
cmdPtr->objProc = TclInvokeStringCommand;
|
cmdPtr->objClientData = (ClientData) cmdPtr;
|
cmdPtr->objClientData = (ClientData) cmdPtr;
|
} else {
|
} else {
|
cmdPtr->objProc = cmdInfoPtr->objProc;
|
cmdPtr->objProc = cmdInfoPtr->objProc;
|
cmdPtr->objClientData = (ClientData) NULL;
|
cmdPtr->objClientData = (ClientData) NULL;
|
}
|
}
|
cmdPtr->deleteProc = NULL;
|
cmdPtr->deleteProc = NULL;
|
cmdPtr->deleteData = (ClientData) NULL;
|
cmdPtr->deleteData = (ClientData) NULL;
|
cmdPtr->deleted = 0;
|
cmdPtr->deleted = 0;
|
cmdPtr->importRefPtr = NULL;
|
cmdPtr->importRefPtr = NULL;
|
Tcl_SetHashValue(hPtr, cmdPtr);
|
Tcl_SetHashValue(hPtr, cmdPtr);
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Initialize/Create "errorInfo" and "errorCode" global vars
|
* Initialize/Create "errorInfo" and "errorCode" global vars
|
* (because some part of the C code assume they exists
|
* (because some part of the C code assume they exists
|
* and we can get a seg fault otherwise (in multiple
|
* and we can get a seg fault otherwise (in multiple
|
* interps loading of extensions for instance) --dl)
|
* interps loading of extensions for instance) --dl)
|
*/
|
*/
|
/*
|
/*
|
* We can't assume that because we initialize
|
* We can't assume that because we initialize
|
* the variables here, they won't be unset later.
|
* the variables here, they won't be unset later.
|
* so we had 2 choices:
|
* so we had 2 choices:
|
* + Check every place where a GetVar of those is used
|
* + Check every place where a GetVar of those is used
|
* and the NULL result is not checked (like in tclLoad.c)
|
* and the NULL result is not checked (like in tclLoad.c)
|
* + Make SetVar,... NULL friendly
|
* + Make SetVar,... NULL friendly
|
* We choosed the second option because :
|
* We choosed the second option because :
|
* + It is easy and low cost to check for NULL pointer before
|
* + It is easy and low cost to check for NULL pointer before
|
* calling strlen()
|
* calling strlen()
|
* + It can be helpfull to other people using those API
|
* + It can be helpfull to other people using those API
|
* + Passing a NULL value to those closest 'meaning' is empty string
|
* + Passing a NULL value to those closest 'meaning' is empty string
|
* (specially with the new objects where 0 bytes strings are ok)
|
* (specially with the new objects where 0 bytes strings are ok)
|
* So the following init is commented out: -- dl
|
* So the following init is commented out: -- dl
|
*/
|
*/
|
/*
|
/*
|
(void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, "",
|
(void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, "",
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
(void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, "NONE",
|
(void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, "NONE",
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
*/
|
*/
|
|
|
#ifndef TCL_GENERIC_ONLY
|
#ifndef TCL_GENERIC_ONLY
|
TclSetupEnv((Tcl_Interp *) iPtr);
|
TclSetupEnv((Tcl_Interp *) iPtr);
|
#endif
|
#endif
|
|
|
/*
|
/*
|
* Do Multiple/Safe Interps Tcl init stuff
|
* Do Multiple/Safe Interps Tcl init stuff
|
*/
|
*/
|
(void) TclInterpInit((Tcl_Interp *)iPtr);
|
(void) TclInterpInit((Tcl_Interp *)iPtr);
|
|
|
/*
|
/*
|
* Set up variables such as tcl_version.
|
* Set up variables such as tcl_version.
|
*/
|
*/
|
|
|
TclPlatformInit((Tcl_Interp *)iPtr);
|
TclPlatformInit((Tcl_Interp *)iPtr);
|
Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL,
|
Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL,
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION,
|
Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION,
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL,
|
Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL,
|
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
|
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
|
TclPrecTraceProc, (ClientData) NULL);
|
TclPrecTraceProc, (ClientData) NULL);
|
|
|
/*
|
/*
|
* Compute the byte order of this machine.
|
* Compute the byte order of this machine.
|
*/
|
*/
|
|
|
order.s = 1;
|
order.s = 1;
|
Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder",
|
Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder",
|
(order.c[0] == 1) ? "littleEndian" : "bigEndian",
|
(order.c[0] == 1) ? "littleEndian" : "bigEndian",
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
|
|
/*
|
/*
|
* Register Tcl's version number.
|
* Register Tcl's version number.
|
*/
|
*/
|
|
|
Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION);
|
Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION);
|
|
|
return (Tcl_Interp *) iPtr;
|
return (Tcl_Interp *) iPtr;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclHideUnsafeCommands --
|
* TclHideUnsafeCommands --
|
*
|
*
|
* Hides base commands that are not marked as safe from this
|
* Hides base commands that are not marked as safe from this
|
* interpreter.
|
* interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* TCL_OK if it succeeds, TCL_ERROR else.
|
* TCL_OK if it succeeds, TCL_ERROR else.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Hides functionality in an interpreter.
|
* Hides functionality in an interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclHideUnsafeCommands(interp)
|
TclHideUnsafeCommands(interp)
|
Tcl_Interp *interp; /* Hide commands in this interpreter. */
|
Tcl_Interp *interp; /* Hide commands in this interpreter. */
|
{
|
{
|
register CmdInfo *cmdInfoPtr;
|
register CmdInfo *cmdInfoPtr;
|
|
|
if (interp == (Tcl_Interp *) NULL) {
|
if (interp == (Tcl_Interp *) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
|
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
|
if (!cmdInfoPtr->isSafe) {
|
if (!cmdInfoPtr->isSafe) {
|
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
|
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
|
}
|
}
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*
|
*
|
* Tcl_CallWhenDeleted --
|
* Tcl_CallWhenDeleted --
|
*
|
*
|
* Arrange for a procedure to be called before a given
|
* Arrange for a procedure to be called before a given
|
* interpreter is deleted. The procedure is called as soon
|
* interpreter is deleted. The procedure is called as soon
|
* as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
|
* as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
|
* called on an interpreter that has already been deleted,
|
* called on an interpreter that has already been deleted,
|
* the procedure will be called when the last Tcl_Release is
|
* the procedure will be called when the last Tcl_Release is
|
* done on the interpreter.
|
* done on the interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* When Tcl_DeleteInterp is invoked to delete interp,
|
* When Tcl_DeleteInterp is invoked to delete interp,
|
* proc will be invoked. See the manual entry for
|
* proc will be invoked. See the manual entry for
|
* details.
|
* details.
|
*
|
*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_CallWhenDeleted(interp, proc, clientData)
|
Tcl_CallWhenDeleted(interp, proc, clientData)
|
Tcl_Interp *interp; /* Interpreter to watch. */
|
Tcl_Interp *interp; /* Interpreter to watch. */
|
Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
|
Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
|
* is about to be deleted. */
|
* is about to be deleted. */
|
ClientData clientData; /* One-word value to pass to proc. */
|
ClientData clientData; /* One-word value to pass to proc. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
static int assocDataCounter = 0;
|
static int assocDataCounter = 0;
|
int new;
|
int new;
|
char buffer[128];
|
char buffer[128];
|
AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
|
AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
|
|
sprintf(buffer, "Assoc Data Key #%d", assocDataCounter);
|
sprintf(buffer, "Assoc Data Key #%d", assocDataCounter);
|
assocDataCounter++;
|
assocDataCounter++;
|
|
|
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
|
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
|
iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
|
iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
|
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
|
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
|
}
|
}
|
hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
|
hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
|
dPtr->proc = proc;
|
dPtr->proc = proc;
|
dPtr->clientData = clientData;
|
dPtr->clientData = clientData;
|
Tcl_SetHashValue(hPtr, dPtr);
|
Tcl_SetHashValue(hPtr, dPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*
|
*
|
* Tcl_DontCallWhenDeleted --
|
* Tcl_DontCallWhenDeleted --
|
*
|
*
|
* Cancel the arrangement for a procedure to be called when
|
* Cancel the arrangement for a procedure to be called when
|
* a given interpreter is deleted.
|
* a given interpreter is deleted.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If proc and clientData were previously registered as a
|
* If proc and clientData were previously registered as a
|
* callback via Tcl_CallWhenDeleted, they are unregistered.
|
* callback via Tcl_CallWhenDeleted, they are unregistered.
|
* If they weren't previously registered then nothing
|
* If they weren't previously registered then nothing
|
* happens.
|
* happens.
|
*
|
*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DontCallWhenDeleted(interp, proc, clientData)
|
Tcl_DontCallWhenDeleted(interp, proc, clientData)
|
Tcl_Interp *interp; /* Interpreter to watch. */
|
Tcl_Interp *interp; /* Interpreter to watch. */
|
Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
|
Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
|
* is about to be deleted. */
|
* is about to be deleted. */
|
ClientData clientData; /* One-word value to pass to proc. */
|
ClientData clientData; /* One-word value to pass to proc. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
Tcl_HashTable *hTablePtr;
|
Tcl_HashTable *hTablePtr;
|
Tcl_HashSearch hSearch;
|
Tcl_HashSearch hSearch;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
AssocData *dPtr;
|
AssocData *dPtr;
|
|
|
hTablePtr = iPtr->assocData;
|
hTablePtr = iPtr->assocData;
|
if (hTablePtr == (Tcl_HashTable *) NULL) {
|
if (hTablePtr == (Tcl_HashTable *) NULL) {
|
return;
|
return;
|
}
|
}
|
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
|
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
|
if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
|
ckfree((char *) dPtr);
|
ckfree((char *) dPtr);
|
Tcl_DeleteHashEntry(hPtr);
|
Tcl_DeleteHashEntry(hPtr);
|
return;
|
return;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SetAssocData --
|
* Tcl_SetAssocData --
|
*
|
*
|
* Creates a named association between user-specified data, a delete
|
* Creates a named association between user-specified data, a delete
|
* function and this interpreter. If the association already exists
|
* function and this interpreter. If the association already exists
|
* the data is overwritten with the new data. The delete function will
|
* the data is overwritten with the new data. The delete function will
|
* be invoked when the interpreter is deleted.
|
* be invoked when the interpreter is deleted.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Sets the associated data, creates the association if needed.
|
* Sets the associated data, creates the association if needed.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_SetAssocData(interp, name, proc, clientData)
|
Tcl_SetAssocData(interp, name, proc, clientData)
|
Tcl_Interp *interp; /* Interpreter to associate with. */
|
Tcl_Interp *interp; /* Interpreter to associate with. */
|
char *name; /* Name for association. */
|
char *name; /* Name for association. */
|
Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
|
Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
|
* about to be deleted. */
|
* about to be deleted. */
|
ClientData clientData; /* One-word value to pass to proc. */
|
ClientData clientData; /* One-word value to pass to proc. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
AssocData *dPtr;
|
AssocData *dPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
int new;
|
int new;
|
|
|
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
|
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
|
iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
|
iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
|
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
|
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
|
}
|
}
|
hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
|
hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
|
if (new == 0) {
|
if (new == 0) {
|
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
} else {
|
} else {
|
dPtr = (AssocData *) ckalloc(sizeof(AssocData));
|
dPtr = (AssocData *) ckalloc(sizeof(AssocData));
|
}
|
}
|
dPtr->proc = proc;
|
dPtr->proc = proc;
|
dPtr->clientData = clientData;
|
dPtr->clientData = clientData;
|
|
|
Tcl_SetHashValue(hPtr, dPtr);
|
Tcl_SetHashValue(hPtr, dPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DeleteAssocData --
|
* Tcl_DeleteAssocData --
|
*
|
*
|
* Deletes a named association of user-specified data with
|
* Deletes a named association of user-specified data with
|
* the specified interpreter.
|
* the specified interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Deletes the association.
|
* Deletes the association.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DeleteAssocData(interp, name)
|
Tcl_DeleteAssocData(interp, name)
|
Tcl_Interp *interp; /* Interpreter to associate with. */
|
Tcl_Interp *interp; /* Interpreter to associate with. */
|
char *name; /* Name of association. */
|
char *name; /* Name of association. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
AssocData *dPtr;
|
AssocData *dPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
|
|
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
|
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
|
return;
|
return;
|
}
|
}
|
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
|
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
return;
|
return;
|
}
|
}
|
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
if (dPtr->proc != NULL) {
|
if (dPtr->proc != NULL) {
|
(dPtr->proc) (dPtr->clientData, interp);
|
(dPtr->proc) (dPtr->clientData, interp);
|
}
|
}
|
ckfree((char *) dPtr);
|
ckfree((char *) dPtr);
|
Tcl_DeleteHashEntry(hPtr);
|
Tcl_DeleteHashEntry(hPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetAssocData --
|
* Tcl_GetAssocData --
|
*
|
*
|
* Returns the client data associated with this name in the
|
* Returns the client data associated with this name in the
|
* specified interpreter.
|
* specified interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* The client data in the AssocData record denoted by the named
|
* The client data in the AssocData record denoted by the named
|
* association, or NULL.
|
* association, or NULL.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
ClientData
|
ClientData
|
Tcl_GetAssocData(interp, name, procPtr)
|
Tcl_GetAssocData(interp, name, procPtr)
|
Tcl_Interp *interp; /* Interpreter associated with. */
|
Tcl_Interp *interp; /* Interpreter associated with. */
|
char *name; /* Name of association. */
|
char *name; /* Name of association. */
|
Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address
|
Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address
|
* of current deletion callback. */
|
* of current deletion callback. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
AssocData *dPtr;
|
AssocData *dPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
|
|
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
|
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
|
return (ClientData) NULL;
|
return (ClientData) NULL;
|
}
|
}
|
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
|
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
return (ClientData) NULL;
|
return (ClientData) NULL;
|
}
|
}
|
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
|
if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
|
*procPtr = dPtr->proc;
|
*procPtr = dPtr->proc;
|
}
|
}
|
return dPtr->clientData;
|
return dPtr->clientData;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* DeleteInterpProc --
|
* DeleteInterpProc --
|
*
|
*
|
* Helper procedure to delete an interpreter. This procedure is
|
* Helper procedure to delete an interpreter. This procedure is
|
* called when the last call to Tcl_Preserve on this interpreter
|
* called when the last call to Tcl_Preserve on this interpreter
|
* is matched by a call to Tcl_Release. The procedure cleans up
|
* is matched by a call to Tcl_Release. The procedure cleans up
|
* all resources used in the interpreter and calls all currently
|
* all resources used in the interpreter and calls all currently
|
* registered interpreter deletion callbacks.
|
* registered interpreter deletion callbacks.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Whatever the interpreter deletion callbacks do. Frees resources
|
* Whatever the interpreter deletion callbacks do. Frees resources
|
* used by the interpreter.
|
* used by the interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
DeleteInterpProc(interp)
|
DeleteInterpProc(interp)
|
Tcl_Interp *interp; /* Interpreter to delete. */
|
Tcl_Interp *interp; /* Interpreter to delete. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashSearch search;
|
Tcl_HashSearch search;
|
Tcl_HashTable *hTablePtr;
|
Tcl_HashTable *hTablePtr;
|
AssocData *dPtr;
|
AssocData *dPtr;
|
ResolverScheme *resPtr, *nextResPtr;
|
ResolverScheme *resPtr, *nextResPtr;
|
int i;
|
int i;
|
|
|
/*
|
/*
|
* Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
|
* Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
|
*/
|
*/
|
|
|
if (iPtr->numLevels > 0) {
|
if (iPtr->numLevels > 0) {
|
panic("DeleteInterpProc called with active evals");
|
panic("DeleteInterpProc called with active evals");
|
}
|
}
|
|
|
/*
|
/*
|
* The interpreter should already be marked deleted; otherwise how
|
* The interpreter should already be marked deleted; otherwise how
|
* did we get here?
|
* did we get here?
|
*/
|
*/
|
|
|
if (!(iPtr->flags & DELETED)) {
|
if (!(iPtr->flags & DELETED)) {
|
panic("DeleteInterpProc called on interpreter not marked deleted");
|
panic("DeleteInterpProc called on interpreter not marked deleted");
|
}
|
}
|
|
|
/*
|
/*
|
* Dismantle everything in the global namespace except for the
|
* Dismantle everything in the global namespace except for the
|
* "errorInfo" and "errorCode" variables. These remain until the
|
* "errorInfo" and "errorCode" variables. These remain until the
|
* namespace is actually destroyed, in case any errors occur.
|
* namespace is actually destroyed, in case any errors occur.
|
*
|
*
|
* Dismantle the namespace here, before we clear the assocData. If any
|
* Dismantle the namespace here, before we clear the assocData. If any
|
* background errors occur here, they will be deleted below.
|
* background errors occur here, they will be deleted below.
|
*/
|
*/
|
|
|
TclTeardownNamespace(iPtr->globalNsPtr);
|
TclTeardownNamespace(iPtr->globalNsPtr);
|
|
|
/*
|
/*
|
* Tear down the math function table.
|
* Tear down the math function table.
|
*/
|
*/
|
|
|
for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
|
for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
|
hPtr != NULL;
|
hPtr != NULL;
|
hPtr = Tcl_NextHashEntry(&search)) {
|
hPtr = Tcl_NextHashEntry(&search)) {
|
ckfree((char *) Tcl_GetHashValue(hPtr));
|
ckfree((char *) Tcl_GetHashValue(hPtr));
|
}
|
}
|
Tcl_DeleteHashTable(&iPtr->mathFuncTable);
|
Tcl_DeleteHashTable(&iPtr->mathFuncTable);
|
|
|
/*
|
/*
|
* Invoke deletion callbacks; note that a callback can create new
|
* Invoke deletion callbacks; note that a callback can create new
|
* callbacks, so we iterate.
|
* callbacks, so we iterate.
|
*/
|
*/
|
|
|
while (iPtr->assocData != (Tcl_HashTable *) NULL) {
|
while (iPtr->assocData != (Tcl_HashTable *) NULL) {
|
hTablePtr = iPtr->assocData;
|
hTablePtr = iPtr->assocData;
|
iPtr->assocData = (Tcl_HashTable *) NULL;
|
iPtr->assocData = (Tcl_HashTable *) NULL;
|
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
|
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
|
hPtr != NULL;
|
hPtr != NULL;
|
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
|
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
|
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
|
Tcl_DeleteHashEntry(hPtr);
|
Tcl_DeleteHashEntry(hPtr);
|
if (dPtr->proc != NULL) {
|
if (dPtr->proc != NULL) {
|
(*dPtr->proc)(dPtr->clientData, interp);
|
(*dPtr->proc)(dPtr->clientData, interp);
|
}
|
}
|
ckfree((char *) dPtr);
|
ckfree((char *) dPtr);
|
}
|
}
|
Tcl_DeleteHashTable(hTablePtr);
|
Tcl_DeleteHashTable(hTablePtr);
|
ckfree((char *) hTablePtr);
|
ckfree((char *) hTablePtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Finish deleting the global namespace.
|
* Finish deleting the global namespace.
|
*/
|
*/
|
|
|
Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
|
Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
|
|
|
/*
|
/*
|
* Free up the result *after* deleting variables, since variable
|
* Free up the result *after* deleting variables, since variable
|
* deletion could have transferred ownership of the result string
|
* deletion could have transferred ownership of the result string
|
* to Tcl.
|
* to Tcl.
|
*/
|
*/
|
|
|
Tcl_FreeResult(interp);
|
Tcl_FreeResult(interp);
|
interp->result = NULL;
|
interp->result = NULL;
|
Tcl_DecrRefCount(iPtr->objResultPtr);
|
Tcl_DecrRefCount(iPtr->objResultPtr);
|
iPtr->objResultPtr = NULL;
|
iPtr->objResultPtr = NULL;
|
if (iPtr->errorInfo != NULL) {
|
if (iPtr->errorInfo != NULL) {
|
ckfree(iPtr->errorInfo);
|
ckfree(iPtr->errorInfo);
|
iPtr->errorInfo = NULL;
|
iPtr->errorInfo = NULL;
|
}
|
}
|
if (iPtr->errorCode != NULL) {
|
if (iPtr->errorCode != NULL) {
|
ckfree(iPtr->errorCode);
|
ckfree(iPtr->errorCode);
|
iPtr->errorCode = NULL;
|
iPtr->errorCode = NULL;
|
}
|
}
|
if (iPtr->appendResult != NULL) {
|
if (iPtr->appendResult != NULL) {
|
ckfree(iPtr->appendResult);
|
ckfree(iPtr->appendResult);
|
iPtr->appendResult = NULL;
|
iPtr->appendResult = NULL;
|
}
|
}
|
for (i = 0; i < NUM_REGEXPS; i++) {
|
for (i = 0; i < NUM_REGEXPS; i++) {
|
if (iPtr->patterns[i] == NULL) {
|
if (iPtr->patterns[i] == NULL) {
|
break;
|
break;
|
}
|
}
|
ckfree(iPtr->patterns[i]);
|
ckfree(iPtr->patterns[i]);
|
ckfree((char *) iPtr->regexps[i]);
|
ckfree((char *) iPtr->regexps[i]);
|
iPtr->regexps[i] = NULL;
|
iPtr->regexps[i] = NULL;
|
}
|
}
|
TclFreePackageInfo(iPtr);
|
TclFreePackageInfo(iPtr);
|
while (iPtr->tracePtr != NULL) {
|
while (iPtr->tracePtr != NULL) {
|
Trace *nextPtr = iPtr->tracePtr->nextPtr;
|
Trace *nextPtr = iPtr->tracePtr->nextPtr;
|
|
|
ckfree((char *) iPtr->tracePtr);
|
ckfree((char *) iPtr->tracePtr);
|
iPtr->tracePtr = nextPtr;
|
iPtr->tracePtr = nextPtr;
|
}
|
}
|
if (iPtr->execEnvPtr != NULL) {
|
if (iPtr->execEnvPtr != NULL) {
|
TclDeleteExecEnv(iPtr->execEnvPtr);
|
TclDeleteExecEnv(iPtr->execEnvPtr);
|
}
|
}
|
Tcl_DecrRefCount(iPtr->emptyObjPtr);
|
Tcl_DecrRefCount(iPtr->emptyObjPtr);
|
iPtr->emptyObjPtr = NULL;
|
iPtr->emptyObjPtr = NULL;
|
|
|
resPtr = iPtr->resolverPtr;
|
resPtr = iPtr->resolverPtr;
|
while (resPtr) {
|
while (resPtr) {
|
nextResPtr = resPtr->nextPtr;
|
nextResPtr = resPtr->nextPtr;
|
ckfree(resPtr->name);
|
ckfree(resPtr->name);
|
ckfree((char *) resPtr);
|
ckfree((char *) resPtr);
|
resPtr = nextResPtr;
|
resPtr = nextResPtr;
|
}
|
}
|
|
|
ckfree((char *) iPtr);
|
ckfree((char *) iPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_InterpDeleted --
|
* Tcl_InterpDeleted --
|
*
|
*
|
* Returns nonzero if the interpreter has been deleted with a call
|
* Returns nonzero if the interpreter has been deleted with a call
|
* to Tcl_DeleteInterp.
|
* to Tcl_DeleteInterp.
|
*
|
*
|
* Results:
|
* Results:
|
* Nonzero if the interpreter is deleted, zero otherwise.
|
* Nonzero if the interpreter is deleted, zero otherwise.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_InterpDeleted(interp)
|
Tcl_InterpDeleted(interp)
|
Tcl_Interp *interp;
|
Tcl_Interp *interp;
|
{
|
{
|
return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
|
return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DeleteInterp --
|
* Tcl_DeleteInterp --
|
*
|
*
|
* Ensures that the interpreter will be deleted eventually. If there
|
* Ensures that the interpreter will be deleted eventually. If there
|
* are no Tcl_Preserve calls in effect for this interpreter, it is
|
* are no Tcl_Preserve calls in effect for this interpreter, it is
|
* deleted immediately, otherwise the interpreter is deleted when
|
* deleted immediately, otherwise the interpreter is deleted when
|
* the last Tcl_Preserve is matched by a call to Tcl_Release. In either
|
* the last Tcl_Preserve is matched by a call to Tcl_Release. In either
|
* case, the procedure runs the currently registered deletion callbacks.
|
* case, the procedure runs the currently registered deletion callbacks.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The interpreter is marked as deleted. The caller may still use it
|
* The interpreter is marked as deleted. The caller may still use it
|
* safely if there are calls to Tcl_Preserve in effect for the
|
* safely if there are calls to Tcl_Preserve in effect for the
|
* interpreter, but further calls to Tcl_Eval etc in this interpreter
|
* interpreter, but further calls to Tcl_Eval etc in this interpreter
|
* will fail.
|
* will fail.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DeleteInterp(interp)
|
Tcl_DeleteInterp(interp)
|
Tcl_Interp *interp; /* Token for command interpreter (returned
|
Tcl_Interp *interp; /* Token for command interpreter (returned
|
* by a previous call to Tcl_CreateInterp). */
|
* by a previous call to Tcl_CreateInterp). */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
|
|
/*
|
/*
|
* If the interpreter has already been marked deleted, just punt.
|
* If the interpreter has already been marked deleted, just punt.
|
*/
|
*/
|
|
|
if (iPtr->flags & DELETED) {
|
if (iPtr->flags & DELETED) {
|
return;
|
return;
|
}
|
}
|
|
|
/*
|
/*
|
* Mark the interpreter as deleted. No further evals will be allowed.
|
* Mark the interpreter as deleted. No further evals will be allowed.
|
*/
|
*/
|
|
|
iPtr->flags |= DELETED;
|
iPtr->flags |= DELETED;
|
|
|
/*
|
/*
|
* Ensure that the interpreter is eventually deleted.
|
* Ensure that the interpreter is eventually deleted.
|
*/
|
*/
|
|
|
Tcl_EventuallyFree((ClientData) interp,
|
Tcl_EventuallyFree((ClientData) interp,
|
(Tcl_FreeProc *) DeleteInterpProc);
|
(Tcl_FreeProc *) DeleteInterpProc);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* HiddenCmdsDeleteProc --
|
* HiddenCmdsDeleteProc --
|
*
|
*
|
* Called on interpreter deletion to delete all the hidden
|
* Called on interpreter deletion to delete all the hidden
|
* commands in an interpreter.
|
* commands in an interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Frees up memory.
|
* Frees up memory.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
HiddenCmdsDeleteProc(clientData, interp)
|
HiddenCmdsDeleteProc(clientData, interp)
|
ClientData clientData; /* The hidden commands hash table. */
|
ClientData clientData; /* The hidden commands hash table. */
|
Tcl_Interp *interp; /* The interpreter being deleted. */
|
Tcl_Interp *interp; /* The interpreter being deleted. */
|
{
|
{
|
Tcl_HashTable *hiddenCmdTblPtr;
|
Tcl_HashTable *hiddenCmdTblPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashSearch hSearch;
|
Tcl_HashSearch hSearch;
|
Command *cmdPtr;
|
Command *cmdPtr;
|
|
|
hiddenCmdTblPtr = (Tcl_HashTable *) clientData;
|
hiddenCmdTblPtr = (Tcl_HashTable *) clientData;
|
for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch);
|
for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch);
|
hPtr != NULL;
|
hPtr != NULL;
|
hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) {
|
hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) {
|
|
|
/*
|
/*
|
* Cannot use Tcl_DeleteCommand because (a) the command is not
|
* Cannot use Tcl_DeleteCommand because (a) the command is not
|
* in the command hash table, and (b) that table has already been
|
* in the command hash table, and (b) that table has already been
|
* deleted above. Hence we emulate what it does, below.
|
* deleted above. Hence we emulate what it does, below.
|
*/
|
*/
|
|
|
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
|
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
|
|
|
/*
|
/*
|
* The code here is tricky. We can't delete the hash table entry
|
* The code here is tricky. We can't delete the hash table entry
|
* before invoking the deletion callback because there are cases
|
* before invoking the deletion callback because there are cases
|
* where the deletion callback needs to invoke the command (e.g.
|
* where the deletion callback needs to invoke the command (e.g.
|
* object systems such as OTcl). However, this means that the
|
* object systems such as OTcl). However, this means that the
|
* callback could try to delete or rename the command. The deleted
|
* callback could try to delete or rename the command. The deleted
|
* flag allows us to detect these cases and skip nested deletes.
|
* flag allows us to detect these cases and skip nested deletes.
|
*/
|
*/
|
|
|
if (cmdPtr->deleted) {
|
if (cmdPtr->deleted) {
|
|
|
/*
|
/*
|
* Another deletion is already in progress. Remove the hash
|
* Another deletion is already in progress. Remove the hash
|
* table entry now, but don't invoke a callback or free the
|
* table entry now, but don't invoke a callback or free the
|
* command structure.
|
* command structure.
|
*/
|
*/
|
|
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
cmdPtr->hPtr = NULL;
|
cmdPtr->hPtr = NULL;
|
continue;
|
continue;
|
}
|
}
|
cmdPtr->deleted = 1;
|
cmdPtr->deleted = 1;
|
if (cmdPtr->deleteProc != NULL) {
|
if (cmdPtr->deleteProc != NULL) {
|
(*cmdPtr->deleteProc)(cmdPtr->deleteData);
|
(*cmdPtr->deleteProc)(cmdPtr->deleteData);
|
}
|
}
|
|
|
/*
|
/*
|
* Bump the command epoch counter. This will invalidate all cached
|
* Bump the command epoch counter. This will invalidate all cached
|
* references that refer to this command.
|
* references that refer to this command.
|
*/
|
*/
|
|
|
cmdPtr->cmdEpoch++;
|
cmdPtr->cmdEpoch++;
|
|
|
/*
|
/*
|
* Don't use hPtr to delete the hash entry here, because it's
|
* Don't use hPtr to delete the hash entry here, because it's
|
* possible that the deletion callback renamed the command.
|
* possible that the deletion callback renamed the command.
|
* Instead, use cmdPtr->hptr, and make sure that no-one else
|
* Instead, use cmdPtr->hptr, and make sure that no-one else
|
* has already deleted the hash entry.
|
* has already deleted the hash entry.
|
*/
|
*/
|
|
|
if (cmdPtr->hPtr != NULL) {
|
if (cmdPtr->hPtr != NULL) {
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Now free the Command structure, unless there is another reference
|
* Now free the Command structure, unless there is another reference
|
* to it from a CmdName Tcl object in some ByteCode code
|
* to it from a CmdName Tcl object in some ByteCode code
|
* sequence. In that case, delay the cleanup until all references
|
* sequence. In that case, delay the cleanup until all references
|
* are either discarded (when a ByteCode is freed) or replaced by a
|
* are either discarded (when a ByteCode is freed) or replaced by a
|
* new reference (when a cached CmdName Command reference is found
|
* new reference (when a cached CmdName Command reference is found
|
* to be invalid and TclExecuteByteCode looks up the command in the
|
* to be invalid and TclExecuteByteCode looks up the command in the
|
* command hashtable).
|
* command hashtable).
|
*/
|
*/
|
|
|
TclCleanupCommand(cmdPtr);
|
TclCleanupCommand(cmdPtr);
|
}
|
}
|
Tcl_DeleteHashTable(hiddenCmdTblPtr);
|
Tcl_DeleteHashTable(hiddenCmdTblPtr);
|
ckfree((char *) hiddenCmdTblPtr);
|
ckfree((char *) hiddenCmdTblPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_HideCommand --
|
* Tcl_HideCommand --
|
*
|
*
|
* Makes a command hidden so that it cannot be invoked from within
|
* Makes a command hidden so that it cannot be invoked from within
|
* an interpreter, only from within an ancestor.
|
* an interpreter, only from within an ancestor.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result; also leaves a message in interp->result
|
* A standard Tcl result; also leaves a message in interp->result
|
* if an error occurs.
|
* if an error occurs.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Removes a command from the command table and create an entry
|
* Removes a command from the command table and create an entry
|
* into the hidden command table under the specified token name.
|
* into the hidden command table under the specified token name.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
|
Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
|
Tcl_Interp *interp; /* Interpreter in which to hide command. */
|
Tcl_Interp *interp; /* Interpreter in which to hide command. */
|
char *cmdName; /* Name of command to hide. */
|
char *cmdName; /* Name of command to hide. */
|
char *hiddenCmdToken; /* Token name of the to-be-hidden command. */
|
char *hiddenCmdToken; /* Token name of the to-be-hidden command. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
Tcl_Command cmd;
|
Tcl_Command cmd;
|
Command *cmdPtr;
|
Command *cmdPtr;
|
Tcl_HashTable *hTblPtr;
|
Tcl_HashTable *hTblPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
int new;
|
int new;
|
|
|
if (iPtr->flags & DELETED) {
|
if (iPtr->flags & DELETED) {
|
|
|
/*
|
/*
|
* The interpreter is being deleted. Do not create any new
|
* The interpreter is being deleted. Do not create any new
|
* structures, because it is not safe to modify the interpreter.
|
* structures, because it is not safe to modify the interpreter.
|
*/
|
*/
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Disallow hiding of commands that are currently in a namespace or
|
* Disallow hiding of commands that are currently in a namespace or
|
* renaming (as part of hiding) into a namespace.
|
* renaming (as part of hiding) into a namespace.
|
*
|
*
|
* (because the current implementation with a single global table
|
* (because the current implementation with a single global table
|
* and the needed uniqueness of names cause problems with namespaces)
|
* and the needed uniqueness of names cause problems with namespaces)
|
*
|
*
|
* we don't need to check for "::" in cmdName because the real check is
|
* we don't need to check for "::" in cmdName because the real check is
|
* on the nsPtr below.
|
* on the nsPtr below.
|
*
|
*
|
* hiddenCmdToken is just a string which is not interpreted in any way.
|
* hiddenCmdToken is just a string which is not interpreted in any way.
|
* It may contain :: but the string is not interpreted as a namespace
|
* It may contain :: but the string is not interpreted as a namespace
|
* qualifier command name. Thus, hiding foo::bar to foo::bar and then
|
* qualifier command name. Thus, hiding foo::bar to foo::bar and then
|
* trying to expose or invoke ::foo::bar will NOT work; but if the
|
* trying to expose or invoke ::foo::bar will NOT work; but if the
|
* application always uses the same strings it will get consistent
|
* application always uses the same strings it will get consistent
|
* behaviour.
|
* behaviour.
|
*
|
*
|
* But as we currently limit ourselves to the global namespace only
|
* But as we currently limit ourselves to the global namespace only
|
* for the source, in order to avoid potential confusion,
|
* for the source, in order to avoid potential confusion,
|
* lets prevent "::" in the token too. --dl
|
* lets prevent "::" in the token too. --dl
|
*/
|
*/
|
|
|
if (strstr(hiddenCmdToken, "::") != NULL) {
|
if (strstr(hiddenCmdToken, "::") != NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"cannot use namespace qualifiers as hidden command",
|
"cannot use namespace qualifiers as hidden command",
|
"token (rename)", (char *) NULL);
|
"token (rename)", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Find the command to hide. An error is returned if cmdName can't
|
* Find the command to hide. An error is returned if cmdName can't
|
* be found. Look up the command only from the global namespace.
|
* be found. Look up the command only from the global namespace.
|
* Full path of the command must be given if using namespaces.
|
* Full path of the command must be given if using namespaces.
|
*/
|
*/
|
|
|
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
|
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
|
/*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
|
/*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
|
if (cmd == (Tcl_Command) NULL) {
|
if (cmd == (Tcl_Command) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
cmdPtr = (Command *) cmd;
|
cmdPtr = (Command *) cmd;
|
|
|
/*
|
/*
|
* Check that the command is really in global namespace
|
* Check that the command is really in global namespace
|
*/
|
*/
|
|
|
if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
|
if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"can only hide global namespace commands",
|
"can only hide global namespace commands",
|
" (use rename then hide)", (char *) NULL);
|
" (use rename then hide)", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Initialize the hidden command table if necessary.
|
* Initialize the hidden command table if necessary.
|
*/
|
*/
|
|
|
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds",
|
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds",
|
NULL);
|
NULL);
|
if (hTblPtr == (Tcl_HashTable *) NULL) {
|
if (hTblPtr == (Tcl_HashTable *) NULL) {
|
hTblPtr = (Tcl_HashTable *)
|
hTblPtr = (Tcl_HashTable *)
|
ckalloc((unsigned) sizeof(Tcl_HashTable));
|
ckalloc((unsigned) sizeof(Tcl_HashTable));
|
Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);
|
Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);
|
Tcl_SetAssocData(interp, "tclHiddenCmds", HiddenCmdsDeleteProc,
|
Tcl_SetAssocData(interp, "tclHiddenCmds", HiddenCmdsDeleteProc,
|
(ClientData) hTblPtr);
|
(ClientData) hTblPtr);
|
}
|
}
|
|
|
/*
|
/*
|
* It is an error to move an exposed command to a hidden command with
|
* It is an error to move an exposed command to a hidden command with
|
* hiddenCmdToken if a hidden command with the name hiddenCmdToken already
|
* hiddenCmdToken if a hidden command with the name hiddenCmdToken already
|
* exists.
|
* exists.
|
*/
|
*/
|
|
|
hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new);
|
hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new);
|
if (!new) {
|
if (!new) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"hidden command named \"", hiddenCmdToken, "\" already exists",
|
"hidden command named \"", hiddenCmdToken, "\" already exists",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Nb : This code is currently 'like' a rename to a specialy set apart
|
* Nb : This code is currently 'like' a rename to a specialy set apart
|
* name table. Changes here and in TclRenameCommand must
|
* name table. Changes here and in TclRenameCommand must
|
* be kept in synch untill the common parts are actually
|
* be kept in synch untill the common parts are actually
|
* factorized out.
|
* factorized out.
|
*/
|
*/
|
|
|
/*
|
/*
|
* Remove the hash entry for the command from the interpreter command
|
* Remove the hash entry for the command from the interpreter command
|
* table. This is like deleting the command, so bump its command epoch;
|
* table. This is like deleting the command, so bump its command epoch;
|
* this invalidates any cached references that point to the command.
|
* this invalidates any cached references that point to the command.
|
*/
|
*/
|
|
|
if (cmdPtr->hPtr != NULL) {
|
if (cmdPtr->hPtr != NULL) {
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
cmdPtr->hPtr = (Tcl_HashEntry *) NULL;
|
cmdPtr->hPtr = (Tcl_HashEntry *) NULL;
|
cmdPtr->cmdEpoch++;
|
cmdPtr->cmdEpoch++;
|
}
|
}
|
|
|
/*
|
/*
|
* Now link the hash table entry with the command structure.
|
* Now link the hash table entry with the command structure.
|
* We ensured above that the nsPtr was right.
|
* We ensured above that the nsPtr was right.
|
*/
|
*/
|
|
|
cmdPtr->hPtr = hPtr;
|
cmdPtr->hPtr = hPtr;
|
Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
|
Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
|
|
|
/*
|
/*
|
* If the command being hidden has a compile procedure, increment the
|
* If the command being hidden has a compile procedure, increment the
|
* interpreter's compileEpoch to invalidate its compiled code. This
|
* interpreter's compileEpoch to invalidate its compiled code. This
|
* makes sure that we don't later try to execute old code compiled with
|
* makes sure that we don't later try to execute old code compiled with
|
* command-specific (i.e., inline) bytecodes for the now-hidden
|
* command-specific (i.e., inline) bytecodes for the now-hidden
|
* command. This field is checked in Tcl_EvalObj and ObjInterpProc,
|
* command. This field is checked in Tcl_EvalObj and ObjInterpProc,
|
* and code whose compilation epoch doesn't match is recompiled.
|
* and code whose compilation epoch doesn't match is recompiled.
|
*/
|
*/
|
|
|
if (cmdPtr->compileProc != NULL) {
|
if (cmdPtr->compileProc != NULL) {
|
iPtr->compileEpoch++;
|
iPtr->compileEpoch++;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_ExposeCommand --
|
* Tcl_ExposeCommand --
|
*
|
*
|
* Makes a previously hidden command callable from inside the
|
* Makes a previously hidden command callable from inside the
|
* interpreter instead of only by its ancestors.
|
* interpreter instead of only by its ancestors.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result. If an error occurs, a message is left
|
* A standard Tcl result. If an error occurs, a message is left
|
* in interp->result.
|
* in interp->result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Moves commands from one hash table to another.
|
* Moves commands from one hash table to another.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
|
Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
|
Tcl_Interp *interp; /* Interpreter in which to make command
|
Tcl_Interp *interp; /* Interpreter in which to make command
|
* callable. */
|
* callable. */
|
char *hiddenCmdToken; /* Name of hidden command. */
|
char *hiddenCmdToken; /* Name of hidden command. */
|
char *cmdName; /* Name of to-be-exposed command. */
|
char *cmdName; /* Name of to-be-exposed command. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
Command *cmdPtr;
|
Command *cmdPtr;
|
Namespace *nsPtr;
|
Namespace *nsPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashTable *hTblPtr;
|
Tcl_HashTable *hTblPtr;
|
int new;
|
int new;
|
|
|
if (iPtr->flags & DELETED) {
|
if (iPtr->flags & DELETED) {
|
/*
|
/*
|
* The interpreter is being deleted. Do not create any new
|
* The interpreter is being deleted. Do not create any new
|
* structures, because it is not safe to modify the interpreter.
|
* structures, because it is not safe to modify the interpreter.
|
*/
|
*/
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Check that we have a regular name for the command
|
* Check that we have a regular name for the command
|
* (that the user is not trying to do an expose and a rename
|
* (that the user is not trying to do an expose and a rename
|
* (to another namespace) at the same time)
|
* (to another namespace) at the same time)
|
*/
|
*/
|
|
|
if (strstr(cmdName, "::") != NULL) {
|
if (strstr(cmdName, "::") != NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"can not expose to a namespace ",
|
"can not expose to a namespace ",
|
"(use expose to toplevel, then rename)",
|
"(use expose to toplevel, then rename)",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Find the hash table for the hidden commands; error out if there
|
* Find the hash table for the hidden commands; error out if there
|
* is none.
|
* is none.
|
*/
|
*/
|
|
|
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds",
|
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds",
|
NULL);
|
NULL);
|
if (hTblPtr == NULL) {
|
if (hTblPtr == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"unknown hidden command \"", hiddenCmdToken,
|
"unknown hidden command \"", hiddenCmdToken,
|
"\"", (char *) NULL);
|
"\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Get the command from the hidden command table:
|
* Get the command from the hidden command table:
|
*/
|
*/
|
|
|
hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken);
|
hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken);
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"unknown hidden command \"", hiddenCmdToken,
|
"unknown hidden command \"", hiddenCmdToken,
|
"\"", (char *) NULL);
|
"\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
|
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
|
|
|
|
|
/*
|
/*
|
* Check that we have a true global namespace
|
* Check that we have a true global namespace
|
* command (enforced by Tcl_HideCommand() but let's double
|
* command (enforced by Tcl_HideCommand() but let's double
|
* check. (If it was not, we would not really know how to
|
* check. (If it was not, we would not really know how to
|
* handle it).
|
* handle it).
|
*/
|
*/
|
if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
|
if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
|
/*
|
/*
|
* This case is theoritically impossible,
|
* This case is theoritically impossible,
|
* we might rather panic() than 'nicely' erroring out ?
|
* we might rather panic() than 'nicely' erroring out ?
|
*/
|
*/
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"trying to expose a non global command name space command",
|
"trying to expose a non global command name space command",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/* This is the global table */
|
/* This is the global table */
|
nsPtr = cmdPtr->nsPtr;
|
nsPtr = cmdPtr->nsPtr;
|
|
|
/*
|
/*
|
* It is an error to overwrite an existing exposed command as a result
|
* It is an error to overwrite an existing exposed command as a result
|
* of exposing a previously hidden command.
|
* of exposing a previously hidden command.
|
*/
|
*/
|
|
|
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
|
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
|
if (!new) {
|
if (!new) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"exposed command \"", cmdName,
|
"exposed command \"", cmdName,
|
"\" already exists", (char *) NULL);
|
"\" already exists", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Remove the hash entry for the command from the interpreter hidden
|
* Remove the hash entry for the command from the interpreter hidden
|
* command table.
|
* command table.
|
*/
|
*/
|
|
|
if (cmdPtr->hPtr != NULL) {
|
if (cmdPtr->hPtr != NULL) {
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
cmdPtr->hPtr = NULL;
|
cmdPtr->hPtr = NULL;
|
}
|
}
|
|
|
/*
|
/*
|
* Now link the hash table entry with the command structure.
|
* Now link the hash table entry with the command structure.
|
* This is like creating a new command, so deal with any shadowing
|
* This is like creating a new command, so deal with any shadowing
|
* of commands in the global namespace.
|
* of commands in the global namespace.
|
*/
|
*/
|
|
|
cmdPtr->hPtr = hPtr;
|
cmdPtr->hPtr = hPtr;
|
|
|
Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
|
Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
|
|
|
/*
|
/*
|
* Not needed as we are only in the global namespace
|
* Not needed as we are only in the global namespace
|
* (but would be needed again if we supported namespace command hiding)
|
* (but would be needed again if we supported namespace command hiding)
|
*
|
*
|
* TclResetShadowedCmdRefs(interp, cmdPtr);
|
* TclResetShadowedCmdRefs(interp, cmdPtr);
|
*/
|
*/
|
|
|
|
|
/*
|
/*
|
* If the command being exposed has a compile procedure, increment
|
* If the command being exposed has a compile procedure, increment
|
* interpreter's compileEpoch to invalidate its compiled code. This
|
* interpreter's compileEpoch to invalidate its compiled code. This
|
* makes sure that we don't later try to execute old code compiled
|
* makes sure that we don't later try to execute old code compiled
|
* assuming the command is hidden. This field is checked in Tcl_EvalObj
|
* assuming the command is hidden. This field is checked in Tcl_EvalObj
|
* and ObjInterpProc, and code whose compilation epoch doesn't match is
|
* and ObjInterpProc, and code whose compilation epoch doesn't match is
|
* recompiled.
|
* recompiled.
|
*/
|
*/
|
|
|
if (cmdPtr->compileProc != NULL) {
|
if (cmdPtr->compileProc != NULL) {
|
iPtr->compileEpoch++;
|
iPtr->compileEpoch++;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_CreateCommand --
|
* Tcl_CreateCommand --
|
*
|
*
|
* Define a new command in a command table.
|
* Define a new command in a command table.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a token for the command, which can
|
* The return value is a token for the command, which can
|
* be used in future calls to Tcl_GetCommandName.
|
* be used in future calls to Tcl_GetCommandName.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If a command named cmdName already exists for interp, it is deleted.
|
* If a command named cmdName already exists for interp, it is deleted.
|
* In the future, when cmdName is seen as the name of a command by
|
* In the future, when cmdName is seen as the name of a command by
|
* Tcl_Eval, proc will be called. To support the bytecode interpreter,
|
* Tcl_Eval, proc will be called. To support the bytecode interpreter,
|
* the command is created with a wrapper Tcl_ObjCmdProc
|
* the command is created with a wrapper Tcl_ObjCmdProc
|
* (TclInvokeStringCommand) that eventially calls proc. When the
|
* (TclInvokeStringCommand) that eventially calls proc. When the
|
* command is deleted from the table, deleteProc will be called.
|
* command is deleted from the table, deleteProc will be called.
|
* See the manual entry for details on the calling sequence.
|
* See the manual entry for details on the calling sequence.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_Command
|
Tcl_Command
|
Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
|
Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
|
Tcl_Interp *interp; /* Token for command interpreter returned by
|
Tcl_Interp *interp; /* Token for command interpreter returned by
|
* a previous call to Tcl_CreateInterp. */
|
* a previous call to Tcl_CreateInterp. */
|
char *cmdName; /* Name of command. If it contains namespace
|
char *cmdName; /* Name of command. If it contains namespace
|
* qualifiers, the new command is put in the
|
* qualifiers, the new command is put in the
|
* specified namespace; otherwise it is put
|
* specified namespace; otherwise it is put
|
* in the global namespace. */
|
* in the global namespace. */
|
Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */
|
Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */
|
ClientData clientData; /* Arbitrary value passed to string proc. */
|
ClientData clientData; /* Arbitrary value passed to string proc. */
|
Tcl_CmdDeleteProc *deleteProc;
|
Tcl_CmdDeleteProc *deleteProc;
|
/* If not NULL, gives a procedure to call
|
/* If not NULL, gives a procedure to call
|
* when this command is deleted. */
|
* when this command is deleted. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
ImportRef *oldRefPtr = NULL;
|
ImportRef *oldRefPtr = NULL;
|
Namespace *nsPtr, *dummy1, *dummy2;
|
Namespace *nsPtr, *dummy1, *dummy2;
|
Command *cmdPtr, *refCmdPtr;
|
Command *cmdPtr, *refCmdPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
char *tail;
|
char *tail;
|
int new, result;
|
int new, result;
|
ImportedCmdData *dataPtr;
|
ImportedCmdData *dataPtr;
|
|
|
if (iPtr->flags & DELETED) {
|
if (iPtr->flags & DELETED) {
|
/*
|
/*
|
* The interpreter is being deleted. Don't create any new
|
* The interpreter is being deleted. Don't create any new
|
* commands; it's not safe to muck with the interpreter anymore.
|
* commands; it's not safe to muck with the interpreter anymore.
|
*/
|
*/
|
|
|
return (Tcl_Command) NULL;
|
return (Tcl_Command) NULL;
|
}
|
}
|
|
|
/*
|
/*
|
* Determine where the command should reside. If its name contains
|
* Determine where the command should reside. If its name contains
|
* namespace qualifiers, we put it in the specified namespace;
|
* namespace qualifiers, we put it in the specified namespace;
|
* otherwise, we always put it in the global namespace.
|
* otherwise, we always put it in the global namespace.
|
*/
|
*/
|
|
|
if (strstr(cmdName, "::") != NULL) {
|
if (strstr(cmdName, "::") != NULL) {
|
result = TclGetNamespaceForQualName(interp, cmdName,
|
result = TclGetNamespaceForQualName(interp, cmdName,
|
(Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr,
|
(Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr,
|
&dummy1, &dummy2, &tail);
|
&dummy1, &dummy2, &tail);
|
if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) {
|
if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) {
|
return (Tcl_Command) NULL;
|
return (Tcl_Command) NULL;
|
}
|
}
|
} else {
|
} else {
|
nsPtr = iPtr->globalNsPtr;
|
nsPtr = iPtr->globalNsPtr;
|
tail = cmdName;
|
tail = cmdName;
|
}
|
}
|
|
|
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
|
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
|
if (!new) {
|
if (!new) {
|
/*
|
/*
|
* Command already exists. Delete the old one.
|
* Command already exists. Delete the old one.
|
* Be careful to preserve any existing import links so we can
|
* Be careful to preserve any existing import links so we can
|
* restore them down below. That way, you can redefine a
|
* restore them down below. That way, you can redefine a
|
* command and its import status will remain intact.
|
* command and its import status will remain intact.
|
*/
|
*/
|
|
|
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
|
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
|
oldRefPtr = cmdPtr->importRefPtr;
|
oldRefPtr = cmdPtr->importRefPtr;
|
cmdPtr->importRefPtr = NULL;
|
cmdPtr->importRefPtr = NULL;
|
|
|
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
|
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
|
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
|
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
|
if (!new) {
|
if (!new) {
|
/*
|
/*
|
* If the deletion callback recreated the command, just throw
|
* If the deletion callback recreated the command, just throw
|
* away the new command (if we try to delete it again, we
|
* away the new command (if we try to delete it again, we
|
* could get stuck in an infinite loop).
|
* could get stuck in an infinite loop).
|
*/
|
*/
|
|
|
ckfree((char*) cmdPtr);
|
ckfree((char*) cmdPtr);
|
}
|
}
|
}
|
}
|
cmdPtr = (Command *) ckalloc(sizeof(Command));
|
cmdPtr = (Command *) ckalloc(sizeof(Command));
|
Tcl_SetHashValue(hPtr, cmdPtr);
|
Tcl_SetHashValue(hPtr, cmdPtr);
|
cmdPtr->hPtr = hPtr;
|
cmdPtr->hPtr = hPtr;
|
cmdPtr->nsPtr = nsPtr;
|
cmdPtr->nsPtr = nsPtr;
|
cmdPtr->refCount = 1;
|
cmdPtr->refCount = 1;
|
cmdPtr->cmdEpoch = 0;
|
cmdPtr->cmdEpoch = 0;
|
cmdPtr->compileProc = (CompileProc *) NULL;
|
cmdPtr->compileProc = (CompileProc *) NULL;
|
cmdPtr->objProc = TclInvokeStringCommand;
|
cmdPtr->objProc = TclInvokeStringCommand;
|
cmdPtr->objClientData = (ClientData) cmdPtr;
|
cmdPtr->objClientData = (ClientData) cmdPtr;
|
cmdPtr->proc = proc;
|
cmdPtr->proc = proc;
|
cmdPtr->clientData = clientData;
|
cmdPtr->clientData = clientData;
|
cmdPtr->deleteProc = deleteProc;
|
cmdPtr->deleteProc = deleteProc;
|
cmdPtr->deleteData = clientData;
|
cmdPtr->deleteData = clientData;
|
cmdPtr->deleted = 0;
|
cmdPtr->deleted = 0;
|
cmdPtr->importRefPtr = NULL;
|
cmdPtr->importRefPtr = NULL;
|
|
|
/*
|
/*
|
* Plug in any existing import references found above. Be sure
|
* Plug in any existing import references found above. Be sure
|
* to update all of these references to point to the new command.
|
* to update all of these references to point to the new command.
|
*/
|
*/
|
|
|
if (oldRefPtr != NULL) {
|
if (oldRefPtr != NULL) {
|
cmdPtr->importRefPtr = oldRefPtr;
|
cmdPtr->importRefPtr = oldRefPtr;
|
while (oldRefPtr != NULL) {
|
while (oldRefPtr != NULL) {
|
refCmdPtr = oldRefPtr->importedCmdPtr;
|
refCmdPtr = oldRefPtr->importedCmdPtr;
|
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
|
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
|
dataPtr->realCmdPtr = cmdPtr;
|
dataPtr->realCmdPtr = cmdPtr;
|
oldRefPtr = oldRefPtr->nextPtr;
|
oldRefPtr = oldRefPtr->nextPtr;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* We just created a command, so in its namespace and all of its parent
|
* We just created a command, so in its namespace and all of its parent
|
* namespaces, it may shadow global commands with the same name. If any
|
* namespaces, it may shadow global commands with the same name. If any
|
* shadowed commands are found, invalidate all cached command references
|
* shadowed commands are found, invalidate all cached command references
|
* in the affected namespaces.
|
* in the affected namespaces.
|
*/
|
*/
|
|
|
TclResetShadowedCmdRefs(interp, cmdPtr);
|
TclResetShadowedCmdRefs(interp, cmdPtr);
|
return (Tcl_Command) cmdPtr;
|
return (Tcl_Command) cmdPtr;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_CreateObjCommand --
|
* Tcl_CreateObjCommand --
|
*
|
*
|
* Define a new object-based command in a command table.
|
* Define a new object-based command in a command table.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a token for the command, which can
|
* The return value is a token for the command, which can
|
* be used in future calls to Tcl_NameOfCommand.
|
* be used in future calls to Tcl_NameOfCommand.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If no command named "cmdName" already exists for interp, one is
|
* If no command named "cmdName" already exists for interp, one is
|
* created. Otherwise, if a command does exist, then if the
|
* created. Otherwise, if a command does exist, then if the
|
* object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume
|
* object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume
|
* Tcl_CreateCommand was called previously for the same command and
|
* Tcl_CreateCommand was called previously for the same command and
|
* just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we
|
* just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we
|
* delete the old command.
|
* delete the old command.
|
*
|
*
|
* In the future, during bytecode evaluation when "cmdName" is seen as
|
* In the future, during bytecode evaluation when "cmdName" is seen as
|
* the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
|
* the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
|
* Tcl_ObjCmdProc proc will be called. When the command is deleted from
|
* Tcl_ObjCmdProc proc will be called. When the command is deleted from
|
* the table, deleteProc will be called. See the manual entry for
|
* the table, deleteProc will be called. See the manual entry for
|
* details on the calling sequence.
|
* details on the calling sequence.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_Command
|
Tcl_Command
|
Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
|
Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
|
Tcl_Interp *interp; /* Token for command interpreter (returned
|
Tcl_Interp *interp; /* Token for command interpreter (returned
|
* by previous call to Tcl_CreateInterp). */
|
* by previous call to Tcl_CreateInterp). */
|
char *cmdName; /* Name of command. If it contains namespace
|
char *cmdName; /* Name of command. If it contains namespace
|
* qualifiers, the new command is put in the
|
* qualifiers, the new command is put in the
|
* specified namespace; otherwise it is put
|
* specified namespace; otherwise it is put
|
* in the global namespace. */
|
* in the global namespace. */
|
Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with
|
Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with
|
* name. */
|
* name. */
|
ClientData clientData; /* Arbitrary value to pass to object
|
ClientData clientData; /* Arbitrary value to pass to object
|
* procedure. */
|
* procedure. */
|
Tcl_CmdDeleteProc *deleteProc;
|
Tcl_CmdDeleteProc *deleteProc;
|
/* If not NULL, gives a procedure to call
|
/* If not NULL, gives a procedure to call
|
* when this command is deleted. */
|
* when this command is deleted. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
ImportRef *oldRefPtr = NULL;
|
ImportRef *oldRefPtr = NULL;
|
Namespace *nsPtr, *dummy1, *dummy2;
|
Namespace *nsPtr, *dummy1, *dummy2;
|
Command *cmdPtr, *refCmdPtr;
|
Command *cmdPtr, *refCmdPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
char *tail;
|
char *tail;
|
int new, result;
|
int new, result;
|
ImportedCmdData *dataPtr;
|
ImportedCmdData *dataPtr;
|
|
|
if (iPtr->flags & DELETED) {
|
if (iPtr->flags & DELETED) {
|
/*
|
/*
|
* The interpreter is being deleted. Don't create any new
|
* The interpreter is being deleted. Don't create any new
|
* commands; it's not safe to muck with the interpreter anymore.
|
* commands; it's not safe to muck with the interpreter anymore.
|
*/
|
*/
|
|
|
return (Tcl_Command) NULL;
|
return (Tcl_Command) NULL;
|
}
|
}
|
|
|
/*
|
/*
|
* Determine where the command should reside. If its name contains
|
* Determine where the command should reside. If its name contains
|
* namespace qualifiers, we put it in the specified namespace;
|
* namespace qualifiers, we put it in the specified namespace;
|
* otherwise, we always put it in the global namespace.
|
* otherwise, we always put it in the global namespace.
|
*/
|
*/
|
|
|
if (strstr(cmdName, "::") != NULL) {
|
if (strstr(cmdName, "::") != NULL) {
|
result = TclGetNamespaceForQualName(interp, cmdName,
|
result = TclGetNamespaceForQualName(interp, cmdName,
|
(Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr,
|
(Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr,
|
&dummy1, &dummy2, &tail);
|
&dummy1, &dummy2, &tail);
|
if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) {
|
if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) {
|
return (Tcl_Command) NULL;
|
return (Tcl_Command) NULL;
|
}
|
}
|
} else {
|
} else {
|
nsPtr = iPtr->globalNsPtr;
|
nsPtr = iPtr->globalNsPtr;
|
tail = cmdName;
|
tail = cmdName;
|
}
|
}
|
|
|
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
|
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
|
if (!new) {
|
if (!new) {
|
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
|
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
|
|
|
/*
|
/*
|
* Command already exists. If its object-based Tcl_ObjCmdProc is
|
* Command already exists. If its object-based Tcl_ObjCmdProc is
|
* TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
|
* TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
|
* argument "proc". Otherwise, we delete the old command.
|
* argument "proc". Otherwise, we delete the old command.
|
*/
|
*/
|
|
|
if (cmdPtr->objProc == TclInvokeStringCommand) {
|
if (cmdPtr->objProc == TclInvokeStringCommand) {
|
cmdPtr->objProc = proc;
|
cmdPtr->objProc = proc;
|
cmdPtr->objClientData = clientData;
|
cmdPtr->objClientData = clientData;
|
cmdPtr->deleteProc = deleteProc;
|
cmdPtr->deleteProc = deleteProc;
|
cmdPtr->deleteData = clientData;
|
cmdPtr->deleteData = clientData;
|
return (Tcl_Command) cmdPtr;
|
return (Tcl_Command) cmdPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* Otherwise, we delete the old command. Be careful to preserve
|
* Otherwise, we delete the old command. Be careful to preserve
|
* any existing import links so we can restore them down below.
|
* any existing import links so we can restore them down below.
|
* That way, you can redefine a command and its import status
|
* That way, you can redefine a command and its import status
|
* will remain intact.
|
* will remain intact.
|
*/
|
*/
|
|
|
oldRefPtr = cmdPtr->importRefPtr;
|
oldRefPtr = cmdPtr->importRefPtr;
|
cmdPtr->importRefPtr = NULL;
|
cmdPtr->importRefPtr = NULL;
|
|
|
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
|
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
|
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
|
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
|
if (!new) {
|
if (!new) {
|
/*
|
/*
|
* If the deletion callback recreated the command, just throw
|
* If the deletion callback recreated the command, just throw
|
* away the new command (if we try to delete it again, we
|
* away the new command (if we try to delete it again, we
|
* could get stuck in an infinite loop).
|
* could get stuck in an infinite loop).
|
*/
|
*/
|
|
|
ckfree((char *) Tcl_GetHashValue(hPtr));
|
ckfree((char *) Tcl_GetHashValue(hPtr));
|
}
|
}
|
}
|
}
|
cmdPtr = (Command *) ckalloc(sizeof(Command));
|
cmdPtr = (Command *) ckalloc(sizeof(Command));
|
Tcl_SetHashValue(hPtr, cmdPtr);
|
Tcl_SetHashValue(hPtr, cmdPtr);
|
cmdPtr->hPtr = hPtr;
|
cmdPtr->hPtr = hPtr;
|
cmdPtr->nsPtr = nsPtr;
|
cmdPtr->nsPtr = nsPtr;
|
cmdPtr->refCount = 1;
|
cmdPtr->refCount = 1;
|
cmdPtr->cmdEpoch = 0;
|
cmdPtr->cmdEpoch = 0;
|
cmdPtr->compileProc = (CompileProc *) NULL;
|
cmdPtr->compileProc = (CompileProc *) NULL;
|
cmdPtr->objProc = proc;
|
cmdPtr->objProc = proc;
|
cmdPtr->objClientData = clientData;
|
cmdPtr->objClientData = clientData;
|
cmdPtr->proc = TclInvokeObjectCommand;
|
cmdPtr->proc = TclInvokeObjectCommand;
|
cmdPtr->clientData = (ClientData) cmdPtr;
|
cmdPtr->clientData = (ClientData) cmdPtr;
|
cmdPtr->deleteProc = deleteProc;
|
cmdPtr->deleteProc = deleteProc;
|
cmdPtr->deleteData = clientData;
|
cmdPtr->deleteData = clientData;
|
cmdPtr->deleted = 0;
|
cmdPtr->deleted = 0;
|
cmdPtr->importRefPtr = NULL;
|
cmdPtr->importRefPtr = NULL;
|
|
|
/*
|
/*
|
* Plug in any existing import references found above. Be sure
|
* Plug in any existing import references found above. Be sure
|
* to update all of these references to point to the new command.
|
* to update all of these references to point to the new command.
|
*/
|
*/
|
|
|
if (oldRefPtr != NULL) {
|
if (oldRefPtr != NULL) {
|
cmdPtr->importRefPtr = oldRefPtr;
|
cmdPtr->importRefPtr = oldRefPtr;
|
while (oldRefPtr != NULL) {
|
while (oldRefPtr != NULL) {
|
refCmdPtr = oldRefPtr->importedCmdPtr;
|
refCmdPtr = oldRefPtr->importedCmdPtr;
|
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
|
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
|
dataPtr->realCmdPtr = cmdPtr;
|
dataPtr->realCmdPtr = cmdPtr;
|
oldRefPtr = oldRefPtr->nextPtr;
|
oldRefPtr = oldRefPtr->nextPtr;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* We just created a command, so in its namespace and all of its parent
|
* We just created a command, so in its namespace and all of its parent
|
* namespaces, it may shadow global commands with the same name. If any
|
* namespaces, it may shadow global commands with the same name. If any
|
* shadowed commands are found, invalidate all cached command references
|
* shadowed commands are found, invalidate all cached command references
|
* in the affected namespaces.
|
* in the affected namespaces.
|
*/
|
*/
|
|
|
TclResetShadowedCmdRefs(interp, cmdPtr);
|
TclResetShadowedCmdRefs(interp, cmdPtr);
|
return (Tcl_Command) cmdPtr;
|
return (Tcl_Command) cmdPtr;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclInvokeStringCommand --
|
* TclInvokeStringCommand --
|
*
|
*
|
* "Wrapper" Tcl_ObjCmdProc used to call an existing string-based
|
* "Wrapper" Tcl_ObjCmdProc used to call an existing string-based
|
* Tcl_CmdProc if no object-based procedure exists for a command. A
|
* Tcl_CmdProc if no object-based procedure exists for a command. A
|
* pointer to this procedure is stored as the Tcl_ObjCmdProc in a
|
* pointer to this procedure is stored as the Tcl_ObjCmdProc in a
|
* Command structure. It simply turns around and calls the string
|
* Command structure. It simply turns around and calls the string
|
* Tcl_CmdProc in the Command structure.
|
* Tcl_CmdProc in the Command structure.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl object result value.
|
* A standard Tcl object result value.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Besides those side effects of the called Tcl_CmdProc,
|
* Besides those side effects of the called Tcl_CmdProc,
|
* TclInvokeStringCommand allocates and frees storage.
|
* TclInvokeStringCommand allocates and frees storage.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclInvokeStringCommand(clientData, interp, objc, objv)
|
TclInvokeStringCommand(clientData, interp, objc, objv)
|
ClientData clientData; /* Points to command's Command structure. */
|
ClientData clientData; /* Points to command's Command structure. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
register int objc; /* Number of arguments. */
|
register int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
register Command *cmdPtr = (Command *) clientData;
|
register Command *cmdPtr = (Command *) clientData;
|
register int i;
|
register int i;
|
int result;
|
int result;
|
|
|
/*
|
/*
|
* This procedure generates an argv array for the string arguments. It
|
* This procedure generates an argv array for the string arguments. It
|
* starts out with stack-allocated space but uses dynamically-allocated
|
* starts out with stack-allocated space but uses dynamically-allocated
|
* storage if needed.
|
* storage if needed.
|
*/
|
*/
|
|
|
#define NUM_ARGS 20
|
#define NUM_ARGS 20
|
char *(argStorage[NUM_ARGS]);
|
char *(argStorage[NUM_ARGS]);
|
char **argv = argStorage;
|
char **argv = argStorage;
|
|
|
/*
|
/*
|
* Create the string argument array "argv". Make sure argv is large
|
* Create the string argument array "argv". Make sure argv is large
|
* enough to hold the objc arguments plus 1 extra for the zero
|
* enough to hold the objc arguments plus 1 extra for the zero
|
* end-of-argv word.
|
* end-of-argv word.
|
* THIS FAILS IF ANY ARGUMENT OBJECT CONTAINS AN EMBEDDED NULL.
|
* THIS FAILS IF ANY ARGUMENT OBJECT CONTAINS AN EMBEDDED NULL.
|
*/
|
*/
|
|
|
if ((objc + 1) > NUM_ARGS) {
|
if ((objc + 1) > NUM_ARGS) {
|
argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
|
argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
|
}
|
}
|
|
|
for (i = 0; i < objc; i++) {
|
for (i = 0; i < objc; i++) {
|
argv[i] = Tcl_GetStringFromObj(objv[i], (int *) NULL);
|
argv[i] = Tcl_GetStringFromObj(objv[i], (int *) NULL);
|
}
|
}
|
argv[objc] = 0;
|
argv[objc] = 0;
|
|
|
/*
|
/*
|
* Invoke the command's string-based Tcl_CmdProc.
|
* Invoke the command's string-based Tcl_CmdProc.
|
*/
|
*/
|
|
|
result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);
|
result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);
|
|
|
/*
|
/*
|
* Free the argv array if malloc'ed storage was used.
|
* Free the argv array if malloc'ed storage was used.
|
*/
|
*/
|
|
|
if (argv != argStorage) {
|
if (argv != argStorage) {
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
}
|
}
|
return result;
|
return result;
|
#undef NUM_ARGS
|
#undef NUM_ARGS
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclInvokeObjectCommand --
|
* TclInvokeObjectCommand --
|
*
|
*
|
* "Wrapper" Tcl_CmdProc used to call an existing object-based
|
* "Wrapper" Tcl_CmdProc used to call an existing object-based
|
* Tcl_ObjCmdProc if no string-based procedure exists for a command.
|
* Tcl_ObjCmdProc if no string-based procedure exists for a command.
|
* A pointer to this procedure is stored as the Tcl_CmdProc in a
|
* A pointer to this procedure is stored as the Tcl_CmdProc in a
|
* Command structure. It simply turns around and calls the object
|
* Command structure. It simply turns around and calls the object
|
* Tcl_ObjCmdProc in the Command structure.
|
* Tcl_ObjCmdProc in the Command structure.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl string result value.
|
* A standard Tcl string result value.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Besides those side effects of the called Tcl_CmdProc,
|
* Besides those side effects of the called Tcl_CmdProc,
|
* TclInvokeStringCommand allocates and frees storage.
|
* TclInvokeStringCommand allocates and frees storage.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclInvokeObjectCommand(clientData, interp, argc, argv)
|
TclInvokeObjectCommand(clientData, interp, argc, argv)
|
ClientData clientData; /* Points to command's Command structure. */
|
ClientData clientData; /* Points to command's Command structure. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
register char **argv; /* Argument strings. */
|
register char **argv; /* Argument strings. */
|
{
|
{
|
Command *cmdPtr = (Command *) clientData;
|
Command *cmdPtr = (Command *) clientData;
|
register Tcl_Obj *objPtr;
|
register Tcl_Obj *objPtr;
|
register int i;
|
register int i;
|
int length, result;
|
int length, result;
|
|
|
/*
|
/*
|
* This procedure generates an objv array for object arguments that hold
|
* This procedure generates an objv array for object arguments that hold
|
* the argv strings. It starts out with stack-allocated space but uses
|
* the argv strings. It starts out with stack-allocated space but uses
|
* dynamically-allocated storage if needed.
|
* dynamically-allocated storage if needed.
|
*/
|
*/
|
|
|
#define NUM_ARGS 20
|
#define NUM_ARGS 20
|
Tcl_Obj *(argStorage[NUM_ARGS]);
|
Tcl_Obj *(argStorage[NUM_ARGS]);
|
register Tcl_Obj **objv = argStorage;
|
register Tcl_Obj **objv = argStorage;
|
|
|
/*
|
/*
|
* Create the object argument array "objv". Make sure objv is large
|
* Create the object argument array "objv". Make sure objv is large
|
* enough to hold the objc arguments plus 1 extra for the zero
|
* enough to hold the objc arguments plus 1 extra for the zero
|
* end-of-objv word.
|
* end-of-objv word.
|
*/
|
*/
|
|
|
if ((argc + 1) > NUM_ARGS) {
|
if ((argc + 1) > NUM_ARGS) {
|
objv = (Tcl_Obj **)
|
objv = (Tcl_Obj **)
|
ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
|
ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
|
}
|
}
|
|
|
for (i = 0; i < argc; i++) {
|
for (i = 0; i < argc; i++) {
|
length = strlen(argv[i]);
|
length = strlen(argv[i]);
|
TclNewObj(objPtr);
|
TclNewObj(objPtr);
|
TclInitStringRep(objPtr, argv[i], length);
|
TclInitStringRep(objPtr, argv[i], length);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
objv[i] = objPtr;
|
objv[i] = objPtr;
|
}
|
}
|
objv[argc] = 0;
|
objv[argc] = 0;
|
|
|
/*
|
/*
|
* Invoke the command's object-based Tcl_ObjCmdProc.
|
* Invoke the command's object-based Tcl_ObjCmdProc.
|
*/
|
*/
|
|
|
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
|
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
|
|
|
/*
|
/*
|
* Move the interpreter's object result to the string result,
|
* Move the interpreter's object result to the string result,
|
* then reset the object result.
|
* then reset the object result.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULL BYTES.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULL BYTES.
|
*/
|
*/
|
|
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
|
TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
|
|
/*
|
/*
|
* Decrement the ref counts for the argument objects created above,
|
* Decrement the ref counts for the argument objects created above,
|
* then free the objv array if malloc'ed storage was used.
|
* then free the objv array if malloc'ed storage was used.
|
*/
|
*/
|
|
|
for (i = 0; i < argc; i++) {
|
for (i = 0; i < argc; i++) {
|
objPtr = objv[i];
|
objPtr = objv[i];
|
Tcl_DecrRefCount(objPtr);
|
Tcl_DecrRefCount(objPtr);
|
}
|
}
|
if (objv != argStorage) {
|
if (objv != argStorage) {
|
ckfree((char *) objv);
|
ckfree((char *) objv);
|
}
|
}
|
return result;
|
return result;
|
#undef NUM_ARGS
|
#undef NUM_ARGS
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclRenameCommand --
|
* TclRenameCommand --
|
*
|
*
|
* Called to give an existing Tcl command a different name. Both the
|
* Called to give an existing Tcl command a different name. Both the
|
* old command name and the new command name can have "::" namespace
|
* old command name and the new command name can have "::" namespace
|
* qualifiers. If the new command has a different namespace context,
|
* qualifiers. If the new command has a different namespace context,
|
* the command will be moved to that namespace and will execute in
|
* the command will be moved to that namespace and will execute in
|
* the context of that new namespace.
|
* the context of that new namespace.
|
*
|
*
|
* If the new command name is NULL or the null string, the command is
|
* If the new command name is NULL or the null string, the command is
|
* deleted.
|
* deleted.
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
|
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If anything goes wrong, an error message is returned in the
|
* If anything goes wrong, an error message is returned in the
|
* interpreter's result object.
|
* interpreter's result object.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclRenameCommand(interp, oldName, newName)
|
TclRenameCommand(interp, oldName, newName)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
char *oldName; /* Existing command name. */
|
char *oldName; /* Existing command name. */
|
char *newName; /* New command name. */
|
char *newName; /* New command name. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
char *newTail;
|
char *newTail;
|
Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
|
Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
|
Tcl_Command cmd;
|
Tcl_Command cmd;
|
Command *cmdPtr;
|
Command *cmdPtr;
|
Tcl_HashEntry *hPtr, *oldHPtr;
|
Tcl_HashEntry *hPtr, *oldHPtr;
|
int new, result;
|
int new, result;
|
|
|
/*
|
/*
|
* Find the existing command. An error is returned if cmdName can't
|
* Find the existing command. An error is returned if cmdName can't
|
* be found.
|
* be found.
|
*/
|
*/
|
|
|
cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,
|
cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,
|
/*flags*/ 0);
|
/*flags*/ 0);
|
cmdPtr = (Command *) cmd;
|
cmdPtr = (Command *) cmd;
|
if (cmdPtr == NULL) {
|
if (cmdPtr == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",
|
((newName == NULL)||(*newName == '\0'))? "delete":"rename",
|
((newName == NULL)||(*newName == '\0'))? "delete":"rename",
|
" \"", oldName, "\": command doesn't exist", (char *) NULL);
|
" \"", oldName, "\": command doesn't exist", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
cmdNsPtr = cmdPtr->nsPtr;
|
cmdNsPtr = cmdPtr->nsPtr;
|
|
|
/*
|
/*
|
* If the new command name is NULL or empty, delete the command. Do this
|
* If the new command name is NULL or empty, delete the command. Do this
|
* with Tcl_DeleteCommandFromToken, since we already have the command.
|
* with Tcl_DeleteCommandFromToken, since we already have the command.
|
*/
|
*/
|
|
|
if ((newName == NULL) || (*newName == '\0')) {
|
if ((newName == NULL) || (*newName == '\0')) {
|
Tcl_DeleteCommandFromToken(interp, cmd);
|
Tcl_DeleteCommandFromToken(interp, cmd);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure that the destination command does not already exist.
|
* Make sure that the destination command does not already exist.
|
* The rename operation is like creating a command, so we should
|
* The rename operation is like creating a command, so we should
|
* automatically create the containing namespaces just like
|
* automatically create the containing namespaces just like
|
* Tcl_CreateCommand would.
|
* Tcl_CreateCommand would.
|
*/
|
*/
|
|
|
result = TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,
|
result = TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,
|
(CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
|
(CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
|
&newNsPtr, &dummy1, &dummy2, &newTail);
|
&newNsPtr, &dummy1, &dummy2, &newTail);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
if ((newNsPtr == NULL) || (newTail == NULL)) {
|
if ((newNsPtr == NULL) || (newTail == NULL)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"can't rename to \"", newName, "\": bad command name",
|
"can't rename to \"", newName, "\": bad command name",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
|
if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"can't rename to \"", newName,
|
"can't rename to \"", newName,
|
"\": command already exists", (char *) NULL);
|
"\": command already exists", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* Warning: any changes done in the code here are likely
|
* Warning: any changes done in the code here are likely
|
* to be needed in Tcl_HideCommand() code too.
|
* to be needed in Tcl_HideCommand() code too.
|
* (until the common parts are extracted out) --dl
|
* (until the common parts are extracted out) --dl
|
*/
|
*/
|
|
|
/*
|
/*
|
* Put the command in the new namespace so we can check for an alias
|
* Put the command in the new namespace so we can check for an alias
|
* loop. Since we are adding a new command to a namespace, we must
|
* loop. Since we are adding a new command to a namespace, we must
|
* handle any shadowing of the global commands that this might create.
|
* handle any shadowing of the global commands that this might create.
|
*/
|
*/
|
|
|
oldHPtr = cmdPtr->hPtr;
|
oldHPtr = cmdPtr->hPtr;
|
hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);
|
hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);
|
Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
|
Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
|
cmdPtr->hPtr = hPtr;
|
cmdPtr->hPtr = hPtr;
|
cmdPtr->nsPtr = newNsPtr;
|
cmdPtr->nsPtr = newNsPtr;
|
TclResetShadowedCmdRefs(interp, cmdPtr);
|
TclResetShadowedCmdRefs(interp, cmdPtr);
|
|
|
/*
|
/*
|
* Now check for an alias loop. If we detect one, put everything back
|
* Now check for an alias loop. If we detect one, put everything back
|
* the way it was and report the error.
|
* the way it was and report the error.
|
*/
|
*/
|
|
|
result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
|
result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
cmdPtr->hPtr = oldHPtr;
|
cmdPtr->hPtr = oldHPtr;
|
cmdPtr->nsPtr = cmdNsPtr;
|
cmdPtr->nsPtr = cmdNsPtr;
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
* The new command name is okay, so remove the command from its
|
* The new command name is okay, so remove the command from its
|
* current namespace. This is like deleting the command, so bump
|
* current namespace. This is like deleting the command, so bump
|
* the cmdEpoch to invalidate any cached references to the command.
|
* the cmdEpoch to invalidate any cached references to the command.
|
*/
|
*/
|
|
|
Tcl_DeleteHashEntry(oldHPtr);
|
Tcl_DeleteHashEntry(oldHPtr);
|
cmdPtr->cmdEpoch++;
|
cmdPtr->cmdEpoch++;
|
|
|
/*
|
/*
|
* If the command being renamed has a compile procedure, increment the
|
* If the command being renamed has a compile procedure, increment the
|
* interpreter's compileEpoch to invalidate its compiled code. This
|
* interpreter's compileEpoch to invalidate its compiled code. This
|
* makes sure that we don't later try to execute old code compiled for
|
* makes sure that we don't later try to execute old code compiled for
|
* the now-renamed command.
|
* the now-renamed command.
|
*/
|
*/
|
|
|
if (cmdPtr->compileProc != NULL) {
|
if (cmdPtr->compileProc != NULL) {
|
iPtr->compileEpoch++;
|
iPtr->compileEpoch++;
|
}
|
}
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SetCommandInfo --
|
* Tcl_SetCommandInfo --
|
*
|
*
|
* Modifies various information about a Tcl command. Note that
|
* Modifies various information about a Tcl command. Note that
|
* this procedure will not change a command's namespace; use
|
* this procedure will not change a command's namespace; use
|
* Tcl_RenameCommand to do that. Also, the isNativeObjectProc
|
* Tcl_RenameCommand to do that. Also, the isNativeObjectProc
|
* member of *infoPtr is ignored.
|
* member of *infoPtr is ignored.
|
*
|
*
|
* Results:
|
* Results:
|
* If cmdName exists in interp, then the information at *infoPtr
|
* If cmdName exists in interp, then the information at *infoPtr
|
* is stored with the command in place of the current information
|
* is stored with the command in place of the current information
|
* and 1 is returned. If the command doesn't exist then 0 is
|
* and 1 is returned. If the command doesn't exist then 0 is
|
* returned.
|
* returned.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_SetCommandInfo(interp, cmdName, infoPtr)
|
Tcl_SetCommandInfo(interp, cmdName, infoPtr)
|
Tcl_Interp *interp; /* Interpreter in which to look
|
Tcl_Interp *interp; /* Interpreter in which to look
|
* for command. */
|
* for command. */
|
char *cmdName; /* Name of desired command. */
|
char *cmdName; /* Name of desired command. */
|
Tcl_CmdInfo *infoPtr; /* Where to store information about
|
Tcl_CmdInfo *infoPtr; /* Where to store information about
|
* command. */
|
* command. */
|
{
|
{
|
Tcl_Command cmd;
|
Tcl_Command cmd;
|
Command *cmdPtr;
|
Command *cmdPtr;
|
|
|
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
|
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
|
/*flags*/ 0);
|
/*flags*/ 0);
|
if (cmd == (Tcl_Command) NULL) {
|
if (cmd == (Tcl_Command) NULL) {
|
return 0;
|
return 0;
|
}
|
}
|
|
|
/*
|
/*
|
* The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
|
* The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
|
*/
|
*/
|
|
|
cmdPtr = (Command *) cmd;
|
cmdPtr = (Command *) cmd;
|
cmdPtr->proc = infoPtr->proc;
|
cmdPtr->proc = infoPtr->proc;
|
cmdPtr->clientData = infoPtr->clientData;
|
cmdPtr->clientData = infoPtr->clientData;
|
if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
|
if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
|
cmdPtr->objProc = TclInvokeStringCommand;
|
cmdPtr->objProc = TclInvokeStringCommand;
|
cmdPtr->objClientData = (ClientData) cmdPtr;
|
cmdPtr->objClientData = (ClientData) cmdPtr;
|
} else {
|
} else {
|
cmdPtr->objProc = infoPtr->objProc;
|
cmdPtr->objProc = infoPtr->objProc;
|
cmdPtr->objClientData = infoPtr->objClientData;
|
cmdPtr->objClientData = infoPtr->objClientData;
|
}
|
}
|
cmdPtr->deleteProc = infoPtr->deleteProc;
|
cmdPtr->deleteProc = infoPtr->deleteProc;
|
cmdPtr->deleteData = infoPtr->deleteData;
|
cmdPtr->deleteData = infoPtr->deleteData;
|
return 1;
|
return 1;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetCommandInfo --
|
* Tcl_GetCommandInfo --
|
*
|
*
|
* Returns various information about a Tcl command.
|
* Returns various information about a Tcl command.
|
*
|
*
|
* Results:
|
* Results:
|
* If cmdName exists in interp, then *infoPtr is modified to
|
* If cmdName exists in interp, then *infoPtr is modified to
|
* hold information about cmdName and 1 is returned. If the
|
* hold information about cmdName and 1 is returned. If the
|
* command doesn't exist then 0 is returned and *infoPtr isn't
|
* command doesn't exist then 0 is returned and *infoPtr isn't
|
* modified.
|
* modified.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_GetCommandInfo(interp, cmdName, infoPtr)
|
Tcl_GetCommandInfo(interp, cmdName, infoPtr)
|
Tcl_Interp *interp; /* Interpreter in which to look
|
Tcl_Interp *interp; /* Interpreter in which to look
|
* for command. */
|
* for command. */
|
char *cmdName; /* Name of desired command. */
|
char *cmdName; /* Name of desired command. */
|
Tcl_CmdInfo *infoPtr; /* Where to store information about
|
Tcl_CmdInfo *infoPtr; /* Where to store information about
|
* command. */
|
* command. */
|
{
|
{
|
Tcl_Command cmd;
|
Tcl_Command cmd;
|
Command *cmdPtr;
|
Command *cmdPtr;
|
|
|
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
|
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
|
/*flags*/ 0);
|
/*flags*/ 0);
|
if (cmd == (Tcl_Command) NULL) {
|
if (cmd == (Tcl_Command) NULL) {
|
return 0;
|
return 0;
|
}
|
}
|
|
|
/*
|
/*
|
* Set isNativeObjectProc 1 if objProc was registered by a call to
|
* Set isNativeObjectProc 1 if objProc was registered by a call to
|
* Tcl_CreateObjCommand. Otherwise set it to 0.
|
* Tcl_CreateObjCommand. Otherwise set it to 0.
|
*/
|
*/
|
|
|
cmdPtr = (Command *) cmd;
|
cmdPtr = (Command *) cmd;
|
infoPtr->isNativeObjectProc =
|
infoPtr->isNativeObjectProc =
|
(cmdPtr->objProc != TclInvokeStringCommand);
|
(cmdPtr->objProc != TclInvokeStringCommand);
|
infoPtr->objProc = cmdPtr->objProc;
|
infoPtr->objProc = cmdPtr->objProc;
|
infoPtr->objClientData = cmdPtr->objClientData;
|
infoPtr->objClientData = cmdPtr->objClientData;
|
infoPtr->proc = cmdPtr->proc;
|
infoPtr->proc = cmdPtr->proc;
|
infoPtr->clientData = cmdPtr->clientData;
|
infoPtr->clientData = cmdPtr->clientData;
|
infoPtr->deleteProc = cmdPtr->deleteProc;
|
infoPtr->deleteProc = cmdPtr->deleteProc;
|
infoPtr->deleteData = cmdPtr->deleteData;
|
infoPtr->deleteData = cmdPtr->deleteData;
|
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
|
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
|
return 1;
|
return 1;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetCommandName --
|
* Tcl_GetCommandName --
|
*
|
*
|
* Given a token returned by Tcl_CreateCommand, this procedure
|
* Given a token returned by Tcl_CreateCommand, this procedure
|
* returns the current name of the command (which may have changed
|
* returns the current name of the command (which may have changed
|
* due to renaming).
|
* due to renaming).
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is the name of the given command.
|
* The return value is the name of the given command.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
char *
|
char *
|
Tcl_GetCommandName(interp, command)
|
Tcl_GetCommandName(interp, command)
|
Tcl_Interp *interp; /* Interpreter containing the command. */
|
Tcl_Interp *interp; /* Interpreter containing the command. */
|
Tcl_Command command; /* Token for command returned by a previous
|
Tcl_Command command; /* Token for command returned by a previous
|
* call to Tcl_CreateCommand. The command
|
* call to Tcl_CreateCommand. The command
|
* must not have been deleted. */
|
* must not have been deleted. */
|
{
|
{
|
Command *cmdPtr = (Command *) command;
|
Command *cmdPtr = (Command *) command;
|
|
|
if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
|
if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
|
|
|
/*
|
/*
|
* This should only happen if command was "created" after the
|
* This should only happen if command was "created" after the
|
* interpreter began to be deleted, so there isn't really any
|
* interpreter began to be deleted, so there isn't really any
|
* command. Just return an empty string.
|
* command. Just return an empty string.
|
*/
|
*/
|
|
|
return "";
|
return "";
|
}
|
}
|
return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
|
return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetCommandFullName --
|
* Tcl_GetCommandFullName --
|
*
|
*
|
* Given a token returned by, e.g., Tcl_CreateCommand or
|
* Given a token returned by, e.g., Tcl_CreateCommand or
|
* Tcl_FindCommand, this procedure appends to an object the command's
|
* Tcl_FindCommand, this procedure appends to an object the command's
|
* full name, qualified by a sequence of parent namespace names. The
|
* full name, qualified by a sequence of parent namespace names. The
|
* command's fully-qualified name may have changed due to renaming.
|
* command's fully-qualified name may have changed due to renaming.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The command's fully-qualified name is appended to the string
|
* The command's fully-qualified name is appended to the string
|
* representation of objPtr.
|
* representation of objPtr.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_GetCommandFullName(interp, command, objPtr)
|
Tcl_GetCommandFullName(interp, command, objPtr)
|
Tcl_Interp *interp; /* Interpreter containing the command. */
|
Tcl_Interp *interp; /* Interpreter containing the command. */
|
Tcl_Command command; /* Token for command returned by a previous
|
Tcl_Command command; /* Token for command returned by a previous
|
* call to Tcl_CreateCommand. The command
|
* call to Tcl_CreateCommand. The command
|
* must not have been deleted. */
|
* must not have been deleted. */
|
Tcl_Obj *objPtr; /* Points to the object onto which the
|
Tcl_Obj *objPtr; /* Points to the object onto which the
|
* command's full name is appended. */
|
* command's full name is appended. */
|
|
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
register Command *cmdPtr = (Command *) command;
|
register Command *cmdPtr = (Command *) command;
|
char *name;
|
char *name;
|
|
|
/*
|
/*
|
* Add the full name of the containing namespace, followed by the "::"
|
* Add the full name of the containing namespace, followed by the "::"
|
* separator, and the command name.
|
* separator, and the command name.
|
*/
|
*/
|
|
|
if (cmdPtr != NULL) {
|
if (cmdPtr != NULL) {
|
if (cmdPtr->nsPtr != NULL) {
|
if (cmdPtr->nsPtr != NULL) {
|
Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
|
Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
|
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
|
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
|
Tcl_AppendToObj(objPtr, "::", 2);
|
Tcl_AppendToObj(objPtr, "::", 2);
|
}
|
}
|
}
|
}
|
if (cmdPtr->hPtr != NULL) {
|
if (cmdPtr->hPtr != NULL) {
|
name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
|
name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
|
Tcl_AppendToObj(objPtr, name, -1);
|
Tcl_AppendToObj(objPtr, name, -1);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DeleteCommand --
|
* Tcl_DeleteCommand --
|
*
|
*
|
* Remove the given command from the given interpreter.
|
* Remove the given command from the given interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* 0 is returned if the command was deleted successfully.
|
* 0 is returned if the command was deleted successfully.
|
* -1 is returned if there didn't exist a command by that name.
|
* -1 is returned if there didn't exist a command by that name.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* cmdName will no longer be recognized as a valid command for
|
* cmdName will no longer be recognized as a valid command for
|
* interp.
|
* interp.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_DeleteCommand(interp, cmdName)
|
Tcl_DeleteCommand(interp, cmdName)
|
Tcl_Interp *interp; /* Token for command interpreter (returned
|
Tcl_Interp *interp; /* Token for command interpreter (returned
|
* by a previous Tcl_CreateInterp call). */
|
* by a previous Tcl_CreateInterp call). */
|
char *cmdName; /* Name of command to remove. */
|
char *cmdName; /* Name of command to remove. */
|
{
|
{
|
Tcl_Command cmd;
|
Tcl_Command cmd;
|
|
|
/*
|
/*
|
* Find the desired command and delete it.
|
* Find the desired command and delete it.
|
*/
|
*/
|
|
|
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
|
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
|
/*flags*/ 0);
|
/*flags*/ 0);
|
if (cmd == (Tcl_Command) NULL) {
|
if (cmd == (Tcl_Command) NULL) {
|
return -1;
|
return -1;
|
}
|
}
|
return Tcl_DeleteCommandFromToken(interp, cmd);
|
return Tcl_DeleteCommandFromToken(interp, cmd);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DeleteCommandFromToken --
|
* Tcl_DeleteCommandFromToken --
|
*
|
*
|
* Removes the given command from the given interpreter. This procedure
|
* Removes the given command from the given interpreter. This procedure
|
* resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
|
* resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
|
* of a command name for efficiency.
|
* of a command name for efficiency.
|
*
|
*
|
* Results:
|
* Results:
|
* 0 is returned if the command was deleted successfully.
|
* 0 is returned if the command was deleted successfully.
|
* -1 is returned if there didn't exist a command by that name.
|
* -1 is returned if there didn't exist a command by that name.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The command specified by "cmd" will no longer be recognized as a
|
* The command specified by "cmd" will no longer be recognized as a
|
* valid command for "interp".
|
* valid command for "interp".
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_DeleteCommandFromToken(interp, cmd)
|
Tcl_DeleteCommandFromToken(interp, cmd)
|
Tcl_Interp *interp; /* Token for command interpreter returned by
|
Tcl_Interp *interp; /* Token for command interpreter returned by
|
* a previous call to Tcl_CreateInterp. */
|
* a previous call to Tcl_CreateInterp. */
|
Tcl_Command cmd; /* Token for command to delete. */
|
Tcl_Command cmd; /* Token for command to delete. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
Command *cmdPtr = (Command *) cmd;
|
Command *cmdPtr = (Command *) cmd;
|
ImportRef *refPtr, *nextRefPtr;
|
ImportRef *refPtr, *nextRefPtr;
|
Tcl_Command importCmd;
|
Tcl_Command importCmd;
|
|
|
/*
|
/*
|
* The code here is tricky. We can't delete the hash table entry
|
* The code here is tricky. We can't delete the hash table entry
|
* before invoking the deletion callback because there are cases
|
* before invoking the deletion callback because there are cases
|
* where the deletion callback needs to invoke the command (e.g.
|
* where the deletion callback needs to invoke the command (e.g.
|
* object systems such as OTcl). However, this means that the
|
* object systems such as OTcl). However, this means that the
|
* callback could try to delete or rename the command. The deleted
|
* callback could try to delete or rename the command. The deleted
|
* flag allows us to detect these cases and skip nested deletes.
|
* flag allows us to detect these cases and skip nested deletes.
|
*/
|
*/
|
|
|
if (cmdPtr->deleted) {
|
if (cmdPtr->deleted) {
|
/*
|
/*
|
* Another deletion is already in progress. Remove the hash
|
* Another deletion is already in progress. Remove the hash
|
* table entry now, but don't invoke a callback or free the
|
* table entry now, but don't invoke a callback or free the
|
* command structure.
|
* command structure.
|
*/
|
*/
|
|
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
cmdPtr->hPtr = NULL;
|
cmdPtr->hPtr = NULL;
|
return 0;
|
return 0;
|
}
|
}
|
|
|
/*
|
/*
|
* If the command being deleted has a compile procedure, increment the
|
* If the command being deleted has a compile procedure, increment the
|
* interpreter's compileEpoch to invalidate its compiled code. This
|
* interpreter's compileEpoch to invalidate its compiled code. This
|
* makes sure that we don't later try to execute old code compiled with
|
* makes sure that we don't later try to execute old code compiled with
|
* command-specific (i.e., inline) bytecodes for the now-deleted
|
* command-specific (i.e., inline) bytecodes for the now-deleted
|
* command. This field is checked in Tcl_EvalObj and ObjInterpProc, and
|
* command. This field is checked in Tcl_EvalObj and ObjInterpProc, and
|
* code whose compilation epoch doesn't match is recompiled.
|
* code whose compilation epoch doesn't match is recompiled.
|
*/
|
*/
|
|
|
if (cmdPtr->compileProc != NULL) {
|
if (cmdPtr->compileProc != NULL) {
|
iPtr->compileEpoch++;
|
iPtr->compileEpoch++;
|
}
|
}
|
|
|
cmdPtr->deleted = 1;
|
cmdPtr->deleted = 1;
|
if (cmdPtr->deleteProc != NULL) {
|
if (cmdPtr->deleteProc != NULL) {
|
/*
|
/*
|
* Delete the command's client data. If this was an imported command
|
* Delete the command's client data. If this was an imported command
|
* created when a command was imported into a namespace, this client
|
* created when a command was imported into a namespace, this client
|
* data will be a pointer to a ImportedCmdData structure describing
|
* data will be a pointer to a ImportedCmdData structure describing
|
* the "real" command that this imported command refers to.
|
* the "real" command that this imported command refers to.
|
*/
|
*/
|
|
|
(*cmdPtr->deleteProc)(cmdPtr->deleteData);
|
(*cmdPtr->deleteProc)(cmdPtr->deleteData);
|
}
|
}
|
|
|
/*
|
/*
|
* Bump the command epoch counter. This will invalidate all cached
|
* Bump the command epoch counter. This will invalidate all cached
|
* references that point to this command.
|
* references that point to this command.
|
*/
|
*/
|
|
|
cmdPtr->cmdEpoch++;
|
cmdPtr->cmdEpoch++;
|
|
|
/*
|
/*
|
* If this command was imported into other namespaces, then imported
|
* If this command was imported into other namespaces, then imported
|
* commands were created that refer back to this command. Delete these
|
* commands were created that refer back to this command. Delete these
|
* imported commands now.
|
* imported commands now.
|
*/
|
*/
|
|
|
for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
|
for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
|
refPtr = nextRefPtr) {
|
refPtr = nextRefPtr) {
|
nextRefPtr = refPtr->nextPtr;
|
nextRefPtr = refPtr->nextPtr;
|
importCmd = (Tcl_Command) refPtr->importedCmdPtr;
|
importCmd = (Tcl_Command) refPtr->importedCmdPtr;
|
Tcl_DeleteCommandFromToken(interp, importCmd);
|
Tcl_DeleteCommandFromToken(interp, importCmd);
|
}
|
}
|
|
|
/*
|
/*
|
* Don't use hPtr to delete the hash entry here, because it's
|
* Don't use hPtr to delete the hash entry here, because it's
|
* possible that the deletion callback renamed the command.
|
* possible that the deletion callback renamed the command.
|
* Instead, use cmdPtr->hptr, and make sure that no-one else
|
* Instead, use cmdPtr->hptr, and make sure that no-one else
|
* has already deleted the hash entry.
|
* has already deleted the hash entry.
|
*/
|
*/
|
|
|
if (cmdPtr->hPtr != NULL) {
|
if (cmdPtr->hPtr != NULL) {
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
Tcl_DeleteHashEntry(cmdPtr->hPtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Mark the Command structure as no longer valid. This allows
|
* Mark the Command structure as no longer valid. This allows
|
* TclExecuteByteCode to recognize when a Command has logically been
|
* TclExecuteByteCode to recognize when a Command has logically been
|
* deleted and a pointer to this Command structure cached in a CmdName
|
* deleted and a pointer to this Command structure cached in a CmdName
|
* object is invalid. TclExecuteByteCode will look up the command again
|
* object is invalid. TclExecuteByteCode will look up the command again
|
* in the interpreter's command hashtable.
|
* in the interpreter's command hashtable.
|
*/
|
*/
|
|
|
cmdPtr->objProc = NULL;
|
cmdPtr->objProc = NULL;
|
|
|
/*
|
/*
|
* Now free the Command structure, unless there is another reference to
|
* Now free the Command structure, unless there is another reference to
|
* it from a CmdName Tcl object in some ByteCode code sequence. In that
|
* it from a CmdName Tcl object in some ByteCode code sequence. In that
|
* case, delay the cleanup until all references are either discarded
|
* case, delay the cleanup until all references are either discarded
|
* (when a ByteCode is freed) or replaced by a new reference (when a
|
* (when a ByteCode is freed) or replaced by a new reference (when a
|
* cached CmdName Command reference is found to be invalid and
|
* cached CmdName Command reference is found to be invalid and
|
* TclExecuteByteCode looks up the command in the command hashtable).
|
* TclExecuteByteCode looks up the command in the command hashtable).
|
*/
|
*/
|
|
|
TclCleanupCommand(cmdPtr);
|
TclCleanupCommand(cmdPtr);
|
return 0;
|
return 0;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclCleanupCommand --
|
* TclCleanupCommand --
|
*
|
*
|
* This procedure frees up a Command structure unless it is still
|
* This procedure frees up a Command structure unless it is still
|
* referenced from an interpreter's command hashtable or from a CmdName
|
* referenced from an interpreter's command hashtable or from a CmdName
|
* Tcl object representing the name of a command in a ByteCode
|
* Tcl object representing the name of a command in a ByteCode
|
* instruction sequence.
|
* instruction sequence.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Memory gets freed unless a reference to the Command structure still
|
* Memory gets freed unless a reference to the Command structure still
|
* exists. In that case the cleanup is delayed until the command is
|
* exists. In that case the cleanup is delayed until the command is
|
* deleted or when the last ByteCode referring to it is freed.
|
* deleted or when the last ByteCode referring to it is freed.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
TclCleanupCommand(cmdPtr)
|
TclCleanupCommand(cmdPtr)
|
register Command *cmdPtr; /* Points to the Command structure to
|
register Command *cmdPtr; /* Points to the Command structure to
|
* be freed. */
|
* be freed. */
|
{
|
{
|
cmdPtr->refCount--;
|
cmdPtr->refCount--;
|
if (cmdPtr->refCount <= 0) {
|
if (cmdPtr->refCount <= 0) {
|
ckfree((char *) cmdPtr);
|
ckfree((char *) cmdPtr);
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_Eval --
|
* Tcl_Eval --
|
*
|
*
|
* Execute a Tcl command in a string.
|
* Execute a Tcl command in a string.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is one of the return codes defined in tcl.h
|
* The return value is one of the return codes defined in tcl.h
|
* (such as TCL_OK), and interp->result contains a string value
|
* (such as TCL_OK), and interp->result contains a string value
|
* to supplement the return code. The value of interp->result
|
* to supplement the return code. The value of interp->result
|
* will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
|
* will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
|
* you must copy it or lose it!
|
* you must copy it or lose it!
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The string is compiled to produce a ByteCode object that holds the
|
* The string is compiled to produce a ByteCode object that holds the
|
* command's bytecode instructions. However, this ByteCode object is
|
* command's bytecode instructions. However, this ByteCode object is
|
* lost after executing the command. The command's execution will
|
* lost after executing the command. The command's execution will
|
* almost certainly have side effects. interp->termOffset is set to the
|
* almost certainly have side effects. interp->termOffset is set to the
|
* offset of the character in "string" just after the last one
|
* offset of the character in "string" just after the last one
|
* successfully compiled or executed.
|
* successfully compiled or executed.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_Eval(interp, string)
|
Tcl_Eval(interp, string)
|
Tcl_Interp *interp; /* Token for command interpreter (returned
|
Tcl_Interp *interp; /* Token for command interpreter (returned
|
* by previous call to Tcl_CreateInterp). */
|
* by previous call to Tcl_CreateInterp). */
|
char *string; /* Pointer to TCL command to execute. */
|
char *string; /* Pointer to TCL command to execute. */
|
{
|
{
|
register Tcl_Obj *cmdPtr;
|
register Tcl_Obj *cmdPtr;
|
int length = strlen(string);
|
int length = strlen(string);
|
int result;
|
int result;
|
|
|
if (length > 0) {
|
if (length > 0) {
|
/*
|
/*
|
* Initialize a Tcl object from the command string.
|
* Initialize a Tcl object from the command string.
|
*/
|
*/
|
|
|
TclNewObj(cmdPtr);
|
TclNewObj(cmdPtr);
|
TclInitStringRep(cmdPtr, string, length);
|
TclInitStringRep(cmdPtr, string, length);
|
Tcl_IncrRefCount(cmdPtr);
|
Tcl_IncrRefCount(cmdPtr);
|
|
|
/*
|
/*
|
* Compile and execute the bytecodes.
|
* Compile and execute the bytecodes.
|
*/
|
*/
|
|
|
result = Tcl_EvalObj(interp, cmdPtr);
|
result = Tcl_EvalObj(interp, cmdPtr);
|
|
|
/*
|
/*
|
* Move the interpreter's object result to the string result,
|
* Move the interpreter's object result to the string result,
|
* then reset the object result.
|
* then reset the object result.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
|
*/
|
*/
|
|
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
|
TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
|
|
/*
|
/*
|
* Discard the Tcl object created to hold the command and its code.
|
* Discard the Tcl object created to hold the command and its code.
|
*/
|
*/
|
|
|
Tcl_DecrRefCount(cmdPtr);
|
Tcl_DecrRefCount(cmdPtr);
|
} else {
|
} else {
|
/*
|
/*
|
* An empty string. Just reset the interpreter's result.
|
* An empty string. Just reset the interpreter's result.
|
*/
|
*/
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
result = TCL_OK;
|
result = TCL_OK;
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_EvalObj --
|
* Tcl_EvalObj --
|
*
|
*
|
* Execute Tcl commands stored in a Tcl object. These commands are
|
* Execute Tcl commands stored in a Tcl object. These commands are
|
* compiled into bytecodes if necessary.
|
* compiled into bytecodes if necessary.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is one of the return codes defined in tcl.h
|
* The return value is one of the return codes defined in tcl.h
|
* (such as TCL_OK), and the interpreter's result contains a value
|
* (such as TCL_OK), and the interpreter's result contains a value
|
* to supplement the return code.
|
* to supplement the return code.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object is converted, if necessary, to a ByteCode object that
|
* The object is converted, if necessary, to a ByteCode object that
|
* holds the bytecode instructions for the commands. Executing the
|
* holds the bytecode instructions for the commands. Executing the
|
* commands will almost certainly have side effects that depend
|
* commands will almost certainly have side effects that depend
|
* on those commands.
|
* on those commands.
|
*
|
*
|
* Just as in Tcl_Eval, interp->termOffset is set to the offset of the
|
* Just as in Tcl_Eval, interp->termOffset is set to the offset of the
|
* last character executed in the objPtr's string.
|
* last character executed in the objPtr's string.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
#undef Tcl_EvalObj
|
#undef Tcl_EvalObj
|
|
|
int
|
int
|
Tcl_EvalObj(interp, objPtr)
|
Tcl_EvalObj(interp, objPtr)
|
Tcl_Interp *interp; /* Token for command interpreter
|
Tcl_Interp *interp; /* Token for command interpreter
|
* (returned by a previous call to
|
* (returned by a previous call to
|
* Tcl_CreateInterp). */
|
* Tcl_CreateInterp). */
|
Tcl_Obj *objPtr; /* Pointer to object containing
|
Tcl_Obj *objPtr; /* Pointer to object containing
|
* commands to execute. */
|
* commands to execute. */
|
{
|
{
|
register Interp *iPtr = (Interp *) interp;
|
register Interp *iPtr = (Interp *) interp;
|
int flags; /* Interp->evalFlags value when the
|
int flags; /* Interp->evalFlags value when the
|
* procedure was called. */
|
* procedure was called. */
|
register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
|
register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
|
int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
|
int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
|
* at all were executed. */
|
* at all were executed. */
|
int numSrcChars;
|
int numSrcChars;
|
register int result;
|
register int result;
|
Namespace *namespacePtr;
|
Namespace *namespacePtr;
|
|
|
/*
|
/*
|
* Reset both the interpreter's string and object results and clear out
|
* Reset both the interpreter's string and object results and clear out
|
* any error information. This makes sure that we return an empty
|
* any error information. This makes sure that we return an empty
|
* result if there are no commands in the command string.
|
* result if there are no commands in the command string.
|
*/
|
*/
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
|
|
/*
|
/*
|
* Check depth of nested calls to Tcl_Eval: if this gets too large,
|
* Check depth of nested calls to Tcl_Eval: if this gets too large,
|
* it's probably because of an infinite loop somewhere.
|
* it's probably because of an infinite loop somewhere.
|
*/
|
*/
|
|
|
iPtr->numLevels++;
|
iPtr->numLevels++;
|
if (iPtr->numLevels > iPtr->maxNestingDepth) {
|
if (iPtr->numLevels > iPtr->maxNestingDepth) {
|
iPtr->numLevels--;
|
iPtr->numLevels--;
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
"too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
|
"too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* On the Mac, we will never reach the default recursion limit before blowing
|
* On the Mac, we will never reach the default recursion limit before blowing
|
* the stack. So we need to do a check here.
|
* the stack. So we need to do a check here.
|
*/
|
*/
|
|
|
if (TclpCheckStackSpace() == 0) {
|
if (TclpCheckStackSpace() == 0) {
|
/*NOTREACHED*/
|
/*NOTREACHED*/
|
iPtr->numLevels--;
|
iPtr->numLevels--;
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
"too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
|
"too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If the interpreter has been deleted, return an error.
|
* If the interpreter has been deleted, return an error.
|
*/
|
*/
|
|
|
if (iPtr->flags & DELETED) {
|
if (iPtr->flags & DELETED) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
"attempt to call eval in deleted interpreter", -1);
|
"attempt to call eval in deleted interpreter", -1);
|
Tcl_SetErrorCode(interp, "CORE", "IDELETE",
|
Tcl_SetErrorCode(interp, "CORE", "IDELETE",
|
"attempt to call eval in deleted interpreter", (char *) NULL);
|
"attempt to call eval in deleted interpreter", (char *) NULL);
|
iPtr->numLevels--;
|
iPtr->numLevels--;
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Get the ByteCode from the object. If it exists, make sure it hasn't
|
* Get the ByteCode from the object. If it exists, make sure it hasn't
|
* been invalidated by, e.g., someone redefining a command with a
|
* been invalidated by, e.g., someone redefining a command with a
|
* compile procedure (this might make the compiled code wrong). If
|
* compile procedure (this might make the compiled code wrong). If
|
* necessary, convert the object to be a ByteCode object and compile it.
|
* necessary, convert the object to be a ByteCode object and compile it.
|
* Also, if the code was compiled in/for a different interpreter,
|
* Also, if the code was compiled in/for a different interpreter,
|
* or for a different namespace, or for the same namespace but
|
* or for a different namespace, or for the same namespace but
|
* with different name resolution rules, we recompile it.
|
* with different name resolution rules, we recompile it.
|
*
|
*
|
* Precompiled objects, however, are immutable and therefore
|
* Precompiled objects, however, are immutable and therefore
|
* they are not recompiled, even if the epoch has changed.
|
* they are not recompiled, even if the epoch has changed.
|
*/
|
*/
|
|
|
if (iPtr->varFramePtr != NULL) {
|
if (iPtr->varFramePtr != NULL) {
|
namespacePtr = iPtr->varFramePtr->nsPtr;
|
namespacePtr = iPtr->varFramePtr->nsPtr;
|
} else {
|
} else {
|
namespacePtr = iPtr->globalNsPtr;
|
namespacePtr = iPtr->globalNsPtr;
|
}
|
}
|
|
|
if (objPtr->typePtr == &tclByteCodeType) {
|
if (objPtr->typePtr == &tclByteCodeType) {
|
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
|
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
|
|
|
if ((codePtr->iPtr != iPtr)
|
if ((codePtr->iPtr != iPtr)
|
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|
|| (codePtr->nsPtr != namespacePtr)
|
|| (codePtr->nsPtr != namespacePtr)
|
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
|
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
|
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
|
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
|
if (codePtr->iPtr != iPtr) {
|
if (codePtr->iPtr != iPtr) {
|
panic("Tcl_EvalObj: compiled script jumped interps");
|
panic("Tcl_EvalObj: compiled script jumped interps");
|
}
|
}
|
codePtr->compileEpoch = iPtr->compileEpoch;
|
codePtr->compileEpoch = iPtr->compileEpoch;
|
} else {
|
} else {
|
tclByteCodeType.freeIntRepProc(objPtr);
|
tclByteCodeType.freeIntRepProc(objPtr);
|
}
|
}
|
}
|
}
|
}
|
}
|
if (objPtr->typePtr != &tclByteCodeType) {
|
if (objPtr->typePtr != &tclByteCodeType) {
|
/*
|
/*
|
* First reset any error line number information.
|
* First reset any error line number information.
|
*/
|
*/
|
|
|
iPtr->errorLine = 1; /* no correct line # information yet */
|
iPtr->errorLine = 1; /* no correct line # information yet */
|
result = tclByteCodeType.setFromAnyProc(interp, objPtr);
|
result = tclByteCodeType.setFromAnyProc(interp, objPtr);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
iPtr->numLevels--;
|
iPtr->numLevels--;
|
return result;
|
return result;
|
}
|
}
|
}
|
}
|
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
|
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
|
|
|
/*
|
/*
|
* Extract then reset the compilation flags in the interpreter.
|
* Extract then reset the compilation flags in the interpreter.
|
* Resetting the flags must be done after any compilation.
|
* Resetting the flags must be done after any compilation.
|
*/
|
*/
|
|
|
flags = iPtr->evalFlags;
|
flags = iPtr->evalFlags;
|
iPtr->evalFlags = 0;
|
iPtr->evalFlags = 0;
|
|
|
/*
|
/*
|
* Execute the commands. If the code was compiled from an empty string,
|
* Execute the commands. If the code was compiled from an empty string,
|
* don't bother executing the code.
|
* don't bother executing the code.
|
*/
|
*/
|
|
|
numSrcChars = codePtr->numSrcChars;
|
numSrcChars = codePtr->numSrcChars;
|
if ((numSrcChars > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
|
if ((numSrcChars > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
|
/*
|
/*
|
* Increment the code's ref count while it is being executed. If
|
* Increment the code's ref count while it is being executed. If
|
* afterwards no references to it remain, free the code.
|
* afterwards no references to it remain, free the code.
|
*/
|
*/
|
|
|
codePtr->refCount++;
|
codePtr->refCount++;
|
result = TclExecuteByteCode(interp, codePtr);
|
result = TclExecuteByteCode(interp, codePtr);
|
codePtr->refCount--;
|
codePtr->refCount--;
|
if (codePtr->refCount <= 0) {
|
if (codePtr->refCount <= 0) {
|
TclCleanupByteCode(codePtr);
|
TclCleanupByteCode(codePtr);
|
}
|
}
|
} else {
|
} else {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
result = TCL_OK;
|
result = TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* If no commands at all were executed, check for asynchronous
|
* If no commands at all were executed, check for asynchronous
|
* handlers so that they at least get one change to execute.
|
* handlers so that they at least get one change to execute.
|
* This is needed to handle event loops written in Tcl with
|
* This is needed to handle event loops written in Tcl with
|
* empty bodies.
|
* empty bodies.
|
*/
|
*/
|
|
|
if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) {
|
if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) {
|
result = Tcl_AsyncInvoke(interp, result);
|
result = Tcl_AsyncInvoke(interp, result);
|
}
|
}
|
|
|
/*
|
/*
|
* Free up any extra resources that were allocated.
|
* Free up any extra resources that were allocated.
|
*/
|
*/
|
|
|
iPtr->numLevels--;
|
iPtr->numLevels--;
|
if (iPtr->numLevels == 0) {
|
if (iPtr->numLevels == 0) {
|
if (result == TCL_RETURN) {
|
if (result == TCL_RETURN) {
|
result = TclUpdateReturnInfo(iPtr);
|
result = TclUpdateReturnInfo(iPtr);
|
}
|
}
|
if ((result != TCL_OK) && (result != TCL_ERROR)
|
if ((result != TCL_OK) && (result != TCL_ERROR)
|
&& !(flags & TCL_ALLOW_EXCEPTIONS)) {
|
&& !(flags & TCL_ALLOW_EXCEPTIONS)) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
if (result == TCL_BREAK) {
|
if (result == TCL_BREAK) {
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
"invoked \"break\" outside of a loop", -1);
|
"invoked \"break\" outside of a loop", -1);
|
} else if (result == TCL_CONTINUE) {
|
} else if (result == TCL_CONTINUE) {
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
"invoked \"continue\" outside of a loop", -1);
|
"invoked \"continue\" outside of a loop", -1);
|
} else {
|
} else {
|
char buf[50];
|
char buf[50];
|
sprintf(buf, "command returned bad code: %d", result);
|
sprintf(buf, "command returned bad code: %d", result);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
|
}
|
}
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* If an error occurred, record information about what was being
|
* If an error occurred, record information about what was being
|
* executed when the error occurred.
|
* executed when the error occurred.
|
*/
|
*/
|
|
|
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
char buf[200];
|
char buf[200];
|
char *ellipsis = "";
|
char *ellipsis = "";
|
char *bytes;
|
char *bytes;
|
int length;
|
int length;
|
|
|
/*
|
/*
|
* Figure out how much of the command to print in the error
|
* Figure out how much of the command to print in the error
|
* message (up to a certain number of characters, or up to
|
* message (up to a certain number of characters, or up to
|
* the first new-line).
|
* the first new-line).
|
* THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL.
|
* THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL.
|
*/
|
*/
|
|
|
bytes = Tcl_GetStringFromObj(objPtr, &length);
|
bytes = Tcl_GetStringFromObj(objPtr, &length);
|
length = TclMin(numSrcChars, length);
|
length = TclMin(numSrcChars, length);
|
if (length > 150) {
|
if (length > 150) {
|
length = 150;
|
length = 150;
|
ellipsis = " ...";
|
ellipsis = " ...";
|
}
|
}
|
|
|
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
|
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
|
sprintf(buf, "\n while executing\n\"%.*s%s\"",
|
sprintf(buf, "\n while executing\n\"%.*s%s\"",
|
length, bytes, ellipsis);
|
length, bytes, ellipsis);
|
} else {
|
} else {
|
sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
|
sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
|
length, bytes, ellipsis);
|
length, bytes, ellipsis);
|
}
|
}
|
Tcl_AddObjErrorInfo(interp, buf, -1);
|
Tcl_AddObjErrorInfo(interp, buf, -1);
|
}
|
}
|
|
|
/*
|
/*
|
* Set the interpreter's termOffset member to the offset of the
|
* Set the interpreter's termOffset member to the offset of the
|
* character just after the last one executed. We approximate the offset
|
* character just after the last one executed. We approximate the offset
|
* of the last character executed by using the number of characters
|
* of the last character executed by using the number of characters
|
* compiled.
|
* compiled.
|
*/
|
*/
|
|
|
iPtr->termOffset = numSrcChars;
|
iPtr->termOffset = numSrcChars;
|
iPtr->flags &= ~ERR_ALREADY_LOGGED;
|
iPtr->flags &= ~ERR_ALREADY_LOGGED;
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*
|
*
|
* Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
|
* Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
|
*
|
*
|
* Procedures to evaluate an expression and return its value in a
|
* Procedures to evaluate an expression and return its value in a
|
* particular form.
|
* particular form.
|
*
|
*
|
* Results:
|
* Results:
|
* Each of the procedures below returns a standard Tcl result. If an
|
* Each of the procedures below returns a standard Tcl result. If an
|
* error occurs then an error message is left in interp->result.
|
* error occurs then an error message is left in interp->result.
|
* Otherwise the value of the expression, in the appropriate form, is
|
* Otherwise the value of the expression, in the appropriate form, is
|
* stored at *ptr. If the expression had a result that was
|
* stored at *ptr. If the expression had a result that was
|
* incompatible with the desired form then an error is returned.
|
* incompatible with the desired form then an error is returned.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_ExprLong(interp, string, ptr)
|
Tcl_ExprLong(interp, string, ptr)
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
* expression. */
|
* expression. */
|
char *string; /* Expression to evaluate. */
|
char *string; /* Expression to evaluate. */
|
long *ptr; /* Where to store result. */
|
long *ptr; /* Where to store result. */
|
{
|
{
|
register Tcl_Obj *exprPtr;
|
register Tcl_Obj *exprPtr;
|
Tcl_Obj *resultPtr;
|
Tcl_Obj *resultPtr;
|
int length = strlen(string);
|
int length = strlen(string);
|
int result = TCL_OK;
|
int result = TCL_OK;
|
|
|
if (length > 0) {
|
if (length > 0) {
|
exprPtr = Tcl_NewStringObj(string, length);
|
exprPtr = Tcl_NewStringObj(string, length);
|
Tcl_IncrRefCount(exprPtr);
|
Tcl_IncrRefCount(exprPtr);
|
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
|
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
/*
|
/*
|
* Store an integer based on the expression result.
|
* Store an integer based on the expression result.
|
*/
|
*/
|
|
|
if (resultPtr->typePtr == &tclIntType) {
|
if (resultPtr->typePtr == &tclIntType) {
|
*ptr = resultPtr->internalRep.longValue;
|
*ptr = resultPtr->internalRep.longValue;
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
*ptr = (long) resultPtr->internalRep.doubleValue;
|
*ptr = (long) resultPtr->internalRep.doubleValue;
|
} else {
|
} else {
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
"expression didn't have numeric value", TCL_STATIC);
|
"expression didn't have numeric value", TCL_STATIC);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
}
|
}
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
} else {
|
} else {
|
/*
|
/*
|
* Move the interpreter's object result to the string result,
|
* Move the interpreter's object result to the string result,
|
* then reset the object result.
|
* then reset the object result.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
|
*/
|
*/
|
|
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
TclGetStringFromObj(Tcl_GetObjResult(interp),
|
TclGetStringFromObj(Tcl_GetObjResult(interp),
|
(int *) NULL),
|
(int *) NULL),
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
}
|
}
|
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
|
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
|
} else {
|
} else {
|
/*
|
/*
|
* An empty string. Just set the result integer to 0.
|
* An empty string. Just set the result integer to 0.
|
*/
|
*/
|
|
|
*ptr = 0;
|
*ptr = 0;
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
int
|
int
|
Tcl_ExprDouble(interp, string, ptr)
|
Tcl_ExprDouble(interp, string, ptr)
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
* expression. */
|
* expression. */
|
char *string; /* Expression to evaluate. */
|
char *string; /* Expression to evaluate. */
|
double *ptr; /* Where to store result. */
|
double *ptr; /* Where to store result. */
|
{
|
{
|
register Tcl_Obj *exprPtr;
|
register Tcl_Obj *exprPtr;
|
Tcl_Obj *resultPtr;
|
Tcl_Obj *resultPtr;
|
int length = strlen(string);
|
int length = strlen(string);
|
int result = TCL_OK;
|
int result = TCL_OK;
|
|
|
if (length > 0) {
|
if (length > 0) {
|
exprPtr = Tcl_NewStringObj(string, length);
|
exprPtr = Tcl_NewStringObj(string, length);
|
Tcl_IncrRefCount(exprPtr);
|
Tcl_IncrRefCount(exprPtr);
|
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
|
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
/*
|
/*
|
* Store a double based on the expression result.
|
* Store a double based on the expression result.
|
*/
|
*/
|
|
|
if (resultPtr->typePtr == &tclIntType) {
|
if (resultPtr->typePtr == &tclIntType) {
|
*ptr = (double) resultPtr->internalRep.longValue;
|
*ptr = (double) resultPtr->internalRep.longValue;
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
*ptr = resultPtr->internalRep.doubleValue;
|
*ptr = resultPtr->internalRep.doubleValue;
|
} else {
|
} else {
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
"expression didn't have numeric value", TCL_STATIC);
|
"expression didn't have numeric value", TCL_STATIC);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
}
|
}
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
} else {
|
} else {
|
/*
|
/*
|
* Move the interpreter's object result to the string result,
|
* Move the interpreter's object result to the string result,
|
* then reset the object result.
|
* then reset the object result.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
|
*/
|
*/
|
|
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
TclGetStringFromObj(Tcl_GetObjResult(interp),
|
TclGetStringFromObj(Tcl_GetObjResult(interp),
|
(int *) NULL),
|
(int *) NULL),
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
}
|
}
|
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
|
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
|
} else {
|
} else {
|
/*
|
/*
|
* An empty string. Just set the result double to 0.0.
|
* An empty string. Just set the result double to 0.0.
|
*/
|
*/
|
|
|
*ptr = 0.0;
|
*ptr = 0.0;
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
int
|
int
|
Tcl_ExprBoolean(interp, string, ptr)
|
Tcl_ExprBoolean(interp, string, ptr)
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
* expression. */
|
* expression. */
|
char *string; /* Expression to evaluate. */
|
char *string; /* Expression to evaluate. */
|
int *ptr; /* Where to store 0/1 result. */
|
int *ptr; /* Where to store 0/1 result. */
|
{
|
{
|
register Tcl_Obj *exprPtr;
|
register Tcl_Obj *exprPtr;
|
Tcl_Obj *resultPtr;
|
Tcl_Obj *resultPtr;
|
int length = strlen(string);
|
int length = strlen(string);
|
int result = TCL_OK;
|
int result = TCL_OK;
|
|
|
if (length > 0) {
|
if (length > 0) {
|
exprPtr = Tcl_NewStringObj(string, length);
|
exprPtr = Tcl_NewStringObj(string, length);
|
Tcl_IncrRefCount(exprPtr);
|
Tcl_IncrRefCount(exprPtr);
|
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
|
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
/*
|
/*
|
* Store a boolean based on the expression result.
|
* Store a boolean based on the expression result.
|
*/
|
*/
|
|
|
if (resultPtr->typePtr == &tclIntType) {
|
if (resultPtr->typePtr == &tclIntType) {
|
*ptr = (resultPtr->internalRep.longValue != 0);
|
*ptr = (resultPtr->internalRep.longValue != 0);
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
*ptr = (resultPtr->internalRep.doubleValue != 0.0);
|
*ptr = (resultPtr->internalRep.doubleValue != 0.0);
|
} else {
|
} else {
|
result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
|
result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
|
}
|
}
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
}
|
}
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
/*
|
/*
|
* Move the interpreter's object result to the string result,
|
* Move the interpreter's object result to the string result,
|
* then reset the object result.
|
* then reset the object result.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
|
*/
|
*/
|
|
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
TclGetStringFromObj(Tcl_GetObjResult(interp),
|
TclGetStringFromObj(Tcl_GetObjResult(interp),
|
(int *) NULL),
|
(int *) NULL),
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
}
|
}
|
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
|
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
|
} else {
|
} else {
|
/*
|
/*
|
* An empty string. Just set the result boolean to 0 (false).
|
* An empty string. Just set the result boolean to 0 (false).
|
*/
|
*/
|
|
|
*ptr = 0;
|
*ptr = 0;
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*
|
*
|
* Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
|
* Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
|
*
|
*
|
* Procedures to evaluate an expression in an object and return its
|
* Procedures to evaluate an expression in an object and return its
|
* value in a particular form.
|
* value in a particular form.
|
*
|
*
|
* Results:
|
* Results:
|
* Each of the procedures below returns a standard Tcl result
|
* Each of the procedures below returns a standard Tcl result
|
* object. If an error occurs then an error message is left in the
|
* object. If an error occurs then an error message is left in the
|
* interpreter's result. Otherwise the value of the expression, in the
|
* interpreter's result. Otherwise the value of the expression, in the
|
* appropriate form, is stored at *ptr. If the expression had a result
|
* appropriate form, is stored at *ptr. If the expression had a result
|
* that was incompatible with the desired form then an error is
|
* that was incompatible with the desired form then an error is
|
* returned.
|
* returned.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_ExprLongObj(interp, objPtr, ptr)
|
Tcl_ExprLongObj(interp, objPtr, ptr)
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
* expression. */
|
* expression. */
|
register Tcl_Obj *objPtr; /* Expression to evaluate. */
|
register Tcl_Obj *objPtr; /* Expression to evaluate. */
|
long *ptr; /* Where to store long result. */
|
long *ptr; /* Where to store long result. */
|
{
|
{
|
Tcl_Obj *resultPtr;
|
Tcl_Obj *resultPtr;
|
int result;
|
int result;
|
|
|
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
|
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
if (resultPtr->typePtr == &tclIntType) {
|
if (resultPtr->typePtr == &tclIntType) {
|
*ptr = resultPtr->internalRep.longValue;
|
*ptr = resultPtr->internalRep.longValue;
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
*ptr = (long) resultPtr->internalRep.doubleValue;
|
*ptr = (long) resultPtr->internalRep.doubleValue;
|
} else {
|
} else {
|
result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
|
result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
}
|
}
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
int
|
int
|
Tcl_ExprDoubleObj(interp, objPtr, ptr)
|
Tcl_ExprDoubleObj(interp, objPtr, ptr)
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
* expression. */
|
* expression. */
|
register Tcl_Obj *objPtr; /* Expression to evaluate. */
|
register Tcl_Obj *objPtr; /* Expression to evaluate. */
|
double *ptr; /* Where to store double result. */
|
double *ptr; /* Where to store double result. */
|
{
|
{
|
Tcl_Obj *resultPtr;
|
Tcl_Obj *resultPtr;
|
int result;
|
int result;
|
|
|
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
|
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
if (resultPtr->typePtr == &tclIntType) {
|
if (resultPtr->typePtr == &tclIntType) {
|
*ptr = (double) resultPtr->internalRep.longValue;
|
*ptr = (double) resultPtr->internalRep.longValue;
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
*ptr = resultPtr->internalRep.doubleValue;
|
*ptr = resultPtr->internalRep.doubleValue;
|
} else {
|
} else {
|
result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
|
result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
}
|
}
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
int
|
int
|
Tcl_ExprBooleanObj(interp, objPtr, ptr)
|
Tcl_ExprBooleanObj(interp, objPtr, ptr)
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
* expression. */
|
* expression. */
|
register Tcl_Obj *objPtr; /* Expression to evaluate. */
|
register Tcl_Obj *objPtr; /* Expression to evaluate. */
|
int *ptr; /* Where to store 0/1 result. */
|
int *ptr; /* Where to store 0/1 result. */
|
{
|
{
|
Tcl_Obj *resultPtr;
|
Tcl_Obj *resultPtr;
|
int result;
|
int result;
|
|
|
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
|
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
if (resultPtr->typePtr == &tclIntType) {
|
if (resultPtr->typePtr == &tclIntType) {
|
*ptr = (resultPtr->internalRep.longValue != 0);
|
*ptr = (resultPtr->internalRep.longValue != 0);
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
*ptr = (resultPtr->internalRep.doubleValue != 0.0);
|
*ptr = (resultPtr->internalRep.doubleValue != 0.0);
|
} else {
|
} else {
|
result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
|
result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
}
|
}
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclInvoke --
|
* TclInvoke --
|
*
|
*
|
* Invokes a Tcl command, given an argv/argc, from either the
|
* Invokes a Tcl command, given an argv/argc, from either the
|
* exposed or the hidden sets of commands in the given interpreter.
|
* exposed or the hidden sets of commands in the given interpreter.
|
* NOTE: The command is invoked in the current stack frame of
|
* NOTE: The command is invoked in the current stack frame of
|
* the interpreter, thus it can modify local variables.
|
* the interpreter, thus it can modify local variables.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Whatever the command does.
|
* Whatever the command does.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclInvoke(interp, argc, argv, flags)
|
TclInvoke(interp, argc, argv, flags)
|
Tcl_Interp *interp; /* Where to invoke the command. */
|
Tcl_Interp *interp; /* Where to invoke the command. */
|
int argc; /* Count of args. */
|
int argc; /* Count of args. */
|
register char **argv; /* The arg strings; argv[0] is the name of
|
register char **argv; /* The arg strings; argv[0] is the name of
|
* the command to invoke. */
|
* the command to invoke. */
|
int flags; /* Combination of flags controlling the
|
int flags; /* Combination of flags controlling the
|
* call: TCL_INVOKE_HIDDEN and
|
* call: TCL_INVOKE_HIDDEN and
|
* TCL_INVOKE_NO_UNKNOWN. */
|
* TCL_INVOKE_NO_UNKNOWN. */
|
{
|
{
|
register Tcl_Obj *objPtr;
|
register Tcl_Obj *objPtr;
|
register int i;
|
register int i;
|
int length, result;
|
int length, result;
|
|
|
/*
|
/*
|
* This procedure generates an objv array for object arguments that hold
|
* This procedure generates an objv array for object arguments that hold
|
* the argv strings. It starts out with stack-allocated space but uses
|
* the argv strings. It starts out with stack-allocated space but uses
|
* dynamically-allocated storage if needed.
|
* dynamically-allocated storage if needed.
|
*/
|
*/
|
|
|
#define NUM_ARGS 20
|
#define NUM_ARGS 20
|
Tcl_Obj *(objStorage[NUM_ARGS]);
|
Tcl_Obj *(objStorage[NUM_ARGS]);
|
register Tcl_Obj **objv = objStorage;
|
register Tcl_Obj **objv = objStorage;
|
|
|
/*
|
/*
|
* Create the object argument array "objv". Make sure objv is large
|
* Create the object argument array "objv". Make sure objv is large
|
* enough to hold the objc arguments plus 1 extra for the zero
|
* enough to hold the objc arguments plus 1 extra for the zero
|
* end-of-objv word.
|
* end-of-objv word.
|
*/
|
*/
|
|
|
if ((argc + 1) > NUM_ARGS) {
|
if ((argc + 1) > NUM_ARGS) {
|
objv = (Tcl_Obj **)
|
objv = (Tcl_Obj **)
|
ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
|
ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
|
}
|
}
|
|
|
for (i = 0; i < argc; i++) {
|
for (i = 0; i < argc; i++) {
|
length = strlen(argv[i]);
|
length = strlen(argv[i]);
|
objv[i] = Tcl_NewStringObj(argv[i], length);
|
objv[i] = Tcl_NewStringObj(argv[i], length);
|
Tcl_IncrRefCount(objv[i]);
|
Tcl_IncrRefCount(objv[i]);
|
}
|
}
|
objv[argc] = 0;
|
objv[argc] = 0;
|
|
|
/*
|
/*
|
* Use TclObjInterpProc to actually invoke the command.
|
* Use TclObjInterpProc to actually invoke the command.
|
*/
|
*/
|
|
|
result = TclObjInvoke(interp, argc, objv, flags);
|
result = TclObjInvoke(interp, argc, objv, flags);
|
|
|
/*
|
/*
|
* Move the interpreter's object result to the string result,
|
* Move the interpreter's object result to the string result,
|
* then reset the object result.
|
* then reset the object result.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
|
*/
|
*/
|
|
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
|
TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
|
|
/*
|
/*
|
* Decrement the ref counts on the objv elements since we are done
|
* Decrement the ref counts on the objv elements since we are done
|
* with them.
|
* with them.
|
*/
|
*/
|
|
|
for (i = 0; i < argc; i++) {
|
for (i = 0; i < argc; i++) {
|
objPtr = objv[i];
|
objPtr = objv[i];
|
Tcl_DecrRefCount(objPtr);
|
Tcl_DecrRefCount(objPtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Free the objv array if malloc'ed storage was used.
|
* Free the objv array if malloc'ed storage was used.
|
*/
|
*/
|
|
|
if (objv != objStorage) {
|
if (objv != objStorage) {
|
ckfree((char *) objv);
|
ckfree((char *) objv);
|
}
|
}
|
return result;
|
return result;
|
#undef NUM_ARGS
|
#undef NUM_ARGS
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclGlobalInvoke --
|
* TclGlobalInvoke --
|
*
|
*
|
* Invokes a Tcl command, given an argv/argc, from either the
|
* Invokes a Tcl command, given an argv/argc, from either the
|
* exposed or hidden sets of commands in the given interpreter.
|
* exposed or hidden sets of commands in the given interpreter.
|
* NOTE: The command is invoked in the global stack frame of
|
* NOTE: The command is invoked in the global stack frame of
|
* the interpreter, thus it cannot see any current state on
|
* the interpreter, thus it cannot see any current state on
|
* the stack for that interpreter.
|
* the stack for that interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Whatever the command does.
|
* Whatever the command does.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclGlobalInvoke(interp, argc, argv, flags)
|
TclGlobalInvoke(interp, argc, argv, flags)
|
Tcl_Interp *interp; /* Where to invoke the command. */
|
Tcl_Interp *interp; /* Where to invoke the command. */
|
int argc; /* Count of args. */
|
int argc; /* Count of args. */
|
register char **argv; /* The arg strings; argv[0] is the name of
|
register char **argv; /* The arg strings; argv[0] is the name of
|
* the command to invoke. */
|
* the command to invoke. */
|
int flags; /* Combination of flags controlling the
|
int flags; /* Combination of flags controlling the
|
* call: TCL_INVOKE_HIDDEN and
|
* call: TCL_INVOKE_HIDDEN and
|
* TCL_INVOKE_NO_UNKNOWN. */
|
* TCL_INVOKE_NO_UNKNOWN. */
|
{
|
{
|
register Interp *iPtr = (Interp *) interp;
|
register Interp *iPtr = (Interp *) interp;
|
int result;
|
int result;
|
CallFrame *savedVarFramePtr;
|
CallFrame *savedVarFramePtr;
|
|
|
savedVarFramePtr = iPtr->varFramePtr;
|
savedVarFramePtr = iPtr->varFramePtr;
|
iPtr->varFramePtr = NULL;
|
iPtr->varFramePtr = NULL;
|
result = TclInvoke(interp, argc, argv, flags);
|
result = TclInvoke(interp, argc, argv, flags);
|
iPtr->varFramePtr = savedVarFramePtr;
|
iPtr->varFramePtr = savedVarFramePtr;
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclObjInvokeGlobal --
|
* TclObjInvokeGlobal --
|
*
|
*
|
* Object version: Invokes a Tcl command, given an objv/objc, from
|
* Object version: Invokes a Tcl command, given an objv/objc, from
|
* either the exposed or hidden set of commands in the given
|
* either the exposed or hidden set of commands in the given
|
* interpreter.
|
* interpreter.
|
* NOTE: The command is invoked in the global stack frame of the
|
* NOTE: The command is invoked in the global stack frame of the
|
* interpreter, thus it cannot see any current state on the
|
* interpreter, thus it cannot see any current state on the
|
* stack of that interpreter.
|
* stack of that interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Whatever the command does.
|
* Whatever the command does.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclObjInvokeGlobal(interp, objc, objv, flags)
|
TclObjInvokeGlobal(interp, objc, objv, flags)
|
Tcl_Interp *interp; /* Interpreter in which command is
|
Tcl_Interp *interp; /* Interpreter in which command is
|
* to be invoked. */
|
* to be invoked. */
|
int objc; /* Count of arguments. */
|
int objc; /* Count of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0]
|
Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0]
|
* points to the name of the
|
* points to the name of the
|
* command to invoke. */
|
* command to invoke. */
|
int flags; /* Combination of flags controlling
|
int flags; /* Combination of flags controlling
|
* the call: TCL_INVOKE_HIDDEN and
|
* the call: TCL_INVOKE_HIDDEN and
|
* TCL_INVOKE_NO_UNKNOWN. */
|
* TCL_INVOKE_NO_UNKNOWN. */
|
{
|
{
|
register Interp *iPtr = (Interp *) interp;
|
register Interp *iPtr = (Interp *) interp;
|
int result;
|
int result;
|
CallFrame *savedVarFramePtr;
|
CallFrame *savedVarFramePtr;
|
|
|
savedVarFramePtr = iPtr->varFramePtr;
|
savedVarFramePtr = iPtr->varFramePtr;
|
iPtr->varFramePtr = NULL;
|
iPtr->varFramePtr = NULL;
|
result = TclObjInvoke(interp, objc, objv, flags);
|
result = TclObjInvoke(interp, objc, objv, flags);
|
iPtr->varFramePtr = savedVarFramePtr;
|
iPtr->varFramePtr = savedVarFramePtr;
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclObjInvoke --
|
* TclObjInvoke --
|
*
|
*
|
* Invokes a Tcl command, given an objv/objc, from either the
|
* Invokes a Tcl command, given an objv/objc, from either the
|
* exposed or the hidden sets of commands in the given interpreter.
|
* exposed or the hidden sets of commands in the given interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl object result.
|
* A standard Tcl object result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Whatever the command does.
|
* Whatever the command does.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclObjInvoke(interp, objc, objv, flags)
|
TclObjInvoke(interp, objc, objv, flags)
|
Tcl_Interp *interp; /* Interpreter in which command is
|
Tcl_Interp *interp; /* Interpreter in which command is
|
* to be invoked. */
|
* to be invoked. */
|
int objc; /* Count of arguments. */
|
int objc; /* Count of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0]
|
Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0]
|
* points to the name of the
|
* points to the name of the
|
* command to invoke. */
|
* command to invoke. */
|
int flags; /* Combination of flags controlling
|
int flags; /* Combination of flags controlling
|
* the call: TCL_INVOKE_HIDDEN and
|
* the call: TCL_INVOKE_HIDDEN and
|
* TCL_INVOKE_NO_UNKNOWN. */
|
* TCL_INVOKE_NO_UNKNOWN. */
|
{
|
{
|
register Interp *iPtr = (Interp *) interp;
|
register Interp *iPtr = (Interp *) interp;
|
Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
|
Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
|
char *cmdName; /* Name of the command from objv[0]. */
|
char *cmdName; /* Name of the command from objv[0]. */
|
register Tcl_HashEntry *hPtr;
|
register Tcl_HashEntry *hPtr;
|
Tcl_Command cmd;
|
Tcl_Command cmd;
|
Command *cmdPtr;
|
Command *cmdPtr;
|
int localObjc; /* Used to invoke "unknown" if the */
|
int localObjc; /* Used to invoke "unknown" if the */
|
Tcl_Obj **localObjv = NULL; /* command is not found. */
|
Tcl_Obj **localObjv = NULL; /* command is not found. */
|
register int i;
|
register int i;
|
int length, result;
|
int length, result;
|
char *bytes;
|
char *bytes;
|
|
|
if (interp == (Tcl_Interp *) NULL) {
|
if (interp == (Tcl_Interp *) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) {
|
if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) {
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
"illegal argument vector", -1);
|
"illegal argument vector", -1);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* THE FOLLOWING CODE FAILS IF THE STRING REP CONTAINS NULLS.
|
* THE FOLLOWING CODE FAILS IF THE STRING REP CONTAINS NULLS.
|
*/
|
*/
|
|
|
cmdName = Tcl_GetStringFromObj(objv[0], (int *) NULL);
|
cmdName = Tcl_GetStringFromObj(objv[0], (int *) NULL);
|
if (flags & TCL_INVOKE_HIDDEN) {
|
if (flags & TCL_INVOKE_HIDDEN) {
|
/*
|
/*
|
* Find the table of hidden commands; error out if none.
|
* Find the table of hidden commands; error out if none.
|
*/
|
*/
|
|
|
hTblPtr = (Tcl_HashTable *)
|
hTblPtr = (Tcl_HashTable *)
|
Tcl_GetAssocData(interp, "tclHiddenCmds", NULL);
|
Tcl_GetAssocData(interp, "tclHiddenCmds", NULL);
|
if (hTblPtr == (Tcl_HashTable *) NULL) {
|
if (hTblPtr == (Tcl_HashTable *) NULL) {
|
badhiddenCmdToken:
|
badhiddenCmdToken:
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"invalid hidden command name \"", cmdName, "\"",
|
"invalid hidden command name \"", cmdName, "\"",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
|
hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
|
|
|
/*
|
/*
|
* We never invoke "unknown" for hidden commands.
|
* We never invoke "unknown" for hidden commands.
|
*/
|
*/
|
|
|
if (hPtr == NULL) {
|
if (hPtr == NULL) {
|
goto badhiddenCmdToken;
|
goto badhiddenCmdToken;
|
}
|
}
|
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
|
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
|
} else {
|
} else {
|
cmdPtr = NULL;
|
cmdPtr = NULL;
|
cmd = Tcl_FindCommand(interp, cmdName,
|
cmd = Tcl_FindCommand(interp, cmdName,
|
(Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
|
(Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
|
if (cmd != (Tcl_Command) NULL) {
|
if (cmd != (Tcl_Command) NULL) {
|
cmdPtr = (Command *) cmd;
|
cmdPtr = (Command *) cmd;
|
}
|
}
|
if (cmdPtr == NULL) {
|
if (cmdPtr == NULL) {
|
if (!(flags & TCL_INVOKE_NO_UNKNOWN)) {
|
if (!(flags & TCL_INVOKE_NO_UNKNOWN)) {
|
cmd = Tcl_FindCommand(interp, "unknown",
|
cmd = Tcl_FindCommand(interp, "unknown",
|
(Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
|
(Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
|
if (cmd != (Tcl_Command) NULL) {
|
if (cmd != (Tcl_Command) NULL) {
|
cmdPtr = (Command *) cmd;
|
cmdPtr = (Command *) cmd;
|
}
|
}
|
if (cmdPtr != NULL) {
|
if (cmdPtr != NULL) {
|
localObjc = (objc + 1);
|
localObjc = (objc + 1);
|
localObjv = (Tcl_Obj **)
|
localObjv = (Tcl_Obj **)
|
ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc));
|
ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc));
|
localObjv[0] = Tcl_NewStringObj("unknown", -1);
|
localObjv[0] = Tcl_NewStringObj("unknown", -1);
|
Tcl_IncrRefCount(localObjv[0]);
|
Tcl_IncrRefCount(localObjv[0]);
|
for (i = 0; i < objc; i++) {
|
for (i = 0; i < objc; i++) {
|
localObjv[i+1] = objv[i];
|
localObjv[i+1] = objv[i];
|
}
|
}
|
objc = localObjc;
|
objc = localObjc;
|
objv = localObjv;
|
objv = localObjv;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Check again if we found the command. If not, "unknown" is
|
* Check again if we found the command. If not, "unknown" is
|
* not present and we cannot help, or the caller said not to
|
* not present and we cannot help, or the caller said not to
|
* call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN).
|
* call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN).
|
*/
|
*/
|
|
|
if (cmdPtr == NULL) {
|
if (cmdPtr == NULL) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"invalid command name \"", cmdName, "\"",
|
"invalid command name \"", cmdName, "\"",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Invoke the command procedure. First reset the interpreter's string
|
* Invoke the command procedure. First reset the interpreter's string
|
* and object results to their default empty values since they could
|
* and object results to their default empty values since they could
|
* have gotten changed by earlier invocations.
|
* have gotten changed by earlier invocations.
|
*/
|
*/
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
iPtr->cmdCount++;
|
iPtr->cmdCount++;
|
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
|
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
|
|
|
/*
|
/*
|
* If an error occurred, record information about what was being
|
* If an error occurred, record information about what was being
|
* executed when the error occurred.
|
* executed when the error occurred.
|
*/
|
*/
|
|
|
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
|
Tcl_DString ds;
|
Tcl_DString ds;
|
|
|
Tcl_DStringInit(&ds);
|
Tcl_DStringInit(&ds);
|
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
|
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
|
Tcl_DStringAppend(&ds, "\n while invoking\n\"", -1);
|
Tcl_DStringAppend(&ds, "\n while invoking\n\"", -1);
|
} else {
|
} else {
|
Tcl_DStringAppend(&ds, "\n invoked from within\n\"", -1);
|
Tcl_DStringAppend(&ds, "\n invoked from within\n\"", -1);
|
}
|
}
|
for (i = 0; i < objc; i++) {
|
for (i = 0; i < objc; i++) {
|
bytes = Tcl_GetStringFromObj(objv[i], &length);
|
bytes = Tcl_GetStringFromObj(objv[i], &length);
|
Tcl_DStringAppend(&ds, bytes, length);
|
Tcl_DStringAppend(&ds, bytes, length);
|
if (i < (objc - 1)) {
|
if (i < (objc - 1)) {
|
Tcl_DStringAppend(&ds, " ", -1);
|
Tcl_DStringAppend(&ds, " ", -1);
|
} else if (Tcl_DStringLength(&ds) > 100) {
|
} else if (Tcl_DStringLength(&ds) > 100) {
|
Tcl_DStringSetLength(&ds, 100);
|
Tcl_DStringSetLength(&ds, 100);
|
Tcl_DStringAppend(&ds, "...", -1);
|
Tcl_DStringAppend(&ds, "...", -1);
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
Tcl_DStringAppend(&ds, "\"", -1);
|
Tcl_DStringAppend(&ds, "\"", -1);
|
Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&ds), -1);
|
Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&ds), -1);
|
Tcl_DStringFree(&ds);
|
Tcl_DStringFree(&ds);
|
iPtr->flags &= ~ERR_ALREADY_LOGGED;
|
iPtr->flags &= ~ERR_ALREADY_LOGGED;
|
}
|
}
|
|
|
/*
|
/*
|
* Free any locally allocated storage used to call "unknown".
|
* Free any locally allocated storage used to call "unknown".
|
*/
|
*/
|
|
|
if (localObjv != (Tcl_Obj **) NULL) {
|
if (localObjv != (Tcl_Obj **) NULL) {
|
ckfree((char *) localObjv);
|
ckfree((char *) localObjv);
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*
|
*
|
* Tcl_ExprString --
|
* Tcl_ExprString --
|
*
|
*
|
* Evaluate an expression in a string and return its value in string
|
* Evaluate an expression in a string and return its value in string
|
* form.
|
* form.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result. If the result is TCL_OK, then the
|
* A standard Tcl result. If the result is TCL_OK, then the
|
* interpreter's result is set to the string value of the
|
* interpreter's result is set to the string value of the
|
* expression. If the result is TCL_OK, then interp->result
|
* expression. If the result is TCL_OK, then interp->result
|
* contains an error message.
|
* contains an error message.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* A Tcl object is allocated to hold a copy of the expression string.
|
* A Tcl object is allocated to hold a copy of the expression string.
|
* This expression object is passed to Tcl_ExprObj and then
|
* This expression object is passed to Tcl_ExprObj and then
|
* deallocated.
|
* deallocated.
|
*
|
*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_ExprString(interp, string)
|
Tcl_ExprString(interp, string)
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
* expression. */
|
* expression. */
|
char *string; /* Expression to evaluate. */
|
char *string; /* Expression to evaluate. */
|
{
|
{
|
register Tcl_Obj *exprPtr;
|
register Tcl_Obj *exprPtr;
|
Tcl_Obj *resultPtr;
|
Tcl_Obj *resultPtr;
|
int length = strlen(string);
|
int length = strlen(string);
|
char buf[100];
|
char buf[100];
|
int result = TCL_OK;
|
int result = TCL_OK;
|
|
|
if (length > 0) {
|
if (length > 0) {
|
TclNewObj(exprPtr);
|
TclNewObj(exprPtr);
|
TclInitStringRep(exprPtr, string, length);
|
TclInitStringRep(exprPtr, string, length);
|
Tcl_IncrRefCount(exprPtr);
|
Tcl_IncrRefCount(exprPtr);
|
|
|
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
|
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
/*
|
/*
|
* Set the interpreter's string result from the result object.
|
* Set the interpreter's string result from the result object.
|
*/
|
*/
|
|
|
if (resultPtr->typePtr == &tclIntType) {
|
if (resultPtr->typePtr == &tclIntType) {
|
sprintf(buf, "%ld", resultPtr->internalRep.longValue);
|
sprintf(buf, "%ld", resultPtr->internalRep.longValue);
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
} else if (resultPtr->typePtr == &tclDoubleType) {
|
Tcl_PrintDouble((Tcl_Interp *) NULL,
|
Tcl_PrintDouble((Tcl_Interp *) NULL,
|
resultPtr->internalRep.doubleValue, buf);
|
resultPtr->internalRep.doubleValue, buf);
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
} else {
|
} else {
|
/*
|
/*
|
* Set interpreter's string result from the result object.
|
* Set interpreter's string result from the result object.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
|
*/
|
*/
|
|
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
TclGetStringFromObj(resultPtr, (int *) NULL),
|
TclGetStringFromObj(resultPtr, (int *) NULL),
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
}
|
}
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
Tcl_DecrRefCount(resultPtr); /* discard the result object */
|
} else {
|
} else {
|
/*
|
/*
|
* Move the interpreter's object result to the string result,
|
* Move the interpreter's object result to the string result,
|
* then reset the object result.
|
* then reset the object result.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
|
*/
|
*/
|
|
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
TclGetStringFromObj(Tcl_GetObjResult(interp),
|
TclGetStringFromObj(Tcl_GetObjResult(interp),
|
(int *) NULL),
|
(int *) NULL),
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
}
|
}
|
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
|
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
|
} else {
|
} else {
|
/*
|
/*
|
* An empty string. Just set the interpreter's result to 0.
|
* An empty string. Just set the interpreter's result to 0.
|
*/
|
*/
|
|
|
Tcl_SetResult(interp, "0", TCL_VOLATILE);
|
Tcl_SetResult(interp, "0", TCL_VOLATILE);
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*
|
*
|
* Tcl_ExprObj --
|
* Tcl_ExprObj --
|
*
|
*
|
* Evaluate an expression in a Tcl_Obj.
|
* Evaluate an expression in a Tcl_Obj.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl object result. If the result is other than TCL_OK,
|
* A standard Tcl object result. If the result is other than TCL_OK,
|
* then the interpreter's result contains an error message. If the
|
* then the interpreter's result contains an error message. If the
|
* result is TCL_OK, then a pointer to the expression's result value
|
* result is TCL_OK, then a pointer to the expression's result value
|
* object is stored in resultPtrPtr. In that case, the object's ref
|
* object is stored in resultPtrPtr. In that case, the object's ref
|
* count is incremented to reflect the reference returned to the
|
* count is incremented to reflect the reference returned to the
|
* caller; the caller is then responsible for the resulting object
|
* caller; the caller is then responsible for the resulting object
|
* and must, for example, decrement the ref count when it is finished
|
* and must, for example, decrement the ref count when it is finished
|
* with the object.
|
* with the object.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Any side effects caused by subcommands in the expression, if any.
|
* Any side effects caused by subcommands in the expression, if any.
|
* The interpreter result is not modified unless there is an error.
|
* The interpreter result is not modified unless there is an error.
|
*
|
*
|
*--------------------------------------------------------------
|
*--------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_ExprObj(interp, objPtr, resultPtrPtr)
|
Tcl_ExprObj(interp, objPtr, resultPtrPtr)
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
Tcl_Interp *interp; /* Context in which to evaluate the
|
* expression. */
|
* expression. */
|
register Tcl_Obj *objPtr; /* Points to Tcl object containing
|
register Tcl_Obj *objPtr; /* Points to Tcl object containing
|
* expression to evaluate. */
|
* expression to evaluate. */
|
Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression
|
Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression
|
* result is stored if no errors occur. */
|
* result is stored if no errors occur. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
CompileEnv compEnv; /* Compilation environment structure
|
CompileEnv compEnv; /* Compilation environment structure
|
* allocated in frame. */
|
* allocated in frame. */
|
register ByteCode *codePtr = NULL;
|
register ByteCode *codePtr = NULL;
|
/* Tcl Internal type of bytecode.
|
/* Tcl Internal type of bytecode.
|
* Initialized to avoid compiler warning. */
|
* Initialized to avoid compiler warning. */
|
AuxData *auxDataPtr;
|
AuxData *auxDataPtr;
|
Interp dummy;
|
Interp dummy;
|
Tcl_Obj *saveObjPtr;
|
Tcl_Obj *saveObjPtr;
|
char *string;
|
char *string;
|
int result;
|
int result;
|
int i;
|
int i;
|
|
|
/*
|
/*
|
* Get the ByteCode from the object. If it exists, make sure it hasn't
|
* Get the ByteCode from the object. If it exists, make sure it hasn't
|
* been invalidated by, e.g., someone redefining a command with a
|
* been invalidated by, e.g., someone redefining a command with a
|
* compile procedure (this might make the compiled code wrong). If
|
* compile procedure (this might make the compiled code wrong). If
|
* necessary, convert the object to be a ByteCode object and compile it.
|
* necessary, convert the object to be a ByteCode object and compile it.
|
* Also, if the code was compiled in/for a different interpreter, we
|
* Also, if the code was compiled in/for a different interpreter, we
|
* recompile it.
|
* recompile it.
|
*
|
*
|
* Precompiled expressions, however, are immutable and therefore
|
* Precompiled expressions, however, are immutable and therefore
|
* they are not recompiled, even if the epoch has changed.
|
* they are not recompiled, even if the epoch has changed.
|
*
|
*
|
* THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE.
|
* THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE.
|
*/
|
*/
|
|
|
if (objPtr->typePtr == &tclByteCodeType) {
|
if (objPtr->typePtr == &tclByteCodeType) {
|
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
|
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
|
if ((codePtr->iPtr != iPtr)
|
if ((codePtr->iPtr != iPtr)
|
|| (codePtr->compileEpoch != iPtr->compileEpoch)) {
|
|| (codePtr->compileEpoch != iPtr->compileEpoch)) {
|
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
|
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
|
if (codePtr->iPtr != iPtr) {
|
if (codePtr->iPtr != iPtr) {
|
panic("Tcl_ExprObj: compiled expression jumped interps");
|
panic("Tcl_ExprObj: compiled expression jumped interps");
|
}
|
}
|
codePtr->compileEpoch = iPtr->compileEpoch;
|
codePtr->compileEpoch = iPtr->compileEpoch;
|
} else {
|
} else {
|
tclByteCodeType.freeIntRepProc(objPtr);
|
tclByteCodeType.freeIntRepProc(objPtr);
|
objPtr->typePtr = (Tcl_ObjType *) NULL;
|
objPtr->typePtr = (Tcl_ObjType *) NULL;
|
}
|
}
|
}
|
}
|
}
|
}
|
if (objPtr->typePtr != &tclByteCodeType) {
|
if (objPtr->typePtr != &tclByteCodeType) {
|
int length;
|
int length;
|
string = Tcl_GetStringFromObj(objPtr, &length);
|
string = Tcl_GetStringFromObj(objPtr, &length);
|
TclInitCompileEnv(interp, &compEnv, string);
|
TclInitCompileEnv(interp, &compEnv, string);
|
result = TclCompileExpr(interp, string, string + length,
|
result = TclCompileExpr(interp, string, string + length,
|
/*flags*/ 0, &compEnv);
|
/*flags*/ 0, &compEnv);
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
/*
|
/*
|
* If the expression yielded no instructions (e.g., was empty),
|
* If the expression yielded no instructions (e.g., was empty),
|
* push an integer zero object as the expressions's result.
|
* push an integer zero object as the expressions's result.
|
*/
|
*/
|
|
|
if (compEnv.codeNext == NULL) {
|
if (compEnv.codeNext == NULL) {
|
int objIndex = TclObjIndexForString("0", 0,
|
int objIndex = TclObjIndexForString("0", 0,
|
/*allocStrRep*/ 0, /*inHeap*/ 0, &compEnv);
|
/*allocStrRep*/ 0, /*inHeap*/ 0, &compEnv);
|
Tcl_Obj *objPtr = compEnv.objArrayPtr[objIndex];
|
Tcl_Obj *objPtr = compEnv.objArrayPtr[objIndex];
|
|
|
Tcl_InvalidateStringRep(objPtr);
|
Tcl_InvalidateStringRep(objPtr);
|
objPtr->internalRep.longValue = 0;
|
objPtr->internalRep.longValue = 0;
|
objPtr->typePtr = &tclIntType;
|
objPtr->typePtr = &tclIntType;
|
|
|
TclEmitPush(objIndex, &compEnv);
|
TclEmitPush(objIndex, &compEnv);
|
}
|
}
|
|
|
/*
|
/*
|
* Add done instruction at the end of the instruction sequence.
|
* Add done instruction at the end of the instruction sequence.
|
*/
|
*/
|
|
|
TclEmitOpcode(INST_DONE, &compEnv);
|
TclEmitOpcode(INST_DONE, &compEnv);
|
|
|
TclInitByteCodeObj(objPtr, &compEnv);
|
TclInitByteCodeObj(objPtr, &compEnv);
|
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
|
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
|
if (tclTraceCompile == 2) {
|
if (tclTraceCompile == 2) {
|
TclPrintByteCodeObj(interp, objPtr);
|
TclPrintByteCodeObj(interp, objPtr);
|
}
|
}
|
TclFreeCompileEnv(&compEnv);
|
TclFreeCompileEnv(&compEnv);
|
} else {
|
} else {
|
/*
|
/*
|
* Compilation errors. Decrement the ref counts on any objects
|
* Compilation errors. Decrement the ref counts on any objects
|
* in the object array before freeing the compilation
|
* in the object array before freeing the compilation
|
* environment.
|
* environment.
|
*/
|
*/
|
|
|
for (i = 0; i < compEnv.objArrayNext; i++) {
|
for (i = 0; i < compEnv.objArrayNext; i++) {
|
Tcl_Obj *elemPtr = compEnv.objArrayPtr[i];
|
Tcl_Obj *elemPtr = compEnv.objArrayPtr[i];
|
Tcl_DecrRefCount(elemPtr);
|
Tcl_DecrRefCount(elemPtr);
|
}
|
}
|
|
|
auxDataPtr = compEnv.auxDataArrayPtr;
|
auxDataPtr = compEnv.auxDataArrayPtr;
|
for (i = 0; i < compEnv.auxDataArrayNext; i++) {
|
for (i = 0; i < compEnv.auxDataArrayNext; i++) {
|
if (auxDataPtr->type->freeProc != NULL) {
|
if (auxDataPtr->type->freeProc != NULL) {
|
auxDataPtr->type->freeProc(auxDataPtr->clientData);
|
auxDataPtr->type->freeProc(auxDataPtr->clientData);
|
}
|
}
|
auxDataPtr++;
|
auxDataPtr++;
|
}
|
}
|
TclFreeCompileEnv(&compEnv);
|
TclFreeCompileEnv(&compEnv);
|
return result;
|
return result;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Execute the expression after first saving the interpreter's result.
|
* Execute the expression after first saving the interpreter's result.
|
*/
|
*/
|
|
|
dummy.objResultPtr = Tcl_NewObj();
|
dummy.objResultPtr = Tcl_NewObj();
|
Tcl_IncrRefCount(dummy.objResultPtr);
|
Tcl_IncrRefCount(dummy.objResultPtr);
|
if (interp->freeProc == 0) {
|
if (interp->freeProc == 0) {
|
dummy.freeProc = (Tcl_FreeProc *) 0;
|
dummy.freeProc = (Tcl_FreeProc *) 0;
|
dummy.result = "";
|
dummy.result = "";
|
Tcl_SetResult((Tcl_Interp *) &dummy, interp->result,
|
Tcl_SetResult((Tcl_Interp *) &dummy, interp->result,
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
} else {
|
} else {
|
dummy.freeProc = interp->freeProc;
|
dummy.freeProc = interp->freeProc;
|
dummy.result = interp->result;
|
dummy.result = interp->result;
|
interp->freeProc = (Tcl_FreeProc *) 0;
|
interp->freeProc = (Tcl_FreeProc *) 0;
|
}
|
}
|
|
|
saveObjPtr = Tcl_GetObjResult(interp);
|
saveObjPtr = Tcl_GetObjResult(interp);
|
Tcl_IncrRefCount(saveObjPtr);
|
Tcl_IncrRefCount(saveObjPtr);
|
|
|
/*
|
/*
|
* Increment the code's ref count while it is being executed. If
|
* Increment the code's ref count while it is being executed. If
|
* afterwards no references to it remain, free the code.
|
* afterwards no references to it remain, free the code.
|
*/
|
*/
|
|
|
codePtr->refCount++;
|
codePtr->refCount++;
|
result = TclExecuteByteCode(interp, codePtr);
|
result = TclExecuteByteCode(interp, codePtr);
|
codePtr->refCount--;
|
codePtr->refCount--;
|
if (codePtr->refCount <= 0) {
|
if (codePtr->refCount <= 0) {
|
TclCleanupByteCode(codePtr);
|
TclCleanupByteCode(codePtr);
|
}
|
}
|
|
|
/*
|
/*
|
* If the expression evaluated successfully, store a pointer to its
|
* If the expression evaluated successfully, store a pointer to its
|
* value object in resultPtrPtr then restore the old interpreter result.
|
* value object in resultPtrPtr then restore the old interpreter result.
|
* We increment the object's ref count to reflect the reference that we
|
* We increment the object's ref count to reflect the reference that we
|
* are returning to the caller. We also decrement the ref count of the
|
* are returning to the caller. We also decrement the ref count of the
|
* interpreter's result object after calling Tcl_SetResult since we
|
* interpreter's result object after calling Tcl_SetResult since we
|
* next store into that field directly.
|
* next store into that field directly.
|
*/
|
*/
|
|
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
*resultPtrPtr = iPtr->objResultPtr;
|
*resultPtrPtr = iPtr->objResultPtr;
|
Tcl_IncrRefCount(iPtr->objResultPtr);
|
Tcl_IncrRefCount(iPtr->objResultPtr);
|
|
|
Tcl_SetResult(interp, dummy.result,
|
Tcl_SetResult(interp, dummy.result,
|
((dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc));
|
((dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc));
|
Tcl_DecrRefCount(iPtr->objResultPtr);
|
Tcl_DecrRefCount(iPtr->objResultPtr);
|
iPtr->objResultPtr = saveObjPtr;
|
iPtr->objResultPtr = saveObjPtr;
|
} else {
|
} else {
|
Tcl_DecrRefCount(saveObjPtr);
|
Tcl_DecrRefCount(saveObjPtr);
|
Tcl_FreeResult((Tcl_Interp *) &dummy);
|
Tcl_FreeResult((Tcl_Interp *) &dummy);
|
}
|
}
|
|
|
Tcl_DecrRefCount(dummy.objResultPtr);
|
Tcl_DecrRefCount(dummy.objResultPtr);
|
dummy.objResultPtr = NULL;
|
dummy.objResultPtr = NULL;
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_CreateTrace --
|
* Tcl_CreateTrace --
|
*
|
*
|
* Arrange for a procedure to be called to trace command execution.
|
* Arrange for a procedure to be called to trace command execution.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a token for the trace, which may be passed
|
* The return value is a token for the trace, which may be passed
|
* to Tcl_DeleteTrace to eliminate the trace.
|
* to Tcl_DeleteTrace to eliminate the trace.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* From now on, proc will be called just before a command procedure
|
* From now on, proc will be called just before a command procedure
|
* is called to execute a Tcl command. Calls to proc will have the
|
* is called to execute a Tcl command. Calls to proc will have the
|
* following form:
|
* following form:
|
*
|
*
|
* void
|
* void
|
* proc(clientData, interp, level, command, cmdProc, cmdClientData,
|
* proc(clientData, interp, level, command, cmdProc, cmdClientData,
|
* argc, argv)
|
* argc, argv)
|
* ClientData clientData;
|
* ClientData clientData;
|
* Tcl_Interp *interp;
|
* Tcl_Interp *interp;
|
* int level;
|
* int level;
|
* char *command;
|
* char *command;
|
* int (*cmdProc)();
|
* int (*cmdProc)();
|
* ClientData cmdClientData;
|
* ClientData cmdClientData;
|
* int argc;
|
* int argc;
|
* char **argv;
|
* char **argv;
|
* {
|
* {
|
* }
|
* }
|
*
|
*
|
* The clientData and interp arguments to proc will be the same
|
* The clientData and interp arguments to proc will be the same
|
* as the corresponding arguments to this procedure. Level gives
|
* as the corresponding arguments to this procedure. Level gives
|
* the nesting level of command interpretation for this interpreter
|
* the nesting level of command interpretation for this interpreter
|
* (0 corresponds to top level). Command gives the ASCII text of
|
* (0 corresponds to top level). Command gives the ASCII text of
|
* the raw command, cmdProc and cmdClientData give the procedure that
|
* the raw command, cmdProc and cmdClientData give the procedure that
|
* will be called to process the command and the ClientData value it
|
* will be called to process the command and the ClientData value it
|
* will receive, and argc and argv give the arguments to the
|
* will receive, and argc and argv give the arguments to the
|
* command, after any argument parsing and substitution. Proc
|
* command, after any argument parsing and substitution. Proc
|
* does not return a value.
|
* does not return a value.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_Trace
|
Tcl_Trace
|
Tcl_CreateTrace(interp, level, proc, clientData)
|
Tcl_CreateTrace(interp, level, proc, clientData)
|
Tcl_Interp *interp; /* Interpreter in which to create trace. */
|
Tcl_Interp *interp; /* Interpreter in which to create trace. */
|
int level; /* Only call proc for commands at nesting
|
int level; /* Only call proc for commands at nesting
|
* level<=argument level (1=>top level). */
|
* level<=argument level (1=>top level). */
|
Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
|
Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
|
* command. */
|
* command. */
|
ClientData clientData; /* Arbitrary value word to pass to proc. */
|
ClientData clientData; /* Arbitrary value word to pass to proc. */
|
{
|
{
|
register Trace *tracePtr;
|
register Trace *tracePtr;
|
register Interp *iPtr = (Interp *) interp;
|
register Interp *iPtr = (Interp *) interp;
|
|
|
/*
|
/*
|
* Invalidate existing compiled code for this interpreter and arrange
|
* Invalidate existing compiled code for this interpreter and arrange
|
* (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling
|
* (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling
|
* new code, no commands will be compiled inline (i.e., into an inline
|
* new code, no commands will be compiled inline (i.e., into an inline
|
* sequence of instructions). We do this because commands that were
|
* sequence of instructions). We do this because commands that were
|
* compiled inline will never result in a command trace being called.
|
* compiled inline will never result in a command trace being called.
|
*/
|
*/
|
|
|
iPtr->compileEpoch++;
|
iPtr->compileEpoch++;
|
iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
|
iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
|
|
|
tracePtr = (Trace *) ckalloc(sizeof(Trace));
|
tracePtr = (Trace *) ckalloc(sizeof(Trace));
|
tracePtr->level = level;
|
tracePtr->level = level;
|
tracePtr->proc = proc;
|
tracePtr->proc = proc;
|
tracePtr->clientData = clientData;
|
tracePtr->clientData = clientData;
|
tracePtr->nextPtr = iPtr->tracePtr;
|
tracePtr->nextPtr = iPtr->tracePtr;
|
iPtr->tracePtr = tracePtr;
|
iPtr->tracePtr = tracePtr;
|
|
|
return (Tcl_Trace) tracePtr;
|
return (Tcl_Trace) tracePtr;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DeleteTrace --
|
* Tcl_DeleteTrace --
|
*
|
*
|
* Remove a trace.
|
* Remove a trace.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* From now on there will be no more calls to the procedure given
|
* From now on there will be no more calls to the procedure given
|
* in trace.
|
* in trace.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DeleteTrace(interp, trace)
|
Tcl_DeleteTrace(interp, trace)
|
Tcl_Interp *interp; /* Interpreter that contains trace. */
|
Tcl_Interp *interp; /* Interpreter that contains trace. */
|
Tcl_Trace trace; /* Token for trace (returned previously by
|
Tcl_Trace trace; /* Token for trace (returned previously by
|
* Tcl_CreateTrace). */
|
* Tcl_CreateTrace). */
|
{
|
{
|
register Interp *iPtr = (Interp *) interp;
|
register Interp *iPtr = (Interp *) interp;
|
register Trace *tracePtr = (Trace *) trace;
|
register Trace *tracePtr = (Trace *) trace;
|
register Trace *tracePtr2;
|
register Trace *tracePtr2;
|
|
|
if (iPtr->tracePtr == tracePtr) {
|
if (iPtr->tracePtr == tracePtr) {
|
iPtr->tracePtr = tracePtr->nextPtr;
|
iPtr->tracePtr = tracePtr->nextPtr;
|
ckfree((char *) tracePtr);
|
ckfree((char *) tracePtr);
|
} else {
|
} else {
|
for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
|
for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
|
tracePtr2 = tracePtr2->nextPtr) {
|
tracePtr2 = tracePtr2->nextPtr) {
|
if (tracePtr2->nextPtr == tracePtr) {
|
if (tracePtr2->nextPtr == tracePtr) {
|
tracePtr2->nextPtr = tracePtr->nextPtr;
|
tracePtr2->nextPtr = tracePtr->nextPtr;
|
ckfree((char *) tracePtr);
|
ckfree((char *) tracePtr);
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
if (iPtr->tracePtr == NULL) {
|
if (iPtr->tracePtr == NULL) {
|
/*
|
/*
|
* When compiling new code, allow commands to be compiled inline.
|
* When compiling new code, allow commands to be compiled inline.
|
*/
|
*/
|
|
|
iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
|
iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_AddErrorInfo --
|
* Tcl_AddErrorInfo --
|
*
|
*
|
* Add information to the "errorInfo" variable that describes the
|
* Add information to the "errorInfo" variable that describes the
|
* current error.
|
* current error.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The contents of message are added to the "errorInfo" variable.
|
* The contents of message are added to the "errorInfo" variable.
|
* If Tcl_Eval has been called since the current value of errorInfo
|
* If Tcl_Eval has been called since the current value of errorInfo
|
* was set, errorInfo is cleared before adding the new message.
|
* was set, errorInfo is cleared before adding the new message.
|
* If we are just starting to log an error, errorInfo is initialized
|
* If we are just starting to log an error, errorInfo is initialized
|
* from the error message in the interpreter's result.
|
* from the error message in the interpreter's result.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_AddErrorInfo(interp, message)
|
Tcl_AddErrorInfo(interp, message)
|
Tcl_Interp *interp; /* Interpreter to which error information
|
Tcl_Interp *interp; /* Interpreter to which error information
|
* pertains. */
|
* pertains. */
|
char *message; /* Message to record. */
|
char *message; /* Message to record. */
|
{
|
{
|
Tcl_AddObjErrorInfo(interp, message, -1);
|
Tcl_AddObjErrorInfo(interp, message, -1);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_AddObjErrorInfo --
|
* Tcl_AddObjErrorInfo --
|
*
|
*
|
* Add information to the "errorInfo" variable that describes the
|
* Add information to the "errorInfo" variable that describes the
|
* current error. This routine differs from Tcl_AddErrorInfo by
|
* current error. This routine differs from Tcl_AddErrorInfo by
|
* taking a byte pointer and length.
|
* taking a byte pointer and length.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* "length" bytes from "message" are added to the "errorInfo" variable.
|
* "length" bytes from "message" are added to the "errorInfo" variable.
|
* If "length" is negative, use bytes up to the first NULL byte.
|
* If "length" is negative, use bytes up to the first NULL byte.
|
* If Tcl_EvalObj has been called since the current value of errorInfo
|
* If Tcl_EvalObj has been called since the current value of errorInfo
|
* was set, errorInfo is cleared before adding the new message.
|
* was set, errorInfo is cleared before adding the new message.
|
* If we are just starting to log an error, errorInfo is initialized
|
* If we are just starting to log an error, errorInfo is initialized
|
* from the error message in the interpreter's result.
|
* from the error message in the interpreter's result.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_AddObjErrorInfo(interp, message, length)
|
Tcl_AddObjErrorInfo(interp, message, length)
|
Tcl_Interp *interp; /* Interpreter to which error information
|
Tcl_Interp *interp; /* Interpreter to which error information
|
* pertains. */
|
* pertains. */
|
char *message; /* Points to the first byte of an array of
|
char *message; /* Points to the first byte of an array of
|
* bytes of the message. */
|
* bytes of the message. */
|
register int length; /* The number of bytes in the message.
|
register int length; /* The number of bytes in the message.
|
* If < 0, then append all bytes up to a
|
* If < 0, then append all bytes up to a
|
* NULL byte. */
|
* NULL byte. */
|
{
|
{
|
register Interp *iPtr = (Interp *) interp;
|
register Interp *iPtr = (Interp *) interp;
|
Tcl_Obj *namePtr, *messagePtr;
|
Tcl_Obj *namePtr, *messagePtr;
|
|
|
/*
|
/*
|
* If we are just starting to log an error, errorInfo is initialized
|
* If we are just starting to log an error, errorInfo is initialized
|
* from the error message in the interpreter's result.
|
* from the error message in the interpreter's result.
|
*/
|
*/
|
|
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
namePtr = Tcl_NewStringObj("errorInfo", -1);
|
Tcl_IncrRefCount(namePtr);
|
Tcl_IncrRefCount(namePtr);
|
|
|
if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
|
if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
|
iPtr->flags |= ERR_IN_PROGRESS;
|
iPtr->flags |= ERR_IN_PROGRESS;
|
|
|
if (iPtr->result[0] == 0) {
|
if (iPtr->result[0] == 0) {
|
(void) Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL,
|
(void) Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL,
|
iPtr->objResultPtr, TCL_GLOBAL_ONLY);
|
iPtr->objResultPtr, TCL_GLOBAL_ONLY);
|
} else { /* use the string result */
|
} else { /* use the string result */
|
Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
|
Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
}
|
}
|
|
|
/*
|
/*
|
* If the errorCode variable wasn't set by the code that generated
|
* If the errorCode variable wasn't set by the code that generated
|
* the error, set it to "NONE".
|
* the error, set it to "NONE".
|
*/
|
*/
|
|
|
if (!(iPtr->flags & ERROR_CODE_SET)) {
|
if (!(iPtr->flags & ERROR_CODE_SET)) {
|
(void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
|
(void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Now append "message" to the end of errorInfo.
|
* Now append "message" to the end of errorInfo.
|
*/
|
*/
|
|
|
if (length != 0) {
|
if (length != 0) {
|
messagePtr = Tcl_NewStringObj(message, length);
|
messagePtr = Tcl_NewStringObj(message, length);
|
Tcl_IncrRefCount(messagePtr);
|
Tcl_IncrRefCount(messagePtr);
|
Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr,
|
Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr,
|
(TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
|
(TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
|
Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
|
Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
|
}
|
}
|
|
|
Tcl_DecrRefCount(namePtr); /* free the name object */
|
Tcl_DecrRefCount(namePtr); /* free the name object */
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_VarEval --
|
* Tcl_VarEval --
|
*
|
*
|
* Given a variable number of string arguments, concatenate them
|
* Given a variable number of string arguments, concatenate them
|
* all together and execute the result as a Tcl command.
|
* all together and execute the result as a Tcl command.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl return result. An error message or other
|
* A standard Tcl return result. An error message or other
|
* result may be left in interp->result.
|
* result may be left in interp->result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Depends on what was done by the command.
|
* Depends on what was done by the command.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
/* VARARGS2 */ /* ARGSUSED */
|
/* VARARGS2 */ /* ARGSUSED */
|
int
|
int
|
Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
|
Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
|
{
|
{
|
va_list argList;
|
va_list argList;
|
Tcl_DString buf;
|
Tcl_DString buf;
|
char *string;
|
char *string;
|
Tcl_Interp *interp;
|
Tcl_Interp *interp;
|
int result;
|
int result;
|
|
|
/*
|
/*
|
* Copy the strings one after the other into a single larger
|
* Copy the strings one after the other into a single larger
|
* string. Use stack-allocated space for small commands, but if
|
* string. Use stack-allocated space for small commands, but if
|
* the command gets too large than call ckalloc to create the
|
* the command gets too large than call ckalloc to create the
|
* space.
|
* space.
|
*/
|
*/
|
|
|
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
|
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
|
Tcl_DStringInit(&buf);
|
Tcl_DStringInit(&buf);
|
while (1) {
|
while (1) {
|
string = va_arg(argList, char *);
|
string = va_arg(argList, char *);
|
if (string == NULL) {
|
if (string == NULL) {
|
break;
|
break;
|
}
|
}
|
Tcl_DStringAppend(&buf, string, -1);
|
Tcl_DStringAppend(&buf, string, -1);
|
}
|
}
|
va_end(argList);
|
va_end(argList);
|
|
|
result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
|
result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
|
Tcl_DStringFree(&buf);
|
Tcl_DStringFree(&buf);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GlobalEval --
|
* Tcl_GlobalEval --
|
*
|
*
|
* Evaluate a command at global level in an interpreter.
|
* Evaluate a command at global level in an interpreter.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result is returned, and interp->result is
|
* A standard Tcl result is returned, and interp->result is
|
* modified accordingly.
|
* modified accordingly.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The command string is executed in interp, and the execution
|
* The command string is executed in interp, and the execution
|
* is carried out in the variable context of global level (no
|
* is carried out in the variable context of global level (no
|
* procedures active), just as if an "uplevel #0" command were
|
* procedures active), just as if an "uplevel #0" command were
|
* being executed.
|
* being executed.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_GlobalEval(interp, command)
|
Tcl_GlobalEval(interp, command)
|
Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
|
Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
|
char *command; /* Command to evaluate. */
|
char *command; /* Command to evaluate. */
|
{
|
{
|
register Interp *iPtr = (Interp *) interp;
|
register Interp *iPtr = (Interp *) interp;
|
int result;
|
int result;
|
CallFrame *savedVarFramePtr;
|
CallFrame *savedVarFramePtr;
|
|
|
savedVarFramePtr = iPtr->varFramePtr;
|
savedVarFramePtr = iPtr->varFramePtr;
|
iPtr->varFramePtr = NULL;
|
iPtr->varFramePtr = NULL;
|
result = Tcl_Eval(interp, command);
|
result = Tcl_Eval(interp, command);
|
iPtr->varFramePtr = savedVarFramePtr;
|
iPtr->varFramePtr = savedVarFramePtr;
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GlobalEvalObj --
|
* Tcl_GlobalEvalObj --
|
*
|
*
|
* Execute Tcl commands stored in a Tcl object at global level in
|
* Execute Tcl commands stored in a Tcl object at global level in
|
* an interpreter. These commands are compiled into bytecodes if
|
* an interpreter. These commands are compiled into bytecodes if
|
* necessary.
|
* necessary.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result is returned, and the interpreter's result
|
* A standard Tcl result is returned, and the interpreter's result
|
* contains a Tcl object value to supplement the return code.
|
* contains a Tcl object value to supplement the return code.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object is converted, if necessary, to a ByteCode object that
|
* The object is converted, if necessary, to a ByteCode object that
|
* holds the bytecode instructions for the commands. Executing the
|
* holds the bytecode instructions for the commands. Executing the
|
* commands will almost certainly have side effects that depend on
|
* commands will almost certainly have side effects that depend on
|
* those commands.
|
* those commands.
|
*
|
*
|
* The commands are executed in interp, and the execution
|
* The commands are executed in interp, and the execution
|
* is carried out in the variable context of global level (no
|
* is carried out in the variable context of global level (no
|
* procedures active), just as if an "uplevel #0" command were
|
* procedures active), just as if an "uplevel #0" command were
|
* being executed.
|
* being executed.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_GlobalEvalObj(interp, objPtr)
|
Tcl_GlobalEvalObj(interp, objPtr)
|
Tcl_Interp *interp; /* Interpreter in which to evaluate
|
Tcl_Interp *interp; /* Interpreter in which to evaluate
|
* commands. */
|
* commands. */
|
Tcl_Obj *objPtr; /* Pointer to object containing commands
|
Tcl_Obj *objPtr; /* Pointer to object containing commands
|
* to execute. */
|
* to execute. */
|
{
|
{
|
register Interp *iPtr = (Interp *) interp;
|
register Interp *iPtr = (Interp *) interp;
|
int result;
|
int result;
|
CallFrame *savedVarFramePtr;
|
CallFrame *savedVarFramePtr;
|
|
|
savedVarFramePtr = iPtr->varFramePtr;
|
savedVarFramePtr = iPtr->varFramePtr;
|
iPtr->varFramePtr = NULL;
|
iPtr->varFramePtr = NULL;
|
result = Tcl_EvalObj(interp, objPtr);
|
result = Tcl_EvalObj(interp, objPtr);
|
iPtr->varFramePtr = savedVarFramePtr;
|
iPtr->varFramePtr = savedVarFramePtr;
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SetRecursionLimit --
|
* Tcl_SetRecursionLimit --
|
*
|
*
|
* Set the maximum number of recursive calls that may be active
|
* Set the maximum number of recursive calls that may be active
|
* for an interpreter at once.
|
* for an interpreter at once.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is the old limit on nesting for interp.
|
* The return value is the old limit on nesting for interp.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_SetRecursionLimit(interp, depth)
|
Tcl_SetRecursionLimit(interp, depth)
|
Tcl_Interp *interp; /* Interpreter whose nesting limit
|
Tcl_Interp *interp; /* Interpreter whose nesting limit
|
* is to be set. */
|
* is to be set. */
|
int depth; /* New value for maximimum depth. */
|
int depth; /* New value for maximimum depth. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
int old;
|
int old;
|
|
|
old = iPtr->maxNestingDepth;
|
old = iPtr->maxNestingDepth;
|
if (depth > 0) {
|
if (depth > 0) {
|
iPtr->maxNestingDepth = depth;
|
iPtr->maxNestingDepth = depth;
|
}
|
}
|
return old;
|
return old;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_AllowExceptions --
|
* Tcl_AllowExceptions --
|
*
|
*
|
* Sets a flag in an interpreter so that exceptions can occur
|
* Sets a flag in an interpreter so that exceptions can occur
|
* in the next call to Tcl_Eval without them being turned into
|
* in the next call to Tcl_Eval without them being turned into
|
* errors.
|
* errors.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
|
* The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
|
* evalFlags structure. See the reference documentation for
|
* evalFlags structure. See the reference documentation for
|
* more details.
|
* more details.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_AllowExceptions(interp)
|
Tcl_AllowExceptions(interp)
|
Tcl_Interp *interp; /* Interpreter in which to set flag. */
|
Tcl_Interp *interp; /* Interpreter in which to set flag. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
|
|
iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
|
iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
|
}
|
}
|
|
|
|
|
