/*
 *
 * t c l - t r a c e . c 		-- Variable Tracing
 * 
 * Variable tracing is important in Tk since some widgets intensively use this
 * mechanism. For instance, a check-button has a variable associated to it.
 * When the button is clicked, the variable is set and when the variable is 
 * modified, button state is consequntly changed (last case is done with a trace
 * over the associated variable). Tcl trace mechanism is more general than this;
 * the mechanism implemented here is just intended to mimic the trace over 
 * variable writing (reading a var is not used by Tk and procedure tracing is a
 * common thing easy to do in the Lisp world).
 * Note: a single variable can be associated to several C functions (For instance
 * when a radio-button associated variable is changed, a C function is used to 
 * clear the selector and another to hilight the new selector). So, traces are 
 * stored in a linked list (all traces are called on variable changement).
 *
 * Note:
 *    - Implementation use Tcl hash tables to see if a variable is traced.
 *    - TCL_TRACE_READS is used here to indicate that the data associated 
 *	with the traced variable must be freed when the trace is unset
 *	UGLY HACK used when we untrace a trace obtained by "trace-var".
 *
 * 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: 24-Feb-1993 13:07
 * Last file update: 15-Apr-1995 22:24
 *
 */
#ifdef USE_TK
#include "stk.h"

#define TRACING (1<<20)
/* #define STR2KEY(var) ((char*)(&VCELL(Intern(var))))*/
#define STR2KEY(var) var

static Tcl_HashTable VarTable;	/* Global hash table retaining traced variables */


int Tcl_TraceVar(interp, var, flags, proc, clientData)
     Tcl_Interp *interp; char *var; int flags;
     Tcl_VarTraceProc *proc; ClientData clientData;
{
  Tcl_HashEntry *entry;
  int new;
  struct VarTrace *data;
  
  entry = Tcl_CreateHashEntry(&VarTable, STR2KEY(var), &new);
  /* Create the value associated to the "var" key */
  data= (struct VarTrace *) ckalloc((unsigned) sizeof (struct VarTrace));
  data->flags	   = flags & ~TCL_TRACE_UNSETS; /* Unset has no meaning in stk */
  data->traceProc  = proc;
  data->clientData = clientData;
  data->nextPtr	   = (VarTrace *) (new ? NULL : Tcl_GetHashValue(entry));

  /* Put it in table */
  Tcl_SetHashValue(entry, (ClientData) data);
  
  return TCL_OK;
}

int Tcl_TraceVar2(interp, name1, name2, flags, proc, clientData)
     Tcl_Interp *interp; char *name1, *name2; int flags; 
     Tcl_VarTraceProc *proc; ClientData clientData;
{
  if (*name2) {
    
  }
  return Tcl_TraceVar(interp, name1, flags, proc, clientData);
}

void Tcl_UntraceVar(interp, var, flags, proc, clientData)
     Tcl_Interp *interp; char *var; int flags;
     Tcl_VarTraceProc *proc; ClientData clientData;
{
  Tcl_HashEntry *entry;
  register VarTrace *p, *prev;
  
  if (entry = Tcl_FindHashEntry(&VarTable, STR2KEY(var))) {
    /* Variable is traced. Try to find correponding trace function */
    flags &= ~TCL_TRACE_UNSETS; /* Unset has no meaning for us */

    p = (struct VarTrace *) Tcl_GetHashValue(entry);    
    for (prev=NULL; p ; prev=p, p=p->nextPtr) {
      if (p->traceProc == proc && p->flags == flags && p->clientData == clientData)
	break;
    }
    if (p) {
      if (prev == NULL) {
	if (p->nextPtr)
	  Tcl_SetHashValue(entry, (ClientData *) p->nextPtr);
	else 
	  Tcl_DeleteHashEntry(entry);
      }
      else
	prev->nextPtr = p->nextPtr;
      ckfree(p);
    }
  }
}

