/* rivetCore.c -- Core commands which are compiled into mod_rivet itself */

/*
    Licensed to the Apache Software Foundation (ASF) under one
    or more contributor license agreements.  See the NOTICE file
    distributed with this work for additional information
    regarding copyright ownership.  The ASF licenses this file
    to you under the Apache License, Version 2.0 (the
    "License"); you may not use this file except in compliance
    with the License.  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

    Unless required by applicable law or agreed to in writing,
    software distributed under the License is distributed on an
    "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
    KIND, either express or implied.  See the License for the
    specific language governing permissions and limitations
    under the License.
*/

/* Rivet config */
#ifdef HAVE_CONFIG_H
#include <rivet_config.h>
#endif

#include <sys/stat.h>

#include "httpd.h"
#include "http_config.h"
#include "http_request.h"
#include "http_core.h"
#include "http_protocol.h"
#include "http_log.h"
#include "http_main.h"
#include "util_script.h"
#include "http_config.h"

#include <tcl.h>
#include <string.h>
#include <stdio.h>
#include <apr_errno.h>
#include <apr_strings.h>
#include <apr_portable.h>

#include "apache_request.h"
#include "mod_rivet.h"
#include "rivet.h"
#include "TclWeb.h"
/* Function prototypes are defined with EXTERN. Since we are in the same DLL,
 * no need to keep this extern... */
#ifdef EXTERN
#   undef EXTERN
#   define EXTERN
#endif /* EXTERN */
#include "rivetParser.h"
#include "mod_rivet_generator.h"
#include "mod_rivet_cache.h"

#define ENV_ARRAY_NAME     "::request::env"
#define HEADERS_ARRAY_NAME "::request::headers"
#define COOKIES_ARRAY_NAME "cookies"

extern module rivet_module;
extern char* TclWeb_GetRawPost (TclWebRequest *req);
extern mod_rivet_globals* module_globals;
extern apr_threadkey_t*  rivet_thread_key;

#define POOL (private->r->pool)

 /* define a convenience macro to cast the ClientData
  * into the thread private data pointer */

#define THREAD_PRIVATE_DATA(p)  p = (rivet_thread_private *)clientData;

/*
 * -- Rivet_NoRequestRec
 *
 * Adds standard error information to the interpreter. This procedure makes 
 * sense only when called by C functions implementing Tcl commands that
 * are meaningful only if a valid requiest_rec object is defined. These
 * procedures must return TCL_ERROR right away after Rivet_NoRequestRecord
 * returns
 *
 * Arguments:
 *
 *  Tcl_Interp*: current Tcl interpreter
 *  Tcl_Obj*: Tcl string object with the command name
 *
 * Results:
 *
 *  None
 *
 */

static void
Rivet_NoRequestRec (Tcl_Interp* interp, Tcl_Obj* command)
{
    Tcl_AddErrorInfo(interp, "Cannot call ");
    Tcl_AppendObjToErrorInfo(interp,command);
    Tcl_AppendObjToErrorInfo(interp,Tcl_NewStringObj(" outside a request processing",-1));
}


