Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclBasic.c@bde4ae8d615e (annotated)

sl@0	1	/*
sl@0	2	* tclBasic.c --
sl@0	3	*
sl@0	4	* Contains the basic facilities for TCL command interpretation,
sl@0	5	* including interpreter creation and deletion, command creation
sl@0	6	* and deletion, and command/script execution.
sl@0	7	*
sl@0	8	* Copyright (c) 1987-1994 The Regents of the University of California.
sl@0	9	* Copyright (c) 1994-1997 Sun Microsystems, Inc.
sl@0	10	* Copyright (c) 1998-1999 by Scriptics Corporation.
sl@0	11	* Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
sl@0	12	* Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
sl@0	13	*
sl@0	14	* See the file "license.terms" for information on usage and redistribution
sl@0	15	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	16	*
sl@0	17	* RCS: @(#) $Id: tclBasic.c,v 1.75.2.26 2006/11/28 22:19:59 andreas_kupries Exp $
sl@0	18	*/
sl@0	19
sl@0	20	#include "tclInt.h"
sl@0	21	#include "tclCompile.h"
sl@0	22	#ifndef TCL_GENERIC_ONLY
sl@0	23	# include "tclPort.h"
sl@0	24	#endif
sl@0	25
sl@0	26	/*
sl@0	27	* Static procedures in this file:
sl@0	28	*/
sl@0	29
sl@0	30	static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr,
sl@0	31	Command cmdPtr, CONST char oldName,
sl@0	32	CONST char* newName, int flags));
sl@0	33	static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
sl@0	34	static void ProcessUnexpectedResult _ANSI_ARGS_((
sl@0	35	Tcl_Interp *interp, int returnCode));
sl@0	36	static int StringTraceProc _ANSI_ARGS_((ClientData clientData,
sl@0	37	Tcl_Interp* interp,
sl@0	38	int level,
sl@0	39	CONST char* command,
sl@0	40	Tcl_Command commandInfo,
sl@0	41	int objc,
sl@0	42	Tcl_Obj *CONST objv[]));
sl@0	43	static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData));
sl@0	44
sl@0	45	#ifdef TCL_TIP280
sl@0	46	/* TIP #280 - Modified token based evulation, with line information */
sl@0	47	static int EvalEx _ANSI_ARGS_((Tcl_Interp interp, CONST char script,
sl@0	48	int numBytes, int flags, int line));
sl@0	49
sl@0	50	static int EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	51	Tcl_Token *tokenPtr,
sl@0	52	int count, int line));
sl@0	53
sl@0	54	#endif
sl@0	55
sl@0	56	extern TclStubs tclStubs;
sl@0	57
sl@0	58	/*
sl@0	59	* The following structure defines the commands in the Tcl core.
sl@0	60	*/
sl@0	61
sl@0	62	typedef struct {
sl@0	63	char name; / Name of object-based command. */
sl@0	64	Tcl_CmdProc proc; / String-based procedure for command. */
sl@0	65	Tcl_ObjCmdProc objProc; / Object-based procedure for command. */
sl@0	66	CompileProc compileProc; / Procedure called to compile command. */
sl@0	67	int isSafe; /* If non-zero, command will be present
sl@0	68	* in safe interpreter. Otherwise it will
sl@0	69	* be hidden. */
sl@0	70	} CmdInfo;
sl@0	71
sl@0	72	/*
sl@0	73	* The built-in commands, and the procedures that implement them:
sl@0	74	*/
sl@0	75
sl@0	76	static CmdInfo builtInCmds[] = {
sl@0	77	/*
sl@0	78	* Commands in the generic core. Note that at least one of the proc or
sl@0	79	* objProc members should be non-NULL. This avoids infinitely recursive
sl@0	80	* calls between TclInvokeObjectCommand and TclInvokeStringCommand if a
sl@0	81	* command name is computed at runtime and results in the name of a
sl@0	82	* compiled command.
sl@0	83	*/
sl@0	84
sl@0	85	{"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd,
sl@0	86	TclCompileAppendCmd, 1},
sl@0	87	{"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd,
sl@0	88	(CompileProc *) NULL, 1},
sl@0	89	{"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd,
sl@0	90	(CompileProc *) NULL, 1},
sl@0	91	{"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd,
sl@0	92	TclCompileBreakCmd, 1},
sl@0	93	{"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd,
sl@0	94	(CompileProc *) NULL, 1},
sl@0	95	{"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd,
sl@0	96	TclCompileCatchCmd, 1},
sl@0	97	{"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd,
sl@0	98	(CompileProc *) NULL, 1},
sl@0	99	{"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd,
sl@0	100	(CompileProc *) NULL, 1},
sl@0	101	{"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd,
sl@0	102	TclCompileContinueCmd, 1},
sl@0	103	{"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd,
sl@0	104	(CompileProc *) NULL, 0},
sl@0	105	{"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd,
sl@0	106	(CompileProc *) NULL, 1},
sl@0	107	{"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd,
sl@0	108	(CompileProc *) NULL, 1},
sl@0	109	{"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd,
sl@0	110	(CompileProc *) NULL, 0},
sl@0	111	{"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd,
sl@0	112	TclCompileExprCmd, 1},
sl@0	113	{"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd,
sl@0	114	(CompileProc *) NULL, 1},
sl@0	115	{"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd,
sl@0	116	(CompileProc *) NULL, 1},
sl@0	117	{"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd,
sl@0	118	TclCompileForCmd, 1},
sl@0	119	{"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd,
sl@0	120	TclCompileForeachCmd, 1},
sl@0	121	{"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd,
sl@0	122	(CompileProc *) NULL, 1},
sl@0	123	{"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd,
sl@0	124	(CompileProc *) NULL, 1},
sl@0	125	{"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd,
sl@0	126	TclCompileIfCmd, 1},
sl@0	127	{"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd,
sl@0	128	TclCompileIncrCmd, 1},
sl@0	129	{"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd,
sl@0	130	(CompileProc *) NULL, 1},
sl@0	131	{"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd,
sl@0	132	(CompileProc *) NULL, 1},
sl@0	133	{"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd,
sl@0	134	TclCompileLappendCmd, 1},
sl@0	135	{"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd,
sl@0	136	TclCompileLindexCmd, 1},
sl@0	137	{"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd,
sl@0	138	(CompileProc *) NULL, 1},
sl@0	139	{"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd,
sl@0	140	TclCompileListCmd, 1},
sl@0	141	{"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd,
sl@0	142	TclCompileLlengthCmd, 1},
sl@0	143	{"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd,
sl@0	144	(CompileProc *) NULL, 0},
sl@0	145	{"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd,
sl@0	146	(CompileProc *) NULL, 1},
sl@0	147	{"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd,
sl@0	148	(CompileProc *) NULL, 1},
sl@0	149	{"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd,
sl@0	150	(CompileProc *) NULL, 1},
sl@0	151	{"lset", (Tcl_CmdProc *) NULL, Tcl_LsetObjCmd,
sl@0	152	TclCompileLsetCmd, 1},
sl@0	153	{"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd,
sl@0	154	(CompileProc *) NULL, 1},
sl@0	155	{"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd,
sl@0	156	(CompileProc *) NULL, 1},
sl@0	157	{"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd,
sl@0	158	(CompileProc *) NULL, 1},
sl@0	159	{"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd,
sl@0	160	(CompileProc *) NULL, 1},
sl@0	161	{"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd,
sl@0	162	TclCompileRegexpCmd, 1},
sl@0	163	{"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd,
sl@0	164	(CompileProc *) NULL, 1},
sl@0	165	{"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd,
sl@0	166	(CompileProc *) NULL, 1},
sl@0	167	{"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd,
sl@0	168	TclCompileReturnCmd, 1},
sl@0	169	{"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd,
sl@0	170	(CompileProc *) NULL, 1},
sl@0	171	{"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd,
sl@0	172	TclCompileSetCmd, 1},
sl@0	173	{"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd,
sl@0	174	(CompileProc *) NULL, 1},
sl@0	175	{"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd,
sl@0	176	TclCompileStringCmd, 1},
sl@0	177	{"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd,
sl@0	178	(CompileProc *) NULL, 1},
sl@0	179	{"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd,
sl@0	180	(CompileProc *) NULL, 1},
sl@0	181	{"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd,
sl@0	182	(CompileProc *) NULL, 1},
sl@0	183	{"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd,
sl@0	184	(CompileProc *) NULL, 1},
sl@0	185	{"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd,
sl@0	186	(CompileProc *) NULL, 1},
sl@0	187	{"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd,
sl@0	188	(CompileProc *) NULL, 1},
sl@0	189	{"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd,
sl@0	190	(CompileProc *) NULL, 1},
sl@0	191	{"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd,
sl@0	192	TclCompileWhileCmd, 1},
sl@0	193
sl@0	194	/*
sl@0	195	* Commands in the UNIX core:
sl@0	196	*/
sl@0	197
sl@0	198	#ifndef TCL_GENERIC_ONLY
sl@0	199	{"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd,
sl@0	200	(CompileProc *) NULL, 1},
sl@0	201	{"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd,
sl@0	202	(CompileProc *) NULL, 0},
sl@0	203	{"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd,
sl@0	204	(CompileProc *) NULL, 1},
sl@0	205	{"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd,
sl@0	206	(CompileProc *) NULL, 1},
sl@0	207	{"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd,
sl@0	208	(CompileProc *) NULL, 1},
sl@0	209	{"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd,
sl@0	210	(CompileProc *) NULL, 0},
sl@0	211	{"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd,
sl@0	212	(CompileProc *) NULL, 0},
sl@0	213	{"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd,
sl@0	214	(CompileProc *) NULL, 1},
sl@0	215	{"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd,
sl@0	216	(CompileProc *) NULL, 1},
sl@0	217	{"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd,
sl@0	218	(CompileProc *) NULL, 0},
sl@0	219	{"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd,
sl@0	220	(CompileProc *) NULL, 0},
sl@0	221	{"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd,
sl@0	222	(CompileProc *) NULL, 1},
sl@0	223	{"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd,
sl@0	224	(CompileProc *) NULL, 1},
sl@0	225	{"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd,
sl@0	226	(CompileProc *) NULL, 0},
sl@0	227	{"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd,
sl@0	228	(CompileProc *) NULL, 1},
sl@0	229	{"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd,
sl@0	230	(CompileProc *) NULL, 1},
sl@0	231	{"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd,
sl@0	232	(CompileProc *) NULL, 0},
sl@0	233	{"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd,
sl@0	234	(CompileProc *) NULL, 1},
sl@0	235	{"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd,
sl@0	236	(CompileProc *) NULL, 1},
sl@0	237	{"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd,
sl@0	238	(CompileProc *) NULL, 1},
sl@0	239	{"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd,
sl@0	240	(CompileProc *) NULL, 1},
sl@0	241
sl@0	242	#ifdef MAC_TCL
sl@0	243	{"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd,
sl@0	244	(CompileProc *) NULL, 0},
sl@0	245	{"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL,
sl@0	246	(CompileProc *) NULL, 0},
sl@0	247	{"ls", (Tcl_CmdProc *) NULL, Tcl_LsObjCmd,
sl@0	248	(CompileProc *) NULL, 0},
sl@0	249	{"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd,
sl@0	250	(CompileProc *) NULL, 1},
sl@0	251	{"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd,
sl@0	252	(CompileProc *) NULL, 0},
sl@0	253	#else
sl@0	254	{"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd,
sl@0	255	(CompileProc *) NULL, 0},
sl@0	256	{"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd,
sl@0	257	(CompileProc *) NULL, 0},
sl@0	258	#endif /* MAC_TCL */
sl@0	259
sl@0	260	#endif /* TCL_GENERIC_ONLY */
sl@0	261	{NULL, (Tcl_CmdProc ) NULL, (Tcl_ObjCmdProc ) NULL,
sl@0	262	(CompileProc *) NULL, 0}
sl@0	263	};
sl@0	264
sl@0	265	/*
sl@0	266	* The following structure holds the client data for string-based
sl@0	267	* trace procs
sl@0	268	*/
sl@0	269
sl@0	270	typedef struct StringTraceData {
sl@0	271	ClientData clientData; /* Client data from Tcl_CreateTrace */
sl@0	272	Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */
sl@0	273	} StringTraceData;
sl@0	274
sl@0	275	/*
sl@0	276	*----------------------------------------------------------------------
sl@0	277	*
sl@0	278	* Tcl_CreateInterp --
sl@0	279	*
sl@0	280	* Create a new TCL command interpreter.
sl@0	281	*
sl@0	282	* Results:
sl@0	283	* The return value is a token for the interpreter, which may be
sl@0	284	* used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
sl@0	285	* Tcl_DeleteInterp.
sl@0	286	*
sl@0	287	* Side effects:
sl@0	288	* The command interpreter is initialized with the built-in commands
sl@0	289	* and with the variables documented in tclvars(n).
sl@0	290	*
sl@0	291	*----------------------------------------------------------------------
sl@0	292	*/
sl@0	293
sl@0	294	EXPORT_C Tcl_Interp *
sl@0	295	Tcl_CreateInterp()
sl@0	296	{
sl@0	297	Interp *iPtr;
sl@0	298	Tcl_Interp *interp;
sl@0	299	Command *cmdPtr;
sl@0	300	BuiltinFunc *builtinFuncPtr;
sl@0	301	MathFunc *mathFuncPtr;
sl@0	302	Tcl_HashEntry *hPtr;
sl@0	303	CmdInfo *cmdInfoPtr;
sl@0	304	int i;
sl@0	305	union {
sl@0	306	char c[sizeof(short)];
sl@0	307	short s;
sl@0	308	} order;
sl@0	309	#ifdef TCL_COMPILE_STATS
sl@0	310	ByteCodeStats *statsPtr;
sl@0	311	#endif /* TCL_COMPILE_STATS */
sl@0	312
sl@0	313	TclInitSubsystems(NULL);
sl@0	314
sl@0	315	/*
sl@0	316	* Panic if someone updated the CallFrame structure without
sl@0	317	* also updating the Tcl_CallFrame structure (or vice versa).
sl@0	318	*/
sl@0	319
sl@0	320	if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
sl@0	321	/NOTREACHED/
sl@0	322	panic("Tcl_CallFrame and CallFrame are not the same size");
sl@0	323	}
sl@0	324
sl@0	325	/*
sl@0	326	* Initialize support for namespaces and create the global namespace
sl@0	327	* (whose name is ""; an alias is "::"). This also initializes the
sl@0	328	* Tcl object type table and other object management code.
sl@0	329	*/
sl@0	330
sl@0	331	iPtr = (Interp *) ckalloc(sizeof(Interp));
sl@0	332	interp = (Tcl_Interp *) iPtr;
sl@0	333
sl@0	334	iPtr->result = iPtr->resultSpace;
sl@0	335	iPtr->freeProc = NULL;
sl@0	336	iPtr->errorLine = 0;
sl@0	337	iPtr->objResultPtr = Tcl_NewObj();
sl@0	338	Tcl_IncrRefCount(iPtr->objResultPtr);
sl@0	339	iPtr->handle = TclHandleCreate(iPtr);
sl@0	340	iPtr->globalNsPtr = NULL;
sl@0	341	iPtr->hiddenCmdTablePtr = NULL;
sl@0	342	iPtr->interpInfo = NULL;
sl@0	343	Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
sl@0	344
sl@0	345	iPtr->numLevels = 0;
sl@0	346	iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
sl@0	347	iPtr->framePtr = NULL;
sl@0	348	iPtr->varFramePtr = NULL;
sl@0	349
sl@0	350	#ifdef TCL_TIP280
sl@0	351	/*
sl@0	352	* TIP #280 - Initialize the arrays used to extend the ByteCode and
sl@0	353	* Proc structures.
sl@0	354	*/
sl@0	355	iPtr->cmdFramePtr = NULL;
sl@0	356	iPtr->linePBodyPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
sl@0	357	iPtr->lineBCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
sl@0	358	Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
sl@0	359	Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
sl@0	360	#endif
sl@0	361
sl@0	362	iPtr->activeVarTracePtr = NULL;
sl@0	363	iPtr->returnCode = TCL_OK;
sl@0	364	iPtr->errorInfo = NULL;
sl@0	365	iPtr->errorCode = NULL;
sl@0	366
sl@0	367	iPtr->appendResult = NULL;
sl@0	368	iPtr->appendAvl = 0;
sl@0	369	iPtr->appendUsed = 0;
sl@0	370
sl@0	371	Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
sl@0	372	iPtr->packageUnknown = NULL;
sl@0	373	#ifdef TCL_TIP268
sl@0	374	/* TIP #268 */
sl@0	375	iPtr->packagePrefer = (getenv ("TCL_PKG_PREFER_LATEST") == NULL ?
sl@0	376	PKG_PREFER_STABLE :
sl@0	377	PKG_PREFER_LATEST);
sl@0	378	#endif
sl@0	379	iPtr->cmdCount = 0;
sl@0	380	iPtr->termOffset = 0;
sl@0	381	TclInitLiteralTable(&(iPtr->literalTable));
sl@0	382	iPtr->compileEpoch = 0;
sl@0	383	iPtr->compiledProcPtr = NULL;
sl@0	384	iPtr->resolverPtr = NULL;
sl@0	385	iPtr->evalFlags = 0;
sl@0	386	iPtr->scriptFile = NULL;
sl@0	387	iPtr->flags = 0;
sl@0	388	iPtr->tracePtr = NULL;
sl@0	389	iPtr->tracesForbiddingInline = 0;
sl@0	390	iPtr->activeCmdTracePtr = NULL;
sl@0	391	iPtr->activeInterpTracePtr = NULL;
sl@0	392	iPtr->assocData = (Tcl_HashTable *) NULL;
sl@0	393	iPtr->execEnvPtr = NULL; /* set after namespaces initialized */
sl@0	394	iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
sl@0	395	Tcl_IncrRefCount(iPtr->emptyObjPtr);
sl@0	396	iPtr->resultSpace[0] = 0;
sl@0	397	iPtr->threadId = Tcl_GetCurrentThread();
sl@0	398
sl@0	399	iPtr->globalNsPtr = NULL; /* force creation of global ns below */
sl@0	400	iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
sl@0	401	(ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
sl@0	402	if (iPtr->globalNsPtr == NULL) {
sl@0	403	panic("Tcl_CreateInterp: can't create global namespace");
sl@0	404	}
sl@0	405
sl@0	406	/*
sl@0	407	* Initialize support for code compilation and execution. We call
sl@0	408	* TclCreateExecEnv after initializing namespaces since it tries to
sl@0	409	* reference a Tcl variable (it links to the Tcl "tcl_traceExec"
sl@0	410	* variable).
sl@0	411	*/
sl@0	412
sl@0	413	iPtr->execEnvPtr = TclCreateExecEnv(interp);
sl@0	414
sl@0	415	/*
sl@0	416	* Initialize the compilation and execution statistics kept for this
sl@0	417	* interpreter.
sl@0	418	*/
sl@0	419
sl@0	420	#ifdef TCL_COMPILE_STATS
sl@0	421	statsPtr = &(iPtr->stats);
sl@0	422	statsPtr->numExecutions = 0;
sl@0	423	statsPtr->numCompilations = 0;
sl@0	424	statsPtr->numByteCodesFreed = 0;
sl@0	425	(VOID *) memset(statsPtr->instructionCount, 0,
sl@0	426	sizeof(statsPtr->instructionCount));
sl@0	427
sl@0	428	statsPtr->totalSrcBytes = 0.0;
sl@0	429	statsPtr->totalByteCodeBytes = 0.0;
sl@0	430	statsPtr->currentSrcBytes = 0.0;
sl@0	431	statsPtr->currentByteCodeBytes = 0.0;
sl@0	432	(VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
sl@0	433	(VOID *) memset(statsPtr->byteCodeCount, 0,
sl@0	434	sizeof(statsPtr->byteCodeCount));
sl@0	435	(VOID *) memset(statsPtr->lifetimeCount, 0,
sl@0	436	sizeof(statsPtr->lifetimeCount));
sl@0	437
sl@0	438	statsPtr->currentInstBytes = 0.0;
sl@0	439	statsPtr->currentLitBytes = 0.0;
sl@0	440	statsPtr->currentExceptBytes = 0.0;
sl@0	441	statsPtr->currentAuxBytes = 0.0;
sl@0	442	statsPtr->currentCmdMapBytes = 0.0;
sl@0	443
sl@0	444	statsPtr->numLiteralsCreated = 0;
sl@0	445	statsPtr->totalLitStringBytes = 0.0;
sl@0	446	statsPtr->currentLitStringBytes = 0.0;
sl@0	447	(VOID *) memset(statsPtr->literalCount, 0,
sl@0	448	sizeof(statsPtr->literalCount));
sl@0	449	#endif /* TCL_COMPILE_STATS */
sl@0	450
sl@0	451	/*
sl@0	452	* Initialise the stub table pointer.
sl@0	453	*/
sl@0	454
sl@0	455	iPtr->stubTable = &tclStubs;
sl@0	456
sl@0	457
sl@0	458	/*
sl@0	459	* Create the core commands. Do it here, rather than calling
sl@0	460	* Tcl_CreateCommand, because it's faster (there's no need to check for
sl@0	461	* a pre-existing command by the same name). If a command has a
sl@0	462	* Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
sl@0	463	* TclInvokeStringCommand. This is an object-based wrapper procedure
sl@0	464	* that extracts strings, calls the string procedure, and creates an
sl@0	465	* object for the result. Similarly, if a command has a Tcl_ObjCmdProc
sl@0	466	* but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
sl@0	467	*/
sl@0	468
sl@0	469	for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL;
sl@0	470	cmdInfoPtr++) {
sl@0	471	int new;
sl@0	472	Tcl_HashEntry *hPtr;
sl@0	473
sl@0	474	if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL)
sl@0	475	&& (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)
sl@0	476	&& (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
sl@0	477	panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n");
sl@0	478	}
sl@0	479
sl@0	480	hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
sl@0	481	cmdInfoPtr->name, &new);
sl@0	482	if (new) {
sl@0	483	cmdPtr = (Command *) ckalloc(sizeof(Command));
sl@0	484	cmdPtr->hPtr = hPtr;
sl@0	485	cmdPtr->nsPtr = iPtr->globalNsPtr;
sl@0	486	cmdPtr->refCount = 1;
sl@0	487	cmdPtr->cmdEpoch = 0;
sl@0	488	cmdPtr->compileProc = cmdInfoPtr->compileProc;
sl@0	489	if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) {
sl@0	490	cmdPtr->proc = TclInvokeObjectCommand;
sl@0	491	cmdPtr->clientData = (ClientData) cmdPtr;
sl@0	492	} else {
sl@0	493	cmdPtr->proc = cmdInfoPtr->proc;
sl@0	494	cmdPtr->clientData = (ClientData) NULL;
sl@0	495	}
sl@0	496	if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
sl@0	497	cmdPtr->objProc = TclInvokeStringCommand;
sl@0	498	cmdPtr->objClientData = (ClientData) cmdPtr;
sl@0	499	} else {
sl@0	500	cmdPtr->objProc = cmdInfoPtr->objProc;
sl@0	501	cmdPtr->objClientData = (ClientData) NULL;
sl@0	502	}
sl@0	503	cmdPtr->deleteProc = NULL;
sl@0	504	cmdPtr->deleteData = (ClientData) NULL;
sl@0	505	cmdPtr->flags = 0;
sl@0	506	cmdPtr->importRefPtr = NULL;
sl@0	507	cmdPtr->tracePtr = NULL;
sl@0	508	Tcl_SetHashValue(hPtr, cmdPtr);
sl@0	509	}
sl@0	510	}
sl@0	511
sl@0	512	/*
sl@0	513	* Register the builtin math functions.
sl@0	514	*/
sl@0	515
sl@0	516	i = 0;
sl@0	517	for (builtinFuncPtr = tclBuiltinFuncTable; builtinFuncPtr->name != NULL;
sl@0	518	builtinFuncPtr++) {
sl@0	519	Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
sl@0	520	builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
sl@0	521	(Tcl_MathProc *) NULL, (ClientData) 0);
sl@0	522	hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
sl@0	523	builtinFuncPtr->name);
sl@0	524	if (hPtr == NULL) {
sl@0	525	panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name);
sl@0	526	return NULL;
sl@0	527	}
sl@0	528	mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
sl@0	529	mathFuncPtr->builtinFuncIndex = i;
sl@0	530	i++;
sl@0	531	}
sl@0	532	iPtr->flags \|= EXPR_INITIALIZED;
sl@0	533
sl@0	534	/*
sl@0	535	* Do Multiple/Safe Interps Tcl init stuff
sl@0	536	*/
sl@0	537
sl@0	538	TclInterpInit(interp);
sl@0	539
sl@0	540	/*
sl@0	541	* We used to create the "errorInfo" and "errorCode" global vars at this
sl@0	542	* point because so much of the Tcl implementation assumes they already
sl@0	543	* exist. This is not quite enough, however, since they can be unset
sl@0	544	* at any time.
sl@0	545	*
sl@0	546	* There are 2 choices:
sl@0	547	* + Check every place where a GetVar of those is used
sl@0	548	* and the NULL result is not checked (like in tclLoad.c)
sl@0	549	* + Make SetVar,... NULL friendly
sl@0	550	* We choose the second option because :
sl@0	551	* + It is easy and low cost to check for NULL pointer before
sl@0	552	* calling strlen()
sl@0	553	* + It can be helpfull to other people using those API
sl@0	554	* + Passing a NULL value to those closest 'meaning' is empty string
sl@0	555	* (specially with the new objects where 0 bytes strings are ok)
sl@0	556	* So the following init is commented out: -- dl
sl@0	557	*
sl@0	558	* (void) Tcl_SetVar2((Tcl_Interp )iPtr, "errorInfo", (char ) NULL,
sl@0	559	* "", TCL_GLOBAL_ONLY);
sl@0	560	* (void) Tcl_SetVar2((Tcl_Interp )iPtr, "errorCode", (char ) NULL,
sl@0	561	* "NONE", TCL_GLOBAL_ONLY);
sl@0	562	*/
sl@0	563
sl@0	564	#ifndef TCL_GENERIC_ONLY
sl@0	565	TclSetupEnv(interp);
sl@0	566	#endif
sl@0	567
sl@0	568	/*
sl@0	569	* Compute the byte order of this machine.
sl@0	570	*/
sl@0	571
sl@0	572	order.s = 1;
sl@0	573	Tcl_SetVar2(interp, "tcl_platform", "byteOrder",
sl@0	574	((order.c[0] == 1) ? "littleEndian" : "bigEndian"),
sl@0	575	TCL_GLOBAL_ONLY);
sl@0	576
sl@0	577	Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize",
sl@0	578	Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY);
sl@0	579
sl@0	580	/*
sl@0	581	* Set up other variables such as tcl_version and tcl_library
sl@0	582	*/
sl@0	583
sl@0	584	Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
sl@0	585	Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
sl@0	586	Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL,
sl@0	587	TCL_GLOBAL_ONLY\|TCL_TRACE_READS\|TCL_TRACE_WRITES\|TCL_TRACE_UNSETS,
sl@0	588	TclPrecTraceProc, (ClientData) NULL);
sl@0	589	TclpSetVariables(interp);
sl@0	590
sl@0	591	#ifdef TCL_THREADS
sl@0	592	/*
sl@0	593	* The existence of the "threaded" element of the tcl_platform array indicates
sl@0	594	* that this particular Tcl shell has been compiled with threads turned on.
sl@0	595	* Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the
sl@0	596	* interpreter level of thread safety.
sl@0	597	*/
sl@0	598
sl@0	599
sl@0	600	Tcl_SetVar2(interp, "tcl_platform", "threaded", "1",
sl@0	601	TCL_GLOBAL_ONLY);
sl@0	602	#endif
sl@0	603
sl@0	604	/*
sl@0	605	* Register Tcl's version number.
sl@0	606	* TIP#268: Expose information about its status,
sl@0	607	* for runtime switches in the core library
sl@0	608	* and tests.
sl@0	609	*/
sl@0	610
sl@0	611	Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);
sl@0	612
sl@0	613	#ifdef TCL_TIP268
sl@0	614	Tcl_SetVar2(interp, "tcl_platform", "tip,268", "1",
sl@0	615	TCL_GLOBAL_ONLY);
sl@0	616	#endif
sl@0	617	#ifdef TCL_TIP280
sl@0	618	Tcl_SetVar2(interp, "tcl_platform", "tip,280", "1",
sl@0	619	TCL_GLOBAL_ONLY);
sl@0	620	#endif
sl@0	621	#ifdef Tcl_InitStubs
sl@0	622	#undef Tcl_InitStubs
sl@0	623	#endif
sl@0	624	Tcl_InitStubs(interp, TCL_VERSION, 1);
sl@0	625
sl@0	626	return interp;
sl@0	627	}
sl@0	628
sl@0	629	/*
sl@0	630	*----------------------------------------------------------------------
sl@0	631	*
sl@0	632	* TclHideUnsafeCommands --
sl@0	633	*
sl@0	634	* Hides base commands that are not marked as safe from this
sl@0	635	* interpreter.
sl@0	636	*
sl@0	637	* Results:
sl@0	638	* TCL_OK if it succeeds, TCL_ERROR else.
sl@0	639	*
sl@0	640	* Side effects:
sl@0	641	* Hides functionality in an interpreter.
sl@0	642	*
sl@0	643	*----------------------------------------------------------------------
sl@0	644	*/
sl@0	645
sl@0	646	int
sl@0	647	TclHideUnsafeCommands(interp)
sl@0	648	Tcl_Interp interp; / Hide commands in this interpreter. */
sl@0	649	{
sl@0	650	register CmdInfo *cmdInfoPtr;
sl@0	651
sl@0	652	if (interp == (Tcl_Interp *) NULL) {
sl@0	653	return TCL_ERROR;
sl@0	654	}
sl@0	655	for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
sl@0	656	if (!cmdInfoPtr->isSafe) {
sl@0	657	Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
sl@0	658	}
sl@0	659	}
sl@0	660	return TCL_OK;
sl@0	661	}
sl@0	662
sl@0	663	/*
sl@0	664	*--------------------------------------------------------------
sl@0	665	*
sl@0	666	* Tcl_CallWhenDeleted --
sl@0	667	*
sl@0	668	* Arrange for a procedure to be called before a given
sl@0	669	* interpreter is deleted. The procedure is called as soon
sl@0	670	* as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
sl@0	671	* called on an interpreter that has already been deleted,
sl@0	672	* the procedure will be called when the last Tcl_Release is
sl@0	673	* done on the interpreter.
sl@0	674	*
sl@0	675	* Results:
sl@0	676	* None.
sl@0	677	*
sl@0	678	* Side effects:
sl@0	679	* When Tcl_DeleteInterp is invoked to delete interp,
sl@0	680	* proc will be invoked. See the manual entry for
sl@0	681	* details.
sl@0	682	*
sl@0	683	*--------------------------------------------------------------
sl@0	684	*/
sl@0	685
sl@0	686	EXPORT_C void
sl@0	687	Tcl_CallWhenDeleted(interp, proc, clientData)
sl@0	688	Tcl_Interp interp; / Interpreter to watch. */
sl@0	689	Tcl_InterpDeleteProc proc; / Procedure to call when interpreter
sl@0	690	* is about to be deleted. */
sl@0	691	ClientData clientData; /* One-word value to pass to proc. */
sl@0	692	{
sl@0	693	Interp iPtr = (Interp ) interp;
sl@0	694	static Tcl_ThreadDataKey assocDataCounterKey;
sl@0	695	int *assocDataCounterPtr =
sl@0	696	Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int));
sl@0	697	int new;
sl@0	698	char buffer[32 + TCL_INTEGER_SPACE];
sl@0	699	AssocData dPtr = (AssocData ) ckalloc(sizeof(AssocData));
sl@0	700	Tcl_HashEntry *hPtr;
sl@0	701
sl@0	702	sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
sl@0	703	(*assocDataCounterPtr)++;
sl@0	704
sl@0	705	if (iPtr->assocData == (Tcl_HashTable *) NULL) {
sl@0	706	iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
sl@0	707	Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
sl@0	708	}
sl@0	709	hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
sl@0	710	dPtr->proc = proc;
sl@0	711	dPtr->clientData = clientData;
sl@0	712	Tcl_SetHashValue(hPtr, dPtr);
sl@0	713	}
sl@0	714
sl@0	715	/*
sl@0	716	*--------------------------------------------------------------
sl@0	717	*
sl@0	718	* Tcl_DontCallWhenDeleted --
sl@0	719	*
sl@0	720	* Cancel the arrangement for a procedure to be called when
sl@0	721	* a given interpreter is deleted.
sl@0	722	*
sl@0	723	* Results:
sl@0	724	* None.
sl@0	725	*
sl@0	726	* Side effects:
sl@0	727	* If proc and clientData were previously registered as a
sl@0	728	* callback via Tcl_CallWhenDeleted, they are unregistered.
sl@0	729	* If they weren't previously registered then nothing
sl@0	730	* happens.
sl@0	731	*
sl@0	732	*--------------------------------------------------------------
sl@0	733	*/
sl@0	734
sl@0	735	EXPORT_C void
sl@0	736	Tcl_DontCallWhenDeleted(interp, proc, clientData)
sl@0	737	Tcl_Interp interp; / Interpreter to watch. */
sl@0	738	Tcl_InterpDeleteProc proc; / Procedure to call when interpreter
sl@0	739	* is about to be deleted. */
sl@0	740	ClientData clientData; /* One-word value to pass to proc. */
sl@0	741	{
sl@0	742	Interp iPtr = (Interp ) interp;
sl@0	743	Tcl_HashTable *hTablePtr;
sl@0	744	Tcl_HashSearch hSearch;
sl@0	745	Tcl_HashEntry *hPtr;
sl@0	746	AssocData *dPtr;
sl@0	747
sl@0	748	hTablePtr = iPtr->assocData;
sl@0	749	if (hTablePtr == (Tcl_HashTable *) NULL) {
sl@0	750	return;
sl@0	751	}
sl@0	752	for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
sl@0	753	hPtr = Tcl_NextHashEntry(&hSearch)) {
sl@0	754	dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
sl@0	755	if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
sl@0	756	ckfree((char *) dPtr);
sl@0	757	Tcl_DeleteHashEntry(hPtr);
sl@0	758	return;
sl@0	759	}
sl@0	760	}
sl@0	761	}
sl@0	762
sl@0	763	/*
sl@0	764	*----------------------------------------------------------------------
sl@0	765	*
sl@0	766	* Tcl_SetAssocData --
sl@0	767	*
sl@0	768	* Creates a named association between user-specified data, a delete
sl@0	769	* function and this interpreter. If the association already exists
sl@0	770	* the data is overwritten with the new data. The delete function will
sl@0	771	* be invoked when the interpreter is deleted.
sl@0	772	*
sl@0	773	* Results:
sl@0	774	* None.
sl@0	775	*
sl@0	776	* Side effects:
sl@0	777	* Sets the associated data, creates the association if needed.
sl@0	778	*
sl@0	779	*----------------------------------------------------------------------
sl@0	780	*/
sl@0	781
sl@0	782	EXPORT_C void
sl@0	783	Tcl_SetAssocData(interp, name, proc, clientData)
sl@0	784	Tcl_Interp interp; / Interpreter to associate with. */
sl@0	785	CONST char name; / Name for association. */
sl@0	786	Tcl_InterpDeleteProc proc; / Proc to call when interpreter is
sl@0	787	* about to be deleted. */
sl@0	788	ClientData clientData; /* One-word value to pass to proc. */
sl@0	789	{
sl@0	790	Interp iPtr = (Interp ) interp;
sl@0	791	AssocData *dPtr;
sl@0	792	Tcl_HashEntry *hPtr;
sl@0	793	int new;
sl@0	794
sl@0	795	if (iPtr->assocData == (Tcl_HashTable *) NULL) {
sl@0	796	iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
sl@0	797	Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
sl@0	798	}
sl@0	799	hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
sl@0	800	if (new == 0) {
sl@0	801	dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
sl@0	802	} else {
sl@0	803	dPtr = (AssocData *) ckalloc(sizeof(AssocData));
sl@0	804	}
sl@0	805	dPtr->proc = proc;
sl@0	806	dPtr->clientData = clientData;
sl@0	807
sl@0	808	Tcl_SetHashValue(hPtr, dPtr);
sl@0	809	}
sl@0	810
sl@0	811	/*
sl@0	812	*----------------------------------------------------------------------
sl@0	813	*
sl@0	814	* Tcl_DeleteAssocData --
sl@0	815	*
sl@0	816	* Deletes a named association of user-specified data with
sl@0	817	* the specified interpreter.
sl@0	818	*
sl@0	819	* Results:
sl@0	820	* None.
sl@0	821	*
sl@0	822	* Side effects:
sl@0	823	* Deletes the association.
sl@0	824	*
sl@0	825	*----------------------------------------------------------------------
sl@0	826	*/
sl@0	827
sl@0	828	EXPORT_C void
sl@0	829	Tcl_DeleteAssocData(interp, name)
sl@0	830	Tcl_Interp interp; / Interpreter to associate with. */
sl@0	831	CONST char name; / Name of association. */
sl@0	832	{
sl@0	833	Interp iPtr = (Interp ) interp;
sl@0	834	AssocData *dPtr;
sl@0	835	Tcl_HashEntry *hPtr;
sl@0	836
sl@0	837	if (iPtr->assocData == (Tcl_HashTable *) NULL) {
sl@0	838	return;
sl@0	839	}
sl@0	840	hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
sl@0	841	if (hPtr == (Tcl_HashEntry *) NULL) {
sl@0	842	return;
sl@0	843	}
sl@0	844	dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
sl@0	845	if (dPtr->proc != NULL) {
sl@0	846	(dPtr->proc) (dPtr->clientData, interp);
sl@0	847	}
sl@0	848	ckfree((char *) dPtr);
sl@0	849	Tcl_DeleteHashEntry(hPtr);
sl@0	850	}
sl@0	851
sl@0	852	/*
sl@0	853	*----------------------------------------------------------------------
sl@0	854	*
sl@0	855	* Tcl_GetAssocData --
sl@0	856	*
sl@0	857	* Returns the client data associated with this name in the
sl@0	858	* specified interpreter.
sl@0	859	*
sl@0	860	* Results:
sl@0	861	* The client data in the AssocData record denoted by the named
sl@0	862	* association, or NULL.
sl@0	863	*
sl@0	864	* Side effects:
sl@0	865	* None.
sl@0	866	*
sl@0	867	*----------------------------------------------------------------------
sl@0	868	*/
sl@0	869
sl@0	870	EXPORT_C ClientData
sl@0	871	Tcl_GetAssocData(interp, name, procPtr)
sl@0	872	Tcl_Interp interp; / Interpreter associated with. */
sl@0	873	CONST char name; / Name of association. */
sl@0	874	Tcl_InterpDeleteProc *procPtr; / Pointer to place to store address
sl@0	875	* of current deletion callback. */
sl@0	876	{
sl@0	877	Interp iPtr = (Interp ) interp;
sl@0	878	AssocData *dPtr;
sl@0	879	Tcl_HashEntry *hPtr;
sl@0	880
sl@0	881	if (iPtr->assocData == (Tcl_HashTable *) NULL) {
sl@0	882	return (ClientData) NULL;
sl@0	883	}
sl@0	884	hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
sl@0	885	if (hPtr == (Tcl_HashEntry *) NULL) {
sl@0	886	return (ClientData) NULL;
sl@0	887	}
sl@0	888	dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
sl@0	889	if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
sl@0	890	*procPtr = dPtr->proc;
sl@0	891	}
sl@0	892	return dPtr->clientData;
sl@0	893	}
sl@0	894
sl@0	895	/*
sl@0	896	*----------------------------------------------------------------------
sl@0	897	*
sl@0	898	* Tcl_InterpDeleted --
sl@0	899	*
sl@0	900	* Returns nonzero if the interpreter has been deleted with a call
sl@0	901	* to Tcl_DeleteInterp.
sl@0	902	*
sl@0	903	* Results:
sl@0	904	* Nonzero if the interpreter is deleted, zero otherwise.
sl@0	905	*
sl@0	906	* Side effects:
sl@0	907	* None.
sl@0	908	*
sl@0	909	*----------------------------------------------------------------------
sl@0	910	*/
sl@0	911
sl@0	912	EXPORT_C int
sl@0	913	Tcl_InterpDeleted(interp)
sl@0	914	Tcl_Interp *interp;
sl@0	915	{
sl@0	916	return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
sl@0	917	}
sl@0	918
sl@0	919	/*
sl@0	920	*----------------------------------------------------------------------
sl@0	921	*
sl@0	922	* Tcl_DeleteInterp --
sl@0	923	*
sl@0	924	* Ensures that the interpreter will be deleted eventually. If there
sl@0	925	* are no Tcl_Preserve calls in effect for this interpreter, it is
sl@0	926	* deleted immediately, otherwise the interpreter is deleted when
sl@0	927	* the last Tcl_Preserve is matched by a call to Tcl_Release. In either
sl@0	928	* case, the procedure runs the currently registered deletion callbacks.
sl@0	929	*
sl@0	930	* Results:
sl@0	931	* None.
sl@0	932	*
sl@0	933	* Side effects:
sl@0	934	* The interpreter is marked as deleted. The caller may still use it
sl@0	935	* safely if there are calls to Tcl_Preserve in effect for the
sl@0	936	* interpreter, but further calls to Tcl_Eval etc in this interpreter
sl@0	937	* will fail.
sl@0	938	*
sl@0	939	*----------------------------------------------------------------------
sl@0	940	*/
sl@0	941
sl@0	942	EXPORT_C void
sl@0	943	Tcl_DeleteInterp(interp)
sl@0	944	Tcl_Interp interp; / Token for command interpreter (returned
sl@0	945	* by a previous call to Tcl_CreateInterp). */
sl@0	946	{
sl@0	947	Interp iPtr = (Interp ) interp;
sl@0	948
sl@0	949	/*
sl@0	950	* If the interpreter has already been marked deleted, just punt.
sl@0	951	*/
sl@0	952
sl@0	953	if (iPtr->flags & DELETED) {
sl@0	954	return;
sl@0	955	}
sl@0	956
sl@0	957	/*
sl@0	958	* Mark the interpreter as deleted. No further evals will be allowed.
sl@0	959	*/
sl@0	960
sl@0	961	iPtr->flags \|= DELETED;
sl@0	962
sl@0	963	/*
sl@0	964	* Ensure that the interpreter is eventually deleted.
sl@0	965	*/
sl@0	966
sl@0	967	Tcl_EventuallyFree((ClientData) interp,
sl@0	968	(Tcl_FreeProc *) DeleteInterpProc);
sl@0	969	}
sl@0	970
sl@0	971	/*
sl@0	972	*----------------------------------------------------------------------
sl@0	973	*
sl@0	974	* DeleteInterpProc --
sl@0	975	*
sl@0	976	* Helper procedure to delete an interpreter. This procedure is
sl@0	977	* called when the last call to Tcl_Preserve on this interpreter
sl@0	978	* is matched by a call to Tcl_Release. The procedure cleans up
sl@0	979	* all resources used in the interpreter and calls all currently
sl@0	980	* registered interpreter deletion callbacks.
sl@0	981	*
sl@0	982	* Results:
sl@0	983	* None.
sl@0	984	*
sl@0	985	* Side effects:
sl@0	986	* Whatever the interpreter deletion callbacks do. Frees resources
sl@0	987	* used by the interpreter.
sl@0	988	*
sl@0	989	*----------------------------------------------------------------------
sl@0	990	*/
sl@0	991
sl@0	992	static void
sl@0	993	DeleteInterpProc(interp)
sl@0	994	Tcl_Interp interp; / Interpreter to delete. */
sl@0	995	{
sl@0	996	Interp iPtr = (Interp ) interp;
sl@0	997	Tcl_HashEntry *hPtr;
sl@0	998	Tcl_HashSearch search;
sl@0	999	Tcl_HashTable *hTablePtr;
sl@0	1000	ResolverScheme resPtr, nextResPtr;
sl@0	1001
sl@0	1002	/*
sl@0	1003	* Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
sl@0	1004	*/
sl@0	1005
sl@0	1006	if (iPtr->numLevels > 0) {
sl@0	1007	panic("DeleteInterpProc called with active evals");
sl@0	1008	}
sl@0	1009
sl@0	1010	/*
sl@0	1011	* The interpreter should already be marked deleted; otherwise how
sl@0	1012	* did we get here?
sl@0	1013	*/
sl@0	1014
sl@0	1015	if (!(iPtr->flags & DELETED)) {
sl@0	1016	panic("DeleteInterpProc called on interpreter not marked deleted");
sl@0	1017	}
sl@0	1018
sl@0	1019	TclHandleFree(iPtr->handle);
sl@0	1020
sl@0	1021	/*
sl@0	1022	* Dismantle everything in the global namespace except for the
sl@0	1023	* "errorInfo" and "errorCode" variables. These remain until the
sl@0	1024	* namespace is actually destroyed, in case any errors occur.
sl@0	1025	*
sl@0	1026	* Dismantle the namespace here, before we clear the assocData. If any
sl@0	1027	* background errors occur here, they will be deleted below.
sl@0	1028	*/
sl@0	1029
sl@0	1030	TclTeardownNamespace(iPtr->globalNsPtr);
sl@0	1031
sl@0	1032	/*
sl@0	1033	* Delete all the hidden commands.
sl@0	1034	*/
sl@0	1035
sl@0	1036	hTablePtr = iPtr->hiddenCmdTablePtr;
sl@0	1037	if (hTablePtr != NULL) {
sl@0	1038	/*
sl@0	1039	* Non-pernicious deletion. The deletion callbacks will not be
sl@0	1040	* allowed to create any new hidden or non-hidden commands.
sl@0	1041	* Tcl_DeleteCommandFromToken() will remove the entry from the
sl@0	1042	* hiddenCmdTablePtr.
sl@0	1043	*/
sl@0	1044
sl@0	1045	hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
sl@0	1046	for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
sl@0	1047	Tcl_DeleteCommandFromToken(interp,
sl@0	1048	(Tcl_Command) Tcl_GetHashValue(hPtr));
sl@0	1049	}
sl@0	1050	Tcl_DeleteHashTable(hTablePtr);
sl@0	1051	ckfree((char *) hTablePtr);
sl@0	1052	}
sl@0	1053	/*
sl@0	1054	* Tear down the math function table.
sl@0	1055	*/
sl@0	1056
sl@0	1057	for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
sl@0	1058	hPtr != NULL;
sl@0	1059	hPtr = Tcl_NextHashEntry(&search)) {
sl@0	1060	ckfree((char *) Tcl_GetHashValue(hPtr));
sl@0	1061	}
sl@0	1062	Tcl_DeleteHashTable(&iPtr->mathFuncTable);
sl@0	1063
sl@0	1064	/*
sl@0	1065	* Invoke deletion callbacks; note that a callback can create new
sl@0	1066	* callbacks, so we iterate.
sl@0	1067	*/
sl@0	1068
sl@0	1069	while (iPtr->assocData != (Tcl_HashTable *) NULL) {
sl@0	1070	AssocData *dPtr;
sl@0	1071
sl@0	1072	hTablePtr = iPtr->assocData;
sl@0	1073	iPtr->assocData = (Tcl_HashTable *) NULL;
sl@0	1074	for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
sl@0	1075	hPtr != NULL;
sl@0	1076	hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
sl@0	1077	dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
sl@0	1078	Tcl_DeleteHashEntry(hPtr);
sl@0	1079	if (dPtr->proc != NULL) {
sl@0	1080	(*dPtr->proc)(dPtr->clientData, interp);
sl@0	1081	}
sl@0	1082	ckfree((char *) dPtr);
sl@0	1083	}
sl@0	1084	Tcl_DeleteHashTable(hTablePtr);
sl@0	1085	ckfree((char *) hTablePtr);
sl@0	1086	}
sl@0	1087
sl@0	1088	/*
sl@0	1089	* Finish deleting the global namespace.
sl@0	1090	*/
sl@0	1091
sl@0	1092	Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
sl@0	1093
sl@0	1094	/*
sl@0	1095	* Free up the result after deleting variables, since variable
sl@0	1096	* deletion could have transferred ownership of the result string
sl@0	1097	* to Tcl.
sl@0	1098	*/
sl@0	1099
sl@0	1100	Tcl_FreeResult(interp);
sl@0	1101	interp->result = NULL;
sl@0	1102	Tcl_DecrRefCount(iPtr->objResultPtr);
sl@0	1103	iPtr->objResultPtr = NULL;
sl@0	1104	if (iPtr->errorInfo != NULL) {
sl@0	1105	ckfree(iPtr->errorInfo);
sl@0	1106	iPtr->errorInfo = NULL;
sl@0	1107	}
sl@0	1108	if (iPtr->errorCode != NULL) {
sl@0	1109	ckfree(iPtr->errorCode);
sl@0	1110	iPtr->errorCode = NULL;
sl@0	1111	}
sl@0	1112	if (iPtr->appendResult != NULL) {
sl@0	1113	ckfree(iPtr->appendResult);
sl@0	1114	iPtr->appendResult = NULL;
sl@0	1115	}
sl@0	1116	TclFreePackageInfo(iPtr);
sl@0	1117	while (iPtr->tracePtr != NULL) {
sl@0	1118	Tcl_DeleteTrace((Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr);
sl@0	1119	}
sl@0	1120	if (iPtr->execEnvPtr != NULL) {
sl@0	1121	TclDeleteExecEnv(iPtr->execEnvPtr);
sl@0	1122	}
sl@0	1123	Tcl_DecrRefCount(iPtr->emptyObjPtr);
sl@0	1124	iPtr->emptyObjPtr = NULL;
sl@0	1125
sl@0	1126	resPtr = iPtr->resolverPtr;
sl@0	1127	while (resPtr) {
sl@0	1128	nextResPtr = resPtr->nextPtr;
sl@0	1129	ckfree(resPtr->name);
sl@0	1130	ckfree((char *) resPtr);
sl@0	1131	resPtr = nextResPtr;
sl@0	1132	}
sl@0	1133
sl@0	1134	/*
sl@0	1135	* Free up literal objects created for scripts compiled by the
sl@0	1136	* interpreter.
sl@0	1137	*/
sl@0	1138
sl@0	1139	TclDeleteLiteralTable(interp, &(iPtr->literalTable));
sl@0	1140
sl@0	1141	#ifdef TCL_TIP280
sl@0	1142	/* TIP #280 - Release the arrays for ByteCode/Proc extension, and contents.
sl@0	1143	*/
sl@0	1144	{
sl@0	1145	Tcl_HashEntry *hPtr;
sl@0	1146	Tcl_HashSearch hSearch;
sl@0	1147	CmdFrame* cfPtr;
sl@0	1148	ExtCmdLoc* eclPtr;
sl@0	1149	int i;
sl@0	1150
sl@0	1151	for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch);
sl@0	1152	hPtr != NULL;
sl@0	1153	hPtr = Tcl_NextHashEntry(&hSearch)) {
sl@0	1154
sl@0	1155	cfPtr = (CmdFrame*) Tcl_GetHashValue (hPtr);
sl@0	1156
sl@0	1157	if (cfPtr->type == TCL_LOCATION_SOURCE) {
sl@0	1158	Tcl_DecrRefCount (cfPtr->data.eval.path);
sl@0	1159	}
sl@0	1160	ckfree ((char*) cfPtr->line);
sl@0	1161	ckfree ((char*) cfPtr);
sl@0	1162	Tcl_DeleteHashEntry (hPtr);
sl@0	1163
sl@0	1164	}
sl@0	1165	Tcl_DeleteHashTable (iPtr->linePBodyPtr);
sl@0	1166	ckfree ((char*) iPtr->linePBodyPtr);
sl@0	1167	iPtr->linePBodyPtr = NULL;
sl@0	1168
sl@0	1169	/* See also tclCompile.c, TclCleanupByteCode */
sl@0	1170
sl@0	1171	for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch);
sl@0	1172	hPtr != NULL;
sl@0	1173	hPtr = Tcl_NextHashEntry(&hSearch)) {
sl@0	1174
sl@0	1175	eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hPtr);
sl@0	1176
sl@0	1177	if (eclPtr->type == TCL_LOCATION_SOURCE) {
sl@0	1178	Tcl_DecrRefCount (eclPtr->path);
sl@0	1179	}
sl@0	1180	for (i=0; i< eclPtr->nuloc; i++) {
sl@0	1181	ckfree ((char*) eclPtr->loc[i].line);
sl@0	1182	}
sl@0	1183
sl@0	1184	if (eclPtr->loc != NULL) {
sl@0	1185	ckfree ((char*) eclPtr->loc);
sl@0	1186	}
sl@0	1187
sl@0	1188	ckfree ((char*) eclPtr);
sl@0	1189	Tcl_DeleteHashEntry (hPtr);
sl@0	1190	}
sl@0	1191	Tcl_DeleteHashTable (iPtr->lineBCPtr);
sl@0	1192	ckfree((char*) iPtr->lineBCPtr);
sl@0	1193	iPtr->lineBCPtr = NULL;
sl@0	1194	}
sl@0	1195	#endif
sl@0	1196	ckfree((char *) iPtr);
sl@0	1197	}
sl@0	1198
sl@0	1199	/*
sl@0	1200	*---------------------------------------------------------------------------
sl@0	1201	*
sl@0	1202	* Tcl_HideCommand --
sl@0	1203	*
sl@0	1204	* Makes a command hidden so that it cannot be invoked from within
sl@0	1205	* an interpreter, only from within an ancestor.
sl@0	1206	*
sl@0	1207	* Results:
sl@0	1208	* A standard Tcl result; also leaves a message in the interp's result
sl@0	1209	* if an error occurs.
sl@0	1210	*
sl@0	1211	* Side effects:
sl@0	1212	* Removes a command from the command table and create an entry
sl@0	1213	* into the hidden command table under the specified token name.
sl@0	1214	*
sl@0	1215	*---------------------------------------------------------------------------
sl@0	1216	*/
sl@0	1217
sl@0	1218	EXPORT_C int
sl@0	1219	Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
sl@0	1220	Tcl_Interp interp; / Interpreter in which to hide command. */
sl@0	1221	CONST char cmdName; / Name of command to hide. */
sl@0	1222	CONST char hiddenCmdToken; / Token name of the to-be-hidden command. */
sl@0	1223	{
sl@0	1224	Interp iPtr = (Interp ) interp;
sl@0	1225	Tcl_Command cmd;
sl@0	1226	Command *cmdPtr;
sl@0	1227	Tcl_HashTable *hiddenCmdTablePtr;
sl@0	1228	Tcl_HashEntry *hPtr;
sl@0	1229	int new;
sl@0	1230
sl@0	1231	if (iPtr->flags & DELETED) {
sl@0	1232
sl@0	1233	/*
sl@0	1234	* The interpreter is being deleted. Do not create any new
sl@0	1235	* structures, because it is not safe to modify the interpreter.
sl@0	1236	*/
sl@0	1237
sl@0	1238	return TCL_ERROR;
sl@0	1239	}
sl@0	1240
sl@0	1241	/*
sl@0	1242	* Disallow hiding of commands that are currently in a namespace or
sl@0	1243	* renaming (as part of hiding) into a namespace.
sl@0	1244	*
sl@0	1245	* (because the current implementation with a single global table
sl@0	1246	* and the needed uniqueness of names cause problems with namespaces)
sl@0	1247	*
sl@0	1248	* we don't need to check for "::" in cmdName because the real check is
sl@0	1249	* on the nsPtr below.
sl@0	1250	*
sl@0	1251	* hiddenCmdToken is just a string which is not interpreted in any way.
sl@0	1252	* It may contain :: but the string is not interpreted as a namespace
sl@0	1253	* qualifier command name. Thus, hiding foo::bar to foo::bar and then
sl@0	1254	* trying to expose or invoke ::foo::bar will NOT work; but if the
sl@0	1255	* application always uses the same strings it will get consistent
sl@0	1256	* behaviour.
sl@0	1257	*
sl@0	1258	* But as we currently limit ourselves to the global namespace only
sl@0	1259	* for the source, in order to avoid potential confusion,
sl@0	1260	* lets prevent "::" in the token too. --dl
sl@0	1261	*/
sl@0	1262
sl@0	1263	if (strstr(hiddenCmdToken, "::") != NULL) {
sl@0	1264	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1265	"cannot use namespace qualifiers in hidden command",
sl@0	1266	" token (rename)", (char *) NULL);
sl@0	1267	return TCL_ERROR;
sl@0	1268	}
sl@0	1269
sl@0	1270	/*
sl@0	1271	* Find the command to hide. An error is returned if cmdName can't
sl@0	1272	* be found. Look up the command only from the global namespace.
sl@0	1273	* Full path of the command must be given if using namespaces.
sl@0	1274	*/
sl@0	1275
sl@0	1276	cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
sl@0	1277	/flags/ TCL_LEAVE_ERR_MSG \| TCL_GLOBAL_ONLY);
sl@0	1278	if (cmd == (Tcl_Command) NULL) {
sl@0	1279	return TCL_ERROR;
sl@0	1280	}
sl@0	1281	cmdPtr = (Command *) cmd;
sl@0	1282
sl@0	1283	/*
sl@0	1284	* Check that the command is really in global namespace
sl@0	1285	*/
sl@0	1286
sl@0	1287	if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
sl@0	1288	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1289	"can only hide global namespace commands",
sl@0	1290	" (use rename then hide)", (char *) NULL);
sl@0	1291	return TCL_ERROR;
sl@0	1292	}
sl@0	1293
sl@0	1294	/*
sl@0	1295	* Initialize the hidden command table if necessary.
sl@0	1296	*/
sl@0	1297
sl@0	1298	hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
sl@0	1299	if (hiddenCmdTablePtr == NULL) {
sl@0	1300	hiddenCmdTablePtr = (Tcl_HashTable *)
sl@0	1301	ckalloc((unsigned) sizeof(Tcl_HashTable));
sl@0	1302	Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
sl@0	1303	iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
sl@0	1304	}
sl@0	1305
sl@0	1306	/*
sl@0	1307	* It is an error to move an exposed command to a hidden command with
sl@0	1308	* hiddenCmdToken if a hidden command with the name hiddenCmdToken already
sl@0	1309	* exists.
sl@0	1310	*/
sl@0	1311
sl@0	1312	hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new);
sl@0	1313	if (!new) {
sl@0	1314	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1315	"hidden command named \"", hiddenCmdToken, "\" already exists",
sl@0	1316	(char *) NULL);
sl@0	1317	return TCL_ERROR;
sl@0	1318	}
sl@0	1319
sl@0	1320	/*
sl@0	1321	* Nb : This code is currently 'like' a rename to a specialy set apart
sl@0	1322	* name table. Changes here and in TclRenameCommand must
sl@0	1323	* be kept in synch untill the common parts are actually
sl@0	1324	* factorized out.
sl@0	1325	*/
sl@0	1326
sl@0	1327	/*
sl@0	1328	* Remove the hash entry for the command from the interpreter command
sl@0	1329	* table. This is like deleting the command, so bump its command epoch;
sl@0	1330	* this invalidates any cached references that point to the command.
sl@0	1331	*/
sl@0	1332
sl@0	1333	if (cmdPtr->hPtr != NULL) {
sl@0	1334	Tcl_DeleteHashEntry(cmdPtr->hPtr);
sl@0	1335	cmdPtr->hPtr = (Tcl_HashEntry *) NULL;
sl@0	1336	cmdPtr->cmdEpoch++;
sl@0	1337	}
sl@0	1338
sl@0	1339	/*
sl@0	1340	* Now link the hash table entry with the command structure.
sl@0	1341	* We ensured above that the nsPtr was right.
sl@0	1342	*/
sl@0	1343
sl@0	1344	cmdPtr->hPtr = hPtr;
sl@0	1345	Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
sl@0	1346
sl@0	1347	/*
sl@0	1348	* If the command being hidden has a compile procedure, increment the
sl@0	1349	* interpreter's compileEpoch to invalidate its compiled code. This
sl@0	1350	* makes sure that we don't later try to execute old code compiled with
sl@0	1351	* command-specific (i.e., inline) bytecodes for the now-hidden
sl@0	1352	* command. This field is checked in Tcl_EvalObj and ObjInterpProc,
sl@0	1353	* and code whose compilation epoch doesn't match is recompiled.
sl@0	1354	*/
sl@0	1355
sl@0	1356	if (cmdPtr->compileProc != NULL) {
sl@0	1357	iPtr->compileEpoch++;
sl@0	1358	}
sl@0	1359	return TCL_OK;
sl@0	1360	}
sl@0	1361
sl@0	1362	/*
sl@0	1363	*----------------------------------------------------------------------
sl@0	1364	*
sl@0	1365	* Tcl_ExposeCommand --
sl@0	1366	*
sl@0	1367	* Makes a previously hidden command callable from inside the
sl@0	1368	* interpreter instead of only by its ancestors.
sl@0	1369	*
sl@0	1370	* Results:
sl@0	1371	* A standard Tcl result. If an error occurs, a message is left
sl@0	1372	* in the interp's result.
sl@0	1373	*
sl@0	1374	* Side effects:
sl@0	1375	* Moves commands from one hash table to another.
sl@0	1376	*
sl@0	1377	*----------------------------------------------------------------------
sl@0	1378	*/
sl@0	1379
sl@0	1380	EXPORT_C int
sl@0	1381	Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
sl@0	1382	Tcl_Interp interp; / Interpreter in which to make command
sl@0	1383	* callable. */
sl@0	1384	CONST char hiddenCmdToken; / Name of hidden command. */
sl@0	1385	CONST char cmdName; / Name of to-be-exposed command. */
sl@0	1386	{
sl@0	1387	Interp iPtr = (Interp ) interp;
sl@0	1388	Command *cmdPtr;
sl@0	1389	Namespace *nsPtr;
sl@0	1390	Tcl_HashEntry *hPtr;
sl@0	1391	Tcl_HashTable *hiddenCmdTablePtr;
sl@0	1392	int new;
sl@0	1393
sl@0	1394	if (iPtr->flags & DELETED) {
sl@0	1395	/*
sl@0	1396	* The interpreter is being deleted. Do not create any new
sl@0	1397	* structures, because it is not safe to modify the interpreter.
sl@0	1398	*/
sl@0	1399
sl@0	1400	return TCL_ERROR;
sl@0	1401	}
sl@0	1402
sl@0	1403	/*
sl@0	1404	* Check that we have a regular name for the command
sl@0	1405	* (that the user is not trying to do an expose and a rename
sl@0	1406	* (to another namespace) at the same time)
sl@0	1407	*/
sl@0	1408
sl@0	1409	if (strstr(cmdName, "::") != NULL) {
sl@0	1410	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1411	"can not expose to a namespace ",
sl@0	1412	"(use expose to toplevel, then rename)",
sl@0	1413	(char *) NULL);
sl@0	1414	return TCL_ERROR;
sl@0	1415	}
sl@0	1416
sl@0	1417	/*
sl@0	1418	* Get the command from the hidden command table:
sl@0	1419	*/
sl@0	1420
sl@0	1421	hPtr = NULL;
sl@0	1422	hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
sl@0	1423	if (hiddenCmdTablePtr != NULL) {
sl@0	1424	hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
sl@0	1425	}
sl@0	1426	if (hPtr == (Tcl_HashEntry *) NULL) {
sl@0	1427	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1428	"unknown hidden command \"", hiddenCmdToken,
sl@0	1429	"\"", (char *) NULL);
sl@0	1430	return TCL_ERROR;
sl@0	1431	}
sl@0	1432	cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
sl@0	1433
sl@0	1434
sl@0	1435	/*
sl@0	1436	* Check that we have a true global namespace
sl@0	1437	* command (enforced by Tcl_HideCommand() but let's double
sl@0	1438	* check. (If it was not, we would not really know how to
sl@0	1439	* handle it).
sl@0	1440	*/
sl@0	1441	if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
sl@0	1442	/*
sl@0	1443	* This case is theoritically impossible,
sl@0	1444	* we might rather panic() than 'nicely' erroring out ?
sl@0	1445	*/
sl@0	1446	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1447	"trying to expose a non global command name space command",
sl@0	1448	(char *) NULL);
sl@0	1449	return TCL_ERROR;
sl@0	1450	}
sl@0	1451
sl@0	1452	/* This is the global table */
sl@0	1453	nsPtr = cmdPtr->nsPtr;
sl@0	1454
sl@0	1455	/*
sl@0	1456	* It is an error to overwrite an existing exposed command as a result
sl@0	1457	* of exposing a previously hidden command.
sl@0	1458	*/
sl@0	1459
sl@0	1460	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
sl@0	1461	if (!new) {
sl@0	1462	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1463	"exposed command \"", cmdName,
sl@0	1464	"\" already exists", (char *) NULL);
sl@0	1465	return TCL_ERROR;
sl@0	1466	}
sl@0	1467
sl@0	1468	/*
sl@0	1469	* Remove the hash entry for the command from the interpreter hidden
sl@0	1470	* command table.
sl@0	1471	*/
sl@0	1472
sl@0	1473	if (cmdPtr->hPtr != NULL) {
sl@0	1474	Tcl_DeleteHashEntry(cmdPtr->hPtr);
sl@0	1475	cmdPtr->hPtr = NULL;
sl@0	1476	}
sl@0	1477
sl@0	1478	/*
sl@0	1479	* Now link the hash table entry with the command structure.
sl@0	1480	* This is like creating a new command, so deal with any shadowing
sl@0	1481	* of commands in the global namespace.
sl@0	1482	*/
sl@0	1483
sl@0	1484	cmdPtr->hPtr = hPtr;
sl@0	1485
sl@0	1486	Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
sl@0	1487
sl@0	1488	/*
sl@0	1489	* Not needed as we are only in the global namespace
sl@0	1490	* (but would be needed again if we supported namespace command hiding)
sl@0	1491	*
sl@0	1492	* TclResetShadowedCmdRefs(interp, cmdPtr);
sl@0	1493	*/
sl@0	1494
sl@0	1495
sl@0	1496	/*
sl@0	1497	* If the command being exposed has a compile procedure, increment
sl@0	1498	* interpreter's compileEpoch to invalidate its compiled code. This
sl@0	1499	* makes sure that we don't later try to execute old code compiled
sl@0	1500	* assuming the command is hidden. This field is checked in Tcl_EvalObj
sl@0	1501	* and ObjInterpProc, and code whose compilation epoch doesn't match is
sl@0	1502	* recompiled.
sl@0	1503	*/
sl@0	1504
sl@0	1505	if (cmdPtr->compileProc != NULL) {
sl@0	1506	iPtr->compileEpoch++;
sl@0	1507	}
sl@0	1508	return TCL_OK;
sl@0	1509	}
sl@0	1510
sl@0	1511	/*
sl@0	1512	*----------------------------------------------------------------------
sl@0	1513	*
sl@0	1514	* Tcl_CreateCommand --
sl@0	1515	*
sl@0	1516	* Define a new command in a command table.
sl@0	1517	*
sl@0	1518	* Results:
sl@0	1519	* The return value is a token for the command, which can
sl@0	1520	* be used in future calls to Tcl_GetCommandName.
sl@0	1521	*
sl@0	1522	* Side effects:
sl@0	1523	* If a command named cmdName already exists for interp, it is deleted.
sl@0	1524	* In the future, when cmdName is seen as the name of a command by
sl@0	1525	* Tcl_Eval, proc will be called. To support the bytecode interpreter,
sl@0	1526	* the command is created with a wrapper Tcl_ObjCmdProc
sl@0	1527	* (TclInvokeStringCommand) that eventially calls proc. When the
sl@0	1528	* command is deleted from the table, deleteProc will be called.
sl@0	1529	* See the manual entry for details on the calling sequence.
sl@0	1530	*
sl@0	1531	*----------------------------------------------------------------------
sl@0	1532	*/
sl@0	1533
sl@0	1534	EXPORT_C Tcl_Command
sl@0	1535	Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
sl@0	1536	Tcl_Interp interp; / Token for command interpreter returned by
sl@0	1537	* a previous call to Tcl_CreateInterp. */
sl@0	1538	CONST char cmdName; / Name of command. If it contains namespace
sl@0	1539	* qualifiers, the new command is put in the
sl@0	1540	* specified namespace; otherwise it is put
sl@0	1541	* in the global namespace. */
sl@0	1542	Tcl_CmdProc proc; / Procedure to associate with cmdName. */
sl@0	1543	ClientData clientData; /* Arbitrary value passed to string proc. */
sl@0	1544	Tcl_CmdDeleteProc *deleteProc;
sl@0	1545	/* If not NULL, gives a procedure to call
sl@0	1546	* when this command is deleted. */
sl@0	1547	{
sl@0	1548	Interp iPtr = (Interp ) interp;
sl@0	1549	ImportRef *oldRefPtr = NULL;
sl@0	1550	Namespace nsPtr, dummy1, *dummy2;
sl@0	1551	Command cmdPtr, refCmdPtr;
sl@0	1552	Tcl_HashEntry *hPtr;
sl@0	1553	CONST char *tail;
sl@0	1554	int new;
sl@0	1555	ImportedCmdData *dataPtr;
sl@0	1556
sl@0	1557	if (iPtr->flags & DELETED) {
sl@0	1558	/*
sl@0	1559	* The interpreter is being deleted. Don't create any new
sl@0	1560	* commands; it's not safe to muck with the interpreter anymore.
sl@0	1561	*/
sl@0	1562
sl@0	1563	return (Tcl_Command) NULL;
sl@0	1564	}
sl@0	1565
sl@0	1566	/*
sl@0	1567	* Determine where the command should reside. If its name contains
sl@0	1568	* namespace qualifiers, we put it in the specified namespace;
sl@0	1569	* otherwise, we always put it in the global namespace.
sl@0	1570	*/
sl@0	1571
sl@0	1572	if (strstr(cmdName, "::") != NULL) {
sl@0	1573	TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
sl@0	1574	CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
sl@0	1575	if ((nsPtr == NULL) \|\| (tail == NULL)) {
sl@0	1576	return (Tcl_Command) NULL;
sl@0	1577	}
sl@0	1578	} else {
sl@0	1579	nsPtr = iPtr->globalNsPtr;
sl@0	1580	tail = cmdName;
sl@0	1581	}
sl@0	1582
sl@0	1583	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
sl@0	1584	if (!new) {
sl@0	1585	/*
sl@0	1586	* Command already exists. Delete the old one.
sl@0	1587	* Be careful to preserve any existing import links so we can
sl@0	1588	* restore them down below. That way, you can redefine a
sl@0	1589	* command and its import status will remain intact.
sl@0	1590	*/
sl@0	1591
sl@0	1592	cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
sl@0	1593	oldRefPtr = cmdPtr->importRefPtr;
sl@0	1594	cmdPtr->importRefPtr = NULL;
sl@0	1595
sl@0	1596	Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
sl@0	1597	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
sl@0	1598	if (!new) {
sl@0	1599	/*
sl@0	1600	* If the deletion callback recreated the command, just throw
sl@0	1601	* away the new command (if we try to delete it again, we
sl@0	1602	* could get stuck in an infinite loop).
sl@0	1603	*/
sl@0	1604
sl@0	1605	ckfree((char*) Tcl_GetHashValue(hPtr));
sl@0	1606	}
sl@0	1607	}
sl@0	1608	cmdPtr = (Command *) ckalloc(sizeof(Command));
sl@0	1609	Tcl_SetHashValue(hPtr, cmdPtr);
sl@0	1610	cmdPtr->hPtr = hPtr;
sl@0	1611	cmdPtr->nsPtr = nsPtr;
sl@0	1612	cmdPtr->refCount = 1;
sl@0	1613	cmdPtr->cmdEpoch = 0;
sl@0	1614	cmdPtr->compileProc = (CompileProc *) NULL;
sl@0	1615	cmdPtr->objProc = TclInvokeStringCommand;
sl@0	1616	cmdPtr->objClientData = (ClientData) cmdPtr;
sl@0	1617	cmdPtr->proc = proc;
sl@0	1618	cmdPtr->clientData = clientData;
sl@0	1619	cmdPtr->deleteProc = deleteProc;
sl@0	1620	cmdPtr->deleteData = clientData;
sl@0	1621	cmdPtr->flags = 0;
sl@0	1622	cmdPtr->importRefPtr = NULL;
sl@0	1623	cmdPtr->tracePtr = NULL;
sl@0	1624
sl@0	1625	/*
sl@0	1626	* Plug in any existing import references found above. Be sure
sl@0	1627	* to update all of these references to point to the new command.
sl@0	1628	*/
sl@0	1629
sl@0	1630	if (oldRefPtr != NULL) {
sl@0	1631	cmdPtr->importRefPtr = oldRefPtr;
sl@0	1632	while (oldRefPtr != NULL) {
sl@0	1633	refCmdPtr = oldRefPtr->importedCmdPtr;
sl@0	1634	dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
sl@0	1635	dataPtr->realCmdPtr = cmdPtr;
sl@0	1636	oldRefPtr = oldRefPtr->nextPtr;
sl@0	1637	}
sl@0	1638	}
sl@0	1639
sl@0	1640	/*
sl@0	1641	* We just created a command, so in its namespace and all of its parent
sl@0	1642	* namespaces, it may shadow global commands with the same name. If any
sl@0	1643	* shadowed commands are found, invalidate all cached command references
sl@0	1644	* in the affected namespaces.
sl@0	1645	*/
sl@0	1646
sl@0	1647	TclResetShadowedCmdRefs(interp, cmdPtr);
sl@0	1648	return (Tcl_Command) cmdPtr;
sl@0	1649	}
sl@0	1650
sl@0	1651	/*
sl@0	1652	*----------------------------------------------------------------------
sl@0	1653	*
sl@0	1654	* Tcl_CreateObjCommand --
sl@0	1655	*
sl@0	1656	* Define a new object-based command in a command table.
sl@0	1657	*
sl@0	1658	* Results:
sl@0	1659	* The return value is a token for the command, which can
sl@0	1660	* be used in future calls to Tcl_GetCommandName.
sl@0	1661	*
sl@0	1662	* Side effects:
sl@0	1663	* If no command named "cmdName" already exists for interp, one is
sl@0	1664	* created. Otherwise, if a command does exist, then if the
sl@0	1665	* object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume
sl@0	1666	* Tcl_CreateCommand was called previously for the same command and
sl@0	1667	* just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we
sl@0	1668	* delete the old command.
sl@0	1669	*
sl@0	1670	* In the future, during bytecode evaluation when "cmdName" is seen as
sl@0	1671	* the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
sl@0	1672	* Tcl_ObjCmdProc proc will be called. When the command is deleted from
sl@0	1673	* the table, deleteProc will be called. See the manual entry for
sl@0	1674	* details on the calling sequence.
sl@0	1675	*
sl@0	1676	*----------------------------------------------------------------------
sl@0	1677	*/
sl@0	1678
sl@0	1679	EXPORT_C Tcl_Command
sl@0	1680	Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
sl@0	1681	Tcl_Interp interp; / Token for command interpreter (returned
sl@0	1682	* by previous call to Tcl_CreateInterp). */
sl@0	1683	CONST char cmdName; / Name of command. If it contains namespace
sl@0	1684	* qualifiers, the new command is put in the
sl@0	1685	* specified namespace; otherwise it is put
sl@0	1686	* in the global namespace. */
sl@0	1687	Tcl_ObjCmdProc proc; / Object-based procedure to associate with
sl@0	1688	* name. */
sl@0	1689	ClientData clientData; /* Arbitrary value to pass to object
sl@0	1690	* procedure. */
sl@0	1691	Tcl_CmdDeleteProc *deleteProc;
sl@0	1692	/* If not NULL, gives a procedure to call
sl@0	1693	* when this command is deleted. */
sl@0	1694	{
sl@0	1695	Interp iPtr = (Interp ) interp;
sl@0	1696	ImportRef *oldRefPtr = NULL;
sl@0	1697	Namespace nsPtr, dummy1, *dummy2;
sl@0	1698	Command cmdPtr, refCmdPtr;
sl@0	1699	Tcl_HashEntry *hPtr;
sl@0	1700	CONST char *tail;
sl@0	1701	int new;
sl@0	1702	ImportedCmdData *dataPtr;
sl@0	1703
sl@0	1704	if (iPtr->flags & DELETED) {
sl@0	1705	/*
sl@0	1706	* The interpreter is being deleted. Don't create any new
sl@0	1707	* commands; it's not safe to muck with the interpreter anymore.
sl@0	1708	*/
sl@0	1709
sl@0	1710	return (Tcl_Command) NULL;
sl@0	1711	}
sl@0	1712
sl@0	1713	/*
sl@0	1714	* Determine where the command should reside. If its name contains
sl@0	1715	* namespace qualifiers, we put it in the specified namespace;
sl@0	1716	* otherwise, we always put it in the global namespace.
sl@0	1717	*/
sl@0	1718
sl@0	1719	if (strstr(cmdName, "::") != NULL) {
sl@0	1720	TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
sl@0	1721	CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
sl@0	1722	if ((nsPtr == NULL) \|\| (tail == NULL)) {
sl@0	1723	return (Tcl_Command) NULL;
sl@0	1724	}
sl@0	1725	} else {
sl@0	1726	nsPtr = iPtr->globalNsPtr;
sl@0	1727	tail = cmdName;
sl@0	1728	}
sl@0	1729
sl@0	1730	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
sl@0	1731	if (!new) {
sl@0	1732	cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
sl@0	1733
sl@0	1734	/*
sl@0	1735	* Command already exists. If its object-based Tcl_ObjCmdProc is
sl@0	1736	* TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
sl@0	1737	* argument "proc". Otherwise, we delete the old command.
sl@0	1738	*/
sl@0	1739
sl@0	1740	if (cmdPtr->objProc == TclInvokeStringCommand) {
sl@0	1741	cmdPtr->objProc = proc;
sl@0	1742	cmdPtr->objClientData = clientData;
sl@0	1743	cmdPtr->deleteProc = deleteProc;
sl@0	1744	cmdPtr->deleteData = clientData;
sl@0	1745	return (Tcl_Command) cmdPtr;
sl@0	1746	}
sl@0	1747
sl@0	1748	/*
sl@0	1749	* Otherwise, we delete the old command. Be careful to preserve
sl@0	1750	* any existing import links so we can restore them down below.
sl@0	1751	* That way, you can redefine a command and its import status
sl@0	1752	* will remain intact.
sl@0	1753	*/
sl@0	1754
sl@0	1755	oldRefPtr = cmdPtr->importRefPtr;
sl@0	1756	cmdPtr->importRefPtr = NULL;
sl@0	1757
sl@0	1758	Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
sl@0	1759	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
sl@0	1760	if (!new) {
sl@0	1761	/*
sl@0	1762	* If the deletion callback recreated the command, just throw
sl@0	1763	* away the new command (if we try to delete it again, we
sl@0	1764	* could get stuck in an infinite loop).
sl@0	1765	*/
sl@0	1766
sl@0	1767	ckfree((char *) Tcl_GetHashValue(hPtr));
sl@0	1768	}
sl@0	1769	}
sl@0	1770	cmdPtr = (Command *) ckalloc(sizeof(Command));
sl@0	1771	Tcl_SetHashValue(hPtr, cmdPtr);
sl@0	1772	cmdPtr->hPtr = hPtr;
sl@0	1773	cmdPtr->nsPtr = nsPtr;
sl@0	1774	cmdPtr->refCount = 1;
sl@0	1775	cmdPtr->cmdEpoch = 0;
sl@0	1776	cmdPtr->compileProc = (CompileProc *) NULL;
sl@0	1777	cmdPtr->objProc = proc;
sl@0	1778	cmdPtr->objClientData = clientData;
sl@0	1779	cmdPtr->proc = TclInvokeObjectCommand;
sl@0	1780	cmdPtr->clientData = (ClientData) cmdPtr;
sl@0	1781	cmdPtr->deleteProc = deleteProc;
sl@0	1782	cmdPtr->deleteData = clientData;
sl@0	1783	cmdPtr->flags = 0;
sl@0	1784	cmdPtr->importRefPtr = NULL;
sl@0	1785	cmdPtr->tracePtr = NULL;
sl@0	1786
sl@0	1787	/*
sl@0	1788	* Plug in any existing import references found above. Be sure
sl@0	1789	* to update all of these references to point to the new command.
sl@0	1790	*/
sl@0	1791
sl@0	1792	if (oldRefPtr != NULL) {
sl@0	1793	cmdPtr->importRefPtr = oldRefPtr;
sl@0	1794	while (oldRefPtr != NULL) {
sl@0	1795	refCmdPtr = oldRefPtr->importedCmdPtr;
sl@0	1796	dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
sl@0	1797	dataPtr->realCmdPtr = cmdPtr;
sl@0	1798	oldRefPtr = oldRefPtr->nextPtr;
sl@0	1799	}
sl@0	1800	}
sl@0	1801
sl@0	1802	/*
sl@0	1803	* We just created a command, so in its namespace and all of its parent
sl@0	1804	* namespaces, it may shadow global commands with the same name. If any
sl@0	1805	* shadowed commands are found, invalidate all cached command references
sl@0	1806	* in the affected namespaces.
sl@0	1807	*/
sl@0	1808
sl@0	1809	TclResetShadowedCmdRefs(interp, cmdPtr);
sl@0	1810	return (Tcl_Command) cmdPtr;
sl@0	1811	}
sl@0	1812
sl@0	1813	/*
sl@0	1814	*----------------------------------------------------------------------
sl@0	1815	*
sl@0	1816	* TclInvokeStringCommand --
sl@0	1817	*
sl@0	1818	* "Wrapper" Tcl_ObjCmdProc used to call an existing string-based
sl@0	1819	* Tcl_CmdProc if no object-based procedure exists for a command. A
sl@0	1820	* pointer to this procedure is stored as the Tcl_ObjCmdProc in a
sl@0	1821	* Command structure. It simply turns around and calls the string
sl@0	1822	* Tcl_CmdProc in the Command structure.
sl@0	1823	*
sl@0	1824	* Results:
sl@0	1825	* A standard Tcl object result value.
sl@0	1826	*
sl@0	1827	* Side effects:
sl@0	1828	* Besides those side effects of the called Tcl_CmdProc,
sl@0	1829	* TclInvokeStringCommand allocates and frees storage.
sl@0	1830	*
sl@0	1831	*----------------------------------------------------------------------
sl@0	1832	*/
sl@0	1833
sl@0	1834	int
sl@0	1835	TclInvokeStringCommand(clientData, interp, objc, objv)
sl@0	1836	ClientData clientData; /* Points to command's Command structure. */
sl@0	1837	Tcl_Interp interp; / Current interpreter. */
sl@0	1838	register int objc; /* Number of arguments. */
sl@0	1839	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1840	{
sl@0	1841	register Command cmdPtr = (Command ) clientData;
sl@0	1842	register int i;
sl@0	1843	int result;
sl@0	1844
sl@0	1845	/*
sl@0	1846	* This procedure generates an argv array for the string arguments. It
sl@0	1847	* starts out with stack-allocated space but uses dynamically-allocated
sl@0	1848	* storage if needed.
sl@0	1849	*/
sl@0	1850
sl@0	1851	#define NUM_ARGS 20
sl@0	1852	CONST char *(argStorage[NUM_ARGS]);
sl@0	1853	CONST char **argv = argStorage;
sl@0	1854
sl@0	1855	/*
sl@0	1856	* Create the string argument array "argv". Make sure argv is large
sl@0	1857	* enough to hold the objc arguments plus 1 extra for the zero
sl@0	1858	* end-of-argv word.
sl@0	1859	*/
sl@0	1860
sl@0	1861	if ((objc + 1) > NUM_ARGS) {
sl@0	1862	argv = (CONST char *) ckalloc((unsigned)(objc + 1) sizeof(char *));
sl@0	1863	}
sl@0	1864
sl@0	1865	for (i = 0; i < objc; i++) {
sl@0	1866	argv[i] = Tcl_GetString(objv[i]);
sl@0	1867	}
sl@0	1868	argv[objc] = 0;
sl@0	1869
sl@0	1870	/*
sl@0	1871	* Invoke the command's string-based Tcl_CmdProc.
sl@0	1872	*/
sl@0	1873
sl@0	1874	result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);
sl@0	1875
sl@0	1876	/*
sl@0	1877	* Free the argv array if malloc'ed storage was used.
sl@0	1878	*/
sl@0	1879
sl@0	1880	if (argv != argStorage) {
sl@0	1881	ckfree((char *) argv);
sl@0	1882	}
sl@0	1883	return result;
sl@0	1884	#undef NUM_ARGS
sl@0	1885	}
sl@0	1886
sl@0	1887	/*
sl@0	1888	*----------------------------------------------------------------------
sl@0	1889	*
sl@0	1890	* TclInvokeObjectCommand --
sl@0	1891	*
sl@0	1892	* "Wrapper" Tcl_CmdProc used to call an existing object-based
sl@0	1893	* Tcl_ObjCmdProc if no string-based procedure exists for a command.
sl@0	1894	* A pointer to this procedure is stored as the Tcl_CmdProc in a
sl@0	1895	* Command structure. It simply turns around and calls the object
sl@0	1896	* Tcl_ObjCmdProc in the Command structure.
sl@0	1897	*
sl@0	1898	* Results:
sl@0	1899	* A standard Tcl string result value.
sl@0	1900	*
sl@0	1901	* Side effects:
sl@0	1902	* Besides those side effects of the called Tcl_CmdProc,
sl@0	1903	* TclInvokeStringCommand allocates and frees storage.
sl@0	1904	*
sl@0	1905	*----------------------------------------------------------------------
sl@0	1906	*/
sl@0	1907
sl@0	1908	int
sl@0	1909	TclInvokeObjectCommand(clientData, interp, argc, argv)
sl@0	1910	ClientData clientData; /* Points to command's Command structure. */
sl@0	1911	Tcl_Interp interp; / Current interpreter. */
sl@0	1912	int argc; /* Number of arguments. */
sl@0	1913	register CONST char *argv; / Argument strings. */
sl@0	1914	{
sl@0	1915	Command cmdPtr = (Command ) clientData;
sl@0	1916	register Tcl_Obj *objPtr;
sl@0	1917	register int i;
sl@0	1918	int length, result;
sl@0	1919
sl@0	1920	/*
sl@0	1921	* This procedure generates an objv array for object arguments that hold
sl@0	1922	* the argv strings. It starts out with stack-allocated space but uses
sl@0	1923	* dynamically-allocated storage if needed.
sl@0	1924	*/
sl@0	1925
sl@0	1926	#define NUM_ARGS 20
sl@0	1927	Tcl_Obj *(argStorage[NUM_ARGS]);
sl@0	1928	register Tcl_Obj **objv = argStorage;
sl@0	1929
sl@0	1930	/*
sl@0	1931	* Create the object argument array "objv". Make sure objv is large
sl@0	1932	* enough to hold the objc arguments plus 1 extra for the zero
sl@0	1933	* end-of-objv word.
sl@0	1934	*/
sl@0	1935
sl@0	1936	if (argc > NUM_ARGS) {
sl@0	1937	objv = (Tcl_Obj **)
sl@0	1938	ckalloc((unsigned)(argc * sizeof(Tcl_Obj *)));
sl@0	1939	}
sl@0	1940
sl@0	1941	for (i = 0; i < argc; i++) {
sl@0	1942	length = strlen(argv[i]);
sl@0	1943	TclNewObj(objPtr);
sl@0	1944	TclInitStringRep(objPtr, argv[i], length);
sl@0	1945	Tcl_IncrRefCount(objPtr);
sl@0	1946	objv[i] = objPtr;
sl@0	1947	}
sl@0	1948
sl@0	1949	/*
sl@0	1950	* Invoke the command's object-based Tcl_ObjCmdProc.
sl@0	1951	*/
sl@0	1952
sl@0	1953	result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
sl@0	1954
sl@0	1955	/*
sl@0	1956	* Move the interpreter's object result to the string result,
sl@0	1957	* then reset the object result.
sl@0	1958	*/
sl@0	1959
sl@0	1960	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
sl@0	1961	TCL_VOLATILE);
sl@0	1962
sl@0	1963	/*
sl@0	1964	* Decrement the ref counts for the argument objects created above,
sl@0	1965	* then free the objv array if malloc'ed storage was used.
sl@0	1966	*/
sl@0	1967
sl@0	1968	for (i = 0; i < argc; i++) {
sl@0	1969	objPtr = objv[i];
sl@0	1970	Tcl_DecrRefCount(objPtr);
sl@0	1971	}
sl@0	1972	if (objv != argStorage) {
sl@0	1973	ckfree((char *) objv);
sl@0	1974	}
sl@0	1975	return result;
sl@0	1976	#undef NUM_ARGS
sl@0	1977	}
sl@0	1978
sl@0	1979	/*
sl@0	1980	*----------------------------------------------------------------------
sl@0	1981	*
sl@0	1982	* TclRenameCommand --
sl@0	1983	*
sl@0	1984	* Called to give an existing Tcl command a different name. Both the
sl@0	1985	* old command name and the new command name can have "::" namespace
sl@0	1986	* qualifiers. If the new command has a different namespace context,
sl@0	1987	* the command will be moved to that namespace and will execute in
sl@0	1988	* the context of that new namespace.
sl@0	1989	*
sl@0	1990	* If the new command name is NULL or the null string, the command is
sl@0	1991	* deleted.
sl@0	1992	*
sl@0	1993	* Results:
sl@0	1994	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	1995	*
sl@0	1996	* Side effects:
sl@0	1997	* If anything goes wrong, an error message is returned in the
sl@0	1998	* interpreter's result object.
sl@0	1999	*
sl@0	2000	*----------------------------------------------------------------------
sl@0	2001	*/
sl@0	2002
sl@0	2003	int
sl@0	2004	TclRenameCommand(interp, oldName, newName)
sl@0	2005	Tcl_Interp interp; / Current interpreter. */
sl@0	2006	char oldName; / Existing command name. */
sl@0	2007	char newName; / New command name. */
sl@0	2008	{
sl@0	2009	Interp iPtr = (Interp ) interp;
sl@0	2010	CONST char *newTail;
sl@0	2011	Namespace cmdNsPtr, newNsPtr, dummy1, dummy2;
sl@0	2012	Tcl_Command cmd;
sl@0	2013	Command *cmdPtr;
sl@0	2014	Tcl_HashEntry hPtr, oldHPtr;
sl@0	2015	int new, result;
sl@0	2016	Tcl_Obj* oldFullName;
sl@0	2017	Tcl_DString newFullName;
sl@0	2018
sl@0	2019	/*
sl@0	2020	* Find the existing command. An error is returned if cmdName can't
sl@0	2021	* be found.
sl@0	2022	*/
sl@0	2023
sl@0	2024	cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,
sl@0	2025	/flags/ 0);
sl@0	2026	cmdPtr = (Command *) cmd;
sl@0	2027	if (cmdPtr == NULL) {
sl@0	2028	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",
sl@0	2029	((newName == NULL)\|\|(*newName == '\0'))? "delete":"rename",
sl@0	2030	" \"", oldName, "\": command doesn't exist", (char *) NULL);
sl@0	2031	return TCL_ERROR;
sl@0	2032	}
sl@0	2033	cmdNsPtr = cmdPtr->nsPtr;
sl@0	2034	oldFullName = Tcl_NewObj();
sl@0	2035	Tcl_IncrRefCount( oldFullName );
sl@0	2036	Tcl_GetCommandFullName( interp, cmd, oldFullName );
sl@0	2037
sl@0	2038	/*
sl@0	2039	* If the new command name is NULL or empty, delete the command. Do this
sl@0	2040	* with Tcl_DeleteCommandFromToken, since we already have the command.
sl@0	2041	*/
sl@0	2042
sl@0	2043	if ((newName == NULL) \|\| (*newName == '\0')) {
sl@0	2044	Tcl_DeleteCommandFromToken(interp, cmd);
sl@0	2045	result = TCL_OK;
sl@0	2046	goto done;
sl@0	2047	}
sl@0	2048
sl@0	2049	/*
sl@0	2050	* Make sure that the destination command does not already exist.
sl@0	2051	* The rename operation is like creating a command, so we should
sl@0	2052	* automatically create the containing namespaces just like
sl@0	2053	* Tcl_CreateCommand would.
sl@0	2054	*/
sl@0	2055
sl@0	2056	TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,
sl@0	2057	CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
sl@0	2058
sl@0	2059	if ((newNsPtr == NULL) \|\| (newTail == NULL)) {
sl@0	2060	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	2061	"can't rename to \"", newName, "\": bad command name",
sl@0	2062	(char *) NULL);
sl@0	2063	result = TCL_ERROR;
sl@0	2064	goto done;
sl@0	2065	}
sl@0	2066	if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
sl@0	2067	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	2068	"can't rename to \"", newName,
sl@0	2069	"\": command already exists", (char *) NULL);
sl@0	2070	result = TCL_ERROR;
sl@0	2071	goto done;
sl@0	2072	}
sl@0	2073
sl@0	2074	/*
sl@0	2075	* Warning: any changes done in the code here are likely
sl@0	2076	* to be needed in Tcl_HideCommand() code too.
sl@0	2077	* (until the common parts are extracted out) --dl
sl@0	2078	*/
sl@0	2079
sl@0	2080	/*
sl@0	2081	* Put the command in the new namespace so we can check for an alias
sl@0	2082	* loop. Since we are adding a new command to a namespace, we must
sl@0	2083	* handle any shadowing of the global commands that this might create.
sl@0	2084	*/
sl@0	2085
sl@0	2086	oldHPtr = cmdPtr->hPtr;
sl@0	2087	hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);
sl@0	2088	Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
sl@0	2089	cmdPtr->hPtr = hPtr;
sl@0	2090	cmdPtr->nsPtr = newNsPtr;
sl@0	2091	TclResetShadowedCmdRefs(interp, cmdPtr);
sl@0	2092
sl@0	2093	/*
sl@0	2094	* Now check for an alias loop. If we detect one, put everything back
sl@0	2095	* the way it was and report the error.
sl@0	2096	*/
sl@0	2097
sl@0	2098	result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
sl@0	2099	if (result != TCL_OK) {
sl@0	2100	Tcl_DeleteHashEntry(cmdPtr->hPtr);
sl@0	2101	cmdPtr->hPtr = oldHPtr;
sl@0	2102	cmdPtr->nsPtr = cmdNsPtr;
sl@0	2103	goto done;
sl@0	2104	}
sl@0	2105
sl@0	2106	/*
sl@0	2107	* Script for rename traces can delete the command "oldName".
sl@0	2108	* Therefore increment the reference count for cmdPtr so that
sl@0	2109	* it's Command structure is freed only towards the end of this
sl@0	2110	* function by calling TclCleanupCommand.
sl@0	2111	*
sl@0	2112	* The trace procedure needs to get a fully qualified name for
sl@0	2113	* old and new commands [Tcl bug #651271], or else there's no way
sl@0	2114	* for the trace procedure to get the namespace from which the old
sl@0	2115	* command is being renamed!
sl@0	2116	*/
sl@0	2117
sl@0	2118	Tcl_DStringInit( &newFullName );
sl@0	2119	Tcl_DStringAppend( &newFullName, newNsPtr->fullName, -1 );
sl@0	2120	if ( newNsPtr != iPtr->globalNsPtr ) {
sl@0	2121	Tcl_DStringAppend( &newFullName, "::", 2 );
sl@0	2122	}
sl@0	2123	Tcl_DStringAppend( &newFullName, newTail, -1 );
sl@0	2124	cmdPtr->refCount++;
sl@0	2125	CallCommandTraces( iPtr, cmdPtr,
sl@0	2126	Tcl_GetString( oldFullName ),
sl@0	2127	Tcl_DStringValue( &newFullName ),
sl@0	2128	TCL_TRACE_RENAME);
sl@0	2129	Tcl_DStringFree( &newFullName );
sl@0	2130
sl@0	2131	/*
sl@0	2132	* The new command name is okay, so remove the command from its
sl@0	2133	* current namespace. This is like deleting the command, so bump
sl@0	2134	* the cmdEpoch to invalidate any cached references to the command.
sl@0	2135	*/
sl@0	2136
sl@0	2137	Tcl_DeleteHashEntry(oldHPtr);
sl@0	2138	cmdPtr->cmdEpoch++;
sl@0	2139
sl@0	2140	/*
sl@0	2141	* If the command being renamed has a compile procedure, increment the
sl@0	2142	* interpreter's compileEpoch to invalidate its compiled code. This
sl@0	2143	* makes sure that we don't later try to execute old code compiled for
sl@0	2144	* the now-renamed command.
sl@0	2145	*/
sl@0	2146
sl@0	2147	if (cmdPtr->compileProc != NULL) {
sl@0	2148	iPtr->compileEpoch++;
sl@0	2149	}
sl@0	2150
sl@0	2151	/*
sl@0	2152	* Now free the Command structure, if the "oldName" command has
sl@0	2153	* been deleted by invocation of rename traces.
sl@0	2154	*/
sl@0	2155	TclCleanupCommand(cmdPtr);
sl@0	2156	result = TCL_OK;
sl@0	2157
sl@0	2158	done:
sl@0	2159	TclDecrRefCount( oldFullName );
sl@0	2160	return result;
sl@0	2161	}
sl@0	2162
sl@0	2163	/*
sl@0	2164	*----------------------------------------------------------------------
sl@0	2165	*
sl@0	2166	* Tcl_SetCommandInfo --
sl@0	2167	*
sl@0	2168	* Modifies various information about a Tcl command. Note that
sl@0	2169	* this procedure will not change a command's namespace; use
sl@0	2170	* Tcl_RenameCommand to do that. Also, the isNativeObjectProc
sl@0	2171	* member of *infoPtr is ignored.
sl@0	2172	*
sl@0	2173	* Results:
sl@0	2174	* If cmdName exists in interp, then the information at *infoPtr
sl@0	2175	* is stored with the command in place of the current information
sl@0	2176	* and 1 is returned. If the command doesn't exist then 0 is
sl@0	2177	* returned.
sl@0	2178	*
sl@0	2179	* Side effects:
sl@0	2180	* None.
sl@0	2181	*
sl@0	2182	*----------------------------------------------------------------------
sl@0	2183	*/
sl@0	2184
sl@0	2185	EXPORT_C int
sl@0	2186	Tcl_SetCommandInfo(interp, cmdName, infoPtr)
sl@0	2187	Tcl_Interp interp; / Interpreter in which to look
sl@0	2188	* for command. */
sl@0	2189	CONST char cmdName; / Name of desired command. */
sl@0	2190	CONST Tcl_CmdInfo infoPtr; / Where to find information
sl@0	2191	* to store in the command. */
sl@0	2192	{
sl@0	2193	Tcl_Command cmd;
sl@0	2194
sl@0	2195	cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
sl@0	2196	/flags/ 0);
sl@0	2197
sl@0	2198	return Tcl_SetCommandInfoFromToken( cmd, infoPtr );
sl@0	2199
sl@0	2200	}
sl@0	2201
sl@0	2202	/*
sl@0	2203	*----------------------------------------------------------------------
sl@0	2204	*
sl@0	2205	* Tcl_SetCommandInfoFromToken --
sl@0	2206	*
sl@0	2207	* Modifies various information about a Tcl command. Note that
sl@0	2208	* this procedure will not change a command's namespace; use
sl@0	2209	* Tcl_RenameCommand to do that. Also, the isNativeObjectProc
sl@0	2210	* member of *infoPtr is ignored.
sl@0	2211	*
sl@0	2212	* Results:
sl@0	2213	* If cmdName exists in interp, then the information at *infoPtr
sl@0	2214	* is stored with the command in place of the current information
sl@0	2215	* and 1 is returned. If the command doesn't exist then 0 is
sl@0	2216	* returned.
sl@0	2217	*
sl@0	2218	* Side effects:
sl@0	2219	* None.
sl@0	2220	*
sl@0	2221	*----------------------------------------------------------------------
sl@0	2222	*/
sl@0	2223
sl@0	2224	EXPORT_C int
sl@0	2225	Tcl_SetCommandInfoFromToken( cmd, infoPtr )
sl@0	2226	Tcl_Command cmd;
sl@0	2227	CONST Tcl_CmdInfo* infoPtr;
sl@0	2228	{
sl@0	2229	Command* cmdPtr; /* Internal representation of the command */
sl@0	2230
sl@0	2231	if (cmd == (Tcl_Command) NULL) {
sl@0	2232	return 0;
sl@0	2233	}
sl@0	2234
sl@0	2235	/*
sl@0	2236	* The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
sl@0	2237	*/
sl@0	2238
sl@0	2239	cmdPtr = (Command *) cmd;
sl@0	2240	cmdPtr->proc = infoPtr->proc;
sl@0	2241	cmdPtr->clientData = infoPtr->clientData;
sl@0	2242	if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
sl@0	2243	cmdPtr->objProc = TclInvokeStringCommand;
sl@0	2244	cmdPtr->objClientData = (ClientData) cmdPtr;
sl@0	2245	} else {
sl@0	2246	cmdPtr->objProc = infoPtr->objProc;
sl@0	2247	cmdPtr->objClientData = infoPtr->objClientData;
sl@0	2248	}
sl@0	2249	cmdPtr->deleteProc = infoPtr->deleteProc;
sl@0	2250	cmdPtr->deleteData = infoPtr->deleteData;
sl@0	2251	return 1;
sl@0	2252	}
sl@0	2253
sl@0	2254	/*
sl@0	2255	*----------------------------------------------------------------------
sl@0	2256	*
sl@0	2257	* Tcl_GetCommandInfo --
sl@0	2258	*
sl@0	2259	* Returns various information about a Tcl command.
sl@0	2260	*
sl@0	2261	* Results:
sl@0	2262	* If cmdName exists in interp, then *infoPtr is modified to
sl@0	2263	* hold information about cmdName and 1 is returned. If the
sl@0	2264	* command doesn't exist then 0 is returned and *infoPtr isn't
sl@0	2265	* modified.
sl@0	2266	*
sl@0	2267	* Side effects:
sl@0	2268	* None.
sl@0	2269	*
sl@0	2270	*----------------------------------------------------------------------
sl@0	2271	*/
sl@0	2272
sl@0	2273	EXPORT_C int
sl@0	2274	Tcl_GetCommandInfo(interp, cmdName, infoPtr)
sl@0	2275	Tcl_Interp interp; / Interpreter in which to look
sl@0	2276	* for command. */
sl@0	2277	CONST char cmdName; / Name of desired command. */
sl@0	2278	Tcl_CmdInfo infoPtr; / Where to store information about
sl@0	2279	* command. */
sl@0	2280	{
sl@0	2281	Tcl_Command cmd;
sl@0	2282
sl@0	2283	cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
sl@0	2284	/flags/ 0);
sl@0	2285
sl@0	2286	return Tcl_GetCommandInfoFromToken( cmd, infoPtr );
sl@0	2287
sl@0	2288	}
sl@0	2289
sl@0	2290	/*
sl@0	2291	*----------------------------------------------------------------------
sl@0	2292	*
sl@0	2293	* Tcl_GetCommandInfoFromToken --
sl@0	2294	*
sl@0	2295	* Returns various information about a Tcl command.
sl@0	2296	*
sl@0	2297	* Results:
sl@0	2298	* Copies information from the command identified by 'cmd' into
sl@0	2299	* a caller-supplied structure and returns 1. If the 'cmd' is
sl@0	2300	* NULL, leaves the structure untouched and returns 0.
sl@0	2301	*
sl@0	2302	* Side effects:
sl@0	2303	* None.
sl@0	2304	*
sl@0	2305	*----------------------------------------------------------------------
sl@0	2306	*/
sl@0	2307
sl@0	2308	EXPORT_C int
sl@0	2309	Tcl_GetCommandInfoFromToken( cmd, infoPtr )
sl@0	2310	Tcl_Command cmd;
sl@0	2311	Tcl_CmdInfo* infoPtr;
sl@0	2312	{
sl@0	2313
sl@0	2314	Command* cmdPtr; /* Internal representation of the command */
sl@0	2315
sl@0	2316	if ( cmd == (Tcl_Command) NULL ) {
sl@0	2317	return 0;
sl@0	2318	}
sl@0	2319
sl@0	2320	/*
sl@0	2321	* Set isNativeObjectProc 1 if objProc was registered by a call to
sl@0	2322	* Tcl_CreateObjCommand. Otherwise set it to 0.
sl@0	2323	*/
sl@0	2324
sl@0	2325	cmdPtr = (Command *) cmd;
sl@0	2326	infoPtr->isNativeObjectProc =
sl@0	2327	(cmdPtr->objProc != TclInvokeStringCommand);
sl@0	2328	infoPtr->objProc = cmdPtr->objProc;
sl@0	2329	infoPtr->objClientData = cmdPtr->objClientData;
sl@0	2330	infoPtr->proc = cmdPtr->proc;
sl@0	2331	infoPtr->clientData = cmdPtr->clientData;
sl@0	2332	infoPtr->deleteProc = cmdPtr->deleteProc;
sl@0	2333	infoPtr->deleteData = cmdPtr->deleteData;
sl@0	2334	infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
sl@0	2335
sl@0	2336	return 1;
sl@0	2337
sl@0	2338	}
sl@0	2339
sl@0	2340	/*
sl@0	2341	*----------------------------------------------------------------------
sl@0	2342	*
sl@0	2343	* Tcl_GetCommandName --
sl@0	2344	*
sl@0	2345	* Given a token returned by Tcl_CreateCommand, this procedure
sl@0	2346	* returns the current name of the command (which may have changed
sl@0	2347	* due to renaming).
sl@0	2348	*
sl@0	2349	* Results:
sl@0	2350	* The return value is the name of the given command.
sl@0	2351	*
sl@0	2352	* Side effects:
sl@0	2353	* None.
sl@0	2354	*
sl@0	2355	*----------------------------------------------------------------------
sl@0	2356	*/
sl@0	2357
sl@0	2358	EXPORT_C CONST char *
sl@0	2359	Tcl_GetCommandName(interp, command)
sl@0	2360	Tcl_Interp interp; / Interpreter containing the command. */
sl@0	2361	Tcl_Command command; /* Token for command returned by a previous
sl@0	2362	* call to Tcl_CreateCommand. The command
sl@0	2363	* must not have been deleted. */
sl@0	2364	{
sl@0	2365	Command cmdPtr = (Command ) command;
sl@0	2366
sl@0	2367	if ((cmdPtr == NULL) \|\| (cmdPtr->hPtr == NULL)) {
sl@0	2368
sl@0	2369	/*
sl@0	2370	* This should only happen if command was "created" after the
sl@0	2371	* interpreter began to be deleted, so there isn't really any
sl@0	2372	* command. Just return an empty string.
sl@0	2373	*/
sl@0	2374
sl@0	2375	return "";
sl@0	2376	}
sl@0	2377	return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
sl@0	2378	}
sl@0	2379
sl@0	2380	/*
sl@0	2381	*----------------------------------------------------------------------
sl@0	2382	*
sl@0	2383	* Tcl_GetCommandFullName --
sl@0	2384	*
sl@0	2385	* Given a token returned by, e.g., Tcl_CreateCommand or
sl@0	2386	* Tcl_FindCommand, this procedure appends to an object the command's
sl@0	2387	* full name, qualified by a sequence of parent namespace names. The
sl@0	2388	* command's fully-qualified name may have changed due to renaming.
sl@0	2389	*
sl@0	2390	* Results:
sl@0	2391	* None.
sl@0	2392	*
sl@0	2393	* Side effects:
sl@0	2394	* The command's fully-qualified name is appended to the string
sl@0	2395	* representation of objPtr.
sl@0	2396	*
sl@0	2397	*----------------------------------------------------------------------
sl@0	2398	*/
sl@0	2399
sl@0	2400	void
sl@0	2401	Tcl_GetCommandFullName(interp, command, objPtr)
sl@0	2402	Tcl_Interp interp; / Interpreter containing the command. */
sl@0	2403	Tcl_Command command; /* Token for command returned by a previous
sl@0	2404	* call to Tcl_CreateCommand. The command
sl@0	2405	* must not have been deleted. */
sl@0	2406	Tcl_Obj objPtr; / Points to the object onto which the
sl@0	2407	* command's full name is appended. */
sl@0	2408
sl@0	2409	{
sl@0	2410	Interp iPtr = (Interp ) interp;
sl@0	2411	register Command cmdPtr = (Command ) command;
sl@0	2412	char *name;
sl@0	2413
sl@0	2414	/*
sl@0	2415	* Add the full name of the containing namespace, followed by the "::"
sl@0	2416	* separator, and the command name.
sl@0	2417	*/
sl@0	2418
sl@0	2419	if (cmdPtr != NULL) {
sl@0	2420	if (cmdPtr->nsPtr != NULL) {
sl@0	2421	Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
sl@0	2422	if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
sl@0	2423	Tcl_AppendToObj(objPtr, "::", 2);
sl@0	2424	}
sl@0	2425	}
sl@0	2426	if (cmdPtr->hPtr != NULL) {
sl@0	2427	name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
sl@0	2428	Tcl_AppendToObj(objPtr, name, -1);
sl@0	2429	}
sl@0	2430	}
sl@0	2431	}
sl@0	2432
sl@0	2433	/*
sl@0	2434	*----------------------------------------------------------------------
sl@0	2435	*
sl@0	2436	* Tcl_DeleteCommand --
sl@0	2437	*
sl@0	2438	* Remove the given command from the given interpreter.
sl@0	2439	*
sl@0	2440	* Results:
sl@0	2441	* 0 is returned if the command was deleted successfully.
sl@0	2442	* -1 is returned if there didn't exist a command by that name.
sl@0	2443	*
sl@0	2444	* Side effects:
sl@0	2445	* cmdName will no longer be recognized as a valid command for
sl@0	2446	* interp.
sl@0	2447	*
sl@0	2448	*----------------------------------------------------------------------
sl@0	2449	*/
sl@0	2450
sl@0	2451	EXPORT_C int
sl@0	2452	Tcl_DeleteCommand(interp, cmdName)
sl@0	2453	Tcl_Interp interp; / Token for command interpreter (returned
sl@0	2454	* by a previous Tcl_CreateInterp call). */
sl@0	2455	CONST char cmdName; / Name of command to remove. */
sl@0	2456	{
sl@0	2457	Tcl_Command cmd;
sl@0	2458
sl@0	2459	/*
sl@0	2460	* Find the desired command and delete it.
sl@0	2461	*/
sl@0	2462
sl@0	2463	cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
sl@0	2464	/flags/ 0);
sl@0	2465	if (cmd == (Tcl_Command) NULL) {
sl@0	2466	return -1;
sl@0	2467	}
sl@0	2468	return Tcl_DeleteCommandFromToken(interp, cmd);
sl@0	2469	}
sl@0	2470
sl@0	2471	/*
sl@0	2472	*----------------------------------------------------------------------
sl@0	2473	*
sl@0	2474	* Tcl_DeleteCommandFromToken --
sl@0	2475	*
sl@0	2476	* Removes the given command from the given interpreter. This procedure
sl@0	2477	* resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
sl@0	2478	* of a command name for efficiency.
sl@0	2479	*
sl@0	2480	* Results:
sl@0	2481	* 0 is returned if the command was deleted successfully.
sl@0	2482	* -1 is returned if there didn't exist a command by that name.
sl@0	2483	*
sl@0	2484	* Side effects:
sl@0	2485	* The command specified by "cmd" will no longer be recognized as a
sl@0	2486	* valid command for "interp".
sl@0	2487	*
sl@0	2488	*----------------------------------------------------------------------
sl@0	2489	*/
sl@0	2490
sl@0	2491	EXPORT_C int
sl@0	2492	Tcl_DeleteCommandFromToken(interp, cmd)
sl@0	2493	Tcl_Interp interp; / Token for command interpreter returned by
sl@0	2494	* a previous call to Tcl_CreateInterp. */
sl@0	2495	Tcl_Command cmd; /* Token for command to delete. */
sl@0	2496	{
sl@0	2497	Interp iPtr = (Interp ) interp;
sl@0	2498	Command cmdPtr = (Command ) cmd;
sl@0	2499	ImportRef refPtr, nextRefPtr;
sl@0	2500	Tcl_Command importCmd;
sl@0	2501
sl@0	2502	/*
sl@0	2503	* The code here is tricky. We can't delete the hash table entry
sl@0	2504	* before invoking the deletion callback because there are cases
sl@0	2505	* where the deletion callback needs to invoke the command (e.g.
sl@0	2506	* object systems such as OTcl). However, this means that the
sl@0	2507	* callback could try to delete or rename the command. The deleted
sl@0	2508	* flag allows us to detect these cases and skip nested deletes.
sl@0	2509	*/
sl@0	2510
sl@0	2511	if (cmdPtr->flags & CMD_IS_DELETED) {
sl@0	2512	/*
sl@0	2513	* Another deletion is already in progress. Remove the hash
sl@0	2514	* table entry now, but don't invoke a callback or free the
sl@0	2515	* command structure.
sl@0	2516	*/
sl@0	2517
sl@0	2518	Tcl_DeleteHashEntry(cmdPtr->hPtr);
sl@0	2519	cmdPtr->hPtr = NULL;
sl@0	2520	return 0;
sl@0	2521	}
sl@0	2522
sl@0	2523	/*
sl@0	2524	* We must delete this command, even though both traces and
sl@0	2525	* delete procs may try to avoid this (renaming the command etc).
sl@0	2526	* Also traces and delete procs may try to delete the command
sl@0	2527	* themsevles. This flag declares that a delete is in progress
sl@0	2528	* and that recursive deletes should be ignored.
sl@0	2529	*/
sl@0	2530	cmdPtr->flags \|= CMD_IS_DELETED;
sl@0	2531
sl@0	2532	/*
sl@0	2533	* Bump the command epoch counter. This will invalidate all cached
sl@0	2534	* references that point to this command.
sl@0	2535	*/
sl@0	2536
sl@0	2537	cmdPtr->cmdEpoch++;
sl@0	2538
sl@0	2539	/*
sl@0	2540	* Call trace procedures for the command being deleted. Then delete
sl@0	2541	* its traces.
sl@0	2542	*/
sl@0	2543
sl@0	2544	if (cmdPtr->tracePtr != NULL) {
sl@0	2545	CommandTrace *tracePtr;
sl@0	2546	CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
sl@0	2547	/* Now delete these traces */
sl@0	2548	tracePtr = cmdPtr->tracePtr;
sl@0	2549	while (tracePtr != NULL) {
sl@0	2550	CommandTrace *nextPtr = tracePtr->nextPtr;
sl@0	2551	if ((--tracePtr->refCount) <= 0) {
sl@0	2552	ckfree((char*)tracePtr);
sl@0	2553	}
sl@0	2554	tracePtr = nextPtr;
sl@0	2555	}
sl@0	2556	cmdPtr->tracePtr = NULL;
sl@0	2557	}
sl@0	2558
sl@0	2559	/*
sl@0	2560	* If the command being deleted has a compile procedure, increment the
sl@0	2561	* interpreter's compileEpoch to invalidate its compiled code. This
sl@0	2562	* makes sure that we don't later try to execute old code compiled with
sl@0	2563	* command-specific (i.e., inline) bytecodes for the now-deleted
sl@0	2564	* command. This field is checked in Tcl_EvalObj and ObjInterpProc, and
sl@0	2565	* code whose compilation epoch doesn't match is recompiled.
sl@0	2566	*/
sl@0	2567
sl@0	2568	if (cmdPtr->compileProc != NULL) {
sl@0	2569	iPtr->compileEpoch++;
sl@0	2570	}
sl@0	2571
sl@0	2572	if (cmdPtr->deleteProc != NULL) {
sl@0	2573	/*
sl@0	2574	* Delete the command's client data. If this was an imported command
sl@0	2575	* created when a command was imported into a namespace, this client
sl@0	2576	* data will be a pointer to a ImportedCmdData structure describing
sl@0	2577	* the "real" command that this imported command refers to.
sl@0	2578	*/
sl@0	2579
sl@0	2580	/*
sl@0	2581	* If you are getting a crash during the call to deleteProc and
sl@0	2582	* cmdPtr->deleteProc is a pointer to the function free(), the
sl@0	2583	* most likely cause is that your extension allocated memory
sl@0	2584	* for the clientData argument to Tcl_CreateObjCommand() with
sl@0	2585	* the ckalloc() macro and you are now trying to deallocate
sl@0	2586	* this memory with free() instead of ckfree(). You should
sl@0	2587	* pass a pointer to your own method that calls ckfree().
sl@0	2588	*/
sl@0	2589
sl@0	2590	(*cmdPtr->deleteProc)(cmdPtr->deleteData);
sl@0	2591	}
sl@0	2592
sl@0	2593	/*
sl@0	2594	* If this command was imported into other namespaces, then imported
sl@0	2595	* commands were created that refer back to this command. Delete these
sl@0	2596	* imported commands now.
sl@0	2597	*/
sl@0	2598
sl@0	2599	for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
sl@0	2600	refPtr = nextRefPtr) {
sl@0	2601	nextRefPtr = refPtr->nextPtr;
sl@0	2602	importCmd = (Tcl_Command) refPtr->importedCmdPtr;
sl@0	2603	Tcl_DeleteCommandFromToken(interp, importCmd);
sl@0	2604	}
sl@0	2605
sl@0	2606	/*
sl@0	2607	* Don't use hPtr to delete the hash entry here, because it's
sl@0	2608	* possible that the deletion callback renamed the command.
sl@0	2609	* Instead, use cmdPtr->hptr, and make sure that no-one else
sl@0	2610	* has already deleted the hash entry.
sl@0	2611	*/
sl@0	2612
sl@0	2613	if (cmdPtr->hPtr != NULL) {
sl@0	2614	Tcl_DeleteHashEntry(cmdPtr->hPtr);
sl@0	2615	}
sl@0	2616
sl@0	2617	/*
sl@0	2618	* Mark the Command structure as no longer valid. This allows
sl@0	2619	* TclExecuteByteCode to recognize when a Command has logically been
sl@0	2620	* deleted and a pointer to this Command structure cached in a CmdName
sl@0	2621	* object is invalid. TclExecuteByteCode will look up the command again
sl@0	2622	* in the interpreter's command hashtable.
sl@0	2623	*/
sl@0	2624
sl@0	2625	cmdPtr->objProc = NULL;
sl@0	2626
sl@0	2627	/*
sl@0	2628	* Now free the Command structure, unless there is another reference to
sl@0	2629	* it from a CmdName Tcl object in some ByteCode code sequence. In that
sl@0	2630	* case, delay the cleanup until all references are either discarded
sl@0	2631	* (when a ByteCode is freed) or replaced by a new reference (when a
sl@0	2632	* cached CmdName Command reference is found to be invalid and
sl@0	2633	* TclExecuteByteCode looks up the command in the command hashtable).
sl@0	2634	*/
sl@0	2635
sl@0	2636	TclCleanupCommand(cmdPtr);
sl@0	2637	return 0;
sl@0	2638	}
sl@0	2639
sl@0	2640	static char *
sl@0	2641	CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
sl@0	2642	Interp iPtr; / Interpreter containing command. */
sl@0	2643	Command cmdPtr; / Command whose traces are to be
sl@0	2644	* invoked. */
sl@0	2645	CONST char oldName; / Command's old name, or NULL if we
sl@0	2646	* must get the name from cmdPtr */
sl@0	2647	CONST char newName; / Command's new name, or NULL if
sl@0	2648	* the command is not being renamed */
sl@0	2649	int flags; /* Flags indicating the type of traces
sl@0	2650	* to trigger, either TCL_TRACE_DELETE
sl@0	2651	* or TCL_TRACE_RENAME. */
sl@0	2652	{
sl@0	2653	register CommandTrace *tracePtr;
sl@0	2654	ActiveCommandTrace active;
sl@0	2655	char *result;
sl@0	2656	Tcl_Obj *oldNamePtr = NULL;
sl@0	2657	int mask = (TCL_TRACE_DELETE \| TCL_TRACE_RENAME); /* Safety */
sl@0	2658
sl@0	2659	flags &= mask;
sl@0	2660
sl@0	2661	if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
sl@0	2662	/*
sl@0	2663	* While a rename trace is active, we will not process any more
sl@0	2664	* rename traces; while a delete trace is active we will never
sl@0	2665	* reach here -- because Tcl_DeleteCommandFromToken checks for the
sl@0	2666	* condition (cmdPtr->flags & CMD_IS_DELETED) and returns immediately
sl@0	2667	* when a command deletion is in progress. For all other traces,
sl@0	2668	* delete traces will not be invoked but a call to TraceCommandProc
sl@0	2669	* will ensure that tracePtr->clientData is freed whenever the
sl@0	2670	* command "oldName" is deleted.
sl@0	2671	*/
sl@0	2672	if (cmdPtr->flags & TCL_TRACE_RENAME) {
sl@0	2673	flags &= ~TCL_TRACE_RENAME;
sl@0	2674	}
sl@0	2675	if (flags == 0) {
sl@0	2676	return NULL;
sl@0	2677	}
sl@0	2678	}
sl@0	2679	cmdPtr->flags \|= CMD_TRACE_ACTIVE;
sl@0	2680	cmdPtr->refCount++;
sl@0	2681
sl@0	2682	result = NULL;
sl@0	2683	active.nextPtr = iPtr->activeCmdTracePtr;
sl@0	2684	active.reverseScan = 0;
sl@0	2685	iPtr->activeCmdTracePtr = &active;
sl@0	2686
sl@0	2687	if (flags & TCL_TRACE_DELETE) {
sl@0	2688	flags \|= TCL_TRACE_DESTROYED;
sl@0	2689	}
sl@0	2690	active.cmdPtr = cmdPtr;
sl@0	2691
sl@0	2692	Tcl_Preserve((ClientData) iPtr);
sl@0	2693
sl@0	2694	for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
sl@0	2695	tracePtr = active.nextTracePtr) {
sl@0	2696	int traceFlags = (tracePtr->flags & mask);
sl@0	2697
sl@0	2698	active.nextTracePtr = tracePtr->nextPtr;
sl@0	2699	if (!(traceFlags & flags)) {
sl@0	2700	continue;
sl@0	2701	}
sl@0	2702	cmdPtr->flags \|= traceFlags;
sl@0	2703	if (oldName == NULL) {
sl@0	2704	TclNewObj(oldNamePtr);
sl@0	2705	Tcl_IncrRefCount(oldNamePtr);
sl@0	2706	Tcl_GetCommandFullName((Tcl_Interp *) iPtr,
sl@0	2707	(Tcl_Command) cmdPtr, oldNamePtr);
sl@0	2708	oldName = TclGetString(oldNamePtr);
sl@0	2709	}
sl@0	2710	tracePtr->refCount++;
sl@0	2711	(*tracePtr->traceProc)(tracePtr->clientData,
sl@0	2712	(Tcl_Interp *) iPtr, oldName, newName, flags);
sl@0	2713	cmdPtr->flags &= ~traceFlags;
sl@0	2714	if ((--tracePtr->refCount) <= 0) {
sl@0	2715	ckfree((char*)tracePtr);
sl@0	2716	}
sl@0	2717	}
sl@0	2718
sl@0	2719	/*
sl@0	2720	* If a new object was created to hold the full oldName,
sl@0	2721	* free it now.
sl@0	2722	*/
sl@0	2723
sl@0	2724	if (oldNamePtr != NULL) {
sl@0	2725	TclDecrRefCount(oldNamePtr);
sl@0	2726	}
sl@0	2727
sl@0	2728	/*
sl@0	2729	* Restore the variable's flags, remove the record of our active
sl@0	2730	* traces, and then return.
sl@0	2731	*/
sl@0	2732
sl@0	2733	cmdPtr->flags &= ~CMD_TRACE_ACTIVE;
sl@0	2734	cmdPtr->refCount--;
sl@0	2735	iPtr->activeCmdTracePtr = active.nextPtr;
sl@0	2736	Tcl_Release((ClientData) iPtr);
sl@0	2737	return result;
sl@0	2738	}
sl@0	2739
sl@0	2740	/*
sl@0	2741	*----------------------------------------------------------------------
sl@0	2742	*
sl@0	2743	* TclCleanupCommand --
sl@0	2744	*
sl@0	2745	* This procedure frees up a Command structure unless it is still
sl@0	2746	* referenced from an interpreter's command hashtable or from a CmdName
sl@0	2747	* Tcl object representing the name of a command in a ByteCode
sl@0	2748	* instruction sequence.
sl@0	2749	*
sl@0	2750	* Results:
sl@0	2751	* None.
sl@0	2752	*
sl@0	2753	* Side effects:
sl@0	2754	* Memory gets freed unless a reference to the Command structure still
sl@0	2755	* exists. In that case the cleanup is delayed until the command is
sl@0	2756	* deleted or when the last ByteCode referring to it is freed.
sl@0	2757	*
sl@0	2758	*----------------------------------------------------------------------
sl@0	2759	*/
sl@0	2760
sl@0	2761	void
sl@0	2762	TclCleanupCommand(cmdPtr)
sl@0	2763	register Command cmdPtr; / Points to the Command structure to
sl@0	2764	* be freed. */
sl@0	2765	{
sl@0	2766	cmdPtr->refCount--;
sl@0	2767	if (cmdPtr->refCount <= 0) {
sl@0	2768	ckfree((char *) cmdPtr);
sl@0	2769	}
sl@0	2770	}
sl@0	2771
sl@0	2772	/*
sl@0	2773	*----------------------------------------------------------------------
sl@0	2774	*
sl@0	2775	* Tcl_CreateMathFunc --
sl@0	2776	*
sl@0	2777	* Creates a new math function for expressions in a given
sl@0	2778	* interpreter.
sl@0	2779	*
sl@0	2780	* Results:
sl@0	2781	* None.
sl@0	2782	*
sl@0	2783	* Side effects:
sl@0	2784	* The function defined by "name" is created or redefined. If the
sl@0	2785	* function already exists then its definition is replaced; this
sl@0	2786	* includes the builtin functions. Redefining a builtin function forces
sl@0	2787	* all existing code to be invalidated since that code may be compiled
sl@0	2788	* using an instruction specific to the replaced function. In addition,
sl@0	2789	* redefioning a non-builtin function will force existing code to be
sl@0	2790	* invalidated if the number of arguments has changed.
sl@0	2791	*
sl@0	2792	*----------------------------------------------------------------------
sl@0	2793	*/
sl@0	2794
sl@0	2795	EXPORT_C void
sl@0	2796	Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
sl@0	2797	Tcl_Interp interp; / Interpreter in which function is
sl@0	2798	* to be available. */
sl@0	2799	CONST char name; / Name of function (e.g. "sin"). */
sl@0	2800	int numArgs; /* Nnumber of arguments required by
sl@0	2801	* function. */
sl@0	2802	Tcl_ValueType argTypes; / Array of types acceptable for
sl@0	2803	* each argument. */
sl@0	2804	Tcl_MathProc proc; / Procedure that implements the
sl@0	2805	* math function. */
sl@0	2806	ClientData clientData; /* Additional value to pass to the
sl@0	2807	* function. */
sl@0	2808	{
sl@0	2809	Interp iPtr = (Interp ) interp;
sl@0	2810	Tcl_HashEntry *hPtr;
sl@0	2811	MathFunc *mathFuncPtr;
sl@0	2812	int new, i;
sl@0	2813
sl@0	2814	hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
sl@0	2815	if (new) {
sl@0	2816	Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
sl@0	2817	}
sl@0	2818	mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
sl@0	2819
sl@0	2820	if (!new) {
sl@0	2821	if (mathFuncPtr->builtinFuncIndex >= 0) {
sl@0	2822	/*
sl@0	2823	* We are redefining a builtin math function. Invalidate the
sl@0	2824	* interpreter's existing code by incrementing its
sl@0	2825	* compileEpoch member. This field is checked in Tcl_EvalObj
sl@0	2826	* and ObjInterpProc, and code whose compilation epoch doesn't
sl@0	2827	* match is recompiled. Newly compiled code will no longer
sl@0	2828	* treat the function as builtin.
sl@0	2829	*/
sl@0	2830
sl@0	2831	iPtr->compileEpoch++;
sl@0	2832	} else {
sl@0	2833	/*
sl@0	2834	* A non-builtin function is being redefined. We must invalidate
sl@0	2835	* existing code if the number of arguments has changed. This
sl@0	2836	* is because existing code was compiled assuming that number.
sl@0	2837	*/
sl@0	2838
sl@0	2839	if (numArgs != mathFuncPtr->numArgs) {
sl@0	2840	iPtr->compileEpoch++;
sl@0	2841	}
sl@0	2842	}
sl@0	2843	}
sl@0	2844
sl@0	2845	mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */
sl@0	2846	if (numArgs > MAX_MATH_ARGS) {
sl@0	2847	numArgs = MAX_MATH_ARGS;
sl@0	2848	}
sl@0	2849	mathFuncPtr->numArgs = numArgs;
sl@0	2850	for (i = 0; i < numArgs; i++) {
sl@0	2851	mathFuncPtr->argTypes[i] = argTypes[i];
sl@0	2852	}
sl@0	2853	mathFuncPtr->proc = proc;
sl@0	2854	mathFuncPtr->clientData = clientData;
sl@0	2855	}
sl@0	2856
sl@0	2857	/*
sl@0	2858	*----------------------------------------------------------------------
sl@0	2859	*
sl@0	2860	* Tcl_GetMathFuncInfo --
sl@0	2861	*
sl@0	2862	* Discovers how a particular math function was created in a given
sl@0	2863	* interpreter.
sl@0	2864	*
sl@0	2865	* Results:
sl@0	2866	* TCL_OK if it succeeds, TCL_ERROR else (leaving an error message
sl@0	2867	* in the interpreter result if that happens.)
sl@0	2868	*
sl@0	2869	* Side effects:
sl@0	2870	* If this function succeeds, the variables pointed to by the
sl@0	2871	* numArgsPtr and argTypePtr arguments will be updated to detail the
sl@0	2872	* arguments allowed by the function. The variable pointed to by the
sl@0	2873	* procPtr argument will be set to NULL if the function is a builtin
sl@0	2874	* function, and will be set to the address of the C function used to
sl@0	2875	* implement the math function otherwise (in which case the variable
sl@0	2876	* pointed to by the clientDataPtr argument will also be updated.)
sl@0	2877	*
sl@0	2878	*----------------------------------------------------------------------
sl@0	2879	*/
sl@0	2880
sl@0	2881	EXPORT_C int
sl@0	2882	Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr,
sl@0	2883	clientDataPtr)
sl@0	2884	Tcl_Interp *interp;
sl@0	2885	CONST char *name;
sl@0	2886	int *numArgsPtr;
sl@0	2887	Tcl_ValueType **argTypesPtr;
sl@0	2888	Tcl_MathProc **procPtr;
sl@0	2889	ClientData *clientDataPtr;
sl@0	2890	{
sl@0	2891	Interp iPtr = (Interp ) interp;
sl@0	2892	Tcl_HashEntry *hPtr;
sl@0	2893	MathFunc *mathFuncPtr;
sl@0	2894	Tcl_ValueType *argTypes;
sl@0	2895	int i,numArgs;
sl@0	2896
sl@0	2897	hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name);
sl@0	2898	if (hPtr == NULL) {
sl@0	2899	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	2900	"math function \"", name, "\" not known in this interpreter",
sl@0	2901	(char *) NULL);
sl@0	2902	return TCL_ERROR;
sl@0	2903	}
sl@0	2904	mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
sl@0	2905
sl@0	2906	*numArgsPtr = numArgs = mathFuncPtr->numArgs;
sl@0	2907	if (numArgs == 0) {
sl@0	2908	/* Avoid doing zero-sized allocs... */
sl@0	2909	numArgs = 1;
sl@0	2910	}
sl@0	2911	*argTypesPtr = argTypes =
sl@0	2912	(Tcl_ValueType )ckalloc(numArgs sizeof(Tcl_ValueType));
sl@0	2913	for (i = 0; i < mathFuncPtr->numArgs; i++) {
sl@0	2914	argTypes[i] = mathFuncPtr->argTypes[i];
sl@0	2915	}
sl@0	2916
sl@0	2917	if (mathFuncPtr->builtinFuncIndex == -1) {
sl@0	2918	procPtr = (Tcl_MathProc ) NULL;
sl@0	2919	} else {
sl@0	2920	*procPtr = mathFuncPtr->proc;
sl@0	2921	*clientDataPtr = mathFuncPtr->clientData;
sl@0	2922	}
sl@0	2923
sl@0	2924	return TCL_OK;
sl@0	2925	}
sl@0	2926
sl@0	2927	/*
sl@0	2928	*----------------------------------------------------------------------
sl@0	2929	*
sl@0	2930	* Tcl_ListMathFuncs --
sl@0	2931	*
sl@0	2932	* Produces a list of all the math functions defined in a given
sl@0	2933	* interpreter.
sl@0	2934	*
sl@0	2935	* Results:
sl@0	2936	* A pointer to a Tcl_Obj structure with a reference count of zero,
sl@0	2937	* or NULL in the case of an error (in which case a suitable error
sl@0	2938	* message will be left in the interpreter result.)
sl@0	2939	*
sl@0	2940	* Side effects:
sl@0	2941	* None.
sl@0	2942	*
sl@0	2943	*----------------------------------------------------------------------
sl@0	2944	*/
sl@0	2945
sl@0	2946	EXPORT_C Tcl_Obj *
sl@0	2947	Tcl_ListMathFuncs(interp, pattern)
sl@0	2948	Tcl_Interp *interp;
sl@0	2949	CONST char *pattern;
sl@0	2950	{
sl@0	2951	Interp iPtr = (Interp ) interp;
sl@0	2952	Tcl_Obj *resultList = Tcl_NewObj();
sl@0	2953	register Tcl_HashEntry *hPtr;
sl@0	2954	Tcl_HashSearch hSearch;
sl@0	2955	CONST char *name;
sl@0	2956
sl@0	2957	for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch);
sl@0	2958	hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
sl@0	2959	name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr);
sl@0	2960	if ((pattern == NULL \|\| Tcl_StringMatch(name, pattern)) &&
sl@0	2961	/* I don't expect this to fail, but... */
sl@0	2962	Tcl_ListObjAppendElement(interp, resultList,
sl@0	2963	Tcl_NewStringObj(name,-1)) != TCL_OK) {
sl@0	2964	Tcl_DecrRefCount(resultList);
sl@0	2965	return NULL;
sl@0	2966	}
sl@0	2967	}
sl@0	2968	return resultList;
sl@0	2969	}
sl@0	2970
sl@0	2971	/*
sl@0	2972	*----------------------------------------------------------------------
sl@0	2973	*
sl@0	2974	* TclInterpReady --
sl@0	2975	*
sl@0	2976	* Check if an interpreter is ready to eval commands or scripts,
sl@0	2977	* i.e., if it was not deleted and if the nesting level is not
sl@0	2978	* too high.
sl@0	2979	*
sl@0	2980	* Results:
sl@0	2981	* The return value is TCL_OK if it the interpreter is ready,
sl@0	2982	* TCL_ERROR otherwise.
sl@0	2983	*
sl@0	2984	* Side effects:
sl@0	2985	* The interpreters object and string results are cleared.
sl@0	2986	*
sl@0	2987	*----------------------------------------------------------------------
sl@0	2988	*/
sl@0	2989
sl@0	2990	int
sl@0	2991	TclInterpReady(interp)
sl@0	2992	Tcl_Interp *interp;
sl@0	2993	{
sl@0	2994	register Interp iPtr = (Interp ) interp;
sl@0	2995
sl@0	2996	/*
sl@0	2997	* Reset both the interpreter's string and object results and clear
sl@0	2998	* out any previous error information.
sl@0	2999	*/
sl@0	3000
sl@0	3001	Tcl_ResetResult(interp);
sl@0	3002
sl@0	3003	/*
sl@0	3004	* If the interpreter has been deleted, return an error.
sl@0	3005	*/
sl@0	3006
sl@0	3007	if (iPtr->flags & DELETED) {
sl@0	3008	Tcl_ResetResult(interp);
sl@0	3009	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	3010	"attempt to call eval in deleted interpreter", -1);
sl@0	3011	Tcl_SetErrorCode(interp, "CORE", "IDELETE",
sl@0	3012	"attempt to call eval in deleted interpreter",
sl@0	3013	(char *) NULL);
sl@0	3014	return TCL_ERROR;
sl@0	3015	}
sl@0	3016
sl@0	3017	/*
sl@0	3018	* Check depth of nested calls to Tcl_Eval: if this gets too large,
sl@0	3019	* it's probably because of an infinite loop somewhere.
sl@0	3020	*/
sl@0	3021
sl@0	3022	if (((iPtr->numLevels) > iPtr->maxNestingDepth)
sl@0	3023	\|\| (TclpCheckStackSpace() == 0)) {
sl@0	3024	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	3025	"too many nested evaluations (infinite loop?)", -1);
sl@0	3026	return TCL_ERROR;
sl@0	3027	}
sl@0	3028
sl@0	3029	return TCL_OK;
sl@0	3030	}
sl@0	3031
sl@0	3032	/*
sl@0	3033	*----------------------------------------------------------------------
sl@0	3034	*
sl@0	3035	* TclEvalObjvInternal --
sl@0	3036	*
sl@0	3037	* This procedure evaluates a Tcl command that has already been
sl@0	3038	* parsed into words, with one Tcl_Obj holding each word. The caller
sl@0	3039	* is responsible for managing the iPtr->numLevels.
sl@0	3040	*
sl@0	3041	* Results:
sl@0	3042	* The return value is a standard Tcl completion code such as
sl@0	3043	* TCL_OK or TCL_ERROR. A result or error message is left in
sl@0	3044	* interp's result. If an error occurs, this procedure does
sl@0	3045	* NOT add any information to the errorInfo variable.
sl@0	3046	*
sl@0	3047	* Side effects:
sl@0	3048	* Depends on the command.
sl@0	3049	*
sl@0	3050	*----------------------------------------------------------------------
sl@0	3051	*/
sl@0	3052
sl@0	3053	int
sl@0	3054	TclEvalObjvInternal(interp, objc, objv, command, length, flags)
sl@0	3055	Tcl_Interp interp; / Interpreter in which to evaluate the
sl@0	3056	* command. Also used for error
sl@0	3057	* reporting. */
sl@0	3058	int objc; /* Number of words in command. */
sl@0	3059	Tcl_Obj CONST objv[]; / An array of pointers to objects that are
sl@0	3060	* the words that make up the command. */
sl@0	3061	CONST char command; / Points to the beginning of the string
sl@0	3062	* representation of the command; this
sl@0	3063	* is used for traces. If the string
sl@0	3064	* representation of the command is
sl@0	3065	* unknown, an empty string should be
sl@0	3066	* supplied. If it is NULL, no traces will
sl@0	3067	* be called. */
sl@0	3068	int length; /* Number of bytes in command; if -1, all
sl@0	3069	* characters up to the first null byte are
sl@0	3070	* used. */
sl@0	3071	int flags; /* Collection of OR-ed bits that control
sl@0	3072	* the evaluation of the script. Only
sl@0	3073	* TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
sl@0	3074	* currently supported. */
sl@0	3075
sl@0	3076	{
sl@0	3077	Command *cmdPtr;
sl@0	3078	Interp iPtr = (Interp ) interp;
sl@0	3079	Tcl_Obj **newObjv;
sl@0	3080	int i;
sl@0	3081	CallFrame savedVarFramePtr; / Saves old copy of iPtr->varFramePtr
sl@0	3082	* in case TCL_EVAL_GLOBAL was set. */
sl@0	3083	int code = TCL_OK;
sl@0	3084	int traceCode = TCL_OK;
sl@0	3085	int checkTraces = 1;
sl@0	3086	Namespace *savedNsPtr = NULL;
sl@0	3087
sl@0	3088	if (TclInterpReady(interp) == TCL_ERROR) {
sl@0	3089	return TCL_ERROR;
sl@0	3090	}
sl@0	3091
sl@0	3092	if (objc == 0) {
sl@0	3093	return TCL_OK;
sl@0	3094	}
sl@0	3095
sl@0	3096
sl@0	3097	/*
sl@0	3098	* If any execution traces rename or delete the current command,
sl@0	3099	* we may need (at most) two passes here.
sl@0	3100	*/
sl@0	3101
sl@0	3102	savedVarFramePtr = iPtr->varFramePtr;
sl@0	3103	while (1) {
sl@0	3104
sl@0	3105	/* Configure evaluation context to match the requested flags */
sl@0	3106	if (flags & TCL_EVAL_GLOBAL) {
sl@0	3107	iPtr->varFramePtr = NULL;
sl@0	3108	} else if ((flags & TCL_EVAL_INVOKE) && iPtr->varFramePtr) {
sl@0	3109	savedNsPtr = iPtr->varFramePtr->nsPtr;
sl@0	3110	iPtr->varFramePtr->nsPtr = iPtr->globalNsPtr;
sl@0	3111	}
sl@0	3112
sl@0	3113	/*
sl@0	3114	* Find the procedure to execute this command. If there isn't one,
sl@0	3115	* then see if there is a command "unknown". If so, create a new
sl@0	3116	* word array with "unknown" as the first word and the original
sl@0	3117	* command words as arguments. Then call ourselves recursively
sl@0	3118	* to execute it.
sl@0	3119	*/
sl@0	3120	cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
sl@0	3121	if (cmdPtr == NULL) {
sl@0	3122	newObjv = (Tcl_Obj **) ckalloc((unsigned)
sl@0	3123	((objc + 1) * sizeof (Tcl_Obj *)));
sl@0	3124	for (i = objc-1; i >= 0; i--) {
sl@0	3125	newObjv[i+1] = objv[i];
sl@0	3126	}
sl@0	3127	newObjv[0] = Tcl_NewStringObj("::unknown", -1);
sl@0	3128	Tcl_IncrRefCount(newObjv[0]);
sl@0	3129	cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
sl@0	3130	if (cmdPtr == NULL) {
sl@0	3131	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	3132	"invalid command name \"", Tcl_GetString(objv[0]), "\"",
sl@0	3133	(char *) NULL);
sl@0	3134	code = TCL_ERROR;
sl@0	3135	} else {
sl@0	3136	iPtr->numLevels++;
sl@0	3137	code = TclEvalObjvInternal(interp, objc+1, newObjv,
sl@0	3138	command, length, 0);
sl@0	3139	iPtr->numLevels--;
sl@0	3140	}
sl@0	3141	Tcl_DecrRefCount(newObjv[0]);
sl@0	3142	ckfree((char *) newObjv);
sl@0	3143	if (savedNsPtr) {
sl@0	3144	iPtr->varFramePtr->nsPtr = savedNsPtr;
sl@0	3145	}
sl@0	3146	goto done;
sl@0	3147	}
sl@0	3148	if (savedNsPtr) {
sl@0	3149	iPtr->varFramePtr->nsPtr = savedNsPtr;
sl@0	3150	}
sl@0	3151
sl@0	3152	/*
sl@0	3153	* Call trace procedures if needed.
sl@0	3154	*/
sl@0	3155	if ((checkTraces) && (command != NULL)) {
sl@0	3156	int cmdEpoch = cmdPtr->cmdEpoch;
sl@0	3157	int newEpoch;
sl@0	3158
sl@0	3159	cmdPtr->refCount++;
sl@0	3160	/*
sl@0	3161	* If the first set of traces modifies/deletes the command or
sl@0	3162	* any existing traces, then the set checkTraces to 0 and
sl@0	3163	* go through this while loop one more time.
sl@0	3164	*/
sl@0	3165	if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
sl@0	3166	traceCode = TclCheckInterpTraces(interp, command, length,
sl@0	3167	cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
sl@0	3168	}
sl@0	3169	if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES)
sl@0	3170	&& (traceCode == TCL_OK)) {
sl@0	3171	traceCode = TclCheckExecutionTraces(interp, command, length,
sl@0	3172	cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
sl@0	3173	}
sl@0	3174	newEpoch = cmdPtr->cmdEpoch;
sl@0	3175	TclCleanupCommand(cmdPtr);
sl@0	3176	if (cmdEpoch != newEpoch) {
sl@0	3177	/* The command has been modified in some way */
sl@0	3178	checkTraces = 0;
sl@0	3179	continue;
sl@0	3180	}
sl@0	3181	}
sl@0	3182	break;
sl@0	3183	}
sl@0	3184
sl@0	3185	/*
sl@0	3186	* Finally, invoke the command's Tcl_ObjCmdProc.
sl@0	3187	*/
sl@0	3188	cmdPtr->refCount++;
sl@0	3189	iPtr->cmdCount++;
sl@0	3190	if ( code == TCL_OK && traceCode == TCL_OK) {
sl@0	3191	code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
sl@0	3192	}
sl@0	3193	if (Tcl_AsyncReady()) {
sl@0	3194	code = Tcl_AsyncInvoke(interp, code);
sl@0	3195	}
sl@0	3196
sl@0	3197	/*
sl@0	3198	* Call 'leave' command traces
sl@0	3199	*/
sl@0	3200	if (!(cmdPtr->flags & CMD_IS_DELETED)) {
sl@0	3201	int saveErrFlags = iPtr->flags
sl@0	3202	& (ERR_IN_PROGRESS \| ERR_ALREADY_LOGGED \| ERROR_CODE_SET);
sl@0	3203	if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
sl@0	3204	traceCode = TclCheckExecutionTraces (interp, command, length,
sl@0	3205	cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
sl@0	3206	}
sl@0	3207	if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
sl@0	3208	traceCode = TclCheckInterpTraces(interp, command, length,
sl@0	3209	cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
sl@0	3210	}
sl@0	3211	if (traceCode == TCL_OK) {
sl@0	3212	iPtr->flags \|= saveErrFlags;
sl@0	3213	}
sl@0	3214	}
sl@0	3215	TclCleanupCommand(cmdPtr);
sl@0	3216
sl@0	3217	/*
sl@0	3218	* If one of the trace invocation resulted in error, then
sl@0	3219	* change the result code accordingly. Note, that the
sl@0	3220	* interp->result should already be set correctly by the
sl@0	3221	* call to TraceExecutionProc.
sl@0	3222	*/
sl@0	3223
sl@0	3224	if (traceCode != TCL_OK) {
sl@0	3225	code = traceCode;
sl@0	3226	}
sl@0	3227
sl@0	3228	/*
sl@0	3229	* If the interpreter has a non-empty string result, the result
sl@0	3230	* object is either empty or stale because some procedure set
sl@0	3231	* interp->result directly. If so, move the string result to the
sl@0	3232	* result object, then reset the string result.
sl@0	3233	*/
sl@0	3234
sl@0	3235	if (*(iPtr->result) != 0) {
sl@0	3236	(void) Tcl_GetObjResult(interp);
sl@0	3237	}
sl@0	3238
sl@0	3239	done:
sl@0	3240	iPtr->varFramePtr = savedVarFramePtr;
sl@0	3241	return code;
sl@0	3242	}
sl@0	3243
sl@0	3244	/*
sl@0	3245	*----------------------------------------------------------------------
sl@0	3246	*
sl@0	3247	* Tcl_EvalObjv --
sl@0	3248	*
sl@0	3249	* This procedure evaluates a Tcl command that has already been
sl@0	3250	* parsed into words, with one Tcl_Obj holding each word.
sl@0	3251	*
sl@0	3252	* Results:
sl@0	3253	* The return value is a standard Tcl completion code such as
sl@0	3254	* TCL_OK or TCL_ERROR. A result or error message is left in
sl@0	3255	* interp's result.
sl@0	3256	*
sl@0	3257	* Side effects:
sl@0	3258	* Depends on the command.
sl@0	3259	*
sl@0	3260	*----------------------------------------------------------------------
sl@0	3261	*/
sl@0	3262
sl@0	3263	EXPORT_C int
sl@0	3264	Tcl_EvalObjv(interp, objc, objv, flags)
sl@0	3265	Tcl_Interp interp; / Interpreter in which to evaluate the
sl@0	3266	* command. Also used for error
sl@0	3267	* reporting. */
sl@0	3268	int objc; /* Number of words in command. */
sl@0	3269	Tcl_Obj CONST objv[]; / An array of pointers to objects that are
sl@0	3270	* the words that make up the command. */
sl@0	3271	int flags; /* Collection of OR-ed bits that control
sl@0	3272	* the evaluation of the script. Only
sl@0	3273	* TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE
sl@0	3274	* are currently supported. */
sl@0	3275	{
sl@0	3276	Interp iPtr = (Interp )interp;
sl@0	3277	Trace *tracePtr;
sl@0	3278	Tcl_DString cmdBuf;
sl@0	3279	char cmdString = ""; / A command string is only necessary for
sl@0	3280	* command traces or error logs; it will be
sl@0	3281	* generated to replace this default value if
sl@0	3282	* necessary. */
sl@0	3283	int cmdLen = 0; /* a non-zero value indicates that a command
sl@0	3284	* string was generated. */
sl@0	3285	int code = TCL_OK;
sl@0	3286	int i;
sl@0	3287	int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
sl@0	3288
sl@0	3289	for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
sl@0	3290	if ((tracePtr->level == 0) \|\| (iPtr->numLevels <= tracePtr->level)) {
sl@0	3291	/*
sl@0	3292	* The command may be needed for an execution trace. Generate a
sl@0	3293	* command string.
sl@0	3294	*/
sl@0	3295
sl@0	3296	Tcl_DStringInit(&cmdBuf);
sl@0	3297	for (i = 0; i < objc; i++) {
sl@0	3298	Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
sl@0	3299	}
sl@0	3300	cmdString = Tcl_DStringValue(&cmdBuf);
sl@0	3301	cmdLen = Tcl_DStringLength(&cmdBuf);
sl@0	3302	break;
sl@0	3303	}
sl@0	3304	}
sl@0	3305
sl@0	3306	iPtr->numLevels++;
sl@0	3307	code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags);
sl@0	3308	iPtr->numLevels--;
sl@0	3309
sl@0	3310	/*
sl@0	3311	* If we are again at the top level, process any unusual
sl@0	3312	* return code returned by the evaluated code.
sl@0	3313	*/
sl@0	3314
sl@0	3315	if (iPtr->numLevels == 0) {
sl@0	3316	if (code == TCL_RETURN) {
sl@0	3317	code = TclUpdateReturnInfo(iPtr);
sl@0	3318	}
sl@0	3319	if ((code != TCL_OK) && (code != TCL_ERROR)
sl@0	3320	&& !allowExceptions) {
sl@0	3321	ProcessUnexpectedResult(interp, code);
sl@0	3322	code = TCL_ERROR;
sl@0	3323	}
sl@0	3324	}
sl@0	3325
sl@0	3326	if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) {
sl@0	3327
sl@0	3328	/*
sl@0	3329	* If there was an error, a command string will be needed for the
sl@0	3330	* error log: generate it now if it was not done previously.
sl@0	3331	*/
sl@0	3332
sl@0	3333	if (cmdLen == 0) {
sl@0	3334	Tcl_DStringInit(&cmdBuf);
sl@0	3335	for (i = 0; i < objc; i++) {
sl@0	3336	Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
sl@0	3337	}
sl@0	3338	cmdString = Tcl_DStringValue(&cmdBuf);
sl@0	3339	cmdLen = Tcl_DStringLength(&cmdBuf);
sl@0	3340	}
sl@0	3341	Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
sl@0	3342	}
sl@0	3343
sl@0	3344	if (cmdLen != 0) {
sl@0	3345	Tcl_DStringFree(&cmdBuf);
sl@0	3346	}
sl@0	3347	return code;
sl@0	3348	}
sl@0	3349
sl@0	3350	/*
sl@0	3351	*----------------------------------------------------------------------
sl@0	3352	*
sl@0	3353	* Tcl_LogCommandInfo --
sl@0	3354	*
sl@0	3355	* This procedure is invoked after an error occurs in an interpreter.
sl@0	3356	* It adds information to the "errorInfo" variable to describe the
sl@0	3357	* command that was being executed when the error occurred.
sl@0	3358	*
sl@0	3359	* Results:
sl@0	3360	* None.
sl@0	3361	*
sl@0	3362	* Side effects:
sl@0	3363	* Information about the command is added to errorInfo and the
sl@0	3364	* line number stored internally in the interpreter is set. If this
sl@0	3365	* is the first call to this procedure or Tcl_AddObjErrorInfo since
sl@0	3366	* an error occurred, then old information in errorInfo is
sl@0	3367	* deleted.
sl@0	3368	*
sl@0	3369	*----------------------------------------------------------------------
sl@0	3370	*/
sl@0	3371
sl@0	3372	EXPORT_C void
sl@0	3373	Tcl_LogCommandInfo(interp, script, command, length)
sl@0	3374	Tcl_Interp interp; / Interpreter in which to log information. */
sl@0	3375	CONST char script; / First character in script containing
sl@0	3376	* command (must be <= command). */
sl@0	3377	CONST char command; / First character in command that
sl@0	3378	* generated the error. */
sl@0	3379	int length; /* Number of bytes in command (-1 means
sl@0	3380	* use all bytes up to first null byte). */
sl@0	3381	{
sl@0	3382	char buffer[200];
sl@0	3383	register CONST char *p;
sl@0	3384	char *ellipsis = "";
sl@0	3385	Interp iPtr = (Interp ) interp;
sl@0	3386
sl@0	3387	if (iPtr->flags & ERR_ALREADY_LOGGED) {
sl@0	3388	/*
sl@0	3389	* Someone else has already logged error information for this
sl@0	3390	* command; we shouldn't add anything more.
sl@0	3391	*/
sl@0	3392
sl@0	3393	return;
sl@0	3394	}
sl@0	3395
sl@0	3396	/*
sl@0	3397	* Compute the line number where the error occurred.
sl@0	3398	*/
sl@0	3399
sl@0	3400	iPtr->errorLine = 1;
sl@0	3401	for (p = script; p != command; p++) {
sl@0	3402	if (*p == '\n') {
sl@0	3403	iPtr->errorLine++;
sl@0	3404	}
sl@0	3405	}
sl@0	3406
sl@0	3407	/*
sl@0	3408	* Create an error message to add to errorInfo, including up to a
sl@0	3409	* maximum number of characters of the command.
sl@0	3410	*/
sl@0	3411
sl@0	3412	if (length < 0) {
sl@0	3413	length = strlen(command);
sl@0	3414	}
sl@0	3415	if (length > 150) {
sl@0	3416	length = 150;
sl@0	3417	ellipsis = "...";
sl@0	3418	}
sl@0	3419	while ( (command[length] & 0xC0) == 0x80 ) {
sl@0	3420	/*
sl@0	3421	* Back up truncation point so that we don't truncate in the
sl@0	3422	* middle of a multi-byte character (in UTF-8)
sl@0	3423	*/
sl@0	3424	length--;
sl@0	3425	ellipsis = "...";
sl@0	3426	}
sl@0	3427	if (!(iPtr->flags & ERR_IN_PROGRESS)) {
sl@0	3428	sprintf(buffer, "\n while executing\n\"%.*s%s\"",
sl@0	3429	length, command, ellipsis);
sl@0	3430	} else {
sl@0	3431	sprintf(buffer, "\n invoked from within\n\"%.*s%s\"",
sl@0	3432	length, command, ellipsis);
sl@0	3433	}
sl@0	3434	Tcl_AddObjErrorInfo(interp, buffer, -1);
sl@0	3435	iPtr->flags &= ~ERR_ALREADY_LOGGED;
sl@0	3436	}
sl@0	3437
sl@0	3438	/*
sl@0	3439	*----------------------------------------------------------------------
sl@0	3440	*
sl@0	3441	* Tcl_EvalTokensStandard, EvalTokensStandard --
sl@0	3442	*
sl@0	3443	* Given an array of tokens parsed from a Tcl command (e.g., the
sl@0	3444	* tokens that make up a word or the index for an array variable)
sl@0	3445	* this procedure evaluates the tokens and concatenates their
sl@0	3446	* values to form a single result value.
sl@0	3447	*
sl@0	3448	* Results:
sl@0	3449	* The return value is a standard Tcl completion code such as
sl@0	3450	* TCL_OK or TCL_ERROR. A result or error message is left in
sl@0	3451	* interp's result.
sl@0	3452	*
sl@0	3453	* Side effects:
sl@0	3454	* Depends on the array of tokens being evaled.
sl@0	3455	*
sl@0	3456	* TIP #280 : Keep public API, internally extended API.
sl@0	3457	*----------------------------------------------------------------------
sl@0	3458	*/
sl@0	3459
sl@0	3460	EXPORT_C int
sl@0	3461	Tcl_EvalTokensStandard(interp, tokenPtr, count)
sl@0	3462	Tcl_Interp interp; / Interpreter in which to lookup
sl@0	3463	* variables, execute nested commands,
sl@0	3464	* and report errors. */
sl@0	3465	Tcl_Token tokenPtr; / Pointer to first in an array of tokens
sl@0	3466	* to evaluate and concatenate. */
sl@0	3467	int count; /* Number of tokens to consider at tokenPtr.
sl@0	3468	* Must be at least 1. */
sl@0	3469	{
sl@0	3470	#ifdef TCL_TIP280
sl@0	3471	return EvalTokensStandard (interp, tokenPtr, count, 1);
sl@0	3472	}
sl@0	3473
sl@0	3474	static int
sl@0	3475	EvalTokensStandard(interp, tokenPtr, count, line)
sl@0	3476	Tcl_Interp interp; / Interpreter in which to lookup
sl@0	3477	* variables, execute nested commands,
sl@0	3478	* and report errors. */
sl@0	3479	Tcl_Token tokenPtr; / Pointer to first in an array of tokens
sl@0	3480	* to evaluate and concatenate. */
sl@0	3481	int count; /* Number of tokens to consider at tokenPtr.
sl@0	3482	* Must be at least 1. */
sl@0	3483	int line; /* The line the script starts on. */
sl@0	3484	{
sl@0	3485	#endif
sl@0	3486	Tcl_Obj resultPtr, indexPtr, *valuePtr;
sl@0	3487	char buffer[TCL_UTF_MAX];
sl@0	3488	#ifdef TCL_MEM_DEBUG
sl@0	3489	# define MAX_VAR_CHARS 5
sl@0	3490	#else
sl@0	3491	# define MAX_VAR_CHARS 30
sl@0	3492	#endif
sl@0	3493	char nameBuffer[MAX_VAR_CHARS+1];
sl@0	3494	char varName, index;
sl@0	3495	CONST char p = NULL; / Initialized to avoid compiler warning. */
sl@0	3496	int length, code;
sl@0	3497
sl@0	3498	/*
sl@0	3499	* The only tricky thing about this procedure is that it attempts to
sl@0	3500	* avoid object creation and string copying whenever possible. For
sl@0	3501	* example, if the value is just a nested command, then use the
sl@0	3502	* command's result object directly.
sl@0	3503	*/
sl@0	3504
sl@0	3505	code = TCL_OK;
sl@0	3506	resultPtr = NULL;
sl@0	3507	Tcl_ResetResult(interp);
sl@0	3508	for ( ; count > 0; count--, tokenPtr++) {
sl@0	3509	valuePtr = NULL;
sl@0	3510
sl@0	3511	/*
sl@0	3512	* The switch statement below computes the next value to be
sl@0	3513	* concat to the result, as either a range of text or an
sl@0	3514	* object.
sl@0	3515	*/
sl@0	3516
sl@0	3517	switch (tokenPtr->type) {
sl@0	3518	case TCL_TOKEN_TEXT:
sl@0	3519	p = tokenPtr->start;
sl@0	3520	length = tokenPtr->size;
sl@0	3521	break;
sl@0	3522
sl@0	3523	case TCL_TOKEN_BS:
sl@0	3524	length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
sl@0	3525	buffer);
sl@0	3526	p = buffer;
sl@0	3527	break;
sl@0	3528
sl@0	3529	case TCL_TOKEN_COMMAND: {
sl@0	3530	Interp iPtr = (Interp ) interp;
sl@0	3531	iPtr->numLevels++;
sl@0	3532	code = TclInterpReady(interp);
sl@0	3533	if (code == TCL_OK) {
sl@0	3534	#ifndef TCL_TIP280
sl@0	3535	code = Tcl_EvalEx(interp,
sl@0	3536	tokenPtr->start+1, tokenPtr->size-2, 0);
sl@0	3537	#else
sl@0	3538	/* TIP #280: Transfer line information to nested command */
sl@0	3539	code = EvalEx(interp,
sl@0	3540	tokenPtr->start+1, tokenPtr->size-2, 0, line);
sl@0	3541	#endif
sl@0	3542	}
sl@0	3543	iPtr->numLevels--;
sl@0	3544	if (code != TCL_OK) {
sl@0	3545	goto done;
sl@0	3546	}
sl@0	3547	valuePtr = Tcl_GetObjResult(interp);
sl@0	3548	break;
sl@0	3549	}
sl@0	3550
sl@0	3551	case TCL_TOKEN_VARIABLE:
sl@0	3552	if (tokenPtr->numComponents == 1) {
sl@0	3553	indexPtr = NULL;
sl@0	3554	index = NULL;
sl@0	3555	} else {
sl@0	3556	#ifndef TCL_TIP280
sl@0	3557	code = Tcl_EvalTokensStandard(interp, tokenPtr+2,
sl@0	3558	tokenPtr->numComponents - 1);
sl@0	3559	#else
sl@0	3560	/* TIP #280: Transfer line information to nested command */
sl@0	3561	code = EvalTokensStandard(interp, tokenPtr+2,
sl@0	3562	tokenPtr->numComponents - 1, line);
sl@0	3563	#endif
sl@0	3564	if (code != TCL_OK) {
sl@0	3565	goto done;
sl@0	3566	}
sl@0	3567	indexPtr = Tcl_GetObjResult(interp);
sl@0	3568	Tcl_IncrRefCount(indexPtr);
sl@0	3569	index = Tcl_GetString(indexPtr);
sl@0	3570	}
sl@0	3571
sl@0	3572	/*
sl@0	3573	* We have to make a copy of the variable name in order
sl@0	3574	* to have a null-terminated string. We can't make a
sl@0	3575	* temporary modification to the script to null-terminate
sl@0	3576	* the name, because a trace callback might potentially
sl@0	3577	* reuse the script and be affected by the null character.
sl@0	3578	*/
sl@0	3579
sl@0	3580	if (tokenPtr[1].size <= MAX_VAR_CHARS) {
sl@0	3581	varName = nameBuffer;
sl@0	3582	} else {
sl@0	3583	varName = ckalloc((unsigned) (tokenPtr[1].size + 1));
sl@0	3584	}
sl@0	3585	strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size);
sl@0	3586	varName[tokenPtr[1].size] = 0;
sl@0	3587	valuePtr = Tcl_GetVar2Ex(interp, varName, index,
sl@0	3588	TCL_LEAVE_ERR_MSG);
sl@0	3589	if (varName != nameBuffer) {
sl@0	3590	ckfree(varName);
sl@0	3591	}
sl@0	3592	if (indexPtr != NULL) {
sl@0	3593	Tcl_DecrRefCount(indexPtr);
sl@0	3594	}
sl@0	3595	if (valuePtr == NULL) {
sl@0	3596	code = TCL_ERROR;
sl@0	3597	goto done;
sl@0	3598	}
sl@0	3599	count -= tokenPtr->numComponents;
sl@0	3600	tokenPtr += tokenPtr->numComponents;
sl@0	3601	break;
sl@0	3602
sl@0	3603	default:
sl@0	3604	panic("unexpected token type in Tcl_EvalTokensStandard");
sl@0	3605	}
sl@0	3606
sl@0	3607	/*
sl@0	3608	* If valuePtr isn't NULL, the next piece of text comes from that
sl@0	3609	* object; otherwise, take length bytes starting at p.
sl@0	3610	*/
sl@0	3611
sl@0	3612	if (resultPtr == NULL) {
sl@0	3613	if (valuePtr != NULL) {
sl@0	3614	resultPtr = valuePtr;
sl@0	3615	} else {
sl@0	3616	resultPtr = Tcl_NewStringObj(p, length);
sl@0	3617	}
sl@0	3618	Tcl_IncrRefCount(resultPtr);
sl@0	3619	} else {
sl@0	3620	if (Tcl_IsShared(resultPtr)) {
sl@0	3621	Tcl_DecrRefCount(resultPtr);
sl@0	3622	resultPtr = Tcl_DuplicateObj(resultPtr);
sl@0	3623	Tcl_IncrRefCount(resultPtr);
sl@0	3624	}
sl@0	3625	if (valuePtr != NULL) {
sl@0	3626	p = Tcl_GetStringFromObj(valuePtr, &length);
sl@0	3627	}
sl@0	3628	Tcl_AppendToObj(resultPtr, p, length);
sl@0	3629	}
sl@0	3630	}
sl@0	3631	if (resultPtr != NULL) {
sl@0	3632	Tcl_SetObjResult(interp, resultPtr);
sl@0	3633	} else {
sl@0	3634	code = TCL_ERROR;
sl@0	3635	}
sl@0	3636
sl@0	3637	done:
sl@0	3638	if (resultPtr != NULL) {
sl@0	3639	Tcl_DecrRefCount(resultPtr);
sl@0	3640	}
sl@0	3641	return code;
sl@0	3642	}
sl@0	3643
sl@0	3644	/*
sl@0	3645	*----------------------------------------------------------------------
sl@0	3646	*
sl@0	3647	* Tcl_EvalTokens --
sl@0	3648	*
sl@0	3649	* Given an array of tokens parsed from a Tcl command (e.g., the
sl@0	3650	* tokens that make up a word or the index for an array variable)
sl@0	3651	* this procedure evaluates the tokens and concatenates their
sl@0	3652	* values to form a single result value.
sl@0	3653	*
sl@0	3654	* Results:
sl@0	3655	* The return value is a pointer to a newly allocated Tcl_Obj
sl@0	3656	* containing the value of the array of tokens. The reference
sl@0	3657	* count of the returned object has been incremented. If an error
sl@0	3658	* occurs in evaluating the tokens then a NULL value is returned
sl@0	3659	* and an error message is left in interp's result.
sl@0	3660	*
sl@0	3661	* Side effects:
sl@0	3662	* A new object is allocated to hold the result.
sl@0	3663	*
sl@0	3664	*----------------------------------------------------------------------
sl@0	3665	*
sl@0	3666	* This uses a non-standard return convention; its use is now deprecated.
sl@0	3667	* It is a wrapper for the new function Tcl_EvalTokensStandard, and is not
sl@0	3668	* used in the core any longer. It is only kept for backward compatibility.
sl@0	3669	*/
sl@0	3670
sl@0	3671	EXPORT_C Tcl_Obj *
sl@0	3672	Tcl_EvalTokens(interp, tokenPtr, count)
sl@0	3673	Tcl_Interp interp; / Interpreter in which to lookup
sl@0	3674	* variables, execute nested commands,
sl@0	3675	* and report errors. */
sl@0	3676	Tcl_Token tokenPtr; / Pointer to first in an array of tokens
sl@0	3677	* to evaluate and concatenate. */
sl@0	3678	int count; /* Number of tokens to consider at tokenPtr.
sl@0	3679	* Must be at least 1. */
sl@0	3680	{
sl@0	3681	int code;
sl@0	3682	Tcl_Obj *resPtr;
sl@0	3683
sl@0	3684	code = Tcl_EvalTokensStandard(interp, tokenPtr, count);
sl@0	3685	if (code == TCL_OK) {
sl@0	3686	resPtr = Tcl_GetObjResult(interp);
sl@0	3687	Tcl_IncrRefCount(resPtr);
sl@0	3688	Tcl_ResetResult(interp);
sl@0	3689	return resPtr;
sl@0	3690	} else {
sl@0	3691	return NULL;
sl@0	3692	}
sl@0	3693	}
sl@0	3694
sl@0	3695
sl@0	3696	/*
sl@0	3697	*----------------------------------------------------------------------
sl@0	3698	*
sl@0	3699	* Tcl_EvalEx, EvalEx --
sl@0	3700	*
sl@0	3701	* This procedure evaluates a Tcl script without using the compiler
sl@0	3702	* or byte-code interpreter. It just parses the script, creates
sl@0	3703	* values for each word of each command, then calls EvalObjv
sl@0	3704	* to execute each command.
sl@0	3705	*
sl@0	3706	* Results:
sl@0	3707	* The return value is a standard Tcl completion code such as
sl@0	3708	* TCL_OK or TCL_ERROR. A result or error message is left in
sl@0	3709	* interp's result.
sl@0	3710	*
sl@0	3711	* Side effects:
sl@0	3712	* Depends on the script.
sl@0	3713	*
sl@0	3714	* TIP #280 : Keep public API, internally extended API.
sl@0	3715	*----------------------------------------------------------------------
sl@0	3716	*/
sl@0	3717
sl@0	3718	EXPORT_C int
sl@0	3719	Tcl_EvalEx(interp, script, numBytes, flags)
sl@0	3720	Tcl_Interp interp; / Interpreter in which to evaluate the
sl@0	3721	* script. Also used for error reporting. */
sl@0	3722	CONST char script; / First character of script to evaluate. */
sl@0	3723	int numBytes; /* Number of bytes in script. If < 0, the
sl@0	3724	* script consists of all bytes up to the
sl@0	3725	* first null character. */
sl@0	3726	int flags; /* Collection of OR-ed bits that control
sl@0	3727	* the evaluation of the script. Only
sl@0	3728	* TCL_EVAL_GLOBAL is currently
sl@0	3729	* supported. */
sl@0	3730	{
sl@0	3731	#ifdef TCL_TIP280
sl@0	3732	return EvalEx (interp, script, numBytes, flags, 1);
sl@0	3733	}
sl@0	3734
sl@0	3735	static int
sl@0	3736	EvalEx(interp, script, numBytes, flags, line)
sl@0	3737	Tcl_Interp interp; / Interpreter in which to evaluate the
sl@0	3738	* script. Also used for error reporting. */
sl@0	3739	CONST char script; / First character of script to evaluate. */
sl@0	3740	int numBytes; /* Number of bytes in script. If < 0, the
sl@0	3741	* script consists of all bytes up to the
sl@0	3742	* first null character. */
sl@0	3743	int flags; /* Collection of OR-ed bits that control
sl@0	3744	* the evaluation of the script. Only
sl@0	3745	* TCL_EVAL_GLOBAL is currently
sl@0	3746	* supported. */
sl@0	3747	int line; /* The line the script starts on. */
sl@0	3748	{
sl@0	3749	#endif
sl@0	3750	Interp iPtr = (Interp ) interp;
sl@0	3751	CONST char p, next;
sl@0	3752	Tcl_Parse parse;
sl@0	3753	#define NUM_STATIC_OBJS 20
sl@0	3754	Tcl_Obj staticObjArray[NUM_STATIC_OBJS], *objv;
sl@0	3755	Tcl_Token *tokenPtr;
sl@0	3756	int code = TCL_OK;
sl@0	3757	int i, commandLength, bytesLeft, nested;
sl@0	3758	CallFrame savedVarFramePtr; / Saves old copy of iPtr->varFramePtr
sl@0	3759	* in case TCL_EVAL_GLOBAL was set. */
sl@0	3760	int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
sl@0	3761
sl@0	3762	/*
sl@0	3763	* The variables below keep track of how much state has been
sl@0	3764	* allocated while evaluating the script, so that it can be freed
sl@0	3765	* properly if an error occurs.
sl@0	3766	*/
sl@0	3767
sl@0	3768	int gotParse = 0, objectsUsed = 0;
sl@0	3769
sl@0	3770	#ifdef TCL_TIP280
sl@0	3771	/* TIP #280 Structures for tracking of command locations. */
sl@0	3772	CmdFrame eeFrame;
sl@0	3773	#endif
sl@0	3774
sl@0	3775	if (numBytes < 0) {
sl@0	3776	numBytes = strlen(script);
sl@0	3777	}
sl@0	3778	Tcl_ResetResult(interp);
sl@0	3779
sl@0	3780	savedVarFramePtr = iPtr->varFramePtr;
sl@0	3781	if (flags & TCL_EVAL_GLOBAL) {
sl@0	3782	iPtr->varFramePtr = NULL;
sl@0	3783	}
sl@0	3784
sl@0	3785	/*
sl@0	3786	* Each iteration through the following loop parses the next
sl@0	3787	* command from the script and then executes it.
sl@0	3788	*/
sl@0	3789
sl@0	3790	objv = staticObjArray;
sl@0	3791	p = script;
sl@0	3792	bytesLeft = numBytes;
sl@0	3793	if (iPtr->evalFlags & TCL_BRACKET_TERM) {
sl@0	3794	nested = 1;
sl@0	3795	} else {
sl@0	3796	nested = 0;
sl@0	3797	}
sl@0	3798
sl@0	3799	#ifdef TCL_TIP280
sl@0	3800	/* TIP #280 Initialize tracking. Do not push on the frame stack yet. */
sl@0	3801	/*
sl@0	3802	* We may cont. counting based on a specific context (CTX), or open a new
sl@0	3803	* context, either for a sourced script, or 'eval'. For sourced files we
sl@0	3804	* always have a path object, even if nothing was specified in the interp
sl@0	3805	* itself. That makes code using it simpler as NULL checks can be left
sl@0	3806	* out. Sourced file without path in the 'scriptFile' is possible during
sl@0	3807	* Tcl initialization.
sl@0	3808	*/
sl@0	3809
sl@0	3810	if (iPtr->evalFlags & TCL_EVAL_CTX) {
sl@0	3811	/* Path information comes out of the context. */
sl@0	3812
sl@0	3813	eeFrame.type = TCL_LOCATION_SOURCE;
sl@0	3814	eeFrame.data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path;
sl@0	3815	Tcl_IncrRefCount (eeFrame.data.eval.path);
sl@0	3816	} else if (iPtr->evalFlags & TCL_EVAL_FILE) {
sl@0	3817	/* Set up for a sourced file */
sl@0	3818
sl@0	3819	eeFrame.type = TCL_LOCATION_SOURCE;
sl@0	3820
sl@0	3821	if (iPtr->scriptFile) {
sl@0	3822	/* Normalization here, to have the correct pwd. Should have
sl@0	3823	* negligible impact on performance, as the norm should have been
sl@0	3824	* done already by the 'source' invoking us, and it caches the
sl@0	3825	* result
sl@0	3826	*/
sl@0	3827
sl@0	3828	Tcl_Obj* norm = Tcl_FSGetNormalizedPath (interp, iPtr->scriptFile);
sl@0	3829	if (!norm) {
sl@0	3830	/* Error message in the interp result */
sl@0	3831	return TCL_ERROR;
sl@0	3832	}
sl@0	3833	eeFrame.data.eval.path = norm;
sl@0	3834	Tcl_IncrRefCount (eeFrame.data.eval.path);
sl@0	3835	} else {
sl@0	3836	eeFrame.data.eval.path = Tcl_NewStringObj ("",-1);
sl@0	3837	}
sl@0	3838	} else {
sl@0	3839	/* Set up for plain eval */
sl@0	3840
sl@0	3841	eeFrame.type = TCL_LOCATION_EVAL;
sl@0	3842	eeFrame.data.eval.path = NULL;
sl@0	3843	}
sl@0	3844
sl@0	3845	eeFrame.level = (iPtr->cmdFramePtr == NULL
sl@0	3846	? 1
sl@0	3847	: iPtr->cmdFramePtr->level + 1);
sl@0	3848	eeFrame.framePtr = iPtr->framePtr;
sl@0	3849	eeFrame.nextPtr = iPtr->cmdFramePtr;
sl@0	3850	eeFrame.nline = 0;
sl@0	3851	eeFrame.line = NULL;
sl@0	3852	#endif
sl@0	3853
sl@0	3854	iPtr->evalFlags = 0;
sl@0	3855	do {
sl@0	3856	if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse)
sl@0	3857	!= TCL_OK) {
sl@0	3858	code = TCL_ERROR;
sl@0	3859	goto error;
sl@0	3860	}
sl@0	3861	gotParse = 1;
sl@0	3862
sl@0	3863	if (nested && parse.term == (script + numBytes)) {
sl@0	3864	/*
sl@0	3865	* A nested script can only terminate in ']'. If
sl@0	3866	* the parsing got terminated at the end of the script,
sl@0	3867	* there was no closing ']'. Report the syntax error.
sl@0	3868	*/
sl@0	3869
sl@0	3870	code = TCL_ERROR;
sl@0	3871	goto error;
sl@0	3872	}
sl@0	3873
sl@0	3874	#ifdef TCL_TIP280
sl@0	3875	/*
sl@0	3876	* TIP #280 Track lines. The parser may have skipped text till it
sl@0	3877	* found the command we are now at. We have count the lines in this
sl@0	3878	* block.
sl@0	3879	*/
sl@0	3880
sl@0	3881	TclAdvanceLines (&line, p, parse.commandStart);
sl@0	3882	#endif
sl@0	3883
sl@0	3884	if (parse.numWords > 0) {
sl@0	3885	#ifdef TCL_TIP280
sl@0	3886	/*
sl@0	3887	* TIP #280. Track lines within the words of the current
sl@0	3888	* command.
sl@0	3889	*/
sl@0	3890
sl@0	3891	int wordLine = line;
sl@0	3892	CONST char* wordStart = parse.commandStart;
sl@0	3893	#endif
sl@0	3894
sl@0	3895	/*
sl@0	3896	* Generate an array of objects for the words of the command.
sl@0	3897	*/
sl@0	3898
sl@0	3899	if (parse.numWords <= NUM_STATIC_OBJS) {
sl@0	3900	objv = staticObjArray;
sl@0	3901	} else {
sl@0	3902	objv = (Tcl_Obj **) ckalloc((unsigned)
sl@0	3903	(parse.numWords * sizeof (Tcl_Obj *)));
sl@0	3904	}
sl@0	3905
sl@0	3906	#ifdef TCL_TIP280
sl@0	3907	eeFrame.nline = parse.numWords;
sl@0	3908	eeFrame.line = (int*) ckalloc((unsigned)
sl@0	3909	(parse.numWords * sizeof (int)));
sl@0	3910	#endif
sl@0	3911
sl@0	3912	for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
sl@0	3913	objectsUsed < parse.numWords;
sl@0	3914	objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
sl@0	3915	#ifndef TCL_TIP280
sl@0	3916	code = Tcl_EvalTokensStandard(interp, tokenPtr+1,
sl@0	3917	tokenPtr->numComponents);
sl@0	3918	#else
sl@0	3919	/*
sl@0	3920	* TIP #280. Track lines to current word. Save the
sl@0	3921	* information on a per-word basis, signaling dynamic words as
sl@0	3922	* needed. Make the information available to the recursively
sl@0	3923	* called evaluator as well, including the type of context
sl@0	3924	* (source vs. eval).
sl@0	3925	*/
sl@0	3926
sl@0	3927	TclAdvanceLines (&wordLine, wordStart, tokenPtr->start);
sl@0	3928	wordStart = tokenPtr->start;
sl@0	3929
sl@0	3930	eeFrame.line [objectsUsed] = (TclWordKnownAtCompileTime (tokenPtr)
sl@0	3931	? wordLine
sl@0	3932	: -1);
sl@0	3933
sl@0	3934	if (eeFrame.type == TCL_LOCATION_SOURCE) {
sl@0	3935	iPtr->evalFlags \|= TCL_EVAL_FILE;
sl@0	3936	}
sl@0	3937
sl@0	3938	code = EvalTokensStandard(interp, tokenPtr+1,
sl@0	3939	tokenPtr->numComponents, wordLine);
sl@0	3940
sl@0	3941	iPtr->evalFlags = 0;
sl@0	3942	#endif
sl@0	3943
sl@0	3944	if (code == TCL_OK) {
sl@0	3945	objv[objectsUsed] = Tcl_GetObjResult(interp);
sl@0	3946	Tcl_IncrRefCount(objv[objectsUsed]);
sl@0	3947	} else {
sl@0	3948	goto error;
sl@0	3949	}
sl@0	3950	}
sl@0	3951
sl@0	3952	/*
sl@0	3953	* Execute the command and free the objects for its words.
sl@0	3954	*
sl@0	3955	* TIP #280: Remember the command itself for 'info frame'. We
sl@0	3956	* shorten the visible command by one char to exclude the
sl@0	3957	* termination character, if necessary. Here is where we put our
sl@0	3958	* frame on the stack of frames too. _After_ the nested commands
sl@0	3959	* have been executed.
sl@0	3960	*/
sl@0	3961
sl@0	3962	#ifdef TCL_TIP280
sl@0	3963	eeFrame.cmd.str.cmd = parse.commandStart;
sl@0	3964	eeFrame.cmd.str.len = parse.commandSize;
sl@0	3965
sl@0	3966	if (parse.term == parse.commandStart + parse.commandSize - 1) {
sl@0	3967	eeFrame.cmd.str.len --;
sl@0	3968	}
sl@0	3969
sl@0	3970	iPtr->cmdFramePtr = &eeFrame;
sl@0	3971	#endif
sl@0	3972	iPtr->numLevels++;
sl@0	3973	code = TclEvalObjvInternal(interp, objectsUsed, objv,
sl@0	3974	parse.commandStart, parse.commandSize, 0);
sl@0	3975	iPtr->numLevels--;
sl@0	3976	#ifdef TCL_TIP280
sl@0	3977	iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
sl@0	3978
sl@0	3979	ckfree ((char*) eeFrame.line);
sl@0	3980	eeFrame.line = NULL;
sl@0	3981	eeFrame.nline = 0;
sl@0	3982	#endif
sl@0	3983
sl@0	3984	if (code != TCL_OK) {
sl@0	3985	goto error;
sl@0	3986	}
sl@0	3987	for (i = 0; i < objectsUsed; i++) {
sl@0	3988	Tcl_DecrRefCount(objv[i]);
sl@0	3989	}
sl@0	3990	objectsUsed = 0;
sl@0	3991	if (objv != staticObjArray) {
sl@0	3992	ckfree((char *) objv);
sl@0	3993	objv = staticObjArray;
sl@0	3994	}
sl@0	3995	}
sl@0	3996
sl@0	3997	/*
sl@0	3998	* Advance to the next command in the script.
sl@0	3999	*
sl@0	4000	* TIP #280 Track Lines. Now we track how many lines were in the
sl@0	4001	* executed command.
sl@0	4002	*/
sl@0	4003
sl@0	4004	next = parse.commandStart + parse.commandSize;
sl@0	4005	bytesLeft -= next - p;
sl@0	4006	p = next;
sl@0	4007	#ifdef TCL_TIP280
sl@0	4008	TclAdvanceLines (&line, parse.commandStart, p);
sl@0	4009	#endif
sl@0	4010	Tcl_FreeParse(&parse);
sl@0	4011	gotParse = 0;
sl@0	4012	if (nested && (*parse.term == ']')) {
sl@0	4013	/*
sl@0	4014	* We get here in the special case where the TCL_BRACKET_TERM
sl@0	4015	* flag was set in the interpreter and the latest parsed command
sl@0	4016	* was terminated by the matching close-bracket we seek.
sl@0	4017	* Return immediately.
sl@0	4018	*/
sl@0	4019
sl@0	4020	iPtr->termOffset = (p - 1) - script;
sl@0	4021	iPtr->varFramePtr = savedVarFramePtr;
sl@0	4022	#ifndef TCL_TIP280
sl@0	4023	return TCL_OK;
sl@0	4024	#else
sl@0	4025	code = TCL_OK;
sl@0	4026	goto cleanup_return;
sl@0	4027	#endif
sl@0	4028	}
sl@0	4029	} while (bytesLeft > 0);
sl@0	4030
sl@0	4031	if (nested) {
sl@0	4032	/*
sl@0	4033	* This nested script did not terminate in ']', it is an error.
sl@0	4034	*/
sl@0	4035
sl@0	4036	code = TCL_ERROR;
sl@0	4037	goto error;
sl@0	4038	}
sl@0	4039
sl@0	4040	iPtr->termOffset = p - script;
sl@0	4041	iPtr->varFramePtr = savedVarFramePtr;
sl@0	4042	#ifndef TCL_TIP280
sl@0	4043	return TCL_OK;
sl@0	4044	#else
sl@0	4045	code = TCL_OK;
sl@0	4046	goto cleanup_return;
sl@0	4047	#endif
sl@0	4048
sl@0	4049	error:
sl@0	4050	/*
sl@0	4051	* Generate various pieces of error information, such as the line
sl@0	4052	* number where the error occurred and information to add to the
sl@0	4053	* errorInfo variable. Then free resources that had been allocated
sl@0	4054	* to the command.
sl@0	4055	*/
sl@0	4056
sl@0	4057	if (iPtr->numLevels == 0) {
sl@0	4058	if (code == TCL_RETURN) {
sl@0	4059	code = TclUpdateReturnInfo(iPtr);
sl@0	4060	}
sl@0	4061	if ((code != TCL_OK) && (code != TCL_ERROR)
sl@0	4062	&& !allowExceptions) {
sl@0	4063	ProcessUnexpectedResult(interp, code);
sl@0	4064	code = TCL_ERROR;
sl@0	4065	}
sl@0	4066	}
sl@0	4067	if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
sl@0	4068	commandLength = parse.commandSize;
sl@0	4069	if (parse.term == parse.commandStart + commandLength - 1) {
sl@0	4070	/*
sl@0	4071	* The terminator character (such as ; or ]) of the command where
sl@0	4072	* the error occurred is the last character in the parsed command.
sl@0	4073	* Reduce the length by one so that the error message doesn't
sl@0	4074	* include the terminator character.
sl@0	4075	*/
sl@0	4076
sl@0	4077	commandLength -= 1;
sl@0	4078	}
sl@0	4079	Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength);
sl@0	4080	}
sl@0	4081
sl@0	4082	for (i = 0; i < objectsUsed; i++) {
sl@0	4083	Tcl_DecrRefCount(objv[i]);
sl@0	4084	}
sl@0	4085	if (gotParse) {
sl@0	4086	Tcl_FreeParse(&parse);
sl@0	4087	}
sl@0	4088	if (objv != staticObjArray) {
sl@0	4089	ckfree((char *) objv);
sl@0	4090	}
sl@0	4091	iPtr->varFramePtr = savedVarFramePtr;
sl@0	4092
sl@0	4093	/*
sl@0	4094	* All that's left to do before returning is to set iPtr->termOffset
sl@0	4095	* to point past the end of the script we just evaluated.
sl@0	4096	*/
sl@0	4097
sl@0	4098	next = parse.commandStart + parse.commandSize;
sl@0	4099	bytesLeft -= next - p;
sl@0	4100	p = next;
sl@0	4101
sl@0	4102	if (!nested) {
sl@0	4103	iPtr->termOffset = p - script;
sl@0	4104	#ifndef TCL_TIP280
sl@0	4105	return code;
sl@0	4106	#else
sl@0	4107	goto cleanup_return;
sl@0	4108	#endif
sl@0	4109	}
sl@0	4110
sl@0	4111	/*
sl@0	4112	* When we are nested (the TCL_BRACKET_TERM flag was set in the
sl@0	4113	* interpreter), we must find the matching close-bracket to
sl@0	4114	* end the script we are evaluating.
sl@0	4115	*
sl@0	4116	* When our return code is TCL_CONTINUE or TCL_RETURN, we want
sl@0	4117	* to correctly set iPtr->termOffset to point to that matching
sl@0	4118	* close-bracket so our caller can move to the part of the
sl@0	4119	* string beyond the script we were asked to evaluate.
sl@0	4120	* So we try to parse past the rest of the commands.
sl@0	4121	*/
sl@0	4122
sl@0	4123	next = NULL;
sl@0	4124	while (bytesLeft && (*parse.term != ']')) {
sl@0	4125	if (TCL_OK != Tcl_ParseCommand(NULL, p, bytesLeft, 1, &parse)) {
sl@0	4126	/*
sl@0	4127	* Syntax error. Set the termOffset to the beginning of
sl@0	4128	* the last command parsed.
sl@0	4129	*/
sl@0	4130
sl@0	4131	if (next == NULL) {
sl@0	4132	iPtr->termOffset = (parse.commandStart - 1) - script;
sl@0	4133	} else {
sl@0	4134	iPtr->termOffset = (next - 1) - script;
sl@0	4135	}
sl@0	4136	#ifndef TCL_TIP280
sl@0	4137	return code;
sl@0	4138	#else
sl@0	4139	goto cleanup_return;
sl@0	4140	#endif
sl@0	4141	}
sl@0	4142	next = parse.commandStart + parse.commandSize;
sl@0	4143	bytesLeft -= next - p;
sl@0	4144	p = next;
sl@0	4145	next = parse.commandStart;
sl@0	4146	Tcl_FreeParse(&parse);
sl@0	4147	}
sl@0	4148
sl@0	4149	if (bytesLeft) {
sl@0	4150	/*
sl@0	4151	* parse.term points to the close-bracket.
sl@0	4152	*/
sl@0	4153
sl@0	4154	iPtr->termOffset = parse.term - script;
sl@0	4155	} else if (parse.term == script + numBytes) {
sl@0	4156	/*
sl@0	4157	* There was no close-bracket. Syntax error.
sl@0	4158	*/
sl@0	4159
sl@0	4160	iPtr->termOffset = parse.term - script;
sl@0	4161	Tcl_SetObjResult(interp,
sl@0	4162	Tcl_NewStringObj("missing close-bracket", -1));
sl@0	4163	#ifndef TCL_TIP280
sl@0	4164	return TCL_ERROR;
sl@0	4165	#else
sl@0	4166	code = TCL_ERROR;
sl@0	4167	goto cleanup_return;
sl@0	4168	#endif
sl@0	4169	} else if (*parse.term != ']') {
sl@0	4170	/*
sl@0	4171	* There was no close-bracket. Syntax error.
sl@0	4172	*/
sl@0	4173
sl@0	4174	iPtr->termOffset = (parse.term + 1) - script;
sl@0	4175	Tcl_SetObjResult(interp,
sl@0	4176	Tcl_NewStringObj("missing close-bracket", -1));
sl@0	4177	#ifndef TCL_TIP280
sl@0	4178	return TCL_ERROR;
sl@0	4179	#else
sl@0	4180	code = TCL_ERROR;
sl@0	4181	goto cleanup_return;
sl@0	4182	#endif
sl@0	4183	} else {
sl@0	4184	/*
sl@0	4185	* parse.term points to the close-bracket.
sl@0	4186	*/
sl@0	4187	iPtr->termOffset = parse.term - script;
sl@0	4188	}
sl@0	4189
sl@0	4190	#ifdef TCL_TIP280
sl@0	4191	cleanup_return:
sl@0	4192	/* TIP #280. Release the local CmdFrame, and its contents. */
sl@0	4193
sl@0	4194	if (eeFrame.line != NULL) {
sl@0	4195	ckfree ((char*) eeFrame.line);
sl@0	4196	}
sl@0	4197	if (eeFrame.type == TCL_LOCATION_SOURCE) {
sl@0	4198	Tcl_DecrRefCount (eeFrame.data.eval.path);
sl@0	4199	}
sl@0	4200	#endif
sl@0	4201	return code;
sl@0	4202	}
sl@0	4203
sl@0	4204	#ifdef TCL_TIP280
sl@0	4205	/*
sl@0	4206	*----------------------------------------------------------------------
sl@0	4207	*
sl@0	4208	* TclAdvanceLines --
sl@0	4209	*
sl@0	4210	* This procedure is a helper which counts the number of lines
sl@0	4211	* in a block of text and advances an external counter.
sl@0	4212	*
sl@0	4213	* Results:
sl@0	4214	* None.
sl@0	4215	*
sl@0	4216	* Side effects:
sl@0	4217	* The specified counter is advanced per the number of lines found.
sl@0	4218	*
sl@0	4219	* TIP #280
sl@0	4220	*----------------------------------------------------------------------
sl@0	4221	*/
sl@0	4222
sl@0	4223	void
sl@0	4224	TclAdvanceLines (line,start,end)
sl@0	4225	int* line;
sl@0	4226	CONST char* start;
sl@0	4227	CONST char* end;
sl@0	4228	{
sl@0	4229	CONST char* p;
sl@0	4230	for (p = start; p < end; p++) {
sl@0	4231	if (*p == '\n') {
sl@0	4232	(*line) ++;
sl@0	4233	}
sl@0	4234	}
sl@0	4235	}
sl@0	4236	#endif
sl@0	4237
sl@0	4238	/*
sl@0	4239	*----------------------------------------------------------------------
sl@0	4240	*
sl@0	4241	* Tcl_Eval --
sl@0	4242	*
sl@0	4243	* Execute a Tcl command in a string. This procedure executes the
sl@0	4244	* script directly, rather than compiling it to bytecodes. Before
sl@0	4245	* the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was
sl@0	4246	* the main procedure used for executing Tcl commands, but nowadays
sl@0	4247	* it isn't used much.
sl@0	4248	*
sl@0	4249	* Results:
sl@0	4250	* The return value is one of the return codes defined in tcl.h
sl@0	4251	* (such as TCL_OK), and interp's result contains a value
sl@0	4252	* to supplement the return code. The value of the result
sl@0	4253	* will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
sl@0	4254	* you must copy it or lose it!
sl@0	4255	*
sl@0	4256	* Side effects:
sl@0	4257	* Can be almost arbitrary, depending on the commands in the script.
sl@0	4258	*
sl@0	4259	*----------------------------------------------------------------------
sl@0	4260	*/
sl@0	4261
sl@0	4262	EXPORT_C int
sl@0	4263	Tcl_Eval(interp, string)
sl@0	4264	Tcl_Interp interp; / Token for command interpreter (returned
sl@0	4265	* by previous call to Tcl_CreateInterp). */
sl@0	4266	CONST char string; / Pointer to TCL command to execute. */
sl@0	4267	{
sl@0	4268	int code = Tcl_EvalEx(interp, string, -1, 0);
sl@0	4269
sl@0	4270	/*
sl@0	4271	* For backwards compatibility with old C code that predates the
sl@0	4272	* object system in Tcl 8.0, we have to mirror the object result
sl@0	4273	* back into the string result (some callers may expect it there).
sl@0	4274	*/
sl@0	4275
sl@0	4276	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
sl@0	4277	TCL_VOLATILE);
sl@0	4278	return code;
sl@0	4279	}
sl@0	4280
sl@0	4281	/*
sl@0	4282	*----------------------------------------------------------------------
sl@0	4283	*
sl@0	4284	* Tcl_EvalObj, Tcl_GlobalEvalObj --
sl@0	4285	*
sl@0	4286	* These functions are deprecated but we keep them around for backwards
sl@0	4287	* compatibility reasons.
sl@0	4288	*
sl@0	4289	* Results:
sl@0	4290	* See the functions they call.
sl@0	4291	*
sl@0	4292	* Side effects:
sl@0	4293	* See the functions they call.
sl@0	4294	*
sl@0	4295	*----------------------------------------------------------------------
sl@0	4296	*/
sl@0	4297
sl@0	4298	#undef Tcl_EvalObj
sl@0	4299	EXPORT_C int
sl@0	4300	Tcl_EvalObj(interp, objPtr)
sl@0	4301	Tcl_Interp * interp;
sl@0	4302	Tcl_Obj * objPtr;
sl@0	4303	{
sl@0	4304	return Tcl_EvalObjEx(interp, objPtr, 0);
sl@0	4305	}
sl@0	4306
sl@0	4307	#undef Tcl_GlobalEvalObj
sl@0	4308	EXPORT_C int
sl@0	4309	Tcl_GlobalEvalObj(interp, objPtr)
sl@0	4310	Tcl_Interp * interp;
sl@0	4311	Tcl_Obj * objPtr;
sl@0	4312	{
sl@0	4313	return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
sl@0	4314	}
sl@0	4315
sl@0	4316	/*
sl@0	4317	*----------------------------------------------------------------------
sl@0	4318	*
sl@0	4319	* Tcl_EvalObjEx, TclEvalObjEx --
sl@0	4320	*
sl@0	4321	* Execute Tcl commands stored in a Tcl object. These commands are
sl@0	4322	* compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT
sl@0	4323	* is specified.
sl@0	4324	*
sl@0	4325	* Results:
sl@0	4326	* The return value is one of the return codes defined in tcl.h
sl@0	4327	* (such as TCL_OK), and the interpreter's result contains a value
sl@0	4328	* to supplement the return code.
sl@0	4329	*
sl@0	4330	* Side effects:
sl@0	4331	* The object is converted, if necessary, to a ByteCode object that
sl@0	4332	* holds the bytecode instructions for the commands. Executing the
sl@0	4333	* commands will almost certainly have side effects that depend
sl@0	4334	* on those commands.
sl@0	4335	*
sl@0	4336	* Just as in Tcl_Eval, interp->termOffset is set to the offset of the
sl@0	4337	* last character executed in the objPtr's string.
sl@0	4338	*
sl@0	4339	* TIP #280 : Keep public API, internally extended API.
sl@0	4340	*----------------------------------------------------------------------
sl@0	4341	*/
sl@0	4342
sl@0	4343	EXPORT_C int
sl@0	4344	Tcl_EvalObjEx(interp, objPtr, flags)
sl@0	4345	Tcl_Interp interp; / Token for command interpreter
sl@0	4346	* (returned by a previous call to
sl@0	4347	* Tcl_CreateInterp). */
sl@0	4348	register Tcl_Obj objPtr; / Pointer to object containing
sl@0	4349	* commands to execute. */
sl@0	4350	int flags; /* Collection of OR-ed bits that
sl@0	4351	* control the evaluation of the
sl@0	4352	* script. Supported values are
sl@0	4353	* TCL_EVAL_GLOBAL and
sl@0	4354	* TCL_EVAL_DIRECT. */
sl@0	4355	{
sl@0	4356	#ifdef TCL_TIP280
sl@0	4357	return TclEvalObjEx (interp, objPtr, flags, NULL, 0);
sl@0	4358	}
sl@0	4359
sl@0	4360	int
sl@0	4361	TclEvalObjEx(interp, objPtr, flags, invoker, word)
sl@0	4362	Tcl_Interp interp; / Token for command interpreter
sl@0	4363	* (returned by a previous call to
sl@0	4364	* Tcl_CreateInterp). */
sl@0	4365	register Tcl_Obj objPtr; / Pointer to object containing
sl@0	4366	* commands to execute. */
sl@0	4367	int flags; /* Collection of OR-ed bits that
sl@0	4368	* control the evaluation of the
sl@0	4369	* script. Supported values are
sl@0	4370	* TCL_EVAL_GLOBAL and
sl@0	4371	* TCL_EVAL_DIRECT. */
sl@0	4372	CONST CmdFrame* invoker; /* Frame of the command doing the eval */
sl@0	4373	int word; /* Index of the word which is in objPtr */
sl@0	4374	{
sl@0	4375	#endif
sl@0	4376	register Interp iPtr = (Interp ) interp;
sl@0	4377	char *script;
sl@0	4378	int numSrcBytes;
sl@0	4379	int result;
sl@0	4380	CallFrame savedVarFramePtr; / Saves old copy of iPtr->varFramePtr
sl@0	4381	* in case TCL_EVAL_GLOBAL was set. */
sl@0	4382	int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
sl@0	4383
sl@0	4384	Tcl_IncrRefCount(objPtr);
sl@0	4385
sl@0	4386	if ((iPtr->flags & USE_EVAL_DIRECT) \|\| (flags & TCL_EVAL_DIRECT)) {
sl@0	4387	/*
sl@0	4388	* We're not supposed to use the compiler or byte-code interpreter.
sl@0	4389	* Let Tcl_EvalEx evaluate the command directly (and probably
sl@0	4390	* more slowly).
sl@0	4391	*
sl@0	4392	* Pure List Optimization (no string representation). In this
sl@0	4393	* case, we can safely use Tcl_EvalObjv instead and get an
sl@0	4394	* appreciable improvement in execution speed. This is because it
sl@0	4395	* allows us to avoid a setFromAny step that would just pack
sl@0	4396	* everything into a string and back out again.
sl@0	4397	*
sl@0	4398	* USE_EVAL_DIRECT is a special flag used for testing purpose only
sl@0	4399	* (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)
sl@0	4400	*/
sl@0	4401	if (!(iPtr->flags & USE_EVAL_DIRECT) &&
sl@0	4402	(objPtr->typePtr == &tclListType) && /* is a list... */
sl@0	4403	(objPtr->bytes == NULL) /* ...without a string rep */) {
sl@0	4404	register List *listRepPtr =
sl@0	4405	(List *) objPtr->internalRep.twoPtrValue.ptr1;
sl@0	4406	int i, objc = listRepPtr->elemCount;
sl@0	4407
sl@0	4408	#define TEOE_PREALLOC 10
sl@0	4409	Tcl_Obj staticObjv[TEOE_PREALLOC], *objv = staticObjv;
sl@0	4410
sl@0	4411	#ifdef TCL_TIP280
sl@0	4412	/* TIP #280 Structures for tracking lines.
sl@0	4413	* As we know that this is dynamic execution we ignore the
sl@0	4414	* invoker, even if known.
sl@0	4415	*/
sl@0	4416	int line;
sl@0	4417	CmdFrame eoFrame;
sl@0	4418
sl@0	4419	eoFrame.type = TCL_LOCATION_EVAL_LIST;
sl@0	4420	eoFrame.level = (iPtr->cmdFramePtr == NULL ?
sl@0	4421	1 :
sl@0	4422	iPtr->cmdFramePtr->level + 1);
sl@0	4423	eoFrame.framePtr = iPtr->framePtr;
sl@0	4424	eoFrame.nextPtr = iPtr->cmdFramePtr;
sl@0	4425	eoFrame.nline = objc;
sl@0	4426	eoFrame.line = (int) ckalloc (objc sizeof (int));
sl@0	4427
sl@0	4428	/* NOTE: Getting the string rep of the list to eval to fill the
sl@0	4429	* command information required by 'info frame' implies that
sl@0	4430	* further calls for the same list would not be optimized, as it
sl@0	4431	* would not be 'pure' anymore. It would also be a waste of time
sl@0	4432	* as most of the time this information is not needed at all. What
sl@0	4433	* we do instead is to keep the list obj itself around and have
sl@0	4434	* 'info frame' sort it out.
sl@0	4435	*/
sl@0	4436
sl@0	4437	eoFrame.cmd.listPtr = objPtr;
sl@0	4438	Tcl_IncrRefCount (eoFrame.cmd.listPtr);
sl@0	4439	eoFrame.data.eval.path = NULL;
sl@0	4440	#endif
sl@0	4441	if (objc > TEOE_PREALLOC) {
sl@0	4442	objv = (Tcl_Obj *) ckalloc(objcsizeof(Tcl_Obj *));
sl@0	4443	}
sl@0	4444	#undef TEOE_PREALLOC
sl@0	4445	/*
sl@0	4446	* Copy the list elements here, to avoid a segfault if
sl@0	4447	* objPtr loses its List internal rep [Bug 1119369].
sl@0	4448	*
sl@0	4449	* TIP #280 Computes all the line numbers for the
sl@0	4450	* words in the command.
sl@0	4451	*/
sl@0	4452
sl@0	4453	#ifdef TCL_TIP280
sl@0	4454	line = 1;
sl@0	4455	#endif
sl@0	4456	for (i=0; i < objc; i++) {
sl@0	4457	objv[i] = listRepPtr->elements[i];
sl@0	4458	Tcl_IncrRefCount(objv[i]);
sl@0	4459	#ifdef TCL_TIP280
sl@0	4460	eoFrame.line [i] = line;
sl@0	4461	{
sl@0	4462	char* w = Tcl_GetString (objv [i]);
sl@0	4463	TclAdvanceLines (&line, w, w+ strlen(w));
sl@0	4464	}
sl@0	4465	#endif
sl@0	4466	}
sl@0	4467
sl@0	4468	#ifdef TCL_TIP280
sl@0	4469	iPtr->cmdFramePtr = &eoFrame;
sl@0	4470	#endif
sl@0	4471	result = Tcl_EvalObjv(interp, objc, objv, flags);
sl@0	4472	#ifdef TCL_TIP280
sl@0	4473	iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
sl@0	4474	Tcl_DecrRefCount (eoFrame.cmd.listPtr);
sl@0	4475	#endif
sl@0	4476
sl@0	4477	for (i=0; i < objc; i++) {
sl@0	4478	TclDecrRefCount(objv[i]);
sl@0	4479	}
sl@0	4480	if (objv != staticObjv) {
sl@0	4481	ckfree((char *) objv);
sl@0	4482	}
sl@0	4483	#ifdef TCL_TIP280
sl@0	4484	ckfree ((char*) eoFrame.line);
sl@0	4485	eoFrame.line = NULL;
sl@0	4486	eoFrame.nline = 0;
sl@0	4487	#endif
sl@0	4488	} else {
sl@0	4489	#ifndef TCL_TIP280
sl@0	4490	script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
sl@0	4491	result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
sl@0	4492	#else
sl@0	4493	/*
sl@0	4494	* TIP #280. Propagate context as much as we can. Especially if
sl@0	4495	* the script to evaluate is a single literal it makes sense to
sl@0	4496	* look if our context is one with absolute line numbers we can
sl@0	4497	* then track into the literal itself too.
sl@0	4498	*
sl@0	4499	* See also tclCompile.c, TclInitCompileEnv, for the equivalent
sl@0	4500	* code in the bytecode compiler.
sl@0	4501	*/
sl@0	4502
sl@0	4503	if (invoker == NULL) {
sl@0	4504	/* No context, force opening of our own */
sl@0	4505	script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
sl@0	4506	result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
sl@0	4507	} else {
sl@0	4508	/* We have an invoker, describing the command asking for the
sl@0	4509	* evaluation of a subordinate script. This script may
sl@0	4510	* originate in a literal word, or from a variable, etc. Using
sl@0	4511	* the line array we now check if we have good line
sl@0	4512	* information for the relevant word. The type of context is
sl@0	4513	* relevant as well. In a non-'source' context we don't have
sl@0	4514	* to try tracking lines.
sl@0	4515	*
sl@0	4516	* First see if the word exists and is a literal. If not we go
sl@0	4517	* through the easy dynamic branch. No need to perform more
sl@0	4518	* complex invokations.
sl@0	4519	*/
sl@0	4520
sl@0	4521	if ((invoker->nline <= word) \|\| (invoker->line[word] < 0)) {
sl@0	4522	/* Dynamic script, or dynamic context, force our own
sl@0	4523	* context */
sl@0	4524
sl@0	4525	script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
sl@0	4526	result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
sl@0	4527
sl@0	4528	} else {
sl@0	4529	/* Try to get an absolute context for the evaluation
sl@0	4530	*/
sl@0	4531
sl@0	4532	CmdFrame ctx = *invoker;
sl@0	4533	int pc = 0;
sl@0	4534
sl@0	4535	if (invoker->type == TCL_LOCATION_BC) {
sl@0	4536	/* Note: Type BC => ctx.data.eval.path is not used.
sl@0	4537	* ctx.data.tebc.codePtr is used instead.
sl@0	4538	*/
sl@0	4539	TclGetSrcInfoForPc (&ctx);
sl@0	4540	pc = 1;
sl@0	4541	}
sl@0	4542
sl@0	4543	if (ctx.type == TCL_LOCATION_SOURCE) {
sl@0	4544	/* Absolute context to reuse. */
sl@0	4545
sl@0	4546	iPtr->invokeCmdFramePtr = &ctx;
sl@0	4547	iPtr->evalFlags \|= TCL_EVAL_CTX;
sl@0	4548
sl@0	4549	script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
sl@0	4550	result = EvalEx(interp, script, numSrcBytes, flags, ctx.line [word]);
sl@0	4551
sl@0	4552	if (pc) {
sl@0	4553	/* Death of SrcInfo reference */
sl@0	4554	Tcl_DecrRefCount (ctx.data.eval.path);
sl@0	4555	}
sl@0	4556	} else {
sl@0	4557	/* Dynamic context or script, easier to make our own as
sl@0	4558	* well */
sl@0	4559	script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
sl@0	4560	result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
sl@0	4561	}
sl@0	4562	}
sl@0	4563	}
sl@0	4564	#endif
sl@0	4565	}
sl@0	4566	} else {
sl@0	4567	/*
sl@0	4568	* Let the compiler/engine subsystem do the evaluation.
sl@0	4569	*
sl@0	4570	* TIP #280 The invoker provides us with the context for the
sl@0	4571	* script. We transfer this to the byte code compiler.
sl@0	4572	*/
sl@0	4573
sl@0	4574	savedVarFramePtr = iPtr->varFramePtr;
sl@0	4575	if (flags & TCL_EVAL_GLOBAL) {
sl@0	4576	iPtr->varFramePtr = NULL;
sl@0	4577	}
sl@0	4578
sl@0	4579	#ifndef TCL_TIP280
sl@0	4580	result = TclCompEvalObj(interp, objPtr);
sl@0	4581	#else
sl@0	4582	result = TclCompEvalObj(interp, objPtr, invoker, word);
sl@0	4583	#endif
sl@0	4584
sl@0	4585	/*
sl@0	4586	* If we are again at the top level, process any unusual
sl@0	4587	* return code returned by the evaluated code.
sl@0	4588	*/
sl@0	4589
sl@0	4590	if (iPtr->numLevels == 0) {
sl@0	4591	if (result == TCL_RETURN) {
sl@0	4592	result = TclUpdateReturnInfo(iPtr);
sl@0	4593	}
sl@0	4594	if ((result != TCL_OK) && (result != TCL_ERROR)
sl@0	4595	&& !allowExceptions) {
sl@0	4596	ProcessUnexpectedResult(interp, result);
sl@0	4597	result = TCL_ERROR;
sl@0	4598
sl@0	4599	/*
sl@0	4600	* If an error was created here, record information about
sl@0	4601	* what was being executed when the error occurred. Remove
sl@0	4602	* the extra \n added by tclMain.c in the command sent to
sl@0	4603	* Tcl_LogCommandInfo [Bug 833150].
sl@0	4604	*/
sl@0	4605
sl@0	4606	if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
sl@0	4607	script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
sl@0	4608	Tcl_LogCommandInfo(interp, script, script, --numSrcBytes);
sl@0	4609	iPtr->flags &= ~ERR_ALREADY_LOGGED;
sl@0	4610	}
sl@0	4611	}
sl@0	4612	}
sl@0	4613	iPtr->evalFlags = 0;
sl@0	4614	iPtr->varFramePtr = savedVarFramePtr;
sl@0	4615	}
sl@0	4616
sl@0	4617	TclDecrRefCount(objPtr);
sl@0	4618	return result;
sl@0	4619	}
sl@0	4620
sl@0	4621	/*
sl@0	4622	*----------------------------------------------------------------------
sl@0	4623	*
sl@0	4624	* ProcessUnexpectedResult --
sl@0	4625	*
sl@0	4626	* Procedure called by Tcl_EvalObj to set the interpreter's result
sl@0	4627	* value to an appropriate error message when the code it evaluates
sl@0	4628	* returns an unexpected result code (not TCL_OK and not TCL_ERROR) to
sl@0	4629	* the topmost evaluation level.
sl@0	4630	*
sl@0	4631	* Results:
sl@0	4632	* None.
sl@0	4633	*
sl@0	4634	* Side effects:
sl@0	4635	* The interpreter result is set to an error message appropriate to
sl@0	4636	* the result code.
sl@0	4637	*
sl@0	4638	*----------------------------------------------------------------------
sl@0	4639	*/
sl@0	4640
sl@0	4641	static void
sl@0	4642	ProcessUnexpectedResult(interp, returnCode)
sl@0	4643	Tcl_Interp interp; / The interpreter in which the unexpected
sl@0	4644	* result code was returned. */
sl@0	4645	int returnCode; /* The unexpected result code. */
sl@0	4646	{
sl@0	4647	Tcl_ResetResult(interp);
sl@0	4648	if (returnCode == TCL_BREAK) {
sl@0	4649	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	4650	"invoked \"break\" outside of a loop", -1);
sl@0	4651	} else if (returnCode == TCL_CONTINUE) {
sl@0	4652	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	4653	"invoked \"continue\" outside of a loop", -1);
sl@0	4654	} else {
sl@0	4655	char buf[30 + TCL_INTEGER_SPACE];
sl@0	4656
sl@0	4657	sprintf(buf, "command returned bad code: %d", returnCode);
sl@0	4658	Tcl_SetResult(interp, buf, TCL_VOLATILE);
sl@0	4659	}
sl@0	4660	}
sl@0	4661
sl@0	4662	/*
sl@0	4663	*---------------------------------------------------------------------------
sl@0	4664	*
sl@0	4665	* Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
sl@0	4666	*
sl@0	4667	* Procedures to evaluate an expression and return its value in a
sl@0	4668	* particular form.
sl@0	4669	*
sl@0	4670	* Results:
sl@0	4671	* Each of the procedures below returns a standard Tcl result. If an
sl@0	4672	* error occurs then an error message is left in the interp's result.
sl@0	4673	* Otherwise the value of the expression, in the appropriate form,
sl@0	4674	* is stored at *ptr. If the expression had a result that was
sl@0	4675	* incompatible with the desired form then an error is returned.
sl@0	4676	*
sl@0	4677	* Side effects:
sl@0	4678	* None.
sl@0	4679	*
sl@0	4680	*---------------------------------------------------------------------------
sl@0	4681	*/
sl@0	4682
sl@0	4683	EXPORT_C int
sl@0	4684	Tcl_ExprLong(interp, string, ptr)
sl@0	4685	Tcl_Interp interp; / Context in which to evaluate the
sl@0	4686	* expression. */
sl@0	4687	CONST char string; / Expression to evaluate. */
sl@0	4688	long ptr; / Where to store result. */
sl@0	4689	{
sl@0	4690	register Tcl_Obj *exprPtr;
sl@0	4691	Tcl_Obj *resultPtr;
sl@0	4692	int length = strlen(string);
sl@0	4693	int result = TCL_OK;
sl@0	4694
sl@0	4695	if (length > 0) {
sl@0	4696	exprPtr = Tcl_NewStringObj(string, length);
sl@0	4697	Tcl_IncrRefCount(exprPtr);
sl@0	4698	result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
sl@0	4699	if (result == TCL_OK) {
sl@0	4700	/*
sl@0	4701	* Store an integer based on the expression result.
sl@0	4702	*/
sl@0	4703
sl@0	4704	if (resultPtr->typePtr == &tclIntType) {
sl@0	4705	*ptr = resultPtr->internalRep.longValue;
sl@0	4706	} else if (resultPtr->typePtr == &tclDoubleType) {
sl@0	4707	*ptr = (long) resultPtr->internalRep.doubleValue;
sl@0	4708	} else if (resultPtr->typePtr == &tclWideIntType) {
sl@0	4709	#ifndef TCL_WIDE_INT_IS_LONG
sl@0	4710	/*
sl@0	4711	* See Tcl_GetIntFromObj for conversion comments.
sl@0	4712	*/
sl@0	4713	Tcl_WideInt w = resultPtr->internalRep.wideValue;
sl@0	4714	if ((w >= -(Tcl_WideInt)(ULONG_MAX))
sl@0	4715	&& (w <= (Tcl_WideInt)(ULONG_MAX))) {
sl@0	4716	*ptr = Tcl_WideAsLong(w);
sl@0	4717	} else {
sl@0	4718	Tcl_SetResult(interp,
sl@0	4719	"integer value too large to represent as non-long integer",
sl@0	4720	TCL_STATIC);
sl@0	4721	result = TCL_ERROR;
sl@0	4722	}
sl@0	4723	#else
sl@0	4724	*ptr = resultPtr->internalRep.longValue;
sl@0	4725	#endif
sl@0	4726	} else {
sl@0	4727	Tcl_SetResult(interp,
sl@0	4728	"expression didn't have numeric value", TCL_STATIC);
sl@0	4729	result = TCL_ERROR;
sl@0	4730	}
sl@0	4731	Tcl_DecrRefCount(resultPtr); /* discard the result object */
sl@0	4732	} else {
sl@0	4733	/*
sl@0	4734	* Move the interpreter's object result to the string result,
sl@0	4735	* then reset the object result.
sl@0	4736	*/
sl@0	4737
sl@0	4738	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
sl@0	4739	TCL_VOLATILE);
sl@0	4740	}
sl@0	4741	Tcl_DecrRefCount(exprPtr); /* discard the expression object */
sl@0	4742	} else {
sl@0	4743	/*
sl@0	4744	* An empty string. Just set the result integer to 0.
sl@0	4745	*/
sl@0	4746
sl@0	4747	*ptr = 0;
sl@0	4748	}
sl@0	4749	return result;
sl@0	4750	}
sl@0	4751
sl@0	4752	EXPORT_C int
sl@0	4753	Tcl_ExprDouble(interp, string, ptr)
sl@0	4754	Tcl_Interp interp; / Context in which to evaluate the
sl@0	4755	* expression. */
sl@0	4756	CONST char string; / Expression to evaluate. */
sl@0	4757	double ptr; / Where to store result. */
sl@0	4758	{
sl@0	4759	register Tcl_Obj *exprPtr;
sl@0	4760	Tcl_Obj *resultPtr;
sl@0	4761	int length = strlen(string);
sl@0	4762	int result = TCL_OK;
sl@0	4763
sl@0	4764	if (length > 0) {
sl@0	4765	exprPtr = Tcl_NewStringObj(string, length);
sl@0	4766	Tcl_IncrRefCount(exprPtr);
sl@0	4767	result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
sl@0	4768	if (result == TCL_OK) {
sl@0	4769	/*
sl@0	4770	* Store a double based on the expression result.
sl@0	4771	*/
sl@0	4772
sl@0	4773	if (resultPtr->typePtr == &tclIntType) {
sl@0	4774	*ptr = (double) resultPtr->internalRep.longValue;
sl@0	4775	} else if (resultPtr->typePtr == &tclDoubleType) {
sl@0	4776	*ptr = resultPtr->internalRep.doubleValue;
sl@0	4777	} else if (resultPtr->typePtr == &tclWideIntType) {
sl@0	4778	#ifndef TCL_WIDE_INT_IS_LONG
sl@0	4779	/*
sl@0	4780	* See Tcl_GetIntFromObj for conversion comments.
sl@0	4781	*/
sl@0	4782	Tcl_WideInt w = resultPtr->internalRep.wideValue;
sl@0	4783	if ((w >= -(Tcl_WideInt)(ULONG_MAX))
sl@0	4784	&& (w <= (Tcl_WideInt)(ULONG_MAX))) {
sl@0	4785	*ptr = (double) Tcl_WideAsLong(w);
sl@0	4786	} else {
sl@0	4787	Tcl_SetResult(interp,
sl@0	4788	"integer value too large to represent as non-long integer",
sl@0	4789	TCL_STATIC);
sl@0	4790	result = TCL_ERROR;
sl@0	4791	}
sl@0	4792	#else
sl@0	4793	*ptr = (double) resultPtr->internalRep.longValue;
sl@0	4794	#endif
sl@0	4795	} else {
sl@0	4796	Tcl_SetResult(interp,
sl@0	4797	"expression didn't have numeric value", TCL_STATIC);
sl@0	4798	result = TCL_ERROR;
sl@0	4799	}
sl@0	4800	Tcl_DecrRefCount(resultPtr); /* discard the result object */
sl@0	4801	} else {
sl@0	4802	/*
sl@0	4803	* Move the interpreter's object result to the string result,
sl@0	4804	* then reset the object result.
sl@0	4805	*/
sl@0	4806
sl@0	4807	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
sl@0	4808	TCL_VOLATILE);
sl@0	4809	}
sl@0	4810	Tcl_DecrRefCount(exprPtr); /* discard the expression object */
sl@0	4811	} else {
sl@0	4812	/*
sl@0	4813	* An empty string. Just set the result double to 0.0.
sl@0	4814	*/
sl@0	4815
sl@0	4816	*ptr = 0.0;
sl@0	4817	}
sl@0	4818	return result;
sl@0	4819	}
sl@0	4820
sl@0	4821	EXPORT_C int
sl@0	4822	Tcl_ExprBoolean(interp, string, ptr)
sl@0	4823	Tcl_Interp interp; / Context in which to evaluate the
sl@0	4824	* expression. */
sl@0	4825	CONST char string; / Expression to evaluate. */
sl@0	4826	int ptr; / Where to store 0/1 result. */
sl@0	4827	{
sl@0	4828	register Tcl_Obj *exprPtr;
sl@0	4829	Tcl_Obj *resultPtr;
sl@0	4830	int length = strlen(string);
sl@0	4831	int result = TCL_OK;
sl@0	4832
sl@0	4833	if (length > 0) {
sl@0	4834	exprPtr = Tcl_NewStringObj(string, length);
sl@0	4835	Tcl_IncrRefCount(exprPtr);
sl@0	4836	result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
sl@0	4837	if (result == TCL_OK) {
sl@0	4838	/*
sl@0	4839	* Store a boolean based on the expression result.
sl@0	4840	*/
sl@0	4841
sl@0	4842	if (resultPtr->typePtr == &tclIntType) {
sl@0	4843	*ptr = (resultPtr->internalRep.longValue != 0);
sl@0	4844	} else if (resultPtr->typePtr == &tclDoubleType) {
sl@0	4845	*ptr = (resultPtr->internalRep.doubleValue != 0.0);
sl@0	4846	} else if (resultPtr->typePtr == &tclWideIntType) {
sl@0	4847	#ifndef TCL_WIDE_INT_IS_LONG
sl@0	4848	*ptr = (resultPtr->internalRep.wideValue != 0);
sl@0	4849	#else
sl@0	4850	*ptr = (resultPtr->internalRep.longValue != 0);
sl@0	4851	#endif
sl@0	4852	} else {
sl@0	4853	result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
sl@0	4854	}
sl@0	4855	Tcl_DecrRefCount(resultPtr); /* discard the result object */
sl@0	4856	}
sl@0	4857	if (result != TCL_OK) {
sl@0	4858	/*
sl@0	4859	* Move the interpreter's object result to the string result,
sl@0	4860	* then reset the object result.
sl@0	4861	*/
sl@0	4862
sl@0	4863	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
sl@0	4864	TCL_VOLATILE);
sl@0	4865	}
sl@0	4866	Tcl_DecrRefCount(exprPtr); /* discard the expression object */
sl@0	4867	} else {
sl@0	4868	/*
sl@0	4869	* An empty string. Just set the result boolean to 0 (false).
sl@0	4870	*/
sl@0	4871
sl@0	4872	*ptr = 0;
sl@0	4873	}
sl@0	4874	return result;
sl@0	4875	}
sl@0	4876
sl@0	4877	/*
sl@0	4878	*--------------------------------------------------------------
sl@0	4879	*
sl@0	4880	* Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
sl@0	4881	*
sl@0	4882	* Procedures to evaluate an expression in an object and return its
sl@0	4883	* value in a particular form.
sl@0	4884	*
sl@0	4885	* Results:
sl@0	4886	* Each of the procedures below returns a standard Tcl result
sl@0	4887	* object. If an error occurs then an error message is left in the
sl@0	4888	* interpreter's result. Otherwise the value of the expression, in the
sl@0	4889	* appropriate form, is stored at *ptr. If the expression had a result
sl@0	4890	* that was incompatible with the desired form then an error is
sl@0	4891	* returned.
sl@0	4892	*
sl@0	4893	* Side effects:
sl@0	4894	* None.
sl@0	4895	*
sl@0	4896	*--------------------------------------------------------------
sl@0	4897	*/
sl@0	4898
sl@0	4899	EXPORT_C int
sl@0	4900	Tcl_ExprLongObj(interp, objPtr, ptr)
sl@0	4901	Tcl_Interp interp; / Context in which to evaluate the
sl@0	4902	* expression. */
sl@0	4903	register Tcl_Obj objPtr; / Expression to evaluate. */
sl@0	4904	long ptr; / Where to store long result. */
sl@0	4905	{
sl@0	4906	Tcl_Obj *resultPtr;
sl@0	4907	int result;
sl@0	4908
sl@0	4909	result = Tcl_ExprObj(interp, objPtr, &resultPtr);
sl@0	4910	if (result == TCL_OK) {
sl@0	4911	if (resultPtr->typePtr == &tclIntType) {
sl@0	4912	*ptr = resultPtr->internalRep.longValue;
sl@0	4913	} else if (resultPtr->typePtr == &tclDoubleType) {
sl@0	4914	*ptr = (long) resultPtr->internalRep.doubleValue;
sl@0	4915	} else {
sl@0	4916	result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
sl@0	4917	if (result != TCL_OK) {
sl@0	4918	return result;
sl@0	4919	}
sl@0	4920	}
sl@0	4921	Tcl_DecrRefCount(resultPtr); /* discard the result object */
sl@0	4922	}
sl@0	4923	return result;
sl@0	4924	}
sl@0	4925
sl@0	4926	EXPORT_C int
sl@0	4927	Tcl_ExprDoubleObj(interp, objPtr, ptr)
sl@0	4928	Tcl_Interp interp; / Context in which to evaluate the
sl@0	4929	* expression. */
sl@0	4930	register Tcl_Obj objPtr; / Expression to evaluate. */
sl@0	4931	double ptr; / Where to store double result. */
sl@0	4932	{
sl@0	4933	Tcl_Obj *resultPtr;
sl@0	4934	int result;
sl@0	4935
sl@0	4936	result = Tcl_ExprObj(interp, objPtr, &resultPtr);
sl@0	4937	if (result == TCL_OK) {
sl@0	4938	if (resultPtr->typePtr == &tclIntType) {
sl@0	4939	*ptr = (double) resultPtr->internalRep.longValue;
sl@0	4940	} else if (resultPtr->typePtr == &tclDoubleType) {
sl@0	4941	*ptr = resultPtr->internalRep.doubleValue;
sl@0	4942	} else {
sl@0	4943	result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
sl@0	4944	if (result != TCL_OK) {
sl@0	4945	return result;
sl@0	4946	}
sl@0	4947	}
sl@0	4948	Tcl_DecrRefCount(resultPtr); /* discard the result object */
sl@0	4949	}
sl@0	4950	return result;
sl@0	4951	}
sl@0	4952
sl@0	4953	EXPORT_C int
sl@0	4954	Tcl_ExprBooleanObj(interp, objPtr, ptr)
sl@0	4955	Tcl_Interp interp; / Context in which to evaluate the
sl@0	4956	* expression. */
sl@0	4957	register Tcl_Obj objPtr; / Expression to evaluate. */
sl@0	4958	int ptr; / Where to store 0/1 result. */
sl@0	4959	{
sl@0	4960	Tcl_Obj *resultPtr;
sl@0	4961	int result;
sl@0	4962
sl@0	4963	result = Tcl_ExprObj(interp, objPtr, &resultPtr);
sl@0	4964	if (result == TCL_OK) {
sl@0	4965	if (resultPtr->typePtr == &tclIntType) {
sl@0	4966	*ptr = (resultPtr->internalRep.longValue != 0);
sl@0	4967	} else if (resultPtr->typePtr == &tclDoubleType) {
sl@0	4968	*ptr = (resultPtr->internalRep.doubleValue != 0.0);
sl@0	4969	} else {
sl@0	4970	result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
sl@0	4971	}
sl@0	4972	Tcl_DecrRefCount(resultPtr); /* discard the result object */
sl@0	4973	}
sl@0	4974	return result;
sl@0	4975	}
sl@0	4976
sl@0	4977	/*
sl@0	4978	*----------------------------------------------------------------------
sl@0	4979	*
sl@0	4980	* TclInvoke --
sl@0	4981	*
sl@0	4982	* Invokes a Tcl command, given an argv/argc, from either the
sl@0	4983	* exposed or the hidden sets of commands in the given interpreter.
sl@0	4984	* NOTE: The command is invoked in the current stack frame of
sl@0	4985	* the interpreter, thus it can modify local variables.
sl@0	4986	*
sl@0	4987	* Results:
sl@0	4988	* A standard Tcl result.
sl@0	4989	*
sl@0	4990	* Side effects:
sl@0	4991	* Whatever the command does.
sl@0	4992	*
sl@0	4993	*----------------------------------------------------------------------
sl@0	4994	*/
sl@0	4995
sl@0	4996	int
sl@0	4997	TclInvoke(interp, argc, argv, flags)
sl@0	4998	Tcl_Interp interp; / Where to invoke the command. */
sl@0	4999	int argc; /* Count of args. */
sl@0	5000	register CONST char *argv; / The arg strings; argv[0] is the name of
sl@0	5001	* the command to invoke. */
sl@0	5002	int flags; /* Combination of flags controlling the
sl@0	5003	* call: TCL_INVOKE_HIDDEN and
sl@0	5004	* TCL_INVOKE_NO_UNKNOWN. */
sl@0	5005	{
sl@0	5006	register Tcl_Obj *objPtr;
sl@0	5007	register int i;
sl@0	5008	int length, result;
sl@0	5009
sl@0	5010	/*
sl@0	5011	* This procedure generates an objv array for object arguments that hold
sl@0	5012	* the argv strings. It starts out with stack-allocated space but uses
sl@0	5013	* dynamically-allocated storage if needed.
sl@0	5014	*/
sl@0	5015
sl@0	5016	#define NUM_ARGS 20
sl@0	5017	Tcl_Obj *(objStorage[NUM_ARGS]);
sl@0	5018	register Tcl_Obj **objv = objStorage;
sl@0	5019
sl@0	5020	/*
sl@0	5021	* Create the object argument array "objv". Make sure objv is large
sl@0	5022	* enough to hold the objc arguments plus 1 extra for the zero
sl@0	5023	* end-of-objv word.
sl@0	5024	*/
sl@0	5025
sl@0	5026	if ((argc + 1) > NUM_ARGS) {
sl@0	5027	objv = (Tcl_Obj **)
sl@0	5028	ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
sl@0	5029	}
sl@0	5030
sl@0	5031	for (i = 0; i < argc; i++) {
sl@0	5032	length = strlen(argv[i]);
sl@0	5033	objv[i] = Tcl_NewStringObj(argv[i], length);
sl@0	5034	Tcl_IncrRefCount(objv[i]);
sl@0	5035	}
sl@0	5036	objv[argc] = 0;
sl@0	5037
sl@0	5038	/*
sl@0	5039	* Use TclObjInterpProc to actually invoke the command.
sl@0	5040	*/
sl@0	5041
sl@0	5042	result = TclObjInvoke(interp, argc, objv, flags);
sl@0	5043
sl@0	5044	/*
sl@0	5045	* Move the interpreter's object result to the string result,
sl@0	5046	* then reset the object result.
sl@0	5047	*/
sl@0	5048
sl@0	5049	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
sl@0	5050	TCL_VOLATILE);
sl@0	5051
sl@0	5052	/*
sl@0	5053	* Decrement the ref counts on the objv elements since we are done
sl@0	5054	* with them.
sl@0	5055	*/
sl@0	5056
sl@0	5057	for (i = 0; i < argc; i++) {
sl@0	5058	objPtr = objv[i];
sl@0	5059	Tcl_DecrRefCount(objPtr);
sl@0	5060	}
sl@0	5061
sl@0	5062	/*
sl@0	5063	* Free the objv array if malloc'ed storage was used.
sl@0	5064	*/
sl@0	5065
sl@0	5066	if (objv != objStorage) {
sl@0	5067	ckfree((char *) objv);
sl@0	5068	}
sl@0	5069	return result;
sl@0	5070	#undef NUM_ARGS
sl@0	5071	}
sl@0	5072
sl@0	5073	/*
sl@0	5074	*----------------------------------------------------------------------
sl@0	5075	*
sl@0	5076	* TclGlobalInvoke --
sl@0	5077	*
sl@0	5078	* Invokes a Tcl command, given an argv/argc, from either the
sl@0	5079	* exposed or hidden sets of commands in the given interpreter.
sl@0	5080	* NOTE: The command is invoked in the global stack frame of
sl@0	5081	* the interpreter, thus it cannot see any current state on
sl@0	5082	* the stack for that interpreter.
sl@0	5083	*
sl@0	5084	* Results:
sl@0	5085	* A standard Tcl result.
sl@0	5086	*
sl@0	5087	* Side effects:
sl@0	5088	* Whatever the command does.
sl@0	5089	*
sl@0	5090	*----------------------------------------------------------------------
sl@0	5091	*/
sl@0	5092
sl@0	5093	int
sl@0	5094	TclGlobalInvoke(interp, argc, argv, flags)
sl@0	5095	Tcl_Interp interp; / Where to invoke the command. */
sl@0	5096	int argc; /* Count of args. */
sl@0	5097	register CONST char *argv; / The arg strings; argv[0] is the name of
sl@0	5098	* the command to invoke. */
sl@0	5099	int flags; /* Combination of flags controlling the
sl@0	5100	* call: TCL_INVOKE_HIDDEN and
sl@0	5101	* TCL_INVOKE_NO_UNKNOWN. */
sl@0	5102	{
sl@0	5103	register Interp iPtr = (Interp ) interp;
sl@0	5104	int result;
sl@0	5105	CallFrame *savedVarFramePtr;
sl@0	5106
sl@0	5107	savedVarFramePtr = iPtr->varFramePtr;
sl@0	5108	iPtr->varFramePtr = NULL;
sl@0	5109	result = TclInvoke(interp, argc, argv, flags);
sl@0	5110	iPtr->varFramePtr = savedVarFramePtr;
sl@0	5111	return result;
sl@0	5112	}
sl@0	5113
sl@0	5114	/*
sl@0	5115	*----------------------------------------------------------------------
sl@0	5116	*
sl@0	5117	* TclObjInvokeGlobal --
sl@0	5118	*
sl@0	5119	* Object version: Invokes a Tcl command, given an objv/objc, from
sl@0	5120	* either the exposed or hidden set of commands in the given
sl@0	5121	* interpreter.
sl@0	5122	* NOTE: The command is invoked in the global stack frame of the
sl@0	5123	* interpreter, thus it cannot see any current state on the
sl@0	5124	* stack of that interpreter.
sl@0	5125	*
sl@0	5126	* Results:
sl@0	5127	* A standard Tcl result.
sl@0	5128	*
sl@0	5129	* Side effects:
sl@0	5130	* Whatever the command does.
sl@0	5131	*
sl@0	5132	*----------------------------------------------------------------------
sl@0	5133	*/
sl@0	5134
sl@0	5135	int
sl@0	5136	TclObjInvokeGlobal(interp, objc, objv, flags)
sl@0	5137	Tcl_Interp interp; / Interpreter in which command is to be
sl@0	5138	* invoked. */
sl@0	5139	int objc; /* Count of arguments. */
sl@0	5140	Tcl_Obj CONST objv[]; / Argument objects; objv[0] points to the
sl@0	5141	* name of the command to invoke. */
sl@0	5142	int flags; /* Combination of flags controlling the
sl@0	5143	* call: TCL_INVOKE_HIDDEN,
sl@0	5144	* TCL_INVOKE_NO_UNKNOWN, or
sl@0	5145	* TCL_INVOKE_NO_TRACEBACK. */
sl@0	5146	{
sl@0	5147	register Interp iPtr = (Interp ) interp;
sl@0	5148	int result;
sl@0	5149	CallFrame *savedVarFramePtr;
sl@0	5150
sl@0	5151	savedVarFramePtr = iPtr->varFramePtr;
sl@0	5152	iPtr->varFramePtr = NULL;
sl@0	5153	result = TclObjInvoke(interp, objc, objv, flags);
sl@0	5154	iPtr->varFramePtr = savedVarFramePtr;
sl@0	5155	return result;
sl@0	5156	}
sl@0	5157
sl@0	5158	/*
sl@0	5159	*----------------------------------------------------------------------
sl@0	5160	*
sl@0	5161	* TclObjInvoke --
sl@0	5162	*
sl@0	5163	* Invokes a Tcl command, given an objv/objc, from either the
sl@0	5164	* exposed or the hidden sets of commands in the given interpreter.
sl@0	5165	*
sl@0	5166	* Results:
sl@0	5167	* A standard Tcl object result.
sl@0	5168	*
sl@0	5169	* Side effects:
sl@0	5170	* Whatever the command does.
sl@0	5171	*
sl@0	5172	*----------------------------------------------------------------------
sl@0	5173	*/
sl@0	5174
sl@0	5175	int
sl@0	5176	TclObjInvoke(interp, objc, objv, flags)
sl@0	5177	Tcl_Interp interp; / Interpreter in which command is to be
sl@0	5178	* invoked. */
sl@0	5179	int objc; /* Count of arguments. */
sl@0	5180	Tcl_Obj CONST objv[]; / Argument objects; objv[0] points to the
sl@0	5181	* name of the command to invoke. */
sl@0	5182	int flags; /* Combination of flags controlling the
sl@0	5183	* call: TCL_INVOKE_HIDDEN,
sl@0	5184	* TCL_INVOKE_NO_UNKNOWN, or
sl@0	5185	* TCL_INVOKE_NO_TRACEBACK. */
sl@0	5186	{
sl@0	5187	register Interp iPtr = (Interp ) interp;
sl@0	5188	Tcl_HashTable hTblPtr; / Table of hidden commands. */
sl@0	5189	char cmdName; / Name of the command from objv[0]. */
sl@0	5190	register Tcl_HashEntry *hPtr;
sl@0	5191	Tcl_Command cmd;
sl@0	5192	Command *cmdPtr;
sl@0	5193	int localObjc; /* Used to invoke "unknown" if the */
sl@0	5194	Tcl_Obj *localObjv = NULL; / command is not found. */
sl@0	5195	register int i;
sl@0	5196	int result;
sl@0	5197
sl@0	5198	if (interp == (Tcl_Interp *) NULL) {
sl@0	5199	return TCL_ERROR;
sl@0	5200	}
sl@0	5201
sl@0	5202	if ((objc < 1) \|\| (objv == (Tcl_Obj **) NULL)) {
sl@0	5203	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	5204	"illegal argument vector", -1);
sl@0	5205	return TCL_ERROR;
sl@0	5206	}
sl@0	5207
sl@0	5208	cmdName = Tcl_GetString(objv[0]);
sl@0	5209	if (flags & TCL_INVOKE_HIDDEN) {
sl@0	5210	/*
sl@0	5211	* We never invoke "unknown" for hidden commands.
sl@0	5212	*/
sl@0	5213
sl@0	5214	hPtr = NULL;
sl@0	5215	hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr;
sl@0	5216	if (hTblPtr != NULL) {
sl@0	5217	hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
sl@0	5218	}
sl@0	5219	if (hPtr == NULL) {
sl@0	5220	Tcl_ResetResult(interp);
sl@0	5221	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	5222	"invalid hidden command name \"", cmdName, "\"",
sl@0	5223	(char *) NULL);
sl@0	5224	return TCL_ERROR;
sl@0	5225	}
sl@0	5226	cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
sl@0	5227	} else {
sl@0	5228	cmdPtr = NULL;
sl@0	5229	cmd = Tcl_FindCommand(interp, cmdName,
sl@0	5230	(Tcl_Namespace ) NULL, /flags*/ TCL_GLOBAL_ONLY);
sl@0	5231	if (cmd != (Tcl_Command) NULL) {
sl@0	5232	cmdPtr = (Command *) cmd;
sl@0	5233	}
sl@0	5234	if (cmdPtr == NULL) {
sl@0	5235	if (!(flags & TCL_INVOKE_NO_UNKNOWN)) {
sl@0	5236	cmd = Tcl_FindCommand(interp, "unknown",
sl@0	5237	(Tcl_Namespace ) NULL, /flags*/ TCL_GLOBAL_ONLY);
sl@0	5238	if (cmd != (Tcl_Command) NULL) {
sl@0	5239	cmdPtr = (Command *) cmd;
sl@0	5240	}
sl@0	5241	if (cmdPtr != NULL) {
sl@0	5242	localObjc = (objc + 1);
sl@0	5243	localObjv = (Tcl_Obj **)
sl@0	5244	ckalloc((unsigned) (sizeof(Tcl_Obj ) localObjc));
sl@0	5245	localObjv[0] = Tcl_NewStringObj("unknown", -1);
sl@0	5246	Tcl_IncrRefCount(localObjv[0]);
sl@0	5247	for (i = 0; i < objc; i++) {
sl@0	5248	localObjv[i+1] = objv[i];
sl@0	5249	}
sl@0	5250	objc = localObjc;
sl@0	5251	objv = localObjv;
sl@0	5252	}
sl@0	5253	}
sl@0	5254
sl@0	5255	/*
sl@0	5256	* Check again if we found the command. If not, "unknown" is
sl@0	5257	* not present and we cannot help, or the caller said not to
sl@0	5258	* call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN).
sl@0	5259	*/
sl@0	5260
sl@0	5261	if (cmdPtr == NULL) {
sl@0	5262	Tcl_ResetResult(interp);
sl@0	5263	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	5264	"invalid command name \"", cmdName, "\"",
sl@0	5265	(char *) NULL);
sl@0	5266	return TCL_ERROR;
sl@0	5267	}
sl@0	5268	}
sl@0	5269	}
sl@0	5270
sl@0	5271	/*
sl@0	5272	* Invoke the command procedure. First reset the interpreter's string
sl@0	5273	* and object results to their default empty values since they could
sl@0	5274	* have gotten changed by earlier invocations.
sl@0	5275	*/
sl@0	5276
sl@0	5277	Tcl_ResetResult(interp);
sl@0	5278	iPtr->cmdCount++;
sl@0	5279	result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
sl@0	5280
sl@0	5281	/*
sl@0	5282	* If an error occurred, record information about what was being
sl@0	5283	* executed when the error occurred.
sl@0	5284	*/
sl@0	5285
sl@0	5286	if ((result == TCL_ERROR)
sl@0	5287	&& ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
sl@0	5288	&& ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
sl@0	5289	Tcl_Obj *msg;
sl@0	5290
sl@0	5291	if (!(iPtr->flags & ERR_IN_PROGRESS)) {
sl@0	5292	msg = Tcl_NewStringObj("\n while invoking\n\"", -1);
sl@0	5293	} else {
sl@0	5294	msg = Tcl_NewStringObj("\n invoked from within\n\"", -1);
sl@0	5295	}
sl@0	5296	Tcl_IncrRefCount(msg);
sl@0	5297	for (i = 0; i < objc; i++) {
sl@0	5298	CONST char *bytes;
sl@0	5299	int length;
sl@0	5300
sl@0	5301	Tcl_AppendObjToObj(msg, objv[i]);
sl@0	5302	bytes = Tcl_GetStringFromObj(msg, &length);
sl@0	5303	if (length > 100) {
sl@0	5304	/*
sl@0	5305	* Back up truncation point so that we don't truncate
sl@0	5306	* in the middle of a multi-byte character.
sl@0	5307	*/
sl@0	5308	length = 100;
sl@0	5309	while ( (bytes[length] & 0xC0) == 0x80 ) {
sl@0	5310	length--;
sl@0	5311	}
sl@0	5312	Tcl_SetObjLength(msg, length);
sl@0	5313	Tcl_AppendToObj(msg, "...", -1);
sl@0	5314	break;
sl@0	5315	}
sl@0	5316	if (i != (objc - 1)) {
sl@0	5317	Tcl_AppendToObj(msg, " ", -1);
sl@0	5318	}
sl@0	5319	}
sl@0	5320
sl@0	5321	Tcl_AppendToObj(msg, "\"", -1);
sl@0	5322	Tcl_AddObjErrorInfo(interp, Tcl_GetString(msg), -1);
sl@0	5323	Tcl_DecrRefCount(msg);
sl@0	5324	iPtr->flags &= ~ERR_ALREADY_LOGGED;
sl@0	5325	}
sl@0	5326
sl@0	5327	/*
sl@0	5328	* Free any locally allocated storage used to call "unknown".
sl@0	5329	*/
sl@0	5330
sl@0	5331	if (localObjv != (Tcl_Obj **) NULL) {
sl@0	5332	Tcl_DecrRefCount(localObjv[0]);
sl@0	5333	ckfree((char *) localObjv);
sl@0	5334	}
sl@0	5335	return result;
sl@0	5336	}
sl@0	5337
sl@0	5338	/*
sl@0	5339	*---------------------------------------------------------------------------
sl@0	5340	*
sl@0	5341	* Tcl_ExprString --
sl@0	5342	*
sl@0	5343	* Evaluate an expression in a string and return its value in string
sl@0	5344	* form.
sl@0	5345	*
sl@0	5346	* Results:
sl@0	5347	* A standard Tcl result. If the result is TCL_OK, then the interp's
sl@0	5348	* result is set to the string value of the expression. If the result
sl@0	5349	* is TCL_ERROR, then the interp's result contains an error message.
sl@0	5350	*
sl@0	5351	* Side effects:
sl@0	5352	* A Tcl object is allocated to hold a copy of the expression string.
sl@0	5353	* This expression object is passed to Tcl_ExprObj and then
sl@0	5354	* deallocated.
sl@0	5355	*
sl@0	5356	*---------------------------------------------------------------------------
sl@0	5357	*/
sl@0	5358
sl@0	5359	EXPORT_C int
sl@0	5360	Tcl_ExprString(interp, string)
sl@0	5361	Tcl_Interp interp; / Context in which to evaluate the
sl@0	5362	* expression. */
sl@0	5363	CONST char string; / Expression to evaluate. */
sl@0	5364	{
sl@0	5365	register Tcl_Obj *exprPtr;
sl@0	5366	Tcl_Obj *resultPtr;
sl@0	5367	int length = strlen(string);
sl@0	5368	char buf[TCL_DOUBLE_SPACE];
sl@0	5369	int result = TCL_OK;
sl@0	5370
sl@0	5371	if (length > 0) {
sl@0	5372	TclNewObj(exprPtr);
sl@0	5373	TclInitStringRep(exprPtr, string, length);
sl@0	5374	Tcl_IncrRefCount(exprPtr);
sl@0	5375
sl@0	5376	result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
sl@0	5377	if (result == TCL_OK) {
sl@0	5378	/*
sl@0	5379	* Set the interpreter's string result from the result object.
sl@0	5380	*/
sl@0	5381
sl@0	5382	if (resultPtr->typePtr == &tclIntType) {
sl@0	5383	sprintf(buf, "%ld", resultPtr->internalRep.longValue);
sl@0	5384	Tcl_SetResult(interp, buf, TCL_VOLATILE);
sl@0	5385	} else if (resultPtr->typePtr == &tclDoubleType) {
sl@0	5386	Tcl_PrintDouble((Tcl_Interp *) NULL,
sl@0	5387	resultPtr->internalRep.doubleValue, buf);
sl@0	5388	Tcl_SetResult(interp, buf, TCL_VOLATILE);
sl@0	5389	} else {
sl@0	5390	/*
sl@0	5391	* Set interpreter's string result from the result object.
sl@0	5392	*/
sl@0	5393
sl@0	5394	Tcl_SetResult(interp, TclGetString(resultPtr),
sl@0	5395	TCL_VOLATILE);
sl@0	5396	}
sl@0	5397	Tcl_DecrRefCount(resultPtr); /* discard the result object */
sl@0	5398	} else {
sl@0	5399	/*
sl@0	5400	* Move the interpreter's object result to the string result,
sl@0	5401	* then reset the object result.
sl@0	5402	*/
sl@0	5403
sl@0	5404	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
sl@0	5405	TCL_VOLATILE);
sl@0	5406	}
sl@0	5407	Tcl_DecrRefCount(exprPtr); /* discard the expression object */
sl@0	5408	} else {
sl@0	5409	/*
sl@0	5410	* An empty string. Just set the interpreter's result to 0.
sl@0	5411	*/
sl@0	5412
sl@0	5413	Tcl_SetResult(interp, "0", TCL_VOLATILE);
sl@0	5414	}
sl@0	5415	return result;
sl@0	5416	}
sl@0	5417
sl@0	5418	/*
sl@0	5419	*----------------------------------------------------------------------
sl@0	5420	*
sl@0	5421	* Tcl_CreateObjTrace --
sl@0	5422	*
sl@0	5423	* Arrange for a procedure to be called to trace command execution.
sl@0	5424	*
sl@0	5425	* Results:
sl@0	5426	* The return value is a token for the trace, which may be passed
sl@0	5427	* to Tcl_DeleteTrace to eliminate the trace.
sl@0	5428	*
sl@0	5429	* Side effects:
sl@0	5430	* From now on, proc will be called just before a command procedure
sl@0	5431	* is called to execute a Tcl command. Calls to proc will have the
sl@0	5432	* following form:
sl@0	5433	*
sl@0	5434	* void proc( ClientData clientData,
sl@0	5435	* Tcl_Interp* interp,
sl@0	5436	* int level,
sl@0	5437	* CONST char* command,
sl@0	5438	* Tcl_Command commandInfo,
sl@0	5439	* int objc,
sl@0	5440	* Tcl_Obj *CONST objv[] );
sl@0	5441	*
sl@0	5442	* The 'clientData' and 'interp' arguments to 'proc' will be the
sl@0	5443	* same as the arguments to Tcl_CreateObjTrace. The 'level'
sl@0	5444	* argument gives the nesting depth of command interpretation within
sl@0	5445	* the interpreter. The 'command' argument is the ASCII text of
sl@0	5446	* the command being evaluated -- before any substitutions are
sl@0	5447	* performed. The 'commandInfo' argument gives a handle to the
sl@0	5448	* command procedure that will be evaluated. The 'objc' and 'objv'
sl@0	5449	* parameters give the parameter vector that will be passed to the
sl@0	5450	* command procedure. proc does not return a value.
sl@0	5451	*
sl@0	5452	* It is permissible for 'proc' to call Tcl_SetCommandTokenInfo
sl@0	5453	* to change the command procedure or client data for the command
sl@0	5454	* being evaluated, and these changes will take effect with the
sl@0	5455	* current evaluation.
sl@0	5456	*
sl@0	5457	* The 'level' argument specifies the maximum nesting level of calls
sl@0	5458	* to be traced. If the execution depth of the interpreter exceeds
sl@0	5459	* 'level', the trace callback is not executed.
sl@0	5460	*
sl@0	5461	* The 'flags' argument is either zero or the value,
sl@0	5462	* TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION
sl@0	5463	* flag is not present, the bytecode compiler will not generate inline
sl@0	5464	* code for Tcl's built-in commands. This behavior will have a significant
sl@0	5465	* impact on performance, but will ensure that all command evaluations are
sl@0	5466	* traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the
sl@0	5467	* bytecode compiler will have its normal behavior of compiling in-line
sl@0	5468	* code for some of Tcl's built-in commands. In this case, the tracing
sl@0	5469	* will be imprecise -- in-line code will not be traced -- but run-time
sl@0	5470	* performance will be improved. The latter behavior is desired for
sl@0	5471	* many applications such as profiling of run time.
sl@0	5472	*
sl@0	5473	* When the trace is deleted, the 'delProc' procedure will be invoked,
sl@0	5474	* passing it the original client data.
sl@0	5475	*
sl@0	5476	*----------------------------------------------------------------------
sl@0	5477	*/
sl@0	5478
sl@0	5479	EXPORT_C Tcl_Trace
sl@0	5480	Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc )
sl@0	5481	Tcl_Interp* interp; /* Tcl interpreter */
sl@0	5482	int level; /* Maximum nesting level */
sl@0	5483	int flags; /* Flags, see above */
sl@0	5484	Tcl_CmdObjTraceProc* proc; /* Trace callback */
sl@0	5485	ClientData clientData; /* Client data for the callback */
sl@0	5486	Tcl_CmdObjTraceDeleteProc* delProc;
sl@0	5487	/* Procedure to call when trace is deleted */
sl@0	5488	{
sl@0	5489	register Trace *tracePtr;
sl@0	5490	register Interp iPtr = (Interp ) interp;
sl@0	5491
sl@0	5492	/* Test if this trace allows inline compilation of commands */
sl@0	5493
sl@0	5494	if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) {
sl@0	5495	if (iPtr->tracesForbiddingInline == 0) {
sl@0	5496
sl@0	5497	/*
sl@0	5498	* When the first trace forbidding inline compilation is
sl@0	5499	* created, invalidate existing compiled code for this
sl@0	5500	* interpreter and arrange (by setting the
sl@0	5501	* DONT_COMPILE_CMDS_INLINE flag) that when compiling new
sl@0	5502	* code, no commands will be compiled inline (i.e., into
sl@0	5503	* an inline sequence of instructions). We do this because
sl@0	5504	* commands that were compiled inline will never result in
sl@0	5505	* a command trace being called.
sl@0	5506	*/
sl@0	5507
sl@0	5508	iPtr->compileEpoch++;
sl@0	5509	iPtr->flags \|= DONT_COMPILE_CMDS_INLINE;
sl@0	5510	}
sl@0	5511	iPtr->tracesForbiddingInline++;
sl@0	5512	}
sl@0	5513
sl@0	5514	tracePtr = (Trace *) ckalloc(sizeof(Trace));
sl@0	5515	tracePtr->level = level;
sl@0	5516	tracePtr->proc = proc;
sl@0	5517	tracePtr->clientData = clientData;
sl@0	5518	tracePtr->delProc = delProc;
sl@0	5519	tracePtr->nextPtr = iPtr->tracePtr;
sl@0	5520	tracePtr->flags = flags;
sl@0	5521	iPtr->tracePtr = tracePtr;
sl@0	5522
sl@0	5523	return (Tcl_Trace) tracePtr;
sl@0	5524	}
sl@0	5525
sl@0	5526	/*
sl@0	5527	*----------------------------------------------------------------------
sl@0	5528	*
sl@0	5529	* Tcl_CreateTrace --
sl@0	5530	*
sl@0	5531	* Arrange for a procedure to be called to trace command execution.
sl@0	5532	*
sl@0	5533	* Results:
sl@0	5534	* The return value is a token for the trace, which may be passed
sl@0	5535	* to Tcl_DeleteTrace to eliminate the trace.
sl@0	5536	*
sl@0	5537	* Side effects:
sl@0	5538	* From now on, proc will be called just before a command procedure
sl@0	5539	* is called to execute a Tcl command. Calls to proc will have the
sl@0	5540	* following form:
sl@0	5541	*
sl@0	5542	* void
sl@0	5543	* proc(clientData, interp, level, command, cmdProc, cmdClientData,
sl@0	5544	* argc, argv)
sl@0	5545	* ClientData clientData;
sl@0	5546	* Tcl_Interp *interp;
sl@0	5547	* int level;
sl@0	5548	* char *command;
sl@0	5549	* int (*cmdProc)();
sl@0	5550	* ClientData cmdClientData;
sl@0	5551	* int argc;
sl@0	5552	* char **argv;
sl@0	5553	* {
sl@0	5554	* }
sl@0	5555	*
sl@0	5556	* The clientData and interp arguments to proc will be the same
sl@0	5557	* as the corresponding arguments to this procedure. Level gives
sl@0	5558	* the nesting level of command interpretation for this interpreter
sl@0	5559	* (0 corresponds to top level). Command gives the ASCII text of
sl@0	5560	* the raw command, cmdProc and cmdClientData give the procedure that
sl@0	5561	* will be called to process the command and the ClientData value it
sl@0	5562	* will receive, and argc and argv give the arguments to the
sl@0	5563	* command, after any argument parsing and substitution. Proc
sl@0	5564	* does not return a value.
sl@0	5565	*
sl@0	5566	*----------------------------------------------------------------------
sl@0	5567	*/
sl@0	5568
sl@0	5569	EXPORT_C Tcl_Trace
sl@0	5570	Tcl_CreateTrace(interp, level, proc, clientData)
sl@0	5571	Tcl_Interp interp; / Interpreter in which to create trace. */
sl@0	5572	int level; /* Only call proc for commands at nesting
sl@0	5573	* level<=argument level (1=>top level). */
sl@0	5574	Tcl_CmdTraceProc proc; / Procedure to call before executing each
sl@0	5575	* command. */
sl@0	5576	ClientData clientData; /* Arbitrary value word to pass to proc. */
sl@0	5577	{
sl@0	5578	StringTraceData* data;
sl@0	5579	data = (StringTraceData) ckalloc( sizeof( data ));
sl@0	5580	data->clientData = clientData;
sl@0	5581	data->proc = proc;
sl@0	5582	return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc,
sl@0	5583	(ClientData) data, StringTraceDeleteProc );
sl@0	5584	}
sl@0	5585
sl@0	5586	/*
sl@0	5587	*----------------------------------------------------------------------
sl@0	5588	*
sl@0	5589	* StringTraceProc --
sl@0	5590	*
sl@0	5591	* Invoke a string-based trace procedure from an object-based
sl@0	5592	* callback.
sl@0	5593	*
sl@0	5594	* Results:
sl@0	5595	* None.
sl@0	5596	*
sl@0	5597	* Side effects:
sl@0	5598	* Whatever the string-based trace procedure does.
sl@0	5599	*
sl@0	5600	*----------------------------------------------------------------------
sl@0	5601	*/
sl@0	5602
sl@0	5603	static int
sl@0	5604	StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv )
sl@0	5605	ClientData clientData;
sl@0	5606	Tcl_Interp* interp;
sl@0	5607	int level;
sl@0	5608	CONST char* command;
sl@0	5609	Tcl_Command commandInfo;
sl@0	5610	int objc;
sl@0	5611	Tcl_Obj CONST objv;
sl@0	5612	{
sl@0	5613	StringTraceData* data = (StringTraceData*) clientData;
sl@0	5614	Command* cmdPtr = (Command*) commandInfo;
sl@0	5615
sl@0	5616	CONST char** argv; /* Args to pass to string trace proc */
sl@0	5617
sl@0	5618	int i;
sl@0	5619
sl@0	5620	/*
sl@0	5621	* This is a bit messy because we have to emulate the old trace
sl@0	5622	* interface, which uses strings for everything.
sl@0	5623	*/
sl@0	5624
sl@0	5625	argv = (CONST char **) ckalloc((unsigned) ( (objc + 1)
sl@0	5626	* sizeof(CONST char *) ));
sl@0	5627	for (i = 0; i < objc; i++) {
sl@0	5628	argv[i] = Tcl_GetString(objv[i]);
sl@0	5629	}
sl@0	5630	argv[objc] = 0;
sl@0	5631
sl@0	5632	/*
sl@0	5633	* Invoke the command procedure. Note that we cast away const-ness
sl@0	5634	* on two parameters for compatibility with legacy code; the code
sl@0	5635	* MUST NOT modify either command or argv.
sl@0	5636	*/
sl@0	5637
sl@0	5638	( data->proc )( data->clientData, interp, level,
sl@0	5639	(char*) command, cmdPtr->proc, cmdPtr->clientData,
sl@0	5640	objc, argv );
sl@0	5641	ckfree( (char*) argv );
sl@0	5642
sl@0	5643	return TCL_OK;
sl@0	5644	}
sl@0	5645
sl@0	5646	/*
sl@0	5647	*----------------------------------------------------------------------
sl@0	5648	*
sl@0	5649	* StringTraceDeleteProc --
sl@0	5650	*
sl@0	5651	* Clean up memory when a string-based trace is deleted.
sl@0	5652	*
sl@0	5653	* Results:
sl@0	5654	* None.
sl@0	5655	*
sl@0	5656	* Side effects:
sl@0	5657	* Allocated memory is returned to the system.
sl@0	5658	*
sl@0	5659	*----------------------------------------------------------------------
sl@0	5660	*/
sl@0	5661
sl@0	5662	static void
sl@0	5663	StringTraceDeleteProc( clientData )
sl@0	5664	ClientData clientData;
sl@0	5665	{
sl@0	5666	ckfree( (char*) clientData );
sl@0	5667	}
sl@0	5668
sl@0	5669	/*
sl@0	5670	*----------------------------------------------------------------------
sl@0	5671	*
sl@0	5672	* Tcl_DeleteTrace --
sl@0	5673	*
sl@0	5674	* Remove a trace.
sl@0	5675	*
sl@0	5676	* Results:
sl@0	5677	* None.
sl@0	5678	*
sl@0	5679	* Side effects:
sl@0	5680	* From now on there will be no more calls to the procedure given
sl@0	5681	* in trace.
sl@0	5682	*
sl@0	5683	*----------------------------------------------------------------------
sl@0	5684	*/
sl@0	5685
sl@0	5686	EXPORT_C void
sl@0	5687	Tcl_DeleteTrace(interp, trace)
sl@0	5688	Tcl_Interp interp; / Interpreter that contains trace. */
sl@0	5689	Tcl_Trace trace; /* Token for trace (returned previously by
sl@0	5690	* Tcl_CreateTrace). */
sl@0	5691	{
sl@0	5692	Interp iPtr = (Interp ) interp;
sl@0	5693	Trace prevPtr, tracePtr = (Trace *) trace;
sl@0	5694	register Trace **tracePtr2 = &(iPtr->tracePtr);
sl@0	5695	ActiveInterpTrace *activePtr;
sl@0	5696
sl@0	5697	/*
sl@0	5698	* Locate the trace entry in the interpreter's trace list,
sl@0	5699	* and remove it from the list.
sl@0	5700	*/
sl@0	5701
sl@0	5702	prevPtr = NULL;
sl@0	5703	while ((tracePtr2) != NULL && (tracePtr2) != tracePtr) {
sl@0	5704	prevPtr = *tracePtr2;
sl@0	5705	tracePtr2 = &((*tracePtr2)->nextPtr);
sl@0	5706	}
sl@0	5707	if (*tracePtr2 == NULL) {
sl@0	5708	return;
sl@0	5709	}
sl@0	5710	(tracePtr2) = (tracePtr2)->nextPtr;
sl@0	5711
sl@0	5712	/*
sl@0	5713	* The code below makes it possible to delete traces while traces
sl@0	5714	* are active: it makes sure that the deleted trace won't be
sl@0	5715	* processed by TclCheckInterpTraces.
sl@0	5716	*/
sl@0	5717
sl@0	5718	for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL;
sl@0	5719	activePtr = activePtr->nextPtr) {
sl@0	5720	if (activePtr->nextTracePtr == tracePtr) {
sl@0	5721	if (activePtr->reverseScan) {
sl@0	5722	activePtr->nextTracePtr = prevPtr;
sl@0	5723	} else {
sl@0	5724	activePtr->nextTracePtr = tracePtr->nextPtr;
sl@0	5725	}
sl@0	5726	}
sl@0	5727	}
sl@0	5728
sl@0	5729	/*
sl@0	5730	* If the trace forbids bytecode compilation, change the interpreter's
sl@0	5731	* state. If bytecode compilation is now permitted, flag the fact and
sl@0	5732	* advance the compilation epoch so that procs will be recompiled to
sl@0	5733	* take advantage of it.
sl@0	5734	*/
sl@0	5735
sl@0	5736	if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) {
sl@0	5737	iPtr->tracesForbiddingInline--;
sl@0	5738	if (iPtr->tracesForbiddingInline == 0) {
sl@0	5739	iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
sl@0	5740	iPtr->compileEpoch++;
sl@0	5741	}
sl@0	5742	}
sl@0	5743
sl@0	5744	/*
sl@0	5745	* Execute any delete callback.
sl@0	5746	*/
sl@0	5747
sl@0	5748	if (tracePtr->delProc != NULL) {
sl@0	5749	(tracePtr->delProc)(tracePtr->clientData);
sl@0	5750	}
sl@0	5751
sl@0	5752	/* Delete the trace object */
sl@0	5753
sl@0	5754	Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC);
sl@0	5755	}
sl@0	5756
sl@0	5757	/*
sl@0	5758	*----------------------------------------------------------------------
sl@0	5759	*
sl@0	5760	* Tcl_AddErrorInfo --
sl@0	5761	*
sl@0	5762	* Add information to the "errorInfo" variable that describes the
sl@0	5763	* current error.
sl@0	5764	*
sl@0	5765	* Results:
sl@0	5766	* None.
sl@0	5767	*
sl@0	5768	* Side effects:
sl@0	5769	* The contents of message are added to the "errorInfo" variable.
sl@0	5770	* If Tcl_Eval has been called since the current value of errorInfo
sl@0	5771	* was set, errorInfo is cleared before adding the new message.
sl@0	5772	* If we are just starting to log an error, errorInfo is initialized
sl@0	5773	* from the error message in the interpreter's result.
sl@0	5774	*
sl@0	5775	*----------------------------------------------------------------------
sl@0	5776	*/
sl@0	5777
sl@0	5778	EXPORT_C void
sl@0	5779	Tcl_AddErrorInfo(interp, message)
sl@0	5780	Tcl_Interp interp; / Interpreter to which error information
sl@0	5781	* pertains. */
sl@0	5782	CONST char message; / Message to record. */
sl@0	5783	{
sl@0	5784	Tcl_AddObjErrorInfo(interp, message, -1);
sl@0	5785	}
sl@0	5786
sl@0	5787	/*
sl@0	5788	*----------------------------------------------------------------------
sl@0	5789	*
sl@0	5790	* Tcl_AddObjErrorInfo --
sl@0	5791	*
sl@0	5792	* Add information to the "errorInfo" variable that describes the
sl@0	5793	* current error. This routine differs from Tcl_AddErrorInfo by
sl@0	5794	* taking a byte pointer and length.
sl@0	5795	*
sl@0	5796	* Results:
sl@0	5797	* None.
sl@0	5798	*
sl@0	5799	* Side effects:
sl@0	5800	* "length" bytes from "message" are added to the "errorInfo" variable.
sl@0	5801	* If "length" is negative, use bytes up to the first NULL byte.
sl@0	5802	* If Tcl_EvalObj has been called since the current value of errorInfo
sl@0	5803	* was set, errorInfo is cleared before adding the new message.
sl@0	5804	* If we are just starting to log an error, errorInfo is initialized
sl@0	5805	* from the error message in the interpreter's result.
sl@0	5806	*
sl@0	5807	*----------------------------------------------------------------------
sl@0	5808	*/
sl@0	5809
sl@0	5810	EXPORT_C void
sl@0	5811	Tcl_AddObjErrorInfo(interp, message, length)
sl@0	5812	Tcl_Interp interp; / Interpreter to which error information
sl@0	5813	* pertains. */
sl@0	5814	CONST char message; / Points to the first byte of an array of
sl@0	5815	* bytes of the message. */
sl@0	5816	int length; /* The number of bytes in the message.
sl@0	5817	* If < 0, then append all bytes up to a
sl@0	5818	* NULL byte. */
sl@0	5819	{
sl@0	5820	register Interp iPtr = (Interp ) interp;
sl@0	5821	Tcl_Obj *objPtr;
sl@0	5822
sl@0	5823	/*
sl@0	5824	* If we are just starting to log an error, errorInfo is initialized
sl@0	5825	* from the error message in the interpreter's result.
sl@0	5826	*/
sl@0	5827
sl@0	5828	if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
sl@0	5829	iPtr->flags \|= ERR_IN_PROGRESS;
sl@0	5830
sl@0	5831	if (iPtr->result[0] == 0) {
sl@0	5832	Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
sl@0	5833	iPtr->objResultPtr, TCL_GLOBAL_ONLY);
sl@0	5834	} else { /* use the string result */
sl@0	5835	objPtr = Tcl_NewStringObj(interp->result, -1);
sl@0	5836	Tcl_IncrRefCount(objPtr);
sl@0	5837	Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
sl@0	5838	objPtr, TCL_GLOBAL_ONLY);
sl@0	5839	Tcl_DecrRefCount(objPtr);
sl@0	5840	}
sl@0	5841
sl@0	5842	/*
sl@0	5843	* If the errorCode variable wasn't set by the code that generated
sl@0	5844	* the error, set it to "NONE".
sl@0	5845	*/
sl@0	5846
sl@0	5847	if (!(iPtr->flags & ERROR_CODE_SET)) {
sl@0	5848	objPtr = Tcl_NewStringObj("NONE", -1);
sl@0	5849	Tcl_IncrRefCount(objPtr);
sl@0	5850	Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
sl@0	5851	objPtr, TCL_GLOBAL_ONLY);
sl@0	5852	Tcl_DecrRefCount(objPtr);
sl@0	5853	}
sl@0	5854	}
sl@0	5855
sl@0	5856	/*
sl@0	5857	* Now append "message" to the end of errorInfo.
sl@0	5858	*/
sl@0	5859
sl@0	5860	if (length != 0) {
sl@0	5861	objPtr = Tcl_NewStringObj(message, length);
sl@0	5862	Tcl_IncrRefCount(objPtr);
sl@0	5863	Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
sl@0	5864	objPtr, (TCL_GLOBAL_ONLY \| TCL_APPEND_VALUE));
sl@0	5865	Tcl_DecrRefCount(objPtr); /* free msg object appended above */
sl@0	5866	}
sl@0	5867	}
sl@0	5868
sl@0	5869	/*
sl@0	5870	*---------------------------------------------------------------------------
sl@0	5871	*
sl@0	5872	* Tcl_VarEvalVA --
sl@0	5873	*
sl@0	5874	* Given a variable number of string arguments, concatenate them
sl@0	5875	* all together and execute the result as a Tcl command.
sl@0	5876	*
sl@0	5877	* Results:
sl@0	5878	* A standard Tcl return result. An error message or other result may
sl@0	5879	* be left in the interp's result.
sl@0	5880	*
sl@0	5881	* Side effects:
sl@0	5882	* Depends on what was done by the command.
sl@0	5883	*
sl@0	5884	*---------------------------------------------------------------------------
sl@0	5885	*/
sl@0	5886
sl@0	5887	EXPORT_C int
sl@0	5888	Tcl_VarEvalVA (interp, argList)
sl@0	5889	Tcl_Interp interp; / Interpreter in which to evaluate command. */
sl@0	5890	va_list argList; /* Variable argument list. */
sl@0	5891	{
sl@0	5892	Tcl_DString buf;
sl@0	5893	char *string;
sl@0	5894	int result;
sl@0	5895
sl@0	5896	/*
sl@0	5897	* Copy the strings one after the other into a single larger
sl@0	5898	* string. Use stack-allocated space for small commands, but if
sl@0	5899	* the command gets too large than call ckalloc to create the
sl@0	5900	* space.
sl@0	5901	*/
sl@0	5902
sl@0	5903	Tcl_DStringInit(&buf);
sl@0	5904	while (1) {
sl@0	5905	string = va_arg(argList, char *);
sl@0	5906	if (string == NULL) {
sl@0	5907	break;
sl@0	5908	}
sl@0	5909	Tcl_DStringAppend(&buf, string, -1);
sl@0	5910	}
sl@0	5911
sl@0	5912	result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
sl@0	5913	Tcl_DStringFree(&buf);
sl@0	5914	return result;
sl@0	5915	}
sl@0	5916
sl@0	5917	/*
sl@0	5918	*----------------------------------------------------------------------
sl@0	5919	*
sl@0	5920	* Tcl_VarEval --
sl@0	5921	*
sl@0	5922	* Given a variable number of string arguments, concatenate them
sl@0	5923	* all together and execute the result as a Tcl command.
sl@0	5924	*
sl@0	5925	* Results:
sl@0	5926	* A standard Tcl return result. An error message or other
sl@0	5927	* result may be left in interp->result.
sl@0	5928	*
sl@0	5929	* Side effects:
sl@0	5930	* Depends on what was done by the command.
sl@0	5931	*
sl@0	5932	*----------------------------------------------------------------------
sl@0	5933	*/
sl@0	5934	/* VARARGS2 / / ARGSUSED */
sl@0	5935	EXPORT_C int
sl@0	5936	Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
sl@0	5937	{
sl@0	5938	Tcl_Interp *interp;
sl@0	5939	va_list argList;
sl@0	5940	int result;
sl@0	5941
sl@0	5942	interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
sl@0	5943	result = Tcl_VarEvalVA(interp, argList);
sl@0	5944	va_end(argList);
sl@0	5945
sl@0	5946	return result;
sl@0	5947	}
sl@0	5948
sl@0	5949	/*
sl@0	5950	*---------------------------------------------------------------------------
sl@0	5951	*
sl@0	5952	* Tcl_GlobalEval --
sl@0	5953	*
sl@0	5954	* Evaluate a command at global level in an interpreter.
sl@0	5955	*
sl@0	5956	* Results:
sl@0	5957	* A standard Tcl result is returned, and the interp's result is
sl@0	5958	* modified accordingly.
sl@0	5959	*
sl@0	5960	* Side effects:
sl@0	5961	* The command string is executed in interp, and the execution
sl@0	5962	* is carried out in the variable context of global level (no
sl@0	5963	* procedures active), just as if an "uplevel #0" command were
sl@0	5964	* being executed.
sl@0	5965	*
sl@0	5966	---------------------------------------------------------------------------
sl@0	5967	*/
sl@0	5968
sl@0	5969	EXPORT_C int
sl@0	5970	Tcl_GlobalEval(interp, command)
sl@0	5971	Tcl_Interp interp; / Interpreter in which to evaluate command. */
sl@0	5972	CONST char command; / Command to evaluate. */
sl@0	5973	{
sl@0	5974	register Interp iPtr = (Interp ) interp;
sl@0	5975	int result;
sl@0	5976	CallFrame *savedVarFramePtr;
sl@0	5977
sl@0	5978	savedVarFramePtr = iPtr->varFramePtr;
sl@0	5979	iPtr->varFramePtr = NULL;
sl@0	5980	result = Tcl_Eval(interp, command);
sl@0	5981	iPtr->varFramePtr = savedVarFramePtr;
sl@0	5982	return result;
sl@0	5983	}
sl@0	5984
sl@0	5985	/*
sl@0	5986	*----------------------------------------------------------------------
sl@0	5987	*
sl@0	5988	* Tcl_SetRecursionLimit --
sl@0	5989	*
sl@0	5990	* Set the maximum number of recursive calls that may be active
sl@0	5991	* for an interpreter at once.
sl@0	5992	*
sl@0	5993	* Results:
sl@0	5994	* The return value is the old limit on nesting for interp.
sl@0	5995	*
sl@0	5996	* Side effects:
sl@0	5997	* None.
sl@0	5998	*
sl@0	5999	*----------------------------------------------------------------------
sl@0	6000	*/
sl@0	6001
sl@0	6002	EXPORT_C int
sl@0	6003	Tcl_SetRecursionLimit(interp, depth)
sl@0	6004	Tcl_Interp interp; / Interpreter whose nesting limit
sl@0	6005	* is to be set. */
sl@0	6006	int depth; /* New value for maximimum depth. */
sl@0	6007	{
sl@0	6008	Interp iPtr = (Interp ) interp;
sl@0	6009	int old;
sl@0	6010
sl@0	6011	old = iPtr->maxNestingDepth;
sl@0	6012	if (depth > 0) {
sl@0	6013	iPtr->maxNestingDepth = depth;
sl@0	6014	}
sl@0	6015	return old;
sl@0	6016	}
sl@0	6017
sl@0	6018	/*
sl@0	6019	*----------------------------------------------------------------------
sl@0	6020	*
sl@0	6021	* Tcl_AllowExceptions --
sl@0	6022	*
sl@0	6023	* Sets a flag in an interpreter so that exceptions can occur
sl@0	6024	* in the next call to Tcl_Eval without them being turned into
sl@0	6025	* errors.
sl@0	6026	*
sl@0	6027	* Results:
sl@0	6028	* None.
sl@0	6029	*
sl@0	6030	* Side effects:
sl@0	6031	* The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
sl@0	6032	* evalFlags structure. See the reference documentation for
sl@0	6033	* more details.
sl@0	6034	*
sl@0	6035	*----------------------------------------------------------------------
sl@0	6036	*/
sl@0	6037
sl@0	6038	EXPORT_C void
sl@0	6039	Tcl_AllowExceptions(interp)
sl@0	6040	Tcl_Interp interp; / Interpreter in which to set flag. */
sl@0	6041	{
sl@0	6042	Interp iPtr = (Interp ) interp;
sl@0	6043
sl@0	6044	iPtr->evalFlags \|= TCL_ALLOW_EXCEPTIONS;
sl@0	6045	}
sl@0	6046
sl@0	6047
sl@0	6048	/*
sl@0	6049	*----------------------------------------------------------------------
sl@0	6050	*
sl@0	6051	* Tcl_GetVersion
sl@0	6052	*
sl@0	6053	* Get the Tcl major, minor, and patchlevel version numbers and
sl@0	6054	* the release type. A patch is a release type TCL_FINAL_RELEASE
sl@0	6055	* with a patchLevel > 0.
sl@0	6056	*
sl@0	6057	* Results:
sl@0	6058	* None.
sl@0	6059	*
sl@0	6060	* Side effects:
sl@0	6061	* None.
sl@0	6062	*
sl@0	6063	*----------------------------------------------------------------------
sl@0	6064	*/
sl@0	6065
sl@0	6066	EXPORT_C void
sl@0	6067	Tcl_GetVersion(majorV, minorV, patchLevelV, type)
sl@0	6068	int *majorV;
sl@0	6069	int *minorV;
sl@0	6070	int *patchLevelV;
sl@0	6071	int *type;
sl@0	6072	{
sl@0	6073	if (majorV != NULL) {
sl@0	6074	*majorV = TCL_MAJOR_VERSION;
sl@0	6075	}
sl@0	6076	if (minorV != NULL) {
sl@0	6077	*minorV = TCL_MINOR_VERSION;
sl@0	6078	}
sl@0	6079	if (patchLevelV != NULL) {
sl@0	6080	*patchLevelV = TCL_RELEASE_SERIAL;
sl@0	6081	}
sl@0	6082	if (type != NULL) {
sl@0	6083	*type = TCL_RELEASE_LEVEL;
sl@0	6084	}
sl@0	6085	}
sl@0	6086
sl@0	6087	/*
sl@0	6088	* Local Variables:
sl@0	6089	* mode: c
sl@0	6090	* c-basic-offset: 4
sl@0	6091	* fill-column: 78
sl@0	6092	* End:
sl@0	6093	*/
sl@0	6094

author	sl@SLION-WIN7.fritz.box
	Fri, 15 Jun 2012 03:10:57 +0200
changeset 0	bde4ae8d615e
permissions	-rw-r--r--