/*
 *
 * t c l - l i b . c 		- A library remplacement for simulating 
 *				  a Tcl interpreter in Scheme
 *
 * Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 * 
 *
 * Permission to use, copy, and/or distribute this software and its
 * documentation for any purpose and without fee is hereby granted, provided
 * that both the above copyright notice and this permission notice appear in
 * all copies and derived works.  Fees for distribution or use of this
 * software or derived works may only be charged with express written
 * permission of the copyright holder.  
 * This software is provided ``as is'' without express or implied warranty.
 *
 * This software is a derivative work of other copyrighted softwares; the
 * copyright notices of these softwares are placed in the file COPYRIGHTS
 *
 *
 *            Author: Erick Gallesio [eg@unice.fr]
 *    Creation date: 19-Feb-1993 22:15
 * Last file update:  5-Jun-1995 15:16
 *
 */

#ifdef USE_TK
#include <varargs.h>
#include "stk.h"


/******************************************************************************
 *
 *				Eval functions
 *
 ******************************************************************************/

int Tcl_GlobalEval(interp, s)
     Tcl_Interp *interp;
     char *s;
{
  char *buffer = "";
  SCM result;

  if (*s == '\0') return TCL_OK;

  /* In some situations Tk append some data (numbers) to the callback. This
   * arise for scrollbars and scales. This parameters are normally used to
   * reflect slider position. When such a situation arises, we have to 
   * specify the callback as a string and add a pair of parenthesis around
   * this string to form a valid sexpr. To recognize such cases, we look
   * at first character: if it is not an open parenthesis, we add a pair of ()
   * around the callback string 
   * 
   */

  if (*s != '(') {
    /* Build the command to evaluate by adding a pair of parenthesis */
    buffer = must_malloc(strlen(s)+3);
    sprintf(buffer, "(%s)", s);
    s = buffer;
  }
  result = STk_internal_eval_string(s, ERR_TK_BACKGROUND, NIL);
  Tcl_ResetResult(interp);
    
  if (*buffer) free(buffer);

  if (result != EVAL_ERROR) {
    SCM dumb;

    Tcl_SetResult(interp, 
		  STk_Stringify(STk_convert_for_tk(result, &dumb), 0), 
		  TCL_DYNAMIC);
    return TCL_OK;
  }
  
  return TCL_ERROR;
}

int Tcl_Eval(interp, s) 	/* very simplist. */
     Tcl_Interp *interp;	/* But do we need something more clever? */
     char *s;
{
  return Tcl_GlobalEval(interp, s);
}

#ifndef lint
int Tcl_VarEval(va_alist)
#else
int Tcl_VarEval(iPtr, p, va_alist)
    Tcl_Interp *iPtr;		/* Interpreter in which to execute command. */
    char *p;			/* One or more strings to concatenate,
				 * terminated with a NULL string. */
#endif
    va_dcl
{
    va_list argList;
#define FIXED_SIZE 200
    char fixedSpace[FIXED_SIZE+1];
    int spaceAvl, spaceUsed, length;
    char *string, *cmd;
    Tcl_Interp *interp;
    int result;

    /*
     * Copy the strings one after the other into a single larger
     * string.  Use stack-allocated space for small commands, but if
     * the commands gets too large than call ckalloc to create the
     * space.
     */

    va_start(argList);
    interp = va_arg(argList, Tcl_Interp *);
    spaceAvl = FIXED_SIZE;
    spaceUsed = 0;
    cmd = fixedSpace;
    while (1) {
	string = va_arg(argList, char *);
	if (string == NULL) {
	    break;
	}
	length = strlen(string);
	if ((spaceUsed + length) > spaceAvl) {
	    char *new;

	    spaceAvl = spaceUsed + length;
	    spaceAvl += spaceAvl/2;
	    new = ckalloc((unsigned) spaceAvl);
	    memcpy((VOID *) new, (VOID *) cmd, spaceUsed);
	    if (cmd != fixedSpace) {
		ckfree(cmd);
	    }
	    cmd = new;
	}
	strcpy(cmd + spaceUsed, string);
	spaceUsed += length;
    }
    va_end(argList);
    cmd[spaceUsed] = '\0';

    result = Tcl_GlobalEval(interp, cmd);
    if (cmd != fixedSpace) {
	ckfree(cmd);
    }
    return result;
}