void Tcl_UntraceVar2(interp, name1, name2, flags, proc, clientData)
     Tcl_Interp *interp; char *name1, *name2; int flags; 
     Tcl_VarTraceProc *proc; ClientData clientData;
{
  if (name2 && *name2) {
    char *s = must_malloc(strlen(name1) + strlen(name2) + 3);

    sprintf(s, "%s{%s}", name1, name2);
    Tcl_UntraceVar(interp, s, flags, proc, clientData);
    free(s);
  }
  else
    Tcl_UntraceVar(interp, name1, flags, proc, clientData);
}


/****
 * 
 * Tcl_ChangeValue
 *
 * This function is called by Scheme when a there's a global variable change
 * (using a set! or a define). "var" is a C string indicating the name of this
 * variable. If this variable is traced, call the C functions associated to it.
 *
 ****/

void Tcl_ChangeValue(char *var)
{ 
  Tcl_HashEntry *entry;
  register VarTrace *data, *p;
  
  if (!Tk_initialized) return;

  if (entry = Tcl_FindHashEntry(&VarTable, var)) {
    /* Variable is traced. Call all the associated traces */
    data = (struct VarTrace *) Tcl_GetHashValue(entry);
    
    for (p = data; p ; p = p->nextPtr) {
      /* Invoke trace procedure if not already active */
      if (p->flags & TRACING) 
	continue;

      p->flags |= TRACING;
      (*p->traceProc)(p->clientData, STk_main_interp, var, "", p->flags);
    
      /* Unset our flag */
      p->flags &= ~TRACING;
    }
  }
}

/*
 * Tcl_CompleteUntraceVar
 *
 * This function is used only by STK. It permits to delete all the traces 
 * associated to a variable (used by ``untrace-var'')
 *
 */

void Tcl_CompleteUntraceVar(Tcl_Interp *interp, char *var)
{
  Tcl_HashEntry *entry;
  register VarTrace *p;
  
  if (entry = Tcl_FindHashEntry(&VarTable, var)) {
    /* Variable is traced. Try to find correponding trace function */
    for (p = (struct VarTrace *) Tcl_GetHashValue(entry); p; p=p->nextPtr) {
      if (p->flags & TCL_TRACE_READS) ckfree(p->clientData);
      ckfree(p);
    }
    Tcl_DeleteHashEntry(entry);
  }
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_VarTraceInfo2 --
 *
 *	Same as Tcl_VarTraceInfo, except takes name in two pieces
 *	instead of one.
 *
 * Results:
 *	Same as Tcl_VarTraceInfo.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    char *part1;		/* Name of variable or array. */
    char *part2;		/* Name of element within array;  NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags;			/* 0 or TCL_GLOBAL_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData prevClientData;	/* If non-NULL, gives last value returned
				 * by this procedure, so this call will
				 * return the next trace after that one.
				 * If NULL, this call will return the
				 * first trace. */
{
  Tcl_HashEntry *entry;
  register VarTrace *tracePtr;

  if (part2 && *part2) {
    char *s = must_malloc(strlen(part1) + strlen(part2) + 3);

    sprintf(s, "%s{%s}", part1, part2);
    entry = Tcl_FindHashEntry(&VarTable, s);
    free(s);
  }
  else
    entry = Tcl_FindHashEntry(&VarTable, part1);
  
  if (entry) {
    /* Variable is traced. 
     * Find the relevant trace, if any, and return its clientData.
     */
    
    tracePtr = (struct VarTrace *) Tcl_GetHashValue(entry);

    if (prevClientData != NULL) {
      for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
	if ((tracePtr->clientData == prevClientData) && 
	    (tracePtr->traceProc == proc)) {
	  tracePtr = tracePtr->nextPtr;
	  break;
	}
      }
    }
    for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
      if (tracePtr->traceProc == proc) {
	return tracePtr->clientData;
      }
    }
  }
  return NULL;
}

void STk_init_tracevar(void)
{
  Tcl_InitHashTable(&VarTable, TCL_STRING_KEYS);
}

#endif /* USE_TK */