/*
 * The contents of this file are subject to the AOLserver Public License
 * Version 1.1 (the "License"); you may not use this file except in
 * compliance with the License. You may obtain a copy of the License at
 * http://aolserver.com/.
 *
 * Software distributed under the License is distributed on an "AS IS"
 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
 * the License for the specific language governing rights and limitations
 * under the License.
 *
 * The Original Code is AOLserver Code and related documentation
 * distributed by AOL.
 * 
 * The Initial Developer of the Original Code is America Online,
 * Inc. Portions created by AOL are Copyright (C) 1999 America Online,
 * Inc. All Rights Reserved.
 *
 * Alternatively, the contents of this file may be used under the terms
 * of the GNU General Public License (the "GPL"), in which case the
 * provisions of GPL are applicable instead of those above.  If you wish
 * to allow use of your version of this file only under the terms of the
 * GPL and not to allow others to use your version of this file under the
 * License, indicate your decision by deleting the provisions above and
 * replace them with the notice and other provisions required by the GPL.
 * If you do not delete the provisions above, a recipient may use your
 * version of this file under either the License or the GPL.
 */

/* 
 * tclinit.c --
 *
 *	Initialization and resource management routines for Tcl.  This
 *	code provides for three types of AOLserver extended Tcl
 *	interps:
 *
 *	1. First, basic interps created with Ns_TclCreateInterp or
 *	initialized with Ns_TclInit.  These interps include "core" Tcl
 *	and AOLserver commands and are normally used simply to
 *	evaluate the config file.
 *
 *	2. Next, virtual server interps allocated from per-thread
 *	caches using Ns_TclAllocateInterp and returned via
 *	Ns_TclDeAllocateInterp.  These interps include all the
 *	commands of the basic interp, commands useful for virtual
 *	server environments, and any commands added as a result of
 *	loadable module initialization callbacks.  These interps are
 *	normally used during connection processing but can also be
 *	used outside a connection, e.g., in a scheduled procedure or
 *	detached background thread.
 *
 *	3. Finally, connection interps accessed  with
 *	Ns_TclGetConnInterp.  These interps are virtual server interps
 *	but managed along with a connection, having access to
 *	connection specific data structures (e.g., via ns_conn) and
 *	released automatically during connection cleanup.  This type
 *	of interp is used for ns_register_filter and ns_register_proc
 *	callback scripts as well as for ADP pages.  The same interp is
 *	used throughout the connection, for all filters, procs, and/or
 *	ADP pages.
 *
 *	Note the need to initialize Tcl state (i.e., procs, vars,
 *	packages, etc.) specific to a virtual server, later to copy
 *	this state to new interps when created, and garbage collection
 *	and end-of-connection cleanup facilities add quite a bit of
 *	complexity and confusion to the code.  See the comments in
 *	Ns_TclRegisterTrace, Ns_TclAllocateInterp, and NsTclICtlObjCmd
 *	and review the code in init.tcl for more details.
 *
 *	Note also the role of the NsInterp structure.  This single
 *	structure provides storage necessary for all AOLserver
 *	commands, core or virtual-server.  The structure is allocated
 *	for each new interp and passed as the ClientData argument to
 *	all AOLserver commands (see InitData and NsTclAddCmds in
 *	tclcmds.c for details).  Both for cases where the ClientData
 *	isn't available and to ensure proper cleanup of the structure
 *	when the interp is deleted, the NsInterp is managed by the
 *	interp via the Tcl assoc data interface under the name
 *	"ns:data" and accessible by NsGetInterpData.
 */

static const char *RCSID = "@(#) $Header: /cvsroot/aolserver/aolserver/nsd/tclinit.c,v 1.52 2006/06/02 18:51:49 jgdavidson Exp $, compiled: " __DATE__ " " __TIME__;

#include "nsd.h"

/*
 * The following structure maintains per-thread context to support Tcl
 * including a table of cached interps by server and a shared async
 * cancel object.
 */

typedef struct TclData {
    Tcl_AsyncHandler cancel;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable interps;
} TclData;

/*
 * The following structure maintains interp callback traces. The traces
 * are normally registered during server startup and invoked later for
 * virutal server interps at specific points in the lifetime of the
 * interp.  Initialization callbacks (create, alloc, getconn) are called
 * in FIFO order while finalization callbacks (freeconn, dealloc,
 * delete) are called in LIFO order. In addition, script callbacks are
 * invoked after non-script callbacks.  A
 * common trace would be an "create" trace to add commands in a loadable
 * C module, e.g., the "ns_accesslog" command in nslog.
 */