/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_MakeURL --
 *
 *      Make a self-referencing URL.
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side Effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_MakeURL )
{
    rivet_thread_private*   private;
    Tcl_Obj*                result  = NULL;
    char*                   url_target_name;
    int                     target_length;

    if (objc > 2)
    {
        Tcl_WrongNumArgs(interp, 1, objv, "filename");
        return TCL_ERROR;
    }

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::makeurl")
    if (objc == 1)
    {
        url_target_name = TclWeb_GetEnvVar (private,"SCRIPT_NAME");
    }
    else
    {
        url_target_name = Tcl_GetStringFromObj(objv[1],&target_length);

        // we check the first character for a '/' (absolute path)
        // If we are dealing with a relative path we prepend it with
        // the SCRIPT_NAME environment variable

        if (url_target_name[0] != '/')
        {
            /* relative path */
            char* script_name = TclWeb_GetEnvVar (private,"SCRIPT_NAME");
            size_t script_name_l = strlen(script_name);

            // regardless the reason for a SCRIPT_NAME being undefined we
            // prevent a segfault and we revert the behavior of makeurl
            // to the case of an absolute path

            if (script_name_l > 0)
            {
                // script name may have the form a directory path (and mod_rewrite 
                // could have mapped it to a .tcl or .rvt script)
                
                if (script_name[script_name_l-1] == '/')
                {
                    url_target_name = apr_pstrcat(private->req->req->pool,script_name,url_target_name,NULL);
                }
                else
                {
                    url_target_name = apr_pstrcat(private->req->req->pool,script_name,"/",url_target_name,NULL);
                }
            }
            else
            {
                url_target_name = apr_pstrcat(private->req->req->pool,"/",url_target_name,NULL);
            }
        }
    }

    result = Tcl_NewObj();   
    TclWeb_MakeURL(result, url_target_name, private->req);
    Tcl_SetObjResult(interp, result);

    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_Parse --
 *
 *      Include and parse a Rivet file.
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side Effects:
 *      Whatever occurs in the Rivet page parsed.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_Parse )
{
    rivet_thread_private*   private;
    char*                   filename = 0;
    apr_status_t            stat_s;
    apr_finfo_t             finfo_b;
    char*                   cache_key;
    rivet_thread_interp*    rivet_interp;
    Tcl_HashEntry*          entry  = NULL;
    Tcl_Obj*                script = NULL;
    int                     result;

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::parse")

    if( objc < 2 || objc > 3 )
    {
        Tcl_WrongNumArgs(interp, 1, objv, "?-virtual? filename");
        return TCL_ERROR;
    }

    if( objc == 2 ) {

        filename = Tcl_GetStringFromObj( objv[1], (int *)NULL );

    } else {

        if (STREQU( Tcl_GetStringFromObj(objv[1], (int *)NULL), "-virtual")) {

        /* */

            filename = TclWeb_GetVirtualFile(private->req,Tcl_GetStringFromObj(objv[2],(int *)NULL));

        } else if ( STREQU( Tcl_GetStringFromObj(objv[1], (int *)NULL), "-string")) {

            int      res;
            Tcl_Obj* script = objv[2];
            Tcl_Obj* outbuf = Tcl_NewObj();

            /* we parse and compose the script ourselves before passing it to Tcl_EvalObjEx */

            Tcl_IncrRefCount(outbuf);
            Tcl_AppendToObj(outbuf, "puts -nonewline \"", -1);

            /* If we are not inside a <? ?> section, add the closing ". */
            if (Rivet_Parser(outbuf, script) == 0)
            {
                Tcl_AppendToObj(outbuf, "\"\n", 2);
            } 

            Tcl_AppendToObj(outbuf,"\n",-1);

            res = Tcl_EvalObjEx(interp,outbuf,0);

            Tcl_DecrRefCount(outbuf);
            return res;
            //return Rivet_ParseExecString(private, objv[2]);

        } else { 

            Tcl_WrongNumArgs( interp, 1, objv, "?-virtual? filename | -string template_string" );
            return TCL_ERROR;

        }

    }

    if (!strcmp(filename, private->r->filename))
    {
        Tcl_AddErrorInfo(interp, "Cannot recursively call the same file!");
        return TCL_ERROR;
    }

    stat_s = apr_stat(&finfo_b,filename,APR_FINFO_NORM,private->r->pool);
    if (stat_s != APR_SUCCESS)
    {
        char apr_error_message[RIVET_MSG_BUFFER_SIZE];

        Tcl_AddErrorInfo(interp,apr_strerror(stat_s,apr_error_message,RIVET_MSG_BUFFER_SIZE));
        return TCL_ERROR;
    }

    /* */

    cache_key = 
        RivetCache_MakeKey( private->pool,filename,
                            finfo_b.ctime,finfo_b.mtime,
                            IS_USER_CONF(private->running_conf),0);

    rivet_interp = RIVET_PEEK_INTERP(private,private->running_conf);
    entry = RivetCache_EntryLookup (rivet_interp,cache_key);

    if (entry == NULL)
    {
        script = Tcl_NewObj();
        Tcl_IncrRefCount(script);

        result = Rivet_GetRivetFile(filename,script,interp);
        if (result != TCL_OK)
        {
            Tcl_AddErrorInfo(interp,apr_pstrcat(private->pool,"Could not read file ",filename,NULL));
            Tcl_DecrRefCount(script);
            return result;
        }

        if (rivet_interp->cache_free > 0)
        {
            int isNew;
            Tcl_HashEntry* entry;

            entry = RivetCache_CreateEntry (rivet_interp,cache_key,&isNew);
            ap_assert(isNew == 1);
            RivetCache_StoreScript(rivet_interp,entry,script);
        }
        else if ((rivet_interp->flags & RIVET_CACHE_FULL) == 0)
        {
            rivet_interp->flags |= RIVET_CACHE_FULL;
            ap_log_error (APLOG_MARK, APLOG_NOTICE, APR_EGENERAL, private->r->server,"%s %s (%s),",
                                                                  "Rivet cache full when parsing ",
                                                                  private->r->filename,
                                                                  private->r->server->server_hostname);
        }

        result = Tcl_EvalObjEx(interp,script,0);
        Tcl_DecrRefCount(script);
        return result;
               
    } else {
        script = RivetCache_FetchScript(entry);
        return Tcl_EvalObjEx(interp,script,0); 
    }

}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_Include --
 *
 *      Includes a file literally in the output stream.  Useful for
 *      images, plain HTML and the like.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side Effects:
 *      Adds to the output stream.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_Include )
{
    rivet_thread_private*   private;
    int                     sz;
    Tcl_Channel             fd;
    Tcl_Channel             tclstdout;
    Tcl_Obj*                outobj;
    char*                   filename;
    Tcl_DString             transoptions;
    Tcl_DString             encoptions;

    if( objc < 2 || objc > 3 )
    {
        Tcl_WrongNumArgs(interp, 1, objv, "?-virtual? filename");
        return TCL_ERROR;
    }

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::include")

    if( objc == 2 ) {
        filename = Tcl_GetStringFromObj( objv[1], (int *)NULL );
    } else {
        if( !STREQU( Tcl_GetStringFromObj(objv[1], (int *)NULL), "-virtual") ) {
            Tcl_WrongNumArgs( interp, 1, objv, "?-virtual? filename" );
            return TCL_ERROR;
        }

        CHECK_REQUEST_REC(private,"::rivet::include -virtual")
        filename = TclWeb_GetVirtualFile(private->req,Tcl_GetStringFromObj(objv[2], (int *)NULL) );
    }

    fd = Tcl_OpenFileChannel(interp, filename, "r", 0664);

    if (fd == NULL)
    {
        return TCL_ERROR;
    }
    Tcl_SetChannelOption(interp, fd, "-translation", "binary");

    outobj = Tcl_NewObj();
    Tcl_IncrRefCount(outobj);
    sz = Tcl_ReadChars(fd, outobj, -1, 0);
    if (sz == -1)
    {
        Tcl_AddErrorInfo(interp, Tcl_PosixError(interp));
        Tcl_DecrRefCount(outobj);
        return TCL_ERROR;
    }

    /* What we are doing is saving the translation and encoding
     * options, setting them both to binary, and the restoring the
     * previous settings. */
    Tcl_DStringInit(&transoptions);
    Tcl_DStringInit(&encoptions);
    tclstdout = Tcl_GetChannel(interp, "stdout", NULL);
    Tcl_GetChannelOption(interp, tclstdout, "-translation", &transoptions);
    Tcl_GetChannelOption(interp, tclstdout, "-encoding", &encoptions);
    Tcl_SetChannelOption(interp, tclstdout, "-translation", "binary");
    Tcl_WriteObj(tclstdout, outobj);
    Tcl_SetChannelOption(interp, tclstdout, "-translation", Tcl_DStringValue(&transoptions));
    Tcl_SetChannelOption(interp, tclstdout, "-encoding", Tcl_DStringValue(&encoptions));
    Tcl_DStringFree(&transoptions);
    Tcl_DStringFree(&encoptions);
    Tcl_DecrRefCount(outobj);
    return Tcl_Close(interp, fd);
}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_Headers --
 *
 *      Command to manipulate HTTP headers from Tcl.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side Effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_Headers )
{
    char *opt;
    rivet_thread_private*   private;

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::headers")

    if (objc < 2)
    {
        Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
        return TCL_ERROR;
    }

    opt = Tcl_GetStringFromObj(objv[1], NULL);

    /* Basic introspection returning the value of the headers_printed flag */

    if (!strcmp("sent",opt))
    {
        Tcl_SetObjResult(interp, Tcl_NewIntObj(private->req->headers_printed));
        return TCL_OK;
    }

    if (private->req->headers_printed != 0)
    {
        Tcl_AddObjErrorInfo(interp,"Cannot manipulate headers - already sent", -1);
        return TCL_ERROR;
    }

    if (!strcmp("redirect", opt)) /* ### redirect ### */
    {
        if (objc != 3)
        {
            Tcl_WrongNumArgs(interp, 2, objv, "new-url");
            return TCL_ERROR;
        }
        apr_table_set(private->r->headers_out, "Location",
                     Tcl_GetStringFromObj (objv[2], (int *)NULL));
        TclWeb_SetStatus(301, private->req);
        return TCL_OK;
    }
    else if (!strcmp("get", opt)) /* ### get ### */
    {
        const char* header_value;

        if (objc != 3)
        {
            Tcl_WrongNumArgs(interp, 2, objv, "headername");
            return TCL_ERROR;
        }

        header_value = TclWeb_OutputHeaderGet(Tcl_GetString(objv[2]),private->req); 

        Tcl_SetObjResult(interp,Tcl_NewStringObj(header_value ? header_value : "",-1));
    }
    else if (!strcmp("set", opt)) /* ### set ### */
    {
        if (objc != 4)
        {
            Tcl_WrongNumArgs(interp, 2, objv, "headername value");
            return TCL_ERROR;
        }
        TclWeb_HeaderSet(Tcl_GetString(objv[2]), Tcl_GetString(objv[3]), private->req);
    }
    else if (!strcmp("add", opt)) /* ### set ### */
    {
        if (objc != 4)
        {
            Tcl_WrongNumArgs(interp, 2, objv, "headername value");
            return TCL_ERROR;
        }
        TclWeb_HeaderAdd(Tcl_GetString(objv[2]), Tcl_GetString(objv[3]), private->req);
    }
    else if (!strcmp("type", opt)) /* ### set ### */
    {
        if (objc != 3)
        {
            Tcl_WrongNumArgs(interp, 2, objv, "mime/type");
            return TCL_ERROR;
        }
        TclWeb_SetHeaderType(Tcl_GetString(objv[2]), private->req);
    }
    else if (!strcmp("numeric", opt)) /* ### numeric ### */
    {
        int st = 200;

        if (objc != 3)
        {
            Tcl_WrongNumArgs(interp, 2, objv, "response_code_number");
            return TCL_ERROR;
        }
        if (Tcl_GetIntFromObj(interp, objv[2], &st) != TCL_ERROR) {
            TclWeb_SetStatus(st, private->req);
        } else {
            return TCL_ERROR;
        }

    } else {

        Tcl_Obj* result = Tcl_NewStringObj("unrecognized subcommand: ",-1);
        Tcl_IncrRefCount(result);
        Tcl_AppendStringsToObj(result,opt,NULL);

        Tcl_SetObjResult(interp, result);
        Tcl_DecrRefCount(result);
        return TCL_ERROR;

    }
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_LoadEnv --
 *
 *      Load the "environmental variables" - those variables that are
 *      set in the environment in a standard CGI program.  If no array
 *      name is supplied, they are loaded into an array whose name is
 *      the value of the ENV_ARRAY_NAME #define.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side Effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_LoadEnv )
{
    rivet_thread_private*   private;
    Tcl_Obj*                ArrayObj;

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::load_env")
    if( objc > 2 ) {
        Tcl_WrongNumArgs( interp, 1, objv, "?arrayName?" );
        return TCL_ERROR;
    }

    if( objc == 2 ) {
        ArrayObj = objv[1];
    } else {
        ArrayObj = Tcl_NewStringObj( ENV_ARRAY_NAME, -1 );
    }

    return TclWeb_GetEnvVars(ArrayObj,private);
}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_LoadHeaders --
 *
 *      Load the HTTP headers supplied by the client into a Tcl array,
 *      whose name defaults to the value of the HEADERS_ARRAY_NAME
 *      #define.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side Effects:
 *      Creates an array variable if none exists.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER ( Rivet_LoadHeaders )
{
    rivet_thread_private*   private;
    Tcl_Obj*                ArrayObj;

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::load_headers")
    if( objc > 2 ) {
        Tcl_WrongNumArgs( interp, 1, objv, "?arrayName?" );
        return TCL_ERROR;
    }

    if( objc == 2 ) {
        ArrayObj = objv[1];
    } else {
        ArrayObj = Tcl_NewStringObj( HEADERS_ARRAY_NAME, -1 );
    }

    return TclWeb_GetHeaderVars(ArrayObj,private);
}

/* Tcl command to return a particular variable.  */

/* Use:
*/

/*
 *-----------------------------------------------------------------------------
 *
 *  Rivet_Var --
 *
 *      Returns information about GET or POST variables:
 *
 *      var get foo ?default?
 *      var list foo
 *      var names
 *      var number
 *      var all
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side Effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER ( Rivet_Var )
{
    rivet_thread_private*   private;
    const char*             cmd; 
    char*                   command;
    Tcl_Obj*                result = NULL;
    int                     source;
    register const char     *p;

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::var,::rivet::var_post,::rivet::var_qs")
    if (objc < 2 || objc > 4)
    {
        Tcl_WrongNumArgs(interp, 1, objv,
                         "(get varname ?default?|list varname|exists varname|names"
                         "|number|all)");
        return TCL_ERROR;
    }
    cmd = Tcl_GetString(objv[0]);
    command = Tcl_GetString(objv[1]);
    result = Tcl_NewObj();

    /* determine if var_qs, var_post or var was called */

    /* first of all we have to skip the namespace string at the beginning of the command:
     * 
     * This fragment of code is taken from tcl 8.6.6 (tclNamesp.c) and it's part of the
     * function implementing Tcl "namespace tail", as such it should be authoritative
     * regarding the stripping of the namespace from a FQ command name
     */

    for (p = cmd;  *p != '\0';  p++) {
	    /* empty body */
    }
    
    while (--p > cmd) {
        if ((*p == ':') && (*(p-1) == ':')) {
            p++;			/* Just after the last "::" */
            break;
        }
    }
    cmd = p;

    if (!strcmp(cmd, "var_qs")) source = VAR_SRC_QUERYSTRING;
    else if (!strcmp(cmd, "var_post")) source = VAR_SRC_POST;
    else source = VAR_SRC_ALL;

    if (!strcmp(command, "get"))
    {
        char *key = NULL;
        char *deflt = NULL;
        if (objc != 3 && objc != 4)
        {
            Tcl_WrongNumArgs(interp, 2, objv, "variablename ?defaultval?");
            return TCL_ERROR;
        }
        key = Tcl_GetStringFromObj(objv[2], NULL);
        if (objc == 4)
        {
            deflt = Tcl_GetString(objv[3]);
        }

        if (TclWeb_GetVar(result, key, source, private->req) != TCL_OK)
        {
            if (deflt == NULL) {
                Tcl_SetStringObj(result, "", -1);
            } else {
                Tcl_SetStringObj(result, deflt, -1);
            }
        }
    } else if(!strcmp(command, "exists")) {
        char *key;
        if (objc != 3)
        {
            Tcl_WrongNumArgs(interp, 2, objv, "variablename");
            return TCL_ERROR;
        }
        key = Tcl_GetString(objv[2]);

        TclWeb_VarExists(result, key, source, private->req);
    } else if(!strcmp(command, "list")) {
        char *key;
        if (objc != 3)
        {
            Tcl_WrongNumArgs(interp, 2, objv, "variablename");
            return TCL_ERROR;
        }
        key = Tcl_GetStringFromObj(objv[2], NULL);

        if (TclWeb_GetVarAsList(result, key, source, private->req) != TCL_OK)
        {
            result = Tcl_NewStringObj("", -1);
        }
    } else if(!strcmp(command, "names")) {
        if (objc != 2)
        {
            Tcl_WrongNumArgs(interp, 2, objv, NULL);
            return TCL_ERROR;
        }

        if (TclWeb_GetVarNames(result, source, private->req) != TCL_OK)
        {
            result = Tcl_NewStringObj("", -1);
        }
    } else if(!strcmp(command, "number")) {
        if (objc != 2)
        {
            Tcl_WrongNumArgs(interp, 2, objv, NULL);
            return TCL_ERROR;
        }

        TclWeb_VarNumber(result, source, private->req);
    } else if(!strcmp(command, "all")) {
        if (objc != 2)
        {
            Tcl_WrongNumArgs(interp, 2, objv, NULL);
            return TCL_ERROR;
        }
        if (TclWeb_GetAllVars(result, source, private->req) != TCL_OK)
        {
            result = Tcl_NewStringObj("", -1);
        }
    } else {
        /* bad command  */
        Tcl_AppendResult(interp, "bad option: must be one of ",
                         "'get, list, names, number, all'", NULL);
        return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, result);

    return TCL_OK;
}