/******************************************************************************
 *
 *	      Variable accesses (GetVar, GetVar2, SetVar, SetVar2)
 *
 ******************************************************************************/

char *Tcl_GetVar(interp, var, flags)
     Tcl_Interp *interp;	/* not used */
     char *var;
     int flags;
{
  SCM dumb, V = VCELL(Intern(var));
  return (V == UNBOUND) ? NULL : STk_convert_for_tk(V, &dumb);
}

char *Tcl_GetVar2(interp, name1, name2, flags)
     Tcl_Interp *interp;	/* not used */
     char *name1, *name2;
     int flags;
{
  if (name2 && *name2) {
    char *res, *s = must_malloc(strlen(name1) + strlen(name2) + 3);

    sprintf(s, "%s{%s}", name1, name2);
    res = Tcl_GetVar(interp, s, flags);
    free(s);
    return res;
  }
  return Tcl_GetVar(interp, name1, flags);
}

char *Tcl_SetVar(interp, var, val, flags)
     Tcl_Interp *interp;
     char *var, *val;
     int flags;
{
  /* Eval the following expression: (set! var val) */
  VCELL(Intern(var)) = STk_makestring(val);
  Tcl_ChangeValue(var); 
  return val;
}

char *Tcl_SetVar2(interp, name1, name2, val, flags)
     Tcl_Interp *interp;
     char *name1, *name2, *val;
     int flags;
{ 
  if (name2 && *name2) {
    char *res, *s = must_malloc(strlen(name1) + strlen(name2) + 3);

    sprintf(s, "%s{%s}", name1, name2);
    res = Tcl_SetVar(interp, s, val, flags);
    free(s);
    return res;
  }
  return Tcl_SetVar(interp, name1, val, flags);
}

/******************************************************************************
 *
 *			    Tcl command management
 *
 ******************************************************************************/


int Tcl_DeleteCommand(interp, cmdName)
     Tcl_Interp *interp;
     char *cmdName;
{
  struct Tk_command *W;
  Interp *iPtr = (Interp *) interp;
  Tcl_HashEntry *hPtr;

  hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);
  if (hPtr == NULL) return -1;

  W = (struct Tk_command *) Tcl_GetHashValue(hPtr);
  /* Execute the delete handler */
  if (W->delproc != NULL) (*W->delproc)(W->ptr);

  /* Note: W will be freed by the GC */
  Tcl_DeleteHashEntry(hPtr);

  /* Undefine "cmdName" by doing a (set! cmdname #<unbound>) */
  VCELL(Intern(cmdName)) = UNBOUND;
  W->Id[0] = 0; /* To avoid to make again a call to this function from GC */
  return 0;
}

void Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
     Tcl_Interp *interp;		
     char *cmdName;
     Tcl_CmdProc *proc;
     ClientData clientData;
     Tcl_CmdDeleteProc *deleteProc;
{
  SCM z, var;
  struct Tk_command *W;

  /* Define a variable whose name is the command name */
  var = Intern(cmdName); 
  NEWCELL(z, tc_tkcommand);
  VCELL(var) = z;

  W = (struct Tk_command *) must_malloc(sizeof(struct Tk_command)+strlen(cmdName));
  W->ptr 	   = clientData;
  W->fct 	   = proc;
  W->delproc       = deleteProc;
  W->string_result = 0; /* by default */
  strcpy(W->Id, cmdName);

  /* 
   * Save the current environment in the object. 
   * This permit to have callback which can reference things in the
   * environment creation. Furthermore, this environment being known by the
   * Scheme interpreter, it will not be garbaged.
   *
   */
  W->environment = STk_top_env_stack();
  
  z->storage_as.tk.data   = W;
  z->storage_as.tk.l_data = Ntruth;

  /* Now enter this command in the interpreter table of commands so that 
   * all the commands created will be destroyed when the interpreter will 
   * be deleted . Probably not very useful since commands have generally
   * a null associated delete procedure. But extensions package could 
   * rely on it.....
   */
  {
    Interp *iPtr = (Interp *) interp;
    struct Tk_command *old_W;
    Tcl_HashEntry *hPtr;
    int new;

    hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
    if (!new) {
      /*
       * Command already exists:  delete the old one.
       */

      old_W = (struct Tk_command *) Tcl_GetHashValue(hPtr);
      if (old_W->delproc != NULL) {
	(*old_W->delproc)(old_W->ptr);
      }
    } 
    else 
      Tcl_SetHashValue(hPtr, W);
  }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandInfo --
 *
 *	Returns various information about a Tcl command.
 *
 * Results:
 *	If cmdName exists in interp, then *infoPtr is modified to
 *	hold information about cmdName and 1 is returned.  If the
 *	command doesn't exist then 0 is returned and *infoPtr isn't
 *	modified.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetCommandInfo(interp, cmdName, infoPtr)
    Tcl_Interp *interp;			/* Interpreter in which to look
					 * for command. */
    char *cmdName;			/* Name of desired command. */
    Tcl_CmdInfo *infoPtr;		/* Where to store information about
					 * command. */
{
    SCM v = Intern(cmdName);
    
    if (NTKCOMMP(VCELL(v))) return 0;

    infoPtr->proc       = (VCELL(v)->storage_as.tk.data)->fct;
    infoPtr->clientData = (VCELL(v)->storage_as.tk.data)->ptr;
    infoPtr->deleteProc = NULL;
    infoPtr->deleteData = NULL;
    return 1;
}


/******************************************************************************
 *
 *			  Tcl interpreter management
 *
 ******************************************************************************/

Tcl_Interp *Tcl_CreateInterp()
{
  register Interp *iPtr = (Interp *) ckalloc(sizeof(Interp));
  
  iPtr->result		 = iPtr->resultSpace;
  iPtr->freeProc	 = 0;
  iPtr->errorLine	 = 0;
  iPtr->resultSpace[0]   = 0;
  
  iPtr->appendResult	 = NULL;
  iPtr->appendAvl	 = 0;
  iPtr->appendUsed	 = 0;

  strcpy(iPtr->pdFormat, "%g");

  iPtr->deleteCallbackPtr= NULL;

  /* See Tcl_CreateCommand for this table utility  */
  Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS);

  return (Tcl_Interp *) iPtr;
}

void Tcl_DeleteInterp(interp)
    Tcl_Interp *interp;
{
  Interp *iPtr = (Interp *) interp;
  Tcl_HashEntry *hPtr;
  Tcl_HashSearch search;
  struct Tk_command *W;

  /* Delete result space */
  if (iPtr->appendResult != NULL) {
    ckfree(iPtr->appendResult);
  }
  
  /* delete hash table of Tk commands (see Tcl_CreateCommand) */
  for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
       hPtr != NULL; 
       hPtr = Tcl_NextHashEntry(&search)) {

    W = (struct Tk_command *) Tcl_GetHashValue(hPtr);
    if (W->delproc != NULL) (*W->delproc)(W->ptr);
    
    /* Undefine "cmdName" by doing a (set! cmdname #<unbound>) */
    VCELL(Intern(W->Id)) = UNBOUND;
  }
  Tcl_DeleteHashTable(&iPtr->commandTable);

  ckfree((char *) iPtr);
}

#endif /* USE_TK */