/* tcl/tk interface V0.2 July 2001 AG (some of this code was pilfered from
   Tk_octave) */

/* This file is part of the Q programming system.

   The Q programming system is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2, or (at your option)
   any later version.

   The Q programming system 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.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */

#if defined (HAVE_CONFIG_H)
#  include "config.h"
#endif

/* system headers */

#include <stdio.h>
#include <ctype.h>
#include <signal.h>
#include <math.h>

/* check for standard C headers */
#if STDC_HEADERS
# include <stdlib.h>
# include <string.h>
#else
# ifndef HAVE_STRCHR
#  define strchr index
#  define strrchr rindex
# endif
char *strchr (), *strrchr ();
#endif

#ifdef HAVE_MALLOC_H
#include <stdlib.h>
#endif

#ifdef HAVE_LIMITS_H
#include <limits.h>
#endif

#if TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
#else
# if HAVE_SYS_TIME_H
#  include <sys/time.h>
# else
#  include <time.h>
# endif
#endif

#include <sys/types.h>
#if HAVE_SYS_WAIT_H
# include <sys/wait.h>
#endif
#ifndef WEXITSTATUS
# define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
#endif
#ifndef WIFEXITED
# define WIFEXITED(stat_val) (((stat_val) & 255) == 0)
#endif

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

#define TCL_THREADS
#include <tcl.h>
#include <tk.h>

#include <libq.h>

/* multithreading support */

#ifdef USE_THREADS
#include <pthread.h>
#endif

#ifdef DMALLOC
#include <dmalloc.h>
#endif

MODULE(tk)

#ifndef HAVE_STRDUP

static char *strdup(char *s)
{
  char *t;
  return ((t=malloc(strlen(s)+1))?strcpy(t, s):NULL);
}

#endif

/* handle X11 protocol errors */

static int XErrorProc(ClientData data, XErrorEvent *errEventPtr)
{
  fprintf(stderr, "X protocol error: ");
  fprintf(stderr, "error=%d request=%d minor=%d\n",
	  errEventPtr->error_code, errEventPtr->request_code,
	  errEventPtr->minor_code);
  return 0;
}

/* handle SIGINT and SIGTERM */

#ifdef _MSC_VER
#define SIGHANDLER_RETURN(status) return
#else
#if RETSIGTYPE == void
#define SIGHANDLER_RETURN(status) return
#else
#define SIGHANDLER_RETURN(status) return status
#endif
#endif

#ifdef MUST_REINSTALL_SIGHANDLERS
#define SIGHANDLER_RESTORE(sig,handler) syssignal(sig,handler)
#else
#define SIGHANDLER_RESTORE(sig,handler) /* nop */
#endif

typedef RETSIGTYPE (*sighandler_t)(int);

static sighandler_t syssignal(sig, handler)
     int sig;
     sighandler_t handler;
{
#ifdef HAVE_POSIX_SIGNALS
  struct sigaction new_action, old_action;
  new_action.sa_handler = handler;
  sigemptyset(&new_action.sa_mask);
  sigemptyset(&old_action.sa_mask);
  new_action.sa_flags = 0;
  sigaction(sig, &new_action, &old_action);
  return old_action.sa_handler;
#else
  return signal(sig, handler);
#endif
}

static int brkflag = 0, tcl_threads = 0;
static volatile int brkevent = 0;
static sighandler_t int_handler = NULL, term_handler = NULL,
  hup_handler = NULL;

static RETSIGTYPE break_handler(int sig)
{
  if (sig == SIGINT && int_handler) int_handler(sig);
  if (sig == SIGTERM && term_handler) term_handler(sig);
#ifdef SIGHUP
  if (sig == SIGHUP && hup_handler) hup_handler(sig);
#endif
  SIGHANDLER_RESTORE(sig, break_handler);
  brkevent = 1;
  SIGHANDLER_RETURN(0);
}

/* event source for handling SIGINT/SIGTERM in the Tcl interpreter */

static void break_setup_proc(ClientData data, int flags)
{
}

static int break_event_proc(Tcl_Event *ev, int flags)
{
  brkflag = 1;
  return 1;
}