/*
*/

static int append_key_callback (void *data, const char *key, const char *val)
{
    Tcl_Obj *list = data;

    Tcl_ListObjAppendElement (NULL, list, Tcl_NewStringObj (key, -1));
    return 1;
}

static int
append_key_value_callback (void *data, const char *key, const char *val)
{
    Tcl_Obj *list = data;

    Tcl_ListObjAppendElement (NULL, list, Tcl_NewStringObj (key, -1));
    Tcl_ListObjAppendElement (NULL, list, Tcl_NewStringObj (val, -1));
    return 1;
}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_ApacheTable --
 *
 *      Deals with Rivet key-value tables in the request structure
 *
 *      apache_table get tablename key
 *      apache_table set tablename key value
 *      apache_table set tablename list
 *      apache_table exists tablename key
 *      apache_table unset tablename key
 *      apache_table names tablename
 *      apache_table array_get tablename
 *      apache_table clear tablename
 *
 *      Table names can be "notes", "headers_in", "headers_out",
 *      "err_headers_out", and "subprocess_env".
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side Effects:
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_ApacheTable )
{
    apr_table_t *table = NULL;
    int subcommandindex;

    static CONST84 char *SubCommand[] = {
        "get",
        "set",
        "exists",
        "unset",
        "names",
        "array_get",
        "clear",
        NULL
    };

    enum subcommand {
        SUB_GET,
        SUB_SET,
        SUB_EXISTS,
        SUB_UNSET,
        SUB_NAMES,
        SUB_ARRAY_GET,
        SUB_CLEAR
    };

    static CONST84 char *tableNames[] = {
        "notes",
        "headers_in",
        "headers_out",
        "err_headers_out",
        "subprocess_env",
        NULL
    };

    int tableindex;

    enum tablename {
        TABLE_NOTES,
        TABLE_HEADERS_IN,
        TABLE_HEADERS_OUT,
        TABLE_ERR_HEADERS_OUT,
        TABLE_SUBPROCESS_ENV
    };

    rivet_thread_private*   private;

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::apache_table")

    if ((objc < 3) || (objc > 5)) {
        Tcl_WrongNumArgs(interp, 1, objv, "option tablename ?args?");
        return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], SubCommand,
                        "get|set|unset|list",
                        0, &subcommandindex) == TCL_ERROR) {
        return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj (interp, objv[2], tableNames,
                    "notes|headers_in|headers_out|err_header_out|subprocess_env",
                    0, &tableindex) == TCL_ERROR) {
	    return TCL_ERROR;
    }

    switch ((enum tablename)tableindex)
    {
        case TABLE_NOTES: {
            table = private->r->notes;
            break;
        }

        case TABLE_HEADERS_IN: {
            table = private->r->headers_in;
            break;
        }

        case TABLE_HEADERS_OUT: {
            table = private->r->headers_out;
            break;
        }

        case TABLE_ERR_HEADERS_OUT: {
            table = private->r->err_headers_out;
            break;
        }

        case TABLE_SUBPROCESS_ENV: {
            table = private->r->subprocess_env;
            break;
        }
    }

    switch ((enum subcommand)subcommandindex)
    {
        case SUB_GET: {
            const char *key;
            const char *value;

            if (objc != 4) {
                Tcl_WrongNumArgs(interp, 2, objv, "tablename key");
                return TCL_ERROR;
            }
            key = Tcl_GetString (objv[3]);
            value = apr_table_get (table, key);

            if (value != NULL) {
                Tcl_SetObjResult (interp, Tcl_NewStringObj (value, -1));
            }
            break;
        }
        case SUB_EXISTS: {
            const char *key;
            const char *value;

            if (objc != 4) {
                Tcl_WrongNumArgs(interp, 2, objv, "tablename key");
                return TCL_ERROR;
            }

            key = Tcl_GetString (objv[3]);
            value = apr_table_get (table, key);

            Tcl_SetObjResult (interp, Tcl_NewBooleanObj (value != NULL));
            break;
        }
        case SUB_SET: {
            int i;
            char *key;
            char *value;

            if (objc == 4) {
                int listObjc;
                Tcl_Obj **listObjv;

                if (Tcl_ListObjGetElements (interp, objv[3], &listObjc, &listObjv) == TCL_ERROR) {
                    return TCL_ERROR;
                }

                if (listObjc % 2 == 1) {
                    Tcl_SetObjResult (interp, Tcl_NewStringObj ("list must have even number of elements", -1));
                    return TCL_ERROR;
                }

                for (i = 0; i < listObjc; i += 2) {
                    apr_table_set (table, Tcl_GetString (listObjv[i]), Tcl_GetString (listObjv[i+1]));
                }

                break;
            }

            if (objc != 5) {
                Tcl_WrongNumArgs(interp, 2, objv, "tablename key value");
                return TCL_ERROR;
            }

            key = Tcl_GetString (objv[3]);
            value = Tcl_GetString (objv[4]);

            apr_table_set (table, key, value);
            break;
        }

        case SUB_UNSET: {
            char *key;

            if (objc != 4) {
                Tcl_WrongNumArgs(interp, 2, objv, "tablename key");
                return TCL_ERROR;
            }

            key = Tcl_GetString (objv[3]);
            apr_table_unset (table, key);
            break;
        }

        case SUB_NAMES: {
            Tcl_Obj *list = Tcl_NewObj ();

            apr_table_do(append_key_callback, (void*)list, table, NULL);

            Tcl_SetObjResult (interp, list);
            break;
        }

        case SUB_ARRAY_GET: {
            Tcl_Obj *list = Tcl_NewObj ();

            apr_table_do(append_key_value_callback, (void*)list, table, NULL);

            Tcl_SetObjResult (interp, list);
            break;
        }

        case SUB_CLEAR: {
            apr_table_clear (table);
        }
    }

    return TCL_OK;
}


