#pragma ident "$Header: /san01/cvs/ashpool/csrc/modtcl/src/Attic/modtcl.c,v 1.7 2004/04/21 21:47:06 aleigh Exp $"

/*
 * Copyright (c) 1994, 2002 Alex Leigh, All Rights Reserved
 * 
 * THIS IS UNPUBLISHED PROPRIETARY SOURCE CODE OF ALEX LEIGH The copyright
 * notice above does not evidence any actual or intended publication of such
 * source code.
 * 
 * Disclosure, copying, distribution, or transmission of this code without
 * express permission is prohibited.
 */

/*
  The biggest problem with the TCL system is the fact that TCL doesn't really
  support a mechanism to *copy* an interpreter. This is too bad, too. Ideally
  what really ought to happen is that we create an interpreter, run it through
  all of it's init tcl scripts to load people's various library functions, and
  then just clone it for each of the threads that happens to need one. That would
  save having to constantly run through the script initialization for each time the
  interpreter is created.
*/

#include <pthread.h>
#include <stdlib.h>
#include <assert.h>
#include <string.h>

#include "../continuity/continuity.h"
#include "../modhttp/http.h"
#include <tcl.h>
#include "modtcl.h"

#define CLEANUP_PROC "_cont_cleanup"
#define GETINIT_PROC "_cont_getinit"

static void tclFinterp_create(tclTthr_data * data);
static void tclFinterp_delete(tclTthr_data * data);

/*
 * The init interpreter which is used to create the init script.
 */
Tcl_Interp *tclGinterp = NULL;

/*
 * Init script containing all the procs. This was generated after the
 * libraries were loaded and it used by tclFinterp_create. 
 */
char *tclGinit_script = NULL;

/* pthread key used to hold tclTthr_data in TLS */
pthread_key_t tclKdata;

/* She shines, in a world full of ugliness */

static char tclGhard_procs[] =
    "proc " CLEANUP_PROC " {{autoclose 0}} {\n"
    "    foreach g [info globals] {\n"
    "       if {![string match tcl* $g]\n"
    "               && ![string match error* $g]\n"
    "               && [string compare env $g] != 0} {\n"
    "           upvar #0 $g gv\n"
    "           if [info exists gv] {\n"
    "               unset gv\n"
    "           }\n"
    "       }\n"
    "    }\n"
    "}\n"
    "proc " GETINIT_PROC " {} {\n"
    "    set script {}\n"
    "    foreach p [info procs] {\n"
    "        set args {}\n"
    "        foreach a [info args $p] {\n"
    "            if [info default $p $a def] {\n"
    "                set a [list $a $def]\n"
    "            }\n"
    "            lappend args $a\n"
    "        }\n"
    "        append script [list proc $p $args [info body $p]]\n"
    "        append script \\n\n" "    }\n" "    return $script\n" "}\n";


/*
 * Output a TCL script error message to the log.
 */
void tclFerror(Tcl_Interp * interp)
{
    const char *err;

    assert(interp != NULL);

    logFmsg(1, "TCL error: %s", interp->result);

    err = Tcl_GetVar(tclGinterp, "errorInfo", TCL_GLOBAL_ONLY);
    if (err != NULL)
        logFmsg(1, "%s", err);
}

/*
 * CAPI function to be called from module.cfg to initialize the TCL module.
 * This function should initialize the master interpreters and run any
 * required startup scripts.
 */
