rem: if (Tcl_ListObjAppendElement(interp, servPtr->tcl.modules, objv[2]) != TCL_OK) { return TCL_ERROR; } Tcl_SetObjResult(interp, servPtr->tcl.modules);
add: Ns_TclInitModule(servPtr->server, Tcl_GetString(objv[2]));
context: static Tcl_AsyncProc AsyncCancel;static Tcl_HashTable interps;static Ns_Mutex ilock;/* * Static variables defined in this file. */static Ns_Tls tls;	/* Slot for per-thread Tcl interp cache. *//* *---------------------------------------------------------------------- * * NsInitTcl -- * *	Initialize the Tcl interp interface. * * Results: *	None. * * Side effects: *	None. * *---------------------------------------------------------------------- */voidNsInitTcl(void){    /*     * Allocate the thread storage slot for the table of interps     * per-thread. At thread exit, DeleteInterps will be called     * to free any interps remaining on the thread cache.     */    Ns_TlsAlloc(&tls, DeleteInterps);    Tcl_InitHashTable(&interps, TCL_STRING_KEYS);    Ns_MutexSetName(&ilock, "ns:interps");}/* *---------------------------------------------------------------------- * * Ns_TclCreateInterp -- * *      Create a new interp with basic AOLserver commands.  * * Results: *      Pointer to new interp. * * Side effects: *	See CreateInterp. * *---------------------------------------------------------------------- */Tcl_Interp *Ns_TclCreateInterp(void){    return CreateInterp(NULL);}/* *---------------------------------------------------------------------- * * Ns_TclInit -- * *      Initialize an interp with basic AOLserver commands. * * Results: *      TCL_OK or TCL_ERROR on init error. * * Side effects: *	See InitInterp. * *---------------------------------------------------------------------- */intNs_TclInit(Tcl_Interp *interp){    (void) NewInterpData(interp);    return TCL_OK;}/* *---------------------------------------------------------------------- * * Nsd_Init -- * *      Init routine called when libnsd is loaded via the Tcl *	load command. This simply calls Ns_TclInit. * * Results: *      See Ns_TclInit. * * Side effects: *	See Ns_TclInit. * *---------------------------------------------------------------------- */intNsd_Init(Tcl_Interp *interp){    return Ns_TclInit(interp);}/* *---------------------------------------------------------------------- * * Ns_TclEval -- * *	Execute a Tcl script in the context of the the given server. * * Results: *	Tcl return code.  * * Side effects: *	String results or error are placed in dsPtr if not NULL. * *---------------------------------------------------------------------- */intNs_TclEval(Ns_DString *dsPtr, char *server, char *script){    int         retcode;    Tcl_Interp *interp;    CONST char *result;    retcode = NS_ERROR;    interp = Ns_TclAllocateInterp(server);    if (interp != NULL) {        if (Tcl_EvalEx(interp, script, -1, 0) != TCL_OK) {	    result = Ns_TclLogError(interp);        } else {	    result = Tcl_GetStringResult(interp);            retcode = NS_OK;	}	if (dsPtr != NULL) {            Ns_DStringAppend(dsPtr, result);        }        Ns_TclDeAllocateInterp(interp);    }    return retcode;}/* *---------------------------------------------------------------------- * * Ns_TclAllocateInterp -- * *	Allocate an interpreter from the per-thread list.  Note that a *	single thread can have multiple interps for multiple virtual *	servers. * * Results: *	Pointer to Tcl_Interp. * * Side effects: *	See PopInterp for details on various traces which may be *	called. * *---------------------------------------------------------------------- */Tcl_Interp *Ns_TclAllocateInterp(char *server){    NsInterp *itPtr;    itPtr = PopInterp(server);    return (itPtr ? itPtr->interp : NULL);}/* *---------------------------------------------------------------------- * * Ns_TclDeAllocateInterp -- * *	Get the NsInterp for the given interp and return the interp to *	the per-thread cache.  If the interp is associated with a *	connection, silently do nothing as cleanup will occur later *	with connection cleanup.  Also, if the interp is not actually *	an AOLserver interp, i.e., missing the NsInterp structure, *	simply delete the interp directly (this is suspect). * * Results: *	None. * * Side effects: *	See notes on garbage collection in PushInterp. * *---------------------------------------------------------------------- */voidNs_TclDeAllocateInterp(Tcl_Interp *interp){    NsInterp *itPtr;    itPtr = NsGetInterpData(interp);    if (itPtr == NULL) {	Tcl_DeleteInterp(interp);    } else if (itPtr->conn == NULL) {    	PushInterp(itPtr);    }}/* *---------------------------------------------------------------------- * * Ns_GetConnInterp -- * *	Get the interp for the given connection.  When first called *	for a connection, the interp data is allocated and associated *	with the given connection.  The interp will be automatically *	cleaned up at the end of the connection via a call to via *	NsFreeConnInterp(). * * Results: *	Pointer to Tcl interp data initialized for given connection. * * Side effects: *	See NsGetInputEncodings for details on connection encoding setup *	required to ensure proper UTF-8 input and output. * *---------------------------------------------------------------------- */Tcl_Interp *Ns_GetConnInterp(Ns_Conn *conn){    Conn *connPtr = (Conn *) conn;    NsInterp *itPtr;    if (connPtr->itPtr == NULL) {	itPtr = PopInterp(connPtr->server);	itPtr->conn = conn;	itPtr->nsconn.flags = 0;	connPtr->itPtr = itPtr;    	Tcl_SetVar2(itPtr->interp, "conn", NULL, connPtr->idstr,		    TCL_GLOBAL_ONLY);	RunTclTraces(itPtr, NS_TCL_TRACE_GETCONN);    }    return connPtr->itPtr->interp;}/* *---------------------------------------------------------------------- * * Ns_FreeConnInterp -- * *	Release and cleanup the interp associated with given *	connection.  This routine no longer does actual cleanup.  The *	connection cleanup code will call NsFreeConnInterp if needed. * * Results: *	None. * * Side effects: *	None. * *---------------------------------------------------------------------- */voidNs_FreeConnInterp(Ns_Conn *conn){    return;}/* *---------------------------------------------------------------------- * * Ns_TclGetConn -- * *	Get the Ns_Conn structure associated with this tcl interp. * * Results: *	An Ns_Conn.  * * Side effects: *	None.  * *---------------------------------------------------------------------- */Ns_Conn *Ns_TclGetConn(Tcl_Interp *interp){    NsInterp *itPtr = NsGetInterpData(interp);    return (itPtr ? itPtr->conn : NULL);}/* *---------------------------------------------------------------------- * * Ns_TclDestroyInterp -- * *      Delete an interp. * * Results: *      None. * * Side effects: *	None. * *---------------------------------------------------------------------- */voidNs_TclDestroyInterp(Tcl_Interp *interp){    NsInterp *itPtr = NsGetInterpData(interp);    /*     * If this is an AOLserver interp, invoke the delete traces.     */    if (itPtr != NULL) {	RunTclTraces(itPtr, NS_TCL_TRACE_DELETE);    }    /*     * All other cleanup, including the NsInterp data, if any, will     * be handled by Tcl's normal delete mechanisms.     */    Tcl_DeleteInterp(interp);}/* *---------------------------------------------------------------------- * * Ns_TclMarkForDelete -- * *	Mark the interp to be deleted at the  next deallocation.  This *	routine is useful to destory interps after they've been *	modified in weird ways, e.g., by the TclPro debugger. * * Results: *	None. * * Side effects: *	Interp will be deleted on next de-allocate. * *---------------------------------------------------------------------- */voidNs_TclMarkForDelete(Tcl_Interp *interp){    NsInterp *itPtr = NsGetInterpData(interp);        if (itPtr != NULL) {	itPtr->delete = 1;    }}/* *---------------------------------------------------------------------- * * Ns_TclRegisterTrace -- * *  	Add a Tcl trace.  Traces are called in FIFO order. * * Results: *	NS_OK if called with a non-NULL server, NS_ERROR otherwise. * * Side effects: *	Will modify server trace list. * *---------------------------------------------------------------------- */ intNs_TclRegisterTrace(char *server, Ns_TclTraceProc *proc, void *arg, int when){    TclTrace *tracePtr, **firstPtrPtr;    NsServer *servPtr;    servPtr = NsGetServer(server);    if (servPtr == NULL || Ns_InfoStarted()) {	return NS_ERROR;    }    tracePtr = ns_malloc(sizeof(TclTrace));    tracePtr->proc = proc;    tracePtr->arg = arg;    tracePtr->when = when;    tracePtr->nextPtr = NULL;    firstPtrPtr = &servPtr->tcl.firstTracePtr;    while (*firstPtrPtr != NULL) {	firstPtrPtr = &((*firstPtrPtr)->nextPtr);    }    *firstPtrPtr = tracePtr;    return NS_OK;}/* *---------------------------------------------------------------------- * * Ns_TclRegisterAtCreate, Ns_TclRegisterAtCleanup, * Ns_TclRegisterAtDelete -- * *	Register callbacks for interp create, cleanup, and delete at *	startup.  These routines are deprecated in favor of the more *	general Ns_TclRegisterTrace. In particular, they do not take a *	virtual server argument so must assume the currently *	initializing server is the intended server. * * Results: *	See Ns_TclRegisterTrace. * * Side effects: *	See Ns_TclRegisterTrace. * *---------------------------------------------------------------------- */intNs_TclRegisterAtCreate(Ns_TclTraceProc *proc, void *arg){    return RegisterAt(proc, arg, NS_TCL_TRACE_CREATE);}intNs_TclRegisterAtCleanup(Ns_TclTraceProc *proc, void *arg){    return RegisterAt(proc, arg, NS_TCL_TRACE_DEALLOCATE);}intNs_TclRegisterAtDelete(Ns_TclTraceProc *proc, void *arg){    return RegisterAt(proc, arg, NS_TCL_TRACE_DELETE);}static intRegisterAt(Ns_TclTraceProc *proc, void *arg, int when){    NsServer *servPtr;    servPtr = NsGetInitServer();    if (servPtr == NULL) {	return NS_ERROR;    }    return Ns_TclRegisterTrace(servPtr->server, proc, arg, when);}/* *---------------------------------------------------------------------- * * Ns_TclInitInterps -- * *	Arrange for the given proc to be called on newly created *	interps.  This routine now simply uses the more general Tcl *	interp tracing facility.  Earlier versions of AOLserver would *	invoke the given proc immediately on each interp in a shared *	pool which explains this otherwise misnamed API. * * Results: *	See Ns_TclRegisterTrace. * * Side effects: *	See Ns_TclRegisterTrace. * *---------------------------------------------------------------------- */intNs_TclInitInterps(char *server, Ns_TclInterpInitProc *proc, void *arg){    return Ns_TclRegisterTrace(server, proc, arg, NS_TCL_TRACE_CREATE);}/* *---------------------------------------------------------------------- * * Ns_TclRegisterDeferred -- * *	Register a procedure to be called when the interp is deallocated. *	This is on-shot FIFO order callback mechanism which is seldom *	used. * * Results: *	None. * * Side effects: *	Procedure will be called later. * *---------------------------------------------------------------------- */voidNs_TclRegisterDeferred(Tcl_Interp *interp, Ns_TclDeferProc *proc, void *arg){    NsInterp   *itPtr = NsGetInterpData(interp);    Defer      *deferPtr, **nextPtrPtr;    if (itPtr == NULL) {        return;    }    deferPtr = ns_malloc(sizeof(Defer));    deferPtr->proc = proc;    deferPtr->arg = arg;    deferPtr->nextPtr = NULL;    nextPtrPtr = &itPtr->firstDeferPtr;    while (*nextPtrPtr != NULL) {	nextPtrPtr = &((*nextPtrPtr)->nextPtr);    }    *nextPtrPtr = deferPtr;}/* *---------------------------------------------------------------------- * * Ns_TclLibrary -- * *	Return the name of the private tcl lib  * * Results: *	Tcl lib name.  * * Side effects: *	None.  * *---------------------------------------------------------------------- */char *Ns_TclLibrary(char *server){    NsServer *servPtr = NsGetServer(server);    return (servPtr ? servPtr->tcl.library : nsconf.tcl.sharedlibrary);}/* *---------------------------------------------------------------------- * * Ns_TclInterpServer -- * *	Return the name of the server.  * * Results: *	Server name.  * * Side effects: *	None.  * *---------------------------------------------------------------------- */char *Ns_TclInterpServer(Tcl_Interp *interp){    NsInterp *itPtr = NsGetInterpData(interp);        if (itPtr != NULL && itPtr->servPtr != NULL) {    	return itPtr->servPtr->server;    }    return NULL;}/* *---------------------------------------------------------------------- * * Ns_TclLogError -- * *	Log the global errorInfo variable to the server log.  * * Results: *	Returns a pointer to the errorInfo.  * * Side effects: *	None.  * *---------------------------------------------------------------------- */char *Ns_TclLogError(Tcl_Interp *interp){    CONST char *errorInfo;    errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);    if (errorInfo == NULL) {        errorInfo = "";    }    Ns_Log(Error, "%s\n%s", Tcl_GetStringResult(interp), errorInfo);    return (char *) errorInfo;}/* *---------------------------------------------------------------------- * * Ns_TclLogErrorRequest -- * *	Log both errorInfo and info about the HTTP request that led  *	to it.  * * Results: *	Returns a pointer to the errorInfo.  * * Side effects: *	None.  * *---------------------------------------------------------------------- */char *Ns_TclLogErrorRequest(Tcl_Interp *interp, Ns_Conn *conn){    char *agent;    CONST char *errorInfo;    errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);    if (errorInfo == NULL) {        errorInfo = Tcl_GetStringResult(interp);    }    agent = Ns_SetIGet(conn->headers, "user-agent");    if (agent == NULL) {	agent = "?";    }    Ns_Log(Error, "error for %s %s, "           "User-Agent: %s, PeerAddress: %s\n%s",            conn->request->method, conn->request->url,	   agent, Ns_ConnPeer(conn), errorInfo);    return (char*)errorInfo;}/* *---------------------------------------------------------------------- * * Ns_TclInitModule -- * *      Add a module name to the init list. * * Results: *      TCL_ERROR if no such server, TCL_OK otherwise. * * Side effects: *	Module will be initialized by the init script later. * *---------------------------------------------------------------------- */intNs_TclInitModule(char *server, char *module){    NsServer *servPtr;    servPtr = NsGetServer(server);    if (servPtr == NULL) {	return NS_ERROR;    }    (void) Tcl_ListObjAppendElement(NULL, servPtr->tcl.modules,			     	    Tcl_NewStringObj(module, -1));    return NS_OK;}/* *---------------------------------------------------------------------- * * NsTclICtlObjCmd -- * *      Implements ns_ictl command to control interp state for *	virtual server interps.  This command provide internal control *	functions required by the init.tcl script and is not intended *	to be called by a user directly.  It supports four activities: *	1. Managing the list of "modules" to initialize. *	2. Saving the init script for evaluation with new interps. *	3. Checking for change of the init script. *	4. Register script-level traces. * *	See init.tcl for details. * * Results: *      Standard Tcl result. * * Side effects: *	May update current saved server Tcl state. * *---------------------------------------------------------------------- */intNsTclICtlObjCmd(ClientData arg, Tcl_Interp *interp, int objc, Tcl_Obj **objv){    NsInterp *itPtr = arg;    NsInterp *citPtr;    NsServer *servPtr = itPtr->servPtr;    Defer    *deferPtr;    ScriptTrace *stPtr;    Tcl_HashEntry *hPtr;    Tcl_HashSearch search;    int	      when, length, result;    char     *script, *iname, *pattern;    static CONST char *opts[] = {	"addmodule", "cleanup", "epoch", "get", "getmodules", "save",	"update", "oncreate", "oncleanup", "oninit", "ondelete", "trace",	"getinterp", "interps", "cancel",	NULL    };    enum {	IAddModuleIdx, ICleanupIdx, IEpochIdx, IGetIdx, IGetModulesIdx,	ISaveIdx, IUpdateIdx, IOnCreateIdx, IOnCleanupIdx, IOnInitIdx,        IOnDeleteIdx, ITraceIdx, IGetInterpIdx, IInterpsIdx, ICancelIdx    } opt;    static CONST char *topts[] = {	"create", "delete", "allocate", "deallocate", "getconn", "freeconn",	NULL    };    enum {	TCreateIdx, TDeleteIdx, TAllocateIdx, TDeAllocateIdx,	TGetConnIdx, TFreeConnIdx    } topt;    static int twhen[] = {	NS_TCL_TRACE_CREATE, NS_TCL_TRACE_DELETE,	NS_TCL_TRACE_ALLOCATE, NS_TCL_TRACE_DEALLOCATE,	NS_TCL_TRACE_GETCONN, NS_TCL_TRACE_FREECONN    };    if (objc < 2) {        Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?");	return TCL_ERROR;    }    if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0,			    (int *) &opt) != TCL_OK) {	return TCL_ERROR;    }    result = TCL_OK;    switch (opt) {    case IAddModuleIdx:	/*	 * Add a Tcl module to the list of for later initialization.	 */	if (objc != 3) {            Tcl_WrongNumArgs(interp, 2, objv, "module");	    return TCL_ERROR;	}	if (Tcl_ListObjAppendElement(interp, servPtr->tcl.modules,				     objv[2]) != TCL_OK) {	    return TCL_ERROR;	}	Tcl_SetObjResult(interp, servPtr->tcl.modules);	break;    case IGetModulesIdx:	/*	 * Get the list of modules for initialization.  See init.tcl	 * for expected use.	 */	if (objc != 2) {            Tcl_WrongNumArgs(interp, 2, objv, NULL);	    return TCL_ERROR;	}	Tcl_SetObjResult(interp, servPtr->tcl.modules);	break;    case IGetIdx:	/*	 * Get the current init script to evaluate in new interps.	 */	if (objc != 2) {            Tcl_WrongNumArgs(interp, 2, objv, NULL);	    return TCL_ERROR;	}	Ns_RWLockRdLock(&servPtr->tcl.lock);	Tcl_SetResult(interp, servPtr->tcl.script, TCL_VOLATILE);	Ns_RWLockUnlock(&servPtr->tcl.lock);	break;    case IEpochIdx:	/*	 * Check the version of this interp against current init script.	 */	if (objc != 2) {            Tcl_WrongNumArgs(interp, 2, objv, NULL);	    return TCL_ERROR;	}	Ns_RWLockRdLock(&servPtr->tcl.lock);	Tcl_SetIntObj(Tcl_GetObjResult(interp), servPtr->tcl.epoch);	Ns_RWLockUnlock(&servPtr->tcl.lock);	break;       case ISaveIdx:	/*	 * Save the init script.	 */	if (objc != 3) {            Tcl_WrongNumArgs(interp, 2, objv, "script");	    return TCL_ERROR;    	}	script = ns_strdup(Tcl_GetStringFromObj(objv[2], &length));	Ns_RWLockWrLock(&servPtr->tcl.lock);	ns_free(servPtr->tcl.script);	servPtr->tcl.script = script;	servPtr->tcl.length = length;	if (++servPtr->tcl.epoch == 0) {	    /* NB: Epoch zero reserved for new interps. */	    ++servPtr->tcl.epoch;	}	Ns_RWLockUnlock(&servPtr->tcl.lock);	break;    case IUpdateIdx:	/*	 * Check for and process possible change in the init script.	 */	if (objc != 2) {            Tcl_WrongNumArgs(interp, 2, objv, NULL);	    return TCL_ERROR;	}	result = UpdateInterp(itPtr);	break;    case ICleanupIdx:	/*	 * Invoke the legacy defer callbacks.	 */	if (objc != 2) {            Tcl_WrongNumArgs(interp, 2, objv, NULL);	    return TCL_ERROR;	}    	while ((deferPtr = itPtr->firstDeferPtr) != NULL) {	    itPtr->firstDeferPtr = deferPtr->nextPtr;	    (*deferPtr->proc)(interp, deferPtr->arg);	    ns_free(deferPtr);	}	break;    case IOnInitIdx:    case IOnCreateIdx:    case IOnCleanupIdx:    case IOnDeleteIdx:	/*	 * Register script-level interp traces.	 */        if (objc != 3) {            Tcl_WrongNumArgs(interp, 2, objv, "script");	    return TCL_ERROR;        }	switch (opt) {	case IOnInitIdx:	case IOnCreateIdx:	    when = NS_TCL_TRACE_CREATE;	    break;	case IOnCleanupIdx:	    when = NS_TCL_TRACE_DEALLOCATE;	    break;	case IOnDeleteIdx:	    when = NS_TCL_TRACE_DELETE;	    break;	default:	    /* NB: Silence compiler. */	    break;	}	goto trace;	break;    case ITraceIdx:        if (objc != 4) {            Tcl_WrongNumArgs(interp, 2, objv, "when script");	    return TCL_ERROR;        }    	if (Tcl_GetIndexFromObj(interp, objv[2], topts, "when", 0,			    (int *) &topt) != TCL_OK) {	    return TCL_ERROR;    	}	when = twhen[topt];    trace:	if (servPtr != NsGetInitServer()) {	    Tcl_AppendResult(interp, "attempt to call ", opts[opt],		" after startup", NULL);	    return TCL_ERROR;	}	script = Tcl_GetString(objv[objc-1]);	length = strlen(script);	stPtr = ns_malloc(sizeof(ScriptTrace) + length);	stPtr->length = length;	strcpy(stPtr->script,  script);	(void) Ns_TclRegisterTrace(servPtr->server, EvalTrace, stPtr, when);	break;    case IGetInterpIdx:	Tcl_SetResult(interp, itPtr->name, TCL_STATIC);	break;    case IInterpsIdx:        if (objc != 2 && objc != 3) {            Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");	    return TCL_ERROR;        }	if (objc == 2) {	    pattern = NULL;	} else {	    pattern = Tcl_GetString(objv[2]);	}	Ns_MutexLock(&ilock);	hPtr = Tcl_FirstHashEntry(&interps, &search);	while (hPtr != NULL) {	    iname = Tcl_GetHashKey(&interps, hPtr);	    if (pattern == NULL || Tcl_StringMatch(iname, pattern)) {	    	Tcl_AppendElement(interp, iname);	    }	    hPtr = Tcl_NextHashEntry(&search);	}	Ns_MutexUnlock(&ilock);	break;    case ICancelIdx:	if (objc != 3) {            Tcl_WrongNumArgs(interp, 2, objv, "interp");	    return TCL_ERROR;        }	iname = Tcl_GetString(objv[2]);	Ns_MutexLock(&ilock);	hPtr = Tcl_FindHashEntry(&interps, iname);	if (hPtr != NULL) {	    citPtr = Tcl_GetHashValue(hPtr);	    Tcl_AsyncMark(citPtr->cancel);	}	Ns_MutexUnlock(&ilock);	if (hPtr == NULL) {	    Tcl_AppendResult(interp, "no such interp: ", iname, NULL);	    return TCL_ERROR;	}	break;    }    return result;}/* *---------------------------------------------------------------------- * * NsTclAtCloseObjCmd -- * *	Implements ns_atclose.  * * Results: *	Tcl result.  * * Side effects: *	Script will be invoked when the connection is closed.  Note *	the connection may continue execution, e.g., with continued *	ADP code, traces, etc. * *---------------------------------------------------------------------- */intNsTclAtCloseObjCmd(ClientData arg, Tcl_Interp *interp, int objc,		   CONST Tcl_Obj **objv){    NsInterp *itPtr = arg;    AtClose *atPtr;    if (objc < 2) {        Tcl_WrongNumArgs(interp, 1, objv, "script ?args?");	return TCL_ERROR;    }    if (itPtr->conn == NULL) {	Tcl_SetResult(interp, "no connection", TCL_STATIC);	return TCL_ERROR;    }    atPtr = ns_malloc(sizeof(AtClose));    atPtr->nextPtr = itPtr->firstAtClosePtr;    itPtr->firstAtClosePtr = atPtr;    atPtr->objPtr = Tcl_ConcatObj(objc-1, objv+1);    Tcl_IncrRefCount(atPtr->objPtr);    return TCL_OK;}/* *---------------------------------------------------------------------- * * NsTclMarkForDeleteObjCmd -- * *	Implements ns_markfordelete.  * * Results: *	Tcl result.  * * Side effects: *	See Ns_TclMarkForDelete.  * *---------------------------------------------------------------------- */intNsTclMarkForDeleteObjCmd(ClientData arg, Tcl_Interp *interp, int objc, Tcl_Obj **objv){    NsInterp *itPtr = arg;    if (objc != 1) {        Tcl_WrongNumArgs(interp, 1, objv, "");	return TCL_ERROR;    }    itPtr->delete = 1;    return TCL_OK;}/* *---------------------------------------------------------------------- * * NsTclDummyObjCmd -- * *      Dummy command for ns_init and ns_cleanup.  The default *	init.tcl script will re-define these commands with proper *	startup initialization and deallocation scripts. * * Results: *      TCL_OK. * * Side effects: *	None. * *---------------------------------------------------------------------- */intNsTclDummyObjCmd(ClientData arg, Tcl_Interp *interp, int objc, Tcl_Obj **objv){    return TCL_OK;}/* *---------------------------------------------------------------------- * * NsTclInitServer -- * *	Evaluate server initialization script at startup. * * Results: *	None. * * Side effects: *	See init script (normally init.tcl). * *---------------------------------------------------------------------- */voidNsTclInitServer(char *server){    NsServer *servPtr = NsGetServer(server);    Tcl_Interp *interp;    if (servPtr != NULL) {	interp = Ns_TclAllocateInterp(server);	if (Tcl_EvalFile(interp, servPtr->tcl.initfile) != TCL_OK) {	    Ns_TclLogError(interp);	}    	Ns_TclDeAllocateInterp(interp);    }}/* *---------------------------------------------------------------------- * * NsGetInterpData -- * *	Return the interp's NsInterp structure from assoc data. *	This routine is used when the NsInterp is needed and *	not available as command ClientData. * * Results: *	Pointer to NsInterp or NULL if none. * * Side effects: *	None. * *---------------------------------------------------------------------- */NsInterp *NsGetInterpData(Tcl_Interp *interp){    return (interp ? Tcl_GetAssocData(interp, "ns:data", NULL) : NULL);}/* *---------------------------------------------------------------------- * * NsFreeConnInterp -- * *	Free the interp data, if any, for given connection.  This *	routine is called at the end of connection processing. * * Results: *	None. * * Side effects: *	See PushInterp. * *---------------------------------------------------------------------- */voidNsFreeConnInterp(Conn *connPtr){    NsInterp *itPtr = connPtr->itPtr;    if (itPtr != NULL) {    	RunTclTraces(itPtr, NS_TCL_TRACE_FREECONN);    	itPtr->conn = NULL;    	itPtr->nsconn.flags = 0;    	PushInterp(itPtr);    	connPtr->itPtr = NULL;    }}/* *---------------------------------------------------------------------- * * NsTclRunAtClose -- * *	Run any registered connection at-close scripts.  * * Results: *	None.  * * Side effects: *	None. * *---------------------------------------------------------------------- */voidNsTclRunAtClose(NsInterp *itPtr){    Tcl_Interp    *interp = itPtr->interp;    AtClose       *atPtr;    while ((atPtr = itPtr->firstAtClosePtr) != NULL) {	itPtr->firstAtClosePtr = atPtr->nextPtr;	if (Tcl_EvalObjEx(interp, atPtr->objPtr, TCL_EVAL_DIRECT) != TCL_OK) {	    Ns_TclLogError(interp);	}	Tcl_DecrRefCount(atPtr->objPtr);	ns_free(atPtr);    }}/* *---------------------------------------------------------------------- * * PopInterp -- * *	Pop next avaialble virtual-server interp from the per-thread *	cache, allocating a new interp if necessary. * * Results: *	Pointer to next available NsInterp. * * Side effects: *	Will invoke alloc traces and, if the interp is new, create *	traces. * *---------------------------------------------------------------------- */static NsInterp *PopInterp(char *server){    static Ns_Cs lock;    NsServer *servPtr;    NsInterp *itPtr;    Tcl_HashEntry *hPtr;    /*     * Verify the server.  NULL (i.e., no server) is valid but     * a non-null, unknown server is an error.     */    if (server == NULL) {	servPtr = NULL;    } else {	servPtr = NsGetServer(server);	if (servPtr == NULL) {	    return NULL;	}    }    /*     * Pop the first interp off the list of availabe interps for     * the given virtual server on this thread.  If none exists,     * create and initialize a new interp.     */    hPtr = GetCacheEntry(servPtr);    itPtr = Tcl_GetHashValue(hPtr);    if (itPtr != NULL) {	Tcl_SetHashValue(hPtr, itPtr->nextPtr);    } else {    	if (nsconf.tcl.lockoninit) {	    Ns_CsEnter(&lock);    	}	(void) CreateInterp(&itPtr);	if (servPtr != NULL) {    	    itPtr->servPtr = servPtr;    	    NsTclAddServerCmds(itPtr->interp, itPtr);    	    RunTclTraces(itPtr, NS_TCL_TRACE_CREATE);    	    if (UpdateInterp(itPtr) != TCL_OK) {		Ns_TclLogError(itPtr->interp);    	    }	}    	if (nsconf.tcl.lockoninit) {	    Ns_CsLeave(&lock);    	}    }    itPtr->nextPtr = NULL;    /*     * Clear any pending async cancel message.     */    (void) Tcl_AsyncInvoke(itPtr->interp, TCL_OK);    /*     * Run allocation traces and evaluate the ns_init proc which by     * default updates the interp state with ns_ictl if necessary.     */    RunTclTraces(itPtr, NS_TCL_TRACE_ALLOCATE);    if (Tcl_EvalEx(itPtr->interp, "ns_init", -1, 0) != TCL_OK) {	Ns_TclLogError(itPtr->interp);    }    return itPtr;}/* *---------------------------------------------------------------------- * * PushInterp -- * *	Return a virtual-server interp to the per-thread interp * * Results: *	None. * * Side effects: *	Will invoke de-alloc traces. * *---------------------------------------------------------------------- */static voidPushInterp(NsInterp *itPtr){    Tcl_Interp *interp = itPtr->interp;    Tcl_HashEntry *hPtr;    /*     * Evaluate the cleanup script to perform various garbage collection     * and then either delete the interp or push it back on the     * per-thread list.     */    RunTclTraces(itPtr, NS_TCL_TRACE_DEALLOCATE);    if (Tcl_EvalEx(interp, "ns_cleanup", -1, 0) != TCL_OK) {	Ns_TclLogError(interp);    }    if (itPtr->delete) {	Ns_TclDestroyInterp(interp);    } else {	Tcl_ResetResult(interp);	hPtr = GetCacheEntry(itPtr->servPtr);	itPtr->nextPtr = Tcl_GetHashValue(hPtr);	Tcl_SetHashValue(hPtr, itPtr);    }}/* *---------------------------------------------------------------------- * * GetCacheEntry -- * *      Get hash entry in per-thread interp cache for given virtual *	 server * * Results: *      Pointer to hash entry. * * Side effects: *	None. * *---------------------------------------------------------------------- */static Tcl_HashEntry *GetCacheEntry(NsServer *servPtr){    Tcl_HashTable *tablePtr;    int ignored;    tablePtr = Ns_TlsGet(&tls);    if (tablePtr == NULL) {	tablePtr = ns_malloc(sizeof(Tcl_HashTable));	Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS);	Ns_TlsSet(&tls, tablePtr);    }    return Tcl_CreateHashEntry(tablePtr, (char *) servPtr, &ignored);}/* *---------------------------------------------------------------------- * * EvalTrace -- * *      Eval the given script from being called as a Tcl Init callback. * * Results: *      Status from script eval. * * Side effects: *	Depends on script. * *---------------------------------------------------------------------- */static intEvalTrace(Tcl_Interp *interp, void *arg){    ScriptTrace *stPtr = arg;    return Tcl_EvalEx(interp, stPtr->script, stPtr->length, 0);}/* *---------------------------------------------------------------------- * * CreateInterp -- * *      Create a new AOLserver interp. * * Results: *      Pointer to new NsInterp. * * Side effects: *	NsInterp structure for new interp will be stored in itPtrPt *	if not null. * *---------------------------------------------------------------------- */static Tcl_Interp *CreateInterp(NsInterp **itPtrPtr){    NsInterp *itPtr;    Tcl_Interp *interp;    /*     * Create and initialize a basic Tcl interp.     */    interp = Tcl_CreateInterp();    Tcl_InitMemory(interp);    if (Tcl_Init(interp) != TCL_OK) {	Ns_TclLogError(interp);    }    /*     * Allocate and associate a new NsInterp struct for the interp.     */    itPtr = NewInterpData(interp);    if (itPtrPtr != NULL) {	*itPtrPtr = itPtr;    }    return interp;}/* *---------------------------------------------------------------------- * * NewInterpData -- * *      Create a new NsInterp struct for the given interp, adding *	core AOLserver commands and associating it with the interp. * * Results: *      Pointer to new NsInterp struct. * * Side effects: *	Will add core AOLserver commands to given interp. * *---------------------------------------------------------------------- */static NsInterp *NewInterpData(Tcl_Interp *interp){    static volatile int initialized = 0;    static unsigned int next = 0;    NsInterp *itPtr;    int new, tid;    /*     * Core one-time AOLserver initialization to add a few Tcl_Obj     * types.  These calls cannot be in NsTclInit above because     * Tcl is not fully initialized at libnsd load time.     */    if (!initialized) {	Ns_MasterLock();	if (!initialized) {	    NsTclInitQueueType();	    NsTclInitAddrType();	    NsTclInitTimeType();	    NsTclInitCacheType();	    NsTclInitKeylistType();	    initialized = 1;	}	Ns_MasterUnlock();    }    /*     * Allocate and initialize a new NsInterp struct.     */    itPtr = ns_calloc(1, sizeof(NsInterp));    itPtr->interp = interp;    itPtr->servPtr = NULL;    tid = Ns_GetThreadId();    Ns_MutexLock(&ilock);    do {    	sprintf(itPtr->name, "nsinterp:%d:%d", tid, next++);    	itPtr->hPtr = Tcl_CreateHashEntry(&interps, itPtr->name, &new);    } while (!new);    Tcl_SetHashValue(itPtr->hPtr, itPtr);    Ns_MutexUnlock(&ilock);    itPtr->cancel = Tcl_AsyncCreate(AsyncCancel, itPtr);    Tcl_InitHashTable(&itPtr->sets, TCL_STRING_KEYS);    Tcl_InitHashTable(&itPtr->chans, TCL_STRING_KEYS);	    Tcl_InitHashTable(&itPtr->https, TCL_STRING_KEYS);	    /*     * Associate the new NsInterp with this interp.  At interp delete     * time, Tcl will call FreeInterpData to cleanup the struct.     */    Tcl_SetAssocData(interp, "ns:data", FreeInterpData, itPtr);    /*     * Add core AOLserver commands.     */    NsTclAddCmds(interp, itPtr);    Tcl_PkgProvide(interp, "Nsd", NS_VERSION);    return itPtr;}/* *---------------------------------------------------------------------- * * UpdateServerInterpData -- * *      Update the state (procs, namespaces) of an interp.  The current *      state of interps for a virtual server is defined by a script *      used to add any needed procs, vars, package calls, etc.  By *	default, the state script for a virtual server is created at *	startup by an interp which sources all cooresponding *	configuration, saves the resulting definitions as a script via *	"ns_ictl save" (see nsd/init.tcl for details), and marks *	itself for deletion as it's only purpose was to create the *	initial state.  To detect possible change of the script at *	runtime through other interps (e.g., through a call to *	ns_eval), an epoch counter is maintained and updated each time *	a new script is saved.  New interps are initialized with epoch *	0 and always detect the need to evaluate the state script *	below.  Existing interps can call UpdateInterp to detect *	runtime config changes via "ns_ictl update" which, by default, *	is called in the "ns_cleanup" garbage collection script called *	at interp deallocation time. * * Results: *      Tcl result from update script if invoked, TCL_OK otherwise. * * Side effects: *	Will update procs when epoch changes. * *---------------------------------------------------------------------- */static intUpdateInterp(NsInterp *itPtr){    int result = TCL_OK;    /*     * A reader-writer lock is used on the assumption updates are     * rare and likley expensive to evaluate if the virtual server     * contains significant state.     */    Ns_RWLockRdLock(&itPtr->servPtr->tcl.lock);    if (itPtr->epoch != itPtr->servPtr->tcl.epoch) {	result = Tcl_EvalEx(itPtr->interp, itPtr->servPtr->tcl.script,		    	    itPtr->servPtr->tcl.length, TCL_EVAL_GLOBAL);	itPtr->epoch = itPtr->servPtr->tcl.epoch;    }    Ns_RWLockUnlock(&itPtr->servPtr->tcl.lock);    return result;}/* *---------------------------------------------------------------------- * * FreeInterpData -- * *      Tcl assoc data callback to destroy the per-interp NsInterp *      structure at interp delete time. * * Results: *      None. * * Side effects: *	None. * *---------------------------------------------------------------------- */static voidFreeInterpData(ClientData arg, Tcl_Interp *interp){    NsInterp *itPtr = arg;    Tcl_AsyncDelete(itPtr->cancel);    NsFreeAdp(itPtr);    Tcl_DeleteHashTable(&itPtr->sets);    Tcl_DeleteHashTable(&itPtr->chans);    Tcl_DeleteHashTable(&itPtr->https);    Ns_MutexLock(&ilock);    Tcl_DeleteHashEntry(itPtr->hPtr);    Ns_MutexUnlock(&ilock);    ns_free(itPtr);}/* *---------------------------------------------------------------------- * * DeleteInterps -- * *      Delete all per-thread interps at thread exit time. * * Results: *      None. * * Side effects: *	None. * *---------------------------------------------------------------------- */static voidDeleteInterps(void *arg){    Tcl_HashTable *tablePtr = arg;    Tcl_HashEntry *hPtr;    Tcl_HashSearch search;    NsInterp *itPtr;    hPtr = Tcl_FirstHashEntry(tablePtr, &search);    while (hPtr != NULL) {	while ((itPtr = Tcl_GetHashValue(hPtr)) != NULL) {	    Tcl_SetHashValue(hPtr, itPtr->nextPtr);	    Ns_TclDestroyInterp(itPtr->interp);	}	hPtr = Tcl_NextHashEntry(&search);    }    Tcl_DeleteHashTable(tablePtr);    ns_free(tablePtr);}/* *---------------------------------------------------------------------- * * RunTclTraces -- * *  	Execute trace callbacks. * * Results: *	None. * * Side effects: *	Depeneds on callbacks. * *---------------------------------------------------------------------- */ static voidRunTclTraces(NsInterp *itPtr, int why){    TclTrace *tracePtr;    if (itPtr->servPtr != NULL) {    	tracePtr = itPtr->servPtr->tcl.firstTracePtr;    	while (tracePtr != NULL) {	    if ((tracePtr->when & why)) {		if ((*tracePtr->proc)(itPtr->interp, tracePtr->arg) != TCL_OK) {	            Ns_TclLogError(itPtr->interp);		}	    }	    tracePtr = tracePtr->nextPtr;	}    }}static intAsyncCancel(ClientData arg, Tcl_Interp *interp, int code){    NsInterp *itPtr = arg;    Tcl_ResetResult(itPtr->interp);    Tcl_SetResult(itPtr->interp, "async cancel", TCL_STATIC);    return TCL_ERROR;}