/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_Upload --
 *
 *      Deals with file uploads (multipart/form-data):
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side Effects:
 *      Has the potential to create files on the file system, or work
 *      with large amounts of data.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_Upload )
{
    char*   varname = NULL;
    int     subcommandindex;

    /* ::rivet::upload subcommands must register
     *
     * - subcommand definition
     * - subcommand integer progressive index
     * - subcommand required (minimum) number of arguments
     *
     * +----------------------------------------+-------+
     * |         argv[1]    argv[2]   argv[3]   | argc  |
     * +----------------------------------------+-------+
     * |  upload channel   uploadname           |   3   |
     * |  upload save      uploadname filename  |   4   |
     * |  upload data      uploadname           |   3   |
     * |  upload exists    uploadname           |   3   |
     * |  upload size      uploadname           |   3   |
     * |  upload type      uploadname           |   3   |
     * |  upload filename  uploadname           |   3   |
     * |  upload tempname  uploadname           |   3   |
     * |  upload names                          |   2   |
     * +----------------------------------------+-------+
     *
     * a subcommand first optional argument must be the name
     * of an upload
     */

    static CONST84 char *SubCommand[] = {
        "channel",
        "save",
        "data",
        "exists",
        "size",
        "type",
        "filename",
        "tempname",
        "names",
        NULL
    };

    enum subcommand {
        CHANNEL,
        SAVE,
        DATA,
        EXISTS,
        SIZE,
        TYPE,
        FILENAME,
        TEMPNAME,
        NAMES
    };

    static CONST84 int cmds_objc[] = { 3,4,3,3,3,3,3,3,2 };
    int expected_objc;

    rivet_thread_private* private;

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::upload")
    if (Tcl_GetIndexFromObj(interp, objv[1], SubCommand,
                        "channel|save|data|exists|size|type|filename|tempname|names",
                        0, &subcommandindex) == TCL_ERROR) {
        return TCL_ERROR;
    }

    expected_objc = cmds_objc[subcommandindex];

    if (objc != expected_objc) {
        Tcl_Obj* infoobj = Tcl_NewStringObj("Wrong argument numbers: ",-1);

        Tcl_IncrRefCount(infoobj);
        Tcl_AppendObjToObj(infoobj,Tcl_NewIntObj(expected_objc));
        Tcl_AppendStringsToObj(infoobj," arguments expected");
        Tcl_AppendObjToErrorInfo(interp, infoobj);
        Tcl_DecrRefCount(infoobj);

        if (subcommandindex == SAVE) {
            Tcl_WrongNumArgs(interp, 2, objv, "uploadname filename");
        } else {
            Tcl_WrongNumArgs(interp, objc, objv, "uploadname");
        }
        return TCL_ERROR;
    }

    /* We check whether an upload with a given name exists */

    if (objc >= 3) {
        int tcl_status;
        varname = Tcl_GetString(objv[2]);

        /* TclWeb_PrepareUpload calls ApacheUpload_find and returns
         * TCL_OK if the named upload exists in the current request */
        tcl_status = TclWeb_PrepareUpload(varname, private->req);

        if (subcommandindex == EXISTS) {
            Tcl_Obj* result = NULL;
            int upload_prepared = 0;

            if (tcl_status == TCL_OK) upload_prepared = 1;

            result = Tcl_NewObj();
            Tcl_SetIntObj(result,upload_prepared);
            Tcl_SetObjResult(interp, result);
            return TCL_OK;
                
        }

        if (tcl_status != TCL_OK)
        {
            Tcl_AddErrorInfo(interp, "Unable to find the upload named '");
            Tcl_AppendObjToErrorInfo(interp,Tcl_NewStringObj(varname,-1));
            Tcl_AppendObjToErrorInfo(interp,Tcl_NewStringObj("'",-1));
            return TCL_ERROR;
        }
    }

    /* CHANNEL  : get the upload channel name
     * SAVE     : save data to a specified filename
     * DATA     : get the uploaded data into a Tcl variable
     * SIZE     : uploaded data size
     * TYPE     : upload mimetype
     * FILENAME : upload original filename
     * TEMPNAME : temporary file where the upload is taking place
     * NAMES    : list of uploads
     *
     * the procedure shouldn't reach for the default case
     */

    switch ((enum subcommand)subcommandindex)
    {
        case CHANNEL:
            return TclWeb_UploadChannel(varname, private->req);
        case SAVE:
            return TclWeb_UploadSave(varname, objv[3], private->req);
        case DATA:
            return TclWeb_UploadData(varname, private->req);
        case SIZE:
            return TclWeb_UploadSize(private->req);
        case TYPE:
            return TclWeb_UploadType(private->req);
        case FILENAME:
            return TclWeb_UploadFilename(private->req);
        case TEMPNAME:
            return TclWeb_UploadTempname(private->req);
        case NAMES:
            return TclWeb_UploadNames(private->req);
        default:
            Tcl_WrongNumArgs(interp, 1, objv,"Rivet internal error: inconsistent argument");
    }
    return TCL_ERROR;
}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_RawPost --
 *
 *      Returns the raw POST data.
 *
 * Results:
 *      The raw post data, or an empty string if there is none.
 *
 * Side Effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER ( Rivet_RawPost )
{
    char*                   data;
    Tcl_Obj*                retval;
    rivet_thread_private*   private;

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::raw_post")

    data = TclWeb_GetRawPost(private->req);

    if (!data) {
        data = "";
    }
    retval = Tcl_NewStringObj(data, -1);
    Tcl_SetObjResult(interp, retval);
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_NoBody --
 *
 *      Tcl command to erase body, so that only header is returned.
 *      Necessary for 304 responses.
 *
 * Results:
 *      A standard Tcl return value.
 *
 * Side Effects:
 *      Eliminates any body returned in the HTTP response.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_NoBody )
{
    rivet_thread_private*   private;

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::no_body")

    if (private->req->content_sent == 1) {
        Tcl_AddErrorInfo(interp, "Content already sent");
        return TCL_ERROR;
    }

    private->req->content_sent = 1;
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_AbortPageCmd --
 *
 *      Similar in purpose to PHP's "die" command, which halts all
 *      further output to the user.  Like an "exit" for web pages, but
 *      without actually exiting the apache child.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side Effects:
 *      Flushes the standard (apache) output channel, and tells apache
 *      to stop sending data.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_AbortPageCmd )
{
    rivet_thread_private* private;
    static char *errorMessage = "Page generation terminated by abort_page directive";

    if (objc > 2)
    {
        Tcl_WrongNumArgs(interp, 1, objv, "");
        return TCL_ERROR;
    }

    THREAD_PRIVATE_DATA(private)

    if (objc == 2)
    {
        char* cmd_arg = Tcl_GetStringFromObj(objv[1],NULL);
        
        if (strcmp(cmd_arg,"-aborting") == 0)
        {
            Tcl_SetObjResult (interp,Tcl_NewBooleanObj(private->page_aborting));
            return TCL_OK;
        }

        if (strcmp(cmd_arg,"-exiting") == 0)
        {
            Tcl_SetObjResult (interp,Tcl_NewBooleanObj(private->thread_exit));
            return TCL_OK;
        }
 
    /* 
     * we assume abort_code to be null, as abort_page shouldn't run twice while
     * processing the same request 
     */
       
        if (private->abort_code == NULL)
        {
            private->abort_code = objv[1];
            Tcl_IncrRefCount(private->abort_code);
        }
    }

    /* 
     * If page_aborting is true then this is the second call to abort_page
     * processing the same request: we ignore it and return a normal
     * completion code
     */

    if (private->page_aborting)
    {
        return TCL_OK;
    }

    /* this is the first (and supposedly unique) abort_page call during this request */

    /* we eleveta the page_aborting flag to the actual flag controlling the page abort execution. 
     * We still return the RIVET and ABORTPAGE_CODE, but internally
     * its page_aborting that will drive the code execution after abort_page
     */

    private->page_aborting = 1;

    Tcl_AddErrorInfo (interp, errorMessage);
    Tcl_SetErrorCode (interp, "RIVET", ABORTPAGE_CODE, errorMessage, (char *)NULL);
    return TCL_ERROR;
}

