Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclNamesp.c@260cb5ec6c19 (annotated)

sl@0	1	/*
sl@0	2	* tclNamesp.c --
sl@0	3	*
sl@0	4	* Contains support for namespaces, which provide a separate context of
sl@0	5	* commands and global variables. The global :: namespace is the
sl@0	6	* traditional Tcl "global" scope. Other namespaces are created as
sl@0	7	* children of the global namespace. These other namespaces contain
sl@0	8	* special-purpose commands and variables for packages.
sl@0	9	*
sl@0	10	* Copyright (c) 1993-1997 Lucent Technologies.
sl@0	11	* Copyright (c) 1997 Sun Microsystems, Inc.
sl@0	12	* Copyright (c) 1998-1999 by Scriptics Corporation.
sl@0	13	*
sl@0	14	* Originally implemented by
sl@0	15	* Michael J. McLennan
sl@0	16	* Bell Labs Innovations for Lucent Technologies
sl@0	17	* mmclennan@lucent.com
sl@0	18	*
sl@0	19	* See the file "license.terms" for information on usage and redistribution
sl@0	20	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	21	*
sl@0	22	* RCS: @(#) $Id: tclNamesp.c,v 1.31.2.14 2007/05/15 18:32:18 dgp Exp $
sl@0	23	*/
sl@0	24
sl@0	25	#include "tclInt.h"
sl@0	26
sl@0	27	/*
sl@0	28	* Flag passed to TclGetNamespaceForQualName to indicate that it should
sl@0	29	* search for a namespace rather than a command or variable inside a
sl@0	30	* namespace. Note that this flag's value must not conflict with the values
sl@0	31	* of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, or CREATE_NS_IF_UNKNOWN.
sl@0	32	*/
sl@0	33
sl@0	34	#define FIND_ONLY_NS 0x1000
sl@0	35
sl@0	36	/*
sl@0	37	* Initial size of stack allocated space for tail list - used when resetting
sl@0	38	* shadowed command references in the functin: TclResetShadowedCmdRefs.
sl@0	39	*/
sl@0	40
sl@0	41	#define NUM_TRAIL_ELEMS 5
sl@0	42
sl@0	43	/*
sl@0	44	* Count of the number of namespaces created. This value is used as a
sl@0	45	* unique id for each namespace.
sl@0	46	*/
sl@0	47
sl@0	48	static long numNsCreated = 0;
sl@0	49	TCL_DECLARE_MUTEX(nsMutex)
sl@0	50
sl@0	51	/*
sl@0	52	* This structure contains a cached pointer to a namespace that is the
sl@0	53	* result of resolving the namespace's name in some other namespace. It is
sl@0	54	* the internal representation for a nsName object. It contains the
sl@0	55	* pointer along with some information that is used to check the cached
sl@0	56	* pointer's validity.
sl@0	57	*/
sl@0	58
sl@0	59	typedef struct ResolvedNsName {
sl@0	60	Namespace nsPtr; / A cached namespace pointer. */
sl@0	61	long nsId; /* nsPtr's unique namespace id. Used to
sl@0	62	* verify that nsPtr is still valid
sl@0	63	* (e.g., it's possible that the namespace
sl@0	64	* was deleted and a new one created at
sl@0	65	* the same address). */
sl@0	66	Namespace refNsPtr; / Points to the namespace containing the
sl@0	67	* reference (not the namespace that
sl@0	68	* contains the referenced namespace). */
sl@0	69	int refCount; /* Reference count: 1 for each nsName
sl@0	70	* object that has a pointer to this
sl@0	71	* ResolvedNsName structure as its internal
sl@0	72	* rep. This structure can be freed when
sl@0	73	* refCount becomes zero. */
sl@0	74	} ResolvedNsName;
sl@0	75
sl@0	76	/*
sl@0	77	* Declarations for procedures local to this file:
sl@0	78	*/
sl@0	79
sl@0	80	static void DeleteImportedCmd _ANSI_ARGS_((
sl@0	81	ClientData clientData));
sl@0	82	static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
sl@0	83	Tcl_Obj *copyPtr));
sl@0	84	static void FreeNsNameInternalRep _ANSI_ARGS_((
sl@0	85	Tcl_Obj *objPtr));
sl@0	86	static int GetNamespaceFromObj _ANSI_ARGS_((
sl@0	87	Tcl_Interp interp, Tcl_Obj objPtr,
sl@0	88	Tcl_Namespace **nsPtrPtr));
sl@0	89	static int InvokeImportedCmd _ANSI_ARGS_((
sl@0	90	ClientData clientData, Tcl_Interp *interp,
sl@0	91	int objc, Tcl_Obj *CONST objv[]));
sl@0	92	static int NamespaceChildrenCmd _ANSI_ARGS_((
sl@0	93	ClientData dummy, Tcl_Interp *interp,
sl@0	94	int objc, Tcl_Obj *CONST objv[]));
sl@0	95	static int NamespaceCodeCmd _ANSI_ARGS_((
sl@0	96	ClientData dummy, Tcl_Interp *interp,
sl@0	97	int objc, Tcl_Obj *CONST objv[]));
sl@0	98	static int NamespaceCurrentCmd _ANSI_ARGS_((
sl@0	99	ClientData dummy, Tcl_Interp *interp,
sl@0	100	int objc, Tcl_Obj *CONST objv[]));
sl@0	101	static int NamespaceDeleteCmd _ANSI_ARGS_((
sl@0	102	ClientData dummy, Tcl_Interp *interp,
sl@0	103	int objc, Tcl_Obj *CONST objv[]));
sl@0	104	static int NamespaceEvalCmd _ANSI_ARGS_((
sl@0	105	ClientData dummy, Tcl_Interp *interp,
sl@0	106	int objc, Tcl_Obj *CONST objv[]));
sl@0	107	static int NamespaceExistsCmd _ANSI_ARGS_((
sl@0	108	ClientData dummy, Tcl_Interp *interp,
sl@0	109	int objc, Tcl_Obj *CONST objv[]));
sl@0	110	static int NamespaceExportCmd _ANSI_ARGS_((
sl@0	111	ClientData dummy, Tcl_Interp *interp,
sl@0	112	int objc, Tcl_Obj *CONST objv[]));
sl@0	113	static int NamespaceForgetCmd _ANSI_ARGS_((
sl@0	114	ClientData dummy, Tcl_Interp *interp,
sl@0	115	int objc, Tcl_Obj *CONST objv[]));
sl@0	116	static void NamespaceFree _ANSI_ARGS_((Namespace *nsPtr));
sl@0	117	static int NamespaceImportCmd _ANSI_ARGS_((
sl@0	118	ClientData dummy, Tcl_Interp *interp,
sl@0	119	int objc, Tcl_Obj *CONST objv[]));
sl@0	120	static int NamespaceInscopeCmd _ANSI_ARGS_((
sl@0	121	ClientData dummy, Tcl_Interp *interp,
sl@0	122	int objc, Tcl_Obj *CONST objv[]));
sl@0	123	static int NamespaceOriginCmd _ANSI_ARGS_((
sl@0	124	ClientData dummy, Tcl_Interp *interp,
sl@0	125	int objc, Tcl_Obj *CONST objv[]));
sl@0	126	static int NamespaceParentCmd _ANSI_ARGS_((
sl@0	127	ClientData dummy, Tcl_Interp *interp,
sl@0	128	int objc, Tcl_Obj *CONST objv[]));
sl@0	129	static int NamespaceQualifiersCmd _ANSI_ARGS_((
sl@0	130	ClientData dummy, Tcl_Interp *interp,
sl@0	131	int objc, Tcl_Obj *CONST objv[]));
sl@0	132	static int NamespaceTailCmd _ANSI_ARGS_((
sl@0	133	ClientData dummy, Tcl_Interp *interp,
sl@0	134	int objc, Tcl_Obj *CONST objv[]));
sl@0	135	static int NamespaceWhichCmd _ANSI_ARGS_((
sl@0	136	ClientData dummy, Tcl_Interp *interp,
sl@0	137	int objc, Tcl_Obj *CONST objv[]));
sl@0	138	static int SetNsNameFromAny _ANSI_ARGS_((
sl@0	139	Tcl_Interp interp, Tcl_Obj objPtr));
sl@0	140	static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr));
sl@0	141
sl@0	142	/*
sl@0	143	* This structure defines a Tcl object type that contains a
sl@0	144	* namespace reference. It is used in commands that take the
sl@0	145	* name of a namespace as an argument. The namespace reference
sl@0	146	* is resolved, and the result in cached in the object.
sl@0	147	*/
sl@0	148
sl@0	149	Tcl_ObjType tclNsNameType = {
sl@0	150	"nsName", /* the type's name */
sl@0	151	FreeNsNameInternalRep, /* freeIntRepProc */
sl@0	152	DupNsNameInternalRep, /* dupIntRepProc */
sl@0	153	UpdateStringOfNsName, /* updateStringProc */
sl@0	154	SetNsNameFromAny /* setFromAnyProc */
sl@0	155	};
sl@0	156
sl@0	157	/*
sl@0	158	*----------------------------------------------------------------------
sl@0	159	*
sl@0	160	* TclInitNamespaceSubsystem --
sl@0	161	*
sl@0	162	* This procedure is called to initialize all the structures that
sl@0	163	* are used by namespaces on a per-process basis.
sl@0	164	*
sl@0	165	* Results:
sl@0	166	* None.
sl@0	167	*
sl@0	168	* Side effects:
sl@0	169	* None.
sl@0	170	*
sl@0	171	*----------------------------------------------------------------------
sl@0	172	*/
sl@0	173
sl@0	174	void
sl@0	175	TclInitNamespaceSubsystem()
sl@0	176	{
sl@0	177	/*
sl@0	178	* Does nothing for now.
sl@0	179	*/
sl@0	180	}
sl@0	181
sl@0	182	/*
sl@0	183	*----------------------------------------------------------------------
sl@0	184	*
sl@0	185	* Tcl_GetCurrentNamespace --
sl@0	186	*
sl@0	187	* Returns a pointer to an interpreter's currently active namespace.
sl@0	188	*
sl@0	189	* Results:
sl@0	190	* Returns a pointer to the interpreter's current namespace.
sl@0	191	*
sl@0	192	* Side effects:
sl@0	193	* None.
sl@0	194	*
sl@0	195	*----------------------------------------------------------------------
sl@0	196	*/
sl@0	197
sl@0	198	Tcl_Namespace *
sl@0	199	Tcl_GetCurrentNamespace(interp)
sl@0	200	register Tcl_Interp interp; / Interpreter whose current namespace is
sl@0	201	* being queried. */
sl@0	202	{
sl@0	203	register Interp iPtr = (Interp ) interp;
sl@0	204	register Namespace *nsPtr;
sl@0	205
sl@0	206	if (iPtr->varFramePtr != NULL) {
sl@0	207	nsPtr = iPtr->varFramePtr->nsPtr;
sl@0	208	} else {
sl@0	209	nsPtr = iPtr->globalNsPtr;
sl@0	210	}
sl@0	211	return (Tcl_Namespace *) nsPtr;
sl@0	212	}
sl@0	213
sl@0	214	/*
sl@0	215	*----------------------------------------------------------------------
sl@0	216	*
sl@0	217	* Tcl_GetGlobalNamespace --
sl@0	218	*
sl@0	219	* Returns a pointer to an interpreter's global :: namespace.
sl@0	220	*
sl@0	221	* Results:
sl@0	222	* Returns a pointer to the specified interpreter's global namespace.
sl@0	223	*
sl@0	224	* Side effects:
sl@0	225	* None.
sl@0	226	*
sl@0	227	*----------------------------------------------------------------------
sl@0	228	*/
sl@0	229
sl@0	230	Tcl_Namespace *
sl@0	231	Tcl_GetGlobalNamespace(interp)
sl@0	232	register Tcl_Interp interp; / Interpreter whose global namespace
sl@0	233	* should be returned. */
sl@0	234	{
sl@0	235	register Interp iPtr = (Interp ) interp;
sl@0	236
sl@0	237	return (Tcl_Namespace *) iPtr->globalNsPtr;
sl@0	238	}
sl@0	239
sl@0	240	/*
sl@0	241	*----------------------------------------------------------------------
sl@0	242	*
sl@0	243	* Tcl_PushCallFrame --
sl@0	244	*
sl@0	245	* Pushes a new call frame onto the interpreter's Tcl call stack.
sl@0	246	* Called when executing a Tcl procedure or a "namespace eval" or
sl@0	247	* "namespace inscope" command.
sl@0	248	*
sl@0	249	* Results:
sl@0	250	* Returns TCL_OK if successful, or TCL_ERROR (along with an error
sl@0	251	* message in the interpreter's result object) if something goes wrong.
sl@0	252	*
sl@0	253	* Side effects:
sl@0	254	* Modifies the interpreter's Tcl call stack.
sl@0	255	*
sl@0	256	*----------------------------------------------------------------------
sl@0	257	*/
sl@0	258
sl@0	259	int
sl@0	260	Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame)
sl@0	261	Tcl_Interp interp; / Interpreter in which the new call frame
sl@0	262	* is to be pushed. */
sl@0	263	Tcl_CallFrame callFramePtr; / Points to a call frame structure to
sl@0	264	* push. Storage for this has already been
sl@0	265	* allocated by the caller; typically this
sl@0	266	* is the address of a CallFrame structure
sl@0	267	* allocated on the caller's C stack. The
sl@0	268	* call frame will be initialized by this
sl@0	269	* procedure. The caller can pop the frame
sl@0	270	* later with Tcl_PopCallFrame, and it is
sl@0	271	* responsible for freeing the frame's
sl@0	272	* storage. */
sl@0	273	Tcl_Namespace namespacePtr; / Points to the namespace in which the
sl@0	274	* frame will execute. If NULL, the
sl@0	275	* interpreter's current namespace will
sl@0	276	* be used. */
sl@0	277	int isProcCallFrame; /* If nonzero, the frame represents a
sl@0	278	* called Tcl procedure and may have local
sl@0	279	* vars. Vars will ordinarily be looked up
sl@0	280	* in the frame. If new variables are
sl@0	281	* created, they will be created in the
sl@0	282	* frame. If 0, the frame is for a
sl@0	283	* "namespace eval" or "namespace inscope"
sl@0	284	* command and var references are treated
sl@0	285	* as references to namespace variables. */
sl@0	286	{
sl@0	287	Interp iPtr = (Interp ) interp;
sl@0	288	register CallFrame framePtr = (CallFrame ) callFramePtr;
sl@0	289	register Namespace *nsPtr;
sl@0	290
sl@0	291	if (namespacePtr == NULL) {
sl@0	292	nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
sl@0	293	} else {
sl@0	294	nsPtr = (Namespace *) namespacePtr;
sl@0	295	if (nsPtr->flags & NS_DEAD) {
sl@0	296	panic("Trying to push call frame for dead namespace");
sl@0	297	/NOTREACHED/
sl@0	298	}
sl@0	299	}
sl@0	300
sl@0	301	nsPtr->activationCount++;
sl@0	302	framePtr->nsPtr = nsPtr;
sl@0	303	framePtr->isProcCallFrame = isProcCallFrame;
sl@0	304	framePtr->objc = 0;
sl@0	305	framePtr->objv = NULL;
sl@0	306	framePtr->callerPtr = iPtr->framePtr;
sl@0	307	framePtr->callerVarPtr = iPtr->varFramePtr;
sl@0	308	if (iPtr->varFramePtr != NULL) {
sl@0	309	framePtr->level = (iPtr->varFramePtr->level + 1);
sl@0	310	} else {
sl@0	311	framePtr->level = 1;
sl@0	312	}
sl@0	313	framePtr->procPtr = NULL; /* no called procedure */
sl@0	314	framePtr->varTablePtr = NULL; /* and no local variables */
sl@0	315	framePtr->numCompiledLocals = 0;
sl@0	316	framePtr->compiledLocals = NULL;
sl@0	317
sl@0	318	/*
sl@0	319	* Push the new call frame onto the interpreter's stack of procedure
sl@0	320	* call frames making it the current frame.
sl@0	321	*/
sl@0	322
sl@0	323	iPtr->framePtr = framePtr;
sl@0	324	iPtr->varFramePtr = framePtr;
sl@0	325	return TCL_OK;
sl@0	326	}
sl@0	327
sl@0	328	/*
sl@0	329	*----------------------------------------------------------------------
sl@0	330	*
sl@0	331	* Tcl_PopCallFrame --
sl@0	332	*
sl@0	333	* Removes a call frame from the Tcl call stack for the interpreter.
sl@0	334	* Called to remove a frame previously pushed by Tcl_PushCallFrame.
sl@0	335	*
sl@0	336	* Results:
sl@0	337	* None.
sl@0	338	*
sl@0	339	* Side effects:
sl@0	340	* Modifies the call stack of the interpreter. Resets various fields of
sl@0	341	* the popped call frame. If a namespace has been deleted and
sl@0	342	* has no more activations on the call stack, the namespace is
sl@0	343	* destroyed.
sl@0	344	*
sl@0	345	*----------------------------------------------------------------------
sl@0	346	*/
sl@0	347
sl@0	348	void
sl@0	349	Tcl_PopCallFrame(interp)
sl@0	350	Tcl_Interp* interp; /* Interpreter with call frame to pop. */
sl@0	351	{
sl@0	352	register Interp iPtr = (Interp ) interp;
sl@0	353	register CallFrame *framePtr = iPtr->framePtr;
sl@0	354	Namespace *nsPtr;
sl@0	355
sl@0	356	/*
sl@0	357	* It's important to remove the call frame from the interpreter's stack
sl@0	358	* of call frames before deleting local variables, so that traces
sl@0	359	* invoked by the variable deletion don't see the partially-deleted
sl@0	360	* frame.
sl@0	361	*/
sl@0	362
sl@0	363	iPtr->framePtr = framePtr->callerPtr;
sl@0	364	iPtr->varFramePtr = framePtr->callerVarPtr;
sl@0	365
sl@0	366	if (framePtr->varTablePtr != NULL) {
sl@0	367	TclDeleteVars(iPtr, framePtr->varTablePtr);
sl@0	368	ckfree((char *) framePtr->varTablePtr);
sl@0	369	framePtr->varTablePtr = NULL;
sl@0	370	}
sl@0	371	if (framePtr->numCompiledLocals > 0) {
sl@0	372	TclDeleteCompiledLocalVars(iPtr, framePtr);
sl@0	373	}
sl@0	374
sl@0	375	/*
sl@0	376	* Decrement the namespace's count of active call frames. If the
sl@0	377	* namespace is "dying" and there are no more active call frames,
sl@0	378	* call Tcl_DeleteNamespace to destroy it.
sl@0	379	*/
sl@0	380
sl@0	381	nsPtr = framePtr->nsPtr;
sl@0	382	nsPtr->activationCount--;
sl@0	383	if ((nsPtr->flags & NS_DYING)
sl@0	384	&& (nsPtr->activationCount == 0)) {
sl@0	385	Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
sl@0	386	}
sl@0	387	framePtr->nsPtr = NULL;
sl@0	388	}
sl@0	389
sl@0	390	/*
sl@0	391	*----------------------------------------------------------------------
sl@0	392	*
sl@0	393	* Tcl_CreateNamespace --
sl@0	394	*
sl@0	395	* Creates a new namespace with the given name. If there is no
sl@0	396	* active namespace (i.e., the interpreter is being initialized),
sl@0	397	* the global :: namespace is created and returned.
sl@0	398	*
sl@0	399	* Results:
sl@0	400	* Returns a pointer to the new namespace if successful. If the
sl@0	401	* namespace already exists or if another error occurs, this routine
sl@0	402	* returns NULL, along with an error message in the interpreter's
sl@0	403	* result object.
sl@0	404	*
sl@0	405	* Side effects:
sl@0	406	* If the name contains "::" qualifiers and a parent namespace does
sl@0	407	* not already exist, it is automatically created.
sl@0	408	*
sl@0	409	*----------------------------------------------------------------------
sl@0	410	*/
sl@0	411
sl@0	412	Tcl_Namespace *
sl@0	413	Tcl_CreateNamespace(interp, name, clientData, deleteProc)
sl@0	414	Tcl_Interp interp; / Interpreter in which a new namespace
sl@0	415	* is being created. Also used for
sl@0	416	* error reporting. */
sl@0	417	CONST char name; / Name for the new namespace. May be a
sl@0	418	* qualified name with names of ancestor
sl@0	419	* namespaces separated by "::"s. */
sl@0	420	ClientData clientData; /* One-word value to store with
sl@0	421	* namespace. */
sl@0	422	Tcl_NamespaceDeleteProc *deleteProc;
sl@0	423	/* Procedure called to delete client
sl@0	424	* data when the namespace is deleted.
sl@0	425	* NULL if no procedure should be
sl@0	426	* called. */
sl@0	427	{
sl@0	428	Interp iPtr = (Interp ) interp;
sl@0	429	register Namespace nsPtr, ancestorPtr;
sl@0	430	Namespace parentPtr, dummy1Ptr, *dummy2Ptr;
sl@0	431	Namespace *globalNsPtr = iPtr->globalNsPtr;
sl@0	432	CONST char *simpleName;
sl@0	433	Tcl_HashEntry *entryPtr;
sl@0	434	Tcl_DString buffer1, buffer2;
sl@0	435	int newEntry;
sl@0	436
sl@0	437	/*
sl@0	438	* If there is no active namespace, the interpreter is being
sl@0	439	* initialized.
sl@0	440	*/
sl@0	441
sl@0	442	if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) {
sl@0	443	/*
sl@0	444	* Treat this namespace as the global namespace, and avoid
sl@0	445	* looking for a parent.
sl@0	446	*/
sl@0	447
sl@0	448	parentPtr = NULL;
sl@0	449	simpleName = "";
sl@0	450	} else if (*name == '\0') {
sl@0	451	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	452	"can't create namespace \"\": only global namespace can have empty name", (char *) NULL);
sl@0	453	return NULL;
sl@0	454	} else {
sl@0	455	/*
sl@0	456	* Find the parent for the new namespace.
sl@0	457	*/
sl@0	458
sl@0	459	TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
sl@0	460	/flags/ (CREATE_NS_IF_UNKNOWN \| TCL_LEAVE_ERR_MSG),
sl@0	461	&parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
sl@0	462
sl@0	463	/*
sl@0	464	* If the unqualified name at the end is empty, there were trailing
sl@0	465	* "::"s after the namespace's name which we ignore. The new
sl@0	466	* namespace was already (recursively) created and is pointed to
sl@0	467	* by parentPtr.
sl@0	468	*/
sl@0	469
sl@0	470	if (*simpleName == '\0') {
sl@0	471	return (Tcl_Namespace *) parentPtr;
sl@0	472	}
sl@0	473
sl@0	474	/*
sl@0	475	* Check for a bad namespace name and make sure that the name
sl@0	476	* does not already exist in the parent namespace.
sl@0	477	*/
sl@0	478
sl@0	479	if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) {
sl@0	480	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	481	"can't create namespace \"", name,
sl@0	482	"\": already exists", (char *) NULL);
sl@0	483	return NULL;
sl@0	484	}
sl@0	485	}
sl@0	486
sl@0	487	/*
sl@0	488	* Create the new namespace and root it in its parent. Increment the
sl@0	489	* count of namespaces created.
sl@0	490	*/
sl@0	491
sl@0	492
sl@0	493	nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
sl@0	494	nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1));
sl@0	495	strcpy(nsPtr->name, simpleName);
sl@0	496	nsPtr->fullName = NULL; /* set below */
sl@0	497	nsPtr->clientData = clientData;
sl@0	498	nsPtr->deleteProc = deleteProc;
sl@0	499	nsPtr->parentPtr = parentPtr;
sl@0	500	Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
sl@0	501	Tcl_MutexLock(&nsMutex);
sl@0	502	numNsCreated++;
sl@0	503	nsPtr->nsId = numNsCreated;
sl@0	504	Tcl_MutexUnlock(&nsMutex);
sl@0	505	nsPtr->interp = interp;
sl@0	506	nsPtr->flags = 0;
sl@0	507	nsPtr->activationCount = 0;
sl@0	508	nsPtr->refCount = 0;
sl@0	509	Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
sl@0	510	Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
sl@0	511	nsPtr->exportArrayPtr = NULL;
sl@0	512	nsPtr->numExportPatterns = 0;
sl@0	513	nsPtr->maxExportPatterns = 0;
sl@0	514	nsPtr->cmdRefEpoch = 0;
sl@0	515	nsPtr->resolverEpoch = 0;
sl@0	516	nsPtr->cmdResProc = NULL;
sl@0	517	nsPtr->varResProc = NULL;
sl@0	518	nsPtr->compiledVarResProc = NULL;
sl@0	519
sl@0	520	if (parentPtr != NULL) {
sl@0	521	entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
sl@0	522	&newEntry);
sl@0	523	Tcl_SetHashValue(entryPtr, (ClientData) nsPtr);
sl@0	524	}
sl@0	525
sl@0	526	/*
sl@0	527	* Build the fully qualified name for this namespace.
sl@0	528	*/
sl@0	529
sl@0	530	Tcl_DStringInit(&buffer1);
sl@0	531	Tcl_DStringInit(&buffer2);
sl@0	532	for (ancestorPtr = nsPtr; ancestorPtr != NULL;
sl@0	533	ancestorPtr = ancestorPtr->parentPtr) {
sl@0	534	if (ancestorPtr != globalNsPtr) {
sl@0	535	Tcl_DStringAppend(&buffer1, "::", 2);
sl@0	536	Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1);
sl@0	537	}
sl@0	538	Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1);
sl@0	539
sl@0	540	Tcl_DStringSetLength(&buffer2, 0);
sl@0	541	Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1);
sl@0	542	Tcl_DStringSetLength(&buffer1, 0);
sl@0	543	}
sl@0	544
sl@0	545	name = Tcl_DStringValue(&buffer2);
sl@0	546	nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1));
sl@0	547	strcpy(nsPtr->fullName, name);
sl@0	548
sl@0	549	Tcl_DStringFree(&buffer1);
sl@0	550	Tcl_DStringFree(&buffer2);
sl@0	551
sl@0	552	/*
sl@0	553	* Return a pointer to the new namespace.
sl@0	554	*/
sl@0	555
sl@0	556	return (Tcl_Namespace *) nsPtr;
sl@0	557	}
sl@0	558
sl@0	559	/*
sl@0	560	*----------------------------------------------------------------------
sl@0	561	*
sl@0	562	* Tcl_DeleteNamespace --
sl@0	563	*
sl@0	564	* Deletes a namespace and all of the commands, variables, and other
sl@0	565	* namespaces within it.
sl@0	566	*
sl@0	567	* Results:
sl@0	568	* None.
sl@0	569	*
sl@0	570	* Side effects:
sl@0	571	* When a namespace is deleted, it is automatically removed as a
sl@0	572	* child of its parent namespace. Also, all its commands, variables
sl@0	573	* and child namespaces are deleted.
sl@0	574	*
sl@0	575	*----------------------------------------------------------------------
sl@0	576	*/
sl@0	577
sl@0	578	void
sl@0	579	Tcl_DeleteNamespace(namespacePtr)
sl@0	580	Tcl_Namespace namespacePtr; / Points to the namespace to delete. */
sl@0	581	{
sl@0	582	register Namespace nsPtr = (Namespace ) namespacePtr;
sl@0	583	Interp iPtr = (Interp ) nsPtr->interp;
sl@0	584	Namespace *globalNsPtr =
sl@0	585	(Namespace ) Tcl_GetGlobalNamespace((Tcl_Interp ) iPtr);
sl@0	586	Tcl_HashEntry *entryPtr;
sl@0	587
sl@0	588	/*
sl@0	589	* If the namespace is on the call frame stack, it is marked as "dying"
sl@0	590	* (NS_DYING is OR'd into its flags): the namespace can't be looked up
sl@0	591	* by name but its commands and variables are still usable by those
sl@0	592	* active call frames. When all active call frames referring to the
sl@0	593	* namespace have been popped from the Tcl stack, Tcl_PopCallFrame will
sl@0	594	* call this procedure again to delete everything in the namespace.
sl@0	595	* If no nsName objects refer to the namespace (i.e., if its refCount
sl@0	596	* is zero), its commands and variables are deleted and the storage for
sl@0	597	* its namespace structure is freed. Otherwise, if its refCount is
sl@0	598	* nonzero, the namespace's commands and variables are deleted but the
sl@0	599	* structure isn't freed. Instead, NS_DEAD is OR'd into the structure's
sl@0	600	* flags to allow the namespace resolution code to recognize that the
sl@0	601	* namespace is "deleted". The structure's storage is freed by
sl@0	602	* FreeNsNameInternalRep when its refCount reaches 0.
sl@0	603	*/
sl@0	604
sl@0	605	if (nsPtr->activationCount > 0) {
sl@0	606	nsPtr->flags \|= NS_DYING;
sl@0	607	if (nsPtr->parentPtr != NULL) {
sl@0	608	entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
sl@0	609	nsPtr->name);
sl@0	610	if (entryPtr != NULL) {
sl@0	611	Tcl_DeleteHashEntry(entryPtr);
sl@0	612	}
sl@0	613	}
sl@0	614	nsPtr->parentPtr = NULL;
sl@0	615	} else if (!(nsPtr->flags & NS_KILLED)) {
sl@0	616	/*
sl@0	617	* Delete the namespace and everything in it. If this is the global
sl@0	618	* namespace, then clear it but don't free its storage unless the
sl@0	619	* interpreter is being torn down. Set the NS_KILLED flag to avoid
sl@0	620	* recursive calls here - if the namespace is really in the process of
sl@0	621	* being deleted, ignore any second call.
sl@0	622	*/
sl@0	623
sl@0	624	nsPtr->flags \|= (NS_DYING\|NS_KILLED);
sl@0	625
sl@0	626	TclTeardownNamespace(nsPtr);
sl@0	627
sl@0	628	if ((nsPtr != globalNsPtr) \|\| (iPtr->flags & DELETED)) {
sl@0	629	/*
sl@0	630	* If this is the global namespace, then it may have residual
sl@0	631	* "errorInfo" and "errorCode" variables for errors that
sl@0	632	* occurred while it was being torn down. Try to clear the
sl@0	633	* variable list one last time.
sl@0	634	*/
sl@0	635
sl@0	636	TclDeleteNamespaceVars(nsPtr);
sl@0	637
sl@0	638	Tcl_DeleteHashTable(&nsPtr->childTable);
sl@0	639	Tcl_DeleteHashTable(&nsPtr->cmdTable);
sl@0	640
sl@0	641	/*
sl@0	642	* If the reference count is 0, then discard the namespace.
sl@0	643	* Otherwise, mark it as "dead" so that it can't be used.
sl@0	644	*/
sl@0	645
sl@0	646	if (nsPtr->refCount == 0) {
sl@0	647	NamespaceFree(nsPtr);
sl@0	648	} else {
sl@0	649	nsPtr->flags \|= NS_DEAD;
sl@0	650	}
sl@0	651	} else {
sl@0	652	/*
sl@0	653	* We didn't really kill it, so remove the KILLED marks, so
sl@0	654	* it can get killed later, avoiding mem leaks
sl@0	655	*/
sl@0	656	nsPtr->flags &= ~(NS_DYING\|NS_KILLED);
sl@0	657	}
sl@0	658	}
sl@0	659	}
sl@0	660
sl@0	661	/*
sl@0	662	*----------------------------------------------------------------------
sl@0	663	*
sl@0	664	* TclTeardownNamespace --
sl@0	665	*
sl@0	666	* Used internally to dismantle and unlink a namespace when it is
sl@0	667	* deleted. Divorces the namespace from its parent, and deletes all
sl@0	668	* commands, variables, and child namespaces.
sl@0	669	*
sl@0	670	* This is kept separate from Tcl_DeleteNamespace so that the global
sl@0	671	* namespace can be handled specially. Global variables like
sl@0	672	* "errorInfo" and "errorCode" need to remain intact while other
sl@0	673	* namespaces and commands are torn down, in case any errors occur.
sl@0	674	*
sl@0	675	* Results:
sl@0	676	* None.
sl@0	677	*
sl@0	678	* Side effects:
sl@0	679	* Removes this namespace from its parent's child namespace hashtable.
sl@0	680	* Deletes all commands, variables and namespaces in this namespace.
sl@0	681	* If this is the global namespace, the "errorInfo" and "errorCode"
sl@0	682	* variables are left alone and deleted later.
sl@0	683	*
sl@0	684	*----------------------------------------------------------------------
sl@0	685	*/
sl@0	686
sl@0	687	void
sl@0	688	TclTeardownNamespace(nsPtr)
sl@0	689	register Namespace nsPtr; / Points to the namespace to be dismantled
sl@0	690	* and unlinked from its parent. */
sl@0	691	{
sl@0	692	Interp iPtr = (Interp ) nsPtr->interp;
sl@0	693	register Tcl_HashEntry *entryPtr;
sl@0	694	Tcl_HashSearch search;
sl@0	695	Tcl_Namespace *childNsPtr;
sl@0	696	Tcl_Command cmd;
sl@0	697	Namespace *globalNsPtr =
sl@0	698	(Namespace ) Tcl_GetGlobalNamespace((Tcl_Interp ) iPtr);
sl@0	699	int i;
sl@0	700
sl@0	701	/*
sl@0	702	* Start by destroying the namespace's variable table,
sl@0	703	* since variables might trigger traces.
sl@0	704	*/
sl@0	705
sl@0	706	if (nsPtr == globalNsPtr) {
sl@0	707	/*
sl@0	708	* This is the global namespace. Tearing it down will destroy the
sl@0	709	* ::errorInfo and ::errorCode variables. We save and restore them
sl@0	710	* in case there are any errors in progress, so the error details
sl@0	711	* they contain will not be lost. See test namespace-8.5
sl@0	712	*/
sl@0	713
sl@0	714	Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo",
sl@0	715	NULL, TCL_GLOBAL_ONLY);
sl@0	716	Tcl_Obj *errorCode = Tcl_GetVar2Ex(nsPtr->interp, "errorCode",
sl@0	717	NULL, TCL_GLOBAL_ONLY);
sl@0	718
sl@0	719	if (errorInfo) {
sl@0	720	Tcl_IncrRefCount(errorInfo);
sl@0	721	}
sl@0	722	if (errorCode) {
sl@0	723	Tcl_IncrRefCount(errorCode);
sl@0	724	}
sl@0	725
sl@0	726	TclDeleteNamespaceVars(nsPtr);
sl@0	727	Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
sl@0	728
sl@0	729	if (errorInfo) {
sl@0	730	Tcl_SetVar2Ex(nsPtr->interp, "errorInfo", NULL,
sl@0	731	errorInfo, TCL_GLOBAL_ONLY);
sl@0	732	Tcl_DecrRefCount(errorInfo);
sl@0	733	}
sl@0	734	if (errorCode) {
sl@0	735	Tcl_SetVar2Ex(nsPtr->interp, "errorCode", NULL,
sl@0	736	errorCode, TCL_GLOBAL_ONLY);
sl@0	737	Tcl_DecrRefCount(errorCode);
sl@0	738	}
sl@0	739	} else {
sl@0	740	/*
sl@0	741	* Variable table should be cleared but not freed! TclDeleteVars
sl@0	742	* frees it, so we reinitialize it afterwards.
sl@0	743	*/
sl@0	744
sl@0	745	TclDeleteNamespaceVars(nsPtr);
sl@0	746	Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
sl@0	747	}
sl@0	748
sl@0	749	/*
sl@0	750	* Delete all commands in this namespace. Be careful when traversing the
sl@0	751	* hash table: when each command is deleted, it removes itself from the
sl@0	752	* command table.
sl@0	753	*/
sl@0	754
sl@0	755	for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
sl@0	756	entryPtr != NULL;
sl@0	757	entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {
sl@0	758	cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
sl@0	759	Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd);
sl@0	760	}
sl@0	761	Tcl_DeleteHashTable(&nsPtr->cmdTable);
sl@0	762	Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
sl@0	763
sl@0	764	/*
sl@0	765	* Remove the namespace from its parent's child hashtable.
sl@0	766	*/
sl@0	767
sl@0	768	if (nsPtr->parentPtr != NULL) {
sl@0	769	entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
sl@0	770	nsPtr->name);
sl@0	771	if (entryPtr != NULL) {
sl@0	772	Tcl_DeleteHashEntry(entryPtr);
sl@0	773	}
sl@0	774	}
sl@0	775	nsPtr->parentPtr = NULL;
sl@0	776
sl@0	777	/*
sl@0	778	* Delete all the child namespaces.
sl@0	779	*
sl@0	780	* BE CAREFUL: When each child is deleted, it will divorce
sl@0	781	* itself from its parent. You can't traverse a hash table
sl@0	782	* properly if its elements are being deleted. We use only
sl@0	783	* the Tcl_FirstHashEntry function to be safe.
sl@0	784	*/
sl@0	785
sl@0	786	for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
sl@0	787	entryPtr != NULL;
sl@0	788	entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
sl@0	789	childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
sl@0	790	Tcl_DeleteNamespace(childNsPtr);
sl@0	791	}
sl@0	792
sl@0	793	/*
sl@0	794	* Free the namespace's export pattern array.
sl@0	795	*/
sl@0	796
sl@0	797	if (nsPtr->exportArrayPtr != NULL) {
sl@0	798	for (i = 0; i < nsPtr->numExportPatterns; i++) {
sl@0	799	ckfree(nsPtr->exportArrayPtr[i]);
sl@0	800	}
sl@0	801	ckfree((char *) nsPtr->exportArrayPtr);
sl@0	802	nsPtr->exportArrayPtr = NULL;
sl@0	803	nsPtr->numExportPatterns = 0;
sl@0	804	nsPtr->maxExportPatterns = 0;
sl@0	805	}
sl@0	806
sl@0	807	/*
sl@0	808	* Free any client data associated with the namespace.
sl@0	809	*/
sl@0	810
sl@0	811	if (nsPtr->deleteProc != NULL) {
sl@0	812	(*nsPtr->deleteProc)(nsPtr->clientData);
sl@0	813	}
sl@0	814	nsPtr->deleteProc = NULL;
sl@0	815	nsPtr->clientData = NULL;
sl@0	816
sl@0	817	/*
sl@0	818	* Reset the namespace's id field to ensure that this namespace won't
sl@0	819	* be interpreted as valid by, e.g., the cache validation code for
sl@0	820	* cached command references in Tcl_GetCommandFromObj.
sl@0	821	*/
sl@0	822
sl@0	823	nsPtr->nsId = 0;
sl@0	824	}
sl@0	825
sl@0	826	/*
sl@0	827	*----------------------------------------------------------------------
sl@0	828	*
sl@0	829	* NamespaceFree --
sl@0	830	*
sl@0	831	* Called after a namespace has been deleted, when its
sl@0	832	* reference count reaches 0. Frees the data structure
sl@0	833	* representing the namespace.
sl@0	834	*
sl@0	835	* Results:
sl@0	836	* None.
sl@0	837	*
sl@0	838	* Side effects:
sl@0	839	* None.
sl@0	840	*
sl@0	841	*----------------------------------------------------------------------
sl@0	842	*/
sl@0	843
sl@0	844	static void
sl@0	845	NamespaceFree(nsPtr)
sl@0	846	register Namespace nsPtr; / Points to the namespace to free. */
sl@0	847	{
sl@0	848	/*
sl@0	849	* Most of the namespace's contents are freed when the namespace is
sl@0	850	* deleted by Tcl_DeleteNamespace. All that remains is to free its names
sl@0	851	* (for error messages), and the structure itself.
sl@0	852	*/
sl@0	853
sl@0	854	ckfree(nsPtr->name);
sl@0	855	ckfree(nsPtr->fullName);
sl@0	856
sl@0	857	ckfree((char *) nsPtr);
sl@0	858	}
sl@0	859
sl@0	860
sl@0	861	/*
sl@0	862	*----------------------------------------------------------------------
sl@0	863	*
sl@0	864	* Tcl_Export --
sl@0	865	*
sl@0	866	* Makes all the commands matching a pattern available to later be
sl@0	867	* imported from the namespace specified by namespacePtr (or the
sl@0	868	* current namespace if namespacePtr is NULL). The specified pattern is
sl@0	869	* appended onto the namespace's export pattern list, which is
sl@0	870	* optionally cleared beforehand.
sl@0	871	*
sl@0	872	* Results:
sl@0	873	* Returns TCL_OK if successful, or TCL_ERROR (along with an error
sl@0	874	* message in the interpreter's result) if something goes wrong.
sl@0	875	*
sl@0	876	* Side effects:
sl@0	877	* Appends the export pattern onto the namespace's export list.
sl@0	878	* Optionally reset the namespace's export pattern list.
sl@0	879	*
sl@0	880	*----------------------------------------------------------------------
sl@0	881	*/
sl@0	882
sl@0	883	int
sl@0	884	Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
sl@0	885	Tcl_Interp interp; / Current interpreter. */
sl@0	886	Tcl_Namespace namespacePtr; / Points to the namespace from which
sl@0	887	* commands are to be exported. NULL for
sl@0	888	* the current namespace. */
sl@0	889	CONST char pattern; / String pattern indicating which commands
sl@0	890	* to export. This pattern may not include
sl@0	891	* any namespace qualifiers; only commands
sl@0	892	* in the specified namespace may be
sl@0	893	* exported. */
sl@0	894	int resetListFirst; /* If nonzero, resets the namespace's
sl@0	895	* export list before appending. */
sl@0	896	{
sl@0	897	#define INIT_EXPORT_PATTERNS 5
sl@0	898	Namespace nsPtr, exportNsPtr, *dummyPtr;
sl@0	899	Namespace currNsPtr = (Namespace ) Tcl_GetCurrentNamespace(interp);
sl@0	900	CONST char *simplePattern;
sl@0	901	char *patternCpy;
sl@0	902	int neededElems, len, i;
sl@0	903
sl@0	904	/*
sl@0	905	* If the specified namespace is NULL, use the current namespace.
sl@0	906	*/
sl@0	907
sl@0	908	if (namespacePtr == NULL) {
sl@0	909	nsPtr = (Namespace *) currNsPtr;
sl@0	910	} else {
sl@0	911	nsPtr = (Namespace *) namespacePtr;
sl@0	912	}
sl@0	913
sl@0	914	/*
sl@0	915	* If resetListFirst is true (nonzero), clear the namespace's export
sl@0	916	* pattern list.
sl@0	917	*/
sl@0	918
sl@0	919	if (resetListFirst) {
sl@0	920	if (nsPtr->exportArrayPtr != NULL) {
sl@0	921	for (i = 0; i < nsPtr->numExportPatterns; i++) {
sl@0	922	ckfree(nsPtr->exportArrayPtr[i]);
sl@0	923	}
sl@0	924	ckfree((char *) nsPtr->exportArrayPtr);
sl@0	925	nsPtr->exportArrayPtr = NULL;
sl@0	926	nsPtr->numExportPatterns = 0;
sl@0	927	nsPtr->maxExportPatterns = 0;
sl@0	928	}
sl@0	929	}
sl@0	930
sl@0	931	/*
sl@0	932	* Check that the pattern doesn't have namespace qualifiers.
sl@0	933	*/
sl@0	934
sl@0	935	TclGetNamespaceForQualName(interp, pattern, nsPtr,
sl@0	936	/flags/ (TCL_LEAVE_ERR_MSG \| TCL_NAMESPACE_ONLY),
sl@0	937	&exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
sl@0	938
sl@0	939	if ((exportNsPtr != nsPtr) \|\| (strcmp(pattern, simplePattern) != 0)) {
sl@0	940	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	941	"invalid export pattern \"", pattern,
sl@0	942	"\": pattern can't specify a namespace",
sl@0	943	(char *) NULL);
sl@0	944	return TCL_ERROR;
sl@0	945	}
sl@0	946
sl@0	947	/*
sl@0	948	* Make sure that we don't already have the pattern in the array
sl@0	949	*/
sl@0	950	if (nsPtr->exportArrayPtr != NULL) {
sl@0	951	for (i = 0; i < nsPtr->numExportPatterns; i++) {
sl@0	952	if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) {
sl@0	953	/*
sl@0	954	* The pattern already exists in the list
sl@0	955	*/
sl@0	956	return TCL_OK;
sl@0	957	}
sl@0	958	}
sl@0	959	}
sl@0	960
sl@0	961	/*
sl@0	962	* Make sure there is room in the namespace's pattern array for the
sl@0	963	* new pattern.
sl@0	964	*/
sl@0	965
sl@0	966	neededElems = nsPtr->numExportPatterns + 1;
sl@0	967	if (nsPtr->exportArrayPtr == NULL) {
sl@0	968	nsPtr->exportArrayPtr = (char **)
sl@0	969	ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *)));
sl@0	970	nsPtr->numExportPatterns = 0;
sl@0	971	nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS;
sl@0	972	} else if (neededElems > nsPtr->maxExportPatterns) {
sl@0	973	int numNewElems = 2 * nsPtr->maxExportPatterns;
sl@0	974	size_t currBytes = nsPtr->numExportPatterns * sizeof(char *);
sl@0	975	size_t newBytes = numNewElems * sizeof(char *);
sl@0	976	char newPtr = (char ) ckalloc((unsigned) newBytes);
sl@0	977
sl@0	978	memcpy((VOID ) newPtr, (VOID ) nsPtr->exportArrayPtr,
sl@0	979	currBytes);
sl@0	980	ckfree((char *) nsPtr->exportArrayPtr);
sl@0	981	nsPtr->exportArrayPtr = (char **) newPtr;
sl@0	982	nsPtr->maxExportPatterns = numNewElems;
sl@0	983	}
sl@0	984
sl@0	985	/*
sl@0	986	* Add the pattern to the namespace's array of export patterns.
sl@0	987	*/
sl@0	988
sl@0	989	len = strlen(pattern);
sl@0	990	patternCpy = (char *) ckalloc((unsigned) (len + 1));
sl@0	991	strcpy(patternCpy, pattern);
sl@0	992
sl@0	993	nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
sl@0	994	nsPtr->numExportPatterns++;
sl@0	995	return TCL_OK;
sl@0	996	#undef INIT_EXPORT_PATTERNS
sl@0	997	}
sl@0	998
sl@0	999	/*
sl@0	1000	*----------------------------------------------------------------------
sl@0	1001	*
sl@0	1002	* Tcl_AppendExportList --
sl@0	1003	*
sl@0	1004	* Appends onto the argument object the list of export patterns for the
sl@0	1005	* specified namespace.
sl@0	1006	*
sl@0	1007	* Results:
sl@0	1008	* The return value is normally TCL_OK; in this case the object
sl@0	1009	* referenced by objPtr has each export pattern appended to it. If an
sl@0	1010	* error occurs, TCL_ERROR is returned and the interpreter's result
sl@0	1011	* holds an error message.
sl@0	1012	*
sl@0	1013	* Side effects:
sl@0	1014	* If necessary, the object referenced by objPtr is converted into
sl@0	1015	* a list object.
sl@0	1016	*
sl@0	1017	*----------------------------------------------------------------------
sl@0	1018	*/
sl@0	1019
sl@0	1020	int
sl@0	1021	Tcl_AppendExportList(interp, namespacePtr, objPtr)
sl@0	1022	Tcl_Interp interp; / Interpreter used for error reporting. */
sl@0	1023	Tcl_Namespace namespacePtr; / Points to the namespace whose export
sl@0	1024	* pattern list is appended onto objPtr.
sl@0	1025	* NULL for the current namespace. */
sl@0	1026	Tcl_Obj objPtr; / Points to the Tcl object onto which the
sl@0	1027	* export pattern list is appended. */
sl@0	1028	{
sl@0	1029	Namespace *nsPtr;
sl@0	1030	int i, result;
sl@0	1031
sl@0	1032	/*
sl@0	1033	* If the specified namespace is NULL, use the current namespace.
sl@0	1034	*/
sl@0	1035
sl@0	1036	if (namespacePtr == NULL) {
sl@0	1037	nsPtr = (Namespace ) (Namespace ) Tcl_GetCurrentNamespace(interp);
sl@0	1038	} else {
sl@0	1039	nsPtr = (Namespace *) namespacePtr;
sl@0	1040	}
sl@0	1041
sl@0	1042	/*
sl@0	1043	* Append the export pattern list onto objPtr.
sl@0	1044	*/
sl@0	1045
sl@0	1046	for (i = 0; i < nsPtr->numExportPatterns; i++) {
sl@0	1047	result = Tcl_ListObjAppendElement(interp, objPtr,
sl@0	1048	Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1));
sl@0	1049	if (result != TCL_OK) {
sl@0	1050	return result;
sl@0	1051	}
sl@0	1052	}
sl@0	1053	return TCL_OK;
sl@0	1054	}
sl@0	1055
sl@0	1056	/*
sl@0	1057	*----------------------------------------------------------------------
sl@0	1058	*
sl@0	1059	* Tcl_Import --
sl@0	1060	*
sl@0	1061	* Imports all of the commands matching a pattern into the namespace
sl@0	1062	* specified by namespacePtr (or the current namespace if contextNsPtr
sl@0	1063	* is NULL). This is done by creating a new command (the "imported
sl@0	1064	* command") that points to the real command in its original namespace.
sl@0	1065	*
sl@0	1066	* If matching commands are on the autoload path but haven't been
sl@0	1067	* loaded yet, this command forces them to be loaded, then creates
sl@0	1068	* the links to them.
sl@0	1069	*
sl@0	1070	* Results:
sl@0	1071	* Returns TCL_OK if successful, or TCL_ERROR (along with an error
sl@0	1072	* message in the interpreter's result) if something goes wrong.
sl@0	1073	*
sl@0	1074	* Side effects:
sl@0	1075	* Creates new commands in the importing namespace. These indirect
sl@0	1076	* calls back to the real command and are deleted if the real commands
sl@0	1077	* are deleted.
sl@0	1078	*
sl@0	1079	*----------------------------------------------------------------------
sl@0	1080	*/
sl@0	1081
sl@0	1082	int
sl@0	1083	Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
sl@0	1084	Tcl_Interp interp; / Current interpreter. */
sl@0	1085	Tcl_Namespace namespacePtr; / Points to the namespace into which the
sl@0	1086	* commands are to be imported. NULL for
sl@0	1087	* the current namespace. */
sl@0	1088	CONST char pattern; / String pattern indicating which commands
sl@0	1089	* to import. This pattern should be
sl@0	1090	* qualified by the name of the namespace
sl@0	1091	* from which to import the command(s). */
sl@0	1092	int allowOverwrite; /* If nonzero, allow existing commands to
sl@0	1093	* be overwritten by imported commands.
sl@0	1094	* If 0, return an error if an imported
sl@0	1095	* cmd conflicts with an existing one. */
sl@0	1096	{
sl@0	1097	Interp iPtr = (Interp ) interp;
sl@0	1098	Namespace nsPtr, importNsPtr, *dummyPtr;
sl@0	1099	Namespace currNsPtr = (Namespace ) Tcl_GetCurrentNamespace(interp);
sl@0	1100	CONST char *simplePattern;
sl@0	1101	char *cmdName;
sl@0	1102	register Tcl_HashEntry *hPtr;
sl@0	1103	Tcl_HashSearch search;
sl@0	1104	Command *cmdPtr;
sl@0	1105	ImportRef *refPtr;
sl@0	1106	Tcl_Command autoCmd, importedCmd;
sl@0	1107	ImportedCmdData *dataPtr;
sl@0	1108	int wasExported, i, result;
sl@0	1109
sl@0	1110	/*
sl@0	1111	* If the specified namespace is NULL, use the current namespace.
sl@0	1112	*/
sl@0	1113
sl@0	1114	if (namespacePtr == NULL) {
sl@0	1115	nsPtr = (Namespace *) currNsPtr;
sl@0	1116	} else {
sl@0	1117	nsPtr = (Namespace *) namespacePtr;
sl@0	1118	}
sl@0	1119
sl@0	1120	/*
sl@0	1121	* First, invoke the "auto_import" command with the pattern
sl@0	1122	* being imported. This command is part of the Tcl library.
sl@0	1123	* It looks for imported commands in autoloaded libraries and
sl@0	1124	* loads them in. That way, they will be found when we try
sl@0	1125	* to create links below.
sl@0	1126	*/
sl@0	1127
sl@0	1128	autoCmd = Tcl_FindCommand(interp, "auto_import",
sl@0	1129	(Tcl_Namespace ) NULL, /flags*/ TCL_GLOBAL_ONLY);
sl@0	1130
sl@0	1131	if (autoCmd != NULL) {
sl@0	1132	Tcl_Obj *objv[2];
sl@0	1133
sl@0	1134	objv[0] = Tcl_NewStringObj("auto_import", -1);
sl@0	1135	Tcl_IncrRefCount(objv[0]);
sl@0	1136	objv[1] = Tcl_NewStringObj(pattern, -1);
sl@0	1137	Tcl_IncrRefCount(objv[1]);
sl@0	1138
sl@0	1139	cmdPtr = (Command *) autoCmd;
sl@0	1140	result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
sl@0	1141	2, objv);
sl@0	1142
sl@0	1143	Tcl_DecrRefCount(objv[0]);
sl@0	1144	Tcl_DecrRefCount(objv[1]);
sl@0	1145
sl@0	1146	if (result != TCL_OK) {
sl@0	1147	return TCL_ERROR;
sl@0	1148	}
sl@0	1149	Tcl_ResetResult(interp);
sl@0	1150	}
sl@0	1151
sl@0	1152	/*
sl@0	1153	* From the pattern, find the namespace from which we are importing
sl@0	1154	* and get the simple pattern (no namespace qualifiers or ::'s) at
sl@0	1155	* the end.
sl@0	1156	*/
sl@0	1157
sl@0	1158	if (strlen(pattern) == 0) {
sl@0	1159	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	1160	"empty import pattern", -1);
sl@0	1161	return TCL_ERROR;
sl@0	1162	}
sl@0	1163	TclGetNamespaceForQualName(interp, pattern, nsPtr,
sl@0	1164	/flags/ (TCL_LEAVE_ERR_MSG \| TCL_NAMESPACE_ONLY),
sl@0	1165	&importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
sl@0	1166
sl@0	1167	if (importNsPtr == NULL) {
sl@0	1168	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1169	"unknown namespace in import pattern \"",
sl@0	1170	pattern, "\"", (char *) NULL);
sl@0	1171	return TCL_ERROR;
sl@0	1172	}
sl@0	1173	if (importNsPtr == nsPtr) {
sl@0	1174	if (pattern == simplePattern) {
sl@0	1175	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1176	"no namespace specified in import pattern \"", pattern,
sl@0	1177	"\"", (char *) NULL);
sl@0	1178	} else {
sl@0	1179	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1180	"import pattern \"", pattern,
sl@0	1181	"\" tries to import from namespace \"",
sl@0	1182	importNsPtr->name, "\" into itself", (char *) NULL);
sl@0	1183	}
sl@0	1184	return TCL_ERROR;
sl@0	1185	}
sl@0	1186
sl@0	1187	/*
sl@0	1188	* Scan through the command table in the source namespace and look for
sl@0	1189	* exported commands that match the string pattern. Create an "imported
sl@0	1190	* command" in the current namespace for each imported command; these
sl@0	1191	* commands redirect their invocations to the "real" command.
sl@0	1192	*/
sl@0	1193
sl@0	1194	for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
sl@0	1195	(hPtr != NULL);
sl@0	1196	hPtr = Tcl_NextHashEntry(&search)) {
sl@0	1197	cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
sl@0	1198	if (Tcl_StringMatch(cmdName, simplePattern)) {
sl@0	1199	/*
sl@0	1200	* The command cmdName in the source namespace matches the
sl@0	1201	* pattern. Check whether it was exported. If it wasn't,
sl@0	1202	* we ignore it.
sl@0	1203	*/
sl@0	1204	Tcl_HashEntry *found;
sl@0	1205
sl@0	1206	wasExported = 0;
sl@0	1207	for (i = 0; i < importNsPtr->numExportPatterns; i++) {
sl@0	1208	if (Tcl_StringMatch(cmdName,
sl@0	1209	importNsPtr->exportArrayPtr[i])) {
sl@0	1210	wasExported = 1;
sl@0	1211	break;
sl@0	1212	}
sl@0	1213	}
sl@0	1214	if (!wasExported) {
sl@0	1215	continue;
sl@0	1216	}
sl@0	1217
sl@0	1218	/*
sl@0	1219	* Unless there is a name clash, create an imported command
sl@0	1220	* in the current namespace that refers to cmdPtr.
sl@0	1221	*/
sl@0	1222
sl@0	1223	found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName);
sl@0	1224	if ((found == NULL) \|\| allowOverwrite) {
sl@0	1225	/*
sl@0	1226	* Create the imported command and its client data.
sl@0	1227	* To create the new command in the current namespace,
sl@0	1228	* generate a fully qualified name for it.
sl@0	1229	*/
sl@0	1230
sl@0	1231	Tcl_DString ds;
sl@0	1232
sl@0	1233	Tcl_DStringInit(&ds);
sl@0	1234	Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
sl@0	1235	if (nsPtr != iPtr->globalNsPtr) {
sl@0	1236	Tcl_DStringAppend(&ds, "::", 2);
sl@0	1237	}
sl@0	1238	Tcl_DStringAppend(&ds, cmdName, -1);
sl@0	1239
sl@0	1240	/*
sl@0	1241	* Check whether creating the new imported command in the
sl@0	1242	* current namespace would create a cycle of imported
sl@0	1243	* command references.
sl@0	1244	*/
sl@0	1245
sl@0	1246	cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
sl@0	1247	if ((found != NULL)
sl@0	1248	&& cmdPtr->deleteProc == DeleteImportedCmd) {
sl@0	1249
sl@0	1250	Command overwrite = (Command ) Tcl_GetHashValue(found);
sl@0	1251	Command *link = cmdPtr;
sl@0	1252	while (link->deleteProc == DeleteImportedCmd) {
sl@0	1253	ImportedCmdData *dataPtr;
sl@0	1254
sl@0	1255	dataPtr = (ImportedCmdData *) link->objClientData;
sl@0	1256	link = dataPtr->realCmdPtr;
sl@0	1257	if (overwrite == link) {
sl@0	1258	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1259	"import pattern \"", pattern,
sl@0	1260	"\" would create a loop containing ",
sl@0	1261	"command \"", Tcl_DStringValue(&ds),
sl@0	1262	"\"", (char *) NULL);
sl@0	1263	Tcl_DStringFree(&ds);
sl@0	1264	return TCL_ERROR;
sl@0	1265	}
sl@0	1266	}
sl@0	1267	}
sl@0	1268
sl@0	1269	dataPtr = (ImportedCmdData *)
sl@0	1270	ckalloc(sizeof(ImportedCmdData));
sl@0	1271	importedCmd = Tcl_CreateObjCommand(interp,
sl@0	1272	Tcl_DStringValue(&ds), InvokeImportedCmd,
sl@0	1273	(ClientData) dataPtr, DeleteImportedCmd);
sl@0	1274	dataPtr->realCmdPtr = cmdPtr;
sl@0	1275	dataPtr->selfPtr = (Command *) importedCmd;
sl@0	1276	dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
sl@0	1277	Tcl_DStringFree(&ds);
sl@0	1278
sl@0	1279	/*
sl@0	1280	* Create an ImportRef structure describing this new import
sl@0	1281	* command and add it to the import ref list in the "real"
sl@0	1282	* command.
sl@0	1283	*/
sl@0	1284
sl@0	1285	refPtr = (ImportRef *) ckalloc(sizeof(ImportRef));
sl@0	1286	refPtr->importedCmdPtr = (Command *) importedCmd;
sl@0	1287	refPtr->nextPtr = cmdPtr->importRefPtr;
sl@0	1288	cmdPtr->importRefPtr = refPtr;
sl@0	1289	} else {
sl@0	1290	Command overwrite = (Command ) Tcl_GetHashValue(found);
sl@0	1291	if (overwrite->deleteProc == DeleteImportedCmd) {
sl@0	1292	ImportedCmdData *dataPtr =
sl@0	1293	(ImportedCmdData *) overwrite->objClientData;
sl@0	1294	if (dataPtr->realCmdPtr
sl@0	1295	== (Command *) Tcl_GetHashValue(hPtr)) {
sl@0	1296	/* Repeated import of same command -- acceptable */
sl@0	1297	return TCL_OK;
sl@0	1298	}
sl@0	1299	}
sl@0	1300	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1301	"can't import command \"", cmdName,
sl@0	1302	"\": already exists", (char *) NULL);
sl@0	1303	return TCL_ERROR;
sl@0	1304	}
sl@0	1305	}
sl@0	1306	}
sl@0	1307	return TCL_OK;
sl@0	1308	}
sl@0	1309
sl@0	1310	/*
sl@0	1311	*----------------------------------------------------------------------
sl@0	1312	*
sl@0	1313	* Tcl_ForgetImport --
sl@0	1314	*
sl@0	1315	* Deletes commands previously imported into the namespace indicated. The
sl@0	1316	* by namespacePtr, or the current namespace of interp, when
sl@0	1317	* namespacePtr is NULL. The pattern controls which imported commands
sl@0	1318	* are deleted. A simple pattern, one without namespace separators,
sl@0	1319	* matches the current command names of imported commands in the
sl@0	1320	* namespace. Matching imported commands are deleted. A qualified
sl@0	1321	* pattern is interpreted as deletion selection on the basis of where
sl@0	1322	* the command is imported from. The original command and "first link"
sl@0	1323	* command for each imported command are determined, and they are matched
sl@0	1324	* against the pattern. A match leads to deletion of the imported
sl@0	1325	* command.
sl@0	1326	*
sl@0	1327	* Results:
sl@0	1328	* Returns TCL_ERROR and records an error message in the interp
sl@0	1329	* result if a namespace qualified pattern refers to a namespace
sl@0	1330	* that does not exist. Otherwise, returns TCL_OK.
sl@0	1331	*
sl@0	1332	* Side effects:
sl@0	1333	* May delete commands.
sl@0	1334	*
sl@0	1335	*----------------------------------------------------------------------
sl@0	1336	*/
sl@0	1337
sl@0	1338	int
sl@0	1339	Tcl_ForgetImport(interp, namespacePtr, pattern)
sl@0	1340	Tcl_Interp interp; / Current interpreter. */
sl@0	1341	Tcl_Namespace namespacePtr; / Points to the namespace from which
sl@0	1342	* previously imported commands should be
sl@0	1343	* removed. NULL for current namespace. */
sl@0	1344	CONST char pattern; / String pattern indicating which imported
sl@0	1345	* commands to remove. */
sl@0	1346	{
sl@0	1347	Namespace nsPtr, sourceNsPtr, *dummyPtr;
sl@0	1348	CONST char *simplePattern;
sl@0	1349	char *cmdName;
sl@0	1350	register Tcl_HashEntry *hPtr;
sl@0	1351	Tcl_HashSearch search;
sl@0	1352
sl@0	1353	/*
sl@0	1354	* If the specified namespace is NULL, use the current namespace.
sl@0	1355	*/
sl@0	1356
sl@0	1357	if (namespacePtr == NULL) {
sl@0	1358	nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
sl@0	1359	} else {
sl@0	1360	nsPtr = (Namespace *) namespacePtr;
sl@0	1361	}
sl@0	1362
sl@0	1363	/*
sl@0	1364	* Parse the pattern into its namespace-qualification (if any)
sl@0	1365	* and the simple pattern.
sl@0	1366	*/
sl@0	1367
sl@0	1368	TclGetNamespaceForQualName(interp, pattern, nsPtr,
sl@0	1369	/flags/ (TCL_LEAVE_ERR_MSG \| TCL_NAMESPACE_ONLY),
sl@0	1370	&sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
sl@0	1371
sl@0	1372	if (sourceNsPtr == NULL) {
sl@0	1373	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1374	"unknown namespace in namespace forget pattern \"",
sl@0	1375	pattern, "\"", (char *) NULL);
sl@0	1376	return TCL_ERROR;
sl@0	1377	}
sl@0	1378
sl@0	1379	if (strcmp(pattern, simplePattern) == 0) {
sl@0	1380	/*
sl@0	1381	* The pattern is simple.
sl@0	1382	* Delete any imported commands that match it.
sl@0	1383	*/
sl@0	1384
sl@0	1385	for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
sl@0	1386	(hPtr != NULL);
sl@0	1387	hPtr = Tcl_NextHashEntry(&search)) {
sl@0	1388	Command cmdPtr = (Command ) Tcl_GetHashValue(hPtr);
sl@0	1389	if (cmdPtr->deleteProc != DeleteImportedCmd) {
sl@0	1390	continue;
sl@0	1391	}
sl@0	1392	cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
sl@0	1393	if (Tcl_StringMatch(cmdName, simplePattern)) {
sl@0	1394	Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
sl@0	1395	}
sl@0	1396	}
sl@0	1397	return TCL_OK;
sl@0	1398	}
sl@0	1399
sl@0	1400	/* The pattern was namespace-qualified */
sl@0	1401
sl@0	1402	for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
sl@0	1403	hPtr = Tcl_NextHashEntry(&search)) {
sl@0	1404	Tcl_CmdInfo info;
sl@0	1405	Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr);
sl@0	1406	Tcl_Command origin = TclGetOriginalCommand(token);
sl@0	1407
sl@0	1408	if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
sl@0	1409	continue; /* Not an imported command */
sl@0	1410	}
sl@0	1411	if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
sl@0	1412	/*
sl@0	1413	* Original not in namespace we're matching.
sl@0	1414	* Check the first link in the import chain.
sl@0	1415	*/
sl@0	1416	Command cmdPtr = (Command ) token;
sl@0	1417	ImportedCmdData *dataPtr =
sl@0	1418	(ImportedCmdData *) cmdPtr->objClientData;
sl@0	1419	Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;
sl@0	1420	if (firstToken == origin) {
sl@0	1421	continue;
sl@0	1422	}
sl@0	1423	Tcl_GetCommandInfoFromToken(firstToken, &info);
sl@0	1424	if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
sl@0	1425	continue;
sl@0	1426	}
sl@0	1427	origin = firstToken;
sl@0	1428	}
sl@0	1429	if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) {
sl@0	1430	Tcl_DeleteCommandFromToken(interp, token);
sl@0	1431	}
sl@0	1432	}
sl@0	1433	return TCL_OK;
sl@0	1434	}
sl@0	1435
sl@0	1436	/*
sl@0	1437	*----------------------------------------------------------------------
sl@0	1438	*
sl@0	1439	* TclGetOriginalCommand --
sl@0	1440	*
sl@0	1441	* An imported command is created in an namespace when a "real" command
sl@0	1442	* is imported from another namespace. If the specified command is an
sl@0	1443	* imported command, this procedure returns the original command it
sl@0	1444	* refers to.
sl@0	1445	*
sl@0	1446	* Results:
sl@0	1447	* If the command was imported into a sequence of namespaces a, b,...,n
sl@0	1448	* where each successive namespace just imports the command from the
sl@0	1449	* previous namespace, this procedure returns the Tcl_Command token in
sl@0	1450	* the first namespace, a. Otherwise, if the specified command is not
sl@0	1451	* an imported command, the procedure returns NULL.
sl@0	1452	*
sl@0	1453	* Side effects:
sl@0	1454	* None.
sl@0	1455	*
sl@0	1456	*----------------------------------------------------------------------
sl@0	1457	*/
sl@0	1458
sl@0	1459	Tcl_Command
sl@0	1460	TclGetOriginalCommand(command)
sl@0	1461	Tcl_Command command; /* The imported command for which the
sl@0	1462	* original command should be returned. */
sl@0	1463	{
sl@0	1464	register Command cmdPtr = (Command ) command;
sl@0	1465	ImportedCmdData *dataPtr;
sl@0	1466
sl@0	1467	if (cmdPtr->deleteProc != DeleteImportedCmd) {
sl@0	1468	return (Tcl_Command) NULL;
sl@0	1469	}
sl@0	1470
sl@0	1471	while (cmdPtr->deleteProc == DeleteImportedCmd) {
sl@0	1472	dataPtr = (ImportedCmdData *) cmdPtr->objClientData;
sl@0	1473	cmdPtr = dataPtr->realCmdPtr;
sl@0	1474	}
sl@0	1475	return (Tcl_Command) cmdPtr;
sl@0	1476	}
sl@0	1477
sl@0	1478	/*
sl@0	1479	*----------------------------------------------------------------------
sl@0	1480	*
sl@0	1481	* InvokeImportedCmd --
sl@0	1482	*
sl@0	1483	* Invoked by Tcl whenever the user calls an imported command that
sl@0	1484	* was created by Tcl_Import. Finds the "real" command (in another
sl@0	1485	* namespace), and passes control to it.
sl@0	1486	*
sl@0	1487	* Results:
sl@0	1488	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	1489	*
sl@0	1490	* Side effects:
sl@0	1491	* Returns a result in the interpreter's result object. If anything
sl@0	1492	* goes wrong, the result object is set to an error message.
sl@0	1493	*
sl@0	1494	*----------------------------------------------------------------------
sl@0	1495	*/
sl@0	1496
sl@0	1497	static int
sl@0	1498	InvokeImportedCmd(clientData, interp, objc, objv)
sl@0	1499	ClientData clientData; /* Points to the imported command's
sl@0	1500	* ImportedCmdData structure. */
sl@0	1501	Tcl_Interp interp; / Current interpreter. */
sl@0	1502	int objc; /* Number of arguments. */
sl@0	1503	Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	1504	{
sl@0	1505	register ImportedCmdData dataPtr = (ImportedCmdData ) clientData;
sl@0	1506	register Command *realCmdPtr = dataPtr->realCmdPtr;
sl@0	1507
sl@0	1508	return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp,
sl@0	1509	objc, objv);
sl@0	1510	}
sl@0	1511
sl@0	1512	/*
sl@0	1513	*----------------------------------------------------------------------
sl@0	1514	*
sl@0	1515	* DeleteImportedCmd --
sl@0	1516	*
sl@0	1517	* Invoked by Tcl whenever an imported command is deleted. The "real"
sl@0	1518	* command keeps a list of all the imported commands that refer to it,
sl@0	1519	* so those imported commands can be deleted when the real command is
sl@0	1520	* deleted. This procedure removes the imported command reference from
sl@0	1521	* the real command's list, and frees up the memory associated with
sl@0	1522	* the imported command.
sl@0	1523	*
sl@0	1524	* Results:
sl@0	1525	* None.
sl@0	1526	*
sl@0	1527	* Side effects:
sl@0	1528	* Removes the imported command from the real command's import list.
sl@0	1529	*
sl@0	1530	*----------------------------------------------------------------------
sl@0	1531	*/
sl@0	1532
sl@0	1533	static void
sl@0	1534	DeleteImportedCmd(clientData)
sl@0	1535	ClientData clientData; /* Points to the imported command's
sl@0	1536	* ImportedCmdData structure. */
sl@0	1537	{
sl@0	1538	ImportedCmdData dataPtr = (ImportedCmdData ) clientData;
sl@0	1539	Command *realCmdPtr = dataPtr->realCmdPtr;
sl@0	1540	Command *selfPtr = dataPtr->selfPtr;
sl@0	1541	register ImportRef refPtr, prevPtr;
sl@0	1542
sl@0	1543	prevPtr = NULL;
sl@0	1544	for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL;
sl@0	1545	refPtr = refPtr->nextPtr) {
sl@0	1546	if (refPtr->importedCmdPtr == selfPtr) {
sl@0	1547	/*
sl@0	1548	* Remove *refPtr from real command's list of imported commands
sl@0	1549	* that refer to it.
sl@0	1550	*/
sl@0	1551
sl@0	1552	if (prevPtr == NULL) { /* refPtr is first in list */
sl@0	1553	realCmdPtr->importRefPtr = refPtr->nextPtr;
sl@0	1554	} else {
sl@0	1555	prevPtr->nextPtr = refPtr->nextPtr;
sl@0	1556	}
sl@0	1557	ckfree((char *) refPtr);
sl@0	1558	ckfree((char *) dataPtr);
sl@0	1559	return;
sl@0	1560	}
sl@0	1561	prevPtr = refPtr;
sl@0	1562	}
sl@0	1563
sl@0	1564	panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
sl@0	1565	}
sl@0	1566
sl@0	1567	/*
sl@0	1568	*----------------------------------------------------------------------
sl@0	1569	*
sl@0	1570	* TclGetNamespaceForQualName --
sl@0	1571	*
sl@0	1572	* Given a qualified name specifying a command, variable, or namespace,
sl@0	1573	* and a namespace in which to resolve the name, this procedure returns
sl@0	1574	* a pointer to the namespace that contains the item. A qualified name
sl@0	1575	* consists of the "simple" name of an item qualified by the names of
sl@0	1576	* an arbitrary number of containing namespace separated by "::"s. If
sl@0	1577	* the qualified name starts with "::", it is interpreted absolutely
sl@0	1578	* from the global namespace. Otherwise, it is interpreted relative to
sl@0	1579	* the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr
sl@0	1580	* is NULL, the name is interpreted relative to the current namespace.
sl@0	1581	*
sl@0	1582	* A relative name like "foo::bar::x" can be found starting in either
sl@0	1583	* the current namespace or in the global namespace. So each search
sl@0	1584	* usually follows two tracks, and two possible namespaces are
sl@0	1585	* returned. If the procedure sets either nsPtrPtr or altNsPtrPtr to
sl@0	1586	* NULL, then that path failed.
sl@0	1587	*
sl@0	1588	* If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is
sl@0	1589	* sought only in the global :: namespace. The alternate search
sl@0	1590	* (also) starting from the global namespace is ignored and
sl@0	1591	* *altNsPtrPtr is set NULL.
sl@0	1592	*
sl@0	1593	* If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified
sl@0	1594	* name is sought only in the namespace specified by cxtNsPtr. The
sl@0	1595	* alternate search starting from the global namespace is ignored and
sl@0	1596	* *altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and
sl@0	1597	* TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and
sl@0	1598	* the search starts from the namespace specified by cxtNsPtr.
sl@0	1599	*
sl@0	1600	* If "flags" contains CREATE_NS_IF_UNKNOWN, all namespace
sl@0	1601	* components of the qualified name that cannot be found are
sl@0	1602	* automatically created within their specified parent. This makes sure
sl@0	1603	* that functions like Tcl_CreateCommand always succeed. There is no
sl@0	1604	* alternate search path, so *altNsPtrPtr is set NULL.
sl@0	1605	*
sl@0	1606	* If "flags" contains FIND_ONLY_NS, the qualified name is treated as a
sl@0	1607	* reference to a namespace, and the entire qualified name is
sl@0	1608	* followed. If the name is relative, the namespace is looked up only
sl@0	1609	* in the current namespace. A pointer to the namespace is stored in
sl@0	1610	* nsPtrPtr and NULL is stored in simpleNamePtr. Otherwise, if
sl@0	1611	* FIND_ONLY_NS is not specified, only the leading components are
sl@0	1612	* treated as namespace names, and a pointer to the simple name of the
sl@0	1613	* final component is stored in *simpleNamePtr.
sl@0	1614	*
sl@0	1615	* Results:
sl@0	1616	* It sets nsPtrPtr and altNsPtrPtr to point to the two possible
sl@0	1617	* namespaces which represent the last (containing) namespace in the
sl@0	1618	* qualified name. If the procedure sets either nsPtrPtr or altNsPtrPtr
sl@0	1619	* to NULL, then the search along that path failed. The procedure also
sl@0	1620	* stores a pointer to the simple name of the final component in
sl@0	1621	* *simpleNamePtr. If the qualified name is "::" or was treated as a
sl@0	1622	* namespace reference (FIND_ONLY_NS), the procedure stores a pointer
sl@0	1623	* to the namespace in nsPtrPtr, NULL in altNsPtrPtr, and sets
sl@0	1624	* *simpleNamePtr to point to an empty string.
sl@0	1625	*
sl@0	1626	* If there is an error, this procedure returns TCL_ERROR. If "flags"
sl@0	1627	* contains TCL_LEAVE_ERR_MSG, an error message is returned in the
sl@0	1628	* interpreter's result object. Otherwise, the interpreter's result
sl@0	1629	* object is left unchanged.
sl@0	1630	*
sl@0	1631	* *actualCxtPtrPtr is set to the actual context namespace. It is
sl@0	1632	* set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr
sl@0	1633	* is NULL, it is set to the current namespace context.
sl@0	1634	*
sl@0	1635	* For backwards compatibility with the TclPro byte code loader,
sl@0	1636	* this function always returns TCL_OK.
sl@0	1637	*
sl@0	1638	* Side effects:
sl@0	1639	* If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be
sl@0	1640	* created.
sl@0	1641	*
sl@0	1642	*----------------------------------------------------------------------
sl@0	1643	*/
sl@0	1644
sl@0	1645	int
sl@0	1646	TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
sl@0	1647	nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr)
sl@0	1648	Tcl_Interp interp; / Interpreter in which to find the
sl@0	1649	* namespace containing qualName. */
sl@0	1650	CONST char qualName; / A namespace-qualified name of an
sl@0	1651	* command, variable, or namespace. */
sl@0	1652	Namespace cxtNsPtr; / The namespace in which to start the
sl@0	1653	* search for qualName's namespace. If NULL
sl@0	1654	* start from the current namespace.
sl@0	1655	* Ignored if TCL_GLOBAL_ONLY is set. */
sl@0	1656	int flags; /* Flags controlling the search: an OR'd
sl@0	1657	* combination of TCL_GLOBAL_ONLY,
sl@0	1658	* TCL_NAMESPACE_ONLY,
sl@0	1659	* CREATE_NS_IF_UNKNOWN, and
sl@0	1660	* FIND_ONLY_NS. */
sl@0	1661	Namespace *nsPtrPtr; / Address where procedure stores a pointer
sl@0	1662	* to containing namespace if qualName is
sl@0	1663	* found starting from *cxtNsPtr or, if
sl@0	1664	* TCL_GLOBAL_ONLY is set, if qualName is
sl@0	1665	* found in the global :: namespace. NULL
sl@0	1666	* is stored otherwise. */
sl@0	1667	Namespace *altNsPtrPtr; / Address where procedure stores a pointer
sl@0	1668	* to containing namespace if qualName is
sl@0	1669	* found starting from the global ::
sl@0	1670	* namespace. NULL is stored if qualName
sl@0	1671	* isn't found starting from :: or if the
sl@0	1672	* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
sl@0	1673	* CREATE_NS_IF_UNKNOWN, FIND_ONLY_NS flag
sl@0	1674	* is set. */
sl@0	1675	Namespace *actualCxtPtrPtr; / Address where procedure stores a pointer
sl@0	1676	* to the actual namespace from which the
sl@0	1677	* search started. This is either cxtNsPtr,
sl@0	1678	* the :: namespace if TCL_GLOBAL_ONLY was
sl@0	1679	* specified, or the current namespace if
sl@0	1680	* cxtNsPtr was NULL. */
sl@0	1681	CONST char *simpleNamePtr; / Address where procedure stores the
sl@0	1682	* simple name at end of the qualName, or
sl@0	1683	* NULL if qualName is "::" or the flag
sl@0	1684	* FIND_ONLY_NS was specified. */
sl@0	1685	{
sl@0	1686	Interp iPtr = (Interp ) interp;
sl@0	1687	Namespace *nsPtr = cxtNsPtr;
sl@0	1688	Namespace *altNsPtr;
sl@0	1689	Namespace *globalNsPtr = iPtr->globalNsPtr;
sl@0	1690	CONST char start, end;
sl@0	1691	CONST char *nsName;
sl@0	1692	Tcl_HashEntry *entryPtr;
sl@0	1693	Tcl_DString buffer;
sl@0	1694	int len;
sl@0	1695
sl@0	1696	/*
sl@0	1697	* Determine the context namespace nsPtr in which to start the primary
sl@0	1698	* search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY
sl@0	1699	* was specified, search from the global namespace. Otherwise, use the
sl@0	1700	* namespace given in cxtNsPtr, or if that is NULL, use the current
sl@0	1701	* namespace context. Note that we always treat two or more
sl@0	1702	* adjacent ":"s as a namespace separator.
sl@0	1703	*/
sl@0	1704
sl@0	1705	if (flags & TCL_GLOBAL_ONLY) {
sl@0	1706	nsPtr = globalNsPtr;
sl@0	1707	} else if (nsPtr == NULL) {
sl@0	1708	if (iPtr->varFramePtr != NULL) {
sl@0	1709	nsPtr = iPtr->varFramePtr->nsPtr;
sl@0	1710	} else {
sl@0	1711	nsPtr = iPtr->globalNsPtr;
sl@0	1712	}
sl@0	1713	}
sl@0	1714
sl@0	1715	start = qualName; /* pts to start of qualifying namespace */
sl@0	1716	if ((qualName == ':') && ((qualName+1) == ':')) {
sl@0	1717	start = qualName+2; /* skip over the initial :: */
sl@0	1718	while (*start == ':') {
sl@0	1719	start++; /* skip over a subsequent : */
sl@0	1720	}
sl@0	1721	nsPtr = globalNsPtr;
sl@0	1722	if (start == '\0') { / qualName is just two or more ":"s */
sl@0	1723	*nsPtrPtr = globalNsPtr;
sl@0	1724	*altNsPtrPtr = NULL;
sl@0	1725	*actualCxtPtrPtr = globalNsPtr;
sl@0	1726	simpleNamePtr = start; / points to empty string */
sl@0	1727	return TCL_OK;
sl@0	1728	}
sl@0	1729	}
sl@0	1730	*actualCxtPtrPtr = nsPtr;
sl@0	1731
sl@0	1732	/*
sl@0	1733	* Start an alternate search path starting with the global namespace.
sl@0	1734	* However, if the starting context is the global namespace, or if the
sl@0	1735	* flag is set to search only the namespace *cxtNsPtr, ignore the
sl@0	1736	* alternate search path.
sl@0	1737	*/
sl@0	1738
sl@0	1739	altNsPtr = globalNsPtr;
sl@0	1740	if ((nsPtr == globalNsPtr)
sl@0	1741	\|\| (flags & (TCL_NAMESPACE_ONLY \| FIND_ONLY_NS))) {
sl@0	1742	altNsPtr = NULL;
sl@0	1743	}
sl@0	1744
sl@0	1745	/*
sl@0	1746	* Loop to resolve each namespace qualifier in qualName.
sl@0	1747	*/
sl@0	1748
sl@0	1749	Tcl_DStringInit(&buffer);
sl@0	1750	end = start;
sl@0	1751	while (*start != '\0') {
sl@0	1752	/*
sl@0	1753	* Find the next namespace qualifier (i.e., a name ending in "::")
sl@0	1754	* or the end of the qualified name (i.e., a name ending in "\0").
sl@0	1755	* Set len to the number of characters, starting from start,
sl@0	1756	* in the name; set end to point after the "::"s or at the "\0".
sl@0	1757	*/
sl@0	1758
sl@0	1759	len = 0;
sl@0	1760	for (end = start; *end != '\0'; end++) {
sl@0	1761	if ((end == ':') && ((end+1) == ':')) {
sl@0	1762	end += 2; /* skip over the initial :: */
sl@0	1763	while (*end == ':') {
sl@0	1764	end++; /* skip over the subsequent : */
sl@0	1765	}
sl@0	1766	break; /* exit for loop; end is after ::'s */
sl@0	1767	}
sl@0	1768	len++;
sl@0	1769	}
sl@0	1770
sl@0	1771	if ((*end == '\0')
sl@0	1772	&& !((end-start >= 2) && ((end-1) == ':') && ((end-2) == ':'))) {
sl@0	1773	/*
sl@0	1774	* qualName ended with a simple name at start. If FIND_ONLY_NS
sl@0	1775	* was specified, look this up as a namespace. Otherwise,
sl@0	1776	* start is the name of a cmd or var and we are done.
sl@0	1777	*/
sl@0	1778
sl@0	1779	if (flags & FIND_ONLY_NS) {
sl@0	1780	nsName = start;
sl@0	1781	} else {
sl@0	1782	*nsPtrPtr = nsPtr;
sl@0	1783	*altNsPtrPtr = altNsPtr;
sl@0	1784	*simpleNamePtr = start;
sl@0	1785	Tcl_DStringFree(&buffer);
sl@0	1786	return TCL_OK;
sl@0	1787	}
sl@0	1788	} else {
sl@0	1789	/*
sl@0	1790	* start points to the beginning of a namespace qualifier ending
sl@0	1791	* in "::". end points to the start of a name in that namespace
sl@0	1792	* that might be empty. Copy the namespace qualifier to a
sl@0	1793	* buffer so it can be null terminated. We can't modify the
sl@0	1794	* incoming qualName since it may be a string constant.
sl@0	1795	*/
sl@0	1796
sl@0	1797	Tcl_DStringSetLength(&buffer, 0);
sl@0	1798	Tcl_DStringAppend(&buffer, start, len);
sl@0	1799	nsName = Tcl_DStringValue(&buffer);
sl@0	1800	}
sl@0	1801
sl@0	1802	/*
sl@0	1803	* Look up the namespace qualifier nsName in the current namespace
sl@0	1804	* context. If it isn't found but CREATE_NS_IF_UNKNOWN is set,
sl@0	1805	* create that qualifying namespace. This is needed for procedures
sl@0	1806	* like Tcl_CreateCommand that cannot fail.
sl@0	1807	*/
sl@0	1808
sl@0	1809	if (nsPtr != NULL) {
sl@0	1810	entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName);
sl@0	1811	if (entryPtr != NULL) {
sl@0	1812	nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
sl@0	1813	} else if (flags & CREATE_NS_IF_UNKNOWN) {
sl@0	1814	Tcl_CallFrame frame;
sl@0	1815
sl@0	1816	(void) Tcl_PushCallFrame(interp, &frame,
sl@0	1817	(Tcl_Namespace ) nsPtr, /isProcCallFrame*/ 0);
sl@0	1818
sl@0	1819	nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName,
sl@0	1820	(ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
sl@0	1821	Tcl_PopCallFrame(interp);
sl@0	1822
sl@0	1823	if (nsPtr == NULL) {
sl@0	1824	panic("Could not create namespace '%s'", nsName);
sl@0	1825	}
sl@0	1826	} else { /* namespace not found and wasn't created */
sl@0	1827	nsPtr = NULL;
sl@0	1828	}
sl@0	1829	}
sl@0	1830
sl@0	1831	/*
sl@0	1832	* Look up the namespace qualifier in the alternate search path too.
sl@0	1833	*/
sl@0	1834
sl@0	1835	if (altNsPtr != NULL) {
sl@0	1836	entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName);
sl@0	1837	if (entryPtr != NULL) {
sl@0	1838	altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
sl@0	1839	} else {
sl@0	1840	altNsPtr = NULL;
sl@0	1841	}
sl@0	1842	}
sl@0	1843
sl@0	1844	/*
sl@0	1845	* If both search paths have failed, return NULL results.
sl@0	1846	*/
sl@0	1847
sl@0	1848	if ((nsPtr == NULL) && (altNsPtr == NULL)) {
sl@0	1849	*nsPtrPtr = NULL;
sl@0	1850	*altNsPtrPtr = NULL;
sl@0	1851	*simpleNamePtr = NULL;
sl@0	1852	Tcl_DStringFree(&buffer);
sl@0	1853	return TCL_OK;
sl@0	1854	}
sl@0	1855
sl@0	1856	start = end;
sl@0	1857	}
sl@0	1858
sl@0	1859	/*
sl@0	1860	* We ignore trailing "::"s in a namespace name, but in a command or
sl@0	1861	* variable name, trailing "::"s refer to the cmd or var named {}.
sl@0	1862	*/
sl@0	1863
sl@0	1864	if ((flags & FIND_ONLY_NS)
sl@0	1865	\|\| ((end > start ) && (*(end-1) != ':'))) {
sl@0	1866	simpleNamePtr = NULL; / found namespace name */
sl@0	1867	} else {
sl@0	1868	simpleNamePtr = end; / found cmd/var: points to empty string */
sl@0	1869	}
sl@0	1870
sl@0	1871	/*
sl@0	1872	* As a special case, if we are looking for a namespace and qualName
sl@0	1873	* is "" and the current active namespace (nsPtr) is not the global
sl@0	1874	* namespace, return NULL (no namespace was found). This is because
sl@0	1875	* namespaces can not have empty names except for the global namespace.
sl@0	1876	*/
sl@0	1877
sl@0	1878	if ((flags & FIND_ONLY_NS) && (*qualName == '\0')
sl@0	1879	&& (nsPtr != globalNsPtr)) {
sl@0	1880	nsPtr = NULL;
sl@0	1881	}
sl@0	1882
sl@0	1883	*nsPtrPtr = nsPtr;
sl@0	1884	*altNsPtrPtr = altNsPtr;
sl@0	1885	Tcl_DStringFree(&buffer);
sl@0	1886	return TCL_OK;
sl@0	1887	}
sl@0	1888
sl@0	1889	/*
sl@0	1890	*----------------------------------------------------------------------
sl@0	1891	*
sl@0	1892	* Tcl_FindNamespace --
sl@0	1893	*
sl@0	1894	* Searches for a namespace.
sl@0	1895	*
sl@0	1896	* Results:
sl@0	1897	* Returns a pointer to the namespace if it is found. Otherwise,
sl@0	1898	* returns NULL and leaves an error message in the interpreter's
sl@0	1899	* result object if "flags" contains TCL_LEAVE_ERR_MSG.
sl@0	1900	*
sl@0	1901	* Side effects:
sl@0	1902	* None.
sl@0	1903	*
sl@0	1904	*----------------------------------------------------------------------
sl@0	1905	*/
sl@0	1906
sl@0	1907	Tcl_Namespace *
sl@0	1908	Tcl_FindNamespace(interp, name, contextNsPtr, flags)
sl@0	1909	Tcl_Interp interp; / The interpreter in which to find the
sl@0	1910	* namespace. */
sl@0	1911	CONST char name; / Namespace name. If it starts with "::",
sl@0	1912	* will be looked up in global namespace.
sl@0	1913	* Else, looked up first in contextNsPtr
sl@0	1914	* (current namespace if contextNsPtr is
sl@0	1915	* NULL), then in global namespace. */
sl@0	1916	Tcl_Namespace contextNsPtr; / Ignored if TCL_GLOBAL_ONLY flag is set
sl@0	1917	* or if the name starts with "::".
sl@0	1918	* Otherwise, points to namespace in which
sl@0	1919	* to resolve name; if NULL, look up name
sl@0	1920	* in the current namespace. */
sl@0	1921	register int flags; /* Flags controlling namespace lookup: an
sl@0	1922	* OR'd combination of TCL_GLOBAL_ONLY and
sl@0	1923	* TCL_LEAVE_ERR_MSG flags. */
sl@0	1924	{
sl@0	1925	Namespace nsPtr, dummy1Ptr, *dummy2Ptr;
sl@0	1926	CONST char *dummy;
sl@0	1927
sl@0	1928	/*
sl@0	1929	* Find the namespace(s) that contain the specified namespace name.
sl@0	1930	* Add the FIND_ONLY_NS flag to resolve the name all the way down
sl@0	1931	* to its last component, a namespace.
sl@0	1932	*/
sl@0	1933
sl@0	1934	TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
sl@0	1935	(flags \| FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
sl@0	1936
sl@0	1937	if (nsPtr != NULL) {
sl@0	1938	return (Tcl_Namespace *) nsPtr;
sl@0	1939	} else if (flags & TCL_LEAVE_ERR_MSG) {
sl@0	1940	Tcl_ResetResult(interp);
sl@0	1941	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1942	"unknown namespace \"", name, "\"", (char *) NULL);
sl@0	1943	}
sl@0	1944	return NULL;
sl@0	1945	}
sl@0	1946
sl@0	1947	/*
sl@0	1948	*----------------------------------------------------------------------
sl@0	1949	*
sl@0	1950	* Tcl_FindCommand --
sl@0	1951	*
sl@0	1952	* Searches for a command.
sl@0	1953	*
sl@0	1954	* Results:
sl@0	1955	* Returns a token for the command if it is found. Otherwise, if it
sl@0	1956	* can't be found or there is an error, returns NULL and leaves an
sl@0	1957	* error message in the interpreter's result object if "flags"
sl@0	1958	* contains TCL_LEAVE_ERR_MSG.
sl@0	1959	*
sl@0	1960	* Side effects:
sl@0	1961	* None.
sl@0	1962	*
sl@0	1963	*----------------------------------------------------------------------
sl@0	1964	*/
sl@0	1965
sl@0	1966	Tcl_Command
sl@0	1967	Tcl_FindCommand(interp, name, contextNsPtr, flags)
sl@0	1968	Tcl_Interp interp; / The interpreter in which to find the
sl@0	1969	* command and to report errors. */
sl@0	1970	CONST char name; / Command's name. If it starts with "::",
sl@0	1971	* will be looked up in global namespace.
sl@0	1972	* Else, looked up first in contextNsPtr
sl@0	1973	* (current namespace if contextNsPtr is
sl@0	1974	* NULL), then in global namespace. */
sl@0	1975	Tcl_Namespace contextNsPtr; / Ignored if TCL_GLOBAL_ONLY flag set.
sl@0	1976	* Otherwise, points to namespace in which
sl@0	1977	* to resolve name. If NULL, look up name
sl@0	1978	* in the current namespace. */
sl@0	1979	int flags; /* An OR'd combination of flags:
sl@0	1980	* TCL_GLOBAL_ONLY (look up name only in
sl@0	1981	* global namespace), TCL_NAMESPACE_ONLY
sl@0	1982	* (look up only in contextNsPtr, or the
sl@0	1983	* current namespace if contextNsPtr is
sl@0	1984	* NULL), and TCL_LEAVE_ERR_MSG. If both
sl@0	1985	* TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY
sl@0	1986	* are given, TCL_GLOBAL_ONLY is
sl@0	1987	* ignored. */
sl@0	1988	{
sl@0	1989	Interp iPtr = (Interp)interp;
sl@0	1990
sl@0	1991	ResolverScheme *resPtr;
sl@0	1992	Namespace nsPtr[2], cxtNsPtr;
sl@0	1993	CONST char *simpleName;
sl@0	1994	register Tcl_HashEntry *entryPtr;
sl@0	1995	register Command *cmdPtr;
sl@0	1996	register int search;
sl@0	1997	int result;
sl@0	1998	Tcl_Command cmd;
sl@0	1999
sl@0	2000	/*
sl@0	2001	* If this namespace has a command resolver, then give it first
sl@0	2002	* crack at the command resolution. If the interpreter has any
sl@0	2003	* command resolvers, consult them next. The command resolver
sl@0	2004	* procedures may return a Tcl_Command value, they may signal
sl@0	2005	* to continue onward, or they may signal an error.
sl@0	2006	*/
sl@0	2007	if ((flags & TCL_GLOBAL_ONLY) != 0) {
sl@0	2008	cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
sl@0	2009	}
sl@0	2010	else if (contextNsPtr != NULL) {
sl@0	2011	cxtNsPtr = (Namespace *) contextNsPtr;
sl@0	2012	}
sl@0	2013	else {
sl@0	2014	cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
sl@0	2015	}
sl@0	2016
sl@0	2017	if (cxtNsPtr->cmdResProc != NULL \|\| iPtr->resolverPtr != NULL) {
sl@0	2018	resPtr = iPtr->resolverPtr;
sl@0	2019
sl@0	2020	if (cxtNsPtr->cmdResProc) {
sl@0	2021	result = (*cxtNsPtr->cmdResProc)(interp, name,
sl@0	2022	(Tcl_Namespace *) cxtNsPtr, flags, &cmd);
sl@0	2023	} else {
sl@0	2024	result = TCL_CONTINUE;
sl@0	2025	}
sl@0	2026
sl@0	2027	while (result == TCL_CONTINUE && resPtr) {
sl@0	2028	if (resPtr->cmdResProc) {
sl@0	2029	result = (*resPtr->cmdResProc)(interp, name,
sl@0	2030	(Tcl_Namespace *) cxtNsPtr, flags, &cmd);
sl@0	2031	}
sl@0	2032	resPtr = resPtr->nextPtr;
sl@0	2033	}
sl@0	2034
sl@0	2035	if (result == TCL_OK) {
sl@0	2036	return cmd;
sl@0	2037	}
sl@0	2038	else if (result != TCL_CONTINUE) {
sl@0	2039	return (Tcl_Command) NULL;
sl@0	2040	}
sl@0	2041	}
sl@0	2042
sl@0	2043	/*
sl@0	2044	* Find the namespace(s) that contain the command.
sl@0	2045	*/
sl@0	2046
sl@0	2047	TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
sl@0	2048	flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
sl@0	2049
sl@0	2050	/*
sl@0	2051	* Look for the command in the command table of its namespace.
sl@0	2052	* Be sure to check both possible search paths: from the specified
sl@0	2053	* namespace context and from the global namespace.
sl@0	2054	*/
sl@0	2055
sl@0	2056	cmdPtr = NULL;
sl@0	2057	for (search = 0; (search < 2) && (cmdPtr == NULL); search++) {
sl@0	2058	if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
sl@0	2059	entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
sl@0	2060	simpleName);
sl@0	2061	if (entryPtr != NULL) {
sl@0	2062	cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
sl@0	2063	}
sl@0	2064	}
sl@0	2065	}
sl@0	2066
sl@0	2067	if (cmdPtr != NULL) {
sl@0	2068	return (Tcl_Command) cmdPtr;
sl@0	2069	} else if (flags & TCL_LEAVE_ERR_MSG) {
sl@0	2070	Tcl_ResetResult(interp);
sl@0	2071	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	2072	"unknown command \"", name, "\"", (char *) NULL);
sl@0	2073	}
sl@0	2074
sl@0	2075	return (Tcl_Command) NULL;
sl@0	2076	}
sl@0	2077
sl@0	2078	/*
sl@0	2079	*----------------------------------------------------------------------
sl@0	2080	*
sl@0	2081	* Tcl_FindNamespaceVar --
sl@0	2082	*
sl@0	2083	* Searches for a namespace variable, a variable not local to a
sl@0	2084	* procedure. The variable can be either a scalar or an array, but
sl@0	2085	* may not be an element of an array.
sl@0	2086	*
sl@0	2087	* Results:
sl@0	2088	* Returns a token for the variable if it is found. Otherwise, if it
sl@0	2089	* can't be found or there is an error, returns NULL and leaves an
sl@0	2090	* error message in the interpreter's result object if "flags"
sl@0	2091	* contains TCL_LEAVE_ERR_MSG.
sl@0	2092	*
sl@0	2093	* Side effects:
sl@0	2094	* None.
sl@0	2095	*
sl@0	2096	*----------------------------------------------------------------------
sl@0	2097	*/
sl@0	2098
sl@0	2099	Tcl_Var
sl@0	2100	Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
sl@0	2101	Tcl_Interp interp; / The interpreter in which to find the
sl@0	2102	* variable. */
sl@0	2103	CONST char name; / Variable's name. If it starts with "::",
sl@0	2104	* will be looked up in global namespace.
sl@0	2105	* Else, looked up first in contextNsPtr
sl@0	2106	* (current namespace if contextNsPtr is
sl@0	2107	* NULL), then in global namespace. */
sl@0	2108	Tcl_Namespace contextNsPtr; / Ignored if TCL_GLOBAL_ONLY flag set.
sl@0	2109	* Otherwise, points to namespace in which
sl@0	2110	* to resolve name. If NULL, look up name
sl@0	2111	* in the current namespace. */
sl@0	2112	int flags; /* An OR'd combination of flags:
sl@0	2113	* TCL_GLOBAL_ONLY (look up name only in
sl@0	2114	* global namespace), TCL_NAMESPACE_ONLY
sl@0	2115	* (look up only in contextNsPtr, or the
sl@0	2116	* current namespace if contextNsPtr is
sl@0	2117	* NULL), and TCL_LEAVE_ERR_MSG. If both
sl@0	2118	* TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY
sl@0	2119	* are given, TCL_GLOBAL_ONLY is
sl@0	2120	* ignored. */
sl@0	2121	{
sl@0	2122	Interp iPtr = (Interp)interp;
sl@0	2123	ResolverScheme *resPtr;
sl@0	2124	Namespace nsPtr[2], cxtNsPtr;
sl@0	2125	CONST char *simpleName;
sl@0	2126	Tcl_HashEntry *entryPtr;
sl@0	2127	Var *varPtr;
sl@0	2128	register int search;
sl@0	2129	int result;
sl@0	2130	Tcl_Var var;
sl@0	2131
sl@0	2132	/*
sl@0	2133	* If this namespace has a variable resolver, then give it first
sl@0	2134	* crack at the variable resolution. It may return a Tcl_Var
sl@0	2135	* value, it may signal to continue onward, or it may signal
sl@0	2136	* an error.
sl@0	2137	*/
sl@0	2138	if ((flags & TCL_GLOBAL_ONLY) != 0) {
sl@0	2139	cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
sl@0	2140	}
sl@0	2141	else if (contextNsPtr != NULL) {
sl@0	2142	cxtNsPtr = (Namespace *) contextNsPtr;
sl@0	2143	}
sl@0	2144	else {
sl@0	2145	cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
sl@0	2146	}
sl@0	2147
sl@0	2148	if (cxtNsPtr->varResProc != NULL \|\| iPtr->resolverPtr != NULL) {
sl@0	2149	resPtr = iPtr->resolverPtr;
sl@0	2150
sl@0	2151	if (cxtNsPtr->varResProc) {
sl@0	2152	result = (*cxtNsPtr->varResProc)(interp, name,
sl@0	2153	(Tcl_Namespace *) cxtNsPtr, flags, &var);
sl@0	2154	} else {
sl@0	2155	result = TCL_CONTINUE;
sl@0	2156	}
sl@0	2157
sl@0	2158	while (result == TCL_CONTINUE && resPtr) {
sl@0	2159	if (resPtr->varResProc) {
sl@0	2160	result = (*resPtr->varResProc)(interp, name,
sl@0	2161	(Tcl_Namespace *) cxtNsPtr, flags, &var);
sl@0	2162	}
sl@0	2163	resPtr = resPtr->nextPtr;
sl@0	2164	}
sl@0	2165
sl@0	2166	if (result == TCL_OK) {
sl@0	2167	return var;
sl@0	2168	}
sl@0	2169	else if (result != TCL_CONTINUE) {
sl@0	2170	return (Tcl_Var) NULL;
sl@0	2171	}
sl@0	2172	}
sl@0	2173
sl@0	2174	/*
sl@0	2175	* Find the namespace(s) that contain the variable.
sl@0	2176	*/
sl@0	2177
sl@0	2178	TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
sl@0	2179	flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
sl@0	2180
sl@0	2181	/*
sl@0	2182	* Look for the variable in the variable table of its namespace.
sl@0	2183	* Be sure to check both possible search paths: from the specified
sl@0	2184	* namespace context and from the global namespace.
sl@0	2185	*/
sl@0	2186
sl@0	2187	varPtr = NULL;
sl@0	2188	for (search = 0; (search < 2) && (varPtr == NULL); search++) {
sl@0	2189	if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
sl@0	2190	entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable,
sl@0	2191	simpleName);
sl@0	2192	if (entryPtr != NULL) {
sl@0	2193	varPtr = (Var *) Tcl_GetHashValue(entryPtr);
sl@0	2194	}
sl@0	2195	}
sl@0	2196	}
sl@0	2197	if (varPtr != NULL) {
sl@0	2198	return (Tcl_Var) varPtr;
sl@0	2199	} else if (flags & TCL_LEAVE_ERR_MSG) {
sl@0	2200	Tcl_ResetResult(interp);
sl@0	2201	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	2202	"unknown variable \"", name, "\"", (char *) NULL);
sl@0	2203	}
sl@0	2204	return (Tcl_Var) NULL;
sl@0	2205	}
sl@0	2206
sl@0	2207	/*
sl@0	2208	*----------------------------------------------------------------------
sl@0	2209	*
sl@0	2210	* TclResetShadowedCmdRefs --
sl@0	2211	*
sl@0	2212	* Called when a command is added to a namespace to check for existing
sl@0	2213	* command references that the new command may invalidate. Consider the
sl@0	2214	* following cases that could happen when you add a command "foo" to a
sl@0	2215	* namespace "b":
sl@0	2216	* 1. It could shadow a command named "foo" at the global scope.
sl@0	2217	* If it does, all command references in the namespace "b" are
sl@0	2218	* suspect.
sl@0	2219	* 2. Suppose the namespace "b" resides in a namespace "a".
sl@0	2220	* Then to "a" the new command "b::foo" could shadow another
sl@0	2221	* command "b::foo" in the global namespace. If so, then all
sl@0	2222	* command references in "a" are suspect.
sl@0	2223	* The same checks are applied to all parent namespaces, until we
sl@0	2224	* reach the global :: namespace.
sl@0	2225	*
sl@0	2226	* Results:
sl@0	2227	* None.
sl@0	2228	*
sl@0	2229	* Side effects:
sl@0	2230	* If the new command shadows an existing command, the cmdRefEpoch
sl@0	2231	* counter is incremented in each namespace that sees the shadow.
sl@0	2232	* This invalidates all command references that were previously cached
sl@0	2233	* in that namespace. The next time the commands are used, they are
sl@0	2234	* resolved from scratch.
sl@0	2235	*
sl@0	2236	*----------------------------------------------------------------------
sl@0	2237	*/
sl@0	2238
sl@0	2239	void
sl@0	2240	TclResetShadowedCmdRefs(interp, newCmdPtr)
sl@0	2241	Tcl_Interp interp; / Interpreter containing the new command. */
sl@0	2242	Command newCmdPtr; / Points to the new command. */
sl@0	2243	{
sl@0	2244	char *cmdName;
sl@0	2245	Tcl_HashEntry *hPtr;
sl@0	2246	register Namespace *nsPtr;
sl@0	2247	Namespace trailNsPtr, shadowNsPtr;
sl@0	2248	Namespace globalNsPtr = (Namespace ) Tcl_GetGlobalNamespace(interp);
sl@0	2249	int found, i;
sl@0	2250
sl@0	2251	/*
sl@0	2252	* This procedure generates an array used to hold the trail list. This
sl@0	2253	* starts out with stack-allocated space but uses dynamically-allocated
sl@0	2254	* storage if needed.
sl@0	2255	*/
sl@0	2256
sl@0	2257	Namespace *(trailStorage[NUM_TRAIL_ELEMS]);
sl@0	2258	Namespace **trailPtr = trailStorage;
sl@0	2259	int trailFront = -1;
sl@0	2260	int trailSize = NUM_TRAIL_ELEMS;
sl@0	2261
sl@0	2262	/*
sl@0	2263	* Start at the namespace containing the new command, and work up
sl@0	2264	* through the list of parents. Stop just before the global namespace,
sl@0	2265	* since the global namespace can't "shadow" its own entries.
sl@0	2266	*
sl@0	2267	* The namespace "trail" list we build consists of the names of each
sl@0	2268	* namespace that encloses the new command, in order from outermost to
sl@0	2269	* innermost: for example, "a" then "b". Each iteration of this loop
sl@0	2270	* eventually extends the trail upwards by one namespace, nsPtr. We use
sl@0	2271	* this trail list to see if nsPtr (e.g. "a" in 2. above) could have
sl@0	2272	* now-invalid cached command references. This will happen if nsPtr
sl@0	2273	* (e.g. "a") contains a sequence of child namespaces (e.g. "b")
sl@0	2274	* such that there is a identically-named sequence of child namespaces
sl@0	2275	* starting from :: (e.g. "::b") whose tail namespace contains a command
sl@0	2276	* also named cmdName.
sl@0	2277	*/
sl@0	2278
sl@0	2279	cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
sl@0	2280	for (nsPtr = newCmdPtr->nsPtr;
sl@0	2281	(nsPtr != NULL) && (nsPtr != globalNsPtr);
sl@0	2282	nsPtr = nsPtr->parentPtr) {
sl@0	2283	/*
sl@0	2284	* Find the maximal sequence of child namespaces contained in nsPtr
sl@0	2285	* such that there is a identically-named sequence of child
sl@0	2286	* namespaces starting from ::. shadowNsPtr will be the tail of this
sl@0	2287	* sequence, or the deepest namespace under :: that might contain a
sl@0	2288	* command now shadowed by cmdName. We check below if shadowNsPtr
sl@0	2289	* actually contains a command cmdName.
sl@0	2290	*/
sl@0	2291
sl@0	2292	found = 1;
sl@0	2293	shadowNsPtr = globalNsPtr;
sl@0	2294
sl@0	2295	for (i = trailFront; i >= 0; i--) {
sl@0	2296	trailNsPtr = trailPtr[i];
sl@0	2297	hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable,
sl@0	2298	trailNsPtr->name);
sl@0	2299	if (hPtr != NULL) {
sl@0	2300	shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr);
sl@0	2301	} else {
sl@0	2302	found = 0;
sl@0	2303	break;
sl@0	2304	}
sl@0	2305	}
sl@0	2306
sl@0	2307	/*
sl@0	2308	* If shadowNsPtr contains a command named cmdName, we invalidate
sl@0	2309	* all of the command refs cached in nsPtr. As a boundary case,
sl@0	2310	* shadowNsPtr is initially :: and we check for case 1. above.
sl@0	2311	*/
sl@0	2312
sl@0	2313	if (found) {
sl@0	2314	hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
sl@0	2315	if (hPtr != NULL) {
sl@0	2316	nsPtr->cmdRefEpoch++;
sl@0	2317
sl@0	2318	/*
sl@0	2319	* If the shadowed command was compiled to bytecodes, we
sl@0	2320	* invalidate all the bytecodes in nsPtr, to force a new
sl@0	2321	* compilation. We use the resolverEpoch to signal the need
sl@0	2322	* for a fresh compilation of every bytecode.
sl@0	2323	*/
sl@0	2324
sl@0	2325	if ((((Command *) Tcl_GetHashValue(hPtr))->compileProc) != NULL) {
sl@0	2326	nsPtr->resolverEpoch++;
sl@0	2327	}
sl@0	2328	}
sl@0	2329	}
sl@0	2330
sl@0	2331	/*
sl@0	2332	* Insert nsPtr at the front of the trail list: i.e., at the end
sl@0	2333	* of the trailPtr array.
sl@0	2334	*/
sl@0	2335
sl@0	2336	trailFront++;
sl@0	2337	if (trailFront == trailSize) {
sl@0	2338	size_t currBytes = trailSize * sizeof(Namespace *);
sl@0	2339	int newSize = 2*trailSize;
sl@0	2340	size_t newBytes = newSize * sizeof(Namespace *);
sl@0	2341	Namespace **newPtr =
sl@0	2342	(Namespace **) ckalloc((unsigned) newBytes);
sl@0	2343
sl@0	2344	memcpy((VOID ) newPtr, (VOID ) trailPtr, currBytes);
sl@0	2345	if (trailPtr != trailStorage) {
sl@0	2346	ckfree((char *) trailPtr);
sl@0	2347	}
sl@0	2348	trailPtr = newPtr;
sl@0	2349	trailSize = newSize;
sl@0	2350	}
sl@0	2351	trailPtr[trailFront] = nsPtr;
sl@0	2352	}
sl@0	2353
sl@0	2354	/*
sl@0	2355	* Free any allocated storage.
sl@0	2356	*/
sl@0	2357
sl@0	2358	if (trailPtr != trailStorage) {
sl@0	2359	ckfree((char *) trailPtr);
sl@0	2360	}
sl@0	2361	}
sl@0	2362
sl@0	2363	/*
sl@0	2364	*----------------------------------------------------------------------
sl@0	2365	*
sl@0	2366	* GetNamespaceFromObj --
sl@0	2367	*
sl@0	2368	* Gets the namespace specified by the name in a Tcl_Obj.
sl@0	2369	*
sl@0	2370	* Results:
sl@0	2371	* Returns TCL_OK if the namespace was resolved successfully, and
sl@0	2372	* stores a pointer to the namespace in the location specified by
sl@0	2373	* nsPtrPtr. If the namespace can't be found, the procedure stores
sl@0	2374	* NULL in *nsPtrPtr and returns TCL_OK. If anything else goes wrong,
sl@0	2375	* this procedure returns TCL_ERROR.
sl@0	2376	*
sl@0	2377	* Side effects:
sl@0	2378	* May update the internal representation for the object, caching the
sl@0	2379	* namespace reference. The next time this procedure is called, the
sl@0	2380	* namespace value can be found quickly.
sl@0	2381	*
sl@0	2382	* If anything goes wrong, an error message is left in the
sl@0	2383	* interpreter's result object.
sl@0	2384	*
sl@0	2385	*----------------------------------------------------------------------
sl@0	2386	*/
sl@0	2387
sl@0	2388	static int
sl@0	2389	GetNamespaceFromObj(interp, objPtr, nsPtrPtr)
sl@0	2390	Tcl_Interp interp; / The current interpreter. */
sl@0	2391	Tcl_Obj objPtr; / The object to be resolved as the name
sl@0	2392	* of a namespace. */
sl@0	2393	Tcl_Namespace *nsPtrPtr; / Result namespace pointer goes here. */
sl@0	2394	{
sl@0	2395	Interp iPtr = (Interp ) interp;
sl@0	2396	register ResolvedNsName *resNamePtr;
sl@0	2397	register Namespace *nsPtr;
sl@0	2398	Namespace *currNsPtr;
sl@0	2399	CallFrame *savedFramePtr;
sl@0	2400	int result = TCL_OK;
sl@0	2401	char *name;
sl@0	2402
sl@0	2403	/*
sl@0	2404	* If the namespace name is fully qualified, do as if the lookup were
sl@0	2405	* done from the global namespace; this helps avoid repeated lookups
sl@0	2406	* of fully qualified names.
sl@0	2407	*/
sl@0	2408
sl@0	2409	savedFramePtr = iPtr->varFramePtr;
sl@0	2410	name = Tcl_GetString(objPtr);
sl@0	2411	if ((name++ == ':') && (name == ':')) {
sl@0	2412	iPtr->varFramePtr = NULL;
sl@0	2413	}
sl@0	2414
sl@0	2415	currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
sl@0	2416
sl@0	2417	/*
sl@0	2418	* Get the internal representation, converting to a namespace type if
sl@0	2419	* needed. The internal representation is a ResolvedNsName that points
sl@0	2420	* to the actual namespace.
sl@0	2421	*/
sl@0	2422
sl@0	2423	if (objPtr->typePtr != &tclNsNameType) {
sl@0	2424	result = tclNsNameType.setFromAnyProc(interp, objPtr);
sl@0	2425	if (result != TCL_OK) {
sl@0	2426	goto done;
sl@0	2427	}
sl@0	2428	}
sl@0	2429	resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
sl@0	2430
sl@0	2431	/*
sl@0	2432	* Check the context namespace of the resolved symbol to make sure that
sl@0	2433	* it is fresh. If not, then force another conversion to the namespace
sl@0	2434	* type, to discard the old rep and create a new one. Note that we
sl@0	2435	* verify that the namespace id of the cached namespace is the same as
sl@0	2436	* the id when we cached it; this insures that the namespace wasn't
sl@0	2437	* deleted and a new one created at the same address.
sl@0	2438	*/
sl@0	2439
sl@0	2440	nsPtr = NULL;
sl@0	2441	if ((resNamePtr != NULL)
sl@0	2442	&& (resNamePtr->refNsPtr == currNsPtr)
sl@0	2443	&& (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) {
sl@0	2444	nsPtr = resNamePtr->nsPtr;
sl@0	2445	if (nsPtr->flags & NS_DEAD) {
sl@0	2446	nsPtr = NULL;
sl@0	2447	}
sl@0	2448	}
sl@0	2449	if (nsPtr == NULL) { /* try again */
sl@0	2450	result = tclNsNameType.setFromAnyProc(interp, objPtr);
sl@0	2451	if (result != TCL_OK) {
sl@0	2452	goto done;
sl@0	2453	}
sl@0	2454	resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
sl@0	2455	if (resNamePtr != NULL) {
sl@0	2456	nsPtr = resNamePtr->nsPtr;
sl@0	2457	if (nsPtr->flags & NS_DEAD) {
sl@0	2458	nsPtr = NULL;
sl@0	2459	}
sl@0	2460	}
sl@0	2461	}
sl@0	2462	nsPtrPtr = (Tcl_Namespace ) nsPtr;
sl@0	2463
sl@0	2464	done:
sl@0	2465	iPtr->varFramePtr = savedFramePtr;
sl@0	2466	return result;
sl@0	2467	}
sl@0	2468
sl@0	2469	/*
sl@0	2470	*----------------------------------------------------------------------
sl@0	2471	*
sl@0	2472	* Tcl_NamespaceObjCmd --
sl@0	2473	*
sl@0	2474	* Invoked to implement the "namespace" command that creates, deletes,
sl@0	2475	* or manipulates Tcl namespaces. Handles the following syntax:
sl@0	2476	*
sl@0	2477	* namespace children ?name? ?pattern?
sl@0	2478	* namespace code arg
sl@0	2479	* namespace current
sl@0	2480	* namespace delete ?name name...?
sl@0	2481	* namespace eval name arg ?arg...?
sl@0	2482	* namespace exists name
sl@0	2483	* namespace export ?-clear? ?pattern pattern...?
sl@0	2484	* namespace forget ?pattern pattern...?
sl@0	2485	* namespace import ?-force? ?pattern pattern...?
sl@0	2486	* namespace inscope name arg ?arg...?
sl@0	2487	* namespace origin name
sl@0	2488	* namespace parent ?name?
sl@0	2489	* namespace qualifiers string
sl@0	2490	* namespace tail string
sl@0	2491	* namespace which ?-command? ?-variable? name
sl@0	2492	*
sl@0	2493	* Results:
sl@0	2494	* Returns TCL_OK if the command is successful. Returns TCL_ERROR if
sl@0	2495	* anything goes wrong.
sl@0	2496	*
sl@0	2497	* Side effects:
sl@0	2498	* Based on the subcommand name (e.g., "import"), this procedure
sl@0	2499	* dispatches to a corresponding procedure NamespaceXXXCmd defined
sl@0	2500	* statically in this file. This procedure's side effects depend on
sl@0	2501	* whatever that subcommand procedure does. If there is an error, this
sl@0	2502	* procedure returns an error message in the interpreter's result
sl@0	2503	* object. Otherwise it may return a result in the interpreter's result
sl@0	2504	* object.
sl@0	2505	*
sl@0	2506	*----------------------------------------------------------------------
sl@0	2507	*/
sl@0	2508
sl@0	2509	int
sl@0	2510	Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
sl@0	2511	ClientData clientData; /* Arbitrary value passed to cmd. */
sl@0	2512	Tcl_Interp interp; / Current interpreter. */
sl@0	2513	register int objc; /* Number of arguments. */
sl@0	2514	register Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2515	{
sl@0	2516	static CONST char *subCmds[] = {
sl@0	2517	"children", "code", "current", "delete",
sl@0	2518	"eval", "exists", "export", "forget", "import",
sl@0	2519	"inscope", "origin", "parent", "qualifiers",
sl@0	2520	"tail", "which", (char *) NULL
sl@0	2521	};
sl@0	2522	enum NSSubCmdIdx {
sl@0	2523	NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx,
sl@0	2524	NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
sl@0	2525	NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx,
sl@0	2526	NSTailIdx, NSWhichIdx
sl@0	2527	};
sl@0	2528	int index, result;
sl@0	2529
sl@0	2530	if (objc < 2) {
sl@0	2531	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
sl@0	2532	return TCL_ERROR;
sl@0	2533	}
sl@0	2534
sl@0	2535	/*
sl@0	2536	* Return an index reflecting the particular subcommand.
sl@0	2537	*/
sl@0	2538
sl@0	2539	result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds,
sl@0	2540	"option", /flags/ 0, (int *) &index);
sl@0	2541	if (result != TCL_OK) {
sl@0	2542	return result;
sl@0	2543	}
sl@0	2544
sl@0	2545	switch (index) {
sl@0	2546	case NSChildrenIdx:
sl@0	2547	result = NamespaceChildrenCmd(clientData, interp, objc, objv);
sl@0	2548	break;
sl@0	2549	case NSCodeIdx:
sl@0	2550	result = NamespaceCodeCmd(clientData, interp, objc, objv);
sl@0	2551	break;
sl@0	2552	case NSCurrentIdx:
sl@0	2553	result = NamespaceCurrentCmd(clientData, interp, objc, objv);
sl@0	2554	break;
sl@0	2555	case NSDeleteIdx:
sl@0	2556	result = NamespaceDeleteCmd(clientData, interp, objc, objv);
sl@0	2557	break;
sl@0	2558	case NSEvalIdx:
sl@0	2559	result = NamespaceEvalCmd(clientData, interp, objc, objv);
sl@0	2560	break;
sl@0	2561	case NSExistsIdx:
sl@0	2562	result = NamespaceExistsCmd(clientData, interp, objc, objv);
sl@0	2563	break;
sl@0	2564	case NSExportIdx:
sl@0	2565	result = NamespaceExportCmd(clientData, interp, objc, objv);
sl@0	2566	break;
sl@0	2567	case NSForgetIdx:
sl@0	2568	result = NamespaceForgetCmd(clientData, interp, objc, objv);
sl@0	2569	break;
sl@0	2570	case NSImportIdx:
sl@0	2571	result = NamespaceImportCmd(clientData, interp, objc, objv);
sl@0	2572	break;
sl@0	2573	case NSInscopeIdx:
sl@0	2574	result = NamespaceInscopeCmd(clientData, interp, objc, objv);
sl@0	2575	break;
sl@0	2576	case NSOriginIdx:
sl@0	2577	result = NamespaceOriginCmd(clientData, interp, objc, objv);
sl@0	2578	break;
sl@0	2579	case NSParentIdx:
sl@0	2580	result = NamespaceParentCmd(clientData, interp, objc, objv);
sl@0	2581	break;
sl@0	2582	case NSQualifiersIdx:
sl@0	2583	result = NamespaceQualifiersCmd(clientData, interp, objc, objv);
sl@0	2584	break;
sl@0	2585	case NSTailIdx:
sl@0	2586	result = NamespaceTailCmd(clientData, interp, objc, objv);
sl@0	2587	break;
sl@0	2588	case NSWhichIdx:
sl@0	2589	result = NamespaceWhichCmd(clientData, interp, objc, objv);
sl@0	2590	break;
sl@0	2591	}
sl@0	2592	return result;
sl@0	2593	}
sl@0	2594
sl@0	2595	/*
sl@0	2596	*----------------------------------------------------------------------
sl@0	2597	*
sl@0	2598	* NamespaceChildrenCmd --
sl@0	2599	*
sl@0	2600	* Invoked to implement the "namespace children" command that returns a
sl@0	2601	* list containing the fully-qualified names of the child namespaces of
sl@0	2602	* a given namespace. Handles the following syntax:
sl@0	2603	*
sl@0	2604	* namespace children ?name? ?pattern?
sl@0	2605	*
sl@0	2606	* Results:
sl@0	2607	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	2608	*
sl@0	2609	* Side effects:
sl@0	2610	* Returns a result in the interpreter's result object. If anything
sl@0	2611	* goes wrong, the result is an error message.
sl@0	2612	*
sl@0	2613	*----------------------------------------------------------------------
sl@0	2614	*/
sl@0	2615
sl@0	2616	static int
sl@0	2617	NamespaceChildrenCmd(dummy, interp, objc, objv)
sl@0	2618	ClientData dummy; /* Not used. */
sl@0	2619	Tcl_Interp interp; / Current interpreter. */
sl@0	2620	int objc; /* Number of arguments. */
sl@0	2621	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2622	{
sl@0	2623	Tcl_Namespace *namespacePtr;
sl@0	2624	Namespace nsPtr, childNsPtr;
sl@0	2625	Namespace globalNsPtr = (Namespace ) Tcl_GetGlobalNamespace(interp);
sl@0	2626	char *pattern = NULL;
sl@0	2627	Tcl_DString buffer;
sl@0	2628	register Tcl_HashEntry *entryPtr;
sl@0	2629	Tcl_HashSearch search;
sl@0	2630	Tcl_Obj listPtr, elemPtr;
sl@0	2631
sl@0	2632	/*
sl@0	2633	* Get a pointer to the specified namespace, or the current namespace.
sl@0	2634	*/
sl@0	2635
sl@0	2636	if (objc == 2) {
sl@0	2637	nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
sl@0	2638	} else if ((objc == 3) \|\| (objc == 4)) {
sl@0	2639	if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
sl@0	2640	return TCL_ERROR;
sl@0	2641	}
sl@0	2642	if (namespacePtr == NULL) {
sl@0	2643	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	2644	"unknown namespace \"", Tcl_GetString(objv[2]),
sl@0	2645	"\" in namespace children command", (char *) NULL);
sl@0	2646	return TCL_ERROR;
sl@0	2647	}
sl@0	2648	nsPtr = (Namespace *) namespacePtr;
sl@0	2649	} else {
sl@0	2650	Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?");
sl@0	2651	return TCL_ERROR;
sl@0	2652	}
sl@0	2653
sl@0	2654	/*
sl@0	2655	* Get the glob-style pattern, if any, used to narrow the search.
sl@0	2656	*/
sl@0	2657
sl@0	2658	Tcl_DStringInit(&buffer);
sl@0	2659	if (objc == 4) {
sl@0	2660	char *name = Tcl_GetString(objv[3]);
sl@0	2661
sl@0	2662	if ((name == ':') && ((name+1) == ':')) {
sl@0	2663	pattern = name;
sl@0	2664	} else {
sl@0	2665	Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
sl@0	2666	if (nsPtr != globalNsPtr) {
sl@0	2667	Tcl_DStringAppend(&buffer, "::", 2);
sl@0	2668	}
sl@0	2669	Tcl_DStringAppend(&buffer, name, -1);
sl@0	2670	pattern = Tcl_DStringValue(&buffer);
sl@0	2671	}
sl@0	2672	}
sl@0	2673
sl@0	2674	/*
sl@0	2675	* Create a list containing the full names of all child namespaces
sl@0	2676	* whose names match the specified pattern, if any.
sl@0	2677	*/
sl@0	2678
sl@0	2679	listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	2680	entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
sl@0	2681	while (entryPtr != NULL) {
sl@0	2682	childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
sl@0	2683	if ((pattern == NULL)
sl@0	2684	\|\| Tcl_StringMatch(childNsPtr->fullName, pattern)) {
sl@0	2685	elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
sl@0	2686	Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
sl@0	2687	}
sl@0	2688	entryPtr = Tcl_NextHashEntry(&search);
sl@0	2689	}
sl@0	2690
sl@0	2691	Tcl_SetObjResult(interp, listPtr);
sl@0	2692	Tcl_DStringFree(&buffer);
sl@0	2693	return TCL_OK;
sl@0	2694	}
sl@0	2695
sl@0	2696	/*
sl@0	2697	*----------------------------------------------------------------------
sl@0	2698	*
sl@0	2699	* NamespaceCodeCmd --
sl@0	2700	*
sl@0	2701	* Invoked to implement the "namespace code" command to capture the
sl@0	2702	* namespace context of a command. Handles the following syntax:
sl@0	2703	*
sl@0	2704	* namespace code arg
sl@0	2705	*
sl@0	2706	* Here "arg" can be a list. "namespace code arg" produces a result
sl@0	2707	* equivalent to that produced by the command
sl@0	2708	*
sl@0	2709	* list ::namespace inscope [namespace current] $arg
sl@0	2710	*
sl@0	2711	* However, if "arg" is itself a scoped value starting with
sl@0	2712	* "::namespace inscope", then the result is just "arg".
sl@0	2713	*
sl@0	2714	* Results:
sl@0	2715	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	2716	*
sl@0	2717	* Side effects:
sl@0	2718	* If anything goes wrong, this procedure returns an error
sl@0	2719	* message as the result in the interpreter's result object.
sl@0	2720	*
sl@0	2721	*----------------------------------------------------------------------
sl@0	2722	*/
sl@0	2723
sl@0	2724	static int
sl@0	2725	NamespaceCodeCmd(dummy, interp, objc, objv)
sl@0	2726	ClientData dummy; /* Not used. */
sl@0	2727	Tcl_Interp interp; / Current interpreter. */
sl@0	2728	int objc; /* Number of arguments. */
sl@0	2729	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2730	{
sl@0	2731	Namespace *currNsPtr;
sl@0	2732	Tcl_Obj listPtr, objPtr;
sl@0	2733	register char arg, p;
sl@0	2734	int length;
sl@0	2735
sl@0	2736	if (objc != 3) {
sl@0	2737	Tcl_WrongNumArgs(interp, 2, objv, "arg");
sl@0	2738	return TCL_ERROR;
sl@0	2739	}
sl@0	2740
sl@0	2741	/*
sl@0	2742	* If "arg" is already a scoped value, then return it directly.
sl@0	2743	*/
sl@0	2744
sl@0	2745	arg = Tcl_GetStringFromObj(objv[2], &length);
sl@0	2746	while (*arg == ':') {
sl@0	2747	arg++;
sl@0	2748	length--;
sl@0	2749	}
sl@0	2750	if ((*arg == 'n') && (length > 17)
sl@0	2751	&& (strncmp(arg, "namespace", 9) == 0)) {
sl@0	2752	for (p = (arg + 9); (*p == ' '); p++) {
sl@0	2753	/* empty body: skip over spaces */
sl@0	2754	}
sl@0	2755	if ((*p == 'i') && ((p + 7) <= (arg + length))
sl@0	2756	&& (strncmp(p, "inscope", 7) == 0)) {
sl@0	2757	Tcl_SetObjResult(interp, objv[2]);
sl@0	2758	return TCL_OK;
sl@0	2759	}
sl@0	2760	}
sl@0	2761
sl@0	2762	/*
sl@0	2763	* Otherwise, construct a scoped command by building a list with
sl@0	2764	* "namespace inscope", the full name of the current namespace, and
sl@0	2765	* the argument "arg". By constructing a list, we ensure that scoped
sl@0	2766	* commands are interpreted properly when they are executed later,
sl@0	2767	* by the "namespace inscope" command.
sl@0	2768	*/
sl@0	2769
sl@0	2770	listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	2771	Tcl_ListObjAppendElement(interp, listPtr,
sl@0	2772	Tcl_NewStringObj("::namespace", -1));
sl@0	2773	Tcl_ListObjAppendElement(interp, listPtr,
sl@0	2774	Tcl_NewStringObj("inscope", -1));
sl@0	2775
sl@0	2776	currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
sl@0	2777	if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) {
sl@0	2778	objPtr = Tcl_NewStringObj("::", -1);
sl@0	2779	} else {
sl@0	2780	objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1);
sl@0	2781	}
sl@0	2782	Tcl_ListObjAppendElement(interp, listPtr, objPtr);
sl@0	2783
sl@0	2784	Tcl_ListObjAppendElement(interp, listPtr, objv[2]);
sl@0	2785
sl@0	2786	Tcl_SetObjResult(interp, listPtr);
sl@0	2787	return TCL_OK;
sl@0	2788	}
sl@0	2789
sl@0	2790	/*
sl@0	2791	*----------------------------------------------------------------------
sl@0	2792	*
sl@0	2793	* NamespaceCurrentCmd --
sl@0	2794	*
sl@0	2795	* Invoked to implement the "namespace current" command which returns
sl@0	2796	* the fully-qualified name of the current namespace. Handles the
sl@0	2797	* following syntax:
sl@0	2798	*
sl@0	2799	* namespace current
sl@0	2800	*
sl@0	2801	* Results:
sl@0	2802	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	2803	*
sl@0	2804	* Side effects:
sl@0	2805	* Returns a result in the interpreter's result object. If anything
sl@0	2806	* goes wrong, the result is an error message.
sl@0	2807	*
sl@0	2808	*----------------------------------------------------------------------
sl@0	2809	*/
sl@0	2810
sl@0	2811	static int
sl@0	2812	NamespaceCurrentCmd(dummy, interp, objc, objv)
sl@0	2813	ClientData dummy; /* Not used. */
sl@0	2814	Tcl_Interp interp; / Current interpreter. */
sl@0	2815	int objc; /* Number of arguments. */
sl@0	2816	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2817	{
sl@0	2818	register Namespace *currNsPtr;
sl@0	2819
sl@0	2820	if (objc != 2) {
sl@0	2821	Tcl_WrongNumArgs(interp, 2, objv, NULL);
sl@0	2822	return TCL_ERROR;
sl@0	2823	}
sl@0	2824
sl@0	2825	/*
sl@0	2826	* The "real" name of the global namespace ("::") is the null string,
sl@0	2827	* but we return "::" for it as a convenience to programmers. Note that
sl@0	2828	* "" and "::" are treated as synonyms by the namespace code so that it
sl@0	2829	* is still easy to do things like:
sl@0	2830	*
sl@0	2831	* namespace [namespace current]::bar { ... }
sl@0	2832	*/
sl@0	2833
sl@0	2834	currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
sl@0	2835	if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) {
sl@0	2836	Tcl_AppendToObj(Tcl_GetObjResult(interp), "::", -1);
sl@0	2837	} else {
sl@0	2838	Tcl_AppendToObj(Tcl_GetObjResult(interp), currNsPtr->fullName, -1);
sl@0	2839	}
sl@0	2840	return TCL_OK;
sl@0	2841	}
sl@0	2842
sl@0	2843	/*
sl@0	2844	*----------------------------------------------------------------------
sl@0	2845	*
sl@0	2846	* NamespaceDeleteCmd --
sl@0	2847	*
sl@0	2848	* Invoked to implement the "namespace delete" command to delete
sl@0	2849	* namespace(s). Handles the following syntax:
sl@0	2850	*
sl@0	2851	* namespace delete ?name name...?
sl@0	2852	*
sl@0	2853	* Each name identifies a namespace. It may include a sequence of
sl@0	2854	* namespace qualifiers separated by "::"s. If a namespace is found, it
sl@0	2855	* is deleted: all variables and procedures contained in that namespace
sl@0	2856	* are deleted. If that namespace is being used on the call stack, it
sl@0	2857	* is kept alive (but logically deleted) until it is removed from the
sl@0	2858	* call stack: that is, it can no longer be referenced by name but any
sl@0	2859	* currently executing procedure that refers to it is allowed to do so
sl@0	2860	* until the procedure returns. If the namespace can't be found, this
sl@0	2861	* procedure returns an error. If no namespaces are specified, this
sl@0	2862	* command does nothing.
sl@0	2863	*
sl@0	2864	* Results:
sl@0	2865	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	2866	*
sl@0	2867	* Side effects:
sl@0	2868	* Deletes the specified namespaces. If anything goes wrong, this
sl@0	2869	* procedure returns an error message in the interpreter's
sl@0	2870	* result object.
sl@0	2871	*
sl@0	2872	*----------------------------------------------------------------------
sl@0	2873	*/
sl@0	2874
sl@0	2875	static int
sl@0	2876	NamespaceDeleteCmd(dummy, interp, objc, objv)
sl@0	2877	ClientData dummy; /* Not used. */
sl@0	2878	Tcl_Interp interp; / Current interpreter. */
sl@0	2879	int objc; /* Number of arguments. */
sl@0	2880	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2881	{
sl@0	2882	Tcl_Namespace *namespacePtr;
sl@0	2883	char *name;
sl@0	2884	register int i;
sl@0	2885
sl@0	2886	if (objc < 2) {
sl@0	2887	Tcl_WrongNumArgs(interp, 2, objv, "?name name...?");
sl@0	2888	return TCL_ERROR;
sl@0	2889	}
sl@0	2890
sl@0	2891	/*
sl@0	2892	* Destroying one namespace may cause another to be destroyed. Break
sl@0	2893	* this into two passes: first check to make sure that all namespaces on
sl@0	2894	* the command line are valid, and report any errors.
sl@0	2895	*/
sl@0	2896
sl@0	2897	for (i = 2; i < objc; i++) {
sl@0	2898	name = Tcl_GetString(objv[i]);
sl@0	2899	namespacePtr = Tcl_FindNamespace(interp, name,
sl@0	2900	(Tcl_Namespace ) NULL, /flags*/ 0);
sl@0	2901	if (namespacePtr == NULL) {
sl@0	2902	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	2903	"unknown namespace \"", Tcl_GetString(objv[i]),
sl@0	2904	"\" in namespace delete command", (char *) NULL);
sl@0	2905	return TCL_ERROR;
sl@0	2906	}
sl@0	2907	}
sl@0	2908
sl@0	2909	/*
sl@0	2910	* Okay, now delete each namespace.
sl@0	2911	*/
sl@0	2912
sl@0	2913	for (i = 2; i < objc; i++) {
sl@0	2914	name = Tcl_GetString(objv[i]);
sl@0	2915	namespacePtr = Tcl_FindNamespace(interp, name,
sl@0	2916	(Tcl_Namespace ) NULL, / flags */ 0);
sl@0	2917	if (namespacePtr) {
sl@0	2918	Tcl_DeleteNamespace(namespacePtr);
sl@0	2919	}
sl@0	2920	}
sl@0	2921	return TCL_OK;
sl@0	2922	}
sl@0	2923
sl@0	2924	/*
sl@0	2925	*----------------------------------------------------------------------
sl@0	2926	*
sl@0	2927	* NamespaceEvalCmd --
sl@0	2928	*
sl@0	2929	* Invoked to implement the "namespace eval" command. Executes
sl@0	2930	* commands in a namespace. If the namespace does not already exist,
sl@0	2931	* it is created. Handles the following syntax:
sl@0	2932	*
sl@0	2933	* namespace eval name arg ?arg...?
sl@0	2934	*
sl@0	2935	* If more than one arg argument is specified, the command that is
sl@0	2936	* executed is the result of concatenating the arguments together with
sl@0	2937	* a space between each argument.
sl@0	2938	*
sl@0	2939	* Results:
sl@0	2940	* Returns TCL_OK if the namespace is found and the commands are
sl@0	2941	* executed successfully. Returns TCL_ERROR if anything goes wrong.
sl@0	2942	*
sl@0	2943	* Side effects:
sl@0	2944	* Returns the result of the command in the interpreter's result
sl@0	2945	* object. If anything goes wrong, this procedure returns an error
sl@0	2946	* message as the result.
sl@0	2947	*
sl@0	2948	*----------------------------------------------------------------------
sl@0	2949	*/
sl@0	2950
sl@0	2951	static int
sl@0	2952	NamespaceEvalCmd(dummy, interp, objc, objv)
sl@0	2953	ClientData dummy; /* Not used. */
sl@0	2954	Tcl_Interp interp; / Current interpreter. */
sl@0	2955	int objc; /* Number of arguments. */
sl@0	2956	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2957	{
sl@0	2958	Tcl_Namespace *namespacePtr;
sl@0	2959	CallFrame frame;
sl@0	2960	Tcl_Obj *objPtr;
sl@0	2961	char *name;
sl@0	2962	int length, result;
sl@0	2963
sl@0	2964	if (objc < 4) {
sl@0	2965	Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
sl@0	2966	return TCL_ERROR;
sl@0	2967	}
sl@0	2968
sl@0	2969	/*
sl@0	2970	* Try to resolve the namespace reference, caching the result in the
sl@0	2971	* namespace object along the way.
sl@0	2972	*/
sl@0	2973
sl@0	2974	result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
sl@0	2975	if (result != TCL_OK) {
sl@0	2976	return result;
sl@0	2977	}
sl@0	2978
sl@0	2979	/*
sl@0	2980	* If the namespace wasn't found, try to create it.
sl@0	2981	*/
sl@0	2982
sl@0	2983	if (namespacePtr == NULL) {
sl@0	2984	name = Tcl_GetStringFromObj(objv[2], &length);
sl@0	2985	namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL,
sl@0	2986	(Tcl_NamespaceDeleteProc *) NULL);
sl@0	2987	if (namespacePtr == NULL) {
sl@0	2988	return TCL_ERROR;
sl@0	2989	}
sl@0	2990	}
sl@0	2991
sl@0	2992	/*
sl@0	2993	* Make the specified namespace the current namespace and evaluate
sl@0	2994	* the command(s).
sl@0	2995	*/
sl@0	2996
sl@0	2997	result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame,
sl@0	2998	namespacePtr, /isProcCallFrame/ 0);
sl@0	2999	if (result != TCL_OK) {
sl@0	3000	return TCL_ERROR;
sl@0	3001	}
sl@0	3002	frame.objc = objc;
sl@0	3003	frame.objv = objv; /* ref counts do not need to be incremented here */
sl@0	3004
sl@0	3005	if (objc == 4) {
sl@0	3006	#ifndef TCL_TIP280
sl@0	3007	result = Tcl_EvalObjEx(interp, objv[3], 0);
sl@0	3008	#else
sl@0	3009	/* TIP #280 : Make invoker available to eval'd script */
sl@0	3010	Interp* iPtr = (Interp*) interp;
sl@0	3011	result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3);
sl@0	3012	#endif
sl@0	3013	} else {
sl@0	3014	/*
sl@0	3015	* More than one argument: concatenate them together with spaces
sl@0	3016	* between, then evaluate the result. Tcl_EvalObjEx will delete
sl@0	3017	* the object when it decrements its refcount after eval'ing it.
sl@0	3018	*/
sl@0	3019	objPtr = Tcl_ConcatObj(objc-3, objv+3);
sl@0	3020	#ifndef TCL_TIP280
sl@0	3021	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
sl@0	3022	#else
sl@0	3023	/* TIP #280. Make invoking context available to eval'd script */
sl@0	3024	result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
sl@0	3025	#endif
sl@0	3026	}
sl@0	3027	if (result == TCL_ERROR) {
sl@0	3028	char msg[256 + TCL_INTEGER_SPACE];
sl@0	3029
sl@0	3030	sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)",
sl@0	3031	namespacePtr->fullName, interp->errorLine);
sl@0	3032	Tcl_AddObjErrorInfo(interp, msg, -1);
sl@0	3033	}
sl@0	3034
sl@0	3035	/*
sl@0	3036	* Restore the previous "current" namespace.
sl@0	3037	*/
sl@0	3038
sl@0	3039	Tcl_PopCallFrame(interp);
sl@0	3040	return result;
sl@0	3041	}
sl@0	3042
sl@0	3043	/*
sl@0	3044	*----------------------------------------------------------------------
sl@0	3045	*
sl@0	3046	* NamespaceExistsCmd --
sl@0	3047	*
sl@0	3048	* Invoked to implement the "namespace exists" command that returns
sl@0	3049	* true if the given namespace currently exists, and false otherwise.
sl@0	3050	* Handles the following syntax:
sl@0	3051	*
sl@0	3052	* namespace exists name
sl@0	3053	*
sl@0	3054	* Results:
sl@0	3055	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	3056	*
sl@0	3057	* Side effects:
sl@0	3058	* Returns a result in the interpreter's result object. If anything
sl@0	3059	* goes wrong, the result is an error message.
sl@0	3060	*
sl@0	3061	*----------------------------------------------------------------------
sl@0	3062	*/
sl@0	3063
sl@0	3064	static int
sl@0	3065	NamespaceExistsCmd(dummy, interp, objc, objv)
sl@0	3066	ClientData dummy; /* Not used. */
sl@0	3067	Tcl_Interp interp; / Current interpreter. */
sl@0	3068	int objc; /* Number of arguments. */
sl@0	3069	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3070	{
sl@0	3071	Tcl_Namespace *namespacePtr;
sl@0	3072
sl@0	3073	if (objc != 3) {
sl@0	3074	Tcl_WrongNumArgs(interp, 2, objv, "name");
sl@0	3075	return TCL_ERROR;
sl@0	3076	}
sl@0	3077
sl@0	3078	/*
sl@0	3079	* Check whether the given namespace exists
sl@0	3080	*/
sl@0	3081
sl@0	3082	if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
sl@0	3083	return TCL_ERROR;
sl@0	3084	}
sl@0	3085
sl@0	3086	Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (namespacePtr != NULL));
sl@0	3087	return TCL_OK;
sl@0	3088	}
sl@0	3089
sl@0	3090	/*
sl@0	3091	*----------------------------------------------------------------------
sl@0	3092	*
sl@0	3093	* NamespaceExportCmd --
sl@0	3094	*
sl@0	3095	* Invoked to implement the "namespace export" command that specifies
sl@0	3096	* which commands are exported from a namespace. The exported commands
sl@0	3097	* are those that can be imported into another namespace using
sl@0	3098	* "namespace import". Both commands defined in a namespace and
sl@0	3099	* commands the namespace has imported can be exported by a
sl@0	3100	* namespace. This command has the following syntax:
sl@0	3101	*
sl@0	3102	* namespace export ?-clear? ?pattern pattern...?
sl@0	3103	*
sl@0	3104	* Each pattern may contain "string match"-style pattern matching
sl@0	3105	* special characters, but the pattern may not include any namespace
sl@0	3106	* qualifiers: that is, the pattern must specify commands in the
sl@0	3107	* current (exporting) namespace. The specified patterns are appended
sl@0	3108	* onto the namespace's list of export patterns.
sl@0	3109	*
sl@0	3110	* To reset the namespace's export pattern list, specify the "-clear"
sl@0	3111	* flag.
sl@0	3112	*
sl@0	3113	* If there are no export patterns and the "-clear" flag isn't given,
sl@0	3114	* this command returns the namespace's current export list.
sl@0	3115	*
sl@0	3116	* Results:
sl@0	3117	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	3118	*
sl@0	3119	* Side effects:
sl@0	3120	* Returns a result in the interpreter's result object. If anything
sl@0	3121	* goes wrong, the result is an error message.
sl@0	3122	*
sl@0	3123	*----------------------------------------------------------------------
sl@0	3124	*/
sl@0	3125
sl@0	3126	static int
sl@0	3127	NamespaceExportCmd(dummy, interp, objc, objv)
sl@0	3128	ClientData dummy; /* Not used. */
sl@0	3129	Tcl_Interp interp; / Current interpreter. */
sl@0	3130	int objc; /* Number of arguments. */
sl@0	3131	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3132	{
sl@0	3133	Namespace currNsPtr = (Namespace) Tcl_GetCurrentNamespace(interp);
sl@0	3134	char pattern, string;
sl@0	3135	int resetListFirst = 0;
sl@0	3136	int firstArg, patternCt, i, result;
sl@0	3137
sl@0	3138	if (objc < 2) {
sl@0	3139	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	3140	"?-clear? ?pattern pattern...?");
sl@0	3141	return TCL_ERROR;
sl@0	3142	}
sl@0	3143
sl@0	3144	/*
sl@0	3145	* Process the optional "-clear" argument.
sl@0	3146	*/
sl@0	3147
sl@0	3148	firstArg = 2;
sl@0	3149	if (firstArg < objc) {
sl@0	3150	string = Tcl_GetString(objv[firstArg]);
sl@0	3151	if (strcmp(string, "-clear") == 0) {
sl@0	3152	resetListFirst = 1;
sl@0	3153	firstArg++;
sl@0	3154	}
sl@0	3155	}
sl@0	3156
sl@0	3157	/*
sl@0	3158	* If no pattern arguments are given, and "-clear" isn't specified,
sl@0	3159	* return the namespace's current export pattern list.
sl@0	3160	*/
sl@0	3161
sl@0	3162	patternCt = (objc - firstArg);
sl@0	3163	if (patternCt == 0) {
sl@0	3164	if (firstArg > 2) {
sl@0	3165	return TCL_OK;
sl@0	3166	} else { /* create list with export patterns */
sl@0	3167	Tcl_Obj listPtr = Tcl_NewListObj(0, (Tcl_Obj *) NULL);
sl@0	3168	result = Tcl_AppendExportList(interp,
sl@0	3169	(Tcl_Namespace *) currNsPtr, listPtr);
sl@0	3170	if (result != TCL_OK) {
sl@0	3171	return result;
sl@0	3172	}
sl@0	3173	Tcl_SetObjResult(interp, listPtr);
sl@0	3174	return TCL_OK;
sl@0	3175	}
sl@0	3176	}
sl@0	3177
sl@0	3178	/*
sl@0	3179	* Add each pattern to the namespace's export pattern list.
sl@0	3180	*/
sl@0	3181
sl@0	3182	for (i = firstArg; i < objc; i++) {
sl@0	3183	pattern = Tcl_GetString(objv[i]);
sl@0	3184	result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern,
sl@0	3185	((i == firstArg)? resetListFirst : 0));
sl@0	3186	if (result != TCL_OK) {
sl@0	3187	return result;
sl@0	3188	}
sl@0	3189	}
sl@0	3190	return TCL_OK;
sl@0	3191	}
sl@0	3192
sl@0	3193	/*
sl@0	3194	*----------------------------------------------------------------------
sl@0	3195	*
sl@0	3196	* NamespaceForgetCmd --
sl@0	3197	*
sl@0	3198	* Invoked to implement the "namespace forget" command to remove
sl@0	3199	* imported commands from a namespace. Handles the following syntax:
sl@0	3200	*
sl@0	3201	* namespace forget ?pattern pattern...?
sl@0	3202	*
sl@0	3203	* Each pattern is a name like "foo::" or "a::b::x". That is, the
sl@0	3204	* pattern may include the special pattern matching characters
sl@0	3205	* recognized by the "string match" command, but only in the command
sl@0	3206	* name at the end of the qualified name; the special pattern
sl@0	3207	* characters may not appear in a namespace name. All of the commands
sl@0	3208	* that match that pattern are checked to see if they have an imported
sl@0	3209	* command in the current namespace that refers to the matched
sl@0	3210	* command. If there is an alias, it is removed.
sl@0	3211	*
sl@0	3212	* Results:
sl@0	3213	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	3214	*
sl@0	3215	* Side effects:
sl@0	3216	* Imported commands are removed from the current namespace. If
sl@0	3217	* anything goes wrong, this procedure returns an error message in the
sl@0	3218	* interpreter's result object.
sl@0	3219	*
sl@0	3220	*----------------------------------------------------------------------
sl@0	3221	*/
sl@0	3222
sl@0	3223	static int
sl@0	3224	NamespaceForgetCmd(dummy, interp, objc, objv)
sl@0	3225	ClientData dummy; /* Not used. */
sl@0	3226	Tcl_Interp interp; / Current interpreter. */
sl@0	3227	int objc; /* Number of arguments. */
sl@0	3228	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3229	{
sl@0	3230	char *pattern;
sl@0	3231	register int i, result;
sl@0	3232
sl@0	3233	if (objc < 2) {
sl@0	3234	Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?");
sl@0	3235	return TCL_ERROR;
sl@0	3236	}
sl@0	3237
sl@0	3238	for (i = 2; i < objc; i++) {
sl@0	3239	pattern = Tcl_GetString(objv[i]);
sl@0	3240	result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern);
sl@0	3241	if (result != TCL_OK) {
sl@0	3242	return result;
sl@0	3243	}
sl@0	3244	}
sl@0	3245	return TCL_OK;
sl@0	3246	}
sl@0	3247
sl@0	3248	/*
sl@0	3249	*----------------------------------------------------------------------
sl@0	3250	*
sl@0	3251	* NamespaceImportCmd --
sl@0	3252	*
sl@0	3253	* Invoked to implement the "namespace import" command that imports
sl@0	3254	* commands into a namespace. Handles the following syntax:
sl@0	3255	*
sl@0	3256	* namespace import ?-force? ?pattern pattern...?
sl@0	3257	*
sl@0	3258	* Each pattern is a namespace-qualified name like "foo::*",
sl@0	3259	* "a::b::x*", or "bar::p". That is, the pattern may include the
sl@0	3260	* special pattern matching characters recognized by the "string match"
sl@0	3261	* command, but only in the command name at the end of the qualified
sl@0	3262	* name; the special pattern characters may not appear in a namespace
sl@0	3263	* name. All of the commands that match the pattern and which are
sl@0	3264	* exported from their namespace are made accessible from the current
sl@0	3265	* namespace context. This is done by creating a new "imported command"
sl@0	3266	* in the current namespace that points to the real command in its
sl@0	3267	* original namespace; when the imported command is called, it invokes
sl@0	3268	* the real command.
sl@0	3269	*
sl@0	3270	* If an imported command conflicts with an existing command, it is
sl@0	3271	* treated as an error. But if the "-force" option is included, then
sl@0	3272	* existing commands are overwritten by the imported commands.
sl@0	3273	*
sl@0	3274	* Results:
sl@0	3275	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	3276	*
sl@0	3277	* Side effects:
sl@0	3278	* Adds imported commands to the current namespace. If anything goes
sl@0	3279	* wrong, this procedure returns an error message in the interpreter's
sl@0	3280	* result object.
sl@0	3281	*
sl@0	3282	*----------------------------------------------------------------------
sl@0	3283	*/
sl@0	3284
sl@0	3285	static int
sl@0	3286	NamespaceImportCmd(dummy, interp, objc, objv)
sl@0	3287	ClientData dummy; /* Not used. */
sl@0	3288	Tcl_Interp interp; / Current interpreter. */
sl@0	3289	int objc; /* Number of arguments. */
sl@0	3290	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3291	{
sl@0	3292	int allowOverwrite = 0;
sl@0	3293	char string, pattern;
sl@0	3294	register int i, result;
sl@0	3295	int firstArg;
sl@0	3296
sl@0	3297	if (objc < 2) {
sl@0	3298	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	3299	"?-force? ?pattern pattern...?");
sl@0	3300	return TCL_ERROR;
sl@0	3301	}
sl@0	3302
sl@0	3303	/*
sl@0	3304	* Skip over the optional "-force" as the first argument.
sl@0	3305	*/
sl@0	3306
sl@0	3307	firstArg = 2;
sl@0	3308	if (firstArg < objc) {
sl@0	3309	string = Tcl_GetString(objv[firstArg]);
sl@0	3310	if ((*string == '-') && (strcmp(string, "-force") == 0)) {
sl@0	3311	allowOverwrite = 1;
sl@0	3312	firstArg++;
sl@0	3313	}
sl@0	3314	}
sl@0	3315
sl@0	3316	/*
sl@0	3317	* Handle the imports for each of the patterns.
sl@0	3318	*/
sl@0	3319
sl@0	3320	for (i = firstArg; i < objc; i++) {
sl@0	3321	pattern = Tcl_GetString(objv[i]);
sl@0	3322	result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern,
sl@0	3323	allowOverwrite);
sl@0	3324	if (result != TCL_OK) {
sl@0	3325	return result;
sl@0	3326	}
sl@0	3327	}
sl@0	3328	return TCL_OK;
sl@0	3329	}
sl@0	3330
sl@0	3331	/*
sl@0	3332	*----------------------------------------------------------------------
sl@0	3333	*
sl@0	3334	* NamespaceInscopeCmd --
sl@0	3335	*
sl@0	3336	* Invoked to implement the "namespace inscope" command that executes a
sl@0	3337	* script in the context of a particular namespace. This command is not
sl@0	3338	* expected to be used directly by programmers; calls to it are
sl@0	3339	* generated implicitly when programs use "namespace code" commands
sl@0	3340	* to register callback scripts. Handles the following syntax:
sl@0	3341	*
sl@0	3342	* namespace inscope name arg ?arg...?
sl@0	3343	*
sl@0	3344	* The "namespace inscope" command is much like the "namespace eval"
sl@0	3345	* command except that it has lappend semantics and the namespace must
sl@0	3346	* already exist. It treats the first argument as a list, and appends
sl@0	3347	* any arguments after the first onto the end as proper list elements.
sl@0	3348	* For example,
sl@0	3349	*
sl@0	3350	* namespace inscope ::foo a b c d
sl@0	3351	*
sl@0	3352	* is equivalent to
sl@0	3353	*
sl@0	3354	* namespace eval ::foo [concat a [list b c d]]
sl@0	3355	*
sl@0	3356	* This lappend semantics is important because many callback scripts
sl@0	3357	* are actually prefixes.
sl@0	3358	*
sl@0	3359	* Results:
sl@0	3360	* Returns TCL_OK to indicate success, or TCL_ERROR to indicate
sl@0	3361	* failure.
sl@0	3362	*
sl@0	3363	* Side effects:
sl@0	3364	* Returns a result in the Tcl interpreter's result object.
sl@0	3365	*
sl@0	3366	*----------------------------------------------------------------------
sl@0	3367	*/
sl@0	3368
sl@0	3369	static int
sl@0	3370	NamespaceInscopeCmd(dummy, interp, objc, objv)
sl@0	3371	ClientData dummy; /* Not used. */
sl@0	3372	Tcl_Interp interp; / Current interpreter. */
sl@0	3373	int objc; /* Number of arguments. */
sl@0	3374	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3375	{
sl@0	3376	Tcl_Namespace *namespacePtr;
sl@0	3377	Tcl_CallFrame frame;
sl@0	3378	int i, result;
sl@0	3379
sl@0	3380	if (objc < 4) {
sl@0	3381	Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
sl@0	3382	return TCL_ERROR;
sl@0	3383	}
sl@0	3384
sl@0	3385	/*
sl@0	3386	* Resolve the namespace reference.
sl@0	3387	*/
sl@0	3388
sl@0	3389	result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
sl@0	3390	if (result != TCL_OK) {
sl@0	3391	return result;
sl@0	3392	}
sl@0	3393	if (namespacePtr == NULL) {
sl@0	3394	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	3395	"unknown namespace \"", Tcl_GetString(objv[2]),
sl@0	3396	"\" in inscope namespace command", (char *) NULL);
sl@0	3397	return TCL_ERROR;
sl@0	3398	}
sl@0	3399
sl@0	3400	/*
sl@0	3401	* Make the specified namespace the current namespace.
sl@0	3402	*/
sl@0	3403
sl@0	3404	result = Tcl_PushCallFrame(interp, &frame, namespacePtr,
sl@0	3405	/isProcCallFrame/ 0);
sl@0	3406	if (result != TCL_OK) {
sl@0	3407	return result;
sl@0	3408	}
sl@0	3409
sl@0	3410	/*
sl@0	3411	* Execute the command. If there is just one argument, just treat it as
sl@0	3412	* a script and evaluate it. Otherwise, create a list from the arguments
sl@0	3413	* after the first one, then concatenate the first argument and the list
sl@0	3414	* of extra arguments to form the command to evaluate.
sl@0	3415	*/
sl@0	3416
sl@0	3417	if (objc == 4) {
sl@0	3418	result = Tcl_EvalObjEx(interp, objv[3], 0);
sl@0	3419	} else {
sl@0	3420	Tcl_Obj *concatObjv[2];
sl@0	3421	register Tcl_Obj listPtr, cmdObjPtr;
sl@0	3422
sl@0	3423	listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	3424	for (i = 4; i < objc; i++) {
sl@0	3425	result = Tcl_ListObjAppendElement(interp, listPtr, objv[i]);
sl@0	3426	if (result != TCL_OK) {
sl@0	3427	Tcl_DecrRefCount(listPtr); /* free unneeded obj */
sl@0	3428	return result;
sl@0	3429	}
sl@0	3430	}
sl@0	3431
sl@0	3432	concatObjv[0] = objv[3];
sl@0	3433	concatObjv[1] = listPtr;
sl@0	3434	cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
sl@0	3435	result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
sl@0	3436	Tcl_DecrRefCount(listPtr); /* we're done with the list object */
sl@0	3437	}
sl@0	3438	if (result == TCL_ERROR) {
sl@0	3439	char msg[256 + TCL_INTEGER_SPACE];
sl@0	3440
sl@0	3441	sprintf(msg,
sl@0	3442	"\n (in namespace inscope \"%.200s\" script line %d)",
sl@0	3443	namespacePtr->fullName, interp->errorLine);
sl@0	3444	Tcl_AddObjErrorInfo(interp, msg, -1);
sl@0	3445	}
sl@0	3446
sl@0	3447	/*
sl@0	3448	* Restore the previous "current" namespace.
sl@0	3449	*/
sl@0	3450
sl@0	3451	Tcl_PopCallFrame(interp);
sl@0	3452	return result;
sl@0	3453	}
sl@0	3454
sl@0	3455	/*
sl@0	3456	*----------------------------------------------------------------------
sl@0	3457	*
sl@0	3458	* NamespaceOriginCmd --
sl@0	3459	*
sl@0	3460	* Invoked to implement the "namespace origin" command to return the
sl@0	3461	* fully-qualified name of the "real" command to which the specified
sl@0	3462	* "imported command" refers. Handles the following syntax:
sl@0	3463	*
sl@0	3464	* namespace origin name
sl@0	3465	*
sl@0	3466	* Results:
sl@0	3467	* An imported command is created in an namespace when that namespace
sl@0	3468	* imports a command from another namespace. If a command is imported
sl@0	3469	* into a sequence of namespaces a, b,...,n where each successive
sl@0	3470	* namespace just imports the command from the previous namespace, this
sl@0	3471	* command returns the fully-qualified name of the original command in
sl@0	3472	* the first namespace, a. If "name" does not refer to an alias, its
sl@0	3473	* fully-qualified name is returned. The returned name is stored in the
sl@0	3474	* interpreter's result object. This procedure returns TCL_OK if
sl@0	3475	* successful, and TCL_ERROR if anything goes wrong.
sl@0	3476	*
sl@0	3477	* Side effects:
sl@0	3478	* If anything goes wrong, this procedure returns an error message in
sl@0	3479	* the interpreter's result object.
sl@0	3480	*
sl@0	3481	*----------------------------------------------------------------------
sl@0	3482	*/
sl@0	3483
sl@0	3484	static int
sl@0	3485	NamespaceOriginCmd(dummy, interp, objc, objv)
sl@0	3486	ClientData dummy; /* Not used. */
sl@0	3487	Tcl_Interp interp; / Current interpreter. */
sl@0	3488	int objc; /* Number of arguments. */
sl@0	3489	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3490	{
sl@0	3491	Tcl_Command command, origCommand;
sl@0	3492
sl@0	3493	if (objc != 3) {
sl@0	3494	Tcl_WrongNumArgs(interp, 2, objv, "name");
sl@0	3495	return TCL_ERROR;
sl@0	3496	}
sl@0	3497
sl@0	3498	command = Tcl_GetCommandFromObj(interp, objv[2]);
sl@0	3499	if (command == (Tcl_Command) NULL) {
sl@0	3500	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	3501	"invalid command name \"", Tcl_GetString(objv[2]),
sl@0	3502	"\"", (char *) NULL);
sl@0	3503	return TCL_ERROR;
sl@0	3504	}
sl@0	3505	origCommand = TclGetOriginalCommand(command);
sl@0	3506	if (origCommand == (Tcl_Command) NULL) {
sl@0	3507	/*
sl@0	3508	* The specified command isn't an imported command. Return the
sl@0	3509	* command's name qualified by the full name of the namespace it
sl@0	3510	* was defined in.
sl@0	3511	*/
sl@0	3512
sl@0	3513	Tcl_GetCommandFullName(interp, command, Tcl_GetObjResult(interp));
sl@0	3514	} else {
sl@0	3515	Tcl_GetCommandFullName(interp, origCommand, Tcl_GetObjResult(interp));
sl@0	3516	}
sl@0	3517	return TCL_OK;
sl@0	3518	}
sl@0	3519
sl@0	3520	/*
sl@0	3521	*----------------------------------------------------------------------
sl@0	3522	*
sl@0	3523	* NamespaceParentCmd --
sl@0	3524	*
sl@0	3525	* Invoked to implement the "namespace parent" command that returns the
sl@0	3526	* fully-qualified name of the parent namespace for a specified
sl@0	3527	* namespace. Handles the following syntax:
sl@0	3528	*
sl@0	3529	* namespace parent ?name?
sl@0	3530	*
sl@0	3531	* Results:
sl@0	3532	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	3533	*
sl@0	3534	* Side effects:
sl@0	3535	* Returns a result in the interpreter's result object. If anything
sl@0	3536	* goes wrong, the result is an error message.
sl@0	3537	*
sl@0	3538	*----------------------------------------------------------------------
sl@0	3539	*/
sl@0	3540
sl@0	3541	static int
sl@0	3542	NamespaceParentCmd(dummy, interp, objc, objv)
sl@0	3543	ClientData dummy; /* Not used. */
sl@0	3544	Tcl_Interp interp; / Current interpreter. */
sl@0	3545	int objc; /* Number of arguments. */
sl@0	3546	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3547	{
sl@0	3548	Tcl_Namespace *nsPtr;
sl@0	3549	int result;
sl@0	3550
sl@0	3551	if (objc == 2) {
sl@0	3552	nsPtr = Tcl_GetCurrentNamespace(interp);
sl@0	3553	} else if (objc == 3) {
sl@0	3554	result = GetNamespaceFromObj(interp, objv[2], &nsPtr);
sl@0	3555	if (result != TCL_OK) {
sl@0	3556	return result;
sl@0	3557	}
sl@0	3558	if (nsPtr == NULL) {
sl@0	3559	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	3560	"unknown namespace \"", Tcl_GetString(objv[2]),
sl@0	3561	"\" in namespace parent command", (char *) NULL);
sl@0	3562	return TCL_ERROR;
sl@0	3563	}
sl@0	3564	} else {
sl@0	3565	Tcl_WrongNumArgs(interp, 2, objv, "?name?");
sl@0	3566	return TCL_ERROR;
sl@0	3567	}
sl@0	3568
sl@0	3569	/*
sl@0	3570	* Report the parent of the specified namespace.
sl@0	3571	*/
sl@0	3572
sl@0	3573	if (nsPtr->parentPtr != NULL) {
sl@0	3574	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	3575	nsPtr->parentPtr->fullName, -1);
sl@0	3576	}
sl@0	3577	return TCL_OK;
sl@0	3578	}
sl@0	3579
sl@0	3580	/*
sl@0	3581	*----------------------------------------------------------------------
sl@0	3582	*
sl@0	3583	* NamespaceQualifiersCmd --
sl@0	3584	*
sl@0	3585	* Invoked to implement the "namespace qualifiers" command that returns
sl@0	3586	* any leading namespace qualifiers in a string. These qualifiers are
sl@0	3587	* namespace names separated by "::"s. For example, for "::foo::p" this
sl@0	3588	* command returns "::foo", and for "::" it returns "". This command
sl@0	3589	* is the complement of the "namespace tail" command. Note that this
sl@0	3590	* command does not check whether the "namespace" names are, in fact,
sl@0	3591	* the names of currently defined namespaces. Handles the following
sl@0	3592	* syntax:
sl@0	3593	*
sl@0	3594	* namespace qualifiers string
sl@0	3595	*
sl@0	3596	* Results:
sl@0	3597	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	3598	*
sl@0	3599	* Side effects:
sl@0	3600	* Returns a result in the interpreter's result object. If anything
sl@0	3601	* goes wrong, the result is an error message.
sl@0	3602	*
sl@0	3603	*----------------------------------------------------------------------
sl@0	3604	*/
sl@0	3605
sl@0	3606	static int
sl@0	3607	NamespaceQualifiersCmd(dummy, interp, objc, objv)
sl@0	3608	ClientData dummy; /* Not used. */
sl@0	3609	Tcl_Interp interp; / Current interpreter. */
sl@0	3610	int objc; /* Number of arguments. */
sl@0	3611	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3612	{
sl@0	3613	register char name, p;
sl@0	3614	int length;
sl@0	3615
sl@0	3616	if (objc != 3) {
sl@0	3617	Tcl_WrongNumArgs(interp, 2, objv, "string");
sl@0	3618	return TCL_ERROR;
sl@0	3619	}
sl@0	3620
sl@0	3621	/*
sl@0	3622	* Find the end of the string, then work backward and find
sl@0	3623	* the start of the last "::" qualifier.
sl@0	3624	*/
sl@0	3625
sl@0	3626	name = Tcl_GetString(objv[2]);
sl@0	3627	for (p = name; *p != '\0'; p++) {
sl@0	3628	/* empty body */
sl@0	3629	}
sl@0	3630	while (--p >= name) {
sl@0	3631	if ((p == ':') && (p > name) && ((p-1) == ':')) {
sl@0	3632	p -= 2; /* back up over the :: */
sl@0	3633	while ((p >= name) && (*p == ':')) {
sl@0	3634	p--; /* back up over the preceeding : */
sl@0	3635	}
sl@0	3636	break;
sl@0	3637	}
sl@0	3638	}
sl@0	3639
sl@0	3640	if (p >= name) {
sl@0	3641	length = p-name+1;
sl@0	3642	Tcl_AppendToObj(Tcl_GetObjResult(interp), name, length);
sl@0	3643	}
sl@0	3644	return TCL_OK;
sl@0	3645	}
sl@0	3646
sl@0	3647	/*
sl@0	3648	*----------------------------------------------------------------------
sl@0	3649	*
sl@0	3650	* NamespaceTailCmd --
sl@0	3651	*
sl@0	3652	* Invoked to implement the "namespace tail" command that returns the
sl@0	3653	* trailing name at the end of a string with "::" namespace
sl@0	3654	* qualifiers. These qualifiers are namespace names separated by
sl@0	3655	* "::"s. For example, for "::foo::p" this command returns "p", and for
sl@0	3656	* "::" it returns "". This command is the complement of the "namespace
sl@0	3657	* qualifiers" command. Note that this command does not check whether
sl@0	3658	* the "namespace" names are, in fact, the names of currently defined
sl@0	3659	* namespaces. Handles the following syntax:
sl@0	3660	*
sl@0	3661	* namespace tail string
sl@0	3662	*
sl@0	3663	* Results:
sl@0	3664	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	3665	*
sl@0	3666	* Side effects:
sl@0	3667	* Returns a result in the interpreter's result object. If anything
sl@0	3668	* goes wrong, the result is an error message.
sl@0	3669	*
sl@0	3670	*----------------------------------------------------------------------
sl@0	3671	*/
sl@0	3672
sl@0	3673	static int
sl@0	3674	NamespaceTailCmd(dummy, interp, objc, objv)
sl@0	3675	ClientData dummy; /* Not used. */
sl@0	3676	Tcl_Interp interp; / Current interpreter. */
sl@0	3677	int objc; /* Number of arguments. */
sl@0	3678	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3679	{
sl@0	3680	register char name, p;
sl@0	3681
sl@0	3682	if (objc != 3) {
sl@0	3683	Tcl_WrongNumArgs(interp, 2, objv, "string");
sl@0	3684	return TCL_ERROR;
sl@0	3685	}
sl@0	3686
sl@0	3687	/*
sl@0	3688	* Find the end of the string, then work backward and find the
sl@0	3689	* last "::" qualifier.
sl@0	3690	*/
sl@0	3691
sl@0	3692	name = Tcl_GetString(objv[2]);
sl@0	3693	for (p = name; *p != '\0'; p++) {
sl@0	3694	/* empty body */
sl@0	3695	}
sl@0	3696	while (--p > name) {
sl@0	3697	if ((p == ':') && ((p-1) == ':')) {
sl@0	3698	p++; /* just after the last "::" */
sl@0	3699	break;
sl@0	3700	}
sl@0	3701	}
sl@0	3702
sl@0	3703	if (p >= name) {
sl@0	3704	Tcl_AppendToObj(Tcl_GetObjResult(interp), p, -1);
sl@0	3705	}
sl@0	3706	return TCL_OK;
sl@0	3707	}
sl@0	3708
sl@0	3709	/*
sl@0	3710	*----------------------------------------------------------------------
sl@0	3711	*
sl@0	3712	* NamespaceWhichCmd --
sl@0	3713	*
sl@0	3714	* Invoked to implement the "namespace which" command that returns the
sl@0	3715	* fully-qualified name of a command or variable. If the specified
sl@0	3716	* command or variable does not exist, it returns "". Handles the
sl@0	3717	* following syntax:
sl@0	3718	*
sl@0	3719	* namespace which ?-command? ?-variable? name
sl@0	3720	*
sl@0	3721	* Results:
sl@0	3722	* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
sl@0	3723	*
sl@0	3724	* Side effects:
sl@0	3725	* Returns a result in the interpreter's result object. If anything
sl@0	3726	* goes wrong, the result is an error message.
sl@0	3727	*
sl@0	3728	*----------------------------------------------------------------------
sl@0	3729	*/
sl@0	3730
sl@0	3731	static int
sl@0	3732	NamespaceWhichCmd(dummy, interp, objc, objv)
sl@0	3733	ClientData dummy; /* Not used. */
sl@0	3734	Tcl_Interp interp; / Current interpreter. */
sl@0	3735	int objc; /* Number of arguments. */
sl@0	3736	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3737	{
sl@0	3738	register char *arg;
sl@0	3739	Tcl_Command cmd;
sl@0	3740	Tcl_Var variable;
sl@0	3741	int argIndex, lookup;
sl@0	3742
sl@0	3743	if (objc < 3) {
sl@0	3744	badArgs:
sl@0	3745	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	3746	"?-command? ?-variable? name");
sl@0	3747	return TCL_ERROR;
sl@0	3748	}
sl@0	3749
sl@0	3750	/*
sl@0	3751	* Look for a flag controlling the lookup.
sl@0	3752	*/
sl@0	3753
sl@0	3754	argIndex = 2;
sl@0	3755	lookup = 0; /* assume command lookup by default */
sl@0	3756	arg = Tcl_GetString(objv[2]);
sl@0	3757	if (*arg == '-') {
sl@0	3758	if (strncmp(arg, "-command", 8) == 0) {
sl@0	3759	lookup = 0;
sl@0	3760	} else if (strncmp(arg, "-variable", 9) == 0) {
sl@0	3761	lookup = 1;
sl@0	3762	} else {
sl@0	3763	goto badArgs;
sl@0	3764	}
sl@0	3765	argIndex = 3;
sl@0	3766	}
sl@0	3767	if (objc != (argIndex + 1)) {
sl@0	3768	goto badArgs;
sl@0	3769	}
sl@0	3770
sl@0	3771	switch (lookup) {
sl@0	3772	case 0: /* -command */
sl@0	3773	cmd = Tcl_GetCommandFromObj(interp, objv[argIndex]);
sl@0	3774	if (cmd == (Tcl_Command) NULL) {
sl@0	3775	return TCL_OK; /* cmd not found, just return (no error) */
sl@0	3776	}
sl@0	3777	Tcl_GetCommandFullName(interp, cmd, Tcl_GetObjResult(interp));
sl@0	3778	break;
sl@0	3779
sl@0	3780	case 1: /* -variable */
sl@0	3781	arg = Tcl_GetString(objv[argIndex]);
sl@0	3782	variable = Tcl_FindNamespaceVar(interp, arg, (Tcl_Namespace *) NULL,
sl@0	3783	/flags/ 0);
sl@0	3784	if (variable != (Tcl_Var) NULL) {
sl@0	3785	Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));
sl@0	3786	}
sl@0	3787	break;
sl@0	3788	}
sl@0	3789	return TCL_OK;
sl@0	3790	}
sl@0	3791
sl@0	3792	/*
sl@0	3793	*----------------------------------------------------------------------
sl@0	3794	*
sl@0	3795	* FreeNsNameInternalRep --
sl@0	3796	*
sl@0	3797	* Frees the resources associated with a nsName object's internal
sl@0	3798	* representation.
sl@0	3799	*
sl@0	3800	* Results:
sl@0	3801	* None.
sl@0	3802	*
sl@0	3803	* Side effects:
sl@0	3804	* Decrements the ref count of any Namespace structure pointed
sl@0	3805	* to by the nsName's internal representation. If there are no more
sl@0	3806	* references to the namespace, it's structure will be freed.
sl@0	3807	*
sl@0	3808	*----------------------------------------------------------------------
sl@0	3809	*/
sl@0	3810
sl@0	3811	static void
sl@0	3812	FreeNsNameInternalRep(objPtr)
sl@0	3813	register Tcl_Obj objPtr; / nsName object with internal
sl@0	3814	* representation to free */
sl@0	3815	{
sl@0	3816	register ResolvedNsName *resNamePtr =
sl@0	3817	(ResolvedNsName *) objPtr->internalRep.otherValuePtr;
sl@0	3818	Namespace *nsPtr;
sl@0	3819
sl@0	3820	/*
sl@0	3821	* Decrement the reference count of the namespace. If there are no
sl@0	3822	* more references, free it up.
sl@0	3823	*/
sl@0	3824
sl@0	3825	if (resNamePtr != NULL) {
sl@0	3826	resNamePtr->refCount--;
sl@0	3827	if (resNamePtr->refCount == 0) {
sl@0	3828
sl@0	3829	/*
sl@0	3830	* Decrement the reference count for the cached namespace. If
sl@0	3831	* the namespace is dead, and there are no more references to
sl@0	3832	* it, free it.
sl@0	3833	*/
sl@0	3834
sl@0	3835	nsPtr = resNamePtr->nsPtr;
sl@0	3836	nsPtr->refCount--;
sl@0	3837	if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
sl@0	3838	NamespaceFree(nsPtr);
sl@0	3839	}
sl@0	3840	ckfree((char *) resNamePtr);
sl@0	3841	}
sl@0	3842	}
sl@0	3843	}
sl@0	3844
sl@0	3845	/*
sl@0	3846	*----------------------------------------------------------------------
sl@0	3847	*
sl@0	3848	* DupNsNameInternalRep --
sl@0	3849	*
sl@0	3850	* Initializes the internal representation of a nsName object to a copy
sl@0	3851	* of the internal representation of another nsName object.
sl@0	3852	*
sl@0	3853	* Results:
sl@0	3854	* None.
sl@0	3855	*
sl@0	3856	* Side effects:
sl@0	3857	* copyPtr's internal rep is set to refer to the same namespace
sl@0	3858	* referenced by srcPtr's internal rep. Increments the ref count of
sl@0	3859	* the ResolvedNsName structure used to hold the namespace reference.
sl@0	3860	*
sl@0	3861	*----------------------------------------------------------------------
sl@0	3862	*/
sl@0	3863
sl@0	3864	static void
sl@0	3865	DupNsNameInternalRep(srcPtr, copyPtr)
sl@0	3866	Tcl_Obj srcPtr; / Object with internal rep to copy. */
sl@0	3867	register Tcl_Obj copyPtr; / Object with internal rep to set. */
sl@0	3868	{
sl@0	3869	register ResolvedNsName *resNamePtr =
sl@0	3870	(ResolvedNsName *) srcPtr->internalRep.otherValuePtr;
sl@0	3871
sl@0	3872	copyPtr->internalRep.otherValuePtr = (VOID *) resNamePtr;
sl@0	3873	if (resNamePtr != NULL) {
sl@0	3874	resNamePtr->refCount++;
sl@0	3875	}
sl@0	3876	copyPtr->typePtr = &tclNsNameType;
sl@0	3877	}
sl@0	3878
sl@0	3879	/*
sl@0	3880	*----------------------------------------------------------------------
sl@0	3881	*
sl@0	3882	* SetNsNameFromAny --
sl@0	3883	*
sl@0	3884	* Attempt to generate a nsName internal representation for a
sl@0	3885	* Tcl object.
sl@0	3886	*
sl@0	3887	* Results:
sl@0	3888	* Returns TCL_OK if the value could be converted to a proper
sl@0	3889	* namespace reference. Otherwise, it returns TCL_ERROR, along
sl@0	3890	* with an error message in the interpreter's result object.
sl@0	3891	*
sl@0	3892	* Side effects:
sl@0	3893	* If successful, the object is made a nsName object. Its internal rep
sl@0	3894	* is set to point to a ResolvedNsName, which contains a cached pointer
sl@0	3895	* to the Namespace. Reference counts are kept on both the
sl@0	3896	* ResolvedNsName and the Namespace, so we can keep track of their
sl@0	3897	* usage and free them when appropriate.
sl@0	3898	*
sl@0	3899	*----------------------------------------------------------------------
sl@0	3900	*/
sl@0	3901
sl@0	3902	static int
sl@0	3903	SetNsNameFromAny(interp, objPtr)
sl@0	3904	Tcl_Interp interp; / Points to the namespace in which to
sl@0	3905	* resolve name. Also used for error
sl@0	3906	* reporting if not NULL. */
sl@0	3907	register Tcl_Obj objPtr; / The object to convert. */
sl@0	3908	{
sl@0	3909	register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
sl@0	3910	char *name;
sl@0	3911	CONST char *dummy;
sl@0	3912	Namespace nsPtr, dummy1Ptr, *dummy2Ptr;
sl@0	3913	register ResolvedNsName *resNamePtr;
sl@0	3914
sl@0	3915	/*
sl@0	3916	* Get the string representation. Make it up-to-date if necessary.
sl@0	3917	*/
sl@0	3918
sl@0	3919	name = objPtr->bytes;
sl@0	3920	if (name == NULL) {
sl@0	3921	name = Tcl_GetString(objPtr);
sl@0	3922	}
sl@0	3923
sl@0	3924	/*
sl@0	3925	* Look for the namespace "name" in the current namespace. If there is
sl@0	3926	* an error parsing the (possibly qualified) name, return an error.
sl@0	3927	* If the namespace isn't found, we convert the object to an nsName
sl@0	3928	* object with a NULL ResolvedNsName* internal rep.
sl@0	3929	*/
sl@0	3930
sl@0	3931	TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
sl@0	3932	FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
sl@0	3933
sl@0	3934	/*
sl@0	3935	* If we found a namespace, then create a new ResolvedNsName structure
sl@0	3936	* that holds a reference to it.
sl@0	3937	*/
sl@0	3938
sl@0	3939	if (nsPtr != NULL) {
sl@0	3940	Namespace *currNsPtr =
sl@0	3941	(Namespace *) Tcl_GetCurrentNamespace(interp);
sl@0	3942
sl@0	3943	nsPtr->refCount++;
sl@0	3944	resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName));
sl@0	3945	resNamePtr->nsPtr = nsPtr;
sl@0	3946	resNamePtr->nsId = nsPtr->nsId;
sl@0	3947	resNamePtr->refNsPtr = currNsPtr;
sl@0	3948	resNamePtr->refCount = 1;
sl@0	3949	} else {
sl@0	3950	resNamePtr = NULL;
sl@0	3951	}
sl@0	3952
sl@0	3953	/*
sl@0	3954	* Free the old internalRep before setting the new one.
sl@0	3955	* We do this as late as possible to allow the conversion code
sl@0	3956	* (in particular, Tcl_GetStringFromObj) to use that old internalRep.
sl@0	3957	*/
sl@0	3958
sl@0	3959	if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
sl@0	3960	oldTypePtr->freeIntRepProc(objPtr);
sl@0	3961	}
sl@0	3962
sl@0	3963	objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr;
sl@0	3964	objPtr->typePtr = &tclNsNameType;
sl@0	3965	return TCL_OK;
sl@0	3966	}
sl@0	3967
sl@0	3968	/*
sl@0	3969	*----------------------------------------------------------------------
sl@0	3970	*
sl@0	3971	* UpdateStringOfNsName --
sl@0	3972	*
sl@0	3973	* Updates the string representation for a nsName object.
sl@0	3974	* Note: This procedure does not free an existing old string rep
sl@0	3975	* so storage will be lost if this has not already been done.
sl@0	3976	*
sl@0	3977	* Results:
sl@0	3978	* None.
sl@0	3979	*
sl@0	3980	* Side effects:
sl@0	3981	* The object's string is set to a copy of the fully qualified
sl@0	3982	* namespace name.
sl@0	3983	*
sl@0	3984	*----------------------------------------------------------------------
sl@0	3985	*/
sl@0	3986
sl@0	3987	static void
sl@0	3988	UpdateStringOfNsName(objPtr)
sl@0	3989	register Tcl_Obj objPtr; / nsName object with string rep to update. */
sl@0	3990	{
sl@0	3991	ResolvedNsName *resNamePtr =
sl@0	3992	(ResolvedNsName *) objPtr->internalRep.otherValuePtr;
sl@0	3993	register Namespace *nsPtr;
sl@0	3994	char *name = "";
sl@0	3995	int length;
sl@0	3996
sl@0	3997	if ((resNamePtr != NULL)
sl@0	3998	&& (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) {
sl@0	3999	nsPtr = resNamePtr->nsPtr;
sl@0	4000	if (nsPtr->flags & NS_DEAD) {
sl@0	4001	nsPtr = NULL;
sl@0	4002	}
sl@0	4003	if (nsPtr != NULL) {
sl@0	4004	name = nsPtr->fullName;
sl@0	4005	}
sl@0	4006	}
sl@0	4007
sl@0	4008	/*
sl@0	4009	* The following sets the string rep to an empty string on the heap
sl@0	4010	* if the internal rep is NULL.
sl@0	4011	*/
sl@0	4012
sl@0	4013	length = strlen(name);
sl@0	4014	if (length == 0) {
sl@0	4015	objPtr->bytes = tclEmptyStringRep;
sl@0	4016	} else {
sl@0	4017	objPtr->bytes = (char *) ckalloc((unsigned) (length + 1));
sl@0	4018	memcpy((VOID ) objPtr->bytes, (VOID ) name, (unsigned) length);
sl@0	4019	objPtr->bytes[length] = '\0';
sl@0	4020	}
sl@0	4021	objPtr->length = length;
sl@0	4022	}

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--