static void break_check_proc(ClientData data, int flags)
{
  if (brkevent) {
    Tcl_Event *ev = (Tcl_Event*)Tcl_Alloc(sizeof(Tcl_Event));
    if (!ev) return;
    ev->proc = break_event_proc;
    Tcl_QueueEvent(ev, TCL_QUEUE_HEAD);
    brkevent = 0;
  }
}

/* thread-local stuff */

#ifdef USE_THREADS
#define MAXTHREAD 1024
#else
#define MAXTHREAD 1
#endif

Tcl_Interp* __interp[MAXTHREAD];
#define tld_interp __interp[this_thread()]

/* buffer for passing messages from Tcl to Q */

#define CHUNKSZ 200

static char *__buf[MAXTHREAD];
static int __bufsz[MAXTHREAD];

#define tld_buf __buf[this_thread()]
#define tld_bufsz __bufsz[this_thread()]

static void clear_buf(void)
{
  tld_buf = NULL;
  tld_bufsz = 0;
}

static void init_buf(void)
{
  if (tld_buf) free(tld_buf);
  clear_buf();
}

static int resize_buf(sz)
{
  if (sz >= tld_bufsz) {
    char *newbuf;
    sz = (sz/CHUNKSZ+1)*CHUNKSZ;
    newbuf = tld_buf?realloc(tld_buf, sz):malloc(sz);
    if (!newbuf) return 0;
    tld_bufsz = sz;
    tld_buf = newbuf;
    return 1;
  } else
    return 1;
}

static int add_buf(char *arg)
{
  int argsz = strlen(arg)+1;
  if (tld_bufsz == 0) {
    if (!resize_buf(argsz)) return 0;
    strcpy(tld_buf, arg);
    return 1;
  } else {
    int buflen = strlen(tld_buf);
    if (!resize_buf(argsz+buflen+1)) return 0;
    strcat(tld_buf, " ");
    strcat(tld_buf, arg);
    return 1;
  }
}

/* message queue */

static struct qentry {
  char *s;
  struct qentry *next;
} *__head[MAXTHREAD], *__tail[MAXTHREAD];

#define tld_head __head[this_thread()]
#define tld_tail __tail[this_thread()]

static void init_queue(void)
{
  while (tld_head) {
    struct qentry *next = tld_head->next;
    if (tld_head->s) free(tld_head->s);
    free(tld_head);
    tld_head = next;
  }
  tld_head = tld_tail = NULL;
}

static int emptyqueue(void)
{
  return tld_head == NULL;
}

static int enqueue(char *s)
{
  struct qentry *next = malloc(sizeof(struct qentry));
  if (!next) return 0;
  next->s = s;
  next->next = NULL;
  if (tld_head) {
    tld_tail->next = next;
    tld_tail = next;
  } else
    tld_head = tld_tail = next;
  return 1;
}

static char *dequeue(void)
{
  struct qentry *next;
  char *s;
  if (!tld_head) return NULL;
  s = tld_head->s;
  next = tld_head->next;
  free(tld_head);
  if (next)
    tld_head = next;
  else
    tld_head = tld_tail = NULL;
  return s;
}

static int q_send(ClientData clientData,
		  Tcl_Interp *interp,
		  int argc, char **argv)
{
  int i;
  Tcl_ResetResult(interp);
  for (i = 1; i < argc; i++) {
    if (!add_buf(argv[i])) {
      init_buf();
      Tcl_AppendResult(interp, "memory overflow", NULL);
      return TCL_ERROR;
    }
  }
  if (!enqueue(tld_buf)) {
    init_buf();
    Tcl_AppendResult(interp, "memory overflow", NULL);
    return TCL_ERROR;
  }
  clear_buf();
  return TCL_OK;
}

static char *__result[MAXTHREAD];
#define tld_result __result[this_thread()]

/* operations dealing with the Tk interpreter */

#ifdef USE_THREADS
static pthread_key_t interp_key;
#endif

static void tk_stop(void)
{
  if (tld_interp) {
    Tcl_DeleteInterp(tld_interp);
    tld_interp = NULL;
#ifdef USE_THREADS
    pthread_setspecific(interp_key, NULL);
#endif
    init_buf();
    init_queue();
  }
}

static int do_event(void)
{
  return Tcl_DoOneEvent(TCL_DONT_WAIT);
}