/*
 *-----------------------------------------------------------------------------
 * Rivet_AbortCodeCmd -- 
 *
 * Returns the abort code stored internally by passing a user defined parameter 
 * to the command 'abort_page'.
 *
 *
 *-----------------------------------------------------------------------------
 */
TCL_CMD_HEADER( Rivet_AbortCodeCmd )
{
    rivet_thread_private*   private;
    
    THREAD_PRIVATE_DATA(private)

    if (private->abort_code != NULL)
    {
        Tcl_SetObjResult(interp,private->abort_code);
    }

    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_EnvCmd --
 *
 *      Loads a single environmental variable, to avoid the overhead
 *      of storing all of them when only one is needed.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side Effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_EnvCmd )
{
    char*                   key;
    char*                   val;
    rivet_thread_private*   private;
    
    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::env")

    if( objc != 2 ) {
        Tcl_WrongNumArgs( interp, 1, objv, "variable" );
        return TCL_ERROR;
    }

    key = Tcl_GetStringFromObj( objv[1], NULL );

    val = TclWeb_GetEnvVar( private, key );

    Tcl_SetObjResult(interp, Tcl_NewStringObj( val, -1 ) );
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_ExitCmd --
 *
 *      Calls the MPM specific exit procedure. For a threaded MPM (such
 *      as 'worker') the procedure should cause a thread to exit, not the
 *      whole process with all its threads. In this case the procedure
 *      returns an TCL_ERROR code that has to be handled in mod_rivet so that
 *      the error is ignored and the request procedure interrupted. 
 *      For a non threaded MPM (such as 'prefork') the single child process 
 *      exits thus reproducing an ordinary 'exit' command. 
 *
 * Result:
 *
 *      TCL_ERROR 
 * 
 * Side Effects:
 *
 *      - non threaded MPMs: the child process exits for good
 *      - threaded MPMs: the child process exits after all Tcl threads
 *      are told to exit
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_ExitCmd )
{
    int value;
    rivet_thread_private*   private;
    char* errorMessage = "page generation interrupted by exit command";

    if ((objc != 1) && (objc != 2)) {
        Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
        return TCL_ERROR;
    }

    if (objc == 1) {
        value = 0;
    } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
        return TCL_ERROR;
    }

    THREAD_PRIVATE_DATA(private)

    private->page_aborting = 1;
    private->abort_code = Tcl_NewDictObj();

    /* The private->abort_code ref count is decremented before 
     * request processing terminates */

    Tcl_IncrRefCount(private->abort_code);

    /*
     * mod_rivet traps call to exit and offers a chance to handle them 
     * in the way we handle ::rivet::abort_page calls
     */

    Tcl_DictObjPut(interp,private->abort_code,
                   Tcl_NewStringObj("error_code",-1),
                   Tcl_NewStringObj("exit",-1));

    Tcl_DictObjPut(interp,private->abort_code,
                   Tcl_NewStringObj("return_code",-1),
                   Tcl_NewIntObj(value));

    private->thread_exit = 1;
    private->exit_status = value;

    /* this call actually could never return for a non-threaded MPM bridge
     * as it eventually will call Tcl_Exit
     */
    Tcl_AddErrorInfo (interp, errorMessage);
    Tcl_SetErrorCode (interp, "RIVET", THREAD_EXIT_CODE, errorMessage, (char *)NULL);

    return TCL_ERROR;
}
/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_VirtualFilenameCmd --
 *
 *      Gets file according to its relationship with the request's
 *      root. (FIXME - check this).
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side Effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_VirtualFilenameCmd )
{
    rivet_thread_private*   private;
    char*                   filename;
    char*                   virtual;

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::virtual_filename")
    if( objc != 2 ) {
        Tcl_WrongNumArgs( interp, 1, objv, "filename" );
        return TCL_ERROR;
    }

    virtual  = Tcl_GetStringFromObj( objv[1], NULL );
    filename = TclWeb_GetVirtualFile( private->req, virtual );

    Tcl_SetObjResult(interp, Tcl_NewStringObj( filename, -1 ) );
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_Inspect --
 *
 *      Rivet configuration introspection. Command '::rivet::inspect' 
 *      returns a dictionary of configuration data:
 *
 * Results:
 *      A dictionary or parameter value
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_InspectCmd )
{
    rivet_thread_private*   private;
    rivet_server_conf*      rsc; 
    int                     status = TCL_OK;

    THREAD_PRIVATE_DATA(private)

    if (objc == 1)
    {
        Tcl_Obj* dictObj;

        CHECK_REQUEST_REC(private,"::rivet::inspect")
        rsc = Rivet_GetConf(private->r); 
        dictObj = Rivet_BuildConfDictionary(interp,rsc);
        if (dictObj != NULL) {
            Tcl_IncrRefCount(dictObj);
            Tcl_SetObjResult(interp,dictObj);
            Tcl_DecrRefCount(dictObj);
        } else {
            status = TCL_ERROR;
        }

    }
    else if (objc == 2)
    {
        Tcl_Obj* par_name = objv[1];
        char*    cmd_arg;

        Tcl_IncrRefCount(par_name);
        cmd_arg = Tcl_GetStringFromObj(par_name,NULL);

        if (STRNEQU(cmd_arg,"script"))
        {
            Tcl_Obj* cmd;

            if (private != NULL)
            {
                if (private->r != NULL)
                {
                    Tcl_SetObjResult(interp,Tcl_NewStringObj(private->r->filename,-1));
                    return TCL_OK;
                }
            }

            cmd = Tcl_NewStringObj("info script",-1);

            Tcl_IncrRefCount(cmd); 
            status = Tcl_EvalObjEx(interp,cmd,TCL_EVAL_DIRECT);
            Tcl_DecrRefCount(cmd);

        }
        else if (STRNEQU(cmd_arg,"-all"))
        {
            Tcl_Obj* dictObj;
            
            CHECK_REQUEST_REC(private,"::rivet::inspect -all")
            rsc = Rivet_GetConf(private->r); 
            dictObj = Rivet_CurrentConfDict(interp,rsc);
            Tcl_IncrRefCount(dictObj);
            Tcl_SetObjResult(interp,dictObj);            
            Tcl_DecrRefCount(dictObj);

        }
        else if (STRNEQU(cmd_arg,"server"))
        {
            Tcl_Obj*    dictObj;
            server_rec* srec;

            if (private == NULL) {
                srec = module_globals->server;
            } else {

                if (private->r == NULL) {
                    srec = module_globals->server; 
                } else {
                    srec = private->r->server;
                }

            }

            /* we read data from the server_rec */

            dictObj = Rivet_CurrentServerRec(interp,srec);
            Tcl_IncrRefCount(dictObj);
            Tcl_SetObjResult(interp,dictObj);            
            Tcl_DecrRefCount(dictObj);

        }
        else if (STRNEQU(cmd_arg,"exit"))
        {
            Tcl_Obj* exit_flag;
            
            CHECK_REQUEST_REC(private,"::rivet::inspect")
            /* thread exit status flag */
            exit_flag = Tcl_NewIntObj(private->thread_exit);

            Tcl_IncrRefCount(exit_flag);
            Tcl_SetObjResult(interp,exit_flag);
            Tcl_DecrRefCount(exit_flag);
        }
        else
        {
            Tcl_Obj* par_value = NULL;

            //CHECK_REQUEST_REC(private,"::rivet::inspect")
            if (private == NULL) {
                rsc = RIVET_SERVER_CONF(module_globals->server->module_config);
            } else {

                if (private->r == NULL) {
                    rsc = private->running_conf;
                } else {
                    rsc = Rivet_GetConf(private->r); 
                }

            }

            par_value = Rivet_ReadConfParameter(interp,rsc,par_name);
            if (par_value == NULL)
            {
                Tcl_Obj* errorinfo = Tcl_NewStringObj("mod_rivet internal error invalid argument: ",-1);

                Tcl_IncrRefCount(errorinfo);
                Tcl_AppendObjToObj(errorinfo,par_name);
                Tcl_AppendObjToErrorInfo(interp,errorinfo);
                Tcl_DecrRefCount(errorinfo);
                status = TCL_ERROR;
            }
            else
            {
                Tcl_IncrRefCount(par_value);
                Tcl_SetObjResult(interp,par_value);
                Tcl_DecrRefCount(par_value);
            }

        }

        Tcl_DecrRefCount(par_name);
    }
    else 
    {
        Tcl_WrongNumArgs( interp, 1, objv, "?server | dir | user? ?parameter name?" );
        status = TCL_ERROR;
    }
    return status;
}

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_LogError --
 *
 *      Log an error from Rivet
 *
 *      log_error priority message
 *
 *        priority can be one of "emerg", "alert", "crit", "err",
 *            "warning", "notice", "info", "debug"
 *
 * Results:
 *      A message is logged to the Apache error log.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_LogErrorCmd )
{
    char *message = NULL;

    server_rec *serverRec;

    int loglevelindex;
    int  apLogLevel = 0;

    static CONST84 char *logLevel[] = {
        "emerg",
        "alert",
        "crit",
        "err",
        "warning",
        "notice",
        "info",
        "debug",
        NULL
    };

    enum loglevel {
        EMERG,
        ALERT,
        CRIT,
        ERR,
        WARNING,
        NOTICE,
        INFO,
        DEBUG
    };

    rivet_thread_private*   private;

    if( objc != 3 ) {
        Tcl_WrongNumArgs( interp, 1, objv, "loglevel message" );
        return TCL_ERROR;
    }

    THREAD_PRIVATE_DATA(private)
    message = Tcl_GetString (objv[2]);
    if (Tcl_GetIndexFromObj(interp, objv[1], logLevel,
                        "emerg|alert|crit|err|warning|notice|info|debug",
                        0, &loglevelindex) == TCL_ERROR) {
        return TCL_ERROR;
    }

    switch ((enum loglevel)loglevelindex)
    {
      case EMERG:
        apLogLevel = APLOG_EMERG;
        break;

      case ALERT:
        apLogLevel = APLOG_ALERT;
        break;

      case CRIT:
        apLogLevel = APLOG_CRIT;
        break;

      case ERR:
        apLogLevel = APLOG_ERR;
        break;

      case WARNING:
        apLogLevel = APLOG_WARNING;
        break;

      case NOTICE:
        apLogLevel = APLOG_NOTICE;
        break;

      case INFO:
        apLogLevel = APLOG_INFO;
        break;

      case DEBUG:
        apLogLevel = APLOG_DEBUG;
        break;
    }

    /* if we are serving a page, we infer our server
     * from the request record, otherwise we use the
     * root server name stored in the module_globals
     */

    serverRec = ((private == NULL) || (private->r == NULL)) ? module_globals->server : private->r->server;

    ap_log_error (APLOG_MARK, apLogLevel, 0, serverRec, "%s", message);
    return TCL_OK;
}