typedef struct TclTrace {
    struct TclTrace	 *prevPtr;
    struct TclTrace	 *nextPtr;
    Ns_TclTraceProc      *proc;
    void		 *arg;  
    int			  when;
} TclTrace;

/*
 * The following structure maintains Tcl-script based traces.
 */

typedef struct ScriptTrace {
    int  length;
    char script[1];
} ScriptTrace;

/*
 * The following structure maintains callbacks registered with the
 * Ns_TclRegisterDeffered rouinte to invoke during interp deallocation
 * Unlike traces, these callbacks are one-shot events and invoked in
 * FIFO order (LIFO would probably have been better). In practice this
 * API is rarely used. Instead, more specific garbage collection schemes
 * should be used with "ns_ictl trace deallocate".
 */

typedef struct Defer {
    struct Defer *nextPtr;
    Ns_TclDeferProc *proc;
    void *arg;
} Defer;

/*
 * The following structure maintains scripts registered via ns_atclose
 * to invoke when the connection is closed.  The scripts are invoked in
 * LIFO order.  As with the Ns_TclRegisteredDeferred callbacks, this
 * interface is rarely used.
 */

typedef struct AtClose {
    struct AtClose *nextPtr;
    Tcl_Obj *objPtr;
} AtClose;

/*
 * The following defines a multi-thread aware Tcl package.
 */

typedef struct Package {
    char *name;
    int exact;
    char version[1];
} Package;

/*
 * Static functions defined in this file.
 */

static TclData *GetData(void);
static Ns_TlsCleanup DeleteData;
static Tcl_Interp *CreateInterp(NsServer *server);
static int InitData(Tcl_Interp *interp, NsServer *servPtr);
static Tcl_InterpDeleteProc FreeData;
static NsInterp *PopInterp(char *server);
static void PushInterp(NsInterp *itPtr);
static Tcl_HashEntry *GetCacheEntry(NsServer *servPtr);
static void RunTraces(NsInterp *itPtr, int why);
static void ForeachTrace(NsInterp *itPtr, int why, int append);
static void DoTrace(Tcl_Interp *interp, TclTrace *tracePtr, int append);
static int EvalTrace(Tcl_Interp *interp, void *arg);
static int RegisterAt(Ns_TclTraceProc *proc, void *arg, int when);
static Tcl_AsyncProc AsyncCancel;
static Ns_TclTraceProc PkgRequire;

/*
 * Static variables defined in this file.
 */

static Ns_Tls tls;		/* Slot for per-thread Tcl interp cache. */
static Tcl_HashTable threads;	/* Table of threads with nsd-based interps. */
static Ns_Mutex tlock;		/* Lock around threads table. */


/*
 *----------------------------------------------------------------------
 *
 * NsInitTcl --
 *
 *	Initialize the Nsd Tcl package.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
NsInitTcl(void)
{
    /*
     * Allocate the thread storage slot for the table of interps
     * per-thread. At thread exit, DeleteData will be called
     * to free any interps remaining on the thread cache
     * and remove the async cancel handler.
     */

    Ns_TlsAlloc(&tls, DeleteData);

    /*
     * Initialize the table of all threads with active TclData
     * and the one-time init table.
     */

    Tcl_InitHashTable(&threads, TCL_ONE_WORD_KEYS);
    Ns_MutexSetName(&tlock, "ns:threads");
}


/*
 *----------------------------------------------------------------------
 *
 * Ns_TclCreateInterp --
 *
 *      Create a new interp with basic Nsd package.
 *
 * Results:
 *      Pointer to new interp.
 *
 * Side effects:
 *	See CreateInterp.
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Ns_TclCreateInterp(void)
{
    return Ns_TclAllocateInterp(NULL);
}


/*
 *----------------------------------------------------------------------
 *
 * Ns_TclInit --
 *
 *      Initialize an interp with the global server context.
 *
 * Results:
 *      TCL_OK or TCL_ERROR on init error.
 *
 * Side effects:
 *	See InitData.
 *
 *----------------------------------------------------------------------
 */

int
Ns_TclInit(Tcl_Interp *interp)
{
    NsServer *servPtr = NsGetServer(NULL);

    return InitData(interp, servPtr);
}


/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 *----------------------------------------------------------------------
 */

int
Nsd_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.
 *
 *----------------------------------------------------------------------
 */