int tclFinit(void *p, lstTset * opts)
{
    const char *initfile;

    logFmsg(0, "mod/tcl: TCL Script Engine (module)");
    logFmsg(0,
            "Copyright (c) 2002, Alex Leigh. All Rights Reserved");
    logFmsg(0,
            "TCL 8.3.4 Copyright (c) Regents of UC, Sun Microsystems, Scriptics");

    // aleigh - What was this?
    // tclFcmd_init();

    /* She reads the minds of all the people that pass her by */

    if (pthread_key_create(&tclKdata, &tclFdata_free) != 0) {
        logFmsg(2, "Unable to create tclKdata.");
        abort();
    }

    tclGinterp = Tcl_CreateInterp();

    assert(tclGinterp != NULL);

    if (Tcl_Eval(tclGinterp, tclGhard_procs) != TCL_OK) {
        tclFerror(tclGinterp);
        logFmsg(2, "Tcl_Eval for hard procs failed.");
        abort();
    }

    /* Bind all the continuity commands */
    tclFsetup_cmds(tclGinterp);

    /* Load .tcl library files here to setup the global init state. */
    initfile = lstFset_get(opts, "init");
    if (initfile != NULL) {
        if (Tcl_EvalFile(tclGinterp, initfile) != TCL_OK) {
            tclFerror(tclGinterp);
        } else {
            logFmsg(0, "Loaded %s", initfile);
        }
    }

    /*
     * Create one proc that will be used to initialize future procs to this
     * state. This is because there is no a mechanism in libtcl to actually
     * copy an interpreter.
     */

    if (Tcl_Eval(tclGinterp, GETINIT_PROC) != TCL_OK) {
        tclFerror(tclGinterp);
        logFmsg(2, "Unable to create init interp. Aborting.");
        abort();
    }

    tclGinit_script = (char *) malloc(strlen(tclGinterp->result) + 1);
    assert(tclGinit_script != NULL);

    strcpy(tclGinit_script, tclGinterp->result);

    return STATUS_PROCEED;
}

int tclFinterp_cleanup(tclTthr_data * data)
{
    Tcl_Interp *interp = data->interp;
    Tcl_DString script;

    Tcl_ResetResult(interp);

    Tcl_DStringInit(&script);
    Tcl_DStringAppendElement(&script, CLEANUP_PROC);
    if (Tcl_Eval(interp, script.string) != TCL_OK) {
        tclFerror(interp);
    }
    Tcl_DStringFree(&script);

    if (data->delete == 0) {
        Tcl_ResetResult(interp);
    } else {
        /* Delete Function */
    }
    return 0;
}

/*
 * Destructor for TLS memory to destroy the data structure.
 */
void tclFdata_free(void *p)
{
    tclTthr_data *data = (tclTthr_data *) p;

    assert(p != NULL);

    if (data->interp != NULL)
        Tcl_DeleteInterp(data->interp);
    free(data);
}

tclTthr_data *tclFdata_get(void)
{
    tclTthr_data *data;

    data = pthread_getspecific(tclKdata);
    if (data == NULL) {
        data = malloc(sizeof(tclTthr_data));
        bzero(data, sizeof(tclTthr_data));
        pthread_setspecific(tclKdata, data);
    }
    return data;
}

/*
 * Allocate an interpreter, or, if one is already associated with this
 * thread, return that one.
 * 
 * Results: TCL Interpreter
 * 
 * Side Effects; May create a new TCL interpreter.
 */
Tcl_Interp *tclFinterp_get(char *server)
{
    tclTthr_data *data;

    data = tclFdata_get();

    assert(data != NULL);

#ifdef TCL_DEBUG
    if (data->interp == NULL) {
        logFmsg(3, "No TCL interpreter previously allocated.");
    } else {
        logFmsg(3, "TCL Interpreter previously allocated.");
    }
#endif

    /* Update times in thread data */

    if (data->interp == NULL) {
        tclFinterp_create(data);
    }
    return data->interp;
}

/*
 * Create a TCL Interpreter and initialize it
 */
static void tclFinterp_create(tclTthr_data * data)
{
    Tcl_Interp *interp;

    data->interp = interp = Tcl_CreateInterp();

    tclFsetup_cmds(interp);

    /* Evaluate the script to create all procs. */
    Tcl_Eval(interp, tclGinit_script);
}


 /* In the machina, you can hear her scream. */

/*
 * tclFeval - Evaluate a TCL script in the current thread for the given
 * server.
 */
void tclFeval(char *server, char *script)
{
    Tcl_Interp *interp;

    interp = tclFinterp_get(server);

    assert(interp != NULL);

#ifdef TCL_DEBUG
    logFmsg(3, "tclFeval: tclFinterp_get returned interp 0x%x", interp);
#endif

    if (Tcl_Eval(interp, script) != TCL_OK) {
        logFmsg(3, "tclFeval: result is %s", interp->result);
    }
}