#undef TESTPANIC
#ifdef TESTPANIC
/*
 *----------------------------------------------------------------------
 *
 * TestpanicCmd --
 *
 *      Calls the panic routine.
 *
 * Results:
 *      Always returns TCL_OK. 
 *
 * Side effects:
 *      May exit application.
 *
 *----------------------------------------------------------------------
 */

static int
TestpanicCmd(dummy, interp, argc, argv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int argc;                           /* Number of arguments. */
    CONST char **argv;                  /* Argument strings. */
{
    CONST char *argString;

    /*
     *  Put the arguments into a var args structure
     *  Append all of the arguments together separated by spaces
     */

    argString = Tcl_Merge(argc-1, argv+1);
    panic("%s",argString);
    ckfree((char *)argString);

    return TCL_OK;
}
#endif /* TESTPANIC  */

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_UrlScript --
 *
 *      Builds the full URL referenced script composed by before_script,
 *      url referenced script and after_script. This command should not
 *      be called by ordinary application development
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side Effects:
 *      returns a Tcl script.
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_UrlScript )
{
    rivet_thread_private* private;
    char*                cache_key;
    rivet_thread_interp* rivet_interp;
    Tcl_HashEntry*       entry  = NULL;
    Tcl_Obj*             script = NULL;
    int                  result;
    unsigned int         user_conf; 
    time_t               ctime;
    time_t               mtime;

    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::url_script")

    user_conf = IS_USER_CONF(private->running_conf);

    rivet_interp = RIVET_PEEK_INTERP(private,private->running_conf);
    ctime = private->r->finfo.ctime;
    mtime = private->r->finfo.mtime;
    cache_key = RivetCache_MakeKey(private->pool,private->r->filename,ctime,mtime,user_conf,1);

    entry = RivetCache_EntryLookup (rivet_interp,cache_key);
    if (entry == NULL)
    {
        Tcl_Interp*     interp;
        
        interp = rivet_interp->interp;

        script = Tcl_NewObj();
        Tcl_IncrRefCount(script);
        /*
         * We check whether we are dealing with a pure Tcl script or a Rivet template.
         * Actually this check is done only if we are processing a toplevel file, every nested
         * file (files included through the 'parse' command) is treated as a template.
         */

        if (Rivet_CheckType(private->r) == RIVET_TEMPLATE)
        {
            result = Rivet_GetRivetFile(private->r->filename,script,interp);

        } else {

            /* It's a plain Tcl file */
            result = Rivet_GetTclFile(private->r->filename, script, interp);

        }

        if (result == TCL_OK)
        {
            /* let's check the cache for free entries */

            if (rivet_interp->cache_free > 0)
            {
                int isNew;
                Tcl_HashEntry* entry;

                entry = RivetCache_CreateEntry (rivet_interp,cache_key,&isNew);
    
                /* Sanity check: we are here for this reason */

                ap_assert(isNew == 1);
            
                /* we proceed storing the script in the cache */

                RivetCache_StoreScript(rivet_interp,entry,script);
            }
            else if ((rivet_interp->flags & RIVET_CACHE_FULL) == 0)
            {
                rivet_interp->flags |= RIVET_CACHE_FULL;
                ap_log_error (APLOG_MARK, APLOG_NOTICE, APR_EGENERAL,private->r->server,"%s %s (%s),",
                                                                      "Rivet cache full when serving ",
                                                                      private->r->filename,
                                                                      private->r->server->server_hostname);
            }
        }
        Tcl_SetObjResult(rivet_interp->interp, script);
        Tcl_DecrRefCount(script);

    } else {
        Tcl_SetObjResult(rivet_interp->interp,RivetCache_FetchScript(entry));
    }

    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 * Rivet_GetThreadId --
 *
 * With a threaded bridge (worker and lazy) command [pid] on Unix systems return
 * the same process id when called from all threads running within that process.
 * For any debugging reason this command returns a unique thread identification
 * that can, for instance, be matched with the thread id (tid) information 
 * in the error log file.
 *
 * Arguments:
 *
 *      Output format: -hex (default) | -decimal
 *
 * Results:
 *
 *      Tcl object with a string representation of the thread id
 *
 * Side effects:
 *
 *      None
 *
 *-----------------------------------------------------------------------------
 */

#define SMALL_BUFFER_SIZE 32

TCL_CMD_HEADER( Rivet_GetThreadId )
{
    char                    buff[SMALL_BUFFER_SIZE];
    apr_os_thread_t         threadid;
    char*                   format_hex = "0x%8.8lx";
    char*                   format_dec = "%ld";
    char*                   output_format = format_hex;
    int                     wrong_args = false;
    //rivet_thread_interp*    interp_obj;

    // interp_obj = RIVET_PEEK_INTERP(private,private->running_conf);
    if (objc == 2)
    {
        Tcl_Obj* argobj = objv[1];
        char*    cmd_arg;

        Tcl_IncrRefCount(argobj);
        cmd_arg = Tcl_GetStringFromObj(argobj,NULL);
        if (STRNEQU(cmd_arg,"-hex"))
        {
            output_format = format_hex;
        }
        else if (STRNEQU(cmd_arg,"-decimal"))
        {
            output_format = format_dec;
        }
        else
        {
            wrong_args = true;
        }
        Tcl_DecrRefCount(argobj);

        if (wrong_args)
        {
            Tcl_AddObjErrorInfo(interp,"Wrong argument: it must be -decimal | -hex", -1);
            return TCL_ERROR;
        }
    } 
    else if (objc > 2)
    {
        Tcl_WrongNumArgs(interp,1,objv,"-decimal | -hex" );
        return TCL_ERROR;
    }

    /* Let's get the thread id and return it in the requested format */

    threadid = apr_os_thread_current();
    snprintf(buff,SMALL_BUFFER_SIZE,output_format,threadid);

    Tcl_SetObjResult(interp,Tcl_NewStringObj(buff,strlen(buff)));
    return TCL_OK;
}

#ifdef RIVET_DEBUG_BUILD
/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_CacheContent --
 *
 *      Dumping in a list the cache content. For debugging purposes.
 *      This command will be placed within conditional compilation and
 *      documented within the 'Rivet Internals' section of the manual
 *
 * Results:
 *      
 *      a Tcl list of the keys in the interpreter cache
 *
 * Side Effects:
 *
 *      none
 *
 *-----------------------------------------------------------------------------
 */

TCL_CMD_HEADER( Rivet_CacheContent )
{
    Tcl_Obj*                entry_list;
    rivet_thread_private*   private;
    rivet_thread_interp*    rivet_interp;
    int                     ep;
    THREAD_PRIVATE_DATA(private)
    CHECK_REQUEST_REC(private,"::rivet::cache_content")

    rivet_interp = RIVET_PEEK_INTERP(private,private->running_conf);
    interp = rivet_interp->interp;
    
    entry_list = Tcl_NewObj();
    Tcl_IncrRefCount(entry_list);

    ep = rivet_interp->cache_size - 1;
    
    while ((ep >= 0) && (rivet_interp->objCacheList[ep]))
    {
        int tcl_status;

        tcl_status = Tcl_ListObjAppendElement(interp,entry_list,Tcl_NewStringObj(rivet_interp->objCacheList[ep],-1));

        if (tcl_status != TCL_OK) {
            return tcl_status;
        }

        ep--;
    }
    Tcl_SetObjResult(interp,entry_list);
    Tcl_DecrRefCount(entry_list);
    return TCL_OK;
}

#endif /* RIVET_DEBUG_BUILD */

/*
 *-----------------------------------------------------------------------------
 *
 * Rivet_InitCore --
 *
 *      Creates the core rivet commands.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side Effects:
 *      Creates new commands.
 *
 *-----------------------------------------------------------------------------
 */

DLLEXPORT int
Rivet_InitCore(Tcl_Interp *interp,rivet_thread_private* private)
{
    rivet_server_conf*      server_conf; 

    RIVET_OBJ_CMD ("makeurl",Rivet_MakeURL,private);
    RIVET_OBJ_CMD ("headers",Rivet_Headers,private);
    RIVET_OBJ_CMD ("load_env",Rivet_LoadEnv,private);
    RIVET_OBJ_CMD ("load_headers",Rivet_LoadHeaders,private);
    RIVET_OBJ_CMD ("var",Rivet_Var,private);
    RIVET_OBJ_CMD ("abort_page",Rivet_AbortPageCmd,private);
    RIVET_OBJ_CMD ("abort_code", Rivet_AbortCodeCmd,private);
    RIVET_OBJ_CMD ("virtual_filename",Rivet_VirtualFilenameCmd,private);
    RIVET_OBJ_CMD ("apache_table",Rivet_ApacheTable,private);
    RIVET_OBJ_CMD ("var_qs",Rivet_Var,private);
    RIVET_OBJ_CMD ("var_post",Rivet_Var,private);
    RIVET_OBJ_CMD ("raw_post",Rivet_RawPost,private);
    RIVET_OBJ_CMD ("upload",Rivet_Upload,private);
    RIVET_OBJ_CMD ("include",Rivet_Include,private);
    RIVET_OBJ_CMD ("parse",Rivet_Parse,private);
    RIVET_OBJ_CMD ("no_body",Rivet_NoBody,private);
    RIVET_OBJ_CMD ("env",Rivet_EnvCmd,private);
    RIVET_OBJ_CMD ("apache_log_error",Rivet_LogErrorCmd,private);
    RIVET_OBJ_CMD ("inspect",Rivet_InspectCmd,private);
    RIVET_OBJ_CMD ("exit",Rivet_ExitCmd,private);
    RIVET_OBJ_CMD ("url_script",Rivet_UrlScript,private);
    RIVET_OBJ_CMD ("thread_id",Rivet_GetThreadId,private);
    
#ifdef RIVET_DEBUG_BUILD
    /* code compiled conditionally for debugging */
    RIVET_OBJ_CMD ("cache_content",Rivet_CacheContent,private);
#endif
#ifdef TESTPANIC
    RIVET_OBJ_CMD ("testpanic",TestpanicCmd,private);
#endif

    /*
     * we don't need to check the virtual host server conf
     * stored in 'private' in order to determine if we are
     * exporting the command set, as this flag is meaningful
     * at the global level
     */
    server_conf = RIVET_SERVER_CONF(module_globals->server->module_config);

    if (server_conf->export_rivet_ns)
    {
        rivet_interp_globals *globals = NULL;
        Tcl_Namespace *rivet_ns;

        globals = Tcl_GetAssocData(interp, "rivet", NULL);
        rivet_ns = globals->rivet_ns;

        RIVET_EXPORT_CMD(interp,rivet_ns,"makeurl");
        RIVET_EXPORT_CMD(interp,rivet_ns,"headers");
        RIVET_EXPORT_CMD(interp,rivet_ns,"load_env");
        RIVET_EXPORT_CMD(interp,rivet_ns,"load_headers");
        RIVET_EXPORT_CMD(interp,rivet_ns,"var");
        RIVET_EXPORT_CMD(interp,rivet_ns,"abort_page");
        RIVET_EXPORT_CMD(interp,rivet_ns,"abort_code");
        RIVET_EXPORT_CMD(interp,rivet_ns,"virtual_filename");
        RIVET_EXPORT_CMD(interp,rivet_ns,"apache_table");
        RIVET_EXPORT_CMD(interp,rivet_ns,"var_qs");
        RIVET_EXPORT_CMD(interp,rivet_ns,"var_post");
        RIVET_EXPORT_CMD(interp,rivet_ns,"raw_post");
        RIVET_EXPORT_CMD(interp,rivet_ns,"upload");
        RIVET_EXPORT_CMD(interp,rivet_ns,"include");
        RIVET_EXPORT_CMD(interp,rivet_ns,"parse");
        RIVET_EXPORT_CMD(interp,rivet_ns,"no_body");
        RIVET_EXPORT_CMD(interp,rivet_ns,"env");
        RIVET_EXPORT_CMD(interp,rivet_ns,"apache_log_error");
        RIVET_EXPORT_CMD(interp,rivet_ns,"inspect");
        RIVET_EXPORT_CMD(interp,rivet_ns,"thread_id");
        // ::rivet::exit is not exported
    }

    return TCL_OK;
}