/*
** This program is free software; you can redistribute it and/or
** modify it under the terms of the Simplified BSD License (also
** known as the "2-Clause License" or "FreeBSD License".)
**
** This program is distributed in the hope that it will be useful,
** but without any warranty; without even the implied warranty of
** merchantability or fitness for a particular purpose.
**
*******************************************************************************
** This file contains code used to bridge the Jim and Tcl scripting languages.
*/

#include "config.h"

#ifdef FOSSIL_ENABLE_TCL

#include "jim.h"
#include "tcl.h"

/*
** Are we being compiled against Tcl 8.6 or higher?
 */
#if (TCL_MAJOR_VERSION > 8) || \
    ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 6))
/*
** Workaround NRE-specific issue in Tcl_EvalObjCmd (SF bug #3399564) by using
** Tcl_EvalObjv instead of invoking the objProc directly.
 */
#define USE_TCL_EVALOBJV   1
#endif

/*
** These macros are designed to reduce the redundant code required to marshal
** arguments from Jim to Tcl.
 */
#define USE_ARGV_TO_OBJV() \
  int objc;                \
  Tcl_Obj **objv;          \
  int i;

#define COPY_ARGV_TO_OBJV()                                                 \
  objc = argc-1;                                                            \
  objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));         \
  for(i=1; i<argc; i++){                                                    \
    objv[i-1] = Tcl_NewStringObj(Jim_String(argv[i]), Jim_Length(argv[i])); \
    Tcl_IncrRefCount(objv[i-1]);                                            \
  }

#define FREE_ARGV_TO_OBJV()      \
  for(i=1; i<argc; i++){         \
    Tcl_DecrRefCount(objv[i-1]); \
  }                              \
  ckfree((char *)objv);

/*
** Fetch the Tcl interpreter from the specified void pointer, cast to a Tcl
** context.
 */
#define GET_CTX_TCL_INTERP(ctx) \
  ((struct TclContext *)(ctx))->interp

/*
** Creates and initializes a Tcl interpreter for use with the specified Jim
** interpreter.  Stores the created Tcl interpreter in the Tcl context supplied
** by the caller.  This must be declared here because quite a few functions in
** this file need to use it before it can be defined.
 */
static int createTclInterp(Jim_Interp *interp, void *pContext);

/*
** Returns the Tcl interpreter result as a string with the associated length.
** If the Tcl interpreter or the Tcl result are NULL, the length will be 0.
** If the length pointer is NULL, the length will not be stored.
 */
static char *getTclResult(
  Tcl_Interp *pInterp,
  int *pN
){
  Tcl_Obj *resultPtr;
  if( !pInterp ){ /* This should not happen. */
    if( pN ) *pN = 0;
    return 0;
  }
  resultPtr = Tcl_GetObjResult(pInterp);
  if( !resultPtr ){ /* This should not happen either? */
    if( pN ) *pN = 0;
    return 0;
  }
  return Tcl_GetStringFromObj(resultPtr, pN);
}

/*
** Tcl context information used by Jim.  This structure definition has been
** copied from and should be kept in sync with the one in "main.c".
*/
struct TclContext {
  int argc;
  char **argv;
  Tcl_Interp *interp;
};

/*
** Syntax:
**
**   tclEval arg ?arg ...?
*/
static int tclEval_command(
  Jim_Interp *interp,
  int argc,
  Jim_Obj *const *argv
){
  Tcl_Interp *tclInterp;
  Tcl_Obj *objPtr;
  int rc;
  int nResult;
  const char *zResult;
  void *ctx = Jim_CmdPrivData(interp);

  if ( createTclInterp(interp, ctx)!=JIM_OK ){
    return JIM_ERR;
  }
  if( argc<2 ){
    Jim_WrongNumArgs(interp, 1, argv, "arg ?arg ...?");
    return JIM_ERR;
  }
  tclInterp = GET_CTX_TCL_INTERP(ctx);
  if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
    Jim_SetResultString(interp, "invalid Tcl interpreter", -1);
    return JIM_ERR;
  }
  Tcl_Preserve((ClientData)tclInterp);
  if( argc==2 ){
    objPtr = Tcl_NewStringObj(Jim_String(argv[1]), Jim_Length(argv[1]));
    Tcl_IncrRefCount(objPtr);
    rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
    Tcl_DecrRefCount(objPtr);
  }else{
    USE_ARGV_TO_OBJV();
    COPY_ARGV_TO_OBJV();
    objPtr = Tcl_ConcatObj(objc, objv);
    Tcl_IncrRefCount(objPtr);
    rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
    Tcl_DecrRefCount(objPtr);
    FREE_ARGV_TO_OBJV();
  }
  zResult = getTclResult(tclInterp, &nResult);
  Jim_SetResultString(interp, zResult, nResult);
  Tcl_Release((ClientData)tclInterp);
  return rc;
}