static void tk_do_events(void)
{
  if (!tld_interp) return;
  while (Tk_MainWindow(tld_interp) && do_event()) ;
  if (!Tk_MainWindow(tld_interp)) tk_stop();
}

static int tk_running(void)
{
  tk_do_events();
  return tld_interp != NULL;
}

static int tk_chk(void)
{
  tk_do_events();
  return !emptyqueue();
}

static char *tk_recv(void)
{
  brkflag = 0;
  tk_do_events();
  while (tld_interp && !brkflag && emptyqueue()) {
    Tcl_Sleep(1);
    tk_do_events();
  }
  brkflag = 0;
  if (emptyqueue())
    return NULL;
  else
    return dequeue();
}

static void set_result(char *s)
{
  tld_result = malloc(strlen(s)+1);
  if (tld_result) strcpy(tld_result, s);
}

static int tk_eval(char *s)
{
  int status;
  char *cmd;
  tld_result = NULL;
  if (!tld_interp) return 0;
  cmd = malloc(strlen(s)+1);
  if (!cmd) return 0;
  strcpy(cmd, s);
  status = Tcl_Eval(tld_interp, cmd);
  if (tld_interp && tld_interp->result && *tld_interp->result)
    set_result(tld_interp->result);
  else if (status == TCL_BREAK)
    set_result("invoked \"break\" outside of a loop");
  else if (status == TCL_CONTINUE)
    set_result("invoked \"continue\" outside of a loop");
  else
    set_result("");
  if (status == TCL_BREAK || status == TCL_CONTINUE)
    status = TCL_ERROR;
  tk_do_events();
  free(cmd);
  return status != TCL_ERROR;
}

static int tk_start(void)
{
  Tk_Window mainw;
  tld_result = NULL;
  if (tld_interp) return 1;
  /* Just to be safe, if Tcl has been compiled without thread support then we
     only allow a single interpreter in the main thread. */
  if (!tcl_threads && this_thread() != 0) return 0;
  /* start up a new interpreter */
  if (!(tld_interp = Tcl_CreateInterp())) return 0;
#ifdef USE_THREADS
  pthread_setspecific(interp_key, tld_interp);
#endif
  if (Tcl_Init(tld_interp) != TCL_OK) {
    if (tld_interp->result && *tld_interp->result)
      set_result(tld_interp->result);
    else
      set_result("error initializing Tcl");
    tk_stop();
    return 0;
  }
  /* intialize message queue for communication between Q and Tcl */
  init_buf();
  init_queue();
  /* create command to send messages from Tcl to Q */
  Tcl_CreateCommand(tld_interp, "q", (Tcl_CmdProc*)q_send, NULL, NULL);
  /* oddly, there are no `env' variables passed, and this one is needed */
  Tcl_SetVar2(tld_interp, "env", "DISPLAY", getenv("DISPLAY"), TCL_GLOBAL_ONLY);
  if (Tk_Init(tld_interp) != TCL_OK) {
    if (tld_interp->result && *tld_interp->result)
      set_result(tld_interp->result);
    else
      set_result("error initializing Tk");
    tk_stop();
    return 0;
  }
  /* set up an X error handler */
  mainw = Tk_MainWindow(tld_interp);
  Tk_CreateErrorHandler(Tk_Display(mainw), -1, -1, -1,
			XErrorProc, (ClientData)mainw);
  return 1;
}