int
Ns_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.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	See notes on garbage collection in PushInterp.
 *
 *----------------------------------------------------------------------
 */

void
Ns_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);
	RunTraces(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.
 *
 *----------------------------------------------------------------------
 */

void
Ns_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.
 *
 *----------------------------------------------------------------------
 */

void
Ns_TclDestroyInterp(Tcl_Interp *interp)
{
    NsInterp *itPtr = NsGetInterpData(interp);

    if (itPtr != NULL) {
    	RunTraces(itPtr, NS_TCL_TRACE_DELETE);
    }
    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.
 *
 *----------------------------------------------------------------------
 */

void
Ns_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.
 *
 *----------------------------------------------------------------------
 */
 
int
Ns_TclRegisterTrace(char *server, Ns_TclTraceProc *proc, void *arg, int when)
{
    TclTrace *tracePtr;
    NsServer *servPtr;

    servPtr = NsGetServer(server);
    if (servPtr == NULL) {
	return NS_ERROR;
    }
    tracePtr = ns_malloc(sizeof(TclTrace));
    tracePtr->proc = proc;
    tracePtr->arg = arg;
    tracePtr->when = when;
    tracePtr->nextPtr = NULL;
    Ns_RWLockWrLock(&servPtr->tcl.tlock);
    tracePtr->prevPtr = servPtr->tcl.lastTracePtr;
    servPtr->tcl.lastTracePtr = tracePtr;
    if (tracePtr->prevPtr != NULL) {
	tracePtr->prevPtr->nextPtr = tracePtr;
    } else {
	servPtr->tcl.firstTracePtr = tracePtr;
    }
    Ns_RWLockUnlock(&servPtr->tcl.tlock);
    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.
 *
 *----------------------------------------------------------------------
 */

int
Ns_TclRegisterAtCreate(Ns_TclTraceProc *proc, void *arg)
{
    return RegisterAt(proc, arg, NS_TCL_TRACE_CREATE);
}

int
Ns_TclRegisterAtCleanup(Ns_TclTraceProc *proc, void *arg)
{
    return RegisterAt(proc, arg, NS_TCL_TRACE_DEALLOCATE);
}

int
Ns_TclRegisterAtDelete(Ns_TclTraceProc *proc, void *arg)
{
    return RegisterAt(proc, arg, NS_TCL_TRACE_DELETE);
}

static int
RegisterAt(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.
 *
 *----------------------------------------------------------------------
 */

int
Ns_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.
 *
 *----------------------------------------------------------------------
 */

void
Ns_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 : NULL);
}


/*
 *----------------------------------------------------------------------
 *
 * Ns_TclInterpServer --
 *
 *	Return the name of the server. 
 *
 * Results:
 *	Server name. 
 *
 * Side effects:
 *	None. 
 *
 *----------------------------------------------------------------------
 */

char *
Ns_TclInterpServer(Tcl_Interp *interp)
{
    NsInterp *itPtr = NsGetInterpData(interp);
    
    return (itPtr ? itPtr->servPtr->server : 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 = Tcl_GetStringResult(interp);
    }
    Ns_Log(Error, "Tcl exception:\n%s", 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:
 *      Always TCL_OK.
 *
 * Side effects:
 *	Module will be initialized by the init script later.
 *
 *----------------------------------------------------------------------
 */

int
Ns_TclInitModule(char *server, char *module)
{
    NsServer *servPtr = NsGetServer(server);

    if (servPtr == NULL) {
	return NS_ERROR;
    }
    Tcl_DStringAppendElement(&servPtr->tcl.modules, module);
    return NS_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * NsGetInterpServer --
 *
 *      Get server for given interp.
 *
 * Results:
 *      TCL_OK if interp has a server, TCL_ERROR otherwise.
 *
 * Side effects:
 *	Given serverPtr will be updated with pointer to server string.
 *
 *----------------------------------------------------------------------
 */

int
NsTclGetServer(NsInterp *itPtr, char **serverPtr)
{
    if (itPtr->servPtr->server == NULL) {
	Tcl_SetResult(itPtr->interp, "no server", TCL_STATIC);
	return TCL_ERROR;
    }
    *serverPtr = itPtr->servPtr->server;
    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.
 *
 *----------------------------------------------------------------------
 */

int
NsTclICtlObjCmd(ClientData arg, Tcl_Interp *interp, int objc, Tcl_Obj **objv)
{
    NsInterp *itPtr = arg;
    NsServer *servPtr = itPtr->servPtr;
    Defer    *deferPtr;
    ScriptTrace *stPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    TclData *dataPtr;
    Tcl_Obj *objPtr, *listPtr;
    Package *pkgPtr;
    int	      when, length, result, tid, new, exact;
    char     *script, *name, *pattern, *version;
    static CONST char *opts[] = {
	"addmodule", "cleanup", "epoch", "get", "getmodules", "save",
	"update", "oncreate", "oncleanup", "oninit", "ondelete", "trace",
	"threads", "cancel", "runtraces", "gettraces", "package", "once",
	NULL
    };
    enum {
	IAddModuleIdx, ICleanupIdx, IEpochIdx, IGetIdx, IGetModulesIdx,
	ISaveIdx, IUpdateIdx, IOnCreateIdx, IOnCleanupIdx, IOnInitIdx,
        IOnDeleteIdx, ITraceIdx, IThreadsIdx, ICancelIdx, IRunIdx, 
	IGetTracesIdx, IPackageIdx, IOnceIdx
    } opt;
    static CONST char *popts[] = {
	"require", "names", NULL
    };
    enum {
	PRequireIdx, PNamesIdx
    } _nsmayalias popt;
    static CONST char *topts[] = {
	"create", "delete", "allocate",
	"deallocate", "getconn", "freeconn", NULL
    };
    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
    };
    enum {
    	TCreateIdx, TDeleteIdx, TAllocateIdx,
	TDeAllocateIdx, TGetConnIdx, TFreeConnIdx
    } _nsmayalias topt;

    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;
	}
	Ns_TclInitModule(servPtr->server, Tcl_GetString(objv[2]));
	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_SetResult(interp, servPtr->tcl.modules.string, TCL_VOLATILE);
	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.slock);
	objPtr = Tcl_NewStringObj(servPtr->tcl.script, servPtr->tcl.length);
	Ns_RWLockUnlock(&servPtr->tcl.slock);
	Tcl_SetObjResult(interp, objPtr);
	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.slock);
	Tcl_SetIntObj(Tcl_GetObjResult(interp), servPtr->tcl.epoch);
	Ns_RWLockUnlock(&servPtr->tcl.slock);
	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.slock);
	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.slock);
	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;
	}
    	Ns_RWLockRdLock(&servPtr->tcl.slock);
    	if (itPtr->epoch != servPtr->tcl.epoch) {
	    result = Tcl_EvalEx(itPtr->interp, servPtr->tcl.script,
		    	    	servPtr->tcl.length, TCL_EVAL_GLOBAL);
	    itPtr->epoch = servPtr->tcl.epoch;
    	}
    	Ns_RWLockUnlock(&servPtr->tcl.slock);
	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 IPackageIdx:
        if (objc < 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "option ?args?");
	    return TCL_ERROR;
        }
    	if (Tcl_GetIndexFromObj(interp, objv[2], popts, "option", 0,
			    (int *) &popt) != TCL_OK) {
	    return TCL_ERROR;
    	}
	switch (popt) {
	case PNamesIdx:
	    if (objc > 3) {
		pattern = Tcl_GetString(objv[3]);
	    } else {
		pattern = NULL;
	    }
	    listPtr = Tcl_NewObj();
	    Ns_MutexLock(&servPtr->tcl.plock);
	    hPtr = Tcl_FirstHashEntry(&servPtr->tcl.packages, &search);
	    while (hPtr != NULL) {
		name = Tcl_GetHashKey(&servPtr->tcl.packages, hPtr);
		if (pattern == NULL || Tcl_StringMatch(name, pattern)) {
		    Tcl_ListObjAppendElement(interp, listPtr,
					     Tcl_NewStringObj(name, -1));
		}
		hPtr = Tcl_NextHashEntry(&search);
	    }
	    Ns_MutexUnlock(&servPtr->tcl.plock);
	    Tcl_SetObjResult(interp, listPtr);
	    break;

	case PRequireIdx:
	    if (objc < 4 || objc > 6) {
badargs:
            	Tcl_WrongNumArgs(interp, 3, objv, "?-exact? package ?version?");
		return TCL_ERROR;
	    }
	    exact = 0;
	    name = Tcl_GetString(objv[3]);
	    if (STREQ(name, "-exact")) {
		if (objc < 5) {
		    goto badargs;
		}
		--objc;
		++objv;
		exact = 1;
		name = Tcl_GetString(objv[3]);
	    }
	    if (objc < 5) {
		version = NULL;
	    } else {
		version = Tcl_GetString(objv[4]);
	    }

	    /*
	     * Confirm the package can be loaded and determine version.
	     */

	    version = Tcl_PkgRequire(interp, name, version, exact);
	    if (version == NULL) {
		return TCL_ERROR;
	    }
	    Ns_MutexLock(&servPtr->tcl.plock);
	    hPtr = Tcl_CreateHashEntry(&servPtr->tcl.packages, name, &new);
	    if (!new) {
		/*
		 * Confirm current registered package is the same version.
		 */

		pkgPtr = Tcl_GetHashValue(hPtr);
		if (!STREQ(pkgPtr->version, version)) {
		    Tcl_AppendResult(interp, "version conflict for package \"",
			name, "\": have ", pkgPtr->version, ", need ",
			version, NULL);
		    pkgPtr = NULL;
		}
	    } else {
		/*
		 * Register new package.
		 */
	    	pkgPtr = ns_malloc(sizeof(Package) + strlen(version));
		strcpy(pkgPtr->version, version);
	    	pkgPtr->name = Tcl_GetHashKey(&servPtr->tcl.packages, hPtr);
	    	pkgPtr->exact = exact;
	    	Tcl_SetHashValue(hPtr, pkgPtr);
		Ns_TclRegisterTrace(servPtr->server, PkgRequire, pkgPtr,
				    NS_TCL_TRACE_ALLOCATE);
	    }
	    Ns_MutexUnlock(&servPtr->tcl.plock);
	    if (pkgPtr == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetResult(interp, pkgPtr->version, TCL_STATIC);
	    break;
	}
	break;

    case IOnceIdx:
	if (objc < 4) {
            Tcl_WrongNumArgs(interp, 3, objv, "name script");
	    return TCL_ERROR;
	}
	name = Tcl_GetString(objv[2]);
	Ns_CsEnter(&servPtr->tcl.olock);
	hPtr = Tcl_CreateHashEntry(&servPtr->tcl.once, name, &new);
	if (new) {
	    result = Tcl_EvalObjEx(interp, objv[3], TCL_EVAL_DIRECT);
	    if (result != TCL_OK) {
		Tcl_DeleteHashEntry(hPtr);
	    }
	}
	Ns_CsLeave(&servPtr->tcl.olock);
	if (result != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_SetBooleanObj(Tcl_GetObjResult(interp), new);
	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. */
	    when = 0;
	    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:
	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 IGetTracesIdx:
    case IRunIdx:
        if (objc != 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "which");
	    return TCL_ERROR;
        }
    	if (Tcl_GetIndexFromObj(interp, objv[2], topts, "traces", 0,
			    (int *) &topt) != TCL_OK) {
	    return TCL_ERROR;
    	}
	ForeachTrace(itPtr, twhen[topt], (opt == IGetTracesIdx));
	break;

    case IThreadsIdx:
        if (objc > 2) {
            Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
        }
	listPtr = Tcl_NewObj();
	Ns_MutexLock(&tlock);
	hPtr = Tcl_FirstHashEntry(&threads, &search);
	while (hPtr != NULL) {
	    tid = (int) Tcl_GetHashKey(&threads, hPtr);
	    objPtr = Tcl_NewIntObj(tid);
	    Tcl_ListObjAppendElement(interp, listPtr, objPtr);
	    hPtr = Tcl_NextHashEntry(&search);
	}
	Ns_MutexUnlock(&tlock);
	Tcl_SetObjResult(interp, listPtr);
	break;

    case ICancelIdx:
	if (objc != 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "tid");
	    return TCL_ERROR;
        }
	if (Tcl_GetIntFromObj(interp, objv[2], &tid) != TCL_OK) {
	    return TCL_ERROR;
	}
	Ns_MutexLock(&tlock);
	hPtr = Tcl_FindHashEntry(&threads, (char *) tid);
	if (hPtr != NULL) {
	    dataPtr = Tcl_GetHashValue(hPtr);
	    Tcl_AsyncMark(dataPtr->cancel);
	}
	Ns_MutexUnlock(&tlock);
	if (hPtr == NULL) {
	    Tcl_AppendResult(interp, "no such active thread: ",
			     Tcl_GetString(objv[2]), 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.
 *
 *----------------------------------------------------------------------
 */

int
NsTclAtCloseObjCmd(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 (NsTclGetConn(itPtr, NULL) != TCL_OK) {
	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. 
 *
 *----------------------------------------------------------------------
 */

int
NsTclMarkForDeleteObjCmd(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;
}


/*
 *----------------------------------------------------------------------
 *
 * NsTclInitServer --
 *
 *	Evaluate server initialization script at startup.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	See init script (normally init.tcl).
 *
 *----------------------------------------------------------------------
 */

void
NsTclInitServer(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.
 *
 *----------------------------------------------------------------------
 */

void
NsFreeConnInterp(Conn *connPtr)
{
    NsInterp *itPtr = connPtr->itPtr;

    if (itPtr != NULL) {
    	RunTraces(itPtr, NS_TCL_TRACE_FREECONN);
    	itPtr->conn = NULL;
    	itPtr->nsconn.flags = 0;
    	connPtr->itPtr = NULL;
    	PushInterp(itPtr);
    }
}


/*
 *----------------------------------------------------------------------
 *
 * NsTclRunAtClose --
 *
 *	Run any registered connection at-close scripts. 
 *
 * Results:
 *	None. 
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
NsTclRunAtClose(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;
    Tcl_Interp *interp;
    int epoch;

    /*
     * Verify the server.  NULL (i.e., no server) is valid but
     * a non-null, unknown server is an error and get the current
     * epoch.
     */

    servPtr = NsGetServer(server);
    if (servPtr == NULL) {
	return NULL;
    }
    Ns_RWLockRdLock(&servPtr->tcl.slock);
    epoch = servPtr->tcl.epoch;
    Ns_RWLockUnlock(&servPtr->tcl.slock);

    /*
     * Dump any interps with an invalid epoch and then pop the first
     * available interp or create a new interp.
     */

    hPtr = GetCacheEntry(servPtr);
    if (epoch == 0) {
	/* NB: Epoch 0 indicates legacy module config disabled. */
	itPtr = Tcl_GetHashValue(hPtr);
    } else {
    	NsInterp *validPtr = NULL;
    	while ((itPtr = Tcl_GetHashValue(hPtr)) != NULL) {
	    Tcl_SetHashValue(hPtr, itPtr->nextPtr);
	    if (itPtr->epoch != epoch) {
	        Ns_TclDestroyInterp(itPtr->interp);
	    } else {
	        itPtr->nextPtr = validPtr;
	    	validPtr = itPtr;
	    }
	}
    	itPtr = validPtr;
    }
    if (itPtr != NULL) {
	Tcl_SetHashValue(hPtr, itPtr->nextPtr);
    } else {
    	if (nsconf.tcl.lockoninit) {
	    Ns_CsEnter(&lock);
    	}
	interp = CreateInterp(servPtr);
	itPtr = NsGetInterpData(interp);
    	RunTraces(itPtr, NS_TCL_TRACE_CREATE);
    	if (nsconf.tcl.lockoninit) {
	    Ns_CsLeave(&lock);
    	}
    }
    itPtr->nextPtr = NULL;
    interp = itPtr->interp;

    /*
     * Clear any pending async cancel message, run the traces and
     * set the epoch if a create and/or allocate traces hasn't
     * already done so.
     */

    (void) Tcl_AsyncInvoke(interp, TCL_OK);
    RunTraces(itPtr, NS_TCL_TRACE_ALLOCATE);
    if (itPtr->epoch != epoch) {
	itPtr->epoch = epoch;
    }
    return itPtr;
}


/*
 *----------------------------------------------------------------------
 *
 * PushInterp --
 *
 *	Return a virtual-server interp to the per-thread interp
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Will invoke de-alloc traces.
 *
 *----------------------------------------------------------------------
 */

static void
PushInterp(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.
     */

    RunTraces(itPtr, NS_TCL_TRACE_DEALLOCATE);
    if (itPtr->delete) {
	Ns_TclDestroyInterp(interp);
    } else {
	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)
{
    TclData *dataPtr = GetData();
    int new;

    return Tcl_CreateHashEntry(&dataPtr->interps, (char *) servPtr, &new);
}


/*
 *----------------------------------------------------------------------
 *
 * EvalTrace --
 *
 *      Eval the given script from being called as a Tcl Init callback.
 *
 * Results:
 *      Status from script eval.
 *
 * Side effects:
 *	Depends on script.
 *
 *----------------------------------------------------------------------
 */

static int
EvalTrace(Tcl_Interp *interp, void *arg)
{
    ScriptTrace *stPtr = arg;

    return Tcl_EvalEx(interp, stPtr->script, stPtr->length, 0);
}


/*
 *----------------------------------------------------------------------
 *
 * CreateInterp --
 *
 *      Create a new interp with the Nsd package.
 *
 * Results:
 *      Pointer to new Tcl_Interp.
 *
 * Side effects:
 *	Will log an error message on core Tcl and/or Nsd package init
 *	failure.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Interp *
CreateInterp(NsServer *servPtr)
{
    Tcl_Interp *interp;

    interp = Tcl_CreateInterp();
    Tcl_InitMemory(interp);
    if (Tcl_Init(interp) != TCL_OK || InitData(interp, servPtr) != TCL_OK) {
	Ns_TclLogError(interp);
    }
    return interp;
}


/*
 *----------------------------------------------------------------------
 *
 * InitData --
 *
 *      Initialize and provide the Nsd package for given interp,
 * 	associating it with a specific virtual server, if any.
 *
 * Results:
 *      Return code of Tcl_PkgProvide.
 *
 * Side effects:
 *	Will add Nsd package commands to given interp.
 *
 *----------------------------------------------------------------------
 */

static int
InitData(Tcl_Interp *interp, NsServer *servPtr)
{
    static volatile int initialized = 0;
    NsInterp *itPtr;

    /*
     * 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_LibInit();
	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 = servPtr;
    Tcl_InitHashTable(&itPtr->sets, TCL_STRING_KEYS);
    Tcl_InitHashTable(&itPtr->chans, TCL_STRING_KEYS);	
    Tcl_InitHashTable(&itPtr->https, TCL_STRING_KEYS);	
    NsAdpInit(itPtr);
    itPtr->adp.cwd = Ns_PageRoot(servPtr->server);

    /*
     * Associate the new NsInterp with this interp.  At interp delete
     * time, Tcl will call FreeData to cleanup the struct.
     */

    Tcl_SetAssocData(interp, "ns:data", FreeData, itPtr);

    /*
     * Ensure the per-thread data with async cancel handle is allocated.
     */

    (void) GetData();

    /*
     * Add core AOLserver commands.
     */

    NsTclAddCmds(interp, itPtr);
    return Tcl_PkgProvide(interp, "Nsd", NS_VERSION);
}


/*
 *----------------------------------------------------------------------
 *
 * FreeData --
 *
 *      Tcl assoc data callback to destroy the per-interp NsInterp
 *      structure at interp delete time.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
FreeData(ClientData arg, Tcl_Interp *interp)
{
    NsInterp *itPtr = arg;

    NsAdpFree(itPtr);
    Tcl_DeleteHashTable(&itPtr->sets);
    Tcl_DeleteHashTable(&itPtr->chans);
    Tcl_DeleteHashTable(&itPtr->https);
    ns_free(itPtr);
}


/*
 *----------------------------------------------------------------------
 *
 * GetData --
 *
 *	Return the per-thread Tcl data structure for current thread.
 *
 * Results:
 *	Pointer to TclData structure.
 *
 * Side effects:
 *	Will allocate and initialize TclData struct if necessary.
 *
 *----------------------------------------------------------------------
 */

static TclData *
GetData(void)
{
    TclData *dataPtr;
    int tid, new;

    dataPtr = Ns_TlsGet(&tls);
    if (dataPtr == NULL) {
	dataPtr = ns_malloc(sizeof(TclData));
	dataPtr->cancel = Tcl_AsyncCreate(AsyncCancel, NULL);
	Tcl_InitHashTable(&dataPtr->interps, TCL_ONE_WORD_KEYS);
	tid = Ns_ThreadId();
	Ns_MutexLock(&tlock);
	dataPtr->hPtr = Tcl_CreateHashEntry(&threads, (char *) tid, &new);
	Tcl_SetHashValue(dataPtr->hPtr, dataPtr);
	Ns_MutexUnlock(&tlock);
	Ns_TlsSet(&tls, dataPtr);
    }
    return dataPtr;
}


/*
 *----------------------------------------------------------------------
 *
 * DeleteData --
 *
 *      Delete all per-thread data at thread exit time.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteData(void *arg)
{
    TclData *dataPtr = arg;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    NsInterp *itPtr;

    Ns_MutexLock(&tlock);
    Tcl_DeleteHashEntry(dataPtr->hPtr);
    Ns_MutexUnlock(&tlock);
    hPtr = Tcl_FirstHashEntry(&dataPtr->interps, &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(&dataPtr->interps);
    Tcl_AsyncDelete(dataPtr->cancel);
    ns_free(dataPtr);
}


/*
 *----------------------------------------------------------------------
 *
 * RunTraces --
 *
 *  	Execute script and C-level trace callbacks
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depeneds on callbacks.
 *
 *----------------------------------------------------------------------
 */
 
static void
RunTraces(NsInterp *itPtr, int why)
{
    ForeachTrace(itPtr, why, 0);
}

static void
ForeachTrace(NsInterp *itPtr, int why, int append)
{
    Tcl_Interp *interp = itPtr->interp;
    TclTrace *tracePtr;

    /*
     * Finalization traces are invoked in LIFO order with script-traces
     * before C-level traces.  Otherwise, traces are invoked in FIFO
     * order, with C-level traces before script-traces.
     */

    Tcl_ResetResult(interp);
    Ns_RWLockRdLock(&itPtr->servPtr->tcl.tlock);
    switch (why) {
    case NS_TCL_TRACE_FREECONN:
    case NS_TCL_TRACE_DEALLOCATE:
    case NS_TCL_TRACE_DELETE:
    	tracePtr = itPtr->servPtr->tcl.lastTracePtr;
	while (tracePtr != NULL) {
	    if (tracePtr->proc == EvalTrace && (tracePtr->when & why)) {
		DoTrace(interp, tracePtr, append);
	    }
	    tracePtr = tracePtr->prevPtr;
	}
    	tracePtr = itPtr->servPtr->tcl.lastTracePtr;
	while (tracePtr != NULL) {
	    if (tracePtr->proc != EvalTrace && (tracePtr->when & why)) {
		DoTrace(interp, tracePtr, append);
	    }
	    tracePtr = tracePtr->prevPtr;
	}
	break;

    default:
    	tracePtr = itPtr->servPtr->tcl.firstTracePtr;
    	while (tracePtr != NULL) {
	    if (tracePtr->proc != EvalTrace && (tracePtr->when & why)) {
		DoTrace(interp, tracePtr, append);
	    }
	    tracePtr = tracePtr->nextPtr;
	}
    	tracePtr = itPtr->servPtr->tcl.firstTracePtr;
    	while (tracePtr != NULL) {
	    if (tracePtr->proc == EvalTrace && (tracePtr->when & why)) {
		DoTrace(interp, tracePtr, append);
	    }
	    tracePtr = tracePtr->nextPtr;
	}
	break;
    }
    Ns_RWLockUnlock(&itPtr->servPtr->tcl.tlock);
    if (!append) {
	Tcl_ResetResult(interp);
    }
}


/*
 *----------------------------------------------------------------------
 *
 * DoTrace --
 *
 *  	Invoke or append a trace, logging any error message.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
 
static void
DoTrace(Tcl_Interp *interp, TclTrace *tracePtr, int append)
{
    Tcl_Obj *procPtr;
    ScriptTrace *stPtr;
    char buf[100];
    int result;

    if (!append) {
    	result = (*tracePtr->proc)(interp, tracePtr->arg);
    	if (result != TCL_OK) {
	    Ns_TclLogError(interp);
    	}
    } else {
    	if (tracePtr->proc == EvalTrace) {
	    stPtr = tracePtr->arg;
	    procPtr = Tcl_NewStringObj(stPtr->script, stPtr->length);
    	} else {
	    sprintf(buf, "C {p:%p a:%p}", tracePtr->proc, tracePtr->arg);
	    procPtr = Tcl_NewStringObj(buf, -1);
    	}
    	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), procPtr);
    }
}


/*
 *----------------------------------------------------------------------
 *
 * PkgRequire --
 *
 *	Trace callback to add a registered package to given interp.
 *
 * Results:
 *	TCL_OK if package added, TCL_ERROR otherwise.
 *
 * Side effects:
 *	Depends on package, typically new namespaces and/or commands.
 *
 *----------------------------------------------------------------------
 */

static int
PkgRequire(Tcl_Interp *interp, void *arg)
{
    Package *pkgPtr = arg;

    if (Tcl_PkgRequire(interp, pkgPtr->name, pkgPtr->version,
			 pkgPtr->exact) == NULL) {
	return TCL_ERROR;
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * AsyncCancel --
 *
 *	Callback which cancels Tcl execution in the given thread.
 *
 * Results:
 *	TCL_ERROR.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
AsyncCancel(ClientData ignored, Tcl_Interp *interp, int code)
{
    Tcl_ResetResult(interp);
    Tcl_SetResult(interp, "async cancel", TCL_STATIC);
    return TCL_ERROR;
}