/*
** Syntax:
**
**   tclExpr arg ?arg ...?
*/
static int tclExpr_command(
  Jim_Interp *interp,
  int argc,
  Jim_Obj *const *argv
){
  Tcl_Interp *tclInterp;
  Tcl_Obj *objPtr;
  Tcl_Obj *resultObjPtr;
  int rc;
  int nResult;
  const char *zResult;
  void *ctx = Jim_CmdPrivData(interp);

  if ( createTclInterp(interp, ctx)!=JIM_OK ){
    return JIM_ERR;
  }
  if( argc<2 ){
    Jim_WrongNumArgs(interp, 1, argv, "arg ?arg ...?");
    return JIM_ERR;
  }
  tclInterp = GET_CTX_TCL_INTERP(ctx);
  if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
    Jim_SetResultString(interp, "invalid Tcl interpreter", -1);
    return JIM_ERR;
  }
  Tcl_Preserve((ClientData)tclInterp);
  if( argc==2 ){
    objPtr = Tcl_NewStringObj(Jim_String(argv[1]), Jim_Length(argv[1]));
    Tcl_IncrRefCount(objPtr);
    rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
    Tcl_DecrRefCount(objPtr);
  }else{
    USE_ARGV_TO_OBJV();
    COPY_ARGV_TO_OBJV();
    objPtr = Tcl_ConcatObj(objc, objv);
    Tcl_IncrRefCount(objPtr);
    rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
    Tcl_DecrRefCount(objPtr);
    FREE_ARGV_TO_OBJV();
  }
  if( rc==TCL_OK ){
    zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
  }else{
    zResult = getTclResult(tclInterp, &nResult);
  }
  Jim_SetResultString(interp, zResult, nResult);
  if( rc==TCL_OK ) Tcl_DecrRefCount(resultObjPtr);
  Tcl_Release((ClientData)tclInterp);
  return rc;
}

/*
** Syntax:
**
**   tclInvoke command ?arg ...?
*/
static int tclInvoke_command(
  Jim_Interp *interp,
  int argc,
  Jim_Obj *const *argv
){
  Tcl_Interp *tclInterp;
#ifndef USE_TCL_EVALOBJV
  Tcl_Command command;
  Tcl_CmdInfo cmdInfo;
#endif
  int rc;
  int nResult;
  const char *zResult;
  void *ctx = Jim_CmdPrivData(interp);
#ifndef USE_TCL_EVALOBJV
  Tcl_Obj *objPtr;
#endif
  USE_ARGV_TO_OBJV();

  if ( createTclInterp(interp, ctx)!=JIM_OK ){
    return JIM_ERR;
  }
  if( argc<2 ){
    Jim_WrongNumArgs(interp, 1, argv, "command ?arg ...?");
    return JIM_ERR;
  }
  tclInterp = GET_CTX_TCL_INTERP(ctx);
  if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
    Jim_SetResultString(interp, "invalid Tcl interpreter", -1);
    return JIM_ERR;
  }
  Tcl_Preserve((ClientData)tclInterp);
#ifndef USE_TCL_EVALOBJV
  objPtr = Tcl_NewStringObj(Jim_String(argv[1]), Jim_Length(argv[1]));
  Tcl_IncrRefCount(objPtr);
  command = Tcl_GetCommandFromObj(tclInterp, objPtr);
  if( !command || Tcl_GetCommandInfoFromToken(command,&cmdInfo)==0 ){
    Jim_SetResultFormatted(interp, "Tcl command not found: %#s", argv[1]);
    Tcl_DecrRefCount(objPtr);
    Tcl_Release((ClientData)tclInterp);
    return JIM_ERR;
  }
  if( !cmdInfo.objProc ){
    Jim_SetResultFormatted(interp, "Cannot invoke command not found: %#s",
        argv[1]);
    Tcl_DecrRefCount(objPtr);
    Tcl_Release((ClientData)tclInterp);
    return JIM_ERR;
  }
  Tcl_DecrRefCount(objPtr);
#endif
  COPY_ARGV_TO_OBJV();
#ifdef USE_TCL_EVALOBJV
  rc = Tcl_EvalObjv(tclInterp, objc, objv, 0);
#else
  Tcl_ResetResult(tclInterp);
  rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
#endif
  FREE_ARGV_TO_OBJV();
  zResult = getTclResult(tclInterp, &nResult);
  Jim_SetResultString(interp, zResult, nResult);
  Tcl_Release((ClientData)tclInterp);
  return rc;
}

/*
** Syntax:
**
**   bridgeEval arg
*/
static int BridgeEvalObjCmd(
  ClientData clientData,
  Tcl_Interp *interp,
  int objc,
  Tcl_Obj *CONST objv[]
){
  Jim_Interp *jimInterp;
  int nArg;
  const char *arg;
  int rc;
  Jim_Obj *argObj;
  Jim_Obj *resultObj;

  if( objc!=2 ){
    Tcl_WrongNumArgs(interp, 1, objv, "arg");
    return TCL_ERROR;
  }
  jimInterp = (Jim_Interp *)clientData;
  if( !jimInterp ){
    Tcl_AppendResult(interp, "invalid bridge interpreter", NULL);
    return TCL_ERROR;
  }
  arg = Tcl_GetStringFromObj(objv[1], &nArg);
  argObj = Jim_NewStringObj(jimInterp, arg, nArg);
  Jim_IncrRefCount(argObj);
  rc = Jim_EvalObj(jimInterp, argObj);
  Jim_DecrRefCount(jimInterp, argObj);
  resultObj = Jim_GetResult(jimInterp);
  arg = Jim_GetString(resultObj, &nArg);
  Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, nArg));
  return rc;
}