FUNCTION(tk,tk,argc,argv)
{
  char *s;
  if (argc == 1 && isstr(argv[0], &s)) {
    if (tk_start()) {
      int res;
      release_lock();
      res = tk_eval(s);
      acquire_lock();
      if (!tld_result)
	return __ERROR;
      else if (res)
	if (*tld_result)
	  return mkstr(tld_result);
	else {
	  free(tld_result);
	  return mkvoid;
	}
      else
	return mkapp(mksym(sym(tk_error)), mkstr(tld_result));
    } else if (tld_result)
      return mkapp(mksym(sym(tk_error)), mkstr(tld_result));
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(tk,tk_set,argc,argv)
{
  char *s, *t;
  if (argc == 2 && isstr(argv[0], &s) && isstr(argv[1], &t)) {
    if (tk_start()) {
      const char *res;
      release_lock();
      res = Tcl_SetVar(tld_interp, s, t, TCL_GLOBAL_ONLY);
      acquire_lock();
      if (res)
	return mkvoid;
      else
	return __FAIL;
    } else if (tld_result)
      return mkapp(mksym(sym(tk_error)), mkstr(tld_result));
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(tk,tk_unset,argc,argv)
{
  char *s;
  if (argc == 1 && isstr(argv[0], &s)) {
    if (tk_start()) {
      int res;
      release_lock();
      res = Tcl_UnsetVar(tld_interp, s, TCL_GLOBAL_ONLY);
      acquire_lock();
      if (res == TCL_OK)
	return mkvoid;
      else
	return __FAIL;
    } else if (tld_result)
      return mkapp(mksym(sym(tk_error)), mkstr(tld_result));
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(tk,tk_get,argc,argv)
{
  char *s;
  if (argc == 1 && isstr(argv[0], &s)) {
    if (tk_start()) {
      const char *res;
      release_lock();
      res = Tcl_GetVar(tld_interp, s, TCL_GLOBAL_ONLY);
      acquire_lock();
      if (res)
	return mkstr(strdup(res));
      else
	return __FAIL;
    } else if (tld_result)
      return mkapp(mksym(sym(tk_error)), mkstr(tld_result));
    else
      return __FAIL;
  } else
    return __FAIL;
}

FUNCTION(tk,tk_quit,argc,argv)
{
  if (argc == 0) {
    tk_stop();
    return mkvoid;
  } else
    return __FAIL;
}

FUNCTION(tk,tk_ready,argc,argv)
{
  if (argc == 0) {
    int res;
    release_lock();
    res = tk_running();
    acquire_lock();
    if (res)
      return mktrue;
    else
      return mkfalse;
  } else
    return __FAIL;
}

FUNCTION(tk,tk_check,argc,argv)
{
  if (argc == 0) {
    int res;
    release_lock();
    res = tk_chk();
    acquire_lock();
    if (res)
      return mktrue;
    else
      return mkfalse;
  } else
    return __FAIL;
}

FUNCTION(tk,tk_reads,argc,argv)
{
  if (argc == 0) {
    char *s;
    release_lock();
    s = tk_recv();
    acquire_lock();
    if (s)
      return mkstr(s);
    else
      return __FAIL;
  } else
    return __FAIL;
}

#ifdef USE_THREADS
static void destruct(void *p)
{
  tk_stop();
}
#endif

#ifndef X_DISPLAY_MISSING

/* hotfix: get rid of spurious X error messages */

#include <X11/Xlib.h>

static int (*last_handler)(Display *, XErrorEvent *);

static int dummy_handler(Display *dpy, XErrorEvent *ev)
{
  return 0;
}

#endif

INIT(tk)
{
  Tcl_Mutex mut = NULL;
  /* work around a bug in recent Tcl/Tk versions */
  Tcl_FindExecutable(NULL);
  /* check whether Tcl actually supports threads */
  Tcl_MutexLock(&mut);
  if (mut) {
    Tcl_MutexUnlock(&mut);
    Tcl_MutexFinalize(&mut);
    tcl_threads = 1;
  } else
    tcl_threads = 0;
  /* register signal handlers and event sources */
  int_handler = syssignal(SIGINT, break_handler);
  term_handler = syssignal(SIGTERM, break_handler);
#ifdef SIGHUP
  hup_handler = syssignal(SIGHUP, break_handler);
#endif
  Tcl_CreateEventSource(break_setup_proc, break_check_proc, NULL);
#ifdef USE_THREADS
  /* set up a destructor which kills a running interpreter in a thread which
     is being terminated */
  pthread_key_create(&interp_key, destruct);
#endif
#ifndef X_DISPLAY_MISSING
  /* KLUDGE ALERT: some interactions between Tk and GGI produce spurious X
     error messages; ignore these for now */
  last_handler = XSetErrorHandler(dummy_handler);
#endif
}

FINI(tk)
{
  tk_stop();
  Tcl_Finalize();
#ifndef X_DISPLAY_MISSING
  XSetErrorHandler(last_handler);
#endif
}