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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
/*
* tcltklib.c
* Aug. 27, 1997 Y. Shigehiro
* Oct. 24, 1997 Y. Matsumoto
*/
#include "ruby.h"
#include "sig.h"
#include <stdio.h>
#include <string.h>
#include <tcl.h>
#include <tk.h>
/* for debug */
#define DUMP1(ARG1) if (debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);}
#define DUMP2(ARG1, ARG2) if (debug) { fprintf(stderr, "tcltklib: ");\
fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); }
/*
#define DUMP1(ARG1)
#define DUMP2(ARG1, ARG2)
*/
/* from tkAppInit.c */
/*
* The following variable is a special hack that is needed in order for
* Sun shared libraries to be used for Tcl.
*/
extern int matherr();
int *tclDummyMathPtr = (int *) matherr;
/*---- module TclTkLib ----*/
static VALUE thread_safe = Qnil;
/* execute Tk_MainLoop */
static VALUE
lib_mainloop(VALUE self)
{
int old_trapflg;
int flags = RTEST(thread_safe)?TCL_DONT_WAIT:0;
DUMP1("start Tk_Mainloop");
while (Tk_GetNumMainWindows() > 0) {
old_trapflg = trap_immediate;
trap_immediate = 1;
Tcl_DoOneEvent(flags);
trap_immediate = old_trapflg;
CHECK_INTS;
flags = (thread_safe == 0 || thread_safe == Qnil)?0:TCL_DONT_WAIT;
}
DUMP1("stop Tk_Mainloop");
return Qnil;
}
/*---- class TclTkIp ----*/
struct tcltkip {
Tcl_Interp *ip; /* the interpreter */
int return_value; /* return value */
};
/* Tcl command `ruby' */
static VALUE
ip_eval_rescue(VALUE *failed, VALUE einfo)
{
*failed = einfo;
return Qnil;
}
static int
ip_ruby(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])
{
VALUE res;
int old_trapflg;
VALUE failed = 0;
/* ruby command has 1 arg. */
if (argc != 2) {
ArgError("wrong # of arguments (%d for 1)", argc);
}
/* evaluate the argument string by ruby */
DUMP2("rb_eval_string(%s)", argv[1]);
old_trapflg = trap_immediate;
trap_immediate = 0;
res = rb_rescue(rb_eval_string, argv[1], ip_eval_rescue, &failed);
trap_immediate = old_trapflg;
if (failed) {
Tcl_AppendResult(interp, RSTRING(failed)->ptr, (char*)NULL);
return TCL_ERROR;
}
/* result must be string or nil */
if (NIL_P(res)) {
DUMP1("(rb_eval_string result) nil");
return TCL_OK;
}
Check_Type(res, T_STRING);
/* copy result to the tcl interpreter */
DUMP2("(rb_eval_string result) %s", RSTRING(res)->ptr);
DUMP1("Tcl_AppendResult");
Tcl_AppendResult(interp, RSTRING(res)->ptr, (char *)NULL);
return TCL_OK;
}
/* destroy interpreter */
static void
ip_free(struct tcltkip *ptr)
{
DUMP1("Tcl_DeleteInterp");
Tcl_DeleteInterp(ptr->ip);
free(ptr);
}
/* create and initialize interpreter */
static VALUE
ip_new(VALUE self)
{
struct tcltkip *ptr; /* tcltkip data struct */
VALUE obj; /* newly created object */
/* create object */
obj = Data_Make_Struct(self, struct tcltkip, 0, ip_free, ptr);
ptr->return_value = 0;
/* from Tk_Main() */
DUMP1("Tcl_CreateInterp");
ptr->ip = Tcl_CreateInterp();
/* from Tcl_AppInit() */
DUMP1("Tcl_Init");
if (Tcl_Init(ptr->ip) == TCL_ERROR) {
Fail("Tcl_Init");
}
DUMP1("Tk_Init");
if (Tk_Init(ptr->ip) == TCL_ERROR) {
Fail("Tk_Init");
}
DUMP1("Tcl_StaticPackage(\"Tk\")");
Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init,
(Tcl_PackageInitProc *) NULL);
/* add ruby command to the interpreter */
DUMP1("Tcl_CreateCommand(\"ruby\")");
Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby, (ClientData *)NULL,
(Tcl_CmdDeleteProc *)NULL);
return obj;
}
/* eval string in tcl by Tcl_Eval() */
static VALUE
ip_eval(VALUE self, VALUE str)
{
char *buf; /* Tcl_Eval requires re-writable string region */
struct tcltkip *ptr; /* tcltkip data struct */
/* get the data struct */
Data_Get_Struct(self, struct tcltkip, ptr);
/* call Tcl_Eval() */
Check_Type(str, T_STRING);
buf = ALLOCA_N(char,RSTRING(str)->len+1);
strcpy(buf, RSTRING(str)->ptr);
DUMP2("Tcl_Eval(%s)", buf);
ptr->return_value = Tcl_Eval(ptr->ip, buf);
if (ptr->return_value == TCL_ERROR) {
Fail(ptr->ip->result);
}
DUMP2("(TCL_Eval result) %d", ptr->return_value);
/* pass back the result (as string) */
return(str_new2(ptr->ip->result));
}
/* get return code from Tcl_Eval() */
static VALUE
ip_retval(VALUE self)
{
struct tcltkip *ptr; /* tcltkip data struct */
/* get the data strcut */
Data_Get_Struct(self, struct tcltkip, ptr);
return (INT2FIX(ptr->return_value));
}
/*---- initialization ----*/
void Init_tcltklib()
{
extern VALUE rb_argv0; /* the argv[0] */
VALUE lib = rb_define_module("TclTkLib");
VALUE ip = rb_define_class("TclTkIp", cObject);
rb_define_module_function(lib, "mainloop", lib_mainloop, 0);
rb_define_singleton_method(ip, "new", ip_new, 0);
rb_define_method(ip, "_eval", ip_eval, 1);
rb_define_method(ip, "_return_value", ip_retval, 0);
rb_define_method(ip, "mainloop", lib_mainloop, 0);
/*---- initialize tcl/tk libraries ----*/
/* from Tk_Main() */
DUMP1("Tcl_FindExecutable");
Tcl_FindExecutable(RSTRING(rb_argv0)->ptr);
rb_define_variable("$tk_thread_safe", &thread_safe);
}
/* eof */
|