/*
** Syntax:
**
**   bridgeExpr arg
*/
static int BridgeExprObjCmd(
  ClientData clientData,
  Tcl_Interp *interp,
  int objc,
  Tcl_Obj *CONST objv[]
){
  Jim_Interp *jimInterp;
  int nArg;
  const char *arg;
  int rc;
  Jim_Obj *argObj;
  Jim_Obj *resultObj;

  if( objc!=2 ){
    Tcl_WrongNumArgs(interp, 1, objv, "arg");
    return TCL_ERROR;
  }
  jimInterp = (Jim_Interp *)clientData;
  if( !jimInterp ){
    Tcl_AppendResult(interp, "invalid bridge interpreter", NULL);
    return TCL_ERROR;
  }
  arg = Tcl_GetStringFromObj(objv[1], &nArg);
  argObj = Jim_NewStringObj(jimInterp, arg, nArg);
  Jim_IncrRefCount(argObj);
  rc = Jim_EvalExpression(jimInterp, argObj, &resultObj);
  Jim_DecrRefCount(jimInterp, argObj);
  if (rc == JIM_OK) {
    arg = Jim_GetString(resultObj, &nArg);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, nArg));
  }
  return rc;
}

/*
** Array of Tcl integration commands.  Used when adding or removing the Tcl
** integration commands from Jim.
*/
static struct _Command {
  const char *zName;
  Jim_CmdProc xProc;
  void *pContext;
} aCommand[] = {
  {"tclEval",   tclEval_command,   0},
  {"tclExpr",   tclExpr_command,   0},
  {"tclInvoke", tclInvoke_command, 0},
  {0, 0, 0}
};

/*
** Called if the Tcl interpreter is deleted.  Removes the Tcl integration
** commands from the Jim interpreter.
 */
static void BridgeDeleteProc(
  ClientData clientData,
  Tcl_Interp *interp
){
  int i;
  Jim_Interp *jimInterp = (Jim_Interp *)clientData;
  if( !jimInterp ) return;
  /* Remove the Tcl integration commands. */
  for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
    Jim_DeleteCommand(jimInterp, aCommand[i].zName);
  }
}

/*
** Creates and initializes a Tcl interpreter for use with the specified Jim
** interpreter.  Stores the created Tcl interpreter in the Tcl context supplied
** by the caller.
 */
static int createTclInterp(
  Jim_Interp *interp,
  void *pContext
){
  struct TclContext *tclContext = (struct TclContext *)pContext;
  Tcl_Interp *tclInterp;

  if ( !tclContext ){
    Jim_SetResultString(interp, "Invalid Tcl context", -1);
    return JIM_ERR;
  }
  if ( tclContext->interp ){
    return JIM_OK;
  }
  if ( tclContext->argc>0 && tclContext->argv ) {
    Tcl_FindExecutable(tclContext->argv[0]);
  }
  tclInterp = tclContext->interp = Tcl_CreateInterp();
  if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
    Jim_SetResultString(interp, "Could not create Tcl interpreter", -1);
    return JIM_ERR;
  }
  if( Tcl_Init(tclInterp)!=TCL_OK ){
    Jim_SetResultFormatted(interp, "Tcl initialization error: %s",
        Tcl_GetStringResult(tclInterp));
    Tcl_DeleteInterp(tclInterp);
    tclContext->interp = tclInterp = 0;
    return JIM_ERR;
  }
  /* Add the Jim integration commands to Tcl. */
  Tcl_CallWhenDeleted(tclInterp, BridgeDeleteProc, interp);
  Tcl_CreateObjCommand(tclInterp, "bridgeEval", BridgeEvalObjCmd, interp, NULL);
  Tcl_CreateObjCommand(tclInterp, "bridgeExpr", BridgeExprObjCmd, interp, NULL);
  return JIM_OK;
}

/*
** Register the Tcl language commands with interpreter interp.
** Usually this is called soon after interpreter creation.
*/
int register_tcl(
  Jim_Interp *interp,
  void *pContext
){
  int i;
  /* Add the Tcl integration commands to Jim. */
  for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
    void *ctx = aCommand[i].pContext;
    /* Use Tcl interpreter for context? */
    if( !ctx ) ctx = pContext;
    Jim_CreateCommand(interp, aCommand[i].zName, aCommand[i].xProc, ctx, NULL);
  }
  return JIM_OK;
}

#endif /* FOSSIL_ENABLE_TCL */