1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
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;
}
|
