diff options
Diffstat (limited to 'otherlibs/labltk/support')
28 files changed, 2014 insertions, 0 deletions
diff --git a/otherlibs/labltk/support/Makefile b/otherlibs/labltk/support/Makefile new file mode 100644 index 000000000..eb1eb7805 --- /dev/null +++ b/otherlibs/labltk/support/Makefile @@ -0,0 +1,57 @@ +include ../Makefile.common + +all: support.cmo widget.cmo protocol.cmo \ + textvariable.cmo timer.cmo fileevent.cmo \ + liblabltk41.a + +opt: support.cmx widget.cmx protocol.cmx \ + textvariable.cmx timer.cmx fileevent.cmx \ + liblabltk41.a + +COBJS=cltkCaml.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o \ + cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o + +CCFLAGS=-ccopt "$(TK_DEFS) $(X11_INCLUDES)" + +COMPFLAGS=-I $(OTHERS)/unix + +liblabltk41.a : $(COBJS) + rm -f liblabltk41.a + ar rc liblabltk41.a $(COBJS) + $(RANLIB) liblabltk41.a + +PUB=fileevent.cmi fileevent.mli \ + protocol.cmi protocol.mli \ + textvariable.cmi textvariable.mli \ + timer.cmi timer.mli \ + widget.cmi widget.mli + +install: liblabltk41.a $(PUB) + if test -d $(LABLTKDIR); then : ; else mkdir $(LABLTKDIR); fi + cp $(PUB) $(LABLTKDIR) + cp liblabltk41.a $(LABLTKDIR) + cd $(LABLTKDIR); chmod 644 $(PUB) liblabltk41.a + $(RANLIB) $(LABLTKDIR)/liblabltk41.a + +clean : + rm -f *.cm* *.o *.a + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmo .cmx .mlp .c .o + +.mli.cmi: + $(LABLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(LABLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + +.c.o: + $(LABLCOMP) $(CCFLAGS) $< + +depend: + $(LABLDEP) *.mli *.ml > .depend + +include .depend diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h new file mode 100644 index 000000000..176ad8a8b --- /dev/null +++ b/otherlibs/labltk/support/camltk.h @@ -0,0 +1,25 @@ +/* cltkEval.c */ +extern Tcl_Interp *cltclinterp; /* The Tcl interpretor */ + +/* copy a Caml string to the C heap. Must be deallocated with stat_free */ +char *string_to_c(); + +/* cltkCaml.c */ +/* pointers to Caml values */ +extern value *tkerror_exn; +extern value *handler_code; +int CamlCBCmd(); +void tk_error(); + +/* cltkMain.c */ +extern int signal_events; +void invoke_pending_caml_signals(); +extern Tk_Window cltk_mainWindow; +extern int cltk_slave_mode; + +/* check that initialisations took place */ +#define CheckInit() if (!cltclinterp) tk_error("Tcl/Tk not initialised") + +#define RCNAME ".camltkrc" +#define CAMLCB "camlcb" + diff --git a/otherlibs/labltk/support/cltkCaml.c b/otherlibs/labltk/support/cltkCaml.c new file mode 100644 index 000000000..bb87ba5bd --- /dev/null +++ b/otherlibs/labltk/support/cltkCaml.c @@ -0,0 +1,70 @@ +#include <tcl.h> +#include <tk.h> +#include <caml/mlvalues.h> +#include <caml/callback.h> +#include "camltk.h" + +value * tkerror_exn = NULL; +value * handler_code = NULL; + +/* The Tcl command for evaluating callback in Caml */ +int CamlCBCmd(clientdata, interp, argc, argv) + ClientData clientdata; + Tcl_Interp *interp; + int argc; + char *argv[]; +{ + CheckInit(); + + /* Assumes no result */ + Tcl_SetResult(interp, NULL, NULL); + if (argc >= 2) { + int id; + if (Tcl_GetInt(interp, argv[1], &id) != TCL_OK) + return TCL_ERROR; + callback2(*handler_code,Val_int(id),copy_string_list(argc - 2,&argv[2])); + /* Never fails (Caml would have raised an exception) */ + /* but result may have been set by callback */ + return TCL_OK; + } + else + return TCL_ERROR; +} + +/* Callbacks are always of type _ -> unit, to simplify storage + * But a callback can nevertheless return something (to Tcl) by + * using the following. TCL_VOLATILE ensures that Tcl will make + * a copy of the string + */ +value camltk_return (v) /* ML */ + value v; +{ + CheckInit(); + + Tcl_SetResult(cltclinterp, String_val(v), TCL_VOLATILE); + return Val_unit; +} + +/* Note: raise_with_string WILL copy the error message */ +void tk_error(errmsg) + char *errmsg; +{ + raise_with_string(*tkerror_exn, errmsg); +} + + +/* The initialisation of the C global variables pointing to Caml values + must be made accessible from Caml, so that we are sure that it *always* + takes place during loading of the protocol module + */ + +value camltk_init(v) /* ML */ + value v; +{ + /* Initialize the Caml pointers */ + if (tkerror_exn == NULL) + tkerror_exn = caml_named_value("tkerror"); + if (handler_code == NULL) + handler_code = caml_named_value("camlcb"); + return Val_unit; +} diff --git a/otherlibs/labltk/support/cltkDMain.c b/otherlibs/labltk/support/cltkDMain.c new file mode 100644 index 000000000..0fef97a56 --- /dev/null +++ b/otherlibs/labltk/support/cltkDMain.c @@ -0,0 +1,229 @@ +#include <unistd.h> +#include <fcntl.h> +#include <tcl.h> +#include <tk.h> +#include "gc.h" +#include "exec.h" +#include "sys.h" +#include "fail.h" +#include "io.h" +#include "mlvalues.h" +#include "memory.h" +#include "camltk.h" + +#ifndef O_BINARY +#define O_BINARY 0 +#endif + + +/* + * Dealing with signals: when a signal handler is defined in Caml, + * the actual execution of the signal handler upon reception of the + * signal is delayed until we are sure we are out of the GC. + * If a signal occurs during the MainLoop, we would have to wait + * the next event for the handler to be invoked. + * The following function will invoke a pending signal handler if any, + * and we put in on a regular timer. + */ + +#define SIGNAL_INTERVAL 300 + +int signal_events = 0; /* do we have a pending timer */ + +void invoke_pending_caml_signals (clientdata) + ClientData clientdata; +{ + signal_events = 0; + enter_blocking_section(); /* triggers signal handling */ + /* Rearm timer */ + Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL); + signal_events = 1; + leave_blocking_section(); +} +/* The following is taken from byterun/startup.c */ +header_t atom_table[256]; +code_t start_code; +asize_t code_size; + +static void init_atoms() +{ + int i; + for(i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, White); +} + +static unsigned long read_size(p) + unsigned char * p; +{ + return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) + + ((unsigned long) p[2] << 8) + p[3]; +} + +#define FILE_NOT_FOUND (-1) +#define TRUNCATED_FILE (-2) +#define BAD_MAGIC_NUM (-3) + +static int read_trailer(fd, trail) + int fd; + struct exec_trailer * trail; +{ + char buffer[TRAILER_SIZE]; + + lseek(fd, (long) -TRAILER_SIZE, 2); + if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return TRUNCATED_FILE; + trail->code_size = read_size(buffer); + trail->data_size = read_size(buffer+4); + trail->symbol_size = read_size(buffer+8); + trail->debug_size = read_size(buffer+12); + if (strncmp(buffer + 16, EXEC_MAGIC, 12) == 0) + return 0; + else + return BAD_MAGIC_NUM; +} + +int attempt_open(name, trail, do_open_script) + char ** name; + struct exec_trailer * trail; + int do_open_script; +{ + char * truename; + int fd; + int err; + char buf [2]; + + truename = searchpath(*name); + if (truename == 0) truename = *name; else *name = truename; + fd = open(truename, O_RDONLY | O_BINARY); + if (fd == -1) return FILE_NOT_FOUND; + if (!do_open_script){ + err = read (fd, buf, 2); + if (err < 2) { close(fd); return TRUNCATED_FILE; } + if (buf [0] == '#' && buf [1] == '!') { close(fd); return BAD_MAGIC_NUM; } + } + err = read_trailer(fd, trail); + if (err != 0) { close(fd); return err; } + return fd; +} + + +/* Command for loading the bytecode file */ +int CamlRunCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int fd; + struct exec_trailer trail; + struct longjmp_buffer raise_buf; + struct channel * chan; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " foo.cmo args\"", (char *) NULL); + return TCL_ERROR; + } + fd = attempt_open(&argv[1], &trail, 1); + + switch(fd) { + case FILE_NOT_FOUND: + fatal_error_arg("Fatal error: cannot find file %s\n", argv[1]); + break; + case TRUNCATED_FILE: + case BAD_MAGIC_NUM: + fatal_error_arg( + "Fatal error: the file %s is not a bytecode executable file\n", + argv[1]); + break; + } + + if (sigsetjmp(raise_buf.buf, 1) == 0) { + + external_raise = &raise_buf; + + lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size + + trail.symbol_size + trail.debug_size), 2); + + code_size = trail.code_size; + start_code = (code_t) stat_alloc(code_size); + if (read(fd, (char *) start_code, code_size) != code_size) + fatal_error("Fatal error: truncated bytecode file.\n"); + +#ifdef ARCH_BIG_ENDIAN + fixup_endianness(start_code, code_size); +#endif + + chan = open_descr(fd); + global_data = input_value(chan); + close_channel(chan); + /* Ensure that the globals are in the major heap. */ + oldify(global_data, &global_data); + + sys_init(argv + 1); + interprete(start_code, code_size); + return TCL_OK; + } else { + Tcl_AppendResult(interp, "Caml program", argv[1], " raised exception \"", + String_val(Field(Field(exn_bucket, 0), 0))); + return TCL_ERROR; + } +} + +int CamlInvokeCmd(dummy + + + +/* Now the real Tk stuff */ +static Tk_Window mainWindow; + +#define RCNAME ".camltkrc" +#define CAMLCB "camlcb" + +/* Initialisation of the dynamically loaded module */ +int Caml_Init(interp) + Tcl_Interp *interp; +{ + cltclinterp = interp; + /* Create the camlcallback command */ + Tcl_CreateCommand(cltclinterp, + CAMLCB, CamlCBCmd, + (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); + + /* This is required by "unknown" and thus autoload */ + Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + /* Our hack for implementing break in callbacks */ + Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY); + + /* Load the traditional rc file */ + { + char *home = getenv("HOME"); + if (home != NULL) { + char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2); + f[0]='\0'; + strcat(f, home); + strcat(f, "/"); + strcat(f, RCNAME); + if (0 == access(f,R_OK)) + if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { + stat_free(f); + tk_error(cltclinterp->result); + }; + stat_free(f); + } + } + + /* Initialisations from caml_main */ + { + int verbose_init = 0, + percent_free_init = Percent_free_def; + long minor_heap_init = Minor_heap_def, + heap_chunk_init = Heap_chunk_def; + + /* Machine-dependent initialization of the floating-point hardware + so that it behaves as much as possible as specified in IEEE */ + init_ieee_floats(); + init_gc (minor_heap_init, heap_chunk_init, percent_free_init, + verbose_init); + init_stack(); + init_atoms(); + } +} diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c new file mode 100644 index 000000000..965fac5c4 --- /dev/null +++ b/otherlibs/labltk/support/cltkEval.c @@ -0,0 +1,222 @@ +#include <stdlib.h> + +#include <tcl.h> +#include <tk.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> +#ifdef HAS_UNISTD +#include <unistd.h> +#endif +#include "camltk.h" + +/* The Tcl interpretor */ +Tcl_Interp *cltclinterp = NULL; + +/* Copy a list of strings from the C heap to Caml */ +value copy_string_list(argc, argv) + int argc; + char ** argv; +{ + value res; + int i; + value oldres = Val_unit, str = Val_unit; + + Begin_roots2 (oldres, str); + res = Val_int(0); /* [] */ + for (i = argc-1; i >= 0; i--) { + oldres = res; + str = copy_string(argv[i]); + res = alloc(2, 0); + Field(res, 0) = str; + Field(res, 1) = oldres; + } + End_roots(); + return res; +} + +/* + * Calling Tcl from Caml + * this version works on an arbitrary Tcl command + */ +value camltk_tcl_eval(str) /* ML */ +value str; +{ + int code; + char *cmd = NULL; + + CheckInit(); + + /* Tcl_Eval may write to its argument, so we take a copy + * If the evaluation raises a Caml exception, we have a space + * leak + */ + Tcl_ResetResult(cltclinterp); + cmd = string_to_c(str); + code = Tcl_Eval(cltclinterp, cmd); + stat_free(cmd); + + switch (code) { + case TCL_OK: + return copy_string(cltclinterp->result); + case TCL_ERROR: + tk_error(cltclinterp->result); + default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ + tk_error("bad tcl result"); + } +} + + +/* + * Calling Tcl from Caml + * direct call, argument is TkArgs vect + type TkArgs = + TkToken of string + | TkTokenList of TkArgs list (* to be expanded *) + | TkQuote of TkArgs (* mapped to Tcl list *) + * NO PARSING, NO SUBSTITUTION + */ + +/* + * Compute the size of the argument (of type TkArgs). + * TkTokenList must be expanded, + * TkQuote count for one. + */ +int argv_size(v) +value v; +{ + switch (Tag_val(v)) { + case 0: /* TkToken */ + return 1; + case 1: /* TkTokenList */ + { int n; + value l; + for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1)) + n+=argv_size(Field(l,0)); + return n; + } + case 2: /* TkQuote */ + return 1; + } +} + +/* + * Memory of allocated Tcl lists. + * We should not need more than MAX_LIST + */ +#define MAX_LIST 256 +static char *tcllists[MAX_LIST]; + +static int startfree = 0; +/* If size is lower, do not allocate */ +static char *quotedargv[16]; + +/* Fill a preallocated vector arguments, doing expansion and all. + * Assumes Tcl will + * not tamper with our strings + * make copies if strings are "persistent" + */ +int fill_args (argv, where, v) +char ** argv; +int where; +value v; +{ + switch (Tag_val(v)) { + case 0: + argv[where] = String_val(Field(v,0)); + return (where + 1); + case 1: + { value l; + for (l=Field(v,0); Is_block(l); l=Field(l,1)) + where = fill_args(argv,where,Field(l,0)); + return where; + } + case 2: + { char **tmpargv; + int size = argv_size(Field(v,0)); + if (size < 16) + tmpargv = "edargv[0]; + else + tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *)); + fill_args(tmpargv,0,Field(v,0)); + tmpargv[size] = NULL; + argv[where] = Tcl_Merge(size,tmpargv); + tcllists[startfree++] = argv[where]; /* so we can free it later */ + if (size >= 16) + stat_free((char *)tmpargv); + return (where + 1); + } + } +} + +/* v is an array of TkArg */ +value camltk_tcl_direct_eval(v) /* ML */ +value v; +{ + int i; + int size; /* size of argv */ + char **argv; + int result; + Tcl_CmdInfo info; + int wherewasi,whereami; /* positions in tcllists array */ + + CheckInit(); + + /* walk the array to compute final size for Tcl */ + for(i=0,size=0;i<Wosize_val(v);i++) + size += argv_size(Field(v,i)); + + /* +2: one slot for NULL + one slot for "unknown" if command not found */ + argv = (char **)stat_alloc((size + 2) * sizeof(char *)); + + wherewasi = startfree; /* should be zero except when nested calls */ + Assert(startfree < MAX_LIST); + + /* Copy */ + { + int where; + for(i=0, where=0;i<Wosize_val(v);i++) + where = fill_args(argv,where,Field(v,i)); + argv[size] = NULL; + argv[size + 1] = NULL; + } + + Begin_roots_block ((value *) argv, size + 2); + + whereami = startfree; + + /* Eval */ + Tcl_ResetResult(cltclinterp); + if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */ + result = (*info.proc)(info.clientData,cltclinterp,size,argv); + } else {/* implement the autoload stuff */ + if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */ + for (i = size; i >= 0; i--) + argv[i+1] = argv[i]; + argv[0] = "unknown"; + result = (*info.proc)(info.clientData,cltclinterp,size+1,argv); + } else { /* ah, it isn't there at all */ + result = TCL_ERROR; + Tcl_AppendResult(cltclinterp, "Unknown command \"", + argv[0], "\"", NULL); + } + } + End_roots (); + + /* Free the various things we allocated */ + stat_free((char *)argv); + for (i=wherewasi; i<whereami; i++) + free(tcllists[i]); + startfree = wherewasi; + + switch (result) { + case TCL_OK: + return copy_string (cltclinterp->result); + case TCL_ERROR: + tk_error(cltclinterp->result); + default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ + tk_error("bad tcl result"); + } +} + diff --git a/otherlibs/labltk/support/cltkEvent.c b/otherlibs/labltk/support/cltkEvent.c new file mode 100644 index 000000000..92221b963 --- /dev/null +++ b/otherlibs/labltk/support/cltkEvent.c @@ -0,0 +1,38 @@ +#include <tcl.h> +#include <tk.h> +#include <caml/mlvalues.h> +#include "camltk.h" + +value camltk_tk_mainloop() /* ML */ +{ + CheckInit(); + + if (cltk_slave_mode) + return Val_unit; + + if (!signal_events) { + /* Initialise signal handling */ + signal_events = 1; + Tk_CreateTimerHandler(100, invoke_pending_caml_signals, NULL); + }; + Tk_MainLoop(); + return Val_unit; +} + +/* Note: this HAS to be reported "as-is" in ML source */ +static int event_flag_table[] = { + TK_DONT_WAIT, TK_X_EVENTS, TK_FILE_EVENTS, TK_TIMER_EVENTS, TK_IDLE_EVENTS, + TK_ALL_EVENTS +}; + +value camltk_dooneevent(flags) /* ML */ + value flags; +{ + int ret; + + CheckInit(); + + ret = Tk_DoOneEvent(convert_flag_list(flags, event_flag_table)); + return Val_int(ret); +} + diff --git a/otherlibs/labltk/support/cltkFile.c b/otherlibs/labltk/support/cltkFile.c new file mode 100644 index 000000000..f58177258 --- /dev/null +++ b/otherlibs/labltk/support/cltkFile.c @@ -0,0 +1,111 @@ +#ifdef _WIN32 +#include <wtypes.h> +#include <winbase.h> +#include <winsock.h> +#endif +#include <tcl.h> +#include <tk.h> +#include <caml/mlvalues.h> +#include "camltk.h" + +/* + * File descriptor callbacks + */ + +void FileProc(ClientData clientdata, int mask) +{ + callback2(*handler_code,Val_int(clientdata),Val_int(0)); +} + +/* Map Unix.file_descr values to Tcl file handles */ + +#ifndef _WIN32 + +/* Unix system */ + +#if TCL_MAJOR_VERSION >= 8 +#define tcl_filehandle(fd) Int_val(fd) +#define Tcl_File int +#define Tcl_FreeFile(fd) +#else +static Tcl_File tcl_filehandle(value fd) +{ + return Tcl_GetFile((ClientData)Long_val(fd), TCL_UNIX_FD); +} +#endif + +#else + +/* Windows */ + +#define Handle_val(v) (*((HANDLE *)(v))) + +static Tcl_File tcl_filehandle(value fd) +{ + HANDLE h = Handle_val(fd); + int type; + int optval, optsize; + + optsize = sizeof(optval); + if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE, &optval, &optsize) == 0) + type = TCL_WIN_SOCKET; + else + switch (GetFileType(h)) { + case FILE_TYPE_CHAR: + type = TCL_WIN_CONSOLE; + case FILE_TYPE_PIPE: + type = TCL_WIN_PIPE; + case FILE_TYPE_DISK: + default: /* use WIN_FILE for unknown handles */ + type = TCL_WIN_FILE; + } + return Tcl_GetFile(h, type); +} + +#endif + +value camltk_add_file_input(fd, cbid) /* ML */ + value fd; + value cbid; +{ + CheckInit(); + Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_READABLE, + FileProc, (ClientData)(Long_val(cbid))); + return Val_unit; +} + +/* We have to free the Tcl handle when we are finished using it (Tcl + * asks us to, and moreover it is probably dangerous to keep the same + * handle over two allocations of the same fd by the kernel). + * But we don't know when we are finished with the fd, so we free it + * in rem_file (it doesn't close the fd anyway). For fds for which we + * repeatedly add/rem, this will cause some overhead. + */ +value camltk_rem_file_input(fd) /* ML */ + value fd; +{ + Tcl_File fh = tcl_filehandle(fd); + Tcl_DeleteFileHandler(fh); + Tcl_FreeFile(fh); + return Val_unit; +} + +value camltk_add_file_output(fd, cbid) /* ML */ + value fd; + value cbid; +{ + CheckInit(); + Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_WRITABLE, + FileProc, (ClientData) (Long_val(cbid))); + return Val_unit; +} + +value camltk_rem_file_output(fd) /* ML */ + value fd; +{ + Tcl_File fh = tcl_filehandle(fd); + Tcl_DeleteFileHandler(fh); + Tcl_FreeFile(fh); + return Val_unit; +} + diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c new file mode 100644 index 000000000..f881df77b --- /dev/null +++ b/otherlibs/labltk/support/cltkMain.c @@ -0,0 +1,117 @@ +#include <string.h> +#include <tcl.h> +#include <tk.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/callback.h> +#ifdef HAS_UNISTD +#include <unistd.h> /* for R_OK */ +#endif +#include "camltk.h" + +#ifndef R_OK +#define R_OK 4 +#endif + +/* + * Dealing with signals: when a signal handler is defined in Caml, + * the actual execution of the signal handler upon reception of the + * signal is delayed until we are sure we are out of the GC. + * If a signal occurs during the MainLoop, we would have to wait + * the next event for the handler to be invoked. + * The following function will invoke a pending signal handler if any, + * and we put in on a regular timer. + */ + +#define SIGNAL_INTERVAL 300 + +int signal_events = 0; /* do we have a pending timer */ + +void invoke_pending_caml_signals (clientdata) + ClientData clientdata; +{ + signal_events = 0; + enter_blocking_section(); /* triggers signal handling */ + /* Rearm timer */ + Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL); + signal_events = 1; + leave_blocking_section(); +} + +/* Now the real Tk stuff */ + +Tk_Window cltk_mainWindow; + + +/* In slave mode, the interpreter *already* exists */ +int cltk_slave_mode = 0; + +/* Initialisation, based on tkMain.c */ +value camltk_opentk(display, name) /* ML */ + value display,name; +{ + if (!cltk_slave_mode) { + /* Create an interpreter, dies if error */ +#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 + Tcl_FindExecutable(String_val(name)); +#endif + cltclinterp = Tcl_CreateInterp(); + + if (Tcl_Init(cltclinterp) != TCL_OK) + tk_error(cltclinterp->result); + Tcl_SetVar(cltclinterp, "argv0", String_val (name), TCL_GLOBAL_ONLY); + { /* Sets display if needed */ + char *args; + char *tkargv[2]; + if (string_length(display) > 0) { + Tcl_SetVar(cltclinterp, "argc", "2", TCL_GLOBAL_ONLY); + tkargv[0] = "-display"; + tkargv[1] = String_val(display); + args = Tcl_Merge(2, tkargv); + Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY); + free(args); + } + } + if (Tk_Init(cltclinterp) != TCL_OK) + tk_error(cltclinterp->result); + + /* Retrieve the main window */ + cltk_mainWindow = Tk_MainWindow(cltclinterp); + + if (NULL == cltk_mainWindow) + tk_error(cltclinterp->result); + + Tk_GeometryRequest(cltk_mainWindow,200,200); + } + + /* Create the camlcallback command */ + Tcl_CreateCommand(cltclinterp, + CAMLCB, CamlCBCmd, + (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); + + /* This is required by "unknown" and thus autoload */ + Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + /* Our hack for implementing break in callbacks */ + Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY); + + /* Load the traditional rc file */ + { + char *home = getenv("HOME"); + if (home != NULL) { + char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2); + f[0]='\0'; + strcat(f, home); + strcat(f, "/"); + strcat(f, RCNAME); + if (0 == access(f,R_OK)) + if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { + stat_free(f); + tk_error(cltclinterp->result); + }; + stat_free(f); + } + } + + return Val_unit; +} + diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c new file mode 100644 index 000000000..685bfffc3 --- /dev/null +++ b/otherlibs/labltk/support/cltkMisc.c @@ -0,0 +1,42 @@ +#include <tcl.h> +#include <tk.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include "camltk.h" + +/* Parsing results */ +value camltk_splitlist (v) /* ML */ + value v; +{ + int argc; + char **argv; + int result; + + CheckInit(); + + /* argv is allocated by Tcl, to be freed by us */ + result = Tcl_SplitList(cltclinterp,String_val(v),&argc,&argv); + switch(result) { + case TCL_OK: + { value res = copy_string_list(argc,argv); + free((char *)argv); /* only one large block was allocated */ + return res; + } + case TCL_ERROR: + default: + tk_error(cltclinterp->result); + } +} + +/* Copy a Caml string to the C heap. Should deallocate with stat_free */ +char *string_to_c(s) + value s; +{ + int l = string_length(s); + char *res = stat_alloc(l + 1); + bcopy(String_val(s),res,l); + res[l] = '\0'; + return res; +} + + diff --git a/otherlibs/labltk/support/cltkTimer.c b/otherlibs/labltk/support/cltkTimer.c new file mode 100644 index 000000000..9cf9e2e3e --- /dev/null +++ b/otherlibs/labltk/support/cltkTimer.c @@ -0,0 +1,30 @@ +#include <tcl.h> +#include <tk.h> +#include <caml/mlvalues.h> +#include "camltk.h" + + +/* Basically the same thing as FileProc */ +void TimerProc (clientdata) + ClientData clientdata; +{ + callback2(*handler_code,Val_long(clientdata),Val_int(0)); +} + +value camltk_add_timer(milli, cbid) /* ML */ + value milli; + value cbid; +{ + CheckInit(); + /* look at tkEvent.c , Tk_Token is an int */ + return (value)Tcl_CreateTimerHandler(Int_val(milli), TimerProc, + (ClientData) (Long_val(cbid))); +} + +value camltk_rem_timer(token) /* ML */ + value token; +{ + Tcl_DeleteTimerHandler((Tcl_TimerToken) token); + return Val_unit; +} + diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c new file mode 100644 index 000000000..54687998d --- /dev/null +++ b/otherlibs/labltk/support/cltkVar.c @@ -0,0 +1,109 @@ +/* Alternative to tkwait variable */ +#include <string.h> +#include <tcl.h> +#include <tk.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include "camltk.h" + +value camltk_getvar(var) /* ML */ + value var; +{ + char *s; + char *stable_var = NULL; + CheckInit(); + + stable_var = string_to_c(var); + s = Tcl_GetVar(cltclinterp,stable_var, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + stat_free(stable_var); + + if (s == NULL) + tk_error(cltclinterp->result); + else + return(copy_string(s)); +} + +value camltk_setvar(var,contents) /* ML */ + value var; + value contents; +{ + char *s; + char *stable_var = NULL; + CheckInit(); + + /* SetVar makes a copy of the contents. */ + /* In case we have write traces in Caml, it's better to make sure that + var doesn't move... */ + stable_var = string_to_c(var); + s = Tcl_SetVar(cltclinterp,stable_var, String_val(contents), + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + stat_free(stable_var); + + if (s == NULL) + tk_error(cltclinterp->result); + else + return(Val_unit); +} + + +/* The appropriate type is +typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *part1, char *part2, int flags)); + */ +static char * tracevar(clientdata, interp, name1, name2, flags) + ClientData clientdata; + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + Tcl_UntraceVar2(interp, name1, name2, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + tracevar, clientdata); + callback2(*handler_code,Val_int(clientdata),Val_unit); + return (char *)NULL; +} + +/* Sets up a callback upon modification of a variable */ +value camltk_trace_var(var,cbid) /* ML */ + value var; + value cbid; +{ + char *cvar = NULL; + + CheckInit(); + /* Make a copy of var, since Tcl will modify it in place, and we + * don't trust that much what it will do here + */ + cvar = string_to_c(var); + if (Tcl_TraceVar(cltclinterp, cvar, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + tracevar, + (ClientData) (Long_val(cbid))) + != TCL_OK) { + stat_free(cvar); + tk_error(cltclinterp->result); + }; + stat_free(cvar); + return Val_unit; +} + +value camltk_untrace_var(var,cbid) /* ML */ + value var; + value cbid; +{ + char *cvar = NULL; + + CheckInit(); + /* Make a copy of var, since Tcl will modify it in place, and we + * don't trust that much what it will do here + */ + cvar = string_to_c(var); + Tcl_UntraceVar(cltclinterp, cvar, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + tracevar, + (ClientData) (Long_val(cbid))); + stat_free(cvar); + return Val_unit; +} diff --git a/otherlibs/labltk/support/cltkWait.c b/otherlibs/labltk/support/cltkWait.c new file mode 100644 index 000000000..e7becdc1d --- /dev/null +++ b/otherlibs/labltk/support/cltkWait.c @@ -0,0 +1,89 @@ +#include <tcl.h> +#include <tk.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include "camltk.h" + +/* The following are replacements for + tkwait visibility + tkwait window + in the case where we use threads (tkwait internally calls an event loop, + and thus prevents thread scheduling from taking place). + + Instead, one should set up a callback, wait for a signal, and signal + from inside the callback +*/ + +static void WaitVisibilityProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void WaitWindowProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); + +/* For the other handlers, we need a bit more data */ +struct WinCBData { + int cbid; + Tk_Window win; +}; + +static void WaitVisibilityProc(clientData, eventPtr) + ClientData clientData; + XEvent *eventPtr; /* Information about event (not used). */ +{ + struct WinCBData *vis = clientData; + value cbid = Val_int(vis->cbid); + + Tk_DeleteEventHandler(vis->win, VisibilityChangeMask, + WaitVisibilityProc, clientData); + + stat_free((char *)vis); + callback2(*handler_code,cbid,Val_int(0)); +} + +/* Sets up a callback upon Visibility of a window */ +value camltk_wait_vis(win,cbid) /* ML */ + value win; + value cbid; +{ + struct WinCBData *vis = + (struct WinCBData *)stat_alloc(sizeof(struct WinCBData)); + vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); + if (vis -> win == NULL) { + stat_free((char *)vis); + tk_error(cltclinterp->result); + }; + vis->cbid = Int_val(cbid); + Tk_CreateEventHandler(vis->win, VisibilityChangeMask, + WaitVisibilityProc, (ClientData) vis); + return Val_unit; +} + +static void WaitWindowProc(clientData, eventPtr) + ClientData clientData; + XEvent *eventPtr; +{ + if (eventPtr->type == DestroyNotify) { + struct WinCBData *vis = clientData; + value cbid = Val_int(vis->cbid); + stat_free((char *)clientData); + /* The handler is destroyed by Tk itself */ + callback2(*handler_code,cbid,Val_int(0)); + } +} + +/* Sets up a callback upon window destruction */ +value camltk_wait_des(win,cbid) /* ML */ + value win; + value cbid; +{ + struct WinCBData *vis = + (struct WinCBData *)stat_alloc(sizeof(struct WinCBData)); + vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); + if (vis -> win == NULL) { + stat_free((char *)vis); + tk_error(cltclinterp->result); + }; + vis->cbid = Int_val(cbid); + Tk_CreateEventHandler(vis->win, StructureNotifyMask, + WaitWindowProc, (ClientData) vis); + return Val_unit; +} diff --git a/otherlibs/labltk/support/coerce.ml b/otherlibs/labltk/support/coerce.ml new file mode 100644 index 000000000..1562fbec1 --- /dev/null +++ b/otherlibs/labltk/support/coerce.ml @@ -0,0 +1,2 @@ +(* for no Support open *) +let coe = Widget.coe diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml new file mode 100644 index 000000000..ffebc909b --- /dev/null +++ b/otherlibs/labltk/support/fileevent.ml @@ -0,0 +1,64 @@ +(* $Id$ *) + +open Unix +open Protocol + +external add_file_input : file_descr -> cbid -> unit + = "camltk_add_file_input" +external rem_file_input : file_descr -> unit + = "camltk_rem_file_input" +external add_file_output : file_descr -> cbid -> unit + = "camltk_add_file_output" +external rem_file_output : file_descr -> unit + = "camltk_rem_file_output" + +(* File input handlers *) + +let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *) + +let add_fileinput :fd callback:f = + let id = new_function_id () in + Hashtbl.add callback_naming_table key:id data:(fun _ -> f()); + Hashtbl.add fd_table key:(fd, 'r') data:id; + if !Protocol.debug then begin + Protocol.prerr_cbid id; prerr_endline " for fileinput" + end; + add_file_input fd id + +let remove_fileinput :fd = + try + let id = Hashtbl.find fd_table key:(fd, 'r') in + clear_callback id; + Hashtbl.remove fd_table key:(fd, 'r'); + if !Protocol.debug then begin + prerr_string "clear "; + Protocol.prerr_cbid id; + prerr_endline " for fileinput" + end; + rem_file_input fd + with + Not_found -> () + +let add_fileoutput :fd callback:f = + let id = new_function_id () in + Hashtbl.add callback_naming_table key:id data:(fun _ -> f()); + Hashtbl.add fd_table key:(fd, 'w') data:id; + if !Protocol.debug then begin + Protocol.prerr_cbid id; prerr_endline " for fileoutput" + end; + add_file_output fd id + +let remove_fileoutput :fd = + try + let id = Hashtbl.find fd_table key:(fd, 'w') in + clear_callback id; + Hashtbl.remove fd_table key:(fd, 'w'); + if !Protocol.debug then begin + prerr_string "clear "; + Protocol.prerr_cbid id; + prerr_endline " for fileoutput" + end; + rem_file_output fd + with + Not_found -> () + diff --git a/otherlibs/labltk/support/fileevent.mli b/otherlibs/labltk/support/fileevent.mli new file mode 100644 index 000000000..b72f6c78c --- /dev/null +++ b/otherlibs/labltk/support/fileevent.mli @@ -0,0 +1,7 @@ +open Unix + +val add_fileinput : fd:file_descr -> callback:(unit -> unit) -> unit +val remove_fileinput: fd:file_descr -> unit +val add_fileoutput : fd:file_descr -> callback:(unit -> unit) -> unit +val remove_fileoutput: fd:file_descr -> unit + (* see [tk] module *) diff --git a/otherlibs/labltk/support/may.ml b/otherlibs/labltk/support/may.ml new file mode 100644 index 000000000..202b561d9 --- /dev/null +++ b/otherlibs/labltk/support/may.ml @@ -0,0 +1,10 @@ + +(* Very easy hack for option type *) +let may f = function + Some x -> Some (f x) +| None -> None + +let maycons f x l = + match x with + Some x -> f x :: l + | None -> l diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml new file mode 100644 index 000000000..c5fa13dcf --- /dev/null +++ b/otherlibs/labltk/support/protocol.ml @@ -0,0 +1,190 @@ +(* $Id$ *) + +open Widget + +type callback_buffer = string list + (* Buffer for reading callback arguments *) + +type tkArgs = + TkToken of string + | TkTokenList of tkArgs list (* to be expanded *) + | TkQuote of tkArgs (* mapped to Tcl list *) + +type cbid = int + +external opentk : string -> string -> unit + = "camltk_opentk" +external tcl_eval : string -> string + = "camltk_tcl_eval" +external tk_mainloop : unit -> unit + = "camltk_tk_mainloop" +external tcl_direct_eval : tkArgs array -> string + = "camltk_tcl_direct_eval" +external splitlist : string -> string list + = "camltk_splitlist" +external tkreturn : string -> unit + = "camltk_return" +external callback_init : unit -> unit + = "camltk_init" + +exception TkError of string + (* Raised by the communication functions *) +let _ = Callback.register_exception "tkerror" (TkError "") + +(* Debugging support *) +let debug = + ref (try Sys.getenv "CAMLTKDEBUG"; true + with Not_found -> false) + +(* This is approximative, since we don't quote what needs to be quoted *) +let dump_args args = + let rec print_arg = function + TkToken s -> prerr_string s; prerr_string " " + | TkTokenList l -> List.iter fun:print_arg l + | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} " + in + Array.iter fun:print_arg args; + prerr_newline() + +(* + * Evaluating Tcl code + * debugging support should not affect performances... + *) + +let tkEval args = + if !debug then dump_args args; + let res = tcl_direct_eval args in + if !debug then begin + prerr_string "->>"; + prerr_endline res + end; + res + +(* + * Callbacks + *) + +let cCAMLtoTKwidget w = + TkToken (Widget.name w) + +let cTKtoCAMLwidget = function + "" -> raise (Invalid_argument "cTKtoCAMLwidget") + | s -> Widget.get_atom s + + +let callback_naming_table = + (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t) + +let callback_memo_table = + (Hashtbl.create 401 : (any widget, int) Hashtbl.t) + +let new_function_id = + let counter = ref 0 in + function () -> incr counter; !counter + +let string_of_cbid = string_of_int + +(* Add a new callback, associated to widget w *) +(* The callback should be cleared when w is destroyed *) +let register_callback w callback:f = + let id = new_function_id () in + Hashtbl.add callback_naming_table key:id data:f; + if (forget_type w) <> (forget_type Widget.dummy) then + Hashtbl.add callback_memo_table key:(forget_type w) data:id; + (string_of_cbid id) + +let clear_callback id = + Hashtbl.remove callback_naming_table key:id + +(* Clear callbacks associated to a given widget *) +let remove_callbacks w = + let w = forget_type w in + let cb_ids = Hashtbl.find_all callback_memo_table key:w in + List.iter fun:clear_callback cb_ids; + for i = 1 to List.length cb_ids do + Hashtbl.remove callback_memo_table key:w + done + +(* Hand-coded callback for destroyed widgets + * This may be extended by the application, or by other layers of Camltk. + * Could use bind + of Tk, but I'd rather give an alternate mechanism so + * that hooks can be set up at load time (i.e. before openTk) + *) +let destroy_hooks = ref [] +let add_destroy_hook f = + destroy_hooks := f :: !destroy_hooks + +let _ = + add_destroy_hook (fun w -> remove_callbacks w; Widget.remove w) + +let install_cleanup () = + let call_destroy_hooks = function + [wname] -> + let w = cTKtoCAMLwidget wname in + List.iter fun:(fun f -> f w) !destroy_hooks + | _ -> raise (TkError "bad cleanup callback") in + let fid = new_function_id () in + Hashtbl.add callback_naming_table key:fid data:call_destroy_hooks; + (* setup general destroy callback *) + tcl_eval ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}") + + +let prerr_cbid id = + prerr_string "camlcb "; prerr_int id + +(* The callback dispatch function *) +let dispatch_callback id args = + if !debug then begin + prerr_cbid id; + List.iter fun:(fun x -> prerr_string " "; prerr_string x) args; + prerr_newline() + end; + (Hashtbl.find callback_naming_table key:id) args; + if !debug then prerr_endline "<<-" + +let protected_dispatch id args = + try + Printexc.print (dispatch_callback id) args + with + Out_of_memory -> raise Out_of_memory + | Sys.Break -> raise Sys.Break + | e -> flush Pervasives.stderr + +let _ = Callback.register "camlcb" protected_dispatch + +(* Make sure the C variables are initialised *) +let _ = callback_init () + +(* Different version of initialisation functions *) +(* Native opentk is [opentk display class] *) +let openTk () = + opentk "" "LablTk"; + install_cleanup(); + Widget.default_toplevel + +let openTkClass s = + opentk "" s; + install_cleanup(); + Widget.default_toplevel + +let openTkDisplayClass display:disp cl = + opentk disp cl; + install_cleanup(); + Widget.default_toplevel + +(* Destroy all widgets, thus cleaning up table and exiting the loop *) +let closeTk () = + tcl_eval "destroy ."; () + +let mainLoop = + tk_mainloop + + +(* [register tclname f] makes [f] available from Tcl with + name [tclname] *) +let register tclname callback:cb = + let s = register_callback Widget.default_toplevel callback:cb in + tcl_eval (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}" + tclname s); + () + diff --git a/otherlibs/labltk/support/protocol.mli b/otherlibs/labltk/support/protocol.mli new file mode 100644 index 000000000..17e004e7c --- /dev/null +++ b/otherlibs/labltk/support/protocol.mli @@ -0,0 +1,66 @@ +open Widget + +(* Lower level interface *) +exception TkError of string + (* Raised by the communication functions *) + +val debug : bool ref + (* When set to true, displays approximation of intermediate Tcl code *) + +type tkArgs = + TkToken of string + | TkTokenList of tkArgs list (* to be expanded *) + | TkQuote of tkArgs (* mapped to Tcl list *) + + +(* Misc *) +external splitlist : string -> string list + = "camltk_splitlist" + +val add_destroy_hook : (any widget -> unit) -> unit + + +(* Opening, closing, and mainloop *) +val openTk : unit -> toplevel widget +val openTkClass: string -> toplevel widget +val openTkDisplayClass: display:string -> string -> toplevel widget +val closeTk : unit -> unit +val mainLoop : unit -> unit + + +(* Direct evaluation of tcl code *) +val tkEval : tkArgs array -> string + +(* Returning a value from a Tcl callback *) +val tkreturn: string -> unit + + +(* Callbacks: this is private *) + +type cbid + +type callback_buffer = string list + (* Buffer for reading callback arguments *) + +val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t +val callback_memo_table : (any widget, cbid) Hashtbl.t + (* Exported for debug purposes only. Don't use them unless you + know what you are doing *) +val new_function_id : unit -> cbid +val string_of_cbid : cbid -> string +val register_callback : 'a widget -> callback:(callback_buffer -> unit) -> string + (* Callback support *) +val clear_callback : cbid -> unit + (* Remove a given callback from the table *) +val remove_callbacks : 'a widget -> unit + (* Clean up callbacks associated to widget. Must be used only when + the Destroy event is bind by the user and masks the default + Destroy event binding *) + +val cTKtoCAMLwidget : string -> any widget +val cCAMLtoTKwidget : 'a widget -> tkArgs + +val register : string -> callback:(callback_buffer -> unit) -> unit + +(*-*) +val prerr_cbid : cbid -> unit diff --git a/otherlibs/labltk/support/report.ml b/otherlibs/labltk/support/report.ml new file mode 100644 index 000000000..ee040de37 --- /dev/null +++ b/otherlibs/labltk/support/report.ml @@ -0,0 +1,7 @@ +(* Report globals from protocol to tk *) +let openTk = openTk +and openTkClass = openTkClass +and openTkDisplayClass = openTkDisplayClass +and closeTk = closeTk +and mainLoop = mainLoop +and register = register diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml new file mode 100644 index 000000000..eee855cae --- /dev/null +++ b/otherlibs/labltk/support/support.ml @@ -0,0 +1,61 @@ +(* $Id$ *) + +(* Extensible buffers *) +type extensible_buffer = { + mutable buffer : string; + mutable pos : int; + mutable len : int} + +let new_buffer () = { + buffer = String.create len:128; + pos = 0; + len = 128 + } + +let print_in_buffer buf s = + let l = String.length s in + if buf.pos + l > buf.len then begin + buf.buffer <- buf.buffer ^ (String.create len:(l+128)); + buf.len <- buf.len + 128 + l + end; + String.blit s pos:0 to:buf.buffer to_pos:buf.pos len:l; + buf.pos <- buf.pos + l + +let get_buffer buf = + String.sub buf.buffer pos:0 len:buf.pos + + + +(* Used by list converters *) +let catenate_sep sep = + function + [] -> "" + | [x] -> x + | x::l -> + let b = new_buffer() in + print_in_buffer b x; + List.iter l + fun:(function s -> print_in_buffer b sep; print_in_buffer b s); + get_buffer b + +(* Parsing results of Tcl *) +(* List.split a string according to char_sep predicate *) +let split_str char_sep str = + let len = String.length str in + let rec skip_sep cur = + if cur >= len then cur + else if char_sep str.[cur] then skip_sep (succ cur) + else cur in + let rec split beg cur = + if cur >= len then + if beg = cur then [] + else [String.sub str pos:beg len:(len - beg)] + else if char_sep str.[cur] + then + let nextw = skip_sep cur in + (String.sub str pos:beg len:(cur - beg)) + ::(split nextw nextw) + else split beg (succ cur) in + let wstart = skip_sep 0 in + split wstart wstart + diff --git a/otherlibs/labltk/support/support.mli b/otherlibs/labltk/support/support.mli new file mode 100644 index 000000000..798842298 --- /dev/null +++ b/otherlibs/labltk/support/support.mli @@ -0,0 +1,11 @@ +(* Extensible buffers *) +type extensible_buffer +val new_buffer : unit -> extensible_buffer +val print_in_buffer : extensible_buffer -> string -> unit +val get_buffer : extensible_buffer -> string + + +val catenate_sep : string -> string list -> string +val split_str : (char -> bool) -> string -> string list + (* Various string manipulations *) + diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml new file mode 100644 index 000000000..363b95d3e --- /dev/null +++ b/otherlibs/labltk/support/textvariable.ml @@ -0,0 +1,135 @@ +(* $Id$ *) + +open Protocol + +external internal_tracevar : string -> cbid -> unit + = "camltk_trace_var" +external internal_untracevar : string -> cbid -> unit + = "camltk_untrace_var" +external set : string -> to:string -> unit = "camltk_setvar" +external get : string -> string = "camltk_getvar" + + +type textVariable = string + +(* List of handles *) +let handles = Hashtbl.create 401 + +let add_handle var cbid = + try + let r = Hashtbl.find handles key:var in + r := cbid :: !r + with + Not_found -> + Hashtbl.add handles key:var data:(ref [cbid]) + +let exceptq x = + let rec ex acc = function + [] -> acc + | y::l when y == x -> ex acc l + | y::l -> ex (y::acc) l + in + ex [] + +let rem_handle var cbid = + try + let r = Hashtbl.find handles key:var in + match exceptq cbid !r with + [] -> Hashtbl.remove handles key:var + | remaining -> r := remaining + with + Not_found -> () + +(* Used when we "free" the variable (otherwise, old handlers would apply to + * new usage of the variable) + *) +let rem_all_handles var = + try + let r = Hashtbl.find handles key:var in + List.iter fun:(internal_untracevar var) !r; + Hashtbl.remove handles key:var + with + Not_found -> () + + +(* Variable trace *) +let handle vname f = + let id = new_function_id() in + let wrapped _ = + clear_callback id; + rem_handle vname id; + f() in + Hashtbl.add callback_naming_table key:id data:wrapped; + add_handle vname id; + if !Protocol.debug then begin + prerr_cbid id; prerr_string " for variable "; prerr_endline vname + end; + internal_tracevar vname id + +(* Avoid space leak (all variables are global in Tcl) *) +module StringSet = + Set.Make(struct type t = string let compare = compare end) +let freelist = ref (StringSet.empty) +let memo = Hashtbl.create 101 + +(* Added a variable v referenced by widget w *) +let add w v = + let w = Widget.forget_type w in + let r = + try Hashtbl.find memo key:w + with + Not_found -> + let r = ref StringSet.empty in + Hashtbl.add memo key:w data:r; + r in + r := StringSet.add !r elt:v + +(* to be used with care ! *) +let free v = + rem_all_handles v; + freelist := StringSet.add elt:v !freelist + +(* Free variables associated with a widget *) +let freew w = + try + let r = Hashtbl.find memo key:w in + StringSet.iter fun:free !r; + Hashtbl.remove memo key:w + with + Not_found -> () + +let _ = add_destroy_hook freew + +(* Allocate a new variable *) +let counter = ref 0 +let getv () = + let v = + if StringSet.is_empty !freelist then begin + incr counter; + "camlv("^ string_of_int !counter ^")" + end + else + let v = StringSet.choose !freelist in + freelist := StringSet.remove elt:v !freelist; + v in + set v to:""; + v + +let create ?on: w () = + let v = getv() in + begin + match w with + Some w -> add w v + | None -> () + end; + v + +(* to be used with care ! *) +let free v = + freelist := StringSet.add elt:v !freelist + +let cCAMLtoTKtextVariable s = TkToken s + +let name s = s +let coerce s = s + diff --git a/otherlibs/labltk/support/textvariable.mli b/otherlibs/labltk/support/textvariable.mli new file mode 100644 index 000000000..b018cc92c --- /dev/null +++ b/otherlibs/labltk/support/textvariable.mli @@ -0,0 +1,29 @@ +(* $Id$ *) + +(* Support for Tk -textvariable option *) +open Widget +open Protocol + +type textVariable + (* TextVariable is an abstract type *) + +val create : ?on: 'a widget -> unit -> textVariable + (* Allocation of a textVariable with lifetime associated to widget + if a widget is specified *) +val set : textVariable -> to: string -> unit + (* Setting the val of a textVariable *) +val get : textVariable -> string + (* Reading the val of a textVariable *) +val name : textVariable -> string + (* Its tcl name *) + +val cCAMLtoTKtextVariable : textVariable -> tkArgs + (* Internal conversion function *) + +val handle : textVariable -> (unit -> unit) -> unit + (* Callbacks on variable modifications *) + +val coerce : string -> textVariable + +(*-*) +val free : textVariable -> unit diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml new file mode 100644 index 000000000..7a1a8f001 --- /dev/null +++ b/otherlibs/labltk/support/timer.ml @@ -0,0 +1,33 @@ +(* $Id$ *) + +(* Timers *) +open Protocol + +type tkTimer = int + +external internal_add_timer : int -> cbid -> tkTimer + = "camltk_add_timer" +external internal_rem_timer : tkTimer -> unit + = "camltk_rem_timer" + +type t = tkTimer * cbid (* the token and the cb id *) + +(* A timer is used only once, so we must clean the callback table *) +let add ms:milli callback:f = + let id = new_function_id () in + let wrapped _ = + clear_callback id; (* do it first in case f raises exception *) + f() in + Hashtbl.add callback_naming_table key:id data:wrapped; + if !Protocol.debug then begin + prerr_cbid id; prerr_endline " for timer" + end; + let t = internal_add_timer milli id in + t,id + +(* If the timer has never been used, there is a small space leak in + the C heap, where a copy of id has been stored *) +let remove (tkTimer, id) = + internal_rem_timer tkTimer; + clear_callback id + diff --git a/otherlibs/labltk/support/timer.mli b/otherlibs/labltk/support/timer.mli new file mode 100644 index 000000000..6e7610ce2 --- /dev/null +++ b/otherlibs/labltk/support/timer.mli @@ -0,0 +1,4 @@ +type t + +val add : ms:int -> callback:(unit -> unit) -> t +val remove : t -> unit diff --git a/otherlibs/labltk/support/tkwait.ml b/otherlibs/labltk/support/tkwait.ml new file mode 100644 index 000000000..e8c1a6504 --- /dev/null +++ b/otherlibs/labltk/support/tkwait.ml @@ -0,0 +1,5 @@ + +external internal_tracevis : string -> string -> unit + = "camltk_wait_vis" +external internal_tracedestroy : string -> string -> unit + = "camltk_wait_des" diff --git a/otherlibs/labltk/support/widget.ml b/otherlibs/labltk/support/widget.ml new file mode 100644 index 000000000..7f6436c9b --- /dev/null +++ b/otherlibs/labltk/support/widget.ml @@ -0,0 +1,160 @@ +(* $Id$ *) + +(* + * Widgets + *) + +exception IllegalWidgetType of string + (* Raised when widget command applied illegally*) + +(***************************************************) +(* Widgets *) +(***************************************************) +type 'a widget = + Untyped of string +| Typed of string * string + +type any +and button +and canvas +and checkbutton +and entry +and frame +and label +and listbox +and menu +and menubutton +and message +and radiobutton +and scale +and scrollbar +and text +and toplevel + +let forget_type w = (Obj.magic (w : 'a widget) : any widget) +let coe = forget_type + +(* table of widgets *) +let table = (Hashtbl.create 401 : (string, any widget) Hashtbl.t) + +let name = function + Untyped s -> s + | Typed (s,_) -> s + +(* Normally all widgets are known *) +(* this is a provision for send commands to external tk processes *) +let known_class = function + Untyped _ -> "unknown" + | Typed (_,c) -> c + +(* This one is always created by opentk *) +let default_toplevel = + let wname = "." in + let w = Typed (wname, "toplevel") in + Hashtbl.add table key:wname data:w; + w + +(* Dummy widget to which global callbacks are associated *) +(* also passed around by camltotkoption when no widget in context *) +let dummy = + Untyped "dummy" + +let remove w = + Hashtbl.remove table key:(name w) + +(* Retype widgets returned from Tk *) +(* JPF report: sometime s is "", see Protocol.cTKtoCAMLwidget *) +let get_atom s = + try + Hashtbl.find table key:s + with + Not_found -> Untyped s + +let naming_scheme = [ + "button", "b"; + "canvas", "ca"; + "checkbutton", "cb"; + "entry", "en"; + "frame", "f"; + "label", "l"; + "listbox", "li"; + "menu", "me"; + "menubutton", "mb"; + "message", "ms"; + "radiobutton", "rb"; + "scale", "sc"; + "scrollbar", "sb"; + "text", "t"; + "toplevel", "top" ] + + +let widget_any_table = List.map fun:fst naming_scheme +(* subtypes *) +let widget_button_table = [ "button" ] +and widget_canvas_table = [ "canvas" ] +and widget_checkbutton_table = [ "checkbutton" ] +and widget_entry_table = [ "entry" ] +and widget_frame_table = [ "frame" ] +and widget_label_table = [ "label" ] +and widget_listbox_table = [ "listbox" ] +and widget_menu_table = [ "menu" ] +and widget_menubutton_table = [ "menubutton" ] +and widget_message_table = [ "message" ] +and widget_radiobutton_table = [ "radiobutton" ] +and widget_scale_table = [ "scale" ] +and widget_scrollbar_table = [ "scrollbar" ] +and widget_text_table = [ "text" ] +and widget_toplevel_table = [ "toplevel" ] + +let new_suffix clas n = + try + (List.assoc key:clas naming_scheme) ^ (string_of_int n) + with + Not_found -> "w" ^ (string_of_int n) + + +(* The function called by generic creation *) +let counter = ref 0 +let new_atom :parent ?name:nom clas = + let parentpath = name parent in + let path = + match nom with + None -> + incr counter; + if parentpath = "." + then "." ^ (new_suffix clas !counter) + else parentpath ^ "." ^ (new_suffix clas !counter) + | Some name -> + if parentpath = "." + then "." ^ (new_suffix clas !counter) + else parentpath ^ "." ^ name + in + let w = Typed(path,clas) in + Hashtbl.add table key:path data:w; + w + +(* Just create a path. Only to check existence of widgets *) +(* Use with care *) +let atom :parent name:pathcomp = + let parentpath = name parent in + let path = + if parentpath = "." + then "." ^ pathcomp + else parentpath ^ "." ^ pathcomp in + Untyped path + + + +(* Redundant with subtyping of Widget, backward compatibility *) +let check_class w clas = + match w with + Untyped _ -> () (* assume run-time check by tk*) + | Typed(_,c) -> + if List.mem clas elt:c then () + else raise (IllegalWidgetType c) + + +(* Checking membership of constructor in subtype table *) +let chk_sub errname table c = + if List.mem table elt:c then () + else raise (Invalid_argument errname) diff --git a/otherlibs/labltk/support/widget.mli b/otherlibs/labltk/support/widget.mli new file mode 100644 index 000000000..cf139a03f --- /dev/null +++ b/otherlibs/labltk/support/widget.mli @@ -0,0 +1,91 @@ +(* Support for widget manipulations *) + +type 'a widget + (* widget is an abstract type *) + +type any +and button +and canvas +and checkbutton +and entry +and frame +and label +and listbox +and menu +and menubutton +and message +and radiobutton +and scale +and scrollbar +and text +and toplevel + +val forget_type : 'a widget -> any widget +val coe : 'a widget -> any widget + +val default_toplevel : toplevel widget + (* [default_toplevel] is "." in Tk, the toplevel widget that is + always existing during a Tk session. Destroying [default_toplevel] + ends the main loop + *) + +val atom : parent: 'a widget -> name: string -> any widget + (* [atom parent name] returns the widget [parent.name]. The widget is + not created. Only its name is returned. In a given parent, there may + only exist one children for a given name. + This function should only be used to check the existence of a widget + with a known name. It doesn't add the widget to the internal tables + of CamlTk. + *) + +val name : 'a widget -> string + (* [name w] returns the name (tk "path") of a widget *) + +(*--*) +(* The following functions are used internally. + There is normally no need for them in users programs + *) + +val known_class : 'a widget -> string + (* [known_class w] returns the class of a widget (e.g. toplevel, frame), + as known by the CamlTk interface. + Not equivalent to "winfo w" in Tk. + *) + +val dummy : any widget + (* [dummy] is a widget used as context when we don't have any. + It is *not* a real widget. + *) + +val new_atom : parent:'a widget -> ?name: string -> string -> 'b widget + +val get_atom : string -> any widget + (* [get_atom path] returns the widget with Tk path [path] *) + +val remove : 'a widget -> unit + (* [remove w] removes widget from the internal tables *) + +(* Subtypes tables *) +val widget_any_table : string list +val widget_button_table : string list +val widget_canvas_table : string list +val widget_checkbutton_table : string list +val widget_entry_table : string list +val widget_frame_table : string list +val widget_label_table : string list +val widget_listbox_table : string list +val widget_menu_table : string list +val widget_menubutton_table : string list +val widget_message_table : string list +val widget_radiobutton_table : string list +val widget_scale_table : string list +val widget_scrollbar_table : string list +val widget_text_table : string list +val widget_toplevel_table : string list + +val chk_sub : string -> 'a list -> 'a -> unit +val check_class : 'a widget -> string list -> unit + (* Widget subtyping *) + +exception IllegalWidgetType of string + (* Raised when widget command applied illegally*) |