static void tclFinterp_delete(tclTthr_data * data)
{
    Tcl_DeleteInterp(data->interp);
    data->interp = NULL;
    data->delete = 0;
}

/*
 * Process a TCL script that is the entire file, IE, not an embedded TCL
 * script.
 */
int tclFhandler(httpTtrans * t, lstTset * opts)
{
    Tcl_Interp *interp;
    const char *ppath = lstFset_get(t->vars, "path");

    interp = tclFinterp_get("tessier");
    assert(interp != NULL);

    lstFset_update(t->res_hdrs, "Content-Type", "text/html");

    if (Tcl_EvalFile(interp, ppath) != TCL_OK) {
        tclFerror(interp);
        httpFwrite(t, interp->result, strlen(interp->result));
    }
    return STATUS_EXIT;
}

static void tclFtext_chunk(dynTstring * dsPtr, char *text)
{
    dynFappend(dsPtr, "t", 1);
    dynFappend(dsPtr, text, strlen(text) + 1);
}

static void tclFpage_parse(dynTstring * dsPtr, char *page)
{
    register char *s, *e, *t = page;

    assert(page != NULL);
    assert(dsPtr != NULL);

    while ((s = strstr(t, "<%")) != NULL && (e = strstr(s, "%>")) != NULL) {

        *s = '\0';
        tclFtext_chunk(dsPtr, t);
        *s = '<';
        s += 2;
        dynFappend(dsPtr, "s", 1);
        if (*s == '=') {
            ++s;
        }
        *e = '\0';
        dynFappend(dsPtr, s, e - s + 1);
        *e = '%';
        t = e + 2;
    }
    tclFtext_chunk(dsPtr, t);
}

/*
 * Dyn should be a dynamic string that contains a chunked
 * page, in this format;
 * tSometexthere\0sAscript\0tMoretext\0\0
 */
static void tclFpage_render(dynTstring * dyn, httpTtrans * t)
{
    const char *p;
    Tcl_Interp *interp;

    assert(dyn != NULL);
    assert(t != NULL);

    interp = tclFinterp_get("tessier");

    assert(interp != NULL);

    p = dynFgetstr(dyn);

    assert(p != NULL);

    while (1) {
        if (*p == 't') {
            p++;
            httpFwrite(t, p, strlen(p));
        } else {
            p++;
            if (Tcl_Eval(interp, p) != TCL_OK) {
                const char *err;
                logFmsg(2, "script failed: [%d] %s",
                        interp->errorLine, interp->result);
                err = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
                if (err != NULL)
                    logFmsg(2, "%s", err);
            }
        }

        p += strlen(p) + 1;

        if ((p - dynFgetstr(dyn)) >= dynFgetlen(dyn))
            break;
    }
}

/*
 * Process an HTML file that may contain embedded TCL.
 */
int tclFembed_handler(httpTtrans * t, lstTset * opts)
{
    const char *ppath;
    char *map, *page;
    dynTstring *script;

    assert(t != NULL);

    ppath = lstFset_get(t->vars, "path");

    assert(ppath != NULL);

    script = dynFinit();

    assert(script != NULL);

    map = (char *) mmcFmap(ppath, &t->statb, NULL);
    if (map == NULL) {
        logFmsg(1, "mmcFmap returned NULL for %s",
                ppath);
        dynFfree(script);
        return STATUS_ERROR;
    }

    if (map == (char *) 0x1) {
        logFmsg(1, "map returned 0x1 for %s", ppath);
        dynFfree(script);
        return STATUS_ERROR;
    }

    page = strFcopy(map);

    lstFset_update(t->res_hdrs, "Content-Type", "text/html");
    httpFset_status(t, 200, NULL);
    httpFstart_response(t);

    tclFpage_parse(script, page);
    tclFpage_render(script, t);

    dynFfree(script);
    free(page);

    return STATUS_EXIT;
}
