Ruby 2.0.0p353(2013-11-22revision43784)

- Main Page
- Modules
- Data Structures
- Files

- File List
- Globals

tcltklib.c
Go to the documentation of this file.
1 /*
2 * tcltklib.c
3 * Aug. 27, 1997 Y. Shigehiro
4 * Oct. 24, 1997 Y. Matsumoto
5 */
6
7 #define TCLTKLIB_RELEASE_DATE "2010-08-25"
8 /* #define CREATE_RUBYTK_KIT */
9
10 #include "ruby.h"
11
12 #ifdef HAVE_RUBY_ENCODING_H
13 #include "ruby/encoding.h"
14 #endif
15 #ifndef RUBY_VERSION
16 #define RUBY_VERSION "(unknown version)"
17 #endif
18 #ifndef RUBY_RELEASE_DATE
19 #define RUBY_RELEASE_DATE "unknown release-date"
20 #endif
21
22 #ifdef RUBY_VM
23 static int rb_thread_critical; /* dummy */
24 int rb_thread_check_trap_pending();
25 #else
26 /* use rb_thread_critical on Ruby 1.8.x */
27 #include "rubysig.h"
28 #endif
29
30 #if !defined(RSTRING_PTR)
31 #define RSTRING_PTR(s) (RSTRING(s)->ptr)
32 #define RSTRING_LEN(s) (RSTRING(s)->len)
33 #endif
34 #if !defined(RSTRING_LENINT)
35 #define RSTRING_LENINT(s) ((int)RSTRING_LEN(s))
36 #endif
37 #if !defined(RARRAY_PTR)
38 #define RARRAY_PTR(s) (RARRAY(s)->ptr)
39 #define RARRAY_LEN(s) (RARRAY(s)->len)
40 #endif
41
42 #ifdef OBJ_UNTRUST
43 #define RbTk_OBJ_UNTRUST(x) do {OBJ_TAINT(x); OBJ_UNTRUST(x);} while (0)
44 #else
45 #define RbTk_OBJ_UNTRUST(x) OBJ_TAINT(x)
46 #endif
47 #define RbTk_ALLOC_N(type, n) (type *)ckalloc((int)(sizeof(type) * (n)))
48
49 #if defined(HAVE_RB_PROC_NEW) && !defined(RUBY_VM)
50 /* Ruby 1.8 :: rb_proc_new() was hidden from intern.h at 2008/04/22 */
51 extern VALUE rb_proc_new _((VALUE (*)(ANYARGS/* VALUE yieldarg[, VALUE procarg] */), VALUE));
52 #endif
53
54 #undef EXTERN /* avoid conflict with tcl.h of tcl8.2 or before */
55 #include <stdio.h>
56 #ifdef HAVE_STDARG_PROTOTYPES
57 #include <stdarg.h>
58 #define va_init_list(a,b) va_start(a,b)
59 #else
60 #include <varargs.h>
61 #define va_init_list(a,b) va_start(a)
62 #endif
63 #include <string.h>
64
65 #if !defined HAVE_VSNPRINTF && !defined vsnprintf
66 # ifdef WIN32
67 /* In Win32, vsnprintf is available as the "non-ANSI" _vsnprintf. */
68 # define vsnprintf _vsnprintf
69 # else
70 # ifdef HAVE_RUBY_RUBY_H
71 # include "ruby/missing.h"
72 # else
73 # include "missing.h"
74 # endif
75 # endif
76 #endif
77
78 #include <tcl.h>
79 #include <tk.h>
80
81 #ifndef HAVE_RUBY_NATIVE_THREAD_P
82 #define ruby_native_thread_p() is_ruby_native_thread()
83 #undef RUBY_USE_NATIVE_THREAD
84 #else
85 #define RUBY_USE_NATIVE_THREAD 1
86 #endif
87
88 #ifndef HAVE_RB_ERRINFO
89 #define rb_errinfo() (ruby_errinfo+0) /* cannot be l-value */
90 #else
91 VALUE rb_errinfo(void);
92 #endif
93 #ifndef HAVE_RB_SAFE_LEVEL
94 #define rb_safe_level() (ruby_safe_level+0)
95 #endif
96 #ifndef HAVE_RB_SOURCEFILE
97 #define rb_sourcefile() (ruby_sourcefile+0)
98 #endif
99
100 #include "stubs.h"
101
102 #ifndef TCL_ALPHA_RELEASE
103 #define TCL_ALPHA_RELEASE 0 /* "alpha" */
104 #define TCL_BETA_RELEASE 1 /* "beta" */
105 #define TCL_FINAL_RELEASE 2 /* "final" */
106 #endif
107
108 static struct {
109 int major;
110 int minor;
111 int type; /* ALPHA==0, BETA==1, FINAL==2 */
112 int patchlevel;
113 } tcltk_version = {0, 0, 0, 0};
114
115 static void
116 set_tcltk_version()
117 {
118 if (tcltk_version.major) return;
119
120 Tcl_GetVersion(&(tcltk_version.major),
121 &(tcltk_version.minor),
122 &(tcltk_version.patchlevel),
123 &(tcltk_version.type));
124 }
125
126 #if TCL_MAJOR_VERSION >= 8
127 # ifndef CONST84
128 # if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 4 /* Tcl8.0.x -- 8.4b1 */
129 # define CONST84
130 # else /* unknown (maybe TCL_VERSION >= 8.5) */
131 # ifdef CONST
132 # define CONST84 CONST
133 # else
134 # define CONST84
135 # endif
136 # endif
137 # endif
138 #else /* TCL_MAJOR_VERSION < 8 */
139 # ifdef CONST
140 # define CONST84 CONST
141 # else
142 # define CONST
143 # define CONST84
144 # endif
145 #endif
146
147 #ifndef CONST86
148 # if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 5 /* Tcl8.0.x -- 8.5.x */
149 # define CONST86
150 # else
151 # define CONST86 CONST84
152 # endif
153 #endif
154
155 /* copied from eval.c */
156 #define TAG_RETURN 0x1
157 #define TAG_BREAK 0x2
158 #define TAG_NEXT 0x3
159 #define TAG_RETRY 0x4
160 #define TAG_REDO 0x5
161 #define TAG_RAISE 0x6
162 #define TAG_THROW 0x7
163 #define TAG_FATAL 0x8
164
165 /* for ruby_debug */
166 #define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1); fflush(stderr); }
167 #define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\
168 fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); fflush(stderr); }
169 #define DUMP3(ARG1, ARG2, ARG3) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\
170 fprintf(stderr, ARG1, ARG2, ARG3); fprintf(stderr, "\n"); fflush(stderr); }
171 /*
172 #define DUMP1(ARG1)
173 #define DUMP2(ARG1, ARG2)
174 #define DUMP3(ARG1, ARG2, ARG3)
175 */
176
177 /* release date */
178 static const char tcltklib_release_date[] = TCLTKLIB_RELEASE_DATE;
179
180 /* finalize_proc_name */
181 static const char finalize_hook_name[] = "INTERP_FINALIZE_HOOK";
182
183 static void ip_finalize _((Tcl_Interp*));
184
185 static int at_exit = 0;
186
187 #ifdef HAVE_RUBY_ENCODING_H
188 static VALUE cRubyEncoding;
189
190 /* encoding */
191 static int ENCODING_INDEX_UTF8;
192 static int ENCODING_INDEX_BINARY;
193 #endif
194 static VALUE ENCODING_NAME_UTF8;
195 static VALUE ENCODING_NAME_BINARY;
196
197 static VALUE create_dummy_encoding_for_tk_core _((VALUE, VALUE, VALUE));
198 static VALUE create_dummy_encoding_for_tk _((VALUE, VALUE));
199 static int update_encoding_table _((VALUE, VALUE, VALUE));
200 static VALUE encoding_table_get_name_core _((VALUE, VALUE, VALUE));
201 static VALUE encoding_table_get_obj_core _((VALUE, VALUE, VALUE));
202 static VALUE encoding_table_get_name _((VALUE, VALUE));
203 static VALUE encoding_table_get_obj _((VALUE, VALUE));
204 static VALUE create_encoding_table _((VALUE));
205 static VALUE ip_get_encoding_table _((VALUE));
206
207
208 /* for callback break & continue */
209 static VALUE eTkCallbackReturn;
210 static VALUE eTkCallbackBreak;
211 static VALUE eTkCallbackContinue;
212
213 static VALUE eLocalJumpError;
214
215 static VALUE eTkLocalJumpError;
216 static VALUE eTkCallbackRetry;
217 static VALUE eTkCallbackRedo;
218 static VALUE eTkCallbackThrow;
219
220 static VALUE tcltkip_class;
221
222 static ID ID_at_enc;
223 static ID ID_at_interp;
224
225 static ID ID_encoding_name;
226 static ID ID_encoding_table;
227
228 static ID ID_stop_p;
229 static ID ID_alive_p;
230 static ID ID_kill;
231 static ID ID_join;
232 static ID ID_value;
233
234 static ID ID_call;
235 static ID ID_backtrace;
236 static ID ID_message;
237
238 static ID ID_at_reason;
239 static ID ID_return;
240 static ID ID_break;
241 static ID ID_next;
242
243 static ID ID_to_s;
244 static ID ID_inspect;
245
246 static VALUE ip_invoke_real _((int, VALUE*, VALUE));
247 static VALUE ip_invoke _((int, VALUE*, VALUE));
248 static VALUE ip_invoke_with_position _((int, VALUE*, VALUE, Tcl_QueuePosition));
249 static VALUE tk_funcall _((VALUE(), int, VALUE*, VALUE));
250 static VALUE callq_safelevel_handler _((VALUE, VALUE));
251
252 /* Tcl's object type */
253 #if TCL_MAJOR_VERSION >= 8
254 static const char Tcl_ObjTypeName_ByteArray[] = "bytearray";
255 static CONST86 Tcl_ObjType *Tcl_ObjType_ByteArray;
256
257 static const char Tcl_ObjTypeName_String[] = "string";
258 static CONST86 Tcl_ObjType *Tcl_ObjType_String;
259
260 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
261 #define IS_TCL_BYTEARRAY(obj) ((obj)->typePtr == Tcl_ObjType_ByteArray)
262 #define IS_TCL_STRING(obj) ((obj)->typePtr == Tcl_ObjType_String)
263 #define IS_TCL_VALID_STRING(obj) ((obj)->bytes != (char*)NULL)
264 #endif
265 #endif
266
267 #ifndef HAVE_RB_HASH_LOOKUP
268 #define rb_hash_lookup rb_hash_aref
269 #endif
270
271 /* safe Tcl_Eval and Tcl_GlobalEval */
272 static int
273 #ifdef HAVE_PROTOTYPES
274 tcl_eval(Tcl_Interp *interp, const char *cmd)
275 #else
276 tcl_eval(interp, cmd)
277 Tcl_Interp *interp;
278 const char *cmd; /* don't have to be writable */
279 #endif
280 {
281 char *buf = strdup(cmd);
282 int ret;
283
284 Tcl_AllowExceptions(interp);
285 ret = Tcl_Eval(interp, buf);
286 free(buf);
287 return ret;
288 }
289
290 #undef Tcl_Eval
291 #define Tcl_Eval tcl_eval
292
293 static int
294 #ifdef HAVE_PROTOTYPES
295 tcl_global_eval(Tcl_Interp *interp, const char *cmd)
296 #else
297 tcl_global_eval(interp, cmd)
298 Tcl_Interp *interp;
299 const char *cmd; /* don't have to be writable */
300 #endif
301 {
302 char *buf = strdup(cmd);
303 int ret;
304
305 Tcl_AllowExceptions(interp);
306 ret = Tcl_GlobalEval(interp, buf);
307 free(buf);
308 return ret;
309 }
310
311 #undef Tcl_GlobalEval
312 #define Tcl_GlobalEval tcl_global_eval
313
314 /* Tcl_{Incr|Decr}RefCount for tcl7.x or earlier */
315 #if TCL_MAJOR_VERSION < 8
316 #define Tcl_IncrRefCount(obj) (1)
317 #define Tcl_DecrRefCount(obj) (1)
318 #endif
319
320 /* Tcl_GetStringResult for tcl7.x or earlier */
321 #if TCL_MAJOR_VERSION < 8
322 #define Tcl_GetStringResult(interp) ((interp)->result)
323 #endif
324
325 /* Tcl_[GS]etVar2Ex for tcl8.0 */
326 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
327 static Tcl_Obj *
328 Tcl_GetVar2Ex(interp, name1, name2, flags)
329 Tcl_Interp *interp;
330 CONST char *name1;
331 CONST char *name2;
332 int flags;
333 {
334 Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj;
335
336 nameObj1 = Tcl_NewStringObj((char*)name1, -1);
337 Tcl_IncrRefCount(nameObj1);
338
339 if (name2) {
340 nameObj2 = Tcl_NewStringObj((char*)name2, -1);
341 Tcl_IncrRefCount(nameObj2);
342 }
343
344 retObj = Tcl_ObjGetVar2(interp, nameObj1, nameObj2, flags);
345
346 if (name2) {
347 Tcl_DecrRefCount(nameObj2);
348 }
349
350 Tcl_DecrRefCount(nameObj1);
351
352 return retObj;
353 }
354
355 static Tcl_Obj *
356 Tcl_SetVar2Ex(interp, name1, name2, newValObj, flags)
357 Tcl_Interp *interp;
358 CONST char *name1;
359 CONST char *name2;
360 Tcl_Obj *newValObj;
361 int flags;
362 {
363 Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj;
364
365 nameObj1 = Tcl_NewStringObj((char*)name1, -1);
366 Tcl_IncrRefCount(nameObj1);
367
368 if (name2) {
369 nameObj2 = Tcl_NewStringObj((char*)name2, -1);
370 Tcl_IncrRefCount(nameObj2);
371 }
372
373 retObj = Tcl_ObjSetVar2(interp, nameObj1, nameObj2, newValObj, flags);
374
375 if (name2) {
376 Tcl_DecrRefCount(nameObj2);
377 }
378
379 Tcl_DecrRefCount(nameObj1);
380
381 return retObj;
382 }
383 #endif
384
385 /* from tkAppInit.c */
386
387 #if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 4)
388 # if !defined __MINGW32__ && !defined __BORLANDC__
389 /*
390 * The following variable is a special hack that is needed in order for
391 * Sun shared libraries to be used for Tcl.
392 */
393
394 extern int matherr();
395 int *tclDummyMathPtr = (int *) matherr;
396 # endif
397 #endif
398
399 /*---- module TclTkLib ----*/
400
401 struct invoke_queue {
402 Tcl_Event ev;
403 int argc;
404 #if TCL_MAJOR_VERSION >= 8
405 Tcl_Obj **argv;
406 #else /* TCL_MAJOR_VERSION < 8 */
407 char **argv;
408 #endif
409 VALUE interp;
410 int *done;
411 int safe_level;
412 VALUE result;
413 VALUE thread;
414 };
415
416 struct eval_queue {
417 Tcl_Event ev;
418 char *str;
419 int len;
420 VALUE interp;
421 int *done;
422 int safe_level;
423 VALUE result;
424 VALUE thread;
425 };
426
427 struct call_queue {
428 Tcl_Event ev;
429 VALUE (*func)();
430 int argc;
431 VALUE *argv;
432 VALUE interp;
433 int *done;
434 int safe_level;
435 VALUE result;
436 VALUE thread;
437 };
438
439 void
440 invoke_queue_mark(struct invoke_queue *q)
441 {
442 rb_gc_mark(q->interp);
443 rb_gc_mark(q->result);
444 rb_gc_mark(q->thread);
445 }
446
447 void
448 eval_queue_mark(struct eval_queue *q)
449 {
450 rb_gc_mark(q->interp);
451 rb_gc_mark(q->result);
452 rb_gc_mark(q->thread);
453 }
454
455 void
456 call_queue_mark(struct call_queue *q)
457 {
458 int i;
459
460 for(i = 0; i < q->argc; i++) {
461 rb_gc_mark(q->argv[i]);
462 }
463
464 rb_gc_mark(q->interp);
465 rb_gc_mark(q->result);
466 rb_gc_mark(q->thread);
467 }
468
469
470 static VALUE eventloop_thread;
471 static Tcl_Interp *eventloop_interp;
472 #ifdef RUBY_USE_NATIVE_THREAD
473 Tcl_ThreadId tk_eventloop_thread_id; /* native thread ID of Tcl interpreter */
474 #endif
475 static VALUE eventloop_stack;
476 static int window_event_mode = ~0;
477
478 static VALUE watchdog_thread;
479
480 Tcl_Interp *current_interp;
481
482 /* thread control strategy */
483 /* multi-tk works with the following settings only ???
484 : CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1
485 : USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0
486 : DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0
487 */
488 #ifdef RUBY_USE_NATIVE_THREAD
489 #define CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1
490 #define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0
491 #define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 1
492 #else /* ! RUBY_USE_NATIVE_THREAD */
493 #define CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1
494 #define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0
495 #define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0
496 #endif
497
498 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
499 static int have_rb_thread_waiting_for_value = 0;
500 #endif
501
502 /*
503 * 'event_loop_max' is a maximum events which the eventloop processes in one
504 * term of thread scheduling. 'no_event_tick' is the count-up value when
505 * there are no event for processing.
506 * 'timer_tick' is a limit of one term of thread scheduling.
507 * If 'timer_tick' == 0, then not use the timer for thread scheduling.
508 */
509 #ifdef RUBY_USE_NATIVE_THREAD
510 #define DEFAULT_EVENT_LOOP_MAX 800/*counts*/
511 #define DEFAULT_NO_EVENT_TICK 10/*counts*/
512 #define DEFAULT_NO_EVENT_WAIT 5/*milliseconds ( 1 -- 999 ) */
513 #define WATCHDOG_INTERVAL 10/*milliseconds ( 1 -- 999 ) */
514 #define DEFAULT_TIMER_TICK 0/*milliseconds ( 0 -- 999 ) */
515 #define NO_THREAD_INTERRUPT_TIME 100/*milliseconds ( 1 -- 999 ) */
516 #else /* ! RUBY_USE_NATIVE_THREAD */
517 #define DEFAULT_EVENT_LOOP_MAX 800/*counts*/
518 #define DEFAULT_NO_EVENT_TICK 10/*counts*/
519 #define DEFAULT_NO_EVENT_WAIT 20/*milliseconds ( 1 -- 999 ) */
520 #define WATCHDOG_INTERVAL 10/*milliseconds ( 1 -- 999 ) */
521 #define DEFAULT_TIMER_TICK 0/*milliseconds ( 0 -- 999 ) */
522 #define NO_THREAD_INTERRUPT_TIME 100/*milliseconds ( 1 -- 999 ) */
523 #endif
524
525 #define EVENT_HANDLER_TIMEOUT 100/*milliseconds*/
526
527 static int event_loop_max = DEFAULT_EVENT_LOOP_MAX;
528 static int no_event_tick = DEFAULT_NO_EVENT_TICK;
529 static int no_event_wait = DEFAULT_NO_EVENT_WAIT;
530 static int timer_tick = DEFAULT_TIMER_TICK;
531 static int req_timer_tick = DEFAULT_TIMER_TICK;
532 static int run_timer_flag = 0;
533
534 static int event_loop_wait_event = 0;
535 static int event_loop_abort_on_exc = 1;
536 static int loop_counter = 0;
537
538 static int check_rootwidget_flag = 0;
539
540
541 /* call ruby interpreter */
542 #if TCL_MAJOR_VERSION >= 8
543 static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
544 static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
545 #else /* TCL_MAJOR_VERSION < 8 */
546 static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, char **));
547 static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, char **));
548 #endif
549
550 struct cmd_body_arg {
551 VALUE receiver;
552 ID method;
553 VALUE args;
554 };
555
556 /*----------------------------*/
557 /* use Tcl internal functions */
558 /*----------------------------*/
559 #ifndef TCL_NAMESPACE_DEBUG
560 #define TCL_NAMESPACE_DEBUG 0
561 #endif
562
563 #if TCL_NAMESPACE_DEBUG
564
565 #if TCL_MAJOR_VERSION >= 8
566 EXTERN struct TclIntStubs *tclIntStubsPtr;
567 #endif
568
569 /*-- Tcl_GetCurrentNamespace --*/
570 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5
571 /* Tcl7.x doesn't have namespace support. */
572 /* Tcl8.5+ has definition of Tcl_GetCurrentNamespace() in tclDecls.h */
573 # ifndef Tcl_GetCurrentNamespace
574 EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace _((Tcl_Interp *));
575 # endif
576 # if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
577 # ifndef Tcl_GetCurrentNamespace
578 # ifndef FunctionNum_of_GetCurrentNamespace
579 #define FunctionNum_of_GetCurrentNamespace 124
580 # endif
581 struct DummyTclIntStubs_for_GetCurrentNamespace {
582 int magic;
583 struct TclIntStubHooks *hooks;
584 void (*func[FunctionNum_of_GetCurrentNamespace])();
585 Tcl_Namespace * (*tcl_GetCurrentNamespace) _((Tcl_Interp *));
586 };
587
588 #define Tcl_GetCurrentNamespace \
589 (((struct DummyTclIntStubs_for_GetCurrentNamespace *)tclIntStubsPtr)->tcl_GetCurrentNamespace)
590 # endif
591 # endif
592 #endif
593
594 /* namespace check */
595 /* ip_null_namespace(Tcl_Interp *interp) */
596 #if TCL_MAJOR_VERSION < 8
597 #define ip_null_namespace(interp) (0)
598 #else /* support namespace */
599 #define ip_null_namespace(interp) \
600 (Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL)
601 #endif
602
603 /* rbtk_invalid_namespace(tcltkip *ptr) */
604 #if TCL_MAJOR_VERSION < 8
605 #define rbtk_invalid_namespace(ptr) (0)
606 #else /* support namespace */
607 #define rbtk_invalid_namespace(ptr) \
608 ((ptr)->default_ns == (Tcl_Namespace*)NULL || Tcl_GetCurrentNamespace((ptr)->ip) != (ptr)->default_ns)
609 #endif
610
611 /*-- Tcl_PopCallFrame & Tcl_PushCallFrame --*/
612 #if TCL_MAJOR_VERSION >= 8
613 # ifndef CallFrame
614 typedef struct CallFrame {
615 Tcl_Namespace *nsPtr;
616 int dummy1;
617 int dummy2;
618 char *dummy3;
619 struct CallFrame *callerPtr;
620 struct CallFrame *callerVarPtr;
621 int level;
622 char *dummy7;
623 char *dummy8;
624 int dummy9;
625 char* dummy10;
626 } CallFrame;
627 # endif
628
629 # if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED)
630 EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **));
631 # endif
632 # if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
633 # ifndef TclGetFrame
634 # ifndef FunctionNum_of_GetFrame
635 #define FunctionNum_of_GetFrame 32
636 # endif
637 struct DummyTclIntStubs_for_GetFrame {
638 int magic;
639 struct TclIntStubHooks *hooks;
640 void (*func[FunctionNum_of_GetFrame])();
641 int (*tclGetFrame) _((Tcl_Interp *, CONST char *, CallFrame **));
642 };
643 #define TclGetFrame \
644 (((struct DummyTclIntStubs_for_GetFrame *)tclIntStubsPtr)->tclGetFrame)
645 # endif
646 # endif
647
648 # if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED)
649 EXTERN void Tcl_PopCallFrame _((Tcl_Interp *));
650 EXTERN int Tcl_PushCallFrame _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int));
651 # endif
652 # if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
653 # ifndef Tcl_PopCallFrame
654 # ifndef FunctionNum_of_PopCallFrame
655 #define FunctionNum_of_PopCallFrame 128
656 # endif
657 struct DummyTclIntStubs_for_PopCallFrame {
658 int magic;
659 struct TclIntStubHooks *hooks;
660 void (*func[FunctionNum_of_PopCallFrame])();
661 void (*tcl_PopCallFrame) _((Tcl_Interp *));
662 int (*tcl_PushCallFrame) _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int));
663 };
664
665 #define Tcl_PopCallFrame \
666 (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PopCallFrame)
667 #define Tcl_PushCallFrame \
668 (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PushCallFrame)
669 # endif
670 # endif
671
672 #else /* Tcl7.x */
673 # ifndef CallFrame
674 typedef struct CallFrame {
675 Tcl_HashTable varTable;
676 int level;
677 int argc;
678 char **argv;
679 struct CallFrame *callerPtr;
680 struct CallFrame *callerVarPtr;
681 } CallFrame;
682 # endif
683 # ifndef Tcl_CallFrame
684 #define Tcl_CallFrame CallFrame
685 # endif
686
687 # if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED)
688 EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **));
689 # endif
690
691 # if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED)
692 typedef struct DummyInterp {
693 char *dummy1;
694 char *dummy2;
695 int dummy3;
696 Tcl_HashTable dummy4;
697 Tcl_HashTable dummy5;
698 Tcl_HashTable dummy6;
699 int numLevels;
700 int maxNestingDepth;
701 CallFrame *framePtr;
702 CallFrame *varFramePtr;
703 } DummyInterp;
704
705 static void
706 Tcl_PopCallFrame(interp)
707 Tcl_Interp *interp;
708 {
709 DummyInterp *iPtr = (DummyInterp*)interp;
710 CallFrame *frame = iPtr->varFramePtr;
711
712 /* **** DUMMY **** */
713 iPtr->framePtr = frame.callerPtr;
714 iPtr->varFramePtr = frame.callerVarPtr;
715
716 return TCL_OK;
717 }
718
719 /* dummy */
720 #define Tcl_Namespace char
721
722 static int
723 Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame)
724 Tcl_Interp *interp;
725 Tcl_CallFrame *framePtr;
726 Tcl_Namespace *nsPtr;
727 int isProcCallFrame;
728 {
729 DummyInterp *iPtr = (DummyInterp*)interp;
730 CallFrame *frame = (CallFrame *)framePtr;
731
732 /* **** DUMMY **** */
733 Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
734 if (iPtr->varFramePtr != NULL) {
735 frame.level = iPtr->varFramePtr->level + 1;
736 } else {
737 frame.level = 1;
738 }
739 frame.callerPtr = iPtr->framePtr;
740 frame.callerVarPtr = iPtr->varFramePtr;
741 iPtr->framePtr = &frame;
742 iPtr->varFramePtr = &frame;
743
744 return TCL_OK;
745 }
746 # endif
747
748 #endif
749
750 #endif /* TCL_NAMESPACE_DEBUG */
751
752
753 /*---- class TclTkIp ----*/
754 struct tcltkip {
755 Tcl_Interp *ip; /* the interpreter */
756 #if TCL_NAMESPACE_DEBUG
757 Tcl_Namespace *default_ns; /* default namespace */
758 #endif
759 #ifdef RUBY_USE_NATIVE_THREAD
760 Tcl_ThreadId tk_thread_id; /* native thread ID of Tcl interpreter */
761 #endif
762 int has_orig_exit; /* has original 'exit' command ? */
763 Tcl_CmdInfo orig_exit_info; /* command info of original 'exit' command */
764 int ref_count; /* reference count of rbtk_preserve_ip call */
765 int allow_ruby_exit; /* allow exiting ruby by 'exit' function */
766 int return_value; /* return value */
767 };
768
769 static struct tcltkip *
770 get_ip(self)
771 VALUE self;
772 {
773 struct tcltkip *ptr;
774
775 Data_Get_Struct(self, struct tcltkip, ptr);
776 if (ptr == 0) {
777 /* rb_raise(rb_eTypeError, "uninitialized TclTkIp"); */
778 return((struct tcltkip *)NULL);
779 }
780 if (ptr->ip == (Tcl_Interp*)NULL) {
781 /* rb_raise(rb_eRuntimeError, "deleted IP"); */
782 return((struct tcltkip *)NULL);
783 }
784 return ptr;
785 }
786
787 static int
788 deleted_ip(ptr)
789 struct tcltkip *ptr;
790 {
791 if (!ptr || !ptr->ip || Tcl_InterpDeleted(ptr->ip)
792 #if TCL_NAMESPACE_DEBUG
793 || rbtk_invalid_namespace(ptr)
794 #endif
795 ) {
796 DUMP1("ip is deleted");
797 return 1;
798 }
799 return 0;
800 }
801
802 /* increment/decrement reference count of tcltkip */
803 static int
804 rbtk_preserve_ip(ptr)
805 struct tcltkip *ptr;
806 {
807 ptr->ref_count++;
808 if (ptr->ip == (Tcl_Interp*)NULL) {
809 /* deleted IP */
810 ptr->ref_count = 0;
811 } else {
812 Tcl_Preserve((ClientData)ptr->ip);
813 }
814 return(ptr->ref_count);
815 }
816
817 static int
818 rbtk_release_ip(ptr)
819 struct tcltkip *ptr;
820 {
821 ptr->ref_count--;
822 if (ptr->ref_count < 0) {
823 ptr->ref_count = 0;
824 } else if (ptr->ip == (Tcl_Interp*)NULL) {
825 /* deleted IP */
826 ptr->ref_count = 0;
827 } else {
828 Tcl_Release((ClientData)ptr->ip);
829 }
830 return(ptr->ref_count);
831 }
832
833
834 static VALUE
835 #ifdef HAVE_STDARG_PROTOTYPES
836 create_ip_exc(VALUE interp, VALUE exc, const char *fmt, ...)
837 #else
838 create_ip_exc(interp, exc, fmt, va_alist)
839 VALUE interp:
840 VALUE exc;
841 const char *fmt;
842 va_dcl
843 #endif
844 {
845 va_list args;
846 char buf[BUFSIZ];
847 VALUE einfo;
848 struct tcltkip *ptr = get_ip(interp);
849
850 va_init_list(args,fmt);
851 vsnprintf(buf, BUFSIZ, fmt, args);
852 buf[BUFSIZ - 1] = '\0';
853 va_end(args);
854 einfo = rb_exc_new2(exc, buf);
855 rb_ivar_set(einfo, ID_at_interp, interp);
856 if (ptr) {
857 Tcl_ResetResult(ptr->ip);
858 }
859
860 return einfo;
861 }
862
863
864 /*####################################################################*/
865 #if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT
866
867 /*--------------------------------------------------------*/
868
869 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 84
870 #error Ruby/Tk-Kit requires Tcl/Tk8.4 or later.
871 #endif
872
873 /*--------------------------------------------------------*/
874
875 /* Many part of code to support Ruby/Tk-Kit is quoted from Tclkit. */
876 /* But, never ask Tclkit community about Ruby/Tk-Kit. */
877 /* Please ask Ruby (Ruby/Tk) community (e.g. "ruby-dev" mailing list). */
878 /*
879 ----<< license terms of TclKit (from kitgen's "README" file) >>---------------
880 The Tclkit-specific sources are license free, they just have a copyright. Hold
881 the author(s) harmless and any lawful use is permitted.
882
883 This does *not* apply to any of the sources of the other major Open Source
884 Software used in Tclkit, which each have very liberal BSD/MIT-like licenses:
885
886 * Tcl/Tk, TclVFS, Thread, Vlerq, Zlib
887 ------------------------------------------------------------------------------
888 */
889 /* Tcl/Tk stubs may work, but probably it is meaningless. */
890 #if defined USE_TCL_STUBS || defined USE_TK_STUBS
891 # error Not support Tcl/Tk stubs with Ruby/Tk-Kit or Rubykit.
892 #endif
893
894 #ifndef KIT_INCLUDES_ZLIB
895 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86
896 #define KIT_INCLUDES_ZLIB 1
897 #else
898 #define KIT_INCLUDES_ZLIB 0
899 #endif
900 #endif
901
902 #ifdef _WIN32
903 #define WIN32_LEAN_AND_MEAN
904 #include <windows.h>
905 #undef WIN32_LEAN_AND_MEAN
906 #endif
907
908 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86
909 EXTERN Tcl_Obj* TclGetStartupScriptPath();
910 EXTERN void TclSetStartupScriptPath _((Tcl_Obj*));
911 #define Tcl_GetStartupScript(encPtr) TclGetStartupScriptPath()
912 #define Tcl_SetStartupScript(path,enc) TclSetStartupScriptPath(path)
913 #endif
914 #if !defined(TclSetPreInitScript) && !defined(TclSetPreInitScript_TCL_DECLARED)
915 EXTERN char* TclSetPreInitScript _((char *));
916 #endif
917
918 #ifndef KIT_INCLUDES_TK
919 # define KIT_INCLUDES_TK 1
920 #endif
921 /* #define KIT_INCLUDES_ITCL 1 */
922 /* #define KIT_INCLUDES_THREAD 1 */
923
924 Tcl_AppInitProc Vfs_Init, Rechan_Init;
925 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85
926 Tcl_AppInitProc Pwb_Init;
927 #endif
928
929 #ifdef KIT_LITE
930 Tcl_AppInitProc Vlerq_Init, Vlerq_SafeInit;
931 #else
932 Tcl_AppInitProc Mk4tcl_Init;
933 #endif
934
935 #if defined TCL_THREADS && defined KIT_INCLUDES_THREAD
936 Tcl_AppInitProc Thread_Init;
937 #endif
938
939 #if KIT_INCLUDES_ZLIB
940 Tcl_AppInitProc Zlib_Init;
941 #endif
942
943 #ifdef KIT_INCLUDES_ITCL
944 Tcl_AppInitProc Itcl_Init;
945 #endif
946
947 #ifdef _WIN32
948 Tcl_AppInitProc Dde_Init, Dde_SafeInit, Registry_Init;
949 #endif
950
951 /*--------------------------------------------------------*/
952
953 #define RUBYTK_KITPATH_CONST_NAME "RUBYTK_KITPATH"
954
955 static char *rubytk_kitpath = NULL;
956
957 static char rubytkkit_preInitCmd[] =
958 "proc tclKitPreInit {} {\n"
959 "rename tclKitPreInit {}\n"
960 "load {} rubytk_kitpath\n"
961 #if KIT_INCLUDES_ZLIB
962 "catch {load {} zlib}\n"
963 #endif
964 #ifdef KIT_LITE
965 "load {} vlerq\n"
966 "namespace eval ::vlerq {}\n"
967 "if {[catch { vlerq open $::tcl::kitpath } ::vlerq::starkit_root]} {\n"
968 "set n -1\n"
969 "} else {\n"
970 "set files [vlerq get $::vlerq::starkit_root 0 dirs 0 files]\n"
971 "set n [lsearch [vlerq get $files * name] boot.tcl]\n"
972 "}\n"
973 "if {$n >= 0} {\n"
974 "array set a [vlerq get $files $n]\n"
975 #else
976 "load {} Mk4tcl\n"
977 #if defined KIT_VFS_WRITABLE && !defined CREATE_RUBYKIT
978 /* running command cannot open itself for writing */
979 "mk::file open exe $::tcl::kitpath\n"
980 #else
981 "mk::file open exe $::tcl::kitpath -readonly\n"
982 #endif
983 "set n [mk::select exe.dirs!0.files name boot.tcl]\n"
984 "if {[llength $n] == 1} {\n"
985 "array set a [mk::get exe.dirs!0.files!$n]\n"
986 #endif
987 "if {![info exists a(contents)]} { error {no boot.tcl file} }\n"
988 "if {$a(size) != [string length $a(contents)]} {\n"
989 "set a(contents) [zlib decompress $a(contents)]\n"
990 "}\n"
991 "if {$a(contents) eq \"\"} { error {empty boot.tcl} }\n"
992 "uplevel #0 $a(contents)\n"
993 #if 0
994 "} elseif {[lindex $::argv 0] eq \"-init-\"} {\n"
995 "uplevel #0 { source [lindex $::argv 1] }\n"
996 "exit\n"
997 #endif
998 "} else {\n"
999 /* When cannot find VFS data, try to use a real directory */
1000 "set vfsdir \"[file rootname $::tcl::kitpath].vfs\"\n"
1001 "if {[file isdirectory $vfsdir]} {\n"
1002 "set ::tcl_library [file join $vfsdir lib tcl$::tcl_version]\n"
1003 "set ::tcl_libPath [list $::tcl_library [file join $vfsdir lib]]\n"
1004 "catch {uplevel #0 [list source [file join $vfsdir config.tcl]]}\n"
1005 "uplevel #0 [list source [file join $::tcl_library init.tcl]]\n"
1006 "set ::auto_path $::tcl_libPath\n"
1007 "} else {\n"
1008 "error \"\n $::tcl::kitpath has no VFS data to start up\"\n"
1009 "}\n"
1010 "}\n"
1011 "}\n"
1012 "tclKitPreInit"
1013 ;
1014
1015 #if 0
1016 /* Not use this script.
1017 It's a memo to support an initScript for Tcl interpreters in the future. */
1018 static const char initScript[] =
1019 "if {[file isfile [file join $::tcl::kitpath main.tcl]]} {\n"
1020 "if {[info commands console] != {}} { console hide }\n"
1021 "set tcl_interactive 0\n"
1022 "incr argc\n"
1023 "set argv [linsert $argv 0 $argv0]\n"
1024 "set argv0 [file join $::tcl::kitpath main.tcl]\n"
1025 "} else continue\n"
1026 ;
1027 #endif
1028
1029 /*--------------------------------------------------------*/
1030
1031 static char*
1032 set_rubytk_kitpath(const char *kitpath)
1033 {
1034 if (kitpath) {
1035 int len = (int)strlen(kitpath);
1036 if (rubytk_kitpath) {
1037 ckfree(rubytk_kitpath);
1038 }
1039
1040 rubytk_kitpath = (char *)ckalloc(len + 1);
1041 memcpy(rubytk_kitpath, kitpath, len);
1042 rubytk_kitpath[len] = '\0';
1043 }
1044 return rubytk_kitpath;
1045 }
1046
1047 /*--------------------------------------------------------*/
1048
1049 #ifdef WIN32
1050 #define DEV_NULL "NUL"
1051 #else
1052 #define DEV_NULL "/dev/null"
1053 #endif
1054
1055 static void
1056 check_tclkit_std_channels()
1057 {
1058 Tcl_Channel chan;
1059
1060 /*
1061 * We need to verify if we have the standard channels and create them if
1062 * not. Otherwise internals channels may get used as standard channels
1063 * (like for encodings) and panic.
1064 */
1065 chan = Tcl_GetStdChannel(TCL_STDIN);
1066 if (chan == NULL) {
1067 chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "r", 0);
1068 if (chan != NULL) {
1069 Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
1070 }
1071 Tcl_SetStdChannel(chan, TCL_STDIN);
1072 }
1073 chan = Tcl_GetStdChannel(TCL_STDOUT);
1074 if (chan == NULL) {
1075 chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0);
1076 if (chan != NULL) {
1077 Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
1078 }
1079 Tcl_SetStdChannel(chan, TCL_STDOUT);
1080 }
1081 chan = Tcl_GetStdChannel(TCL_STDERR);
1082 if (chan == NULL) {
1083 chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0);
1084 if (chan != NULL) {
1085 Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
1086 }
1087 Tcl_SetStdChannel(chan, TCL_STDERR);
1088 }
1089 }
1090
1091 /*--------------------------------------------------------*/
1092
1093 static int
1094 rubytk_kitpathObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
1095 {
1096 const char* str;
1097 if (objc == 2) {
1098 set_rubytk_kitpath(Tcl_GetString(objv[1]));
1099 } else if (objc > 2) {
1100 Tcl_WrongNumArgs(interp, 1, objv, "?path?");
1101 }
1102 str = rubytk_kitpath ? rubytk_kitpath : Tcl_GetNameOfExecutable();
1103 Tcl_SetObjResult(interp, Tcl_NewStringObj(str, -1));
1104 return TCL_OK;
1105 }
1106
1107 /*
1108 * Public entry point for ::tcl::kitpath.
1109 * Creates both link variable name and Tcl command ::tcl::kitpath.
1110 */
1111 static int
1112 rubytk_kitpath_init(Tcl_Interp *interp)
1113 {
1114 Tcl_CreateObjCommand(interp, "::tcl::kitpath", rubytk_kitpathObjCmd, 0, 0);
1115 if (Tcl_LinkVar(interp, "::tcl::kitpath", (char *) &rubytk_kitpath,
1116 TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) {
1117 Tcl_ResetResult(interp);
1118 }
1119
1120 Tcl_CreateObjCommand(interp, "::tcl::rubytk_kitpath", rubytk_kitpathObjCmd, 0, 0);
1121 if (Tcl_LinkVar(interp, "::tcl::rubytk_kitpath", (char *) &rubytk_kitpath,
1122 TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) {
1123 Tcl_ResetResult(interp);
1124 }
1125
1126 if (rubytk_kitpath == NULL) {
1127 /*
1128 * XXX: We may want to avoid doing this to allow tcl::kitpath calls
1129 * XXX: to obtain changes in nameofexe, if they occur.
1130 */
1131 set_rubytk_kitpath(Tcl_GetNameOfExecutable());
1132 }
1133
1134 return Tcl_PkgProvide(interp, "rubytk_kitpath", "1.0");
1135 }
1136
1137 /*--------------------------------------------------------*/
1138
1139 static void
1140 init_static_tcltk_packages()
1141 {
1142 /*
1143 * Ensure that std channels exist (creating them if necessary)
1144 */
1145 check_tclkit_std_channels();
1146
1147 #ifdef KIT_INCLUDES_ITCL
1148 Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL);
1149 #endif
1150 #ifdef KIT_LITE
1151 Tcl_StaticPackage(0, "Vlerq", Vlerq_Init, Vlerq_SafeInit);
1152 #else
1153 Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL);
1154 #endif
1155 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85
1156 Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL);
1157 #endif
1158 Tcl_StaticPackage(0, "rubytk_kitpath", rubytk_kitpath_init, NULL);
1159 Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL);
1160 Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL);
1161 #if KIT_INCLUDES_ZLIB
1162 Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL);
1163 #endif
1164 #if defined TCL_THREADS && defined KIT_INCLUDES_THREAD
1165 Tcl_StaticPackage(0, "Thread", Thread_Init, Thread_SafeInit);
1166 #endif
1167 #ifdef _WIN32
1168 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84
1169 Tcl_StaticPackage(0, "dde", Dde_Init, Dde_SafeInit);
1170 #else
1171 Tcl_StaticPackage(0, "dde", Dde_Init, NULL);
1172 #endif
1173 Tcl_StaticPackage(0, "registry", Registry_Init, NULL);
1174 #endif
1175 #ifdef KIT_INCLUDES_TK
1176 Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit);
1177 #endif
1178 }
1179
1180 /*--------------------------------------------------------*/
1181
1182 static int
1183 call_tclkit_init_script(Tcl_Interp *interp)
1184 {
1185 #if 0
1186 /* Currently, do nothing in this function.
1187 It's a memo (quoted from kitInit.c of Tclkit)
1188 to support an initScript for Tcl interpreters in the future. */
1189 if (Tcl_EvalEx(interp, initScript, -1, TCL_EVAL_GLOBAL) == TCL_OK) {
1190 const char *encoding = NULL;
1191 Tcl_Obj* path = Tcl_GetStartupScript(&encoding);
1192 Tcl_SetStartupScript(Tcl_GetObjResult(interp), encoding);
1193 if (path == NULL) {
1194 Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]");
1195 }
1196 }
1197 #endif
1198
1199 return 1;
1200 }
1201
1202 /*--------------------------------------------------------*/
1203
1204 #ifdef __WIN32__
1205 /* #include <tkWinInt.h> *//* conflict definition of struct timezone */
1206 /* #include <tkIntPlatDecls.h> */
1207 /* #include <windows.h> */
1208 EXTERN void TkWinSetHINSTANCE(HINSTANCE hInstance);
1209 void rbtk_win32_SetHINSTANCE(const char *module_name)
1210 {
1211 /* TCHAR szBuf[256]; */
1212 HINSTANCE hInst;
1213
1214 /* hInst = GetModuleHandle(NULL); */
1215 /* hInst = GetModuleHandle("tcltklib.so"); */
1216 hInst = GetModuleHandle(module_name);
1217 TkWinSetHINSTANCE(hInst);
1218
1219 /* GetModuleFileName(hInst, szBuf, sizeof(szBuf) / sizeof(TCHAR)); */
1220 /* MessageBox(NULL, szBuf, TEXT("OK"), MB_OK); */
1221 }
1222 #endif
1223
1224 /*--------------------------------------------------------*/
1225
1226 static void
1227 setup_rubytkkit()
1228 {
1229 init_static_tcltk_packages();
1230
1231 {
1232 ID const_id;
1233 const_id = rb_intern(RUBYTK_KITPATH_CONST_NAME);
1234
1235 if (rb_const_defined(rb_cObject, const_id)) {
1236 volatile VALUE pathobj;
1237 pathobj = rb_const_get(rb_cObject, const_id);
1238
1239 if (rb_obj_is_kind_of(pathobj, rb_cString)) {
1240 #ifdef HAVE_RUBY_ENCODING_H
1241 pathobj = rb_str_export_to_enc(pathobj, rb_utf8_encoding());
1242 #endif
1243 set_rubytk_kitpath(RSTRING_PTR(pathobj));
1244 }
1245 }
1246 }
1247
1248 #ifdef CREATE_RUBYTK_KIT
1249 if (rubytk_kitpath == NULL) {
1250 #ifdef __WIN32__
1251 /* rbtk_win32_SetHINSTANCE("tcltklib.so"); */
1252 {
1253 volatile VALUE basename;
1254 basename = rb_funcall(rb_cFile, rb_intern("basename"), 1,
1255 rb_str_new2(rb_sourcefile()));
1256 rbtk_win32_SetHINSTANCE(RSTRING_PTR(basename));
1257 }
1258 #endif
1259 set_rubytk_kitpath(rb_sourcefile());
1260 }
1261 #endif
1262
1263 if (rubytk_kitpath == NULL) {
1264 set_rubytk_kitpath(Tcl_GetNameOfExecutable());
1265 }
1266
1267 TclSetPreInitScript(rubytkkit_preInitCmd);
1268 }
1269
1270 /*--------------------------------------------------------*/
1271
1272 #endif /* defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT */
1273 /*####################################################################*/
1274
1275
1276 /**********************************************************************/
1277
1278 /* stub status */
1279 static void
1280 tcl_stubs_check()
1281 {
1282 if (!tcl_stubs_init_p()) {
1283 int st = ruby_tcl_stubs_init();
1284 switch(st) {
1285 case TCLTK_STUBS_OK:
1286 break;
1287 case NO_TCL_DLL:
1288 rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll");
1289 case NO_FindExecutable:
1290 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable");
1291 case NO_CreateInterp:
1292 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()");
1293 case NO_DeleteInterp:
1294 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()");
1295 case FAIL_CreateInterp:
1296 rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP to call Tcl_InitStubs()");
1297 case FAIL_Tcl_InitStubs:
1298 rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()");
1299 default:
1300 rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_stubs_init()", st);
1301 }
1302 }
1303 }
1304
1305
1306 static VALUE
1307 tcltkip_init_tk(interp)
1308 VALUE interp;
1309 {
1310 struct tcltkip *ptr = get_ip(interp);
1311
1312 #if TCL_MAJOR_VERSION >= 8
1313 int st;
1314
1315 if (Tcl_IsSafe(ptr->ip)) {
1316 DUMP1("Tk_SafeInit");
1317 st = ruby_tk_stubs_safeinit(ptr->ip);
1318 switch(st) {
1319 case TCLTK_STUBS_OK:
1320 break;
1321 case NO_Tk_Init:
1322 return rb_exc_new2(rb_eLoadError,
1323 "tcltklib: can't find Tk_SafeInit()");
1324 case FAIL_Tk_Init:
1325 return create_ip_exc(interp, rb_eRuntimeError,
1326 "tcltklib: fail to Tk_SafeInit(). %s",
1327 Tcl_GetStringResult(ptr->ip));
1328 case FAIL_Tk_InitStubs:
1329 return create_ip_exc(interp, rb_eRuntimeError,
1330 "tcltklib: fail to Tk_InitStubs(). %s",
1331 Tcl_GetStringResult(ptr->ip));
1332 default:
1333 return create_ip_exc(interp, rb_eRuntimeError,
1334 "tcltklib: unknown error(%d) on ruby_tk_stubs_safeinit", st);
1335 }
1336 } else {
1337 DUMP1("Tk_Init");
1338 st = ruby_tk_stubs_init(ptr->ip);
1339 switch(st) {
1340 case TCLTK_STUBS_OK:
1341 break;
1342 case NO_Tk_Init:
1343 return rb_exc_new2(rb_eLoadError,
1344 "tcltklib: can't find Tk_Init()");
1345 case FAIL_Tk_Init:
1346 return create_ip_exc(interp, rb_eRuntimeError,
1347 "tcltklib: fail to Tk_Init(). %s",
1348 Tcl_GetStringResult(ptr->ip));
1349 case FAIL_Tk_InitStubs:
1350 return create_ip_exc(interp, rb_eRuntimeError,
1351 "tcltklib: fail to Tk_InitStubs(). %s",
1352 Tcl_GetStringResult(ptr->ip));
1353 default:
1354 return create_ip_exc(interp, rb_eRuntimeError,
1355 "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st);
1356 }
1357 }
1358
1359 #else /* TCL_MAJOR_VERSION < 8 */
1360 DUMP1("Tk_Init");
1361 if (ruby_tk_stubs_init(ptr->ip) != TCLTK_STUBS_OK) {
1362 return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
1363 }
1364 #endif
1365
1366 #ifdef RUBY_USE_NATIVE_THREAD
1367 ptr->tk_thread_id = Tcl_GetCurrentThread();
1368 #endif
1369
1370 return Qnil;
1371 }
1372
1373
1374 /* treat excetiopn on Tcl side */
1375 static VALUE rbtk_pending_exception;
1376 static int rbtk_eventloop_depth = 0;
1377 static int rbtk_internal_eventloop_handler = 0;
1378
1379
1380 static int
1381 pending_exception_check0()
1382 {
1383 volatile VALUE exc = rbtk_pending_exception;
1384
1385 if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) {
1386 DUMP1("find a pending exception");
1387 if (rbtk_eventloop_depth > 0
1388 || rbtk_internal_eventloop_handler > 0
1389 ) {
1390 return 1; /* pending */
1391 } else {
1392 rbtk_pending_exception = Qnil;
1393
1394 if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) {
1395 DUMP1("pending_exception_check0: call rb_jump_tag(retry)");
1396 rb_jump_tag(TAG_RETRY);
1397 } else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) {
1398 DUMP1("pending_exception_check0: call rb_jump_tag(redo)");
1399 rb_jump_tag(TAG_REDO);
1400 } else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) {
1401 DUMP1("pending_exception_check0: call rb_jump_tag(throw)");
1402 rb_jump_tag(TAG_THROW);
1403 }
1404
1405 rb_exc_raise(exc);
1406 }
1407 } else {
1408 return 0;
1409 }
1410
1411 UNREACHABLE;
1412 }
1413
1414 static int
1415 pending_exception_check1(thr_crit_bup, ptr)
1416 int thr_crit_bup;
1417 struct tcltkip *ptr;
1418 {
1419 volatile VALUE exc = rbtk_pending_exception;
1420
1421 if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) {
1422 DUMP1("find a pending exception");
1423
1424 if (rbtk_eventloop_depth > 0
1425 || rbtk_internal_eventloop_handler > 0
1426 ) {
1427 return 1; /* pending */
1428 } else {
1429 rbtk_pending_exception = Qnil;
1430
1431 if (ptr != (struct tcltkip *)NULL) {
1432 /* Tcl_Release(ptr->ip); */
1433 rbtk_release_ip(ptr);
1434 }
1435
1436 rb_thread_critical = thr_crit_bup;
1437
1438 if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) {
1439 DUMP1("pending_exception_check1: call rb_jump_tag(retry)");
1440 rb_jump_tag(TAG_RETRY);
1441 } else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) {
1442 DUMP1("pending_exception_check1: call rb_jump_tag(redo)");
1443 rb_jump_tag(TAG_REDO);
1444 } else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) {
1445 DUMP1("pending_exception_check1: call rb_jump_tag(throw)");
1446 rb_jump_tag(TAG_THROW);
1447 }
1448 rb_exc_raise(exc);
1449 }
1450 } else {
1451 return 0;
1452 }
1453
1454 UNREACHABLE;
1455 }
1456
1457
1458 /* call original 'exit' command */
1459 static void
1460 call_original_exit(ptr, state)
1461 struct tcltkip *ptr;
1462 int state;
1463 {
1464 int thr_crit_bup;
1465 Tcl_CmdInfo *info;
1466 #if TCL_MAJOR_VERSION >= 8
1467 Tcl_Obj *cmd_obj;
1468 Tcl_Obj *state_obj;
1469 #endif
1470 DUMP1("original_exit is called");
1471
1472 if (!(ptr->has_orig_exit)) return;
1473
1474 thr_crit_bup = rb_thread_critical;
1475 rb_thread_critical = Qtrue;
1476
1477 Tcl_ResetResult(ptr->ip);
1478
1479 info = &(ptr->orig_exit_info);
1480
1481 /* memory allocation for arguments of this command */
1482 #if TCL_MAJOR_VERSION >= 8
1483 state_obj = Tcl_NewIntObj(state);
1484 Tcl_IncrRefCount(state_obj);
1485
1486 if (info->isNativeObjectProc) {
1487 Tcl_Obj **argv;
1488 #define USE_RUBY_ALLOC 0
1489 #if USE_RUBY_ALLOC
1490 argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3);
1491 #else /* not USE_RUBY_ALLOC */
1492 argv = RbTk_ALLOC_N(Tcl_Obj *, 3);
1493 #if 0 /* use Tcl_Preserve/Release */
1494 Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
1495 #endif
1496 #endif
1497 cmd_obj = Tcl_NewStringObj("exit", 4);
1498 Tcl_IncrRefCount(cmd_obj);
1499
1500 argv[0] = cmd_obj;
1501 argv[1] = state_obj;
1502 argv[2] = (Tcl_Obj *)NULL;
1503
1504 ptr->return_value
1505 = (*(info->objProc))(info->objClientData, ptr->ip, 2, argv);
1506
1507 Tcl_DecrRefCount(cmd_obj);
1508
1509 #if USE_RUBY_ALLOC
1510 xfree(argv);
1511 #else /* not USE_RUBY_ALLOC */
1512 #if 0 /* use Tcl_EventuallyFree */
1513 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
1514 #else
1515 #if 0 /* use Tcl_Preserve/Release */
1516 Tcl_Release((ClientData)argv); /* XXXXXXXX */
1517 #else
1518 /* free(argv); */
1519 ckfree((char*)argv);
1520 #endif
1521 #endif
1522 #endif
1523 #undef USE_RUBY_ALLOC
1524
1525 } else {
1526 /* string interface */
1527 CONST84 char **argv;
1528 #define USE_RUBY_ALLOC 0
1529 #if USE_RUBY_ALLOC
1530 argv = ALLOC_N(char *, 3); /* XXXXXXXXXX */
1531 #else /* not USE_RUBY_ALLOC */
1532 argv = RbTk_ALLOC_N(CONST84 char *, 3);
1533 #if 0 /* use Tcl_Preserve/Release */
1534 Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
1535 #endif
1536 #endif
1537 argv[0] = (char *)"exit";
1538 /* argv[1] = Tcl_GetString(state_obj); */
1539 argv[1] = Tcl_GetStringFromObj(state_obj, (int*)NULL);
1540 argv[2] = (char *)NULL;
1541
1542 ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, 2, argv);
1543
1544 #if USE_RUBY_ALLOC
1545 xfree(argv);
1546 #else /* not USE_RUBY_ALLOC */
1547 #if 0 /* use Tcl_EventuallyFree */
1548 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
1549 #else
1550 #if 0 /* use Tcl_Preserve/Release */
1551 Tcl_Release((ClientData)argv); /* XXXXXXXX */
1552 #else
1553 /* free(argv); */
1554 ckfree((char*)argv);
1555 #endif
1556 #endif
1557 #endif
1558 #undef USE_RUBY_ALLOC
1559 }
1560
1561 Tcl_DecrRefCount(state_obj);
1562
1563 #else /* TCL_MAJOR_VERSION < 8 */
1564 {
1565 /* string interface */
1566 char **argv;
1567 #define USE_RUBY_ALLOC 0
1568 #if USE_RUBY_ALLOC
1569 argv = (char **)ALLOC_N(char *, 3);
1570 #else /* not USE_RUBY_ALLOC */
1571 argv = RbTk_ALLOC_N(char *, 3);
1572 #if 0 /* use Tcl_Preserve/Release */
1573 Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
1574 #endif
1575 #endif
1576 argv[0] = "exit";
1577 argv[1] = RSTRING_PTR(rb_fix2str(INT2NUM(state), 10));
1578 argv[2] = (char *)NULL;
1579
1580 ptr->return_value = (*(info->proc))(info->clientData, ptr->ip,
1581 2, argv);
1582
1583 #if USE_RUBY_ALLOC
1584 xfree(argv);
1585 #else /* not USE_RUBY_ALLOC */
1586 #if 0 /* use Tcl_EventuallyFree */
1587 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
1588 #else
1589 #if 0 /* use Tcl_Preserve/Release */
1590 Tcl_Release((ClientData)argv); /* XXXXXXXX */
1591 #else
1592 /* free(argv); */
1593 ckfree(argv);
1594 #endif
1595 #endif
1596 #endif
1597 #undef USE_RUBY_ALLOC
1598 }
1599 #endif
1600 DUMP1("complete original_exit");
1601
1602 rb_thread_critical = thr_crit_bup;
1603 }
1604
1605 /* Tk_ThreadTimer */
1606 static Tcl_TimerToken timer_token = (Tcl_TimerToken)NULL;
1607
1608 /* timer callback */
1609 static void _timer_for_tcl _((ClientData));
1610 static void
1611 _timer_for_tcl(clientData)
1612 ClientData clientData;
1613 {
1614 int thr_crit_bup;
1615
1616 /* struct invoke_queue *q, *tmp; */
1617 /* VALUE thread; */
1618
1619 DUMP1("call _timer_for_tcl");
1620
1621 thr_crit_bup = rb_thread_critical;
1622 rb_thread_critical = Qtrue;
1623
1624 Tcl_DeleteTimerHandler(timer_token);
1625
1626 run_timer_flag = 1;
1627
1628 if (timer_tick > 0) {
1629 timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl,
1630 (ClientData)0);
1631 } else {
1632 timer_token = (Tcl_TimerToken)NULL;
1633 }
1634
1635 rb_thread_critical = thr_crit_bup;
1636
1637 /* rb_thread_schedule(); */
1638 /* tick_counter += event_loop_max; */
1639 }
1640
1641 #ifdef RUBY_USE_NATIVE_THREAD
1642 #if USE_TOGGLE_WINDOW_MODE_FOR_IDLE
1643 static int
1644 toggle_eventloop_window_mode_for_idle()
1645 {
1646 if (window_event_mode & TCL_IDLE_EVENTS) {
1647 /* idle -> event */
1648 window_event_mode |= TCL_WINDOW_EVENTS;
1649 window_event_mode &= ~TCL_IDLE_EVENTS;
1650 return 1;
1651 } else {
1652 /* event -> idle */
1653 window_event_mode |= TCL_IDLE_EVENTS;
1654 window_event_mode &= ~TCL_WINDOW_EVENTS;
1655 return 0;
1656 }
1657 }
1658 #endif
1659 #endif
1660
1661 static VALUE
1662 set_eventloop_window_mode(self, mode)
1663 VALUE self;
1664 VALUE mode;
1665 {
1666 rb_secure(4);
1667
1668 if (RTEST(mode)) {
1669 window_event_mode = ~0;
1670 } else {
1671 window_event_mode = ~TCL_WINDOW_EVENTS;
1672 }
1673
1674 return mode;
1675 }
1676
1677 static VALUE
1678 get_eventloop_window_mode(self)
1679 VALUE self;
1680 {
1681 if ( ~window_event_mode ) {
1682 return Qfalse;
1683 } else {
1684 return Qtrue;
1685 }
1686 }
1687
1688 static VALUE
1689 set_eventloop_tick(self, tick)
1690 VALUE self;
1691 VALUE tick;
1692 {
1693 int ttick = NUM2INT(tick);
1694 int thr_crit_bup;
1695
1696 rb_secure(4);
1697
1698 if (ttick < 0) {
1699 rb_raise(rb_eArgError,
1700 "timer-tick parameter must be 0 or positive number");
1701 }
1702
1703 thr_crit_bup = rb_thread_critical;
1704 rb_thread_critical = Qtrue;
1705
1706 /* delete old timer callback */
1707 Tcl_DeleteTimerHandler(timer_token);
1708
1709 timer_tick = req_timer_tick = ttick;
1710 if (timer_tick > 0) {
1711 /* start timer callback */
1712 timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl,
1713 (ClientData)0);
1714 } else {
1715 timer_token = (Tcl_TimerToken)NULL;
1716 }
1717
1718 rb_thread_critical = thr_crit_bup;
1719
1720 return tick;
1721 }
1722
1723 static VALUE
1724 get_eventloop_tick(self)
1725 VALUE self;
1726 {
1727 return INT2NUM(timer_tick);
1728 }
1729
1730 static VALUE
1731 ip_set_eventloop_tick(self, tick)
1732 VALUE self;
1733 VALUE tick;
1734 {
1735 struct tcltkip *ptr = get_ip(self);
1736
1737 /* ip is deleted? */
1738 if (deleted_ip(ptr)) {
1739 return get_eventloop_tick(self);
1740 }
1741
1742 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
1743 /* slave IP */
1744 return get_eventloop_tick(self);
1745 }
1746 return set_eventloop_tick(self, tick);
1747 }
1748
1749 static VALUE
1750 ip_get_eventloop_tick(self)
1751 VALUE self;
1752 {
1753 return get_eventloop_tick(self);
1754 }
1755
1756 static VALUE
1757 set_no_event_wait(self, wait)
1758 VALUE self;
1759 VALUE wait;
1760 {
1761 int t_wait = NUM2INT(wait);
1762
1763 rb_secure(4);
1764
1765 if (t_wait <= 0) {
1766 rb_raise(rb_eArgError,
1767 "no_event_wait parameter must be positive number");
1768 }
1769
1770 no_event_wait = t_wait;
1771
1772 return wait;
1773 }
1774
1775 static VALUE
1776 get_no_event_wait(self)
1777 VALUE self;
1778 {
1779 return INT2NUM(no_event_wait);
1780 }
1781
1782 static VALUE
1783 ip_set_no_event_wait(self, wait)
1784 VALUE self;
1785 VALUE wait;
1786 {
1787 struct tcltkip *ptr = get_ip(self);
1788
1789 /* ip is deleted? */
1790 if (deleted_ip(ptr)) {
1791 return get_no_event_wait(self);
1792 }
1793
1794 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
1795 /* slave IP */
1796 return get_no_event_wait(self);
1797 }
1798 return set_no_event_wait(self, wait);
1799 }
1800
1801 static VALUE
1802 ip_get_no_event_wait(self)
1803 VALUE self;
1804 {
1805 return get_no_event_wait(self);
1806 }
1807
1808 static VALUE
1809 set_eventloop_weight(self, loop_max, no_event)
1810 VALUE self;
1811 VALUE loop_max;
1812 VALUE no_event;
1813 {
1814 int lpmax = NUM2INT(loop_max);
1815 int no_ev = NUM2INT(no_event);
1816
1817 rb_secure(4);
1818
1819 if (lpmax <= 0 || no_ev <= 0) {
1820 rb_raise(rb_eArgError, "weight parameters must be positive numbers");
1821 }
1822
1823 event_loop_max = lpmax;
1824 no_event_tick = no_ev;
1825
1826 return rb_ary_new3(2, loop_max, no_event);
1827 }
1828
1829 static VALUE
1830 get_eventloop_weight(self)
1831 VALUE self;
1832 {
1833 return rb_ary_new3(2, INT2NUM(event_loop_max), INT2NUM(no_event_tick));
1834 }
1835
1836 static VALUE
1837 ip_set_eventloop_weight(self, loop_max, no_event)
1838 VALUE self;
1839 VALUE loop_max;
1840 VALUE no_event;
1841 {
1842 struct tcltkip *ptr = get_ip(self);
1843
1844 /* ip is deleted? */
1845 if (deleted_ip(ptr)) {
1846 return get_eventloop_weight(self);
1847 }
1848
1849 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
1850 /* slave IP */
1851 return get_eventloop_weight(self);
1852 }
1853 return set_eventloop_weight(self, loop_max, no_event);
1854 }
1855
1856 static VALUE
1857 ip_get_eventloop_weight(self)
1858 VALUE self;
1859 {
1860 return get_eventloop_weight(self);
1861 }
1862
1863 static VALUE
1864 set_max_block_time(self, time)
1865 VALUE self;
1866 VALUE time;
1867 {
1868 struct Tcl_Time tcl_time;
1869 VALUE divmod;
1870
1871 switch(TYPE(time)) {
1872 case T_FIXNUM:
1873 case T_BIGNUM:
1874 /* time is micro-second value */
1875 divmod = rb_funcall(time, rb_intern("divmod"), 1, LONG2NUM(1000000));
1876 tcl_time.sec = NUM2LONG(RARRAY_PTR(divmod)[0]);
1877 tcl_time.usec = NUM2LONG(RARRAY_PTR(divmod)[1]);
1878 break;
1879
1880 case T_FLOAT:
1881 /* time is second value */
1882 divmod = rb_funcall(time, rb_intern("divmod"), 1, INT2FIX(1));
1883 tcl_time.sec = NUM2LONG(RARRAY_PTR(divmod)[0]);
1884 tcl_time.usec = (long)(NUM2DBL(RARRAY_PTR(divmod)[1]) * 1000000);
1885
1886 default:
1887 {
1888 VALUE tmp = rb_funcall(time, ID_inspect, 0, 0);
1889 rb_raise(rb_eArgError, "invalid value for time: '%s'",
1890 StringValuePtr(tmp));
1891 }
1892 }
1893
1894 Tcl_SetMaxBlockTime(&tcl_time);
1895
1896 return Qnil;
1897 }
1898
1899 static VALUE
1900 lib_evloop_thread_p(self)
1901 VALUE self;
1902 {
1903 if (NIL_P(eventloop_thread)) {
1904 return Qnil; /* no eventloop */
1905 } else if (rb_thread_current() == eventloop_thread) {
1906 return Qtrue; /* is eventloop */
1907 } else {
1908 return Qfalse; /* not eventloop */
1909 }
1910 }
1911
1912 static VALUE
1913 lib_evloop_abort_on_exc(self)
1914 VALUE self;
1915 {
1916 if (event_loop_abort_on_exc > 0) {
1917 return Qtrue;
1918 } else if (event_loop_abort_on_exc == 0) {
1919 return Qfalse;
1920 } else {
1921 return Qnil;
1922 }
1923 }
1924
1925 static VALUE
1926 ip_evloop_abort_on_exc(self)
1927 VALUE self;
1928 {
1929 return lib_evloop_abort_on_exc(self);
1930 }
1931
1932 static VALUE
1933 lib_evloop_abort_on_exc_set(self, val)
1934 VALUE self, val;
1935 {
1936 rb_secure(4);
1937 if (RTEST(val)) {
1938 event_loop_abort_on_exc = 1;
1939 } else if (NIL_P(val)) {
1940 event_loop_abort_on_exc = -1;
1941 } else {
1942 event_loop_abort_on_exc = 0;
1943 }
1944 return lib_evloop_abort_on_exc(self);
1945 }
1946
1947 static VALUE
1948 ip_evloop_abort_on_exc_set(self, val)
1949 VALUE self, val;
1950 {
1951 struct tcltkip *ptr = get_ip(self);
1952
1953 rb_secure(4);
1954
1955 /* ip is deleted? */
1956 if (deleted_ip(ptr)) {
1957 return lib_evloop_abort_on_exc(self);
1958 }
1959
1960 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
1961 /* slave IP */
1962 return lib_evloop_abort_on_exc(self);
1963 }
1964 return lib_evloop_abort_on_exc_set(self, val);
1965 }
1966
1967 static VALUE
1968 lib_num_of_mainwindows_core(self, argc, argv)
1969 VALUE self;
1970 int argc; /* dummy */
1971 VALUE *argv; /* dummy */
1972 {
1973 if (tk_stubs_init_p()) {
1974 return INT2FIX(Tk_GetNumMainWindows());
1975 } else {
1976 return INT2FIX(0);
1977 }
1978 }
1979
1980 static VALUE
1981 lib_num_of_mainwindows(self)
1982 VALUE self;
1983 {
1984 #ifdef RUBY_USE_NATIVE_THREAD /* Ruby 1.9+ !!! */
1985 return tk_funcall(lib_num_of_mainwindows_core, 0, (VALUE*)NULL, self);
1986 #else
1987 return lib_num_of_mainwindows_core(self, 0, (VALUE*)NULL);
1988 #endif
1989 }
1990
1991 void
1992 rbtk_EventSetupProc(ClientData clientData, int flag)
1993 {
1994 Tcl_Time tcl_time;
1995 tcl_time.sec = 0;
1996 tcl_time.usec = 1000L * (long)no_event_tick;
1997 Tcl_SetMaxBlockTime(&tcl_time);
1998 }
1999
2000 void
2001 rbtk_EventCheckProc(ClientData clientData, int flag)
2002 {
2003 rb_thread_schedule();
2004 }
2005
2006
2007 #ifdef RUBY_USE_NATIVE_THREAD /* Ruby 1.9+ !!! */
2008 static VALUE
2009 #ifdef HAVE_PROTOTYPES
2010 call_DoOneEvent_core(VALUE flag_val)
2011 #else
2012 call_DoOneEvent_core(flag_val)
2013 VALUE flag_val;
2014 #endif
2015 {
2016 int flag;
2017
2018 flag = FIX2INT(flag_val);
2019 if (Tcl_DoOneEvent(flag)) {
2020 return Qtrue;
2021 } else {
2022 return Qfalse;
2023 }
2024 }
2025
2026 static VALUE
2027 #ifdef HAVE_PROTOTYPES
2028 call_DoOneEvent(VALUE flag_val)
2029 #else
2030 call_DoOneEvent(flag_val)
2031 VALUE flag_val;
2032 #endif
2033 {
2034 return tk_funcall(call_DoOneEvent_core, 0, (VALUE*)NULL, flag_val);
2035 }
2036
2037 #else /* Ruby 1.8- */
2038 static VALUE
2039 #ifdef HAVE_PROTOTYPES
2040 call_DoOneEvent(VALUE flag_val)
2041 #else
2042 call_DoOneEvent(flag_val)
2043 VALUE flag_val;
2044 #endif
2045 {
2046 int flag;
2047
2048 flag = FIX2INT(flag_val);
2049 if (Tcl_DoOneEvent(flag)) {
2050 return Qtrue;
2051 } else {
2052 return Qfalse;
2053 }
2054 }
2055 #endif
2056
2057
2058 #if 0
2059 static VALUE
2060 #ifdef HAVE_PROTOTYPES
2061 eventloop_sleep(VALUE dummy)
2062 #else
2063 eventloop_sleep(dummy)
2064 VALUE dummy;
2065 #endif
2066 {
2067 struct timeval t;
2068
2069 if (no_event_wait <= 0) {
2070 return Qnil;
2071 }
2072
2073 t.tv_sec = 0;
2074 t.tv_usec = (int)(no_event_wait*1000.0);
2075
2076 #ifdef HAVE_NATIVETHREAD
2077 #ifndef RUBY_USE_NATIVE_THREAD
2078 if (!ruby_native_thread_p()) {
2079 rb_bug("cross-thread violation on eventloop_sleep()");
2080 }
2081 #endif
2082 #endif
2083
2084 DUMP2("eventloop_sleep: rb_thread_wait_for() at thread : %lx", rb_thread_current());
2085 rb_thread_wait_for(t);
2086 DUMP2("eventloop_sleep: finish at thread : %lx", rb_thread_current());
2087
2088 #ifdef HAVE_NATIVETHREAD
2089 #ifndef RUBY_USE_NATIVE_THREAD
2090 if (!ruby_native_thread_p()) {
2091 rb_bug("cross-thread violation on eventloop_sleep()");
2092 }
2093 #endif
2094 #endif
2095
2096 return Qnil;
2097 }
2098 #endif
2099
2100 #define USE_EVLOOP_THREAD_ALONE_CHECK_FLAG 0
2101
2102 #if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
2103 static int
2104 get_thread_alone_check_flag()
2105 {
2106 #ifdef RUBY_USE_NATIVE_THREAD
2107 return 0;
2108 #else
2109 set_tcltk_version();
2110
2111 if (tcltk_version.major < 8) {
2112 /* Tcl/Tk 7.x */
2113 return 1;
2114 } else if (tcltk_version.major == 8) {
2115 if (tcltk_version.minor < 5) {
2116 /* Tcl/Tk 8.0 - 8.4 */
2117 return 1;
2118 } else if (tcltk_version.minor == 5) {
2119 if (tcltk_version.type < TCL_FINAL_RELEASE) {
2120 /* Tcl/Tk 8.5a? - 8.5b? */
2121 return 1;
2122 } else {
2123 /* Tcl/Tk 8.5.x */
2124 return 0;
2125 }
2126 } else {
2127 /* Tcl/Tk 8.6 - 8.9 ?? */
2128 return 0;
2129 }
2130 } else {
2131 /* Tcl/Tk 9+ ?? */
2132 return 0;
2133 }
2134 #endif
2135 }
2136 #endif
2137
2138 #define TRAP_CHECK() do { \
2139 if (trap_check(check_var) == 0) return 0; \
2140 } while (0)
2141
2142 static int
2143 trap_check(int *check_var)
2144 {
2145 DUMP1("trap check");
2146
2147 #ifdef RUBY_VM
2148 if (rb_thread_check_trap_pending()) {
2149 if (check_var != (int*)NULL) {
2150 /* wait command */
2151 return 0;
2152 }
2153 else {
2154 rb_thread_check_ints();
2155 }
2156 }
2157 #else
2158 if (rb_trap_pending) {
2159 run_timer_flag = 0;
2160 if (rb_prohibit_interrupt || check_var != (int*)NULL) {
2161 /* pending or on wait command */
2162 return 0;
2163 } else {
2164 rb_trap_exec();
2165 }
2166 }
2167 #endif
2168
2169 return 1;
2170 }
2171
2172 static int
2173 check_eventloop_interp()
2174 {
2175 DUMP1("check eventloop_interp");
2176 if (eventloop_interp != (Tcl_Interp*)NULL
2177 && Tcl_InterpDeleted(eventloop_interp)) {
2178 DUMP2("eventloop_interp(%p) was deleted", eventloop_interp);
2179 return 1;
2180 }
2181
2182 return 0;
2183 }
2184
2185 static int
2186 lib_eventloop_core(check_root, update_flag, check_var, interp)
2187 int check_root;
2188 int update_flag;
2189 int *check_var;
2190 Tcl_Interp *interp;
2191 {
2192 volatile VALUE current = eventloop_thread;
2193 int found_event = 1;
2194 int event_flag;
2195 struct timeval t;
2196 int thr_crit_bup;
2197 int status;
2198 int depth = rbtk_eventloop_depth;
2199 #if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
2200 int thread_alone_check_flag = 1;
2201 #endif
2202
2203 if (update_flag) DUMP1("update loop start!!");
2204
2205 t.tv_sec = 0;
2206 t.tv_usec = 1000 * no_event_wait;
2207
2208 Tcl_DeleteTimerHandler(timer_token);
2209 run_timer_flag = 0;
2210 if (timer_tick > 0) {
2211 thr_crit_bup = rb_thread_critical;
2212 rb_thread_critical = Qtrue;
2213 timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl,
2214 (ClientData)0);
2215 rb_thread_critical = thr_crit_bup;
2216 } else {
2217 timer_token = (Tcl_TimerToken)NULL;
2218 }
2219
2220 #if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
2221 /* version check */
2222 thread_alone_check_flag = get_thread_alone_check_flag();
2223 #endif
2224
2225 for(;;) {
2226 if (check_eventloop_interp()) return 0;
2227
2228 #if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
2229 if (thread_alone_check_flag && rb_thread_alone()) {
2230 #else
2231 if (rb_thread_alone()) {
2232 #endif
2233 DUMP1("no other thread");
2234 event_loop_wait_event = 0;
2235
2236 if (update_flag) {
2237 event_flag = update_flag;
2238 /* event_flag = update_flag | TCL_DONT_WAIT; */ /* for safety */
2239 } else {
2240 event_flag = TCL_ALL_EVENTS;
2241 /* event_flag = TCL_ALL_EVENTS | TCL_DONT_WAIT; */
2242 }
2243
2244 if (timer_tick == 0 && update_flag == 0) {
2245 timer_tick = NO_THREAD_INTERRUPT_TIME;
2246 timer_token = Tcl_CreateTimerHandler(timer_tick,
2247 _timer_for_tcl,
2248 (ClientData)0);
2249 }
2250
2251 if (check_var != (int *)NULL) {
2252 if (*check_var || !found_event) {
2253 return found_event;
2254 }
2255 if (interp != (Tcl_Interp*)NULL
2256 && Tcl_InterpDeleted(interp)) {
2257 /* IP for check_var is deleted */
2258 return 0;
2259 }
2260 }
2261
2262 /* found_event = Tcl_DoOneEvent(event_flag); */
2263 found_event = RTEST(rb_protect(call_DoOneEvent,
2264 INT2FIX(event_flag), &status));
2265 if (status) {
2266 switch (status) {
2267 case TAG_RAISE:
2268 if (NIL_P(rb_errinfo())) {
2269 rbtk_pending_exception
2270 = rb_exc_new2(rb_eException, "unknown exception");
2271 } else {
2272 rbtk_pending_exception = rb_errinfo();
2273
2274 if (!NIL_P(rbtk_pending_exception)) {
2275 if (rbtk_eventloop_depth == 0) {
2276 VALUE exc = rbtk_pending_exception;
2277 rbtk_pending_exception = Qnil;
2278 rb_exc_raise(exc);
2279 } else {
2280 return 0;
2281 }
2282 }
2283 }
2284 break;
2285
2286 case TAG_FATAL:
2287 if (NIL_P(rb_errinfo())) {
2288 rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL"));
2289 } else {
2290 rb_exc_raise(rb_errinfo());
2291 }
2292 }
2293 }
2294
2295 if (depth != rbtk_eventloop_depth) {
2296 DUMP2("DoOneEvent(1) abnormal exit!! %d",
2297 rbtk_eventloop_depth);
2298 }
2299
2300 if (check_var != (int*)NULL && !NIL_P(rbtk_pending_exception)) {
2301 DUMP1("exception on wait");
2302 return 0;
2303 }
2304
2305 if (pending_exception_check0()) {
2306 /* pending -> upper level */
2307 return 0;
2308 }
2309
2310 if (update_flag != 0) {
2311 if (found_event) {
2312 DUMP1("next update loop");
2313 continue;
2314 } else {
2315 DUMP1("update complete");
2316 return 0;
2317 }
2318 }
2319
2320 TRAP_CHECK();
2321 if (check_eventloop_interp()) return 0;
2322
2323 DUMP1("check Root Widget");
2324 if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) {
2325 run_timer_flag = 0;
2326 TRAP_CHECK();
2327 return 1;
2328 }
2329
2330 if (loop_counter++ > 30000) {
2331 /* fprintf(stderr, "loop_counter > 30000\n"); */
2332 loop_counter = 0;
2333 }
2334
2335 } else {
2336 int tick_counter;
2337
2338 DUMP1("there are other threads");
2339 event_loop_wait_event = 1;
2340
2341 found_event = 1;
2342
2343 if (update_flag) {
2344 event_flag = update_flag; /* for safety */
2345 /* event_flag = update_flag | TCL_DONT_WAIT; */ /* for safety */
2346 } else {
2347 event_flag = TCL_ALL_EVENTS;
2348 /* event_flag = TCL_ALL_EVENTS | TCL_DONT_WAIT; */
2349 }
2350
2351 timer_tick = req_timer_tick;
2352 tick_counter = 0;
2353 while(tick_counter < event_loop_max) {
2354 if (check_var != (int *)NULL) {
2355 if (*check_var || !found_event) {
2356 return found_event;
2357 }
2358 if (interp != (Tcl_Interp*)NULL
2359 && Tcl_InterpDeleted(interp)) {
2360 /* IP for check_var is deleted */
2361 return 0;
2362 }
2363 }
2364
2365 if (NIL_P(eventloop_thread) || current == eventloop_thread) {
2366 int st;
2367 int status;
2368
2369 #ifdef RUBY_USE_NATIVE_THREAD
2370 if (update_flag) {
2371 st = RTEST(rb_protect(call_DoOneEvent,
2372 INT2FIX(event_flag), &status));
2373 } else {
2374 st = RTEST(rb_protect(call_DoOneEvent,
2375 INT2FIX(event_flag & window_event_mode),
2376 &status));
2377 #if USE_TOGGLE_WINDOW_MODE_FOR_IDLE
2378 if (!st) {
2379 if (toggle_eventloop_window_mode_for_idle()) {
2380 /* idle-mode -> event-mode*/
2381 tick_counter = event_loop_max;
2382 } else {
2383 /* event-mode -> idle-mode */
2384 tick_counter = 0;
2385 }
2386 }
2387 #endif
2388 }
2389 #else
2390 /* st = Tcl_DoOneEvent(event_flag); */
2391 st = RTEST(rb_protect(call_DoOneEvent,
2392 INT2FIX(event_flag), &status));
2393 #endif
2394
2395 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
2396 if (have_rb_thread_waiting_for_value) {
2397 have_rb_thread_waiting_for_value = 0;
2398 rb_thread_schedule();
2399 }
2400 #endif
2401
2402 if (status) {
2403 switch (status) {
2404 case TAG_RAISE:
2405 if (NIL_P(rb_errinfo())) {
2406 rbtk_pending_exception
2407 = rb_exc_new2(rb_eException,
2408 "unknown exception");
2409 } else {
2410 rbtk_pending_exception = rb_errinfo();
2411
2412 if (!NIL_P(rbtk_pending_exception)) {
2413 if (rbtk_eventloop_depth == 0) {
2414 VALUE exc = rbtk_pending_exception;
2415 rbtk_pending_exception = Qnil;
2416 rb_exc_raise(exc);
2417 } else {
2418 return 0;
2419 }
2420 }
2421 }
2422 break;
2423
2424 case TAG_FATAL:
2425 if (NIL_P(rb_errinfo())) {
2426 rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL"));
2427 } else {
2428 rb_exc_raise(rb_errinfo());
2429 }
2430 }
2431 }
2432
2433 if (depth != rbtk_eventloop_depth) {
2434 DUMP2("DoOneEvent(2) abnormal exit!! %d",
2435 rbtk_eventloop_depth);
2436 return 0;
2437 }
2438
2439 TRAP_CHECK();
2440
2441 if (check_var != (int*)NULL
2442 && !NIL_P(rbtk_pending_exception)) {
2443 DUMP1("exception on wait");
2444 return 0;
2445 }
2446
2447 if (pending_exception_check0()) {
2448 /* pending -> upper level */
2449 return 0;
2450 }
2451
2452 if (st) {
2453 tick_counter++;
2454 } else {
2455 if (update_flag != 0) {
2456 DUMP1("update complete");
2457 return 0;
2458 }
2459
2460 tick_counter += no_event_tick;
2461
2462 #if 0
2463 /* rb_thread_wait_for(t); */
2464 rb_protect(eventloop_sleep, Qnil, &status);
2465
2466 if (status) {
2467 switch (status) {
2468 case TAG_RAISE:
2469 if (NIL_P(rb_errinfo())) {
2470 rbtk_pending_exception
2471 = rb_exc_new2(rb_eException,
2472 "unknown exception");
2473 } else {
2474 rbtk_pending_exception = rb_errinfo();
2475
2476 if (!NIL_P(rbtk_pending_exception)) {
2477 if (rbtk_eventloop_depth == 0) {
2478 VALUE exc = rbtk_pending_exception;
2479 rbtk_pending_exception = Qnil;
2480 rb_exc_raise(exc);
2481 } else {
2482 return 0;
2483 }
2484 }
2485 }
2486 break;
2487
2488 case TAG_FATAL:
2489 if (NIL_P(rb_errinfo())) {
2490 rb_exc_raise(rb_exc_new2(rb_eFatal,
2491 "FATAL"));
2492 } else {
2493 rb_exc_raise(rb_errinfo());
2494 }
2495 }
2496 }
2497 #endif
2498 }
2499
2500 } else {
2501 DUMP2("sleep eventloop %lx", current);
2502 DUMP2("eventloop thread is %lx", eventloop_thread);
2503 /* rb_thread_stop(); */
2504 rb_thread_sleep_forever();
2505 }
2506
2507 if (!NIL_P(watchdog_thread) && eventloop_thread != current) {
2508 return 1;
2509 }
2510
2511 TRAP_CHECK();
2512 if (check_eventloop_interp()) return 0;
2513
2514 DUMP1("check Root Widget");
2515 if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) {
2516 run_timer_flag = 0;
2517 TRAP_CHECK();
2518 return 1;
2519 }
2520
2521 if (loop_counter++ > 30000) {
2522 /* fprintf(stderr, "loop_counter > 30000\n"); */
2523 loop_counter = 0;
2524 }
2525
2526 if (run_timer_flag) {
2527 /*
2528 DUMP1("timer interrupt");
2529 run_timer_flag = 0;
2530 */
2531 break; /* switch to other thread */
2532 }
2533 }
2534
2535 DUMP1("thread scheduling");
2536 rb_thread_schedule();
2537 }
2538
2539 DUMP1("check interrupts");
2540 #if defined(RUBY_USE_NATIVE_THREAD) || defined(RUBY_VM)
2541 if (update_flag == 0) rb_thread_check_ints();
2542 #else
2543 if (update_flag == 0) CHECK_INTS;
2544 #endif
2545
2546 }
2547 return 1;
2548 }
2549
2550
2551 struct evloop_params {
2552 int check_root;
2553 int update_flag;
2554 int *check_var;
2555 Tcl_Interp *interp;
2556 int thr_crit_bup;
2557 };
2558
2559 VALUE
2560 lib_eventloop_main_core(args)
2561 VALUE args;
2562 {
2563 struct evloop_params *params = (struct evloop_params *)args;
2564
2565 check_rootwidget_flag = params->check_root;
2566
2567 Tcl_CreateEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc, (ClientData)args);
2568
2569 if (lib_eventloop_core(params->check_root,
2570 params->update_flag,
2571 params->check_var,
2572 params->interp)) {
2573 return Qtrue;
2574 } else {
2575 return Qfalse;
2576 }
2577 }
2578
2579 VALUE
2580 lib_eventloop_main(args)
2581 VALUE args;
2582 {
2583 return lib_eventloop_main_core(args);
2584
2585 #if 0
2586 volatile VALUE ret;
2587 int status = 0;
2588
2589 ret = rb_protect(lib_eventloop_main_core, args, &status);
2590
2591 switch (status) {
2592 case TAG_RAISE:
2593 if (NIL_P(rb_errinfo())) {
2594 rbtk_pending_exception
2595 = rb_exc_new2(rb_eException, "unknown exception");
2596 } else {
2597 rbtk_pending_exception = rb_errinfo();
2598 }
2599 return Qnil;
2600
2601 case TAG_FATAL:
2602 if (NIL_P(rb_errinfo())) {
2603 rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
2604 } else {
2605 rbtk_pending_exception = rb_errinfo();
2606 }
2607 return Qnil;
2608 }
2609
2610 return ret;
2611 #endif
2612 }
2613
2614 VALUE
2615 lib_eventloop_ensure(args)
2616 VALUE args;
2617 {
2618 struct evloop_params *ptr = (struct evloop_params *)args;
2619 volatile VALUE current_evloop = rb_thread_current();
2620
2621 Tcl_DeleteEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc, (ClientData)args);
2622
2623 DUMP2("eventloop_ensure: current-thread : %lx", current_evloop);
2624 DUMP2("eventloop_ensure: eventloop-thread : %lx", eventloop_thread);
2625 if (eventloop_thread != current_evloop) {
2626 DUMP2("finish eventloop %lx (NOT current eventloop)", current_evloop);
2627
2628 rb_thread_critical = ptr->thr_crit_bup;
2629
2630 xfree(ptr);
2631 /* ckfree((char*)ptr); */
2632
2633 return Qnil;
2634 }
2635
2636 while((eventloop_thread = rb_ary_pop(eventloop_stack))) {
2637 DUMP2("eventloop-ensure: new eventloop-thread -> %lx",
2638 eventloop_thread);
2639
2640 if (eventloop_thread == current_evloop) {
2641 rbtk_eventloop_depth--;
2642 DUMP2("eventloop %lx : back from recursive call", current_evloop);
2643 break;
2644 }
2645
2646 if (NIL_P(eventloop_thread)) {
2647 Tcl_DeleteTimerHandler(timer_token);
2648 timer_token = (Tcl_TimerToken)NULL;
2649
2650 break;
2651 }
2652
2653 #ifdef RUBY_VM
2654 if (RTEST(rb_funcall(eventloop_thread, ID_alive_p, 0, 0))) {
2655 #else
2656 if (RTEST(rb_thread_alive_p(eventloop_thread))) {
2657 #endif
2658 DUMP2("eventloop-enshure: wake up parent %lx", eventloop_thread);
2659 rb_thread_wakeup(eventloop_thread);
2660
2661 break;
2662 }
2663 }
2664
2665 #ifdef RUBY_USE_NATIVE_THREAD
2666 if (NIL_P(eventloop_thread)) {
2667 tk_eventloop_thread_id = (Tcl_ThreadId) 0;
2668 }
2669 #endif
2670
2671 rb_thread_critical = ptr->thr_crit_bup;
2672
2673 xfree(ptr);
2674 /* ckfree((char*)ptr);*/
2675
2676 DUMP2("finish current eventloop %lx", current_evloop);
2677 return Qnil;
2678 }
2679
2680 static VALUE
2681 lib_eventloop_launcher(check_root, update_flag, check_var, interp)
2682 int check_root;
2683 int update_flag;
2684 int *check_var;
2685 Tcl_Interp *interp;
2686 {
2687 volatile VALUE parent_evloop = eventloop_thread;
2688 struct evloop_params *args = ALLOC(struct evloop_params);
2689 /* struct evloop_params *args = RbTk_ALLOC_N(struct evloop_params, 1); */
2690
2691 tcl_stubs_check();
2692
2693 eventloop_thread = rb_thread_current();
2694 #ifdef RUBY_USE_NATIVE_THREAD
2695 tk_eventloop_thread_id = Tcl_GetCurrentThread();
2696 #endif
2697
2698 if (parent_evloop == eventloop_thread) {
2699 DUMP2("eventloop: recursive call on %lx", parent_evloop);
2700 rbtk_eventloop_depth++;
2701 }
2702
2703 if (!NIL_P(parent_evloop) && parent_evloop != eventloop_thread) {
2704 DUMP2("wait for stop of parent_evloop %lx", parent_evloop);
2705 while(!RTEST(rb_funcall(parent_evloop, ID_stop_p, 0))) {
2706 DUMP2("parent_evloop %lx doesn't stop", parent_evloop);
2707 rb_thread_run(parent_evloop);
2708 }
2709 DUMP1("succeed to stop parent");
2710 }
2711
2712 rb_ary_push(eventloop_stack, parent_evloop);
2713
2714 DUMP3("tcltklib: eventloop-thread : %lx -> %lx\n",
2715 parent_evloop, eventloop_thread);
2716
2717 args->check_root = check_root;
2718 args->update_flag = update_flag;
2719 args->check_var = check_var;
2720 args->interp = interp;
2721 args->thr_crit_bup = rb_thread_critical;
2722
2723 rb_thread_critical = Qfalse;
2724
2725 #if 0
2726 return rb_ensure(lib_eventloop_main, (VALUE)args,
2727 lib_eventloop_ensure, (VALUE)args);
2728 #endif
2729 return rb_ensure(lib_eventloop_main_core, (VALUE)args,
2730 lib_eventloop_ensure, (VALUE)args);
2731 }
2732
2733 /* execute Tk_MainLoop */
2734 static VALUE
2735 lib_mainloop(argc, argv, self)
2736 int argc;
2737 VALUE *argv;
2738 VALUE self;
2739 {
2740 VALUE check_rootwidget;
2741
2742 if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) {
2743 check_rootwidget = Qtrue;
2744 } else if (RTEST(check_rootwidget)) {
2745 check_rootwidget = Qtrue;
2746 } else {
2747 check_rootwidget = Qfalse;
2748 }
2749
2750 return lib_eventloop_launcher(RTEST(check_rootwidget), 0,
2751 (int*)NULL, (Tcl_Interp*)NULL);
2752 }
2753
2754 static VALUE
2755 ip_mainloop(argc, argv, self)
2756 int argc;
2757 VALUE *argv;
2758 VALUE self;
2759 {
2760 volatile VALUE ret;
2761 struct tcltkip *ptr = get_ip(self);
2762
2763 /* ip is deleted? */
2764 if (deleted_ip(ptr)) {
2765 return Qnil;
2766 }
2767
2768 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
2769 /* slave IP */
2770 return Qnil;
2771 }
2772
2773 eventloop_interp = ptr->ip;
2774 ret = lib_mainloop(argc, argv, self);
2775 eventloop_interp = (Tcl_Interp*)NULL;
2776 return ret;
2777 }
2778
2779
2780 static VALUE
2781 watchdog_evloop_launcher(check_rootwidget)
2782 VALUE check_rootwidget;
2783 {
2784 return lib_eventloop_launcher(RTEST(check_rootwidget), 0,
2785 (int*)NULL, (Tcl_Interp*)NULL);
2786 }
2787
2788 #define EVLOOP_WAKEUP_CHANCE 3
2789
2790 static VALUE
2791 lib_watchdog_core(check_rootwidget)
2792 VALUE check_rootwidget;
2793 {
2794 VALUE evloop;
2795 int prev_val = -1;
2796 int chance = 0;
2797 int check = RTEST(check_rootwidget);
2798 struct timeval t0, t1;
2799
2800 t0.tv_sec = 0;
2801 t0.tv_usec = (long)((NO_THREAD_INTERRUPT_TIME)*1000.0);
2802 t1.tv_sec = 0;
2803 t1.tv_usec = (long)((WATCHDOG_INTERVAL)*1000.0);
2804
2805 /* check other watchdog thread */
2806 if (!NIL_P(watchdog_thread)) {
2807 if (RTEST(rb_funcall(watchdog_thread, ID_stop_p, 0))) {
2808 rb_funcall(watchdog_thread, ID_kill, 0);
2809 } else {
2810 return Qnil;
2811 }
2812 }
2813 watchdog_thread = rb_thread_current();
2814
2815 /* watchdog start */
2816 do {
2817 if (NIL_P(eventloop_thread)
2818 || (loop_counter == prev_val && chance >= EVLOOP_WAKEUP_CHANCE)) {
2819 /* start new eventloop thread */
2820 DUMP2("eventloop thread %lx is sleeping or dead",
2821 eventloop_thread);
2822 evloop = rb_thread_create(watchdog_evloop_launcher,
2823 (void*)&check_rootwidget);
2824 DUMP2("create new eventloop thread %lx", evloop);
2825 loop_counter = -1;
2826 chance = 0;
2827 rb_thread_run(evloop);
2828 } else {
2829 prev_val = loop_counter;
2830 if (RTEST(rb_funcall(eventloop_thread, ID_stop_p, 0))) {
2831 ++chance;
2832 } else {
2833 chance = 0;
2834 }
2835 if (event_loop_wait_event) {
2836 rb_thread_wait_for(t0);
2837 } else {
2838 rb_thread_wait_for(t1);
2839 }
2840 /* rb_thread_schedule(); */
2841 }
2842 } while(!check || !tk_stubs_init_p() || Tk_GetNumMainWindows() != 0);
2843
2844 return Qnil;
2845 }
2846
2847 VALUE
2848 lib_watchdog_ensure(arg)
2849 VALUE arg;
2850 {
2851 eventloop_thread = Qnil; /* stop eventloops */
2852 #ifdef RUBY_USE_NATIVE_THREAD
2853 tk_eventloop_thread_id = (Tcl_ThreadId) 0;
2854 #endif
2855 return Qnil;
2856 }
2857
2858 static VALUE
2859 lib_mainloop_watchdog(argc, argv, self)
2860 int argc;
2861 VALUE *argv;
2862 VALUE self;
2863 {
2864 VALUE check_rootwidget;
2865
2866 #ifdef RUBY_VM
2867 rb_raise(rb_eNotImpError,
2868 "eventloop_watchdog is not implemented on Ruby VM.");
2869 #endif
2870
2871 if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) {
2872 check_rootwidget = Qtrue;
2873 } else if (RTEST(check_rootwidget)) {
2874 check_rootwidget = Qtrue;
2875 } else {
2876 check_rootwidget = Qfalse;
2877 }
2878
2879 return rb_ensure(lib_watchdog_core, check_rootwidget,
2880 lib_watchdog_ensure, Qnil);
2881 }
2882
2883 static VALUE
2884 ip_mainloop_watchdog(argc, argv, self)
2885 int argc;
2886 VALUE *argv;
2887 VALUE self;
2888 {
2889 struct tcltkip *ptr = get_ip(self);
2890
2891 /* ip is deleted? */
2892 if (deleted_ip(ptr)) {
2893 return Qnil;
2894 }
2895
2896 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
2897 /* slave IP */
2898 return Qnil;
2899 }
2900 return lib_mainloop_watchdog(argc, argv, self);
2901 }
2902
2903
2904 /* thread-safe(?) interaction between Ruby and Tk */
2905 struct thread_call_proc_arg {
2906 VALUE proc;
2907 int *done;
2908 };
2909
2910 void
2911 _thread_call_proc_arg_mark(struct thread_call_proc_arg *q)
2912 {
2913 rb_gc_mark(q->proc);
2914 }
2915
2916 static VALUE
2917 _thread_call_proc_core(arg)
2918 VALUE arg;
2919 {
2920 struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg;
2921 return rb_funcall(q->proc, ID_call, 0);
2922 }
2923
2924 static VALUE
2925 _thread_call_proc_ensure(arg)
2926 VALUE arg;
2927 {
2928 struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg;
2929 *(q->done) = 1;
2930 return Qnil;
2931 }
2932
2933 static VALUE
2934 _thread_call_proc(arg)
2935 VALUE arg;
2936 {
2937 struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg;
2938
2939 return rb_ensure(_thread_call_proc_core, (VALUE)q,
2940 _thread_call_proc_ensure, (VALUE)q);
2941 }
2942
2943 static VALUE
2944 #ifdef HAVE_PROTOTYPES
2945 _thread_call_proc_value(VALUE th)
2946 #else
2947 _thread_call_proc_value(th)
2948 VALUE th;
2949 #endif
2950 {
2951 return rb_funcall(th, ID_value, 0);
2952 }
2953
2954 static VALUE
2955 lib_thread_callback(argc, argv, self)
2956 int argc;
2957 VALUE *argv;
2958 VALUE self;
2959 {
2960 struct thread_call_proc_arg *q;
2961 VALUE proc, th, ret;
2962 int status, foundEvent;
2963
2964 if (rb_scan_args(argc, argv, "01", &proc) == 0) {
2965 proc = rb_block_proc();
2966 }
2967
2968 q = (struct thread_call_proc_arg *)ALLOC(struct thread_call_proc_arg);
2969 /* q = RbTk_ALLOC_N(struct thread_call_proc_arg, 1); */
2970 q->proc = proc;
2971 q->done = (int*)ALLOC(int);
2972 /* q->done = RbTk_ALLOC_N(int, 1); */
2973 *(q->done) = 0;
2974
2975 /* create call-proc thread */
2976 th = rb_thread_create(_thread_call_proc, (void*)q);
2977
2978 rb_thread_schedule();
2979
2980 /* start sub-eventloop */
2981 foundEvent = RTEST(lib_eventloop_launcher(/* not check root-widget */0, 0,
2982 q->done, (Tcl_Interp*)NULL));
2983
2984 #ifdef RUBY_VM
2985 if (RTEST(rb_funcall(th, ID_alive_p, 0))) {
2986 #else
2987 if (RTEST(rb_thread_alive_p(th))) {
2988 #endif
2989 rb_funcall(th, ID_kill, 0);
2990 ret = Qnil;
2991 } else {
2992 ret = rb_protect(_thread_call_proc_value, th, &status);
2993 }
2994
2995 xfree(q->done);
2996 xfree(q);
2997 /* ckfree((char*)q->done); */
2998 /* ckfree((char*)q); */
2999
3000 if (NIL_P(rbtk_pending_exception)) {
3001 /* return rb_errinfo(); */
3002 if (status) {
3003 rb_exc_raise(rb_errinfo());
3004 }
3005 } else {
3006 VALUE exc = rbtk_pending_exception;
3007 rbtk_pending_exception = Qnil;
3008 /* return exc; */
3009 rb_exc_raise(exc);
3010 }
3011
3012 return ret;
3013 }
3014
3015
3016 /* do_one_event */
3017 static VALUE
3018 lib_do_one_event_core(argc, argv, self, is_ip)
3019 int argc;
3020 VALUE *argv;
3021 VALUE self;
3022 int is_ip;
3023 {
3024 volatile VALUE vflags;
3025 int flags;
3026 int found_event;
3027
3028 if (!NIL_P(eventloop_thread)) {
3029 rb_raise(rb_eRuntimeError, "eventloop is already running");
3030 }
3031
3032 tcl_stubs_check();
3033
3034 if (rb_scan_args(argc, argv, "01", &vflags) == 0) {
3035 flags = TCL_ALL_EVENTS | TCL_DONT_WAIT;
3036 } else {
3037 Check_Type(vflags, T_FIXNUM);
3038 flags = FIX2INT(vflags);
3039 }
3040
3041 if (rb_safe_level() >= 4 || (rb_safe_level() >=1 && OBJ_TAINTED(vflags))) {
3042 flags |= TCL_DONT_WAIT;
3043 }
3044
3045 if (is_ip) {
3046 /* check IP */
3047 struct tcltkip *ptr = get_ip(self);
3048
3049 /* ip is deleted? */
3050 if (deleted_ip(ptr)) {
3051 return Qfalse;
3052 }
3053
3054 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
3055 /* slave IP */
3056 flags |= TCL_DONT_WAIT;
3057 }
3058 }
3059
3060 /* found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); */
3061 found_event = Tcl_DoOneEvent(flags);
3062
3063 if (pending_exception_check0()) {
3064 return Qfalse;
3065 }
3066
3067 if (found_event) {
3068 return Qtrue;
3069 } else {
3070 return Qfalse;
3071 }
3072 }
3073
3074 static VALUE
3075 lib_do_one_event(argc, argv, self)
3076 int argc;
3077 VALUE *argv;
3078 VALUE self;
3079 {
3080 return lib_do_one_event_core(argc, argv, self, 0);
3081 }
3082
3083 static VALUE
3084 ip_do_one_event(argc, argv, self)
3085 int argc;
3086 VALUE *argv;
3087 VALUE self;
3088 {
3089 return lib_do_one_event_core(argc, argv, self, 0);
3090 }
3091
3092
3093 static void
3094 ip_set_exc_message(interp, exc)
3095 Tcl_Interp *interp;
3096 VALUE exc;
3097 {
3098 char *buf;
3099 Tcl_DString dstr;
3100 volatile VALUE msg;
3101 int thr_crit_bup;
3102
3103 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
3104 volatile VALUE enc;
3105 Tcl_Encoding encoding;
3106 #endif
3107
3108 thr_crit_bup = rb_thread_critical;
3109 rb_thread_critical = Qtrue;
3110
3111 msg = rb_funcall(exc, ID_message, 0, 0);
3112 StringValue(msg);
3113
3114 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
3115 enc = rb_attr_get(exc, ID_at_enc);
3116 if (NIL_P(enc)) {
3117 enc = rb_attr_get(msg, ID_at_enc);
3118 }
3119 if (NIL_P(enc)) {
3120 encoding = (Tcl_Encoding)NULL;
3121 } else if (TYPE(enc) == T_STRING) {
3122 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
3123 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc));
3124 } else {
3125 enc = rb_funcall(enc, ID_to_s, 0, 0);
3126 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
3127 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc));
3128 }
3129
3130 /* to avoid a garbled error message dialog */
3131 /* buf = ALLOC_N(char, (RSTRING(msg)->len)+1);*/
3132 /* memcpy(buf, RSTRING(msg)->ptr, RSTRING(msg)->len);*/
3133 /* buf[RSTRING(msg)->len] = 0; */
3134 buf = ALLOC_N(char, RSTRING_LENINT(msg)+1);
3135 /* buf = ckalloc(RSTRING_LENINT(msg)+1); */
3136 memcpy(buf, RSTRING_PTR(msg), RSTRING_LEN(msg));
3137 buf[RSTRING_LEN(msg)] = 0;
3138
3139 Tcl_DStringInit(&dstr);
3140 Tcl_DStringFree(&dstr);
3141 Tcl_ExternalToUtfDString(encoding, buf, RSTRING_LENINT(msg), &dstr);
3142
3143 Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL);
3144 DUMP2("error message:%s", Tcl_DStringValue(&dstr));
3145 Tcl_DStringFree(&dstr);
3146 xfree(buf);
3147 /* ckfree(buf); */
3148
3149 #else /* TCL_VERSION <= 8.0 */
3150 Tcl_AppendResult(interp, RSTRING_PTR(msg), (char*)NULL);
3151 #endif
3152
3153 rb_thread_critical = thr_crit_bup;
3154 }
3155
3156 static VALUE
3157 TkStringValue(obj)
3158 VALUE obj;
3159 {
3160 switch(TYPE(obj)) {
3161 case T_STRING:
3162 return obj;
3163
3164 case T_NIL:
3165 return rb_str_new2("");
3166
3167 case T_TRUE:
3168 return rb_str_new2("1");
3169
3170 case T_FALSE:
3171 return rb_str_new2("0");
3172
3173 case T_ARRAY:
3174 return rb_funcall(obj, ID_join, 1, rb_str_new2(" "));
3175
3176 default:
3177 if (rb_respond_to(obj, ID_to_s)) {
3178 return rb_funcall(obj, ID_to_s, 0, 0);
3179 }
3180 }
3181
3182 return rb_funcall(obj, ID_inspect, 0, 0);
3183 }
3184
3185 static int
3186 #ifdef HAVE_PROTOTYPES
3187 tcl_protect_core(Tcl_Interp *interp, VALUE (*proc)(VALUE), VALUE data)
3188 #else
3189 tcl_protect_core(interp, proc, data) /* should not raise exception */
3190 Tcl_Interp *interp;
3191 VALUE (*proc)();
3192 VALUE data;
3193 #endif
3194 {
3195 volatile VALUE ret, exc = Qnil;
3196 int status = 0;
3197 int thr_crit_bup = rb_thread_critical;
3198
3199 Tcl_ResetResult(interp);
3200
3201 rb_thread_critical = Qfalse;
3202 ret = rb_protect(proc, data, &status);
3203 rb_thread_critical = Qtrue;
3204 if (status) {
3205 char *buf;
3206 VALUE old_gc;
3207 volatile VALUE type, str;
3208
3209 old_gc = rb_gc_disable();
3210
3211 switch(status) {
3212 case TAG_RETURN:
3213 type = eTkCallbackReturn;
3214 goto error;
3215 case TAG_BREAK:
3216 type = eTkCallbackBreak;
3217 goto error;
3218 case TAG_NEXT:
3219 type = eTkCallbackContinue;
3220 goto error;
3221 error:
3222 str = rb_str_new2("LocalJumpError: ");
3223 rb_str_append(str, rb_obj_as_string(rb_errinfo()));
3224 exc = rb_exc_new3(type, str);
3225 break;
3226
3227 case TAG_RETRY:
3228 if (NIL_P(rb_errinfo())) {
3229 DUMP1("rb_protect: retry");
3230 exc = rb_exc_new2(eTkCallbackRetry, "retry jump error");
3231 } else {
3232 exc = rb_errinfo();
3233 }
3234 break;
3235
3236 case TAG_REDO:
3237 if (NIL_P(rb_errinfo())) {
3238 DUMP1("rb_protect: redo");
3239 exc = rb_exc_new2(eTkCallbackRedo, "redo jump error");
3240 } else {
3241 exc = rb_errinfo();
3242 }
3243 break;
3244
3245 case TAG_RAISE:
3246 if (NIL_P(rb_errinfo())) {
3247 exc = rb_exc_new2(rb_eException, "unknown exception");
3248 } else {
3249 exc = rb_errinfo();
3250 }
3251 break;
3252
3253 case TAG_FATAL:
3254 if (NIL_P(rb_errinfo())) {
3255 exc = rb_exc_new2(rb_eFatal, "FATAL");
3256 } else {
3257 exc = rb_errinfo();
3258 }
3259 break;
3260
3261 case TAG_THROW:
3262 if (NIL_P(rb_errinfo())) {
3263 DUMP1("rb_protect: throw");
3264 exc = rb_exc_new2(eTkCallbackThrow, "throw jump error");
3265 } else {
3266 exc = rb_errinfo();
3267 }
3268 break;
3269
3270 default:
3271 buf = ALLOC_N(char, 256);
3272 /* buf = ckalloc(sizeof(char) * 256); */
3273 sprintf(buf, "unknown loncaljmp status %d", status);
3274 exc = rb_exc_new2(rb_eException, buf);
3275 xfree(buf);
3276 /* ckfree(buf); */
3277 break;
3278 }
3279
3280 if (old_gc == Qfalse) rb_gc_enable();
3281
3282 ret = Qnil;
3283 }
3284
3285 rb_thread_critical = thr_crit_bup;
3286
3287 Tcl_ResetResult(interp);
3288
3289 /* status check */
3290 if (!NIL_P(exc)) {
3291 volatile VALUE eclass = rb_obj_class(exc);
3292 volatile VALUE backtrace;
3293
3294 DUMP1("(failed)");
3295
3296 thr_crit_bup = rb_thread_critical;
3297 rb_thread_critical = Qtrue;
3298
3299 DUMP1("set backtrace");
3300 if (!NIL_P(backtrace = rb_funcall(exc, ID_backtrace, 0, 0))) {
3301 backtrace = rb_ary_join(backtrace, rb_str_new2("\n"));
3302 Tcl_AddErrorInfo(interp, StringValuePtr(backtrace));
3303 }
3304
3305 rb_thread_critical = thr_crit_bup;
3306
3307 ip_set_exc_message(interp, exc);
3308
3309 if (eclass == eTkCallbackReturn)
3310 return TCL_RETURN;
3311
3312 if (eclass == eTkCallbackBreak)
3313 return TCL_BREAK;
3314
3315 if (eclass == eTkCallbackContinue)
3316 return TCL_CONTINUE;
3317
3318 if (eclass == rb_eSystemExit || eclass == rb_eInterrupt) {
3319 rbtk_pending_exception = exc;
3320 return TCL_RETURN;
3321 }
3322
3323 if (rb_obj_is_kind_of(exc, eTkLocalJumpError)) {
3324 rbtk_pending_exception = exc;
3325 return TCL_ERROR;
3326 }
3327
3328 if (rb_obj_is_kind_of(exc, eLocalJumpError)) {
3329 VALUE reason = rb_ivar_get(exc, ID_at_reason);
3330
3331 if (TYPE(reason) == T_SYMBOL) {
3332 if (SYM2ID(reason) == ID_return)
3333 return TCL_RETURN;
3334
3335 if (SYM2ID(reason) == ID_break)
3336 return TCL_BREAK;
3337
3338 if (SYM2ID(reason) == ID_next)
3339 return TCL_CONTINUE;
3340 }
3341 }
3342
3343 return TCL_ERROR;
3344 }
3345
3346 /* result must be string or nil */
3347 if (!NIL_P(ret)) {
3348 /* copy result to the tcl interpreter */
3349 thr_crit_bup = rb_thread_critical;
3350 rb_thread_critical = Qtrue;
3351
3352 ret = TkStringValue(ret);
3353 DUMP1("Tcl_AppendResult");
3354 Tcl_AppendResult(interp, RSTRING_PTR(ret), (char *)NULL);
3355
3356 rb_thread_critical = thr_crit_bup;
3357 }
3358
3359 DUMP2("(result) %s", NIL_P(ret) ? "nil" : RSTRING_PTR(ret));
3360
3361 return TCL_OK;
3362 }
3363
3364 static int
3365 tcl_protect(interp, proc, data)
3366 Tcl_Interp *interp;
3367 VALUE (*proc)();
3368 VALUE data;
3369 {
3370 int code;
3371
3372 #ifdef HAVE_NATIVETHREAD
3373 #ifndef RUBY_USE_NATIVE_THREAD
3374 if (!ruby_native_thread_p()) {
3375 rb_bug("cross-thread violation on tcl_protect()");
3376 }
3377 #endif
3378 #endif
3379
3380 #ifdef RUBY_VM
3381 code = tcl_protect_core(interp, proc, data);
3382 #else
3383 do {
3384 int old_trapflag = rb_trap_immediate;
3385 rb_trap_immediate = 0;
3386 code = tcl_protect_core(interp, proc, data);
3387 rb_trap_immediate = old_trapflag;
3388 } while (0);
3389 #endif
3390
3391 return code;
3392 }
3393
3394 static int
3395 #if TCL_MAJOR_VERSION >= 8
3396 ip_ruby_eval(clientData, interp, argc, argv)
3397 ClientData clientData;
3398 Tcl_Interp *interp;
3399 int argc;
3400 Tcl_Obj *CONST argv[];
3401 #else /* TCL_MAJOR_VERSION < 8 */
3402 ip_ruby_eval(clientData, interp, argc, argv)
3403 ClientData clientData;
3404 Tcl_Interp *interp;
3405 int argc;
3406 char *argv[];
3407 #endif
3408 {
3409 char *arg;
3410 int thr_crit_bup;
3411 int code;
3412
3413 if (interp == (Tcl_Interp*)NULL) {
3414 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
3415 "IP is deleted");
3416 return TCL_ERROR;
3417 }
3418
3419 /* ruby command has 1 arg. */
3420 if (argc != 2) {
3421 #if 0
3422 rb_raise(rb_eArgError,
3423 "wrong number of arguments (%d for 1)", argc - 1);
3424 #else
3425 char buf[sizeof(int)*8 + 1];
3426 Tcl_ResetResult(interp);
3427 sprintf(buf, "%d", argc-1);
3428 Tcl_AppendResult(interp, "wrong number of arguments (",
3429 buf, " for 1)", (char *)NULL);
3430 rbtk_pending_exception = rb_exc_new2(rb_eArgError,
3431 Tcl_GetStringResult(interp));
3432 return TCL_ERROR;
3433 #endif
3434 }
3435
3436 /* get C string from Tcl object */
3437 #if TCL_MAJOR_VERSION >= 8
3438 {
3439 char *str;
3440 int len;
3441
3442 thr_crit_bup = rb_thread_critical;
3443 rb_thread_critical = Qtrue;
3444
3445 str = Tcl_GetStringFromObj(argv[1], &len);
3446 arg = ALLOC_N(char, len + 1);
3447 /* arg = ckalloc(sizeof(char) * (len + 1)); */
3448 memcpy(arg, str, len);
3449 arg[len] = 0;
3450
3451 rb_thread_critical = thr_crit_bup;
3452
3453 }
3454 #else /* TCL_MAJOR_VERSION < 8 */
3455 arg = argv[1];
3456 #endif
3457
3458 /* evaluate the argument string by ruby */
3459 DUMP2("rb_eval_string(%s)", arg);
3460
3461 code = tcl_protect(interp, rb_eval_string, (VALUE)arg);
3462
3463 #if TCL_MAJOR_VERSION >= 8
3464 xfree(arg);
3465 /* ckfree(arg); */
3466 #endif
3467
3468 return code;
3469 }
3470
3471
3472 /* Tcl command `ruby_cmd' */
3473 static VALUE
3474 ip_ruby_cmd_core(arg)
3475 struct cmd_body_arg *arg;
3476 {
3477 volatile VALUE ret;
3478 int thr_crit_bup;
3479
3480 DUMP1("call ip_ruby_cmd_core");
3481 thr_crit_bup = rb_thread_critical;
3482 rb_thread_critical = Qfalse;
3483 ret = rb_apply(arg->receiver, arg->method, arg->args);
3484 DUMP2("rb_apply return:%lx", ret);
3485 rb_thread_critical = thr_crit_bup;
3486 DUMP1("finish ip_ruby_cmd_core");
3487
3488 return ret;
3489 }
3490
3491 #define SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER 1
3492
3493 static VALUE
3494 ip_ruby_cmd_receiver_const_get(name)
3495 char *name;
3496 {
3497 volatile VALUE klass = rb_cObject;
3498 #if 0
3499 char *head, *tail;
3500 #endif
3501 int state;
3502
3503 #if SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER
3504 klass = rb_eval_string_protect(name, &state);
3505 if (state) {
3506 return Qnil;
3507 } else {
3508 return klass;
3509 }
3510 #else
3511 return rb_const_get(klass, rb_intern(name));
3512 #endif
3513
3514 /* TODO!!!!!! */
3515 /* support nest of classes/modules */
3516
3517 /* return rb_eval_string(name); */
3518 /* return rb_eval_string_protect(name, &state); */
3519
3520 #if 0 /* doesn't work!! (fail to autoload?) */
3521 /* duplicate */
3522 head = name = strdup(name);
3523
3524 /* has '::' at head ? */
3525 if (*head == ':') head += 2;
3526 tail = head;
3527
3528 /* search */
3529 while(*tail) {
3530 if (*tail == ':') {
3531 *tail = '\0';
3532 klass = rb_const_get(klass, rb_intern(head));
3533 tail += 2;
3534 head = tail;
3535 } else {
3536 tail++;
3537 }
3538 }
3539
3540 free(name);
3541 return rb_const_get(klass, rb_intern(head));
3542 #endif
3543 }
3544
3545 static VALUE
3546 ip_ruby_cmd_receiver_get(str)
3547 char *str;
3548 {
3549 volatile VALUE receiver;
3550 #if !SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER
3551 int state;
3552 #endif
3553
3554 if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) {
3555 /* class | module | constant */
3556 #if SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER
3557 receiver = ip_ruby_cmd_receiver_const_get(str);
3558 #else
3559 receiver = rb_protect(ip_ruby_cmd_receiver_const_get, (VALUE)str, &state);
3560 if (state) return Qnil;
3561 #endif
3562 } else if (str[0] == '$') {
3563 /* global variable */
3564 receiver = rb_gv_get(str);
3565 } else {
3566 /* global variable omitted '$' */
3567 char *buf;
3568 size_t len;
3569
3570 len = strlen(str);
3571 buf = ALLOC_N(char, len + 2);
3572 /* buf = ckalloc(sizeof(char) * (len + 2)); */
3573 buf[0] = '$';
3574 memcpy(buf + 1, str, len);
3575 buf[len + 1] = 0;
3576 receiver = rb_gv_get(buf);
3577 xfree(buf);
3578 /* ckfree(buf); */
3579 }
3580
3581 return receiver;
3582 }
3583
3584 /* ruby_cmd receiver method arg ... */
3585 static int
3586 #if TCL_MAJOR_VERSION >= 8
3587 ip_ruby_cmd(clientData, interp, argc, argv)
3588 ClientData clientData;
3589 Tcl_Interp *interp;
3590 int argc;
3591 Tcl_Obj *CONST argv[];
3592 #else /* TCL_MAJOR_VERSION < 8 */
3593 ip_ruby_cmd(clientData, interp, argc, argv)
3594 ClientData clientData;
3595 Tcl_Interp *interp;
3596 int argc;
3597 char *argv[];
3598 #endif
3599 {
3600 volatile VALUE receiver;
3601 volatile ID method;
3602 volatile VALUE args;
3603 char *str;
3604 int i;
3605 int len;
3606 struct cmd_body_arg *arg;
3607 int thr_crit_bup;
3608 VALUE old_gc;
3609 int code;
3610
3611 if (interp == (Tcl_Interp*)NULL) {
3612 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
3613 "IP is deleted");
3614 return TCL_ERROR;
3615 }
3616
3617 if (argc < 3) {
3618 #if 0
3619 rb_raise(rb_eArgError, "too few arguments");
3620 #else
3621 Tcl_ResetResult(interp);
3622 Tcl_AppendResult(interp, "too few arguments", (char *)NULL);
3623 rbtk_pending_exception = rb_exc_new2(rb_eArgError,
3624 Tcl_GetStringResult(interp));
3625 return TCL_ERROR;
3626 #endif
3627 }
3628
3629 /* get arguments from Tcl objects */
3630 thr_crit_bup = rb_thread_critical;
3631 rb_thread_critical = Qtrue;
3632 old_gc = rb_gc_disable();
3633
3634 /* get receiver */
3635 #if TCL_MAJOR_VERSION >= 8
3636 str = Tcl_GetStringFromObj(argv[1], &len);
3637 #else /* TCL_MAJOR_VERSION < 8 */
3638 str = argv[1];
3639 #endif
3640 DUMP2("receiver:%s",str);
3641 /* receiver = rb_protect(ip_ruby_cmd_receiver_get, (VALUE)str, &code); */
3642 receiver = ip_ruby_cmd_receiver_get(str);
3643 if (NIL_P(receiver)) {
3644 #if 0
3645 rb_raise(rb_eArgError,
3646 "unknown class/module/global-variable '%s'", str);
3647 #else
3648 Tcl_ResetResult(interp);
3649 Tcl_AppendResult(interp, "unknown class/module/global-variable '",
3650 str, "'", (char *)NULL);
3651 rbtk_pending_exception = rb_exc_new2(rb_eArgError,
3652 Tcl_GetStringResult(interp));
3653 if (old_gc == Qfalse) rb_gc_enable();
3654 return TCL_ERROR;
3655 #endif
3656 }
3657
3658 /* get metrhod */
3659 #if TCL_MAJOR_VERSION >= 8
3660 str = Tcl_GetStringFromObj(argv[2], &len);
3661 #else /* TCL_MAJOR_VERSION < 8 */
3662 str = argv[2];
3663 #endif
3664 method = rb_intern(str);
3665
3666 /* get args */
3667 args = rb_ary_new2(argc - 2);
3668 for(i = 3; i < argc; i++) {
3669 VALUE s;
3670 #if TCL_MAJOR_VERSION >= 8
3671 str = Tcl_GetStringFromObj(argv[i], &len);
3672 s = rb_tainted_str_new(str, len);
3673 #else /* TCL_MAJOR_VERSION < 8 */
3674 str = argv[i];
3675 s = rb_tainted_str_new2(str);
3676 #endif
3677 DUMP2("arg:%s",str);
3678 #ifndef HAVE_STRUCT_RARRAY_LEN
3679 rb_ary_push(args, s);
3680 #else
3681 RARRAY(args)->ptr[RARRAY(args)->len++] = s;
3682 #endif
3683 }
3684
3685 if (old_gc == Qfalse) rb_gc_enable();
3686 rb_thread_critical = thr_crit_bup;
3687
3688 /* allocate */
3689 arg = ALLOC(struct cmd_body_arg);
3690 /* arg = RbTk_ALLOC_N(struct cmd_body_arg, 1); */
3691
3692 arg->receiver = receiver;
3693 arg->method = method;
3694 arg->args = args;
3695
3696 /* evaluate the argument string by ruby */
3697 code = tcl_protect(interp, ip_ruby_cmd_core, (VALUE)arg);
3698
3699 xfree(arg);
3700 /* ckfree((char*)arg); */
3701
3702 return code;
3703 }
3704
3705
3706 /*****************************/
3707 /* relpace of 'exit' command */
3708 /*****************************/
3709 static int
3710 #if TCL_MAJOR_VERSION >= 8
3711 #ifdef HAVE_PROTOTYPES
3712 ip_InterpExitObjCmd(ClientData clientData, Tcl_Interp *interp,
3713 int argc, Tcl_Obj *CONST argv[])
3714 #else
3715 ip_InterpExitObjCmd(clientData, interp, argc, argv)
3716 ClientData clientData;
3717 Tcl_Interp *interp;
3718 int argc;
3719 Tcl_Obj *CONST argv[];
3720 #endif
3721 #else /* TCL_MAJOR_VERSION < 8 */
3722 #ifdef HAVE_PROTOTYPES
3723 ip_InterpExitCommand(ClientData clientData, Tcl_Interp *interp,
3724 int argc, char *argv[])
3725 #else
3726 ip_InterpExitCommand(clientData, interp, argc, argv)
3727 ClientData clientData;
3728 Tcl_Interp *interp;
3729 int argc;
3730 char *argv[];
3731 #endif
3732 #endif
3733 {
3734 DUMP1("start ip_InterpExitCommand");
3735 if (interp != (Tcl_Interp*)NULL
3736 && !Tcl_InterpDeleted(interp)
3737 #if TCL_NAMESPACE_DEBUG
3738 && !ip_null_namespace(interp)
3739 #endif
3740 ) {
3741 Tcl_ResetResult(interp);
3742 /* Tcl_Preserve(interp); */
3743 /* Tcl_Eval(interp, "interp eval {} {destroy .}; interp delete {}"); */
3744 if (!Tcl_InterpDeleted(interp)) {
3745 ip_finalize(interp);
3746
3747 Tcl_DeleteInterp(interp);
3748 Tcl_Release(interp);
3749 }
3750 }
3751 return TCL_OK;
3752 }
3753
3754 static int
3755 #if TCL_MAJOR_VERSION >= 8
3756 #ifdef HAVE_PROTOTYPES
3757 ip_RubyExitObjCmd(ClientData clientData, Tcl_Interp *interp,
3758 int argc, Tcl_Obj *CONST argv[])
3759 #else
3760 ip_RubyExitObjCmd(clientData, interp, argc, argv)
3761 ClientData clientData;
3762 Tcl_Interp *interp;
3763 int argc;
3764 Tcl_Obj *CONST argv[];
3765 #endif
3766 #else /* TCL_MAJOR_VERSION < 8 */
3767 #ifdef HAVE_PROTOTYPES
3768 ip_RubyExitCommand(ClientData clientData, Tcl_Interp *interp,
3769 int argc, char *argv[])
3770 #else
3771 ip_RubyExitCommand(clientData, interp, argc, argv)
3772 ClientData clientData;
3773 Tcl_Interp *interp;
3774 int argc;
3775 char *argv[];
3776 #endif
3777 #endif
3778 {
3779 int state;
3780 char *cmd, *param;
3781 #if TCL_MAJOR_VERSION < 8
3782 char *endptr;
3783 cmd = argv[0];
3784 #endif
3785
3786 DUMP1("start ip_RubyExitCommand");
3787
3788 #if TCL_MAJOR_VERSION >= 8
3789 /* cmd = Tcl_GetString(argv[0]); */
3790 cmd = Tcl_GetStringFromObj(argv[0], (int*)NULL);
3791 #endif
3792
3793 if (argc < 1 || argc > 2) {
3794 /* arguemnt error */
3795 Tcl_AppendResult(interp,
3796 "wrong number of arguments: should be \"",
3797 cmd, " ?returnCode?\"", (char *)NULL);
3798 return TCL_ERROR;
3799 }
3800
3801 if (interp == (Tcl_Interp*)NULL) return TCL_OK;
3802
3803 Tcl_ResetResult(interp);
3804
3805 if (rb_safe_level() >= 4 || Tcl_IsSafe(interp)) {
3806 if (!Tcl_InterpDeleted(interp)) {
3807 ip_finalize(interp);
3808
3809 Tcl_DeleteInterp(interp);
3810 Tcl_Release(interp);
3811 }
3812 return TCL_OK;
3813 }
3814
3815 switch(argc) {
3816 case 1:
3817 /* rb_exit(0); */ /* not return if succeed */
3818 Tcl_AppendResult(interp,
3819 "fail to call \"", cmd, "\"", (char *)NULL);
3820
3821 rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
3822 Tcl_GetStringResult(interp));
3823 rb_iv_set(rbtk_pending_exception, "status", INT2FIX(0));
3824
3825 return TCL_RETURN;
3826
3827 case 2:
3828 #if TCL_MAJOR_VERSION >= 8
3829 if (Tcl_GetIntFromObj(interp, argv[1], &state) == TCL_ERROR) {
3830 return TCL_ERROR;
3831 }
3832 /* param = Tcl_GetString(argv[1]); */
3833 param = Tcl_GetStringFromObj(argv[1], (int*)NULL);
3834 #else /* TCL_MAJOR_VERSION < 8 */
3835 state = (int)strtol(argv[1], &endptr, 0);
3836 if (*endptr) {
3837 Tcl_AppendResult(interp,
3838 "expected integer but got \"",
3839 argv[1], "\"", (char *)NULL);
3840 return TCL_ERROR;
3841 }
3842 param = argv[1];
3843 #endif
3844 /* rb_exit(state); */ /* not return if succeed */
3845
3846 Tcl_AppendResult(interp, "fail to call \"", cmd, " ",
3847 param, "\"", (char *)NULL);
3848
3849 rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
3850 Tcl_GetStringResult(interp));
3851 rb_iv_set(rbtk_pending_exception, "status", INT2FIX(state));
3852
3853 return TCL_RETURN;
3854
3855 default:
3856 /* arguemnt error */
3857 Tcl_AppendResult(interp,
3858 "wrong number of arguments: should be \"",
3859 cmd, " ?returnCode?\"", (char *)NULL);
3860 return TCL_ERROR;
3861 }
3862 }
3863
3864
3865 /**************************/
3866 /* based on tclEvent.c */
3867 /**************************/
3868
3869 /*********************/
3870 /* replace of update */
3871 /*********************/
3872 #if TCL_MAJOR_VERSION >= 8
3873 static int ip_rbUpdateObjCmd _((ClientData, Tcl_Interp *, int,
3874 Tcl_Obj *CONST []));
3875 static int
3876 ip_rbUpdateObjCmd(clientData, interp, objc, objv)
3877 ClientData clientData;
3878 Tcl_Interp *interp;
3879 int objc;
3880 Tcl_Obj *CONST objv[];
3881 #else /* TCL_MAJOR_VERSION < 8 */
3882 static int ip_rbUpdateCommand _((ClientData, Tcl_Interp *, int, char *[]));
3883 static int
3884 ip_rbUpdateCommand(clientData, interp, objc, objv)
3885 ClientData clientData;
3886 Tcl_Interp *interp;
3887 int objc;
3888 char *objv[];
3889 #endif
3890 {
3891 int optionIndex;
3892 int ret;
3893 int flags = 0;
3894 static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
3895 enum updateOptions {REGEXP_IDLETASKS};
3896
3897 DUMP1("Ruby's 'update' is called");
3898 if (interp == (Tcl_Interp*)NULL) {
3899 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
3900 "IP is deleted");
3901 return TCL_ERROR;
3902 }
3903 #ifdef HAVE_NATIVETHREAD
3904 #ifndef RUBY_USE_NATIVE_THREAD
3905 if (!ruby_native_thread_p()) {
3906 rb_bug("cross-thread violation on ip_ruby_eval()");
3907 }
3908 #endif
3909 #endif
3910
3911 Tcl_ResetResult(interp);
3912
3913 if (objc == 1) {
3914 flags = TCL_DONT_WAIT;
3915
3916 } else if (objc == 2) {
3917 #if TCL_MAJOR_VERSION >= 8
3918 if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions,
3919 "option", 0, &optionIndex) != TCL_OK) {
3920 return TCL_ERROR;
3921 }
3922 switch ((enum updateOptions) optionIndex) {
3923 case REGEXP_IDLETASKS: {
3924 flags = TCL_IDLE_EVENTS;
3925 break;
3926 }
3927 default: {
3928 rb_bug("ip_rbUpdateObjCmd: bad option index to UpdateOptions");
3929 }
3930 }
3931 #else
3932 if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) {
3933 Tcl_AppendResult(interp, "bad option \"", objv[1],
3934 "\": must be idletasks", (char *) NULL);
3935 return TCL_ERROR;
3936 }
3937 flags = TCL_IDLE_EVENTS;
3938 #endif
3939 } else {
3940 #ifdef Tcl_WrongNumArgs
3941 Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]");
3942 #else
3943 # if TCL_MAJOR_VERSION >= 8
3944 int dummy;
3945 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
3946 Tcl_GetStringFromObj(objv[0], &dummy),
3947 " [ idletasks ]\"",
3948 (char *) NULL);
3949 # else /* TCL_MAJOR_VERSION < 8 */
3950 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
3951 objv[0], " [ idletasks ]\"", (char *) NULL);
3952 # endif
3953 #endif
3954 return TCL_ERROR;
3955 }
3956
3957 Tcl_Preserve(interp);
3958
3959 /* call eventloop */
3960 /* ret = lib_eventloop_core(0, flags, (int *)NULL);*/ /* ignore result */
3961 ret = RTEST(lib_eventloop_launcher(0, flags, (int *)NULL, interp)); /* ignore result */
3962
3963 /* exception check */
3964 if (!NIL_P(rbtk_pending_exception)) {
3965 Tcl_Release(interp);
3966
3967 /*
3968 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
3969 */
3970 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
3971 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
3972 return TCL_RETURN;
3973 } else{
3974 return TCL_ERROR;
3975 }
3976 }
3977
3978 /* trap check */
3979 #ifdef RUBY_VM
3980 if (rb_thread_check_trap_pending()) {
3981 #else
3982 if (rb_trap_pending) {
3983 #endif
3984 Tcl_Release(interp);
3985
3986 return TCL_RETURN;
3987 }
3988
3989 /*
3990 * Must clear the interpreter's result because event handlers could
3991 * have executed commands.
3992 */
3993
3994 DUMP2("last result '%s'", Tcl_GetStringResult(interp));
3995 Tcl_ResetResult(interp);
3996 Tcl_Release(interp);
3997
3998 DUMP1("finish Ruby's 'update'");
3999 return TCL_OK;
4000 }
4001
4002
4003 /**********************/
4004 /* update with thread */
4005 /**********************/
4006 struct th_update_param {
4007 VALUE thread;
4008 int done;
4009 };
4010
4011 static void rb_threadUpdateProc _((ClientData));
4012 static void
4013 rb_threadUpdateProc(clientData)
4014 ClientData clientData; /* Pointer to integer to set to 1. */
4015 {
4016 struct th_update_param *param = (struct th_update_param *) clientData;
4017
4018 DUMP1("threadUpdateProc is called");
4019 param->done = 1;
4020 rb_thread_wakeup(param->thread);
4021
4022 return;
4023 }
4024
4025 #if TCL_MAJOR_VERSION >= 8
4026 static int ip_rb_threadUpdateObjCmd _((ClientData, Tcl_Interp *, int,
4027 Tcl_Obj *CONST []));
4028 static int
4029 ip_rb_threadUpdateObjCmd(clientData, interp, objc, objv)
4030 ClientData clientData;
4031 Tcl_Interp *interp;
4032 int objc;
4033 Tcl_Obj *CONST objv[];
4034 #else /* TCL_MAJOR_VERSION < 8 */
4035 static int ip_rb_threadUpdateCommand _((ClientData, Tcl_Interp *, int,
4036 char *[]));
4037 static int
4038 ip_rb_threadUpdateCommand(clientData, interp, objc, objv)
4039 ClientData clientData;
4040 Tcl_Interp *interp;
4041 int objc;
4042 char *objv[];
4043 #endif
4044 {
4045 int optionIndex;
4046 int flags = 0;
4047 struct th_update_param *param;
4048 static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
4049 enum updateOptions {REGEXP_IDLETASKS};
4050 volatile VALUE current_thread = rb_thread_current();
4051 struct timeval t;
4052
4053 DUMP1("Ruby's 'thread_update' is called");
4054 if (interp == (Tcl_Interp*)NULL) {
4055 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
4056 "IP is deleted");
4057 return TCL_ERROR;
4058 }
4059 #ifdef HAVE_NATIVETHREAD
4060 #ifndef RUBY_USE_NATIVE_THREAD
4061 if (!ruby_native_thread_p()) {
4062 rb_bug("cross-thread violation on ip_rb_threadUpdateCommand()");
4063 }
4064 #endif
4065 #endif
4066
4067 if (rb_thread_alone()
4068 || NIL_P(eventloop_thread) || eventloop_thread == current_thread) {
4069 #if TCL_MAJOR_VERSION >= 8
4070 DUMP1("call ip_rbUpdateObjCmd");
4071 return ip_rbUpdateObjCmd(clientData, interp, objc, objv);
4072 #else /* TCL_MAJOR_VERSION < 8 */
4073 DUMP1("call ip_rbUpdateCommand");
4074 return ip_rbUpdateCommand(clientData, interp, objc, objv);
4075 #endif
4076 }
4077
4078 DUMP1("start Ruby's 'thread_update' body");
4079
4080 Tcl_ResetResult(interp);
4081
4082 if (objc == 1) {
4083 flags = TCL_DONT_WAIT;
4084
4085 } else if (objc == 2) {
4086 #if TCL_MAJOR_VERSION >= 8
4087 if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions,
4088 "option", 0, &optionIndex) != TCL_OK) {
4089 return TCL_ERROR;
4090 }
4091 switch ((enum updateOptions) optionIndex) {
4092 case REGEXP_IDLETASKS: {
4093 flags = TCL_IDLE_EVENTS;
4094 break;
4095 }
4096 default: {
4097 rb_bug("ip_rb_threadUpdateObjCmd: bad option index to UpdateOptions");
4098 }
4099 }
4100 #else
4101 if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) {
4102 Tcl_AppendResult(interp, "bad option \"", objv[1],
4103 "\": must be idletasks", (char *) NULL);
4104 return TCL_ERROR;
4105 }
4106 flags = TCL_IDLE_EVENTS;
4107 #endif
4108 } else {
4109 #ifdef Tcl_WrongNumArgs
4110 Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]");
4111 #else
4112 # if TCL_MAJOR_VERSION >= 8
4113 int dummy;
4114 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
4115 Tcl_GetStringFromObj(objv[0], &dummy),
4116 " [ idletasks ]\"",
4117 (char *) NULL);
4118 # else /* TCL_MAJOR_VERSION < 8 */
4119 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
4120 objv[0], " [ idletasks ]\"", (char *) NULL);
4121 # endif
4122 #endif
4123 return TCL_ERROR;
4124 }
4125
4126 DUMP1("pass argument check");
4127
4128 /* param = (struct th_update_param *)Tcl_Alloc(sizeof(struct th_update_param)); */
4129 param = RbTk_ALLOC_N(struct th_update_param, 1);
4130 #if 0 /* use Tcl_Preserve/Release */
4131 Tcl_Preserve((ClientData)param);
4132 #endif
4133 param->thread = current_thread;
4134 param->done = 0;
4135
4136 DUMP1("set idle proc");
4137 Tcl_DoWhenIdle(rb_threadUpdateProc, (ClientData) param);
4138
4139 t.tv_sec = 0;
4140 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
4141
4142 while(!param->done) {
4143 DUMP1("wait for complete idle proc");
4144 /* rb_thread_stop(); */
4145 /* rb_thread_sleep_forever(); */
4146 rb_thread_wait_for(t);
4147 if (NIL_P(eventloop_thread)) {
4148 break;
4149 }
4150 }
4151
4152 #if 0 /* use Tcl_EventuallyFree */
4153 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
4154 #else
4155 #if 0 /* use Tcl_Preserve/Release */
4156 Tcl_Release((ClientData)param);
4157 #else
4158 /* Tcl_Free((char *)param); */
4159 ckfree((char *)param);
4160 #endif
4161 #endif
4162
4163 DUMP1("finish Ruby's 'thread_update'");
4164 return TCL_OK;
4165 }
4166
4167
4168 /***************************/
4169 /* replace of vwait/tkwait */
4170 /***************************/
4171 #if TCL_MAJOR_VERSION >= 8
4172 static int ip_rbVwaitObjCmd _((ClientData, Tcl_Interp *, int,
4173 Tcl_Obj *CONST []));
4174 static int ip_rb_threadVwaitObjCmd _((ClientData, Tcl_Interp *, int,
4175 Tcl_Obj *CONST []));
4176 static int ip_rbTkWaitObjCmd _((ClientData, Tcl_Interp *, int,
4177 Tcl_Obj *CONST []));
4178 static int ip_rb_threadTkWaitObjCmd _((ClientData, Tcl_Interp *, int,
4179 Tcl_Obj *CONST []));
4180 #else
4181 static int ip_rbVwaitCommand _((ClientData, Tcl_Interp *, int, char *[]));
4182 static int ip_rb_threadVwaitCommand _((ClientData, Tcl_Interp *, int,
4183 char *[]));
4184 static int ip_rbTkWaitCommand _((ClientData, Tcl_Interp *, int, char *[]));
4185 static int ip_rb_threadTkWaitCommand _((ClientData, Tcl_Interp *, int,
4186 char *[]));
4187 #endif
4188
4189 #if TCL_MAJOR_VERSION >= 8
4190 static char *VwaitVarProc _((ClientData, Tcl_Interp *,
4191 CONST84 char *,CONST84 char *, int));
4192 static char *
4193 VwaitVarProc(clientData, interp, name1, name2, flags)
4194 ClientData clientData; /* Pointer to integer to set to 1. */
4195 Tcl_Interp *interp; /* Interpreter containing variable. */
4196 CONST84 char *name1; /* Name of variable. */
4197 CONST84 char *name2; /* Second part of variable name. */
4198 int flags; /* Information about what happened. */
4199 #else /* TCL_MAJOR_VERSION < 8 */
4200 static char *VwaitVarProc _((ClientData, Tcl_Interp *, char *, char *, int));
4201 static char *
4202 VwaitVarProc(clientData, interp, name1, name2, flags)
4203 ClientData clientData; /* Pointer to integer to set to 1. */
4204 Tcl_Interp *interp; /* Interpreter containing variable. */
4205 char *name1; /* Name of variable. */
4206 char *name2; /* Second part of variable name. */
4207 int flags; /* Information about what happened. */
4208 #endif
4209 {
4210 int *donePtr = (int *) clientData;
4211
4212 *donePtr = 1;
4213 return (char *) NULL;
4214 }
4215
4216 #if TCL_MAJOR_VERSION >= 8
4217 static int
4218 ip_rbVwaitObjCmd(clientData, interp, objc, objv)
4219 ClientData clientData; /* Not used */
4220 Tcl_Interp *interp;
4221 int objc;
4222 Tcl_Obj *CONST objv[];
4223 #else /* TCL_MAJOR_VERSION < 8 */
4224 static int
4225 ip_rbVwaitCommand(clientData, interp, objc, objv)
4226 ClientData clientData; /* Not used */
4227 Tcl_Interp *interp;
4228 int objc;
4229 char *objv[];
4230 #endif
4231 {
4232 int ret, done, foundEvent;
4233 char *nameString;
4234 int dummy;
4235 int thr_crit_bup;
4236
4237 DUMP1("Ruby's 'vwait' is called");
4238 if (interp == (Tcl_Interp*)NULL) {
4239 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
4240 "IP is deleted");
4241 return TCL_ERROR;
4242 }
4243
4244 #if 0
4245 if (!rb_thread_alone()
4246 && eventloop_thread != Qnil
4247 && eventloop_thread != rb_thread_current()) {
4248 #if TCL_MAJOR_VERSION >= 8
4249 DUMP1("call ip_rb_threadVwaitObjCmd");
4250 return ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv);
4251 #else /* TCL_MAJOR_VERSION < 8 */
4252 DUMP1("call ip_rb_threadVwaitCommand");
4253 return ip_rb_threadVwaitCommand(clientData, interp, objc, objv);
4254 #endif
4255 }
4256 #endif
4257
4258 Tcl_Preserve(interp);
4259 #ifdef HAVE_NATIVETHREAD
4260 #ifndef RUBY_USE_NATIVE_THREAD
4261 if (!ruby_native_thread_p()) {
4262 rb_bug("cross-thread violation on ip_rbVwaitCommand()");
4263 }
4264 #endif
4265 #endif
4266
4267 Tcl_ResetResult(interp);
4268
4269 if (objc != 2) {
4270 #ifdef Tcl_WrongNumArgs
4271 Tcl_WrongNumArgs(interp, 1, objv, "name");
4272 #else
4273 thr_crit_bup = rb_thread_critical;
4274 rb_thread_critical = Qtrue;
4275
4276 #if TCL_MAJOR_VERSION >= 8
4277 /* nameString = Tcl_GetString(objv[0]); */
4278 nameString = Tcl_GetStringFromObj(objv[0], &dummy);
4279 #else /* TCL_MAJOR_VERSION < 8 */
4280 nameString = objv[0];
4281 #endif
4282 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
4283 nameString, " name\"", (char *) NULL);
4284
4285 rb_thread_critical = thr_crit_bup;
4286 #endif
4287
4288 Tcl_Release(interp);
4289 return TCL_ERROR;
4290 }
4291
4292 thr_crit_bup = rb_thread_critical;
4293 rb_thread_critical = Qtrue;
4294
4295 #if TCL_MAJOR_VERSION >= 8
4296 Tcl_IncrRefCount(objv[1]);
4297 /* nameString = Tcl_GetString(objv[1]); */
4298 nameString = Tcl_GetStringFromObj(objv[1], &dummy);
4299 #else /* TCL_MAJOR_VERSION < 8 */
4300 nameString = objv[1];
4301 #endif
4302
4303 /*
4304 if (Tcl_TraceVar(interp, nameString,
4305 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
4306 VwaitVarProc, (ClientData) &done) != TCL_OK) {
4307 return TCL_ERROR;
4308 }
4309 */
4310 ret = Tcl_TraceVar(interp, nameString,
4311 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
4312 VwaitVarProc, (ClientData) &done);
4313
4314 rb_thread_critical = thr_crit_bup;
4315
4316 if (ret != TCL_OK) {
4317 #if TCL_MAJOR_VERSION >= 8
4318 Tcl_DecrRefCount(objv[1]);
4319 #endif
4320 Tcl_Release(interp);
4321 return TCL_ERROR;
4322 }
4323
4324 done = 0;
4325
4326 foundEvent = RTEST(lib_eventloop_launcher(/* not check root-widget */0,
4327 0, &done, interp));
4328
4329 thr_crit_bup = rb_thread_critical;
4330 rb_thread_critical = Qtrue;
4331
4332 Tcl_UntraceVar(interp, nameString,
4333 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
4334 VwaitVarProc, (ClientData) &done);
4335
4336 rb_thread_critical = thr_crit_bup;
4337
4338 /* exception check */
4339 if (!NIL_P(rbtk_pending_exception)) {
4340 #if TCL_MAJOR_VERSION >= 8
4341 Tcl_DecrRefCount(objv[1]);
4342 #endif
4343 Tcl_Release(interp);
4344
4345 /*
4346 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
4347 */
4348 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
4349 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
4350 return TCL_RETURN;
4351 } else{
4352 return TCL_ERROR;
4353 }
4354 }
4355
4356 /* trap check */
4357 #ifdef RUBY_VM
4358 if (rb_thread_check_trap_pending()) {
4359 #else
4360 if (rb_trap_pending) {
4361 #endif
4362 #if TCL_MAJOR_VERSION >= 8
4363 Tcl_DecrRefCount(objv[1]);
4364 #endif
4365 Tcl_Release(interp);
4366
4367 return TCL_RETURN;
4368 }
4369
4370 /*
4371 * Clear out the interpreter's result, since it may have been set
4372 * by event handlers.
4373 */
4374
4375 Tcl_ResetResult(interp);
4376 if (!foundEvent) {
4377 thr_crit_bup = rb_thread_critical;
4378 rb_thread_critical = Qtrue;
4379
4380 Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
4381 "\": would wait forever", (char *) NULL);
4382
4383 rb_thread_critical = thr_crit_bup;
4384
4385 #if TCL_MAJOR_VERSION >= 8
4386 Tcl_DecrRefCount(objv[1]);
4387 #endif
4388 Tcl_Release(interp);
4389 return TCL_ERROR;
4390 }
4391
4392 #if TCL_MAJOR_VERSION >= 8
4393 Tcl_DecrRefCount(objv[1]);
4394 #endif
4395 Tcl_Release(interp);
4396 return TCL_OK;
4397 }
4398
4399
4400 /**************************/
4401 /* based on tkCmd.c */
4402 /**************************/
4403 #if TCL_MAJOR_VERSION >= 8
4404 static char *WaitVariableProc _((ClientData, Tcl_Interp *,
4405 CONST84 char *,CONST84 char *, int));
4406 static char *
4407 WaitVariableProc(clientData, interp, name1, name2, flags)
4408 ClientData clientData; /* Pointer to integer to set to 1. */
4409 Tcl_Interp *interp; /* Interpreter containing variable. */
4410 CONST84 char *name1; /* Name of variable. */
4411 CONST84 char *name2; /* Second part of variable name. */
4412 int flags; /* Information about what happened. */
4413 #else /* TCL_MAJOR_VERSION < 8 */
4414 static char *WaitVariableProc _((ClientData, Tcl_Interp *,
4415 char *, char *, int));
4416 static char *
4417 WaitVariableProc(clientData, interp, name1, name2, flags)
4418 ClientData clientData; /* Pointer to integer to set to 1. */
4419 Tcl_Interp *interp; /* Interpreter containing variable. */
4420 char *name1; /* Name of variable. */
4421 char *name2; /* Second part of variable name. */
4422 int flags; /* Information about what happened. */
4423 #endif
4424 {
4425 int *donePtr = (int *) clientData;
4426
4427 *donePtr = 1;
4428 return (char *) NULL;
4429 }
4430
4431 static void WaitVisibilityProc _((ClientData, XEvent *));
4432 static void
4433 WaitVisibilityProc(clientData, eventPtr)
4434 ClientData clientData; /* Pointer to integer to set to 1. */
4435 XEvent *eventPtr; /* Information about event (not used). */
4436 {
4437 int *donePtr = (int *) clientData;
4438
4439 if (eventPtr->type == VisibilityNotify) {
4440 *donePtr = 1;
4441 }
4442 if (eventPtr->type == DestroyNotify) {
4443 *donePtr = 2;
4444 }
4445 }
4446
4447 static void WaitWindowProc _((ClientData, XEvent *));
4448 static void
4449 WaitWindowProc(clientData, eventPtr)
4450 ClientData clientData; /* Pointer to integer to set to 1. */
4451 XEvent *eventPtr; /* Information about event. */
4452 {
4453 int *donePtr = (int *) clientData;
4454
4455 if (eventPtr->type == DestroyNotify) {
4456 *donePtr = 1;
4457 }
4458 }
4459
4460 #if TCL_MAJOR_VERSION >= 8
4461 static int
4462 ip_rbTkWaitObjCmd(clientData, interp, objc, objv)
4463 ClientData clientData;
4464 Tcl_Interp *interp;
4465 int objc;
4466 Tcl_Obj *CONST objv[];
4467 #else /* TCL_MAJOR_VERSION < 8 */
4468 static int
4469 ip_rbTkWaitCommand(clientData, interp, objc, objv)
4470 ClientData clientData;
4471 Tcl_Interp *interp;
4472 int objc;
4473 char *objv[];
4474 #endif
4475 {
4476 Tk_Window tkwin = (Tk_Window) clientData;
4477 Tk_Window window;
4478 int done, index;
4479 static CONST char *optionStrings[] = { "variable", "visibility", "window",
4480 (char *) NULL };
4481 enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW };
4482 char *nameString;
4483 int ret, dummy;
4484 int thr_crit_bup;
4485
4486 DUMP1("Ruby's 'tkwait' is called");
4487 if (interp == (Tcl_Interp*)NULL) {
4488 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
4489 "IP is deleted");
4490 return TCL_ERROR;
4491 }
4492
4493 #if 0
4494 if (!rb_thread_alone()
4495 && eventloop_thread != Qnil
4496 && eventloop_thread != rb_thread_current()) {
4497 #if TCL_MAJOR_VERSION >= 8
4498 DUMP1("call ip_rb_threadTkWaitObjCmd");
4499 return ip_rb_threadTkWaitObjCmd((ClientData)tkwin, interp, objc, objv);
4500 #else /* TCL_MAJOR_VERSION < 8 */
4501 DUMP1("call ip_rb_threadTkWaitCommand");
4502 return ip_rb_threadTkWwaitCommand((ClientData)tkwin, interp, objc, objv);
4503 #endif
4504 }
4505 #endif
4506
4507 Tcl_Preserve(interp);
4508 Tcl_ResetResult(interp);
4509
4510 if (objc != 3) {
4511 #ifdef Tcl_WrongNumArgs
4512 Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name");
4513 #else
4514 thr_crit_bup = rb_thread_critical;
4515 rb_thread_critical = Qtrue;
4516
4517 #if TCL_MAJOR_VERSION >= 8
4518 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
4519 Tcl_GetStringFromObj(objv[0], &dummy),
4520 " variable|visibility|window name\"",
4521 (char *) NULL);
4522 #else /* TCL_MAJOR_VERSION < 8 */
4523 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
4524 objv[0], " variable|visibility|window name\"",
4525 (char *) NULL);
4526 #endif
4527
4528 rb_thread_critical = thr_crit_bup;
4529 #endif
4530
4531 Tcl_Release(interp);
4532 return TCL_ERROR;
4533 }
4534
4535 #if TCL_MAJOR_VERSION >= 8
4536 thr_crit_bup = rb_thread_critical;
4537 rb_thread_critical = Qtrue;
4538
4539 /*
4540 if (Tcl_GetIndexFromObj(interp, objv[1],
4541 (CONST84 char **)optionStrings,
4542 "option", 0, &index) != TCL_OK) {
4543 return TCL_ERROR;
4544 }
4545 */
4546 ret = Tcl_GetIndexFromObj(interp, objv[1],
4547 (CONST84 char **)optionStrings,
4548 "option", 0, &index);
4549
4550 rb_thread_critical = thr_crit_bup;
4551
4552 if (ret != TCL_OK) {
4553 Tcl_Release(interp);
4554 return TCL_ERROR;
4555 }
4556 #else /* TCL_MAJOR_VERSION < 8 */
4557 {
4558 int c = objv[1][0];
4559 size_t length = strlen(objv[1]);
4560
4561 if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0)
4562 && (length >= 2)) {
4563 index = TKWAIT_VARIABLE;
4564 } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0)
4565 && (length >= 2)) {
4566 index = TKWAIT_VISIBILITY;
4567 } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) {
4568 index = TKWAIT_WINDOW;
4569 } else {
4570 Tcl_AppendResult(interp, "bad option \"", objv[1],
4571 "\": must be variable, visibility, or window",
4572 (char *) NULL);
4573 Tcl_Release(interp);
4574 return TCL_ERROR;
4575 }
4576 }
4577 #endif
4578
4579 thr_crit_bup = rb_thread_critical;
4580 rb_thread_critical = Qtrue;
4581
4582 #if TCL_MAJOR_VERSION >= 8
4583 Tcl_IncrRefCount(objv[2]);
4584 /* nameString = Tcl_GetString(objv[2]); */
4585 nameString = Tcl_GetStringFromObj(objv[2], &dummy);
4586 #else /* TCL_MAJOR_VERSION < 8 */
4587 nameString = objv[2];
4588 #endif
4589
4590 rb_thread_critical = thr_crit_bup;
4591
4592 switch ((enum options) index) {
4593 case TKWAIT_VARIABLE:
4594 thr_crit_bup = rb_thread_critical;
4595 rb_thread_critical = Qtrue;
4596 /*
4597 if (Tcl_TraceVar(interp, nameString,
4598 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
4599 WaitVariableProc, (ClientData) &done) != TCL_OK) {
4600 return TCL_ERROR;
4601 }
4602 */
4603 ret = Tcl_TraceVar(interp, nameString,
4604 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
4605 WaitVariableProc, (ClientData) &done);
4606
4607 rb_thread_critical = thr_crit_bup;
4608
4609 if (ret != TCL_OK) {
4610 #if TCL_MAJOR_VERSION >= 8
4611 Tcl_DecrRefCount(objv[2]);
4612 #endif
4613 Tcl_Release(interp);
4614 return TCL_ERROR;
4615 }
4616
4617 done = 0;
4618 /* lib_eventloop_core(check_rootwidget_flag, 0, &done); */
4619 lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp);
4620
4621 thr_crit_bup = rb_thread_critical;
4622 rb_thread_critical = Qtrue;
4623
4624 Tcl_UntraceVar(interp, nameString,
4625 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
4626 WaitVariableProc, (ClientData) &done);
4627
4628 #if TCL_MAJOR_VERSION >= 8
4629 Tcl_DecrRefCount(objv[2]);
4630 #endif
4631
4632 rb_thread_critical = thr_crit_bup;
4633
4634 /* exception check */
4635 if (!NIL_P(rbtk_pending_exception)) {
4636 Tcl_Release(interp);
4637
4638 /*
4639 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
4640 */
4641 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
4642 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
4643 return TCL_RETURN;
4644 } else{
4645 return TCL_ERROR;
4646 }
4647 }
4648
4649 /* trap check */
4650 #ifdef RUBY_VM
4651 if (rb_thread_check_trap_pending()) {
4652 #else
4653 if (rb_trap_pending) {
4654 #endif
4655 Tcl_Release(interp);
4656
4657 return TCL_RETURN;
4658 }
4659
4660 break;
4661
4662 case TKWAIT_VISIBILITY:
4663 thr_crit_bup = rb_thread_critical;
4664 rb_thread_critical = Qtrue;
4665
4666 /* This function works on the Tk eventloop thread only. */
4667 if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
4668 window = NULL;
4669 } else {
4670 window = Tk_NameToWindow(interp, nameString, tkwin);
4671 }
4672
4673 if (window == NULL) {
4674 Tcl_AppendResult(interp, ": tkwait: ",
4675 "no main-window (not Tk application?)",
4676 (char*)NULL);
4677 rb_thread_critical = thr_crit_bup;
4678 #if TCL_MAJOR_VERSION >= 8
4679 Tcl_DecrRefCount(objv[2]);
4680 #endif
4681 Tcl_Release(interp);
4682 return TCL_ERROR;
4683 }
4684
4685 Tk_CreateEventHandler(window,
4686 VisibilityChangeMask|StructureNotifyMask,
4687 WaitVisibilityProc, (ClientData) &done);
4688
4689 rb_thread_critical = thr_crit_bup;
4690
4691 done = 0;
4692 /* lib_eventloop_core(check_rootwidget_flag, 0, &done); */
4693 lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp);
4694
4695 /* exception check */
4696 if (!NIL_P(rbtk_pending_exception)) {
4697 #if TCL_MAJOR_VERSION >= 8
4698 Tcl_DecrRefCount(objv[2]);
4699 #endif
4700 Tcl_Release(interp);
4701
4702 /*
4703 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
4704 */
4705 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
4706 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
4707 return TCL_RETURN;
4708 } else{
4709 return TCL_ERROR;
4710 }
4711 }
4712
4713 /* trap check */
4714 #ifdef RUBY_VM
4715 if (rb_thread_check_trap_pending()) {
4716 #else
4717 if (rb_trap_pending) {
4718 #endif
4719 #if TCL_MAJOR_VERSION >= 8
4720 Tcl_DecrRefCount(objv[2]);
4721 #endif
4722 Tcl_Release(interp);
4723
4724 return TCL_RETURN;
4725 }
4726
4727 if (done != 1) {
4728 /*
4729 * Note that we do not delete the event handler because it
4730 * was deleted automatically when the window was destroyed.
4731 */
4732 thr_crit_bup = rb_thread_critical;
4733 rb_thread_critical = Qtrue;
4734
4735 Tcl_ResetResult(interp);
4736 Tcl_AppendResult(interp, "window \"", nameString,
4737 "\" was deleted before its visibility changed",
4738 (char *) NULL);
4739
4740 rb_thread_critical = thr_crit_bup;
4741
4742 #if TCL_MAJOR_VERSION >= 8
4743 Tcl_DecrRefCount(objv[2]);
4744 #endif
4745 Tcl_Release(interp);
4746 return TCL_ERROR;
4747 }
4748
4749 thr_crit_bup = rb_thread_critical;
4750 rb_thread_critical = Qtrue;
4751
4752 #if TCL_MAJOR_VERSION >= 8
4753 Tcl_DecrRefCount(objv[2]);
4754 #endif
4755
4756 Tk_DeleteEventHandler(window,
4757 VisibilityChangeMask|StructureNotifyMask,
4758 WaitVisibilityProc, (ClientData) &done);
4759
4760 rb_thread_critical = thr_crit_bup;
4761
4762 break;
4763
4764 case TKWAIT_WINDOW:
4765 thr_crit_bup = rb_thread_critical;
4766 rb_thread_critical = Qtrue;
4767
4768 /* This function works on the Tk eventloop thread only. */
4769 if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
4770 window = NULL;
4771 } else {
4772 window = Tk_NameToWindow(interp, nameString, tkwin);
4773 }
4774
4775 #if TCL_MAJOR_VERSION >= 8
4776 Tcl_DecrRefCount(objv[2]);
4777 #endif
4778
4779 if (window == NULL) {
4780 Tcl_AppendResult(interp, ": tkwait: ",
4781 "no main-window (not Tk application?)",
4782 (char*)NULL);
4783 rb_thread_critical = thr_crit_bup;
4784 Tcl_Release(interp);
4785 return TCL_ERROR;
4786 }
4787
4788 Tk_CreateEventHandler(window, StructureNotifyMask,
4789 WaitWindowProc, (ClientData) &done);
4790
4791 rb_thread_critical = thr_crit_bup;
4792
4793 done = 0;
4794 /* lib_eventloop_core(check_rootwidget_flag, 0, &done); */
4795 lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp);
4796
4797 /* exception check */
4798 if (!NIL_P(rbtk_pending_exception)) {
4799 Tcl_Release(interp);
4800
4801 /*
4802 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
4803 */
4804 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
4805 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
4806 return TCL_RETURN;
4807 } else{
4808 return TCL_ERROR;
4809 }
4810 }
4811
4812 /* trap check */
4813 #ifdef RUBY_VM
4814 if (rb_thread_check_trap_pending()) {
4815 #else
4816 if (rb_trap_pending) {
4817 #endif
4818 Tcl_Release(interp);
4819
4820 return TCL_RETURN;
4821 }
4822
4823 /*
4824 * Note: there's no need to delete the event handler. It was
4825 * deleted automatically when the window was destroyed.
4826 */
4827 break;
4828 }
4829
4830 /*
4831 * Clear out the interpreter's result, since it may have been set
4832 * by event handlers.
4833 */
4834
4835 Tcl_ResetResult(interp);
4836 Tcl_Release(interp);
4837 return TCL_OK;
4838 }
4839
4840 /****************************/
4841 /* vwait/tkwait with thread */
4842 /****************************/
4843 struct th_vwait_param {
4844 VALUE thread;
4845 int done;
4846 };
4847
4848 #if TCL_MAJOR_VERSION >= 8
4849 static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *,
4850 CONST84 char *,CONST84 char *, int));
4851 static char *
4852 rb_threadVwaitProc(clientData, interp, name1, name2, flags)
4853 ClientData clientData; /* Pointer to integer to set to 1. */
4854 Tcl_Interp *interp; /* Interpreter containing variable. */
4855 CONST84 char *name1; /* Name of variable. */
4856 CONST84 char *name2; /* Second part of variable name. */
4857 int flags; /* Information about what happened. */
4858 #else /* TCL_MAJOR_VERSION < 8 */
4859 static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *,
4860 char *, char *, int));
4861 static char *
4862 rb_threadVwaitProc(clientData, interp, name1, name2, flags)
4863 ClientData clientData; /* Pointer to integer to set to 1. */
4864 Tcl_Interp *interp; /* Interpreter containing variable. */
4865 char *name1; /* Name of variable. */
4866 char *name2; /* Second part of variable name. */
4867 int flags; /* Information about what happened. */
4868 #endif
4869 {
4870 struct th_vwait_param *param = (struct th_vwait_param *) clientData;
4871
4872 if (flags & (TCL_INTERP_DESTROYED | TCL_TRACE_DESTROYED)) {
4873 param->done = -1;
4874 } else {
4875 param->done = 1;
4876 }
4877 if (param->done != 0) rb_thread_wakeup(param->thread);
4878
4879 return (char *)NULL;
4880 }
4881
4882 #define TKWAIT_MODE_VISIBILITY 1
4883 #define TKWAIT_MODE_DESTROY 2
4884
4885 static void rb_threadWaitVisibilityProc _((ClientData, XEvent *));
4886 static void
4887 rb_threadWaitVisibilityProc(clientData, eventPtr)
4888 ClientData clientData; /* Pointer to integer to set to 1. */
4889 XEvent *eventPtr; /* Information about event (not used). */
4890 {
4891 struct th_vwait_param *param = (struct th_vwait_param *) clientData;
4892
4893 if (eventPtr->type == VisibilityNotify) {
4894 param->done = TKWAIT_MODE_VISIBILITY;
4895 }
4896 if (eventPtr->type == DestroyNotify) {
4897 param->done = TKWAIT_MODE_DESTROY;
4898 }
4899 if (param->done != 0) rb_thread_wakeup(param->thread);
4900 }
4901
4902 static void rb_threadWaitWindowProc _((ClientData, XEvent *));
4903 static void
4904 rb_threadWaitWindowProc(clientData, eventPtr)
4905 ClientData clientData; /* Pointer to integer to set to 1. */
4906 XEvent *eventPtr; /* Information about event. */
4907 {
4908 struct th_vwait_param *param = (struct th_vwait_param *) clientData;
4909
4910 if (eventPtr->type == DestroyNotify) {
4911 param->done = TKWAIT_MODE_DESTROY;
4912 }
4913 if (param->done != 0) rb_thread_wakeup(param->thread);
4914 }
4915
4916 #if TCL_MAJOR_VERSION >= 8
4917 static int
4918 ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv)
4919 ClientData clientData;
4920 Tcl_Interp *interp;
4921 int objc;
4922 Tcl_Obj *CONST objv[];
4923 #else /* TCL_MAJOR_VERSION < 8 */
4924 static int
4925 ip_rb_threadVwaitCommand(clientData, interp, objc, objv)
4926 ClientData clientData; /* Not used */
4927 Tcl_Interp *interp;
4928 int objc;
4929 char *objv[];
4930 #endif
4931 {
4932 struct th_vwait_param *param;
4933 char *nameString;
4934 int ret, dummy;
4935 int thr_crit_bup;
4936 volatile VALUE current_thread = rb_thread_current();
4937 struct timeval t;
4938
4939 DUMP1("Ruby's 'thread_vwait' is called");
4940 if (interp == (Tcl_Interp*)NULL) {
4941 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
4942 "IP is deleted");
4943 return TCL_ERROR;
4944 }
4945
4946 if (rb_thread_alone() || eventloop_thread == current_thread) {
4947 #if TCL_MAJOR_VERSION >= 8
4948 DUMP1("call ip_rbVwaitObjCmd");
4949 return ip_rbVwaitObjCmd(clientData, interp, objc, objv);
4950 #else /* TCL_MAJOR_VERSION < 8 */
4951 DUMP1("call ip_rbVwaitCommand");
4952 return ip_rbVwaitCommand(clientData, interp, objc, objv);
4953 #endif
4954 }
4955
4956 Tcl_Preserve(interp);
4957 Tcl_ResetResult(interp);
4958
4959 if (objc != 2) {
4960 #ifdef Tcl_WrongNumArgs
4961 Tcl_WrongNumArgs(interp, 1, objv, "name");
4962 #else
4963 thr_crit_bup = rb_thread_critical;
4964 rb_thread_critical = Qtrue;
4965
4966 #if TCL_MAJOR_VERSION >= 8
4967 /* nameString = Tcl_GetString(objv[0]); */
4968 nameString = Tcl_GetStringFromObj(objv[0], &dummy);
4969 #else /* TCL_MAJOR_VERSION < 8 */
4970 nameString = objv[0];
4971 #endif
4972 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
4973 nameString, " name\"", (char *) NULL);
4974
4975 rb_thread_critical = thr_crit_bup;
4976 #endif
4977
4978 Tcl_Release(interp);
4979 return TCL_ERROR;
4980 }
4981
4982 #if TCL_MAJOR_VERSION >= 8
4983 Tcl_IncrRefCount(objv[1]);
4984 /* nameString = Tcl_GetString(objv[1]); */
4985 nameString = Tcl_GetStringFromObj(objv[1], &dummy);
4986 #else /* TCL_MAJOR_VERSION < 8 */
4987 nameString = objv[1];
4988 #endif
4989 thr_crit_bup = rb_thread_critical;
4990 rb_thread_critical = Qtrue;
4991
4992 /* param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); */
4993 param = RbTk_ALLOC_N(struct th_vwait_param, 1);
4994 #if 1 /* use Tcl_Preserve/Release */
4995 Tcl_Preserve((ClientData)param);
4996 #endif
4997 param->thread = current_thread;
4998 param->done = 0;
4999
5000 /*
5001 if (Tcl_TraceVar(interp, nameString,
5002 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
5003 rb_threadVwaitProc, (ClientData) param) != TCL_OK) {
5004 return TCL_ERROR;
5005 }
5006 */
5007 ret = Tcl_TraceVar(interp, nameString,
5008 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
5009 rb_threadVwaitProc, (ClientData) param);
5010
5011 rb_thread_critical = thr_crit_bup;
5012
5013 if (ret != TCL_OK) {
5014 #if 0 /* use Tcl_EventuallyFree */
5015 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
5016 #else
5017 #if 1 /* use Tcl_Preserve/Release */
5018 Tcl_Release((ClientData)param);
5019 #else
5020 /* Tcl_Free((char *)param); */
5021 ckfree((char *)param);
5022 #endif
5023 #endif
5024
5025 #if TCL_MAJOR_VERSION >= 8
5026 Tcl_DecrRefCount(objv[1]);
5027 #endif
5028 Tcl_Release(interp);
5029 return TCL_ERROR;
5030 }
5031
5032 t.tv_sec = 0;
5033 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
5034
5035 while(!param->done) {
5036 /* rb_thread_stop(); */
5037 /* rb_thread_sleep_forever(); */
5038 rb_thread_wait_for(t);
5039 if (NIL_P(eventloop_thread)) {
5040 break;
5041 }
5042 }
5043
5044 thr_crit_bup = rb_thread_critical;
5045 rb_thread_critical = Qtrue;
5046
5047 if (param->done > 0) {
5048 Tcl_UntraceVar(interp, nameString,
5049 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
5050 rb_threadVwaitProc, (ClientData) param);
5051 }
5052
5053 #if 0 /* use Tcl_EventuallyFree */
5054 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
5055 #else
5056 #if 1 /* use Tcl_Preserve/Release */
5057 Tcl_Release((ClientData)param);
5058 #else
5059 /* Tcl_Free((char *)param); */
5060 ckfree((char *)param);
5061 #endif
5062 #endif
5063
5064 rb_thread_critical = thr_crit_bup;
5065
5066 #if TCL_MAJOR_VERSION >= 8
5067 Tcl_DecrRefCount(objv[1]);
5068 #endif
5069 Tcl_Release(interp);
5070 return TCL_OK;
5071 }
5072
5073 #if TCL_MAJOR_VERSION >= 8
5074 static int
5075 ip_rb_threadTkWaitObjCmd(clientData, interp, objc, objv)
5076 ClientData clientData;
5077 Tcl_Interp *interp;
5078 int objc;
5079 Tcl_Obj *CONST objv[];
5080 #else /* TCL_MAJOR_VERSION < 8 */
5081 static int
5082 ip_rb_threadTkWaitCommand(clientData, interp, objc, objv)
5083 ClientData clientData;
5084 Tcl_Interp *interp;
5085 int objc;
5086 char *objv[];
5087 #endif
5088 {
5089 struct th_vwait_param *param;
5090 Tk_Window tkwin = (Tk_Window) clientData;
5091 Tk_Window window;
5092 int index;
5093 static CONST char *optionStrings[] = { "variable", "visibility", "window",
5094 (char *) NULL };
5095 enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW };
5096 char *nameString;
5097 int ret, dummy;
5098 int thr_crit_bup;
5099 volatile VALUE current_thread = rb_thread_current();
5100 struct timeval t;
5101
5102 DUMP1("Ruby's 'thread_tkwait' is called");
5103 if (interp == (Tcl_Interp*)NULL) {
5104 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
5105 "IP is deleted");
5106 return TCL_ERROR;
5107 }
5108
5109 if (rb_thread_alone() || eventloop_thread == current_thread) {
5110 #if TCL_MAJOR_VERSION >= 8
5111 DUMP1("call ip_rbTkWaitObjCmd");
5112 DUMP2("eventloop_thread %lx", eventloop_thread);
5113 DUMP2("current_thread %lx", current_thread);
5114 return ip_rbTkWaitObjCmd(clientData, interp, objc, objv);
5115 #else /* TCL_MAJOR_VERSION < 8 */
5116 DUMP1("call rb_VwaitCommand");
5117 return ip_rbTkWaitCommand(clientData, interp, objc, objv);
5118 #endif
5119 }
5120
5121 Tcl_Preserve(interp);
5122 Tcl_Preserve(tkwin);
5123
5124 Tcl_ResetResult(interp);
5125
5126 if (objc != 3) {
5127 #ifdef Tcl_WrongNumArgs
5128 Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name");
5129 #else
5130 thr_crit_bup = rb_thread_critical;
5131 rb_thread_critical = Qtrue;
5132
5133 #if TCL_MAJOR_VERSION >= 8
5134 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
5135 Tcl_GetStringFromObj(objv[0], &dummy),
5136 " variable|visibility|window name\"",
5137 (char *) NULL);
5138 #else /* TCL_MAJOR_VERSION < 8 */
5139 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
5140 objv[0], " variable|visibility|window name\"",
5141 (char *) NULL);
5142 #endif
5143
5144 rb_thread_critical = thr_crit_bup;
5145 #endif
5146
5147 Tcl_Release(tkwin);
5148 Tcl_Release(interp);
5149 return TCL_ERROR;
5150 }
5151
5152 #if TCL_MAJOR_VERSION >= 8
5153 thr_crit_bup = rb_thread_critical;
5154 rb_thread_critical = Qtrue;
5155 /*
5156 if (Tcl_GetIndexFromObj(interp, objv[1],
5157 (CONST84 char **)optionStrings,
5158 "option", 0, &index) != TCL_OK) {
5159 return TCL_ERROR;
5160 }
5161 */
5162 ret = Tcl_GetIndexFromObj(interp, objv[1],
5163 (CONST84 char **)optionStrings,
5164 "option", 0, &index);
5165
5166 rb_thread_critical = thr_crit_bup;
5167
5168 if (ret != TCL_OK) {
5169 Tcl_Release(tkwin);
5170 Tcl_Release(interp);
5171 return TCL_ERROR;
5172 }
5173 #else /* TCL_MAJOR_VERSION < 8 */
5174 {
5175 int c = objv[1][0];
5176 size_t length = strlen(objv[1]);
5177
5178 if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0)
5179 && (length >= 2)) {
5180 index = TKWAIT_VARIABLE;
5181 } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0)
5182 && (length >= 2)) {
5183 index = TKWAIT_VISIBILITY;
5184 } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) {
5185 index = TKWAIT_WINDOW;
5186 } else {
5187 Tcl_AppendResult(interp, "bad option \"", objv[1],
5188 "\": must be variable, visibility, or window",
5189 (char *) NULL);
5190 Tcl_Release(tkwin);
5191 Tcl_Release(interp);
5192 return TCL_ERROR;
5193 }
5194 }
5195 #endif
5196
5197 thr_crit_bup = rb_thread_critical;
5198 rb_thread_critical = Qtrue;
5199
5200 #if TCL_MAJOR_VERSION >= 8
5201 Tcl_IncrRefCount(objv[2]);
5202 /* nameString = Tcl_GetString(objv[2]); */
5203 nameString = Tcl_GetStringFromObj(objv[2], &dummy);
5204 #else /* TCL_MAJOR_VERSION < 8 */
5205 nameString = objv[2];
5206 #endif
5207
5208 /* param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); */
5209 param = RbTk_ALLOC_N(struct th_vwait_param, 1);
5210 #if 1 /* use Tcl_Preserve/Release */
5211 Tcl_Preserve((ClientData)param);
5212 #endif
5213 param->thread = current_thread;
5214 param->done = 0;
5215
5216 rb_thread_critical = thr_crit_bup;
5217
5218 switch ((enum options) index) {
5219 case TKWAIT_VARIABLE:
5220 thr_crit_bup = rb_thread_critical;
5221 rb_thread_critical = Qtrue;
5222 /*
5223 if (Tcl_TraceVar(interp, nameString,
5224 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
5225 rb_threadVwaitProc, (ClientData) param) != TCL_OK) {
5226 return TCL_ERROR;
5227 }
5228 */
5229 ret = Tcl_TraceVar(interp, nameString,
5230 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
5231 rb_threadVwaitProc, (ClientData) param);
5232
5233 rb_thread_critical = thr_crit_bup;
5234
5235 if (ret != TCL_OK) {
5236 #if 0 /* use Tcl_EventuallyFree */
5237 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
5238 #else
5239 #if 1 /* use Tcl_Preserve/Release */
5240 Tcl_Release(param);
5241 #else
5242 /* Tcl_Free((char *)param); */
5243 ckfree((char *)param);
5244 #endif
5245 #endif
5246
5247 #if TCL_MAJOR_VERSION >= 8
5248 Tcl_DecrRefCount(objv[2]);
5249 #endif
5250
5251 Tcl_Release(tkwin);
5252 Tcl_Release(interp);
5253 return TCL_ERROR;
5254 }
5255
5256 t.tv_sec = 0;
5257 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
5258
5259 while(!param->done) {
5260 /* rb_thread_stop(); */
5261 /* rb_thread_sleep_forever(); */
5262 rb_thread_wait_for(t);
5263 if (NIL_P(eventloop_thread)) {
5264 break;
5265 }
5266 }
5267
5268 thr_crit_bup = rb_thread_critical;
5269 rb_thread_critical = Qtrue;
5270
5271 if (param->done > 0) {
5272 Tcl_UntraceVar(interp, nameString,
5273 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
5274 rb_threadVwaitProc, (ClientData) param);
5275 }
5276
5277 #if TCL_MAJOR_VERSION >= 8
5278 Tcl_DecrRefCount(objv[2]);
5279 #endif
5280
5281 rb_thread_critical = thr_crit_bup;
5282
5283 break;
5284
5285 case TKWAIT_VISIBILITY:
5286 thr_crit_bup = rb_thread_critical;
5287 rb_thread_critical = Qtrue;
5288
5289 #if 0 /* variable 'tkwin' must keep the token of MainWindow */
5290 if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
5291 window = NULL;
5292 } else {
5293 window = Tk_NameToWindow(interp, nameString, tkwin);
5294 }
5295 #else
5296 if (!tk_stubs_init_p() || tkwin == (Tk_Window)NULL) {
5297 window = NULL;
5298 } else {
5299 /* Tk_NameToWindow() returns right token on non-eventloop thread */
5300 Tcl_CmdInfo info;
5301 if (Tcl_GetCommandInfo(interp, ".", &info)) { /* check root */
5302 window = Tk_NameToWindow(interp, nameString, tkwin);
5303 } else {
5304 window = NULL;
5305 }
5306 }
5307 #endif
5308
5309 if (window == NULL) {
5310 Tcl_AppendResult(interp, ": thread_tkwait: ",
5311 "no main-window (not Tk application?)",
5312 (char*)NULL);
5313
5314 rb_thread_critical = thr_crit_bup;
5315
5316 #if 0 /* use Tcl_EventuallyFree */
5317 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
5318 #else
5319 #if 1 /* use Tcl_Preserve/Release */
5320 Tcl_Release(param);
5321 #else
5322 /* Tcl_Free((char *)param); */
5323 ckfree((char *)param);
5324 #endif
5325 #endif
5326
5327 #if TCL_MAJOR_VERSION >= 8
5328 Tcl_DecrRefCount(objv[2]);
5329 #endif
5330 Tcl_Release(tkwin);
5331 Tcl_Release(interp);
5332 return TCL_ERROR;
5333 }
5334 Tcl_Preserve(window);
5335
5336 Tk_CreateEventHandler(window,
5337 VisibilityChangeMask|StructureNotifyMask,
5338 rb_threadWaitVisibilityProc, (ClientData) param);
5339
5340 rb_thread_critical = thr_crit_bup;
5341
5342 t.tv_sec = 0;
5343 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
5344
5345 while(param->done != TKWAIT_MODE_VISIBILITY) {
5346 if (param->done == TKWAIT_MODE_DESTROY) break;
5347 /* rb_thread_stop(); */
5348 /* rb_thread_sleep_forever(); */
5349 rb_thread_wait_for(t);
5350 if (NIL_P(eventloop_thread)) {
5351 break;
5352 }
5353 }
5354
5355 thr_crit_bup = rb_thread_critical;
5356 rb_thread_critical = Qtrue;
5357
5358 /* when a window is destroyed, no need to call Tk_DeleteEventHandler */
5359 if (param->done != TKWAIT_MODE_DESTROY) {
5360 Tk_DeleteEventHandler(window,
5361 VisibilityChangeMask|StructureNotifyMask,
5362 rb_threadWaitVisibilityProc,
5363 (ClientData) param);
5364 }
5365
5366 if (param->done != 1) {
5367 Tcl_ResetResult(interp);
5368 Tcl_AppendResult(interp, "window \"", nameString,
5369 "\" was deleted before its visibility changed",
5370 (char *) NULL);
5371
5372 rb_thread_critical = thr_crit_bup;
5373
5374 Tcl_Release(window);
5375
5376 #if 0 /* use Tcl_EventuallyFree */
5377 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
5378 #else
5379 #if 1 /* use Tcl_Preserve/Release */
5380 Tcl_Release(param);
5381 #else
5382 /* Tcl_Free((char *)param); */
5383 ckfree((char *)param);
5384 #endif
5385 #endif
5386
5387 #if TCL_MAJOR_VERSION >= 8
5388 Tcl_DecrRefCount(objv[2]);
5389 #endif
5390
5391 Tcl_Release(tkwin);
5392 Tcl_Release(interp);
5393 return TCL_ERROR;
5394 }
5395
5396 Tcl_Release(window);
5397
5398 #if TCL_MAJOR_VERSION >= 8
5399 Tcl_DecrRefCount(objv[2]);
5400 #endif
5401
5402 rb_thread_critical = thr_crit_bup;
5403
5404 break;
5405
5406 case TKWAIT_WINDOW:
5407 thr_crit_bup = rb_thread_critical;
5408 rb_thread_critical = Qtrue;
5409
5410 #if 0 /* variable 'tkwin' must keep the token of MainWindow */
5411 if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
5412 window = NULL;
5413 } else {
5414 window = Tk_NameToWindow(interp, nameString, tkwin);
5415 }
5416 #else
5417 if (!tk_stubs_init_p() || tkwin == (Tk_Window)NULL) {
5418 window = NULL;
5419 } else {
5420 /* Tk_NameToWindow() returns right token on non-eventloop thread */
5421 Tcl_CmdInfo info;
5422 if (Tcl_GetCommandInfo(interp, ".", &info)) { /* check root */
5423 window = Tk_NameToWindow(interp, nameString, tkwin);
5424 } else {
5425 window = NULL;
5426 }
5427 }
5428 #endif
5429
5430 #if TCL_MAJOR_VERSION >= 8
5431 Tcl_DecrRefCount(objv[2]);
5432 #endif
5433
5434 if (window == NULL) {
5435 Tcl_AppendResult(interp, ": thread_tkwait: ",
5436 "no main-window (not Tk application?)",
5437 (char*)NULL);
5438
5439 rb_thread_critical = thr_crit_bup;
5440
5441 #if 0 /* use Tcl_EventuallyFree */
5442 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
5443 #else
5444 #if 1 /* use Tcl_Preserve/Release */
5445 Tcl_Release(param);
5446 #else
5447 /* Tcl_Free((char *)param); */
5448 ckfree((char *)param);
5449 #endif
5450 #endif
5451
5452 Tcl_Release(tkwin);
5453 Tcl_Release(interp);
5454 return TCL_ERROR;
5455 }
5456
5457 Tcl_Preserve(window);
5458
5459 Tk_CreateEventHandler(window, StructureNotifyMask,
5460 rb_threadWaitWindowProc, (ClientData) param);
5461
5462 rb_thread_critical = thr_crit_bup;
5463
5464 t.tv_sec = 0;
5465 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
5466
5467 while(param->done != TKWAIT_MODE_DESTROY) {
5468 /* rb_thread_stop(); */
5469 /* rb_thread_sleep_forever(); */
5470 rb_thread_wait_for(t);
5471 if (NIL_P(eventloop_thread)) {
5472 break;
5473 }
5474 }
5475
5476 Tcl_Release(window);
5477
5478 /* when a window is destroyed, no need to call Tk_DeleteEventHandler
5479 thr_crit_bup = rb_thread_critical;
5480 rb_thread_critical = Qtrue;
5481
5482 Tk_DeleteEventHandler(window, StructureNotifyMask,
5483 rb_threadWaitWindowProc, (ClientData) param);
5484
5485 rb_thread_critical = thr_crit_bup;
5486 */
5487
5488 break;
5489 } /* end of 'switch' statement */
5490
5491 #if 0 /* use Tcl_EventuallyFree */
5492 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
5493 #else
5494 #if 1 /* use Tcl_Preserve/Release */
5495 Tcl_Release((ClientData)param);
5496 #else
5497 /* Tcl_Free((char *)param); */
5498 ckfree((char *)param);
5499 #endif
5500 #endif
5501
5502 /*
5503 * Clear out the interpreter's result, since it may have been set
5504 * by event handlers.
5505 */
5506
5507 Tcl_ResetResult(interp);
5508
5509 Tcl_Release(tkwin);
5510 Tcl_Release(interp);
5511 return TCL_OK;
5512 }
5513
5514 static VALUE
5515 ip_thread_vwait(self, var)
5516 VALUE self;
5517 VALUE var;
5518 {
5519 VALUE argv[2];
5520 volatile VALUE cmd_str = rb_str_new2("thread_vwait");
5521
5522 argv[0] = cmd_str;
5523 argv[1] = var;
5524
5525 return ip_invoke_with_position(2, argv, self, TCL_QUEUE_TAIL);
5526 }
5527
5528 static VALUE
5529 ip_thread_tkwait(self, mode, target)
5530 VALUE self;
5531 VALUE mode;
5532 VALUE target;
5533 {
5534 VALUE argv[3];
5535 volatile VALUE cmd_str = rb_str_new2("thread_tkwait");
5536
5537 argv[0] = cmd_str;
5538 argv[1] = mode;
5539 argv[2] = target;
5540
5541 return ip_invoke_with_position(3, argv, self, TCL_QUEUE_TAIL);
5542 }
5543
5544
5545 /* delete slave interpreters */
5546 #if TCL_MAJOR_VERSION >= 8
5547 static void
5548 delete_slaves(ip)
5549 Tcl_Interp *ip;
5550 {
5551 int thr_crit_bup;
5552 Tcl_Interp *slave;
5553 Tcl_Obj *slave_list, *elem;
5554 char *slave_name;
5555 int i, len;
5556
5557 DUMP1("delete slaves");
5558 thr_crit_bup = rb_thread_critical;
5559 rb_thread_critical = Qtrue;
5560
5561 if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) {
5562 slave_list = Tcl_GetObjResult(ip);
5563 Tcl_IncrRefCount(slave_list);
5564
5565 if (Tcl_ListObjLength((Tcl_Interp*)NULL, slave_list, &len) == TCL_OK) {
5566 for(i = 0; i < len; i++) {
5567 Tcl_ListObjIndex((Tcl_Interp*)NULL, slave_list, i, &elem);
5568
5569 if (elem == (Tcl_Obj*)NULL) continue;
5570
5571 Tcl_IncrRefCount(elem);
5572
5573 /* get slave */
5574 /* slave_name = Tcl_GetString(elem); */
5575 slave_name = Tcl_GetStringFromObj(elem, (int*)NULL);
5576 DUMP2("delete slave:'%s'", slave_name);
5577
5578 Tcl_DecrRefCount(elem);
5579
5580 slave = Tcl_GetSlave(ip, slave_name);
5581 if (slave == (Tcl_Interp*)NULL) continue;
5582
5583 if (!Tcl_InterpDeleted(slave)) {
5584 /* call ip_finalize */
5585 ip_finalize(slave);
5586
5587 Tcl_DeleteInterp(slave);
5588 /* Tcl_Release(slave); */
5589 }
5590 }
5591 }
5592
5593 Tcl_DecrRefCount(slave_list);
5594 }
5595
5596 rb_thread_critical = thr_crit_bup;
5597 }
5598 #else /* TCL_MAJOR_VERSION < 8 */
5599 static void
5600 delete_slaves(ip)
5601 Tcl_Interp *ip;
5602 {
5603 int thr_crit_bup;
5604 Tcl_Interp *slave;
5605 int argc;
5606 char **argv;
5607 char *slave_list;
5608 char *slave_name;
5609 int i, len;
5610
5611 DUMP1("delete slaves");
5612 thr_crit_bup = rb_thread_critical;
5613 rb_thread_critical = Qtrue;
5614
5615 if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) {
5616 slave_list = ip->result;
5617 if (Tcl_SplitList((Tcl_Interp*)NULL,
5618 slave_list, &argc, &argv) == TCL_OK) {
5619 for(i = 0; i < argc; i++) {
5620 slave_name = argv[i];
5621
5622 DUMP2("delete slave:'%s'", slave_name);
5623
5624 slave = Tcl_GetSlave(ip, slave_name);
5625 if (slave == (Tcl_Interp*)NULL) continue;
5626
5627 if (!Tcl_InterpDeleted(slave)) {
5628 /* call ip_finalize */
5629 ip_finalize(slave);
5630
5631 Tcl_DeleteInterp(slave);
5632 }
5633 }
5634 }
5635 }
5636
5637 rb_thread_critical = thr_crit_bup;
5638 }
5639 #endif
5640
5641
5642 /* finalize operation */
5643 static void
5644 #ifdef HAVE_PROTOTYPES
5645 lib_mark_at_exit(VALUE self)
5646 #else
5647 lib_mark_at_exit(self)
5648 VALUE self;
5649 #endif
5650 {
5651 at_exit = 1;
5652 }
5653
5654 static int
5655 #if TCL_MAJOR_VERSION >= 8
5656 #ifdef HAVE_PROTOTYPES
5657 ip_null_proc(ClientData clientData, Tcl_Interp *interp,
5658 int argc, Tcl_Obj *CONST argv[])
5659 #else
5660 ip_null_proc(clientData, interp, argc, argv)
5661 ClientData clientData;
5662 Tcl_Interp *interp;
5663 int argc;
5664 Tcl_Obj *CONST argv[];
5665 #endif
5666 #else /* TCL_MAJOR_VERSION < 8 */
5667 #ifdef HAVE_PROTOTYPES
5668 ip_null_proc(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])
5669 #else
5670 ip_null_proc(clientData, interp, argc, argv)
5671 ClientData clientData;
5672 Tcl_Interp *interp;
5673 int argc;
5674 char *argv[];
5675 #endif
5676 #endif
5677 {
5678 Tcl_ResetResult(interp);
5679 return TCL_OK;
5680 }
5681
5682 static void
5683 ip_finalize(ip)
5684 Tcl_Interp *ip;
5685 {
5686 Tcl_CmdInfo info;
5687 int thr_crit_bup;
5688
5689 VALUE rb_debug_bup, rb_verbose_bup;
5690 /* When ruby is exiting, printing debug messages in some callback
5691 operations from Tcl-IP sometimes cause SEGV. I don't know the
5692 reason. But I got SEGV when calling "rb_io_write(rb_stdout, ...)".
5693 So, in some part of this function, debug mode and verbose mode
5694 are disabled. If you know the reason, please fix it.
5695 -- Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp) */
5696
5697 DUMP1("start ip_finalize");
5698
5699 if (ip == (Tcl_Interp*)NULL) {
5700 DUMP1("ip is NULL");
5701 return;
5702 }
5703
5704 if (Tcl_InterpDeleted(ip)) {
5705 DUMP2("ip(%p) is already deleted", ip);
5706 return;
5707 }
5708
5709 #if TCL_NAMESPACE_DEBUG
5710 if (ip_null_namespace(ip)) {
5711 DUMP2("ip(%p) has null namespace", ip);
5712 return;
5713 }
5714 #endif
5715
5716 thr_crit_bup = rb_thread_critical;
5717 rb_thread_critical = Qtrue;
5718
5719 rb_debug_bup = ruby_debug;
5720 rb_verbose_bup = ruby_verbose;
5721
5722 Tcl_Preserve(ip);
5723
5724 /* delete slaves */
5725 delete_slaves(ip);
5726
5727 /* shut off some connections from Tcl-proc to Ruby */
5728 if (at_exit) {
5729 /* NOTE: Only when at exit.
5730 Because, ruby removes objects, which depends on the deleted
5731 interpreter, on some callback operations.
5732 It is important for GC. */
5733 #if TCL_MAJOR_VERSION >= 8
5734 Tcl_CreateObjCommand(ip, "ruby", ip_null_proc,
5735 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
5736 Tcl_CreateObjCommand(ip, "ruby_eval", ip_null_proc,
5737 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
5738 Tcl_CreateObjCommand(ip, "ruby_cmd", ip_null_proc,
5739 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
5740 #else /* TCL_MAJOR_VERSION < 8 */
5741 Tcl_CreateCommand(ip, "ruby", ip_null_proc,
5742 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
5743 Tcl_CreateCommand(ip, "ruby_eval", ip_null_proc,
5744 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
5745 Tcl_CreateCommand(ip, "ruby_cmd", ip_null_proc,
5746 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
5747 #endif
5748 /*
5749 rb_thread_critical = thr_crit_bup;
5750 return;
5751 */
5752 }
5753
5754 /* delete root widget */
5755 #ifdef RUBY_VM
5756 /* cause SEGV on Ruby 1.9 */
5757 #else
5758 DUMP1("check `destroy'");
5759 if (Tcl_GetCommandInfo(ip, "destroy", &info)) {
5760 DUMP1("call `destroy .'");
5761 Tcl_GlobalEval(ip, "catch {destroy .}");
5762 }
5763 #endif
5764 #if 1
5765 DUMP1("destroy root widget");
5766 if (tk_stubs_init_p() && Tk_MainWindow(ip) != (Tk_Window)NULL) {
5767 /*
5768 * On Ruby VM, this code piece may be not called, because
5769 * Tk_MainWindow() returns NULL on a native thread except
5770 * the thread which initialize Tk environment.
5771 * Of course, that is a problem. But maybe not so serious.
5772 * All widgets are destroyed when the Tcl interp is deleted.
5773 * At then, Ruby may raise exceptions on the delete hook
5774 * callbacks which registered for the deleted widgets, and
5775 * may fail to clear objects which depends on the widgets.
5776 * Although it is the problem, it is possibly avoidable by
5777 * rescuing exceptions and the finalize hook of the interp.
5778 */
5779 Tk_Window win = Tk_MainWindow(ip);
5780
5781 DUMP1("call Tk_DestroyWindow");
5782 ruby_debug = Qfalse;
5783 ruby_verbose = Qnil;
5784 if (! (((Tk_FakeWin*)win)->flags & TK_ALREADY_DEAD)) {
5785 Tk_DestroyWindow(win);
5786 }
5787 ruby_debug = rb_debug_bup;
5788 ruby_verbose = rb_verbose_bup;
5789 }
5790 #endif
5791
5792 /* call finalize-hook-proc */
5793 DUMP1("check `finalize-hook-proc'");
5794 if ( Tcl_GetCommandInfo(ip, finalize_hook_name, &info)) {
5795 DUMP2("call finalize hook proc '%s'", finalize_hook_name);
5796 ruby_debug = Qfalse;
5797 ruby_verbose = Qnil;
5798 Tcl_GlobalEval(ip, finalize_hook_name);
5799 ruby_debug = rb_debug_bup;
5800 ruby_verbose = rb_verbose_bup;
5801 }
5802
5803 DUMP1("check `foreach' & `after'");
5804 if ( Tcl_GetCommandInfo(ip, "foreach", &info)
5805 && Tcl_GetCommandInfo(ip, "after", &info) ) {
5806 DUMP1("cancel after callbacks");
5807 ruby_debug = Qfalse;
5808 ruby_verbose = Qnil;
5809 Tcl_GlobalEval(ip, "catch {foreach id [after info] {after cancel $id}}");
5810 ruby_debug = rb_debug_bup;
5811 ruby_verbose = rb_verbose_bup;
5812 }
5813
5814 Tcl_Release(ip);
5815
5816 DUMP1("finish ip_finalize");
5817 ruby_debug = rb_debug_bup;
5818 ruby_verbose = rb_verbose_bup;
5819 rb_thread_critical = thr_crit_bup;
5820 }
5821
5822
5823 /* destroy interpreter */
5824 static void
5825 ip_free(ptr)
5826 struct tcltkip *ptr;
5827 {
5828 int thr_crit_bup;
5829
5830 DUMP2("free Tcl Interp %lx", (unsigned long)ptr->ip);
5831 if (ptr) {
5832 thr_crit_bup = rb_thread_critical;
5833 rb_thread_critical = Qtrue;
5834
5835 if ( ptr->ip != (Tcl_Interp*)NULL
5836 && !Tcl_InterpDeleted(ptr->ip)
5837 && Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL
5838 && !Tcl_InterpDeleted(Tcl_GetMaster(ptr->ip)) ) {
5839 DUMP2("parent IP(%lx) is not deleted",
5840 (unsigned long)Tcl_GetMaster(ptr->ip));
5841 DUMP2("slave IP(%lx) should not be deleted",
5842 (unsigned long)ptr->ip);
5843 xfree(ptr);
5844 /* ckfree((char*)ptr); */
5845 rb_thread_critical = thr_crit_bup;
5846 return;
5847 }
5848
5849 if (ptr->ip == (Tcl_Interp*)NULL) {
5850 DUMP1("ip_free is called for deleted IP");
5851 xfree(ptr);
5852 /* ckfree((char*)ptr); */
5853 rb_thread_critical = thr_crit_bup;
5854 return;
5855 }
5856
5857 if (!Tcl_InterpDeleted(ptr->ip)) {
5858 ip_finalize(ptr->ip);
5859
5860 Tcl_DeleteInterp(ptr->ip);
5861 Tcl_Release(ptr->ip);
5862 }
5863
5864 ptr->ip = (Tcl_Interp*)NULL;
5865 xfree(ptr);
5866 /* ckfree((char*)ptr); */
5867
5868 rb_thread_critical = thr_crit_bup;
5869 }
5870
5871 DUMP1("complete freeing Tcl Interp");
5872 }
5873
5874
5875 /* create and initialize interpreter */
5876 static VALUE ip_alloc _((VALUE));
5877 static VALUE
5878 ip_alloc(self)
5879 VALUE self;
5880 {
5881 return Data_Wrap_Struct(self, 0, ip_free, 0);
5882 }
5883
5884 static void
5885 ip_replace_wait_commands(interp, mainWin)
5886 Tcl_Interp *interp;
5887 Tk_Window mainWin;
5888 {
5889 /* replace 'vwait' command */
5890 #if TCL_MAJOR_VERSION >= 8
5891 DUMP1("Tcl_CreateObjCommand(\"vwait\")");
5892 Tcl_CreateObjCommand(interp, "vwait", ip_rbVwaitObjCmd,
5893 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
5894 #else /* TCL_MAJOR_VERSION < 8 */
5895 DUMP1("Tcl_CreateCommand(\"vwait\")");
5896 Tcl_CreateCommand(interp, "vwait", ip_rbVwaitCommand,
5897 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
5898 #endif
5899
5900 /* replace 'tkwait' command */
5901 #if TCL_MAJOR_VERSION >= 8
5902 DUMP1("Tcl_CreateObjCommand(\"tkwait\")");
5903 Tcl_CreateObjCommand(interp, "tkwait", ip_rbTkWaitObjCmd,
5904 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
5905 #else /* TCL_MAJOR_VERSION < 8 */
5906 DUMP1("Tcl_CreateCommand(\"tkwait\")");
5907 Tcl_CreateCommand(interp, "tkwait", ip_rbTkWaitCommand,
5908 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
5909 #endif
5910
5911 /* add 'thread_vwait' command */
5912 #if TCL_MAJOR_VERSION >= 8
5913 DUMP1("Tcl_CreateObjCommand(\"thread_vwait\")");
5914 Tcl_CreateObjCommand(interp, "thread_vwait", ip_rb_threadVwaitObjCmd,
5915 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
5916 #else /* TCL_MAJOR_VERSION < 8 */
5917 DUMP1("Tcl_CreateCommand(\"thread_vwait\")");
5918 Tcl_CreateCommand(interp, "thread_vwait", ip_rb_threadVwaitCommand,
5919 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
5920 #endif
5921
5922 /* add 'thread_tkwait' command */
5923 #if TCL_MAJOR_VERSION >= 8
5924 DUMP1("Tcl_CreateObjCommand(\"thread_tkwait\")");
5925 Tcl_CreateObjCommand(interp, "thread_tkwait", ip_rb_threadTkWaitObjCmd,
5926 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
5927 #else /* TCL_MAJOR_VERSION < 8 */
5928 DUMP1("Tcl_CreateCommand(\"thread_tkwait\")");
5929 Tcl_CreateCommand(interp, "thread_tkwait", ip_rb_threadTkWaitCommand,
5930 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
5931 #endif
5932
5933 /* replace 'update' command */
5934 #if TCL_MAJOR_VERSION >= 8
5935 DUMP1("Tcl_CreateObjCommand(\"update\")");
5936 Tcl_CreateObjCommand(interp, "update", ip_rbUpdateObjCmd,
5937 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
5938 #else /* TCL_MAJOR_VERSION < 8 */
5939 DUMP1("Tcl_CreateCommand(\"update\")");
5940 Tcl_CreateCommand(interp, "update", ip_rbUpdateCommand,
5941 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
5942 #endif
5943
5944 /* add 'thread_update' command */
5945 #if TCL_MAJOR_VERSION >= 8
5946 DUMP1("Tcl_CreateObjCommand(\"thread_update\")");
5947 Tcl_CreateObjCommand(interp, "thread_update", ip_rb_threadUpdateObjCmd,
5948 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
5949 #else /* TCL_MAJOR_VERSION < 8 */
5950 DUMP1("Tcl_CreateCommand(\"thread_update\")");
5951 Tcl_CreateCommand(interp, "thread_update", ip_rb_threadUpdateCommand,
5952 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
5953 #endif
5954 }
5955
5956
5957 #if TCL_MAJOR_VERSION >= 8
5958 static int
5959 ip_rb_replaceSlaveTkCmdsObjCmd(clientData, interp, objc, objv)
5960 ClientData clientData;
5961 Tcl_Interp *interp;
5962 int objc;
5963 Tcl_Obj *CONST objv[];
5964 #else /* TCL_MAJOR_VERSION < 8 */
5965 static int
5966 ip_rb_replaceSlaveTkCmdsCommand(clientData, interp, objc, objv)
5967 ClientData clientData;
5968 Tcl_Interp *interp;
5969 int objc;
5970 char *objv[];
5971 #endif
5972 {
5973 char *slave_name;
5974 Tcl_Interp *slave;
5975 Tk_Window mainWin;
5976
5977 if (objc != 2) {
5978 #ifdef Tcl_WrongNumArgs
5979 Tcl_WrongNumArgs(interp, 1, objv, "slave_name");
5980 #else
5981 char *nameString;
5982 #if TCL_MAJOR_VERSION >= 8
5983 nameString = Tcl_GetStringFromObj(objv[0], (int*)NULL);
5984 #else /* TCL_MAJOR_VERSION < 8 */
5985 nameString = objv[0];
5986 #endif
5987 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
5988 nameString, " slave_name\"", (char *) NULL);
5989 #endif
5990 }
5991
5992 #if TCL_MAJOR_VERSION >= 8
5993 slave_name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
5994 #else
5995 slave_name = objv[1];
5996 #endif
5997
5998 slave = Tcl_GetSlave(interp, slave_name);
5999 if (slave == NULL) {
6000 Tcl_AppendResult(interp, "cannot find slave \"",
6001 slave_name, "\"", (char *)NULL);
6002 return TCL_ERROR;
6003 }
6004 mainWin = Tk_MainWindow(slave);
6005
6006 /* replace 'exit' command --> 'interp_exit' command */
6007 #if TCL_MAJOR_VERSION >= 8
6008 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
6009 Tcl_CreateObjCommand(slave, "exit", ip_InterpExitObjCmd,
6010 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6011 #else /* TCL_MAJOR_VERSION < 8 */
6012 DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
6013 Tcl_CreateCommand(slave, "exit", ip_InterpExitCommand,
6014 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6015 #endif
6016
6017 /* replace vwait and tkwait */
6018 ip_replace_wait_commands(slave, mainWin);
6019
6020 return TCL_OK;
6021 }
6022
6023
6024 #if TCL_MAJOR_VERSION >= 8
6025 static int ip_rbNamespaceObjCmd _((ClientData, Tcl_Interp *, int,
6026 Tcl_Obj *CONST []));
6027 static int
6028 ip_rbNamespaceObjCmd(clientData, interp, objc, objv)
6029 ClientData clientData;
6030 Tcl_Interp *interp;
6031 int objc;
6032 Tcl_Obj *CONST objv[];
6033 {
6034 Tcl_CmdInfo info;
6035 int ret;
6036
6037 if (!Tcl_GetCommandInfo(interp, "__orig_namespace_command__", &(info))) {
6038 Tcl_ResetResult(interp);
6039 Tcl_AppendResult(interp,
6040 "invalid command name \"namespace\"", (char*)NULL);
6041 return TCL_ERROR;
6042 }
6043
6044 rbtk_eventloop_depth++;
6045 /* DUMP2("namespace wrapper enter depth == %d", rbtk_eventloop_depth); */
6046
6047 if (info.isNativeObjectProc) {
6048 ret = (*(info.objProc))(info.objClientData, interp, objc, objv);
6049 } else {
6050 /* string interface */
6051 int i;
6052 char **argv;
6053
6054 /* argv = (char **)Tcl_Alloc(sizeof(char *) * (objc + 1)); */
6055 argv = RbTk_ALLOC_N(char *, (objc + 1));
6056 #if 0 /* use Tcl_Preserve/Release */
6057 Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
6058 #endif
6059
6060 for(i = 0; i < objc; i++) {
6061 /* argv[i] = Tcl_GetString(objv[i]); */
6062 argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL);
6063 }
6064 argv[objc] = (char *)NULL;
6065
6066 ret = (*(info.proc))(info.clientData, interp,
6067 objc, (CONST84 char **)argv);
6068
6069 #if 0 /* use Tcl_EventuallyFree */
6070 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
6071 #else
6072 #if 0 /* use Tcl_Preserve/Release */
6073 Tcl_Release((ClientData)argv); /* XXXXXXXX */
6074 #else
6075 /* Tcl_Free((char*)argv); */
6076 ckfree((char*)argv);
6077 #endif
6078 #endif
6079 }
6080
6081 /* DUMP2("namespace wrapper exit depth == %d", rbtk_eventloop_depth); */
6082 rbtk_eventloop_depth--;
6083
6084 return ret;
6085 }
6086 #endif
6087
6088 static void
6089 ip_wrap_namespace_command(interp)
6090 Tcl_Interp *interp;
6091 {
6092 #if TCL_MAJOR_VERSION >= 8
6093 Tcl_CmdInfo orig_info;
6094
6095 if (!Tcl_GetCommandInfo(interp, "namespace", &(orig_info))) {
6096 return;
6097 }
6098
6099 if (orig_info.isNativeObjectProc) {
6100 Tcl_CreateObjCommand(interp, "__orig_namespace_command__",
6101 orig_info.objProc, orig_info.objClientData,
6102 orig_info.deleteProc);
6103 } else {
6104 Tcl_CreateCommand(interp, "__orig_namespace_command__",
6105 orig_info.proc, orig_info.clientData,
6106 orig_info.deleteProc);
6107 }
6108
6109 Tcl_CreateObjCommand(interp, "namespace", ip_rbNamespaceObjCmd,
6110 (ClientData) 0, (Tcl_CmdDeleteProc *)NULL);
6111 #endif
6112 }
6113
6114
6115 /* call when interpreter is deleted */
6116 static void
6117 #ifdef HAVE_PROTOTYPES
6118 ip_CallWhenDeleted(ClientData clientData, Tcl_Interp *ip)
6119 #else
6120 ip_CallWhenDeleted(clientData, ip)
6121 ClientData clientData;
6122 Tcl_Interp *ip;
6123 #endif
6124 {
6125 int thr_crit_bup;
6126 /* Tk_Window main_win = (Tk_Window) clientData; */
6127
6128 DUMP1("start ip_CallWhenDeleted");
6129 thr_crit_bup = rb_thread_critical;
6130 rb_thread_critical = Qtrue;
6131
6132 ip_finalize(ip);
6133
6134 DUMP1("finish ip_CallWhenDeleted");
6135 rb_thread_critical = thr_crit_bup;
6136 }
6137
6138 /*--------------------------------------------------------*/
6139
6140 /* initialize interpreter */
6141 static VALUE
6142 ip_init(argc, argv, self)
6143 int argc;
6144 VALUE *argv;
6145 VALUE self;
6146 {
6147 struct tcltkip *ptr; /* tcltkip data struct */
6148 VALUE argv0, opts;
6149 int cnt;
6150 int st;
6151 int with_tk = 1;
6152 Tk_Window mainWin = (Tk_Window)NULL;
6153
6154 /* security check */
6155 if (rb_safe_level() >= 4) {
6156 rb_raise(rb_eSecurityError,
6157 "Cannot create a TclTkIp object at level %d",
6158 rb_safe_level());
6159 }
6160
6161 /* create object */
6162 Data_Get_Struct(self, struct tcltkip, ptr);
6163 ptr = ALLOC(struct tcltkip);
6164 /* ptr = RbTk_ALLOC_N(struct tcltkip, 1); */
6165 DATA_PTR(self) = ptr;
6166 #ifdef RUBY_USE_NATIVE_THREAD
6167 ptr->tk_thread_id = 0;
6168 #endif
6169 ptr->ref_count = 0;
6170 ptr->allow_ruby_exit = 1;
6171 ptr->return_value = 0;
6172
6173 /* from Tk_Main() */
6174 DUMP1("Tcl_CreateInterp");
6175 ptr->ip = ruby_tcl_create_ip_and_stubs_init(&st);
6176 if (ptr->ip == NULL) {
6177 switch(st) {
6178 case TCLTK_STUBS_OK:
6179 break;
6180 case NO_TCL_DLL:
6181 rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll");
6182 case NO_FindExecutable:
6183 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable");
6184 case NO_CreateInterp:
6185 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()");
6186 case NO_DeleteInterp:
6187 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()");
6188 case FAIL_CreateInterp:
6189 rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP");
6190 case FAIL_Tcl_InitStubs:
6191 rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()");
6192 default:
6193 rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_create_ip_and_stubs_init", st);
6194 }
6195 }
6196
6197 #if TCL_MAJOR_VERSION >= 8
6198 #if TCL_NAMESPACE_DEBUG
6199 DUMP1("get current namespace");
6200 if ((ptr->default_ns = Tcl_GetCurrentNamespace(ptr->ip))
6201 == (Tcl_Namespace*)NULL) {
6202 rb_raise(rb_eRuntimeError, "a new Tk interpreter has a NULL namespace");
6203 }
6204 #endif
6205 #endif
6206
6207 rbtk_preserve_ip(ptr);
6208 DUMP2("IP ref_count = %d", ptr->ref_count);
6209 current_interp = ptr->ip;
6210
6211 ptr->has_orig_exit
6212 = Tcl_GetCommandInfo(ptr->ip, "exit", &(ptr->orig_exit_info));
6213
6214 #if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT
6215 call_tclkit_init_script(current_interp);
6216
6217 # if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84
6218 {
6219 Tcl_DString encodingName;
6220 Tcl_GetEncodingNameFromEnvironment(&encodingName);
6221 if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) {
6222 /* fails, so we set a variable and do it in the boot.tcl script */
6223 Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName));
6224 }
6225 Tcl_SetVar(current_interp, "tclkit_system_encoding", Tcl_DStringValue(&encodingName), 0);
6226 Tcl_DStringFree(&encodingName);
6227 }
6228 # endif
6229 #endif
6230
6231 /* set variables */
6232 Tcl_Eval(ptr->ip, "set argc 0; set argv {}; set argv0 tcltklib.so");
6233
6234 cnt = rb_scan_args(argc, argv, "02", &argv0, &opts);
6235 switch(cnt) {
6236 case 2:
6237 /* options */
6238 if (NIL_P(opts) || opts == Qfalse) {
6239 /* without Tk */
6240 with_tk = 0;
6241 } else {
6242 /* Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), 0); */
6243 Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), TCL_GLOBAL_ONLY);
6244 Tcl_Eval(ptr->ip, "set argc [llength $argv]");
6245 }
6246 case 1:
6247 /* argv0 */
6248 if (!NIL_P(argv0)) {
6249 if (strncmp(StringValuePtr(argv0), "-e", 3) == 0
6250 || strncmp(StringValuePtr(argv0), "-", 2) == 0) {
6251 Tcl_SetVar(ptr->ip, "argv0", "ruby", TCL_GLOBAL_ONLY);
6252 } else {
6253 /* Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0); */
6254 Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0),
6255 TCL_GLOBAL_ONLY);
6256 }
6257 }
6258 case 0:
6259 /* no args */
6260 ;
6261 }
6262
6263 /* from Tcl_AppInit() */
6264 DUMP1("Tcl_Init");
6265 #if (defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT) && (!defined KIT_LITE) && (10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION == 85)
6266 /*************************************************************************/
6267 /* FIX ME (2010/06/28) */
6268 /* Don't use ::chan command for Mk4tcl + tclvfs-1.4 on Tcl8.5. */
6269 /* It fails to access VFS files because of vfs::zstream. */
6270 /* So, force to use ::rechan by temporaly hiding ::chan. */
6271 /*************************************************************************/
6272 Tcl_Eval(ptr->ip, "catch {rename ::chan ::_tmp_chan}");
6273 if (Tcl_Init(ptr->ip) == TCL_ERROR) {
6274 rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
6275 }
6276 Tcl_Eval(ptr->ip, "catch {rename ::_tmp_chan ::chan}");
6277 #else
6278 if (Tcl_Init(ptr->ip) == TCL_ERROR) {
6279 rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
6280 }
6281 #endif
6282
6283 st = ruby_tcl_stubs_init();
6284 /* from Tcl_AppInit() */
6285 if (with_tk) {
6286 DUMP1("Tk_Init");
6287 st = ruby_tk_stubs_init(ptr->ip);
6288 switch(st) {
6289 case TCLTK_STUBS_OK:
6290 break;
6291 case NO_Tk_Init:
6292 rb_raise(rb_eLoadError, "tcltklib: can't find Tk_Init()");
6293 case FAIL_Tk_Init:
6294 rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_Init(). %s",
6295 Tcl_GetStringResult(ptr->ip));
6296 case FAIL_Tk_InitStubs:
6297 rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_InitStubs(). %s",
6298 Tcl_GetStringResult(ptr->ip));
6299 default:
6300 rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st);
6301 }
6302
6303 DUMP1("Tcl_StaticPackage(\"Tk\")");
6304 #if TCL_MAJOR_VERSION >= 8
6305 Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, Tk_SafeInit);
6306 #else /* TCL_MAJOR_VERSION < 8 */
6307 Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init,
6308 (Tcl_PackageInitProc *) NULL);
6309 #endif
6310
6311 #ifdef RUBY_USE_NATIVE_THREAD
6312 /* set Tk thread ID */
6313 ptr->tk_thread_id = Tcl_GetCurrentThread();
6314 #endif
6315 /* get main window */
6316 mainWin = Tk_MainWindow(ptr->ip);
6317 Tk_Preserve((ClientData)mainWin);
6318 }
6319
6320 /* add ruby command to the interpreter */
6321 #if TCL_MAJOR_VERSION >= 8
6322 DUMP1("Tcl_CreateObjCommand(\"ruby\")");
6323 Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL,
6324 (Tcl_CmdDeleteProc *)NULL);
6325 DUMP1("Tcl_CreateObjCommand(\"ruby_eval\")");
6326 Tcl_CreateObjCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL,
6327 (Tcl_CmdDeleteProc *)NULL);
6328 DUMP1("Tcl_CreateObjCommand(\"ruby_cmd\")");
6329 Tcl_CreateObjCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL,
6330 (Tcl_CmdDeleteProc *)NULL);
6331 #else /* TCL_MAJOR_VERSION < 8 */
6332 DUMP1("Tcl_CreateCommand(\"ruby\")");
6333 Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL,
6334 (Tcl_CmdDeleteProc *)NULL);
6335 DUMP1("Tcl_CreateCommand(\"ruby_eval\")");
6336 Tcl_CreateCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL,
6337 (Tcl_CmdDeleteProc *)NULL);
6338 DUMP1("Tcl_CreateCommand(\"ruby_cmd\")");
6339 Tcl_CreateCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL,
6340 (Tcl_CmdDeleteProc *)NULL);
6341 #endif
6342
6343 /* add 'interp_exit', 'ruby_exit' and replace 'exit' command */
6344 #if TCL_MAJOR_VERSION >= 8
6345 DUMP1("Tcl_CreateObjCommand(\"interp_exit\")");
6346 Tcl_CreateObjCommand(ptr->ip, "interp_exit", ip_InterpExitObjCmd,
6347 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6348 DUMP1("Tcl_CreateObjCommand(\"ruby_exit\")");
6349 Tcl_CreateObjCommand(ptr->ip, "ruby_exit", ip_RubyExitObjCmd,
6350 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6351 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\"");
6352 Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd,
6353 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6354 #else /* TCL_MAJOR_VERSION < 8 */
6355 DUMP1("Tcl_CreateCommand(\"interp_exit\")");
6356 Tcl_CreateCommand(ptr->ip, "interp_exit", ip_InterpExitCommand,
6357 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6358 DUMP1("Tcl_CreateCommand(\"ruby_exit\")");
6359 Tcl_CreateCommand(ptr->ip, "ruby_exit", ip_RubyExitCommand,
6360 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6361 DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\"");
6362 Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand,
6363 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6364 #endif
6365
6366 /* replace vwait and tkwait */
6367 ip_replace_wait_commands(ptr->ip, mainWin);
6368
6369 /* wrap namespace command */
6370 ip_wrap_namespace_command(ptr->ip);
6371
6372 /* define command to replace commands which depend on slave's MainWindow */
6373 #if TCL_MAJOR_VERSION >= 8
6374 Tcl_CreateObjCommand(ptr->ip, "__replace_slave_tk_commands__",
6375 ip_rb_replaceSlaveTkCmdsObjCmd,
6376 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
6377 #else /* TCL_MAJOR_VERSION < 8 */
6378 Tcl_CreateCommand(ptr->ip, "__replace_slave_tk_commands__",
6379 ip_rb_replaceSlaveTkCmdsCommand,
6380 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
6381 #endif
6382
6383 /* set finalizer */
6384 Tcl_CallWhenDeleted(ptr->ip, ip_CallWhenDeleted, (ClientData)mainWin);
6385
6386 if (mainWin != (Tk_Window)NULL) {
6387 Tk_Release((ClientData)mainWin);
6388 }
6389
6390 return self;
6391 }
6392
6393 static VALUE
6394 ip_create_slave_core(interp, argc, argv)
6395 VALUE interp;
6396 int argc;
6397 VALUE *argv;
6398 {
6399 struct tcltkip *master = get_ip(interp);
6400 struct tcltkip *slave = ALLOC(struct tcltkip);
6401 /* struct tcltkip *slave = RbTk_ALLOC_N(struct tcltkip, 1); */
6402 VALUE safemode;
6403 VALUE name;
6404 int safe;
6405 int thr_crit_bup;
6406 Tk_Window mainWin;
6407
6408 /* ip is deleted? */
6409 if (deleted_ip(master)) {
6410 return rb_exc_new2(rb_eRuntimeError,
6411 "deleted master cannot create a new slave");
6412 }
6413
6414 name = argv[0];
6415 safemode = argv[1];
6416
6417 if (Tcl_IsSafe(master->ip) == 1) {
6418 safe = 1;
6419 } else if (safemode == Qfalse || NIL_P(safemode)) {
6420 safe = 0;
6421 /* rb_secure(4); */ /* already checked */
6422 } else {
6423 safe = 1;
6424 }
6425
6426 thr_crit_bup = rb_thread_critical;
6427 rb_thread_critical = Qtrue;
6428
6429 #if 0
6430 /* init Tk */
6431 if (RTEST(with_tk)) {
6432 volatile VALUE exc;
6433 if (!tk_stubs_init_p()) {
6434 exc = tcltkip_init_tk(interp);
6435 if (!NIL_P(exc)) {
6436 rb_thread_critical = thr_crit_bup;
6437 return exc;
6438 }
6439 }
6440 }
6441 #endif
6442
6443 /* create slave-ip */
6444 #ifdef RUBY_USE_NATIVE_THREAD
6445 /* slave->tk_thread_id = 0; */
6446 slave->tk_thread_id = master->tk_thread_id; /* == current thread */
6447 #endif
6448 slave->ref_count = 0;
6449 slave->allow_ruby_exit = 0;
6450 slave->return_value = 0;
6451
6452 slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe);
6453 if (slave->ip == NULL) {
6454 rb_thread_critical = thr_crit_bup;
6455 return rb_exc_new2(rb_eRuntimeError,
6456 "fail to create the new slave interpreter");
6457 }
6458 #if TCL_MAJOR_VERSION >= 8
6459 #if TCL_NAMESPACE_DEBUG
6460 slave->default_ns = Tcl_GetCurrentNamespace(slave->ip);
6461 #endif
6462 #endif
6463 rbtk_preserve_ip(slave);
6464
6465 slave->has_orig_exit
6466 = Tcl_GetCommandInfo(slave->ip, "exit", &(slave->orig_exit_info));
6467
6468 /* replace 'exit' command --> 'interp_exit' command */
6469 mainWin = (tk_stubs_init_p())? Tk_MainWindow(slave->ip): (Tk_Window)NULL;
6470 #if TCL_MAJOR_VERSION >= 8
6471 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
6472 Tcl_CreateObjCommand(slave->ip, "exit", ip_InterpExitObjCmd,
6473 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6474 #else /* TCL_MAJOR_VERSION < 8 */
6475 DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
6476 Tcl_CreateCommand(slave->ip, "exit", ip_InterpExitCommand,
6477 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6478 #endif
6479
6480 /* replace vwait and tkwait */
6481 ip_replace_wait_commands(slave->ip, mainWin);
6482
6483 /* wrap namespace command */
6484 ip_wrap_namespace_command(slave->ip);
6485
6486 /* define command to replace cmds which depend on slave-slave's MainWin */
6487 #if TCL_MAJOR_VERSION >= 8
6488 Tcl_CreateObjCommand(slave->ip, "__replace_slave_tk_commands__",
6489 ip_rb_replaceSlaveTkCmdsObjCmd,
6490 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
6491 #else /* TCL_MAJOR_VERSION < 8 */
6492 Tcl_CreateCommand(slave->ip, "__replace_slave_tk_commands__",
6493 ip_rb_replaceSlaveTkCmdsCommand,
6494 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
6495 #endif
6496
6497 /* set finalizer */
6498 Tcl_CallWhenDeleted(slave->ip, ip_CallWhenDeleted, (ClientData)mainWin);
6499
6500 rb_thread_critical = thr_crit_bup;
6501
6502 return Data_Wrap_Struct(CLASS_OF(interp), 0, ip_free, slave);
6503 }
6504
6505 static VALUE
6506 ip_create_slave(argc, argv, self)
6507 int argc;
6508 VALUE *argv;
6509 VALUE self;
6510 {
6511 struct tcltkip *master = get_ip(self);
6512 VALUE safemode;
6513 VALUE name;
6514 VALUE callargv[2];
6515
6516 /* ip is deleted? */
6517 if (deleted_ip(master)) {
6518 rb_raise(rb_eRuntimeError,
6519 "deleted master cannot create a new slave interpreter");
6520 }
6521
6522 /* argument check */
6523 if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) {
6524 safemode = Qfalse;
6525 }
6526 if (Tcl_IsSafe(master->ip) != 1
6527 && (safemode == Qfalse || NIL_P(safemode))) {
6528 rb_secure(4);
6529 }
6530
6531 StringValue(name);
6532 callargv[0] = name;
6533 callargv[1] = safemode;
6534
6535 return tk_funcall(ip_create_slave_core, 2, callargv, self);
6536 }
6537
6538
6539 /* self is slave of master? */
6540 static VALUE
6541 ip_is_slave_of_p(self, master)
6542 VALUE self, master;
6543 {
6544 if (!rb_obj_is_kind_of(master, tcltkip_class)) {
6545 rb_raise(rb_eArgError, "expected TclTkIp object");
6546 }
6547
6548 if (Tcl_GetMaster(get_ip(self)->ip) == get_ip(master)->ip) {
6549 return Qtrue;
6550 } else {
6551 return Qfalse;
6552 }
6553 }
6554
6555
6556 /* create console (if supported) */
6557 #if defined(MAC_TCL) || defined(__WIN32__)
6558 #if TCL_MAJOR_VERSION < 8 \
6559 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0) \
6560 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \
6561 && (TCL_RELEASE_LEVEL == TCL_ALPHA_RELEASE \
6562 || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \
6563 && TCL_RELEASE_SERIAL < 2) ) )
6564 EXTERN void TkConsoleCreate _((void));
6565 #endif
6566 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \
6567 && ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \
6568 && TCL_RELEASE_SERIAL == 0) \
6569 || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \
6570 && TCL_RELEASE_SERIAL >= 2) )
6571 EXTERN void TkConsoleCreate_ _((void));
6572 #endif
6573 #endif
6574 static VALUE
6575 ip_create_console_core(interp, argc, argv)
6576 VALUE interp;
6577 int argc; /* dummy */
6578 VALUE *argv; /* dummy */
6579 {
6580 struct tcltkip *ptr = get_ip(interp);
6581
6582 if (!tk_stubs_init_p()) {
6583 tcltkip_init_tk(interp);
6584 }
6585
6586 if (Tcl_GetVar(ptr->ip,"tcl_interactive",TCL_GLOBAL_ONLY) == (char*)NULL) {
6587 Tcl_SetVar(ptr->ip, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
6588 }
6589
6590 #if TCL_MAJOR_VERSION > 8 \
6591 || (TCL_MAJOR_VERSION == 8 \
6592 && (TCL_MINOR_VERSION > 1 \
6593 || (TCL_MINOR_VERSION == 1 \
6594 && TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \
6595 && TCL_RELEASE_SERIAL >= 1) ) )
6596 Tk_InitConsoleChannels(ptr->ip);
6597
6598 if (Tk_CreateConsoleWindow(ptr->ip) != TCL_OK) {
6599 rb_raise(rb_eRuntimeError, "fail to create console-window");
6600 }
6601 #else
6602 #if defined(MAC_TCL) || defined(__WIN32__)
6603 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \
6604 && ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE && TCL_RELEASE_SERIAL == 0) \
6605 || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE && TCL_RELEASE_SERIAL >= 2) )
6606 TkConsoleCreate_();
6607 #else
6608 TkConsoleCreate();
6609 #endif
6610
6611 if (TkConsoleInit(ptr->ip) != TCL_OK) {
6612 rb_raise(rb_eRuntimeError, "fail to create console-window");
6613 }
6614 #else
6615 rb_notimplement();
6616 #endif
6617 #endif
6618
6619 return interp;
6620 }
6621
6622 static VALUE
6623 ip_create_console(self)
6624 VALUE self;
6625 {
6626 struct tcltkip *ptr = get_ip(self);
6627
6628 /* ip is deleted? */
6629 if (deleted_ip(ptr)) {
6630 rb_raise(rb_eRuntimeError, "interpreter is deleted");
6631 }
6632
6633 return tk_funcall(ip_create_console_core, 0, (VALUE*)NULL, self);
6634 }
6635
6636 /* make ip "safe" */
6637 static VALUE
6638 ip_make_safe_core(interp, argc, argv)
6639 VALUE interp;
6640 int argc; /* dummy */
6641 VALUE *argv; /* dummy */
6642 {
6643 struct tcltkip *ptr = get_ip(interp);
6644 Tk_Window mainWin;
6645
6646 /* ip is deleted? */
6647 if (deleted_ip(ptr)) {
6648 return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted");
6649 }
6650
6651 if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) {
6652 /* return rb_exc_new2(rb_eRuntimeError,
6653 Tcl_GetStringResult(ptr->ip)); */
6654 return create_ip_exc(interp, rb_eRuntimeError,
6655 Tcl_GetStringResult(ptr->ip));
6656 }
6657
6658 ptr->allow_ruby_exit = 0;
6659
6660 /* replace 'exit' command --> 'interp_exit' command */
6661 mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL;
6662 #if TCL_MAJOR_VERSION >= 8
6663 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
6664 Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd,
6665 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6666 #else /* TCL_MAJOR_VERSION < 8 */
6667 DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
6668 Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand,
6669 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6670 #endif
6671
6672 return interp;
6673 }
6674
6675 static VALUE
6676 ip_make_safe(self)
6677 VALUE self;
6678 {
6679 struct tcltkip *ptr = get_ip(self);
6680
6681 /* ip is deleted? */
6682 if (deleted_ip(ptr)) {
6683 rb_raise(rb_eRuntimeError, "interpreter is deleted");
6684 }
6685
6686 return tk_funcall(ip_make_safe_core, 0, (VALUE*)NULL, self);
6687 }
6688
6689 /* is safe? */
6690 static VALUE
6691 ip_is_safe_p(self)
6692 VALUE self;
6693 {
6694 struct tcltkip *ptr = get_ip(self);
6695
6696 /* ip is deleted? */
6697 if (deleted_ip(ptr)) {
6698 rb_raise(rb_eRuntimeError, "interpreter is deleted");
6699 }
6700
6701 if (Tcl_IsSafe(ptr->ip)) {
6702 return Qtrue;
6703 } else {
6704 return Qfalse;
6705 }
6706 }
6707
6708 /* allow_ruby_exit? */
6709 static VALUE
6710 ip_allow_ruby_exit_p(self)
6711 VALUE self;
6712 {
6713 struct tcltkip *ptr = get_ip(self);
6714
6715 /* ip is deleted? */
6716 if (deleted_ip(ptr)) {
6717 rb_raise(rb_eRuntimeError, "interpreter is deleted");
6718 }
6719
6720 if (ptr->allow_ruby_exit) {
6721 return Qtrue;
6722 } else {
6723 return Qfalse;
6724 }
6725 }
6726
6727 /* allow_ruby_exit = mode */
6728 static VALUE
6729 ip_allow_ruby_exit_set(self, val)
6730 VALUE self, val;
6731 {
6732 struct tcltkip *ptr = get_ip(self);
6733 Tk_Window mainWin;
6734
6735 rb_secure(4);
6736
6737 /* ip is deleted? */
6738 if (deleted_ip(ptr)) {
6739 rb_raise(rb_eRuntimeError, "interpreter is deleted");
6740 }
6741
6742 if (Tcl_IsSafe(ptr->ip)) {
6743 rb_raise(rb_eSecurityError,
6744 "insecure operation on a safe interpreter");
6745 }
6746
6747 /*
6748 * Because of cross-threading, the following line may fail to find
6749 * the MainWindow, even if the Tcl/Tk interpreter has one or more.
6750 * But it has no problem. Current implementation of both type of
6751 * the "exit" command don't need maiinWin token.
6752 */
6753 mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL;
6754
6755 if (RTEST(val)) {
6756 ptr->allow_ruby_exit = 1;
6757 #if TCL_MAJOR_VERSION >= 8
6758 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\"");
6759 Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd,
6760 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6761 #else /* TCL_MAJOR_VERSION < 8 */
6762 DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\"");
6763 Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand,
6764 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6765 #endif
6766 return Qtrue;
6767
6768 } else {
6769 ptr->allow_ruby_exit = 0;
6770 #if TCL_MAJOR_VERSION >= 8
6771 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
6772 Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd,
6773 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6774 #else /* TCL_MAJOR_VERSION < 8 */
6775 DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
6776 Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand,
6777 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
6778 #endif
6779 return Qfalse;
6780 }
6781 }
6782
6783 /* delete interpreter */
6784 static VALUE
6785 ip_delete(self)
6786 VALUE self;
6787 {
6788 int thr_crit_bup;
6789 struct tcltkip *ptr = get_ip(self);
6790
6791 /* if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL) { */
6792 if (deleted_ip(ptr)) {
6793 DUMP1("delete deleted IP");
6794 return Qnil;
6795 }
6796
6797 thr_crit_bup = rb_thread_critical;
6798 rb_thread_critical = Qtrue;
6799
6800 DUMP1("delete interp");
6801 if (!Tcl_InterpDeleted(ptr->ip)) {
6802 DUMP1("call ip_finalize");
6803 ip_finalize(ptr->ip);
6804
6805 Tcl_DeleteInterp(ptr->ip);
6806 Tcl_Release(ptr->ip);
6807 }
6808
6809 rb_thread_critical = thr_crit_bup;
6810
6811 return Qnil;
6812 }
6813
6814
6815 /* is deleted? */
6816 static VALUE
6817 ip_has_invalid_namespace_p(self)
6818 VALUE self;
6819 {
6820 struct tcltkip *ptr = get_ip(self);
6821
6822 if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL) {
6823 /* deleted IP */
6824 return Qtrue;
6825 }
6826
6827 #if TCL_NAMESPACE_DEBUG
6828 if (rbtk_invalid_namespace(ptr)) {
6829 return Qtrue;
6830 } else {
6831 return Qfalse;
6832 }
6833 #else
6834 return Qfalse;
6835 #endif
6836 }
6837
6838 static VALUE
6839 ip_is_deleted_p(self)
6840 VALUE self;
6841 {
6842 struct tcltkip *ptr = get_ip(self);
6843
6844 if (deleted_ip(ptr)) {
6845 return Qtrue;
6846 } else {
6847 return Qfalse;
6848 }
6849 }
6850
6851 static VALUE
6852 ip_has_mainwindow_p_core(self, argc, argv)
6853 VALUE self;
6854 int argc; /* dummy */
6855 VALUE *argv; /* dummy */
6856 {
6857 struct tcltkip *ptr = get_ip(self);
6858
6859 if (deleted_ip(ptr) || !tk_stubs_init_p()) {
6860 return Qnil;
6861 } else if (Tk_MainWindow(ptr->ip) == (Tk_Window)NULL) {
6862 return Qfalse;
6863 } else {
6864 return Qtrue;
6865 }
6866 }
6867
6868 static VALUE
6869 ip_has_mainwindow_p(self)
6870 VALUE self;
6871 {
6872 return tk_funcall(ip_has_mainwindow_p_core, 0, (VALUE*)NULL, self);
6873 }
6874
6875
6876 /*** ruby string <=> tcl object ***/
6877 #if TCL_MAJOR_VERSION >= 8
6878 static VALUE
6879 get_str_from_obj(obj)
6880 Tcl_Obj *obj;
6881 {
6882 int len, binary = 0;
6883 const char *s;
6884 volatile VALUE str;
6885
6886 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
6887 s = Tcl_GetStringFromObj(obj, &len);
6888 #else
6889 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 3
6890 /* TCL_VERSION 8.1 -- 8.3 */
6891 if (Tcl_GetCharLength(obj) != Tcl_UniCharLen(Tcl_GetUnicode(obj))) {
6892 /* possibly binary string */
6893 s = (char *)Tcl_GetByteArrayFromObj(obj, &len);
6894 binary = 1;
6895 } else {
6896 /* possibly text string */
6897 s = Tcl_GetStringFromObj(obj, &len);
6898 }
6899 #else /* TCL_VERSION >= 8.4 */
6900 if (IS_TCL_BYTEARRAY(obj)) {
6901 s = (char *)Tcl_GetByteArrayFromObj(obj, &len);
6902 binary = 1;
6903 } else {
6904 s = Tcl_GetStringFromObj(obj, &len);
6905 }
6906
6907 #endif
6908 #endif
6909 str = s ? rb_str_new(s, len) : rb_str_new2("");
6910 if (binary) {
6911 #ifdef HAVE_RUBY_ENCODING_H
6912 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
6913 #endif
6914 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
6915 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
6916 } else {
6917 #ifdef HAVE_RUBY_ENCODING_H
6918 rb_enc_associate_index(str, ENCODING_INDEX_UTF8);
6919 #endif
6920 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8);
6921 #endif
6922 }
6923 return str;
6924 }
6925
6926 static Tcl_Obj *
6927 get_obj_from_str(str)
6928 VALUE str;
6929 {
6930 const char *s = StringValuePtr(str);
6931
6932 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
6933 return Tcl_NewStringObj((char*)s, RSTRING_LEN(str));
6934 #else /* TCL_VERSION >= 8.1 */
6935 VALUE enc = rb_attr_get(str, ID_at_enc);
6936
6937 if (!NIL_P(enc)) {
6938 StringValue(enc);
6939 if (strcmp(RSTRING_PTR(enc), "binary") == 0) {
6940 /* binary string */
6941 return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str));
6942 } else {
6943 /* text string */
6944 return Tcl_NewStringObj(s, RSTRING_LENINT(str));
6945 }
6946 #ifdef HAVE_RUBY_ENCODING_H
6947 } else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) {
6948 /* binary string */
6949 return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str));
6950 #endif
6951 } else if (memchr(s, 0, RSTRING_LEN(str))) {
6952 /* probably binary string */
6953 return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str));
6954 } else {
6955 /* probably text string */
6956 return Tcl_NewStringObj(s, RSTRING_LENINT(str));
6957 }
6958 #endif
6959 }
6960 #endif /* ruby string <=> tcl object */
6961
6962 static VALUE
6963 ip_get_result_string_obj(interp)
6964 Tcl_Interp *interp;
6965 {
6966 #if TCL_MAJOR_VERSION >= 8
6967 Tcl_Obj *retObj;
6968 volatile VALUE strval;
6969
6970 retObj = Tcl_GetObjResult(interp);
6971 Tcl_IncrRefCount(retObj);
6972 strval = get_str_from_obj(retObj);
6973 RbTk_OBJ_UNTRUST(strval);
6974 Tcl_ResetResult(interp);
6975 Tcl_DecrRefCount(retObj);
6976 return strval;
6977 #else
6978 return rb_tainted_str_new2(interp->result);
6979 #endif
6980 }
6981
6982 /* call Tcl/Tk functions on the eventloop thread */
6983 static VALUE
6984 callq_safelevel_handler(arg, callq)
6985 VALUE arg;
6986 VALUE callq;
6987 {
6988 struct call_queue *q;
6989
6990 Data_Get_Struct(callq, struct call_queue, q);
6991 DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
6992 rb_set_safe_level(q->safe_level);
6993 return((q->func)(q->interp, q->argc, q->argv));
6994 }
6995
6996 static int call_queue_handler _((Tcl_Event *, int));
6997 static int
6998 call_queue_handler(evPtr, flags)
6999 Tcl_Event *evPtr;
7000 int flags;
7001 {
7002 struct call_queue *q = (struct call_queue *)evPtr;
7003 volatile VALUE ret;
7004 volatile VALUE q_dat;
7005 volatile VALUE thread = q->thread;
7006 struct tcltkip *ptr;
7007
7008 DUMP2("do_call_queue_handler : evPtr = %p", evPtr);
7009 DUMP2("call_queue_handler thread : %lx", rb_thread_current());
7010 DUMP2("added by thread : %lx", thread);
7011
7012 if (*(q->done)) {
7013 DUMP1("processed by another event-loop");
7014 return 0;
7015 } else {
7016 DUMP1("process it on current event-loop");
7017 }
7018
7019 #ifdef RUBY_VM
7020 if (RTEST(rb_funcall(thread, ID_alive_p, 0))
7021 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
7022 #else
7023 if (RTEST(rb_thread_alive_p(thread))
7024 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
7025 #endif
7026 DUMP1("caller is not yet ready to receive the result -> pending");
7027 return 0;
7028 }
7029
7030 /* process it */
7031 *(q->done) = 1;
7032
7033 /* deleted ipterp ? */
7034 ptr = get_ip(q->interp);
7035 if (deleted_ip(ptr)) {
7036 /* deleted IP --> ignore */
7037 return 1;
7038 }
7039
7040 /* incr internal handler mark */
7041 rbtk_internal_eventloop_handler++;
7042
7043 /* check safe-level */
7044 if (rb_safe_level() != q->safe_level) {
7045 /* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */
7046 q_dat = Data_Wrap_Struct(rb_cData,call_queue_mark,-1,q);
7047 ret = rb_funcall(rb_proc_new(callq_safelevel_handler, q_dat),
7048 ID_call, 0);
7049 rb_gc_force_recycle(q_dat);
7050 q_dat = (VALUE)NULL;
7051 } else {
7052 DUMP2("call function (for caller thread:%lx)", thread);
7053 DUMP2("call function (current thread:%lx)", rb_thread_current());
7054 ret = (q->func)(q->interp, q->argc, q->argv);
7055 }
7056
7057 /* set result */
7058 RARRAY_PTR(q->result)[0] = ret;
7059 ret = (VALUE)NULL;
7060
7061 /* decr internal handler mark */
7062 rbtk_internal_eventloop_handler--;
7063
7064 /* complete */
7065 *(q->done) = -1;
7066
7067 /* unlink ruby objects */
7068 q->argv = (VALUE*)NULL;
7069 q->interp = (VALUE)NULL;
7070 q->result = (VALUE)NULL;
7071 q->thread = (VALUE)NULL;
7072
7073 /* back to caller */
7074 #ifdef RUBY_VM
7075 if (RTEST(rb_funcall(thread, ID_alive_p, 0, 0))) {
7076 #else
7077 if (RTEST(rb_thread_alive_p(thread))) {
7078 #endif
7079 DUMP2("back to caller (caller thread:%lx)", thread);
7080 DUMP2(" (current thread:%lx)", rb_thread_current());
7081 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
7082 have_rb_thread_waiting_for_value = 1;
7083 rb_thread_wakeup(thread);
7084 #else
7085 rb_thread_run(thread);
7086 #endif
7087 DUMP1("finish back to caller");
7088 #if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
7089 rb_thread_schedule();
7090 #endif
7091 } else {
7092 DUMP2("caller is dead (caller thread:%lx)", thread);
7093 DUMP2(" (current thread:%lx)", rb_thread_current());
7094 }
7095
7096 /* end of handler : remove it */
7097 return 1;
7098 }
7099
7100 static VALUE
7101 tk_funcall(func, argc, argv, obj)
7102 VALUE (*func)();
7103 int argc;
7104 VALUE *argv;
7105 VALUE obj;
7106 {
7107 struct call_queue *callq;
7108 struct tcltkip *ptr;
7109 int *alloc_done;
7110 int thr_crit_bup;
7111 int is_tk_evloop_thread;
7112 volatile VALUE current = rb_thread_current();
7113 volatile VALUE ip_obj = obj;
7114 volatile VALUE result;
7115 volatile VALUE ret;
7116 struct timeval t;
7117
7118 if (!NIL_P(ip_obj) && rb_obj_is_kind_of(ip_obj, tcltkip_class)) {
7119 ptr = get_ip(ip_obj);
7120 if (deleted_ip(ptr)) return Qnil;
7121 } else {
7122 ptr = (struct tcltkip *)NULL;
7123 }
7124
7125 #ifdef RUBY_USE_NATIVE_THREAD
7126 if (ptr) {
7127 /* on Tcl interpreter */
7128 is_tk_evloop_thread = (ptr->tk_thread_id == (Tcl_ThreadId) 0
7129 || ptr->tk_thread_id == Tcl_GetCurrentThread());
7130 } else {
7131 /* on Tcl/Tk library */
7132 is_tk_evloop_thread = (tk_eventloop_thread_id == (Tcl_ThreadId) 0
7133 || tk_eventloop_thread_id == Tcl_GetCurrentThread());
7134 }
7135 #else
7136 is_tk_evloop_thread = 1;
7137 #endif
7138
7139 if (is_tk_evloop_thread
7140 && (NIL_P(eventloop_thread) || current == eventloop_thread)
7141 ) {
7142 if (NIL_P(eventloop_thread)) {
7143 DUMP2("tk_funcall from thread:%lx but no eventloop", current);
7144 } else {
7145 DUMP2("tk_funcall from current eventloop %lx", current);
7146 }
7147 result = (func)(ip_obj, argc, argv);
7148 if (rb_obj_is_kind_of(result, rb_eException)) {
7149 rb_exc_raise(result);
7150 }
7151 return result;
7152 }
7153
7154 DUMP2("tk_funcall from thread %lx (NOT current eventloop)", current);
7155
7156 thr_crit_bup = rb_thread_critical;
7157 rb_thread_critical = Qtrue;
7158
7159 /* allocate memory (argv cross over thread : must be in heap) */
7160 if (argv) {
7161 /* VALUE *temp = ALLOC_N(VALUE, argc); */
7162 VALUE *temp = RbTk_ALLOC_N(VALUE, argc);
7163 #if 0 /* use Tcl_Preserve/Release */
7164 Tcl_Preserve((ClientData)temp); /* XXXXXXXX */
7165 #endif
7166 MEMCPY(temp, argv, VALUE, argc);
7167 argv = temp;
7168 }
7169
7170 /* allocate memory (keep result) */
7171 /* alloc_done = (int*)ALLOC(int); */
7172 alloc_done = RbTk_ALLOC_N(int, 1);
7173 #if 0 /* use Tcl_Preserve/Release */
7174 Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */
7175 #endif
7176 *alloc_done = 0;
7177
7178 /* allocate memory (freed by Tcl_ServiceEvent) */
7179 /* callq = (struct call_queue *)Tcl_Alloc(sizeof(struct call_queue)); */
7180 callq = RbTk_ALLOC_N(struct call_queue, 1);
7181 #if 0 /* use Tcl_Preserve/Release */
7182 Tcl_Preserve(callq);
7183 #endif
7184
7185 /* allocate result obj */
7186 result = rb_ary_new3(1, Qnil);
7187
7188 /* construct event data */
7189 callq->done = alloc_done;
7190 callq->func = func;
7191 callq->argc = argc;
7192 callq->argv = argv;
7193 callq->interp = ip_obj;
7194 callq->result = result;
7195 callq->thread = current;
7196 callq->safe_level = rb_safe_level();
7197 callq->ev.proc = call_queue_handler;
7198
7199 /* add the handler to Tcl event queue */
7200 DUMP1("add handler");
7201 #ifdef RUBY_USE_NATIVE_THREAD
7202 if (ptr && ptr->tk_thread_id) {
7203 /* Tcl_ThreadQueueEvent(ptr->tk_thread_id,
7204 &(callq->ev), TCL_QUEUE_HEAD); */
7205 Tcl_ThreadQueueEvent(ptr->tk_thread_id,
7206 (Tcl_Event*)callq, TCL_QUEUE_HEAD);
7207 Tcl_ThreadAlert(ptr->tk_thread_id);
7208 } else if (tk_eventloop_thread_id) {
7209 /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
7210 &(callq->ev), TCL_QUEUE_HEAD); */
7211 Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
7212 (Tcl_Event*)callq, TCL_QUEUE_HEAD);
7213 Tcl_ThreadAlert(tk_eventloop_thread_id);
7214 } else {
7215 /* Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); */
7216 Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD);
7217 }
7218 #else
7219 /* Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); */
7220 Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD);
7221 #endif
7222
7223 rb_thread_critical = thr_crit_bup;
7224
7225 /* wait for the handler to be processed */
7226 t.tv_sec = 0;
7227 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
7228
7229 DUMP2("callq wait for handler (current thread:%lx)", current);
7230 while(*alloc_done >= 0) {
7231 DUMP2("*** callq wait for handler (current thread:%lx)", current);
7232 /* rb_thread_stop(); */
7233 /* rb_thread_sleep_forever(); */
7234 rb_thread_wait_for(t);
7235 DUMP2("*** callq wakeup (current thread:%lx)", current);
7236 DUMP2("*** (eventloop thread:%lx)", eventloop_thread);
7237 if (NIL_P(eventloop_thread)) {
7238 DUMP1("*** callq lost eventloop thread");
7239 break;
7240 }
7241 }
7242 DUMP2("back from handler (current thread:%lx)", current);
7243
7244 /* get result & free allocated memory */
7245 ret = RARRAY_PTR(result)[0];
7246 #if 0 /* use Tcl_EventuallyFree */
7247 Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */
7248 #else
7249 #if 0 /* use Tcl_Preserve/Release */
7250 Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */
7251 #else
7252 /* free(alloc_done); */
7253 ckfree((char*)alloc_done);
7254 #endif
7255 #endif
7256 /* if (argv) free(argv); */
7257 if (argv) {
7258 /* if argv != NULL, alloc as 'temp' */
7259 int i;
7260 for(i = 0; i < argc; i++) { argv[i] = (VALUE)NULL; }
7261
7262 #if 0 /* use Tcl_EventuallyFree */
7263 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
7264 #else
7265 #if 0 /* use Tcl_Preserve/Release */
7266 Tcl_Release((ClientData)argv); /* XXXXXXXX */
7267 #else
7268 ckfree((char*)argv);
7269 #endif
7270 #endif
7271 }
7272
7273 #if 0 /* callq is freed by Tcl_ServiceEvent */
7274 #if 0 /* use Tcl_Preserve/Release */
7275 Tcl_Release(callq);
7276 #else
7277 ckfree((char*)callq);
7278 #endif
7279 #endif
7280
7281 /* exception? */
7282 if (rb_obj_is_kind_of(ret, rb_eException)) {
7283 DUMP1("raise exception");
7284 /* rb_exc_raise(ret); */
7285 rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
7286 rb_funcall(ret, ID_to_s, 0, 0)));
7287 }
7288
7289 DUMP1("exit tk_funcall");
7290 return ret;
7291 }
7292
7293
7294 /* eval string in tcl by Tcl_Eval() */
7295 #if TCL_MAJOR_VERSION >= 8
7296 struct call_eval_info {
7297 struct tcltkip *ptr;
7298 Tcl_Obj *cmd;
7299 };
7300
7301 static VALUE
7302 #ifdef HAVE_PROTOTYPES
7303 call_tcl_eval(VALUE arg)
7304 #else
7305 call_tcl_eval(arg)
7306 VALUE arg;
7307 #endif
7308 {
7309 struct call_eval_info *inf = (struct call_eval_info *)arg;
7310
7311 Tcl_AllowExceptions(inf->ptr->ip);
7312 inf->ptr->return_value = Tcl_EvalObj(inf->ptr->ip, inf->cmd);
7313
7314 return Qnil;
7315 }
7316 #endif
7317
7318 static VALUE
7319 ip_eval_real(self, cmd_str, cmd_len)
7320 VALUE self;
7321 char *cmd_str;
7322 int cmd_len;
7323 {
7324 volatile VALUE ret;
7325 struct tcltkip *ptr = get_ip(self);
7326 int thr_crit_bup;
7327
7328 #if TCL_MAJOR_VERSION >= 8
7329 /* call Tcl_EvalObj() */
7330 {
7331 Tcl_Obj *cmd;
7332
7333 thr_crit_bup = rb_thread_critical;
7334 rb_thread_critical = Qtrue;
7335
7336 cmd = Tcl_NewStringObj(cmd_str, cmd_len);
7337 Tcl_IncrRefCount(cmd);
7338
7339 /* ip is deleted? */
7340 if (deleted_ip(ptr)) {
7341 Tcl_DecrRefCount(cmd);
7342 rb_thread_critical = thr_crit_bup;
7343 ptr->return_value = TCL_OK;
7344 return rb_tainted_str_new2("");
7345 } else {
7346 int status;
7347 struct call_eval_info inf;
7348
7349 /* Tcl_Preserve(ptr->ip); */
7350 rbtk_preserve_ip(ptr);
7351
7352 #if 0
7353 ptr->return_value = Tcl_EvalObj(ptr->ip, cmd);
7354 /* ptr->return_value = Tcl_GlobalEvalObj(ptr->ip, cmd); */
7355 #else
7356 inf.ptr = ptr;
7357 inf.cmd = cmd;
7358 ret = rb_protect(call_tcl_eval, (VALUE)&inf, &status);
7359 switch(status) {
7360 case TAG_RAISE:
7361 if (NIL_P(rb_errinfo())) {
7362 rbtk_pending_exception = rb_exc_new2(rb_eException,
7363 "unknown exception");
7364 } else {
7365 rbtk_pending_exception = rb_errinfo();
7366 }
7367 break;
7368
7369 case TAG_FATAL:
7370 if (NIL_P(rb_errinfo())) {
7371 rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
7372 } else {
7373 rbtk_pending_exception = rb_errinfo();
7374 }
7375 }
7376 #endif
7377 }
7378
7379 Tcl_DecrRefCount(cmd);
7380
7381 }
7382
7383 if (pending_exception_check1(thr_crit_bup, ptr)) {
7384 rbtk_release_ip(ptr);
7385 return rbtk_pending_exception;
7386 }
7387
7388 /* if (ptr->return_value == TCL_ERROR) { */
7389 if (ptr->return_value != TCL_OK) {
7390 if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
7391 volatile VALUE exc;
7392
7393 switch (ptr->return_value) {
7394 case TCL_RETURN:
7395 exc = create_ip_exc(self, eTkCallbackReturn,
7396 "ip_eval_real receives TCL_RETURN");
7397 case TCL_BREAK:
7398 exc = create_ip_exc(self, eTkCallbackBreak,
7399 "ip_eval_real receives TCL_BREAK");
7400 case TCL_CONTINUE:
7401 exc = create_ip_exc(self, eTkCallbackContinue,
7402 "ip_eval_real receives TCL_CONTINUE");
7403 default:
7404 exc = create_ip_exc(self, rb_eRuntimeError, "%s",
7405 Tcl_GetStringResult(ptr->ip));
7406 }
7407
7408 rbtk_release_ip(ptr);
7409 rb_thread_critical = thr_crit_bup;
7410 return exc;
7411 } else {
7412 if (event_loop_abort_on_exc < 0) {
7413 rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip));
7414 } else {
7415 rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip));
7416 }
7417 Tcl_ResetResult(ptr->ip);
7418 rbtk_release_ip(ptr);
7419 rb_thread_critical = thr_crit_bup;
7420 return rb_tainted_str_new2("");
7421 }
7422 }
7423
7424 /* pass back the result (as string) */
7425 ret = ip_get_result_string_obj(ptr->ip);
7426 rbtk_release_ip(ptr);
7427 rb_thread_critical = thr_crit_bup;
7428 return ret;
7429
7430 #else /* TCL_MAJOR_VERSION < 8 */
7431 DUMP2("Tcl_Eval(%s)", cmd_str);
7432
7433 /* ip is deleted? */
7434 if (deleted_ip(ptr)) {
7435 ptr->return_value = TCL_OK;
7436 return rb_tainted_str_new2("");
7437 } else {
7438 /* Tcl_Preserve(ptr->ip); */
7439 rbtk_preserve_ip(ptr);
7440 ptr->return_value = Tcl_Eval(ptr->ip, cmd_str);
7441 /* ptr->return_value = Tcl_GlobalEval(ptr->ip, cmd_str); */
7442 }
7443
7444 if (pending_exception_check1(thr_crit_bup, ptr)) {
7445 rbtk_release_ip(ptr);
7446 return rbtk_pending_exception;
7447 }
7448
7449 /* if (ptr->return_value == TCL_ERROR) { */
7450 if (ptr->return_value != TCL_OK) {
7451 volatile VALUE exc;
7452
7453 switch (ptr->return_value) {
7454 case TCL_RETURN:
7455 exc = create_ip_exc(self, eTkCallbackReturn,
7456 "ip_eval_real receives TCL_RETURN");
7457 case TCL_BREAK:
7458 exc = create_ip_exc(self, eTkCallbackBreak,
7459 "ip_eval_real receives TCL_BREAK");
7460 case TCL_CONTINUE:
7461 exc = create_ip_exc(self, eTkCallbackContinue,
7462 "ip_eval_real receives TCL_CONTINUE");
7463 default:
7464 exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result);
7465 }
7466
7467 rbtk_release_ip(ptr);
7468 return exc;
7469 }
7470 DUMP2("(TCL_Eval result) %d", ptr->return_value);
7471
7472 /* pass back the result (as string) */
7473 ret = ip_get_result_string_obj(ptr->ip);
7474 rbtk_release_ip(ptr);
7475 return ret;
7476 #endif
7477 }
7478
7479 static VALUE
7480 evq_safelevel_handler(arg, evq)
7481 VALUE arg;
7482 VALUE evq;
7483 {
7484 struct eval_queue *q;
7485
7486 Data_Get_Struct(evq, struct eval_queue, q);
7487 DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
7488 rb_set_safe_level(q->safe_level);
7489 return ip_eval_real(q->interp, q->str, q->len);
7490 }
7491
7492 int eval_queue_handler _((Tcl_Event *, int));
7493 int
7494 eval_queue_handler(evPtr, flags)
7495 Tcl_Event *evPtr;
7496 int flags;
7497 {
7498 struct eval_queue *q = (struct eval_queue *)evPtr;
7499 volatile VALUE ret;
7500 volatile VALUE q_dat;
7501 volatile VALUE thread = q->thread;
7502 struct tcltkip *ptr;
7503
7504 DUMP2("do_eval_queue_handler : evPtr = %p", evPtr);
7505 DUMP2("eval_queue_thread : %lx", rb_thread_current());
7506 DUMP2("added by thread : %lx", thread);
7507
7508 if (*(q->done)) {
7509 DUMP1("processed by another event-loop");
7510 return 0;
7511 } else {
7512 DUMP1("process it on current event-loop");
7513 }
7514
7515 #ifdef RUBY_VM
7516 if (RTEST(rb_funcall(thread, ID_alive_p, 0))
7517 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
7518 #else
7519 if (RTEST(rb_thread_alive_p(thread))
7520 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
7521 #endif
7522 DUMP1("caller is not yet ready to receive the result -> pending");
7523 return 0;
7524 }
7525
7526 /* process it */
7527 *(q->done) = 1;
7528
7529 /* deleted ipterp ? */
7530 ptr = get_ip(q->interp);
7531 if (deleted_ip(ptr)) {
7532 /* deleted IP --> ignore */
7533 return 1;
7534 }
7535
7536 /* incr internal handler mark */
7537 rbtk_internal_eventloop_handler++;
7538
7539 /* check safe-level */
7540 if (rb_safe_level() != q->safe_level) {
7541 #ifdef HAVE_NATIVETHREAD
7542 #ifndef RUBY_USE_NATIVE_THREAD
7543 if (!ruby_native_thread_p()) {
7544 rb_bug("cross-thread violation on eval_queue_handler()");
7545 }
7546 #endif
7547 #endif
7548 /* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */
7549 q_dat = Data_Wrap_Struct(rb_cData,eval_queue_mark,-1,q);
7550 ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat),
7551 ID_call, 0);
7552 rb_gc_force_recycle(q_dat);
7553 q_dat = (VALUE)NULL;
7554 } else {
7555 ret = ip_eval_real(q->interp, q->str, q->len);
7556 }
7557
7558 /* set result */
7559 RARRAY_PTR(q->result)[0] = ret;
7560 ret = (VALUE)NULL;
7561
7562 /* decr internal handler mark */
7563 rbtk_internal_eventloop_handler--;
7564
7565 /* complete */
7566 *(q->done) = -1;
7567
7568 /* unlink ruby objects */
7569 q->interp = (VALUE)NULL;
7570 q->result = (VALUE)NULL;
7571 q->thread = (VALUE)NULL;
7572
7573 /* back to caller */
7574 #ifdef RUBY_VM
7575 if (RTEST(rb_funcall(thread, ID_alive_p, 0, 0))) {
7576 #else
7577 if (RTEST(rb_thread_alive_p(thread))) {
7578 #endif
7579 DUMP2("back to caller (caller thread:%lx)", thread);
7580 DUMP2(" (current thread:%lx)", rb_thread_current());
7581 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
7582 have_rb_thread_waiting_for_value = 1;
7583 rb_thread_wakeup(thread);
7584 #else
7585 rb_thread_run(thread);
7586 #endif
7587 DUMP1("finish back to caller");
7588 #if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
7589 rb_thread_schedule();
7590 #endif
7591 } else {
7592 DUMP2("caller is dead (caller thread:%lx)", thread);
7593 DUMP2(" (current thread:%lx)", rb_thread_current());
7594 }
7595
7596 /* end of handler : remove it */
7597 return 1;
7598 }
7599
7600 static VALUE
7601 ip_eval(self, str)
7602 VALUE self;
7603 VALUE str;
7604 {
7605 struct eval_queue *evq;
7606 #ifdef RUBY_USE_NATIVE_THREAD
7607 struct tcltkip *ptr;
7608 #endif
7609 char *eval_str;
7610 int *alloc_done;
7611 int thr_crit_bup;
7612 volatile VALUE current = rb_thread_current();
7613 volatile VALUE ip_obj = self;
7614 volatile VALUE result;
7615 volatile VALUE ret;
7616 Tcl_QueuePosition position;
7617 struct timeval t;
7618
7619 thr_crit_bup = rb_thread_critical;
7620 rb_thread_critical = Qtrue;
7621 StringValue(str);
7622 rb_thread_critical = thr_crit_bup;
7623
7624 #ifdef RUBY_USE_NATIVE_THREAD
7625 ptr = get_ip(ip_obj);
7626 DUMP2("eval status: ptr->tk_thread_id %p", ptr->tk_thread_id);
7627 DUMP2("eval status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
7628 #else
7629 DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
7630 #endif
7631 DUMP2("status: eventloopt_thread %lx", eventloop_thread);
7632
7633 if (
7634 #ifdef RUBY_USE_NATIVE_THREAD
7635 (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread())
7636 &&
7637 #endif
7638 (NIL_P(eventloop_thread) || current == eventloop_thread)
7639 ) {
7640 if (NIL_P(eventloop_thread)) {
7641 DUMP2("eval from thread:%lx but no eventloop", current);
7642 } else {
7643 DUMP2("eval from current eventloop %lx", current);
7644 }
7645 result = ip_eval_real(self, RSTRING_PTR(str), RSTRING_LENINT(str));
7646 if (rb_obj_is_kind_of(result, rb_eException)) {
7647 rb_exc_raise(result);
7648 }
7649 return result;
7650 }
7651
7652 DUMP2("eval from thread %lx (NOT current eventloop)", current);
7653
7654 thr_crit_bup = rb_thread_critical;
7655 rb_thread_critical = Qtrue;
7656
7657 /* allocate memory (keep result) */
7658 /* alloc_done = (int*)ALLOC(int); */
7659 alloc_done = RbTk_ALLOC_N(int, 1);
7660 #if 0 /* use Tcl_Preserve/Release */
7661 Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */
7662 #endif
7663 *alloc_done = 0;
7664
7665 /* eval_str = ALLOC_N(char, RSTRING_LEN(str) + 1); */
7666 eval_str = ckalloc(RSTRING_LENINT(str) + 1);
7667 #if 0 /* use Tcl_Preserve/Release */
7668 Tcl_Preserve((ClientData)eval_str); /* XXXXXXXX */
7669 #endif
7670 memcpy(eval_str, RSTRING_PTR(str), RSTRING_LEN(str));
7671 eval_str[RSTRING_LEN(str)] = 0;
7672
7673 /* allocate memory (freed by Tcl_ServiceEvent) */
7674 /* evq = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); */
7675 evq = RbTk_ALLOC_N(struct eval_queue, 1);
7676 #if 0 /* use Tcl_Preserve/Release */
7677 Tcl_Preserve(evq);
7678 #endif
7679
7680 /* allocate result obj */
7681 result = rb_ary_new3(1, Qnil);
7682
7683 /* construct event data */
7684 evq->done = alloc_done;
7685 evq->str = eval_str;
7686 evq->len = RSTRING_LENINT(str);
7687 evq->interp = ip_obj;
7688 evq->result = result;
7689 evq->thread = current;
7690 evq->safe_level = rb_safe_level();
7691 evq->ev.proc = eval_queue_handler;
7692
7693 position = TCL_QUEUE_TAIL;
7694
7695 /* add the handler to Tcl event queue */
7696 DUMP1("add handler");
7697 #ifdef RUBY_USE_NATIVE_THREAD
7698 if (ptr->tk_thread_id) {
7699 /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(evq->ev), position); */
7700 Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)evq, position);
7701 Tcl_ThreadAlert(ptr->tk_thread_id);
7702 } else if (tk_eventloop_thread_id) {
7703 Tcl_ThreadQueueEvent(tk_eventloop_thread_id, (Tcl_Event*)evq, position);
7704 /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
7705 &(evq->ev), position); */
7706 Tcl_ThreadAlert(tk_eventloop_thread_id);
7707 } else {
7708 /* Tcl_QueueEvent(&(evq->ev), position); */
7709 Tcl_QueueEvent((Tcl_Event*)evq, position);
7710 }
7711 #else
7712 /* Tcl_QueueEvent(&(evq->ev), position); */
7713 Tcl_QueueEvent((Tcl_Event*)evq, position);
7714 #endif
7715
7716 rb_thread_critical = thr_crit_bup;
7717
7718 /* wait for the handler to be processed */
7719 t.tv_sec = 0;
7720 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
7721
7722 DUMP2("evq wait for handler (current thread:%lx)", current);
7723 while(*alloc_done >= 0) {
7724 DUMP2("*** evq wait for handler (current thread:%lx)", current);
7725 /* rb_thread_stop(); */
7726 /* rb_thread_sleep_forever(); */
7727 rb_thread_wait_for(t);
7728 DUMP2("*** evq wakeup (current thread:%lx)", current);
7729 DUMP2("*** (eventloop thread:%lx)", eventloop_thread);
7730 if (NIL_P(eventloop_thread)) {
7731 DUMP1("*** evq lost eventloop thread");
7732 break;
7733 }
7734 }
7735 DUMP2("back from handler (current thread:%lx)", current);
7736
7737 /* get result & free allocated memory */
7738 ret = RARRAY_PTR(result)[0];
7739
7740 #if 0 /* use Tcl_EventuallyFree */
7741 Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */
7742 #else
7743 #if 0 /* use Tcl_Preserve/Release */
7744 Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */
7745 #else
7746 /* free(alloc_done); */
7747 ckfree((char*)alloc_done);
7748 #endif
7749 #endif
7750 #if 0 /* use Tcl_EventuallyFree */
7751 Tcl_EventuallyFree((ClientData)eval_str, TCL_DYNAMIC); /* XXXXXXXX */
7752 #else
7753 #if 0 /* use Tcl_Preserve/Release */
7754 Tcl_Release((ClientData)eval_str); /* XXXXXXXX */
7755 #else
7756 /* free(eval_str); */
7757 ckfree(eval_str);
7758 #endif
7759 #endif
7760 #if 0 /* evq is freed by Tcl_ServiceEvent */
7761 #if 0 /* use Tcl_Preserve/Release */
7762 Tcl_Release(evq);
7763 #else
7764 ckfree((char*)evq);
7765 #endif
7766 #endif
7767
7768 if (rb_obj_is_kind_of(ret, rb_eException)) {
7769 DUMP1("raise exception");
7770 /* rb_exc_raise(ret); */
7771 rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
7772 rb_funcall(ret, ID_to_s, 0, 0)));
7773 }
7774
7775 return ret;
7776 }
7777
7778
7779 static int
7780 ip_cancel_eval_core(interp, msg, flag)
7781 Tcl_Interp *interp;
7782 VALUE msg;
7783 int flag;
7784 {
7785 #if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6)
7786 rb_raise(rb_eNotImpError,
7787 "cancel_eval is supported Tcl/Tk8.6 or later.");
7788
7789 UNREACHABLE;
7790 #else
7791 Tcl_Obj *msg_obj;
7792
7793 if (NIL_P(msg)) {
7794 msg_obj = NULL;
7795 } else {
7796 msg_obj = Tcl_NewStringObj(RSTRING_PTR(msg), RSTRING_LEN(msg));
7797 Tcl_IncrRefCount(msg_obj);
7798 }
7799
7800 return Tcl_CancelEval(interp, msg_obj, 0, flag);
7801 #endif
7802 }
7803
7804 static VALUE
7805 ip_cancel_eval(argc, argv, self)
7806 int argc;
7807 VALUE *argv;
7808 VALUE self;
7809 {
7810 VALUE retval;
7811
7812 if (rb_scan_args(argc, argv, "01", &retval) == 0) {
7813 retval = Qnil;
7814 }
7815 if (ip_cancel_eval_core(get_ip(self)->ip, retval, 0) == TCL_OK) {
7816 return Qtrue;
7817 } else {
7818 return Qfalse;
7819 }
7820 }
7821
7822 #ifndef TCL_CANCEL_UNWIND
7823 #define TCL_CANCEL_UNWIND 0x100000
7824 #endif
7825 static VALUE
7826 ip_cancel_eval_unwind(argc, argv, self)
7827 int argc;
7828 VALUE *argv;
7829 VALUE self;
7830 {
7831 int flag = 0;
7832 VALUE retval;
7833
7834 if (rb_scan_args(argc, argv, "01", &retval) == 0) {
7835 retval = Qnil;
7836 }
7837
7838 flag |= TCL_CANCEL_UNWIND;
7839 if (ip_cancel_eval_core(get_ip(self)->ip, retval, flag) == TCL_OK) {
7840 return Qtrue;
7841 } else {
7842 return Qfalse;
7843 }
7844 }
7845
7846 /* restart Tk */
7847 static VALUE
7848 lib_restart_core(interp, argc, argv)
7849 VALUE interp;
7850 int argc; /* dummy */
7851 VALUE *argv; /* dummy */
7852 {
7853 volatile VALUE exc;
7854 struct tcltkip *ptr = get_ip(interp);
7855 int thr_crit_bup;
7856
7857 /* rb_secure(4); */ /* already checked */
7858
7859 /* tcl_stubs_check(); */ /* already checked */
7860
7861 /* ip is deleted? */
7862 if (deleted_ip(ptr)) {
7863 return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted");
7864 }
7865
7866 thr_crit_bup = rb_thread_critical;
7867 rb_thread_critical = Qtrue;
7868
7869 /* Tcl_Preserve(ptr->ip); */
7870 rbtk_preserve_ip(ptr);
7871
7872 /* destroy the root wdiget */
7873 ptr->return_value = Tcl_Eval(ptr->ip, "destroy .");
7874 /* ignore ERROR */
7875 DUMP2("(TCL_Eval result) %d", ptr->return_value);
7876 Tcl_ResetResult(ptr->ip);
7877
7878 #if TCL_MAJOR_VERSION >= 8
7879 /* delete namespace ( tested on tk8.4.5 ) */
7880 ptr->return_value = Tcl_Eval(ptr->ip, "namespace delete ::tk::msgcat");
7881 /* ignore ERROR */
7882 DUMP2("(TCL_Eval result) %d", ptr->return_value);
7883 Tcl_ResetResult(ptr->ip);
7884 #endif
7885
7886 /* delete trace proc ( tested on tk8.4.5 ) */
7887 ptr->return_value = Tcl_Eval(ptr->ip, "trace vdelete ::tk_strictMotif w ::tk::EventMotifBindings");
7888 /* ignore ERROR */
7889 DUMP2("(TCL_Eval result) %d", ptr->return_value);
7890 Tcl_ResetResult(ptr->ip);
7891
7892 /* execute Tk_Init or Tk_SafeInit */
7893 exc = tcltkip_init_tk(interp);
7894 if (!NIL_P(exc)) {
7895 rb_thread_critical = thr_crit_bup;
7896 rbtk_release_ip(ptr);
7897 return exc;
7898 }
7899
7900 /* Tcl_Release(ptr->ip); */
7901 rbtk_release_ip(ptr);
7902
7903 rb_thread_critical = thr_crit_bup;
7904
7905 /* return Qnil; */
7906 return interp;
7907 }
7908
7909 static VALUE
7910 lib_restart(self)
7911 VALUE self;
7912 {
7913 struct tcltkip *ptr = get_ip(self);
7914
7915 rb_secure(4);
7916
7917 tcl_stubs_check();
7918
7919 /* ip is deleted? */
7920 if (deleted_ip(ptr)) {
7921 rb_raise(rb_eRuntimeError, "interpreter is deleted");
7922 }
7923
7924 return tk_funcall(lib_restart_core, 0, (VALUE*)NULL, self);
7925 }
7926
7927
7928 static VALUE
7929 ip_restart(self)
7930 VALUE self;
7931 {
7932 struct tcltkip *ptr = get_ip(self);
7933
7934 rb_secure(4);
7935
7936 tcl_stubs_check();
7937
7938 /* ip is deleted? */
7939 if (deleted_ip(ptr)) {
7940 rb_raise(rb_eRuntimeError, "interpreter is deleted");
7941 }
7942
7943 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
7944 /* slave IP */
7945 return Qnil;
7946 }
7947 return lib_restart(self);
7948 }
7949
7950 static VALUE
7951 lib_toUTF8_core(ip_obj, src, encodename)
7952 VALUE ip_obj;
7953 VALUE src;
7954 VALUE encodename;
7955 {
7956 volatile VALUE str = src;
7957
7958 #ifdef TCL_UTF_MAX
7959 Tcl_Interp *interp;
7960 Tcl_Encoding encoding;
7961 Tcl_DString dstr;
7962 int taint_flag = OBJ_TAINTED(str);
7963 struct tcltkip *ptr;
7964 char *buf;
7965 int thr_crit_bup;
7966 #endif
7967
7968 tcl_stubs_check();
7969
7970 if (NIL_P(src)) {
7971 return rb_str_new2("");
7972 }
7973
7974 #ifdef TCL_UTF_MAX
7975 if (NIL_P(ip_obj)) {
7976 interp = (Tcl_Interp *)NULL;
7977 } else {
7978 ptr = get_ip(ip_obj);
7979
7980 /* ip is deleted? */
7981 if (deleted_ip(ptr)) {
7982 interp = (Tcl_Interp *)NULL;
7983 } else {
7984 interp = ptr->ip;
7985 }
7986 }
7987
7988 thr_crit_bup = rb_thread_critical;
7989 rb_thread_critical = Qtrue;
7990
7991 if (NIL_P(encodename)) {
7992 if (TYPE(str) == T_STRING) {
7993 volatile VALUE enc;
7994
7995 #ifdef HAVE_RUBY_ENCODING_H
7996 enc = rb_funcall(rb_obj_encoding(str), ID_to_s, 0, 0);
7997 #else
7998 enc = rb_attr_get(str, ID_at_enc);
7999 #endif
8000 if (NIL_P(enc)) {
8001 if (NIL_P(ip_obj)) {
8002 encoding = (Tcl_Encoding)NULL;
8003 } else {
8004 enc = rb_attr_get(ip_obj, ID_at_enc);
8005 if (NIL_P(enc)) {
8006 encoding = (Tcl_Encoding)NULL;
8007 } else {
8008 /* StringValue(enc); */
8009 enc = rb_funcall(enc, ID_to_s, 0, 0);
8010 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
8011 if (!RSTRING_LEN(enc)) {
8012 encoding = (Tcl_Encoding)NULL;
8013 } else {
8014 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL,
8015 RSTRING_PTR(enc));
8016 if (encoding == (Tcl_Encoding)NULL) {
8017 rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc));
8018 }
8019 }
8020 }
8021 }
8022 } else {
8023 StringValue(enc);
8024 if (strcmp(RSTRING_PTR(enc), "binary") == 0) {
8025 #ifdef HAVE_RUBY_ENCODING_H
8026 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
8027 #endif
8028 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
8029 rb_thread_critical = thr_crit_bup;
8030 return str;
8031 }
8032 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
8033 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL,
8034 RSTRING_PTR(enc));
8035 if (encoding == (Tcl_Encoding)NULL) {
8036 rb_warning("string has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc));
8037 }
8038 }
8039 } else {
8040 encoding = (Tcl_Encoding)NULL;
8041 }
8042 } else {
8043 StringValue(encodename);
8044 if (strcmp(RSTRING_PTR(encodename), "binary") == 0) {
8045 #ifdef HAVE_RUBY_ENCODING_H
8046 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
8047 #endif
8048 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
8049 rb_thread_critical = thr_crit_bup;
8050 return str;
8051 }
8052 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); */
8053 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename));
8054 if (encoding == (Tcl_Encoding)NULL) {
8055 /*
8056 rb_warning("unknown encoding name '%s'",
8057 RSTRING_PTR(encodename));
8058 */
8059 rb_raise(rb_eArgError, "unknown encoding name '%s'",
8060 RSTRING_PTR(encodename));
8061 }
8062 }
8063
8064 StringValue(str);
8065 if (!RSTRING_LEN(str)) {
8066 rb_thread_critical = thr_crit_bup;
8067 return str;
8068 }
8069 buf = ALLOC_N(char, RSTRING_LEN(str)+1);
8070 /* buf = ckalloc(sizeof(char) * (RSTRING_LENINT(str)+1)); */
8071 memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str));
8072 buf[RSTRING_LEN(str)] = 0;
8073
8074 Tcl_DStringInit(&dstr);
8075 Tcl_DStringFree(&dstr);
8076 /* Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr); */
8077 Tcl_ExternalToUtfDString(encoding, buf, RSTRING_LENINT(str), &dstr);
8078
8079 /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */
8080 /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */
8081 str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
8082 #ifdef HAVE_RUBY_ENCODING_H
8083 rb_enc_associate_index(str, ENCODING_INDEX_UTF8);
8084 #endif
8085 if (taint_flag) RbTk_OBJ_UNTRUST(str);
8086 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8);
8087
8088 /*
8089 if (encoding != (Tcl_Encoding)NULL) {
8090 Tcl_FreeEncoding(encoding);
8091 }
8092 */
8093 Tcl_DStringFree(&dstr);
8094
8095 xfree(buf);
8096 /* ckfree(buf); */
8097
8098 rb_thread_critical = thr_crit_bup;
8099 #endif
8100
8101 return str;
8102 }
8103
8104 static VALUE
8105 lib_toUTF8(argc, argv, self)
8106 int argc;
8107 VALUE *argv;
8108 VALUE self;
8109 {
8110 VALUE str, encodename;
8111
8112 if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
8113 encodename = Qnil;
8114 }
8115 return lib_toUTF8_core(Qnil, str, encodename);
8116 }
8117
8118 static VALUE
8119 ip_toUTF8(argc, argv, self)
8120 int argc;
8121 VALUE *argv;
8122 VALUE self;
8123 {
8124 VALUE str, encodename;
8125
8126 if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
8127 encodename = Qnil;
8128 }
8129 return lib_toUTF8_core(self, str, encodename);
8130 }
8131
8132 static VALUE
8133 lib_fromUTF8_core(ip_obj, src, encodename)
8134 VALUE ip_obj;
8135 VALUE src;
8136 VALUE encodename;
8137 {
8138 volatile VALUE str = src;
8139
8140 #ifdef TCL_UTF_MAX
8141 Tcl_Interp *interp;
8142 Tcl_Encoding encoding;
8143 Tcl_DString dstr;
8144 int taint_flag = OBJ_TAINTED(str);
8145 char *buf;
8146 int thr_crit_bup;
8147 #endif
8148
8149 tcl_stubs_check();
8150
8151 if (NIL_P(src)) {
8152 return rb_str_new2("");
8153 }
8154
8155 #ifdef TCL_UTF_MAX
8156 if (NIL_P(ip_obj)) {
8157 interp = (Tcl_Interp *)NULL;
8158 } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) {
8159 interp = (Tcl_Interp *)NULL;
8160 } else {
8161 interp = get_ip(ip_obj)->ip;
8162 }
8163
8164 thr_crit_bup = rb_thread_critical;
8165 rb_thread_critical = Qtrue;
8166
8167 if (NIL_P(encodename)) {
8168 volatile VALUE enc;
8169
8170 if (TYPE(str) == T_STRING) {
8171 enc = rb_attr_get(str, ID_at_enc);
8172 if (!NIL_P(enc)) {
8173 StringValue(enc);
8174 if (strcmp(RSTRING_PTR(enc), "binary") == 0) {
8175 #ifdef HAVE_RUBY_ENCODING_H
8176 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
8177 #endif
8178 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
8179 rb_thread_critical = thr_crit_bup;
8180 return str;
8181 }
8182 #ifdef HAVE_RUBY_ENCODING_H
8183 } else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) {
8184 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
8185 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
8186 rb_thread_critical = thr_crit_bup;
8187 return str;
8188 #endif
8189 }
8190 }
8191
8192 if (NIL_P(ip_obj)) {
8193 encoding = (Tcl_Encoding)NULL;
8194 } else {
8195 enc = rb_attr_get(ip_obj, ID_at_enc);
8196 if (NIL_P(enc)) {
8197 encoding = (Tcl_Encoding)NULL;
8198 } else {
8199 /* StringValue(enc); */
8200 enc = rb_funcall(enc, ID_to_s, 0, 0);
8201 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
8202 if (!RSTRING_LEN(enc)) {
8203 encoding = (Tcl_Encoding)NULL;
8204 } else {
8205 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL,
8206 RSTRING_PTR(enc));
8207 if (encoding == (Tcl_Encoding)NULL) {
8208 rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc));
8209 } else {
8210 encodename = rb_obj_dup(enc);
8211 }
8212 }
8213 }
8214 }
8215
8216 } else {
8217 StringValue(encodename);
8218
8219 if (strcmp(RSTRING_PTR(encodename), "binary") == 0) {
8220 Tcl_Obj *tclstr;
8221 char *s;
8222 int len;
8223
8224 StringValue(str);
8225 tclstr = Tcl_NewStringObj(RSTRING_PTR(str), RSTRING_LENINT(str));
8226 Tcl_IncrRefCount(tclstr);
8227 s = (char*)Tcl_GetByteArrayFromObj(tclstr, &len);
8228 str = rb_tainted_str_new(s, len);
8229 s = (char*)NULL;
8230 Tcl_DecrRefCount(tclstr);
8231 #ifdef HAVE_RUBY_ENCODING_H
8232 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
8233 #endif
8234 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
8235
8236 rb_thread_critical = thr_crit_bup;
8237 return str;
8238 }
8239
8240 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); */
8241 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename));
8242 if (encoding == (Tcl_Encoding)NULL) {
8243 /*
8244 rb_warning("unknown encoding name '%s'",
8245 RSTRING_PTR(encodename));
8246 encodename = Qnil;
8247 */
8248 rb_raise(rb_eArgError, "unknown encoding name '%s'",
8249 RSTRING_PTR(encodename));
8250 }
8251 }
8252
8253 StringValue(str);
8254
8255 if (RSTRING_LEN(str) == 0) {
8256 rb_thread_critical = thr_crit_bup;
8257 return rb_tainted_str_new2("");
8258 }
8259
8260 buf = ALLOC_N(char, RSTRING_LEN(str)+1);
8261 /* buf = ckalloc(sizeof(char) * (RSTRING_LENINT(str)+1)); */
8262 memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str));
8263 buf[RSTRING_LEN(str)] = 0;
8264
8265 Tcl_DStringInit(&dstr);
8266 Tcl_DStringFree(&dstr);
8267 /* Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr); */
8268 Tcl_UtfToExternalDString(encoding,buf,RSTRING_LENINT(str),&dstr);
8269
8270 /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */
8271 /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */
8272 str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
8273 #ifdef HAVE_RUBY_ENCODING_H
8274 if (interp) {
8275 /* can access encoding_table of TclTkIp */
8276 /* -> try to use encoding_table */
8277 VALUE tbl = ip_get_encoding_table(ip_obj);
8278 VALUE encobj = encoding_table_get_obj(tbl, encodename);
8279 rb_enc_associate_index(str, rb_to_encoding_index(encobj));
8280 } else {
8281 /* cannot access encoding_table of TclTkIp */
8282 /* -> try to find on Ruby Encoding */
8283 rb_enc_associate_index(str, rb_enc_find_index(RSTRING_PTR(encodename)));
8284 }
8285 #endif
8286
8287 if (taint_flag) RbTk_OBJ_UNTRUST(str);
8288 rb_ivar_set(str, ID_at_enc, encodename);
8289
8290 /*
8291 if (encoding != (Tcl_Encoding)NULL) {
8292 Tcl_FreeEncoding(encoding);
8293 }
8294 */
8295 Tcl_DStringFree(&dstr);
8296
8297 xfree(buf);
8298 /* ckfree(buf); */
8299
8300 rb_thread_critical = thr_crit_bup;
8301 #endif
8302
8303 return str;
8304 }
8305
8306 static VALUE
8307 lib_fromUTF8(argc, argv, self)
8308 int argc;
8309 VALUE *argv;
8310 VALUE self;
8311 {
8312 VALUE str, encodename;
8313
8314 if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
8315 encodename = Qnil;
8316 }
8317 return lib_fromUTF8_core(Qnil, str, encodename);
8318 }
8319
8320 static VALUE
8321 ip_fromUTF8(argc, argv, self)
8322 int argc;
8323 VALUE *argv;
8324 VALUE self;
8325 {
8326 VALUE str, encodename;
8327
8328 if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
8329 encodename = Qnil;
8330 }
8331 return lib_fromUTF8_core(self, str, encodename);
8332 }
8333
8334 static VALUE
8335 lib_UTF_backslash_core(self, str, all_bs)
8336 VALUE self;
8337 VALUE str;
8338 int all_bs;
8339 {
8340 #ifdef TCL_UTF_MAX
8341 char *src_buf, *dst_buf, *ptr;
8342 int read_len = 0, dst_len = 0;
8343 int taint_flag = OBJ_TAINTED(str);
8344 int thr_crit_bup;
8345
8346 tcl_stubs_check();
8347
8348 StringValue(str);
8349 if (!RSTRING_LEN(str)) {
8350 return str;
8351 }
8352
8353 thr_crit_bup = rb_thread_critical;
8354 rb_thread_critical = Qtrue;
8355
8356 /* src_buf = ALLOC_N(char, RSTRING_LEN(str)+1); */
8357 src_buf = ckalloc(RSTRING_LENINT(str)+1);
8358 #if 0 /* use Tcl_Preserve/Release */
8359 Tcl_Preserve((ClientData)src_buf); /* XXXXXXXX */
8360 #endif
8361 memcpy(src_buf, RSTRING_PTR(str), RSTRING_LEN(str));
8362 src_buf[RSTRING_LEN(str)] = 0;
8363
8364 /* dst_buf = ALLOC_N(char, RSTRING_LEN(str)+1); */
8365 dst_buf = ckalloc(RSTRING_LENINT(str)+1);
8366 #if 0 /* use Tcl_Preserve/Release */
8367 Tcl_Preserve((ClientData)dst_buf); /* XXXXXXXX */
8368 #endif
8369
8370 ptr = src_buf;
8371 while(RSTRING_LEN(str) > ptr - src_buf) {
8372 if (*ptr == '\\' && (all_bs || *(ptr + 1) == 'u')) {
8373 dst_len += Tcl_UtfBackslash(ptr, &read_len, (dst_buf + dst_len));
8374 ptr += read_len;
8375 } else {
8376 *(dst_buf + (dst_len++)) = *(ptr++);
8377 }
8378 }
8379
8380 str = rb_str_new(dst_buf, dst_len);
8381 if (taint_flag) RbTk_OBJ_UNTRUST(str);
8382 #ifdef HAVE_RUBY_ENCODING_H
8383 rb_enc_associate_index(str, ENCODING_INDEX_UTF8);
8384 #endif
8385 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8);
8386
8387 #if 0 /* use Tcl_EventuallyFree */
8388 Tcl_EventuallyFree((ClientData)src_buf, TCL_DYNAMIC); /* XXXXXXXX */
8389 #else
8390 #if 0 /* use Tcl_Preserve/Release */
8391 Tcl_Release((ClientData)src_buf); /* XXXXXXXX */
8392 #else
8393 /* free(src_buf); */
8394 ckfree(src_buf);
8395 #endif
8396 #endif
8397 #if 0 /* use Tcl_EventuallyFree */
8398 Tcl_EventuallyFree((ClientData)dst_buf, TCL_DYNAMIC); /* XXXXXXXX */
8399 #else
8400 #if 0 /* use Tcl_Preserve/Release */
8401 Tcl_Release((ClientData)dst_buf); /* XXXXXXXX */
8402 #else
8403 /* free(dst_buf); */
8404 ckfree(dst_buf);
8405 #endif
8406 #endif
8407
8408 rb_thread_critical = thr_crit_bup;
8409 #endif
8410
8411 return str;
8412 }
8413
8414 static VALUE
8415 lib_UTF_backslash(self, str)
8416 VALUE self;
8417 VALUE str;
8418 {
8419 return lib_UTF_backslash_core(self, str, 0);
8420 }
8421
8422 static VALUE
8423 lib_Tcl_backslash(self, str)
8424 VALUE self;
8425 VALUE str;
8426 {
8427 return lib_UTF_backslash_core(self, str, 1);
8428 }
8429
8430 static VALUE
8431 lib_get_system_encoding(self)
8432 VALUE self;
8433 {
8434 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
8435 tcl_stubs_check();
8436 return rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL));
8437 #else
8438 return Qnil;
8439 #endif
8440 }
8441
8442 static VALUE
8443 lib_set_system_encoding(self, enc_name)
8444 VALUE self;
8445 VALUE enc_name;
8446 {
8447 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
8448 tcl_stubs_check();
8449
8450 if (NIL_P(enc_name)) {
8451 Tcl_SetSystemEncoding((Tcl_Interp *)NULL, (CONST char *)NULL);
8452 return lib_get_system_encoding(self);
8453 }
8454
8455 enc_name = rb_funcall(enc_name, ID_to_s, 0, 0);
8456 if (Tcl_SetSystemEncoding((Tcl_Interp *)NULL,
8457 StringValuePtr(enc_name)) != TCL_OK) {
8458 rb_raise(rb_eArgError, "unknown encoding name '%s'",
8459 RSTRING_PTR(enc_name));
8460 }
8461
8462 return enc_name;
8463 #else
8464 return Qnil;
8465 #endif
8466 }
8467
8468
8469 /* invoke Tcl proc */
8470 struct invoke_info {
8471 struct tcltkip *ptr;
8472 Tcl_CmdInfo cmdinfo;
8473 #if TCL_MAJOR_VERSION >= 8
8474 int objc;
8475 Tcl_Obj **objv;
8476 #else
8477 int argc;
8478 char **argv;
8479 #endif
8480 };
8481
8482 static VALUE
8483 #ifdef HAVE_PROTOTYPES
8484 invoke_tcl_proc(VALUE arg)
8485 #else
8486 invoke_tcl_proc(arg)
8487 VALUE arg;
8488 #endif
8489 {
8490 struct invoke_info *inf = (struct invoke_info *)arg;
8491 int i, len;
8492 #if TCL_MAJOR_VERSION >= 8
8493 int argc = inf->objc;
8494 char **argv = (char **)NULL;
8495 #endif
8496
8497 /* memory allocation for arguments of this command */
8498 #if TCL_MAJOR_VERSION >= 8
8499 if (!inf->cmdinfo.isNativeObjectProc) {
8500 /* string interface */
8501 /* argv = (char **)ALLOC_N(char *, argc+1);*/ /* XXXXXXXXXX */
8502 argv = RbTk_ALLOC_N(char *, (argc+1));
8503 #if 0 /* use Tcl_Preserve/Release */
8504 Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
8505 #endif
8506 for (i = 0; i < argc; ++i) {
8507 argv[i] = Tcl_GetStringFromObj(inf->objv[i], &len);
8508 }
8509 argv[argc] = (char *)NULL;
8510 }
8511 #endif
8512
8513 Tcl_ResetResult(inf->ptr->ip);
8514
8515 /* Invoke the C procedure */
8516 #if TCL_MAJOR_VERSION >= 8
8517 if (inf->cmdinfo.isNativeObjectProc) {
8518 inf->ptr->return_value
8519 = (*(inf->cmdinfo.objProc))(inf->cmdinfo.objClientData,
8520 inf->ptr->ip, inf->objc, inf->objv);
8521 }
8522 else
8523 #endif
8524 {
8525 #if TCL_MAJOR_VERSION >= 8
8526 inf->ptr->return_value
8527 = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip,
8528 argc, (CONST84 char **)argv);
8529
8530 #if 0 /* use Tcl_EventuallyFree */
8531 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
8532 #else
8533 #if 0 /* use Tcl_Preserve/Release */
8534 Tcl_Release((ClientData)argv); /* XXXXXXXX */
8535 #else
8536 /* free(argv); */
8537 ckfree((char*)argv);
8538 #endif
8539 #endif
8540
8541 #else /* TCL_MAJOR_VERSION < 8 */
8542 inf->ptr->return_value
8543 = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip,
8544 inf->argc, inf->argv);
8545 #endif
8546 }
8547
8548 return Qnil;
8549 }
8550
8551
8552 #if TCL_MAJOR_VERSION >= 8
8553 static VALUE
8554 ip_invoke_core(interp, objc, objv)
8555 VALUE interp;
8556 int objc;
8557 Tcl_Obj **objv;
8558 #else
8559 static VALUE
8560 ip_invoke_core(interp, argc, argv)
8561 VALUE interp;
8562 int argc;
8563 char **argv;
8564 #endif
8565 {
8566 struct tcltkip *ptr;
8567 Tcl_CmdInfo info;
8568 char *cmd;
8569 int len;
8570 int thr_crit_bup;
8571 int unknown_flag = 0;
8572
8573 #if 1 /* wrap tcl-proc call */
8574 struct invoke_info inf;
8575 int status;
8576 VALUE ret;
8577 #else
8578 #if TCL_MAJOR_VERSION >= 8
8579 int argc = objc;
8580 char **argv = (char **)NULL;
8581 /* Tcl_Obj *resultPtr; */
8582 #endif
8583 #endif
8584
8585 /* get the data struct */
8586 ptr = get_ip(interp);
8587
8588 /* get the command name string */
8589 #if TCL_MAJOR_VERSION >= 8
8590 cmd = Tcl_GetStringFromObj(objv[0], &len);
8591 #else /* TCL_MAJOR_VERSION < 8 */
8592 cmd = argv[0];
8593 #endif
8594
8595 /* get the data struct */
8596 ptr = get_ip(interp);
8597
8598 /* ip is deleted? */
8599 if (deleted_ip(ptr)) {
8600 return rb_tainted_str_new2("");
8601 }
8602
8603 /* Tcl_Preserve(ptr->ip); */
8604 rbtk_preserve_ip(ptr);
8605
8606 /* map from the command name to a C procedure */
8607 DUMP2("call Tcl_GetCommandInfo, %s", cmd);
8608 if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) {
8609 DUMP1("error Tcl_GetCommandInfo");
8610 DUMP1("try auto_load (call 'unknown' command)");
8611 if (!Tcl_GetCommandInfo(ptr->ip,
8612 #if TCL_MAJOR_VERSION >= 8
8613 "::unknown",
8614 #else
8615 "unknown",
8616 #endif
8617 &info)) {
8618 DUMP1("fail to get 'unknown' command");
8619 /* if (event_loop_abort_on_exc || cmd[0] != '.') { */
8620 if (event_loop_abort_on_exc > 0) {
8621 /* Tcl_Release(ptr->ip); */
8622 rbtk_release_ip(ptr);
8623 /*rb_ip_raise(obj,rb_eNameError,"invalid command name `%s'",cmd);*/
8624 return create_ip_exc(interp, rb_eNameError,
8625 "invalid command name `%s'", cmd);
8626 } else {
8627 if (event_loop_abort_on_exc < 0) {
8628 rb_warning("invalid command name `%s' (ignore)", cmd);
8629 } else {
8630 rb_warn("invalid command name `%s' (ignore)", cmd);
8631 }
8632 Tcl_ResetResult(ptr->ip);
8633 /* Tcl_Release(ptr->ip); */
8634 rbtk_release_ip(ptr);
8635 return rb_tainted_str_new2("");
8636 }
8637 } else {
8638 #if TCL_MAJOR_VERSION >= 8
8639 Tcl_Obj **unknown_objv;
8640 #else
8641 char **unknown_argv;
8642 #endif
8643 DUMP1("find 'unknown' command -> set arguemnts");
8644 unknown_flag = 1;
8645
8646 #if TCL_MAJOR_VERSION >= 8
8647 /* unknown_objv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, objc+2); */
8648 unknown_objv = RbTk_ALLOC_N(Tcl_Obj *, (objc+2));
8649 #if 0 /* use Tcl_Preserve/Release */
8650 Tcl_Preserve((ClientData)unknown_objv); /* XXXXXXXX */
8651 #endif
8652 unknown_objv[0] = Tcl_NewStringObj("::unknown", 9);
8653 Tcl_IncrRefCount(unknown_objv[0]);
8654 memcpy(unknown_objv + 1, objv, sizeof(Tcl_Obj *)*objc);
8655 unknown_objv[++objc] = (Tcl_Obj*)NULL;
8656 objv = unknown_objv;
8657 #else
8658 /* unknown_argv = (char **)ALLOC_N(char *, argc+2); */
8659 unknown_argv = RbTk_ALLOC_N(char *, (argc+2));
8660 #if 0 /* use Tcl_Preserve/Release */
8661 Tcl_Preserve((ClientData)unknown_argv); /* XXXXXXXX */
8662 #endif
8663 unknown_argv[0] = strdup("unknown");
8664 memcpy(unknown_argv + 1, argv, sizeof(char *)*argc);
8665 unknown_argv[++argc] = (char *)NULL;
8666 argv = unknown_argv;
8667 #endif
8668 }
8669 }
8670 DUMP1("end Tcl_GetCommandInfo");
8671
8672 thr_crit_bup = rb_thread_critical;
8673 rb_thread_critical = Qtrue;
8674
8675 #if 1 /* wrap tcl-proc call */
8676 /* setup params */
8677 inf.ptr = ptr;
8678 inf.cmdinfo = info;
8679 #if TCL_MAJOR_VERSION >= 8
8680 inf.objc = objc;
8681 inf.objv = objv;
8682 #else
8683 inf.argc = argc;
8684 inf.argv = argv;
8685 #endif
8686
8687 /* invoke tcl-proc */
8688 ret = rb_protect(invoke_tcl_proc, (VALUE)&inf, &status);
8689 switch(status) {
8690 case TAG_RAISE:
8691 if (NIL_P(rb_errinfo())) {
8692 rbtk_pending_exception = rb_exc_new2(rb_eException,
8693 "unknown exception");
8694 } else {
8695 rbtk_pending_exception = rb_errinfo();
8696 }
8697 break;
8698
8699 case TAG_FATAL:
8700 if (NIL_P(rb_errinfo())) {
8701 rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
8702 } else {
8703 rbtk_pending_exception = rb_errinfo();
8704 }
8705 }
8706
8707 #else /* !wrap tcl-proc call */
8708
8709 /* memory allocation for arguments of this command */
8710 #if TCL_MAJOR_VERSION >= 8
8711 if (!info.isNativeObjectProc) {
8712 int i;
8713
8714 /* string interface */
8715 /* argv = (char **)ALLOC_N(char *, argc+1); */
8716 argv = RbTk_ALLOC_N(char *, (argc+1));
8717 #if 0 /* use Tcl_Preserve/Release */
8718 Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
8719 #endif
8720 for (i = 0; i < argc; ++i) {
8721 argv[i] = Tcl_GetStringFromObj(objv[i], &len);
8722 }
8723 argv[argc] = (char *)NULL;
8724 }
8725 #endif
8726
8727 Tcl_ResetResult(ptr->ip);
8728
8729 /* Invoke the C procedure */
8730 #if TCL_MAJOR_VERSION >= 8
8731 if (info.isNativeObjectProc) {
8732 ptr->return_value = (*info.objProc)(info.objClientData, ptr->ip,
8733 objc, objv);
8734 #if 0
8735 /* get the string value from the result object */
8736 resultPtr = Tcl_GetObjResult(ptr->ip);
8737 Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &len),
8738 TCL_VOLATILE);
8739 #endif
8740 }
8741 else
8742 #endif
8743 {
8744 #if TCL_MAJOR_VERSION >= 8
8745 ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
8746 argc, (CONST84 char **)argv);
8747
8748 #if 0 /* use Tcl_EventuallyFree */
8749 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
8750 #else
8751 #if 0 /* use Tcl_Preserve/Release */
8752 Tcl_Release((ClientData)argv); /* XXXXXXXX */
8753 #else
8754 /* free(argv); */
8755 ckfree((char*)argv);
8756 #endif
8757 #endif
8758
8759 #else /* TCL_MAJOR_VERSION < 8 */
8760 ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
8761 argc, argv);
8762 #endif
8763 }
8764 #endif /* ! wrap tcl-proc call */
8765
8766 /* free allocated memory for calling 'unknown' command */
8767 if (unknown_flag) {
8768 #if TCL_MAJOR_VERSION >= 8
8769 Tcl_DecrRefCount(objv[0]);
8770 #if 0 /* use Tcl_EventuallyFree */
8771 Tcl_EventuallyFree((ClientData)objv, TCL_DYNAMIC); /* XXXXXXXX */
8772 #else
8773 #if 0 /* use Tcl_Preserve/Release */
8774 Tcl_Release((ClientData)objv); /* XXXXXXXX */
8775 #else
8776 /* free(objv); */
8777 ckfree((char*)objv);
8778 #endif
8779 #endif
8780 #else /* TCL_MAJOR_VERSION < 8 */
8781 free(argv[0]);
8782 /* ckfree(argv[0]); */
8783 #if 0 /* use Tcl_EventuallyFree */
8784 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
8785 #else
8786 #if 0 /* use Tcl_Preserve/Release */
8787 Tcl_Release((ClientData)argv); /* XXXXXXXX */
8788 #else
8789 /* free(argv); */
8790 ckfree((char*)argv);
8791 #endif
8792 #endif
8793 #endif
8794 }
8795
8796 /* exception on mainloop */
8797 if (pending_exception_check1(thr_crit_bup, ptr)) {
8798 return rbtk_pending_exception;
8799 }
8800
8801 rb_thread_critical = thr_crit_bup;
8802
8803 /* if (ptr->return_value == TCL_ERROR) { */
8804 if (ptr->return_value != TCL_OK) {
8805 if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
8806 switch (ptr->return_value) {
8807 case TCL_RETURN:
8808 return create_ip_exc(interp, eTkCallbackReturn,
8809 "ip_invoke_core receives TCL_RETURN");
8810 case TCL_BREAK:
8811 return create_ip_exc(interp, eTkCallbackBreak,
8812 "ip_invoke_core receives TCL_BREAK");
8813 case TCL_CONTINUE:
8814 return create_ip_exc(interp, eTkCallbackContinue,
8815 "ip_invoke_core receives TCL_CONTINUE");
8816 default:
8817 return create_ip_exc(interp, rb_eRuntimeError, "%s",
8818 Tcl_GetStringResult(ptr->ip));
8819 }
8820
8821 } else {
8822 if (event_loop_abort_on_exc < 0) {
8823 rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip));
8824 } else {
8825 rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip));
8826 }
8827 Tcl_ResetResult(ptr->ip);
8828 return rb_tainted_str_new2("");
8829 }
8830 }
8831
8832 /* pass back the result (as string) */
8833 return ip_get_result_string_obj(ptr->ip);
8834 }
8835
8836
8837 #if TCL_MAJOR_VERSION >= 8
8838 static Tcl_Obj **
8839 #else /* TCL_MAJOR_VERSION < 8 */
8840 static char **
8841 #endif
8842 alloc_invoke_arguments(argc, argv)
8843 int argc;
8844 VALUE *argv;
8845 {
8846 int i;
8847 int thr_crit_bup;
8848
8849 #if TCL_MAJOR_VERSION >= 8
8850 Tcl_Obj **av;
8851 #else /* TCL_MAJOR_VERSION < 8 */
8852 char **av;
8853 #endif
8854
8855 thr_crit_bup = rb_thread_critical;
8856 rb_thread_critical = Qtrue;
8857
8858 /* memory allocation */
8859 #if TCL_MAJOR_VERSION >= 8
8860 /* av = ALLOC_N(Tcl_Obj *, argc+1);*/ /* XXXXXXXXXX */
8861 av = RbTk_ALLOC_N(Tcl_Obj *, (argc+1));
8862 #if 0 /* use Tcl_Preserve/Release */
8863 Tcl_Preserve((ClientData)av); /* XXXXXXXX */
8864 #endif
8865 for (i = 0; i < argc; ++i) {
8866 av[i] = get_obj_from_str(argv[i]);
8867 Tcl_IncrRefCount(av[i]);
8868 }
8869 av[argc] = NULL;
8870
8871 #else /* TCL_MAJOR_VERSION < 8 */
8872 /* string interface */
8873 /* av = ALLOC_N(char *, argc+1); */
8874 av = RbTk_ALLOC_N(char *, (argc+1));
8875 #if 0 /* use Tcl_Preserve/Release */
8876 Tcl_Preserve((ClientData)av); /* XXXXXXXX */
8877 #endif
8878 for (i = 0; i < argc; ++i) {
8879 av[i] = strdup(StringValuePtr(argv[i]));
8880 }
8881 av[argc] = NULL;
8882 #endif
8883
8884 rb_thread_critical = thr_crit_bup;
8885
8886 return av;
8887 }
8888
8889 static void
8890 free_invoke_arguments(argc, av)
8891 int argc;
8892 #if TCL_MAJOR_VERSION >= 8
8893 Tcl_Obj **av;
8894 #else /* TCL_MAJOR_VERSION < 8 */
8895 char **av;
8896 #endif
8897 {
8898 int i;
8899
8900 for (i = 0; i < argc; ++i) {
8901 #if TCL_MAJOR_VERSION >= 8
8902 Tcl_DecrRefCount(av[i]);
8903 av[i] = (Tcl_Obj*)NULL;
8904 #else /* TCL_MAJOR_VERSION < 8 */
8905 free(av[i]);
8906 av[i] = (char*)NULL;
8907 #endif
8908 }
8909 #if TCL_MAJOR_VERSION >= 8
8910 #if 0 /* use Tcl_EventuallyFree */
8911 Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC); /* XXXXXXXX */
8912 #else
8913 #if 0 /* use Tcl_Preserve/Release */
8914 Tcl_Release((ClientData)av); /* XXXXXXXX */
8915 #else
8916 ckfree((char*)av);
8917 #endif
8918 #endif
8919 #else /* TCL_MAJOR_VERSION < 8 */
8920 #if 0 /* use Tcl_EventuallyFree */
8921 Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC); /* XXXXXXXX */
8922 #else
8923 #if 0 /* use Tcl_Preserve/Release */
8924 Tcl_Release((ClientData)av); /* XXXXXXXX */
8925 #else
8926 /* free(av); */
8927 ckfree((char*)av);
8928 #endif
8929 #endif
8930 #endif
8931 }
8932
8933 static VALUE
8934 ip_invoke_real(argc, argv, interp)
8935 int argc;
8936 VALUE *argv;
8937 VALUE interp;
8938 {
8939 VALUE v;
8940 struct tcltkip *ptr; /* tcltkip data struct */
8941
8942 #if TCL_MAJOR_VERSION >= 8
8943 Tcl_Obj **av = (Tcl_Obj **)NULL;
8944 #else /* TCL_MAJOR_VERSION < 8 */
8945 char **av = (char **)NULL;
8946 #endif
8947
8948 DUMP2("invoke_real called by thread:%lx", rb_thread_current());
8949
8950 /* get the data struct */
8951 ptr = get_ip(interp);
8952
8953 /* ip is deleted? */
8954 if (deleted_ip(ptr)) {
8955 return rb_tainted_str_new2("");
8956 }
8957
8958 /* allocate memory for arguments */
8959 av = alloc_invoke_arguments(argc, argv);
8960
8961 /* Invoke the C procedure */
8962 Tcl_ResetResult(ptr->ip);
8963 v = ip_invoke_core(interp, argc, av);
8964
8965 /* free allocated memory */
8966 free_invoke_arguments(argc, av);
8967
8968 return v;
8969 }
8970
8971 VALUE
8972 ivq_safelevel_handler(arg, ivq)
8973 VALUE arg;
8974 VALUE ivq;
8975 {
8976 struct invoke_queue *q;
8977
8978 Data_Get_Struct(ivq, struct invoke_queue, q);
8979 DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
8980 rb_set_safe_level(q->safe_level);
8981 return ip_invoke_core(q->interp, q->argc, q->argv);
8982 }
8983
8984 int invoke_queue_handler _((Tcl_Event *, int));
8985 int
8986 invoke_queue_handler(evPtr, flags)
8987 Tcl_Event *evPtr;
8988 int flags;
8989 {
8990 struct invoke_queue *q = (struct invoke_queue *)evPtr;
8991 volatile VALUE ret;
8992 volatile VALUE q_dat;
8993 volatile VALUE thread = q->thread;
8994 struct tcltkip *ptr;
8995
8996 DUMP2("do_invoke_queue_handler : evPtr = %p", evPtr);
8997 DUMP2("invoke queue_thread : %lx", rb_thread_current());
8998 DUMP2("added by thread : %lx", thread);
8999
9000 if (*(q->done)) {
9001 DUMP1("processed by another event-loop");
9002 return 0;
9003 } else {
9004 DUMP1("process it on current event-loop");
9005 }
9006
9007 #ifdef RUBY_VM
9008 if (RTEST(rb_funcall(thread, ID_alive_p, 0))
9009 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
9010 #else
9011 if (RTEST(rb_thread_alive_p(thread))
9012 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
9013 #endif
9014 DUMP1("caller is not yet ready to receive the result -> pending");
9015 return 0;
9016 }
9017
9018 /* process it */
9019 *(q->done) = 1;
9020
9021 /* deleted ipterp ? */
9022 ptr = get_ip(q->interp);
9023 if (deleted_ip(ptr)) {
9024 /* deleted IP --> ignore */
9025 return 1;
9026 }
9027
9028 /* incr internal handler mark */
9029 rbtk_internal_eventloop_handler++;
9030
9031 /* check safe-level */
9032 if (rb_safe_level() != q->safe_level) {
9033 /* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */
9034 q_dat = Data_Wrap_Struct(rb_cData,invoke_queue_mark,-1,q);
9035 ret = rb_funcall(rb_proc_new(ivq_safelevel_handler, q_dat),
9036 ID_call, 0);
9037 rb_gc_force_recycle(q_dat);
9038 q_dat = (VALUE)NULL;
9039 } else {
9040 DUMP2("call invoke_real (for caller thread:%lx)", thread);
9041 DUMP2("call invoke_real (current thread:%lx)", rb_thread_current());
9042 ret = ip_invoke_core(q->interp, q->argc, q->argv);
9043 }
9044
9045 /* set result */
9046 RARRAY_PTR(q->result)[0] = ret;
9047 ret = (VALUE)NULL;
9048
9049 /* decr internal handler mark */
9050 rbtk_internal_eventloop_handler--;
9051
9052 /* complete */
9053 *(q->done) = -1;
9054
9055 /* unlink ruby objects */
9056 q->interp = (VALUE)NULL;
9057 q->result = (VALUE)NULL;
9058 q->thread = (VALUE)NULL;
9059
9060 /* back to caller */
9061 #ifdef RUBY_VM
9062 if (RTEST(rb_funcall(thread, ID_alive_p, 0, 0))) {
9063 #else
9064 if (RTEST(rb_thread_alive_p(thread))) {
9065 #endif
9066 DUMP2("back to caller (caller thread:%lx)", thread);
9067 DUMP2(" (current thread:%lx)", rb_thread_current());
9068 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
9069 have_rb_thread_waiting_for_value = 1;
9070 rb_thread_wakeup(thread);
9071 #else
9072 rb_thread_run(thread);
9073 #endif
9074 DUMP1("finish back to caller");
9075 #if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
9076 rb_thread_schedule();
9077 #endif
9078 } else {
9079 DUMP2("caller is dead (caller thread:%lx)", thread);
9080 DUMP2(" (current thread:%lx)", rb_thread_current());
9081 }
9082
9083 /* end of handler : remove it */
9084 return 1;
9085 }
9086
9087 static VALUE
9088 ip_invoke_with_position(argc, argv, obj, position)
9089 int argc;
9090 VALUE *argv;
9091 VALUE obj;
9092 Tcl_QueuePosition position;
9093 {
9094 struct invoke_queue *ivq;
9095 #ifdef RUBY_USE_NATIVE_THREAD
9096 struct tcltkip *ptr;
9097 #endif
9098 int *alloc_done;
9099 int thr_crit_bup;
9100 volatile VALUE current = rb_thread_current();
9101 volatile VALUE ip_obj = obj;
9102 volatile VALUE result;
9103 volatile VALUE ret;
9104 struct timeval t;
9105
9106 #if TCL_MAJOR_VERSION >= 8
9107 Tcl_Obj **av = (Tcl_Obj **)NULL;
9108 #else /* TCL_MAJOR_VERSION < 8 */
9109 char **av = (char **)NULL;
9110 #endif
9111
9112 if (argc < 1) {
9113 rb_raise(rb_eArgError, "command name missing");
9114 }
9115
9116 #ifdef RUBY_USE_NATIVE_THREAD
9117 ptr = get_ip(ip_obj);
9118 DUMP2("invoke status: ptr->tk_thread_id %p", ptr->tk_thread_id);
9119 DUMP2("invoke status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
9120 #else
9121 DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
9122 #endif
9123 DUMP2("status: eventloopt_thread %lx", eventloop_thread);
9124
9125 if (
9126 #ifdef RUBY_USE_NATIVE_THREAD
9127 (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread())
9128 &&
9129 #endif
9130 (NIL_P(eventloop_thread) || current == eventloop_thread)
9131 ) {
9132 if (NIL_P(eventloop_thread)) {
9133 DUMP2("invoke from thread:%lx but no eventloop", current);
9134 } else {
9135 DUMP2("invoke from current eventloop %lx", current);
9136 }
9137 result = ip_invoke_real(argc, argv, ip_obj);
9138 if (rb_obj_is_kind_of(result, rb_eException)) {
9139 rb_exc_raise(result);
9140 }
9141 return result;
9142 }
9143
9144 DUMP2("invoke from thread %lx (NOT current eventloop)", current);
9145
9146 thr_crit_bup = rb_thread_critical;
9147 rb_thread_critical = Qtrue;
9148
9149 /* allocate memory (for arguments) */
9150 av = alloc_invoke_arguments(argc, argv);
9151
9152 /* allocate memory (keep result) */
9153 /* alloc_done = (int*)ALLOC(int); */
9154 alloc_done = RbTk_ALLOC_N(int, 1);
9155 #if 0 /* use Tcl_Preserve/Release */
9156 Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */
9157 #endif
9158 *alloc_done = 0;
9159
9160 /* allocate memory (freed by Tcl_ServiceEvent) */
9161 /* ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); */
9162 ivq = RbTk_ALLOC_N(struct invoke_queue, 1);
9163 #if 0 /* use Tcl_Preserve/Release */
9164 Tcl_Preserve((ClientData)ivq); /* XXXXXXXX */
9165 #endif
9166
9167 /* allocate result obj */
9168 result = rb_ary_new3(1, Qnil);
9169
9170 /* construct event data */
9171 ivq->done = alloc_done;
9172 ivq->argc = argc;
9173 ivq->argv = av;
9174 ivq->interp = ip_obj;
9175 ivq->result = result;
9176 ivq->thread = current;
9177 ivq->safe_level = rb_safe_level();
9178 ivq->ev.proc = invoke_queue_handler;
9179
9180 /* add the handler to Tcl event queue */
9181 DUMP1("add handler");
9182 #ifdef RUBY_USE_NATIVE_THREAD
9183 if (ptr->tk_thread_id) {
9184 /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(ivq->ev), position); */
9185 Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)ivq, position);
9186 Tcl_ThreadAlert(ptr->tk_thread_id);
9187 } else if (tk_eventloop_thread_id) {
9188 /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
9189 &(ivq->ev), position); */
9190 Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
9191 (Tcl_Event*)ivq, position);
9192 Tcl_ThreadAlert(tk_eventloop_thread_id);
9193 } else {
9194 /* Tcl_QueueEvent(&(ivq->ev), position); */
9195 Tcl_QueueEvent((Tcl_Event*)ivq, position);
9196 }
9197 #else
9198 /* Tcl_QueueEvent(&(ivq->ev), position); */
9199 Tcl_QueueEvent((Tcl_Event*)ivq, position);
9200 #endif
9201
9202 rb_thread_critical = thr_crit_bup;
9203
9204 /* wait for the handler to be processed */
9205 t.tv_sec = 0;
9206 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
9207
9208 DUMP2("ivq wait for handler (current thread:%lx)", current);
9209 while(*alloc_done >= 0) {
9210 /* rb_thread_stop(); */
9211 /* rb_thread_sleep_forever(); */
9212 rb_thread_wait_for(t);
9213 DUMP2("*** ivq wakeup (current thread:%lx)", current);
9214 DUMP2("*** (eventloop thread:%lx)", eventloop_thread);
9215 if (NIL_P(eventloop_thread)) {
9216 DUMP1("*** ivq lost eventloop thread");
9217 break;
9218 }
9219 }
9220 DUMP2("back from handler (current thread:%lx)", current);
9221
9222 /* get result & free allocated memory */
9223 ret = RARRAY_PTR(result)[0];
9224 #if 0 /* use Tcl_EventuallyFree */
9225 Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */
9226 #else
9227 #if 0 /* use Tcl_Preserve/Release */
9228 Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */
9229 #else
9230 /* free(alloc_done); */
9231 ckfree((char*)alloc_done);
9232 #endif
9233 #endif
9234
9235 #if 0 /* ivq is freed by Tcl_ServiceEvent */
9236 #if 0 /* use Tcl_EventuallyFree */
9237 Tcl_EventuallyFree((ClientData)ivq, TCL_DYNAMIC); /* XXXXXXXX */
9238 #else
9239 #if 0 /* use Tcl_Preserve/Release */
9240 Tcl_Release(ivq);
9241 #else
9242 ckfree((char*)ivq);
9243 #endif
9244 #endif
9245 #endif
9246
9247 /* free allocated memory */
9248 free_invoke_arguments(argc, av);
9249
9250 /* exception? */
9251 if (rb_obj_is_kind_of(ret, rb_eException)) {
9252 DUMP1("raise exception");
9253 /* rb_exc_raise(ret); */
9254 rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
9255 rb_funcall(ret, ID_to_s, 0, 0)));
9256 }
9257
9258 DUMP1("exit ip_invoke");
9259 return ret;
9260 }
9261
9262
9263 /* get return code from Tcl_Eval() */
9264 static VALUE
9265 ip_retval(self)
9266 VALUE self;
9267 {
9268 struct tcltkip *ptr; /* tcltkip data struct */
9269
9270 /* get the data strcut */
9271 ptr = get_ip(self);
9272
9273 /* ip is deleted? */
9274 if (deleted_ip(ptr)) {
9275 return rb_tainted_str_new2("");
9276 }
9277
9278 return (INT2FIX(ptr->return_value));
9279 }
9280
9281 static VALUE
9282 ip_invoke(argc, argv, obj)
9283 int argc;
9284 VALUE *argv;
9285 VALUE obj;
9286 {
9287 return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_TAIL);
9288 }
9289
9290 static VALUE
9291 ip_invoke_immediate(argc, argv, obj)
9292 int argc;
9293 VALUE *argv;
9294 VALUE obj;
9295 {
9296 /* POTENTIALY INSECURE : can create infinite loop */
9297 rb_secure(4);
9298 return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_HEAD);
9299 }
9300
9301
9302 /* access Tcl variables */
9303 static VALUE
9304 ip_get_variable2_core(interp, argc, argv)
9305 VALUE interp;
9306 int argc;
9307 VALUE *argv;
9308 {
9309 struct tcltkip *ptr = get_ip(interp);
9310 int thr_crit_bup;
9311 volatile VALUE varname, index, flag;
9312
9313 varname = argv[0];
9314 index = argv[1];
9315 flag = argv[2];
9316
9317 /*
9318 StringValue(varname);
9319 if (!NIL_P(index)) StringValue(index);
9320 */
9321
9322 #if TCL_MAJOR_VERSION >= 8
9323 {
9324 Tcl_Obj *ret;
9325 volatile VALUE strval;
9326
9327 thr_crit_bup = rb_thread_critical;
9328 rb_thread_critical = Qtrue;
9329
9330 /* ip is deleted? */
9331 if (deleted_ip(ptr)) {
9332 rb_thread_critical = thr_crit_bup;
9333 return rb_tainted_str_new2("");
9334 } else {
9335 /* Tcl_Preserve(ptr->ip); */
9336 rbtk_preserve_ip(ptr);
9337 ret = Tcl_GetVar2Ex(ptr->ip, RSTRING_PTR(varname),
9338 NIL_P(index) ? NULL : RSTRING_PTR(index),
9339 FIX2INT(flag));
9340 }
9341
9342 if (ret == (Tcl_Obj*)NULL) {
9343 volatile VALUE exc;
9344 /* exc = rb_exc_new2(rb_eRuntimeError,
9345 Tcl_GetStringResult(ptr->ip)); */
9346 exc = create_ip_exc(interp, rb_eRuntimeError,
9347 Tcl_GetStringResult(ptr->ip));
9348 /* Tcl_Release(ptr->ip); */
9349 rbtk_release_ip(ptr);
9350 rb_thread_critical = thr_crit_bup;
9351 return exc;
9352 }
9353
9354 Tcl_IncrRefCount(ret);
9355 strval = get_str_from_obj(ret);
9356 RbTk_OBJ_UNTRUST(strval);
9357 Tcl_DecrRefCount(ret);
9358
9359 /* Tcl_Release(ptr->ip); */
9360 rbtk_release_ip(ptr);
9361 rb_thread_critical = thr_crit_bup;
9362 return(strval);
9363 }
9364 #else /* TCL_MAJOR_VERSION < 8 */
9365 {
9366 char *ret;
9367 volatile VALUE strval;
9368
9369 /* ip is deleted? */
9370 if (deleted_ip(ptr)) {
9371 return rb_tainted_str_new2("");
9372 } else {
9373 /* Tcl_Preserve(ptr->ip); */
9374 rbtk_preserve_ip(ptr);
9375 ret = Tcl_GetVar2(ptr->ip, RSTRING_PTR(varname),
9376 NIL_P(index) ? NULL : RSTRING_PTR(index),
9377 FIX2INT(flag));
9378 }
9379
9380 if (ret == (char*)NULL) {
9381 volatile VALUE exc;
9382 exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
9383 /* Tcl_Release(ptr->ip); */
9384 rbtk_release_ip(ptr);
9385 rb_thread_critical = thr_crit_bup;
9386 return exc;
9387 }
9388
9389 strval = rb_tainted_str_new2(ret);
9390 /* Tcl_Release(ptr->ip); */
9391 rbtk_release_ip(ptr);
9392 rb_thread_critical = thr_crit_bup;
9393
9394 return(strval);
9395 }
9396 #endif
9397 }
9398
9399 static VALUE
9400 ip_get_variable2(self, varname, index, flag)
9401 VALUE self;
9402 VALUE varname;
9403 VALUE index;
9404 VALUE flag;
9405 {
9406 VALUE argv[3];
9407 VALUE retval;
9408
9409 StringValue(varname);
9410 if (!NIL_P(index)) StringValue(index);
9411
9412 argv[0] = varname;
9413 argv[1] = index;
9414 argv[2] = flag;
9415
9416 retval = tk_funcall(ip_get_variable2_core, 3, argv, self);
9417
9418 if (NIL_P(retval)) {
9419 return rb_tainted_str_new2("");
9420 } else {
9421 return retval;
9422 }
9423 }
9424
9425 static VALUE
9426 ip_get_variable(self, varname, flag)
9427 VALUE self;
9428 VALUE varname;
9429 VALUE flag;
9430 {
9431 return ip_get_variable2(self, varname, Qnil, flag);
9432 }
9433
9434 static VALUE
9435 ip_set_variable2_core(interp, argc, argv)
9436 VALUE interp;
9437 int argc;
9438 VALUE *argv;
9439 {
9440 struct tcltkip *ptr = get_ip(interp);
9441 int thr_crit_bup;
9442 volatile VALUE varname, index, value, flag;
9443
9444 varname = argv[0];
9445 index = argv[1];
9446 value = argv[2];
9447 flag = argv[3];
9448
9449 /*
9450 StringValue(varname);
9451 if (!NIL_P(index)) StringValue(index);
9452 StringValue(value);
9453 */
9454
9455 #if TCL_MAJOR_VERSION >= 8
9456 {
9457 Tcl_Obj *valobj, *ret;
9458 volatile VALUE strval;
9459
9460 thr_crit_bup = rb_thread_critical;
9461 rb_thread_critical = Qtrue;
9462
9463 valobj = get_obj_from_str(value);
9464 Tcl_IncrRefCount(valobj);
9465
9466 /* ip is deleted? */
9467 if (deleted_ip(ptr)) {
9468 Tcl_DecrRefCount(valobj);
9469 rb_thread_critical = thr_crit_bup;
9470 return rb_tainted_str_new2("");
9471 } else {
9472 /* Tcl_Preserve(ptr->ip); */
9473 rbtk_preserve_ip(ptr);
9474 ret = Tcl_SetVar2Ex(ptr->ip, RSTRING_PTR(varname),
9475 NIL_P(index) ? NULL : RSTRING_PTR(index),
9476 valobj, FIX2INT(flag));
9477 }
9478
9479 Tcl_DecrRefCount(valobj);
9480
9481 if (ret == (Tcl_Obj*)NULL) {
9482 volatile VALUE exc;
9483 /* exc = rb_exc_new2(rb_eRuntimeError,
9484 Tcl_GetStringResult(ptr->ip)); */
9485 exc = create_ip_exc(interp, rb_eRuntimeError,
9486 Tcl_GetStringResult(ptr->ip));
9487 /* Tcl_Release(ptr->ip); */
9488 rbtk_release_ip(ptr);
9489 rb_thread_critical = thr_crit_bup;
9490 return exc;
9491 }
9492
9493 Tcl_IncrRefCount(ret);
9494 strval = get_str_from_obj(ret);
9495 RbTk_OBJ_UNTRUST(strval);
9496 Tcl_DecrRefCount(ret);
9497
9498 /* Tcl_Release(ptr->ip); */
9499 rbtk_release_ip(ptr);
9500 rb_thread_critical = thr_crit_bup;
9501
9502 return(strval);
9503 }
9504 #else /* TCL_MAJOR_VERSION < 8 */
9505 {
9506 CONST char *ret;
9507 volatile VALUE strval;
9508
9509 /* ip is deleted? */
9510 if (deleted_ip(ptr)) {
9511 return rb_tainted_str_new2("");
9512 } else {
9513 /* Tcl_Preserve(ptr->ip); */
9514 rbtk_preserve_ip(ptr);
9515 ret = Tcl_SetVar2(ptr->ip, RSTRING_PTR(varname),
9516 NIL_P(index) ? NULL : RSTRING_PTR(index),
9517 RSTRING_PTR(value), FIX2INT(flag));
9518 }
9519
9520 if (ret == (char*)NULL) {
9521 return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
9522 }
9523
9524 strval = rb_tainted_str_new2(ret);
9525
9526 /* Tcl_Release(ptr->ip); */
9527 rbtk_release_ip(ptr);
9528 rb_thread_critical = thr_crit_bup;
9529
9530 return(strval);
9531 }
9532 #endif
9533 }
9534
9535 static VALUE
9536 ip_set_variable2(self, varname, index, value, flag)
9537 VALUE self;
9538 VALUE varname;
9539 VALUE index;
9540 VALUE value;
9541 VALUE flag;
9542 {
9543 VALUE argv[4];
9544 VALUE retval;
9545
9546 StringValue(varname);
9547 if (!NIL_P(index)) StringValue(index);
9548 StringValue(value);
9549
9550 argv[0] = varname;
9551 argv[1] = index;
9552 argv[2] = value;
9553 argv[3] = flag;
9554
9555 retval = tk_funcall(ip_set_variable2_core, 4, argv, self);
9556
9557 if (NIL_P(retval)) {
9558 return rb_tainted_str_new2("");
9559 } else {
9560 return retval;
9561 }
9562 }
9563
9564 static VALUE
9565 ip_set_variable(self, varname, value, flag)
9566 VALUE self;
9567 VALUE varname;
9568 VALUE value;
9569 VALUE flag;
9570 {
9571 return ip_set_variable2(self, varname, Qnil, value, flag);
9572 }
9573
9574 static VALUE
9575 ip_unset_variable2_core(interp, argc, argv)
9576 VALUE interp;
9577 int argc;
9578 VALUE *argv;
9579 {
9580 struct tcltkip *ptr = get_ip(interp);
9581 volatile VALUE varname, index, flag;
9582
9583 varname = argv[0];
9584 index = argv[1];
9585 flag = argv[2];
9586
9587 /*
9588 StringValue(varname);
9589 if (!NIL_P(index)) StringValue(index);
9590 */
9591
9592 /* ip is deleted? */
9593 if (deleted_ip(ptr)) {
9594 return Qtrue;
9595 }
9596
9597 ptr->return_value = Tcl_UnsetVar2(ptr->ip, RSTRING_PTR(varname),
9598 NIL_P(index) ? NULL : RSTRING_PTR(index),
9599 FIX2INT(flag));
9600
9601 if (ptr->return_value == TCL_ERROR) {
9602 if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) {
9603 /* return rb_exc_new2(rb_eRuntimeError,
9604 Tcl_GetStringResult(ptr->ip)); */
9605 return create_ip_exc(interp, rb_eRuntimeError,
9606 Tcl_GetStringResult(ptr->ip));
9607 }
9608 return Qfalse;
9609 }
9610 return Qtrue;
9611 }
9612
9613 static VALUE
9614 ip_unset_variable2(self, varname, index, flag)
9615 VALUE self;
9616 VALUE varname;
9617 VALUE index;
9618 VALUE flag;
9619 {
9620 VALUE argv[3];
9621 VALUE retval;
9622
9623 StringValue(varname);
9624 if (!NIL_P(index)) StringValue(index);
9625
9626 argv[0] = varname;
9627 argv[1] = index;
9628 argv[2] = flag;
9629
9630 retval = tk_funcall(ip_unset_variable2_core, 3, argv, self);
9631
9632 if (NIL_P(retval)) {
9633 return rb_tainted_str_new2("");
9634 } else {
9635 return retval;
9636 }
9637 }
9638
9639 static VALUE
9640 ip_unset_variable(self, varname, flag)
9641 VALUE self;
9642 VALUE varname;
9643 VALUE flag;
9644 {
9645 return ip_unset_variable2(self, varname, Qnil, flag);
9646 }
9647
9648 static VALUE
9649 ip_get_global_var(self, varname)
9650 VALUE self;
9651 VALUE varname;
9652 {
9653 return ip_get_variable(self, varname,
9654 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
9655 }
9656
9657 static VALUE
9658 ip_get_global_var2(self, varname, index)
9659 VALUE self;
9660 VALUE varname;
9661 VALUE index;
9662 {
9663 return ip_get_variable2(self, varname, index,
9664 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
9665 }
9666
9667 static VALUE
9668 ip_set_global_var(self, varname, value)
9669 VALUE self;
9670 VALUE varname;
9671 VALUE value;
9672 {
9673 return ip_set_variable(self, varname, value,
9674 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
9675 }
9676
9677 static VALUE
9678 ip_set_global_var2(self, varname, index, value)
9679 VALUE self;
9680 VALUE varname;
9681 VALUE index;
9682 VALUE value;
9683 {
9684 return ip_set_variable2(self, varname, index, value,
9685 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
9686 }
9687
9688 static VALUE
9689 ip_unset_global_var(self, varname)
9690 VALUE self;
9691 VALUE varname;
9692 {
9693 return ip_unset_variable(self, varname,
9694 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
9695 }
9696
9697 static VALUE
9698 ip_unset_global_var2(self, varname, index)
9699 VALUE self;
9700 VALUE varname;
9701 VALUE index;
9702 {
9703 return ip_unset_variable2(self, varname, index,
9704 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
9705 }
9706
9707
9708 /* treat Tcl_List */
9709 static VALUE
9710 lib_split_tklist_core(ip_obj, list_str)
9711 VALUE ip_obj;
9712 VALUE list_str;
9713 {
9714 Tcl_Interp *interp;
9715 volatile VALUE ary, elem;
9716 int idx;
9717 int taint_flag = OBJ_TAINTED(list_str);
9718 #ifdef HAVE_RUBY_ENCODING_H
9719 int list_enc_idx;
9720 volatile VALUE list_ivar_enc;
9721 #endif
9722 int result;
9723 VALUE old_gc;
9724
9725 tcl_stubs_check();
9726
9727 if (NIL_P(ip_obj)) {
9728 interp = (Tcl_Interp *)NULL;
9729 } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) {
9730 interp = (Tcl_Interp *)NULL;
9731 } else {
9732 interp = get_ip(ip_obj)->ip;
9733 }
9734
9735 StringValue(list_str);
9736 #ifdef HAVE_RUBY_ENCODING_H
9737 list_enc_idx = rb_enc_get_index(list_str);
9738 list_ivar_enc = rb_ivar_get(list_str, ID_at_enc);
9739 #endif
9740
9741 {
9742 #if TCL_MAJOR_VERSION >= 8
9743 /* object style interface */
9744 Tcl_Obj *listobj;
9745 int objc;
9746 Tcl_Obj **objv;
9747 int thr_crit_bup;
9748
9749 listobj = get_obj_from_str(list_str);
9750
9751 Tcl_IncrRefCount(listobj);
9752
9753 result = Tcl_ListObjGetElements(interp, listobj, &objc, &objv);
9754
9755 if (result == TCL_ERROR) {
9756 Tcl_DecrRefCount(listobj);
9757 if (interp == (Tcl_Interp*)NULL) {
9758 rb_raise(rb_eRuntimeError, "can't get elements from list");
9759 } else {
9760 rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(interp));
9761 }
9762 }
9763
9764 for(idx = 0; idx < objc; idx++) {
9765 Tcl_IncrRefCount(objv[idx]);
9766 }
9767
9768 thr_crit_bup = rb_thread_critical;
9769 rb_thread_critical = Qtrue;
9770
9771 ary = rb_ary_new2(objc);
9772 if (taint_flag) RbTk_OBJ_UNTRUST(ary);
9773
9774 old_gc = rb_gc_disable();
9775
9776 for(idx = 0; idx < objc; idx++) {
9777 elem = get_str_from_obj(objv[idx]);
9778 if (taint_flag) RbTk_OBJ_UNTRUST(elem);
9779
9780 #ifdef HAVE_RUBY_ENCODING_H
9781 if (rb_enc_get_index(elem) == ENCODING_INDEX_BINARY) {
9782 rb_enc_associate_index(elem, ENCODING_INDEX_BINARY);
9783 rb_ivar_set(elem, ID_at_enc, ENCODING_NAME_BINARY);
9784 } else {
9785 rb_enc_associate_index(elem, list_enc_idx);
9786 rb_ivar_set(elem, ID_at_enc, list_ivar_enc);
9787 }
9788 #endif
9789 /* RARRAY(ary)->ptr[idx] = elem; */
9790 rb_ary_push(ary, elem);
9791 }
9792
9793 /* RARRAY(ary)->len = objc; */
9794
9795 if (old_gc == Qfalse) rb_gc_enable();
9796
9797 rb_thread_critical = thr_crit_bup;
9798
9799 for(idx = 0; idx < objc; idx++) {
9800 Tcl_DecrRefCount(objv[idx]);
9801 }
9802
9803 Tcl_DecrRefCount(listobj);
9804
9805 #else /* TCL_MAJOR_VERSION < 8 */
9806 /* string style interface */
9807 int argc;
9808 char **argv;
9809
9810 if (Tcl_SplitList(interp, RSTRING_PTR(list_str),
9811 &argc, &argv) == TCL_ERROR) {
9812 if (interp == (Tcl_Interp*)NULL) {
9813 rb_raise(rb_eRuntimeError, "can't get elements from list");
9814 } else {
9815 rb_raise(rb_eRuntimeError, "%s", interp->result);
9816 }
9817 }
9818
9819 ary = rb_ary_new2(argc);
9820 if (taint_flag) RbTk_OBJ_UNTRUST(ary);
9821
9822 old_gc = rb_gc_disable();
9823
9824 for(idx = 0; idx < argc; idx++) {
9825 if (taint_flag) {
9826 elem = rb_tainted_str_new2(argv[idx]);
9827 } else {
9828 elem = rb_str_new2(argv[idx]);
9829 }
9830 /* rb_ivar_set(elem, ID_at_enc, rb_str_new2("binary")); */
9831 /* RARRAY(ary)->ptr[idx] = elem; */
9832 rb_ary_push(ary, elem)
9833 }
9834 /* RARRAY(ary)->len = argc; */
9835
9836 if (old_gc == Qfalse) rb_gc_enable();
9837 #endif
9838 }
9839
9840 return ary;
9841 }
9842
9843 static VALUE
9844 lib_split_tklist(self, list_str)
9845 VALUE self;
9846 VALUE list_str;
9847 {
9848 return lib_split_tklist_core(Qnil, list_str);
9849 }
9850
9851
9852 static VALUE
9853 ip_split_tklist(self, list_str)
9854 VALUE self;
9855 VALUE list_str;
9856 {
9857 return lib_split_tklist_core(self, list_str);
9858 }
9859
9860 static VALUE
9861 lib_merge_tklist(argc, argv, obj)
9862 int argc;
9863 VALUE *argv;
9864 VALUE obj;
9865 {
9866 int num, len;
9867 int *flagPtr;
9868 char *dst, *result;
9869 volatile VALUE str;
9870 int taint_flag = 0;
9871 int thr_crit_bup;
9872 VALUE old_gc;
9873
9874 if (argc == 0) return rb_str_new2("");
9875
9876 tcl_stubs_check();
9877
9878 thr_crit_bup = rb_thread_critical;
9879 rb_thread_critical = Qtrue;
9880 old_gc = rb_gc_disable();
9881
9882 /* based on Tcl/Tk's Tcl_Merge() */
9883 /* flagPtr = ALLOC_N(int, argc); */
9884 flagPtr = RbTk_ALLOC_N(int, argc);
9885 #if 0 /* use Tcl_Preserve/Release */
9886 Tcl_Preserve((ClientData)flagPtr); /* XXXXXXXXXX */
9887 #endif
9888
9889 /* pass 1 */
9890 len = 1;
9891 for(num = 0; num < argc; num++) {
9892 if (OBJ_TAINTED(argv[num])) taint_flag = 1;
9893 dst = StringValuePtr(argv[num]);
9894 #if TCL_MAJOR_VERSION >= 8
9895 len += Tcl_ScanCountedElement(dst, RSTRING_LENINT(argv[num]),
9896 &flagPtr[num]) + 1;
9897 #else /* TCL_MAJOR_VERSION < 8 */
9898 len += Tcl_ScanElement(dst, &flagPtr[num]) + 1;
9899 #endif
9900 }
9901
9902 /* pass 2 */
9903 /* result = (char *)Tcl_Alloc(len); */
9904 result = (char *)ckalloc(len);
9905 #if 0 /* use Tcl_Preserve/Release */
9906 Tcl_Preserve((ClientData)result);
9907 #endif
9908 dst = result;
9909 for(num = 0; num < argc; num++) {
9910 #if TCL_MAJOR_VERSION >= 8
9911 len = Tcl_ConvertCountedElement(RSTRING_PTR(argv[num]),
9912 RSTRING_LENINT(argv[num]),
9913 dst, flagPtr[num]);
9914 #else /* TCL_MAJOR_VERSION < 8 */
9915 len = Tcl_ConvertElement(RSTRING_PTR(argv[num]), dst, flagPtr[num]);
9916 #endif
9917 dst += len;
9918 *dst = ' ';
9919 dst++;
9920 }
9921 if (dst == result) {
9922 *dst = 0;
9923 } else {
9924 dst[-1] = 0;
9925 }
9926
9927 #if 0 /* use Tcl_EventuallyFree */
9928 Tcl_EventuallyFree((ClientData)flagPtr, TCL_DYNAMIC); /* XXXXXXXX */
9929 #else
9930 #if 0 /* use Tcl_Preserve/Release */
9931 Tcl_Release((ClientData)flagPtr);
9932 #else
9933 /* free(flagPtr); */
9934 ckfree((char*)flagPtr);
9935 #endif
9936 #endif
9937
9938 /* create object */
9939 str = rb_str_new(result, dst - result - 1);
9940 if (taint_flag) RbTk_OBJ_UNTRUST(str);
9941 #if 0 /* use Tcl_EventuallyFree */
9942 Tcl_EventuallyFree((ClientData)result, TCL_DYNAMIC); /* XXXXXXXX */
9943 #else
9944 #if 0 /* use Tcl_Preserve/Release */
9945 Tcl_Release((ClientData)result); /* XXXXXXXXXXX */
9946 #else
9947 /* Tcl_Free(result); */
9948 ckfree(result);
9949 #endif
9950 #endif
9951
9952 if (old_gc == Qfalse) rb_gc_enable();
9953 rb_thread_critical = thr_crit_bup;
9954
9955 return str;
9956 }
9957
9958 static VALUE
9959 lib_conv_listelement(self, src)
9960 VALUE self;
9961 VALUE src;
9962 {
9963 int len, scan_flag;
9964 volatile VALUE dst;
9965 int taint_flag = OBJ_TAINTED(src);
9966 int thr_crit_bup;
9967
9968 tcl_stubs_check();
9969
9970 thr_crit_bup = rb_thread_critical;
9971 rb_thread_critical = Qtrue;
9972
9973 StringValue(src);
9974
9975 #if TCL_MAJOR_VERSION >= 8
9976 len = Tcl_ScanCountedElement(RSTRING_PTR(src), RSTRING_LENINT(src),
9977 &scan_flag);
9978 dst = rb_str_new(0, len + 1);
9979 len = Tcl_ConvertCountedElement(RSTRING_PTR(src), RSTRING_LENINT(src),
9980 RSTRING_PTR(dst), scan_flag);
9981 #else /* TCL_MAJOR_VERSION < 8 */
9982 len = Tcl_ScanElement(RSTRING_PTR(src), &scan_flag);
9983 dst = rb_str_new(0, len + 1);
9984 len = Tcl_ConvertElement(RSTRING_PTR(src), RSTRING_PTR(dst), scan_flag);
9985 #endif
9986
9987 rb_str_resize(dst, len);
9988 if (taint_flag) RbTk_OBJ_UNTRUST(dst);
9989
9990 rb_thread_critical = thr_crit_bup;
9991
9992 return dst;
9993 }
9994
9995 static VALUE
9996 lib_getversion(self)
9997 VALUE self;
9998 {
9999 set_tcltk_version();
10000
10001 return rb_ary_new3(4, INT2NUM(tcltk_version.major),
10002 INT2NUM(tcltk_version.minor),
10003 INT2NUM(tcltk_version.type),
10004 INT2NUM(tcltk_version.patchlevel));
10005 }
10006
10007 static VALUE
10008 lib_get_reltype_name(self)
10009 VALUE self;
10010 {
10011 set_tcltk_version();
10012
10013 switch(tcltk_version.type) {
10014 case TCL_ALPHA_RELEASE:
10015 return rb_str_new2("alpha");
10016 case TCL_BETA_RELEASE:
10017 return rb_str_new2("beta");
10018 case TCL_FINAL_RELEASE:
10019 return rb_str_new2("final");
10020 default:
10021 rb_raise(rb_eRuntimeError, "tcltklib has invalid release type number");
10022 }
10023
10024 UNREACHABLE;
10025 }
10026
10027
10028 static VALUE
10029 tcltklib_compile_info()
10030 {
10031 volatile VALUE ret;
10032 size_t size;
10033 static CONST char form[]
10034 = "tcltklib %s :: Ruby%s (%s) %s pthread :: Tcl%s(%s)/Tk%s(%s) %s";
10035 char *info;
10036
10037 size = strlen(form)
10038 + strlen(TCLTKLIB_RELEASE_DATE)
10039 + strlen(RUBY_VERSION)
10040 + strlen(RUBY_RELEASE_DATE)
10041 + strlen("without")
10042 + strlen(TCL_PATCH_LEVEL)
10043 + strlen("without stub")
10044 + strlen(TK_PATCH_LEVEL)
10045 + strlen("without stub")
10046 + strlen("unknown tcl_threads");
10047
10048 info = ALLOC_N(char, size);
10049 /* info = ckalloc(sizeof(char) * size); */ /* SEGV */
10050
10051 sprintf(info, form,
10052 TCLTKLIB_RELEASE_DATE,
10053 RUBY_VERSION, RUBY_RELEASE_DATE,
10054 #ifdef HAVE_NATIVETHREAD
10055 "with",
10056 #else
10057 "without",
10058 #endif
10059 TCL_PATCH_LEVEL,
10060 #ifdef USE_TCL_STUBS
10061 "with stub",
10062 #else
10063 "without stub",
10064 #endif
10065 TK_PATCH_LEVEL,
10066 #ifdef USE_TK_STUBS
10067 "with stub",
10068 #else
10069 "without stub",
10070 #endif
10071 #ifdef WITH_TCL_ENABLE_THREAD
10072 # if WITH_TCL_ENABLE_THREAD
10073 "with tcl_threads"
10074 # else
10075 "without tcl_threads"
10076 # endif
10077 #else
10078 "unknown tcl_threads"
10079 #endif
10080 );
10081
10082 ret = rb_obj_freeze(rb_str_new2(info));
10083
10084 xfree(info);
10085 /* ckfree(info); */
10086
10087 return ret;
10088 }
10089
10090
10091 /*###############################################*/
10092
10093 static VALUE
10094 create_dummy_encoding_for_tk_core(interp, name, error_mode)
10095 VALUE interp;
10096 VALUE name;
10097 VALUE error_mode;
10098 {
10099 get_ip(interp);
10100
10101 rb_secure(4);
10102
10103 StringValue(name);
10104
10105 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
10106 if (Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(name)) == (Tcl_Encoding)NULL) {
10107 if (RTEST(error_mode)) {
10108 rb_raise(rb_eArgError, "invalid Tk encoding name '%s'",
10109 RSTRING_PTR(name));
10110 } else {
10111 return Qnil;
10112 }
10113 }
10114 #endif
10115
10116 #ifdef HAVE_RUBY_ENCODING_H
10117 if (RTEST(rb_define_dummy_encoding(RSTRING_PTR(name)))) {
10118 int idx = rb_enc_find_index(StringValueCStr(name));
10119 return rb_enc_from_encoding(rb_enc_from_index(idx));
10120 } else {
10121 if (RTEST(error_mode)) {
10122 rb_raise(rb_eRuntimeError, "fail to create dummy encoding for '%s'",
10123 RSTRING_PTR(name));
10124 } else {
10125 return Qnil;
10126 }
10127 }
10128
10129 UNREACHABLE;
10130 #else
10131 return name;
10132 #endif
10133 }
10134 static VALUE
10135 create_dummy_encoding_for_tk(interp, name)
10136 VALUE interp;
10137 VALUE name;
10138 {
10139 return create_dummy_encoding_for_tk_core(interp, name, Qtrue);
10140 }
10141
10142
10143 #ifdef HAVE_RUBY_ENCODING_H
10144 static int
10145 update_encoding_table(table, interp, error_mode)
10146 VALUE table;
10147 VALUE interp;
10148 VALUE error_mode;
10149 {
10150 struct tcltkip *ptr;
10151 int retry = 0;
10152 int i, idx, objc;
10153 Tcl_Obj **objv;
10154 Tcl_Obj *enc_list;
10155 volatile VALUE encname = Qnil;
10156 volatile VALUE encobj = Qnil;
10157
10158 /* interpreter check */
10159 if (NIL_P(interp)) return 0;
10160 ptr = get_ip(interp);
10161 if (ptr == (struct tcltkip *) NULL) return 0;
10162 if (deleted_ip(ptr)) return 0;
10163
10164 /* get Tcl's encoding list */
10165 Tcl_GetEncodingNames(ptr->ip);
10166 enc_list = Tcl_GetObjResult(ptr->ip);
10167 Tcl_IncrRefCount(enc_list);
10168
10169 if (Tcl_ListObjGetElements(ptr->ip, enc_list,
10170 &objc, &objv) != TCL_OK) {
10171 Tcl_DecrRefCount(enc_list);
10172 /* rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");*/
10173 return 0;
10174 }
10175
10176 /* check each encoding name */
10177 for(i = 0; i < objc; i++) {
10178 encname = rb_str_new2(Tcl_GetString(objv[i]));
10179 if (NIL_P(rb_hash_lookup(table, encname))) {
10180 /* new Tk encoding -> add to table */
10181 idx = rb_enc_find_index(StringValueCStr(encname));
10182 if (idx < 0) {
10183 encobj = create_dummy_encoding_for_tk_core(interp,encname,error_mode);
10184 } else {
10185 encobj = rb_enc_from_encoding(rb_enc_from_index(idx));
10186 }
10187 encname = rb_obj_freeze(encname);
10188 rb_hash_aset(table, encname, encobj);
10189 if (!NIL_P(encobj) && NIL_P(rb_hash_lookup(table, encobj))) {
10190 rb_hash_aset(table, encobj, encname);
10191 }
10192 retry = 1;
10193 }
10194 }
10195
10196 Tcl_DecrRefCount(enc_list);
10197
10198 return retry;
10199 }
10200
10201 static VALUE
10202 encoding_table_get_name_core(table, enc_arg, error_mode)
10203 VALUE table;
10204 VALUE enc_arg;
10205 VALUE error_mode;
10206 {
10207 volatile VALUE enc = enc_arg;
10208 volatile VALUE name = Qnil;
10209 volatile VALUE tmp = Qnil;
10210 volatile VALUE interp = rb_ivar_get(table, ID_at_interp);
10211 struct tcltkip *ptr = (struct tcltkip *) NULL;
10212 int idx;
10213
10214 /* deleted interp ? */
10215 if (!NIL_P(interp)) {
10216 ptr = get_ip(interp);
10217 if (deleted_ip(ptr)) {
10218 ptr = (struct tcltkip *) NULL;
10219 }
10220 }
10221
10222 /* encoding argument check */
10223 /* 1st: default encoding setting of interp */
10224 if (ptr && NIL_P(enc)) {
10225 if (rb_respond_to(interp, ID_encoding_name)) {
10226 enc = rb_funcall(interp, ID_encoding_name, 0, 0);
10227 }
10228 }
10229 /* 2nd: Encoding.default_internal */
10230 if (NIL_P(enc)) {
10231 enc = rb_enc_default_internal();
10232 }
10233 /* 3rd: encoding system of Tcl/Tk */
10234 if (NIL_P(enc)) {
10235 enc = rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL));
10236 }
10237 /* 4th: Encoding.default_external */
10238 if (NIL_P(enc)) {
10239 enc = rb_enc_default_external();
10240 }
10241 /* 5th: Encoding.locale_charmap */
10242 if (NIL_P(enc)) {
10243 enc = rb_locale_charmap(rb_cEncoding);
10244 }
10245
10246 if (RTEST(rb_obj_is_kind_of(enc, cRubyEncoding))) {
10247 /* Ruby's Encoding object */
10248 name = rb_hash_lookup(table, enc);
10249 if (!NIL_P(name)) {
10250 /* find */
10251 return name;
10252 }
10253
10254 /* is it new ? */
10255 /* update check of Tk encoding names */
10256 if (update_encoding_table(table, interp, error_mode)) {
10257 /* add new relations to the table */
10258 /* RETRY: registered Ruby encoding? */
10259 name = rb_hash_lookup(table, enc);
10260 if (!NIL_P(name)) {
10261 /* find */
10262 return name;
10263 }
10264 }
10265 /* fail to find */
10266
10267 } else {
10268 /* String or Symbol? */
10269 name = rb_funcall(enc, ID_to_s, 0, 0);
10270
10271 if (!NIL_P(rb_hash_lookup(table, name))) {
10272 /* find */
10273 return name;
10274 }
10275
10276 /* is it new ? */
10277 idx = rb_enc_find_index(StringValueCStr(name));
10278 if (idx >= 0) {
10279 enc = rb_enc_from_encoding(rb_enc_from_index(idx));
10280
10281 /* registered Ruby encoding? */
10282 tmp = rb_hash_lookup(table, enc);
10283 if (!NIL_P(tmp)) {
10284 /* find */
10285 return tmp;
10286 }
10287
10288 /* update check of Tk encoding names */
10289 if (update_encoding_table(table, interp, error_mode)) {
10290 /* add new relations to the table */
10291 /* RETRY: registered Ruby encoding? */
10292 tmp = rb_hash_lookup(table, enc);
10293 if (!NIL_P(tmp)) {
10294 /* find */
10295 return tmp;
10296 }
10297 }
10298 }
10299 /* fail to find */
10300 }
10301
10302 if (RTEST(error_mode)) {
10303 enc = rb_funcall(enc_arg, ID_to_s, 0, 0);
10304 rb_raise(rb_eArgError, "unsupported Tk encoding '%s'", RSTRING_PTR(enc));
10305 }
10306 return Qnil;
10307 }
10308 static VALUE
10309 encoding_table_get_obj_core(table, enc, error_mode)
10310 VALUE table;
10311 VALUE enc;
10312 VALUE error_mode;
10313 {
10314 volatile VALUE obj = Qnil;
10315
10316 obj = rb_hash_lookup(table,
10317 encoding_table_get_name_core(table, enc, error_mode));
10318 if (RTEST(rb_obj_is_kind_of(obj, cRubyEncoding))) {
10319 return obj;
10320 } else {
10321 return Qnil;
10322 }
10323 }
10324
10325 #else /* ! HAVE_RUBY_ENCODING_H */
10326 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
10327 static int
10328 update_encoding_table(table, interp, error_mode)
10329 VALUE table;
10330 VALUE interp;
10331 VALUE error_mode;
10332 {
10333 struct tcltkip *ptr;
10334 int retry = 0;
10335 int i, objc;
10336 Tcl_Obj **objv;
10337 Tcl_Obj *enc_list;
10338 volatile VALUE encname = Qnil;
10339
10340 /* interpreter check */
10341 if (NIL_P(interp)) return 0;
10342 ptr = get_ip(interp);
10343 if (ptr == (struct tcltkip *) NULL) return 0;
10344 if (deleted_ip(ptr)) return 0;
10345
10346 /* get Tcl's encoding list */
10347 Tcl_GetEncodingNames(ptr->ip);
10348 enc_list = Tcl_GetObjResult(ptr->ip);
10349 Tcl_IncrRefCount(enc_list);
10350
10351 if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) {
10352 Tcl_DecrRefCount(enc_list);
10353 /* rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names"); */
10354 return 0;
10355 }
10356
10357 /* get encoding name and set it to table */
10358 for(i = 0; i < objc; i++) {
10359 encname = rb_str_new2(Tcl_GetString(objv[i]));
10360 if (NIL_P(rb_hash_lookup(table, encname))) {
10361 /* new Tk encoding -> add to table */
10362 encname = rb_obj_freeze(encname);
10363 rb_hash_aset(table, encname, encname);
10364 retry = 1;
10365 }
10366 }
10367
10368 Tcl_DecrRefCount(enc_list);
10369
10370 return retry;
10371 }
10372
10373 static VALUE
10374 encoding_table_get_name_core(table, enc, error_mode)
10375 VALUE table;
10376 VALUE enc;
10377 VALUE error_mode;
10378 {
10379 volatile VALUE name = Qnil;
10380
10381 enc = rb_funcall(enc, ID_to_s, 0, 0);
10382 name = rb_hash_lookup(table, enc);
10383
10384 if (!NIL_P(name)) {
10385 /* find */
10386 return name;
10387 }
10388
10389 /* update check */
10390 if (update_encoding_table(table, rb_ivar_get(table, ID_at_interp),
10391 error_mode)) {
10392 /* add new relations to the table */
10393 /* RETRY: registered Ruby encoding? */
10394 name = rb_hash_lookup(table, enc);
10395 if (!NIL_P(name)) {
10396 /* find */
10397 return name;
10398 }
10399 }
10400
10401 if (RTEST(error_mode)) {
10402 rb_raise(rb_eArgError, "unsupported Tk encoding '%s'", RSTRING_PTR(enc));
10403 }
10404 return Qnil;
10405 }
10406 static VALUE
10407 encoding_table_get_obj_core(table, enc, error_mode)
10408 VALUE table;
10409 VALUE enc;
10410 VALUE error_mode;
10411 {
10412 return encoding_table_get_name_core(table, enc, error_mode);
10413 }
10414
10415 #else /* Tcl/Tk 7.x or 8.0 */
10416 static VALUE
10417 encoding_table_get_name_core(table, enc, error_mode)
10418 VALUE table;
10419 VALUE enc;
10420 VALUE error_mode;
10421 {
10422 return Qnil;
10423 }
10424 static VALUE
10425 encoding_table_get_obj_core(table, enc, error_mode)
10426 VALUE table;
10427 VALUE enc;
10428 VALUE error_mode;
10429 {
10430 return Qnil;
10431 }
10432 #endif /* end of dependency for the version of Tcl/Tk */
10433 #endif
10434
10435 static VALUE
10436 encoding_table_get_name(table, enc)
10437 VALUE table;
10438 VALUE enc;
10439 {
10440 return encoding_table_get_name_core(table, enc, Qtrue);
10441 }
10442 static VALUE
10443 encoding_table_get_obj(table, enc)
10444 VALUE table;
10445 VALUE enc;
10446 {
10447 return encoding_table_get_obj_core(table, enc, Qtrue);
10448 }
10449
10450 #ifdef HAVE_RUBY_ENCODING_H
10451 static VALUE
10452 create_encoding_table_core(arg, interp)
10453 VALUE arg;
10454 VALUE interp;
10455 {
10456 struct tcltkip *ptr = get_ip(interp);
10457 volatile VALUE table = rb_hash_new();
10458 volatile VALUE encname = Qnil;
10459 volatile VALUE encobj = Qnil;
10460 int i, idx, objc;
10461 Tcl_Obj **objv;
10462 Tcl_Obj *enc_list;
10463
10464 #ifdef HAVE_RB_SET_SAFE_LEVEL_FORCE
10465 rb_set_safe_level_force(0);
10466 #else
10467 rb_set_safe_level(0);
10468 #endif
10469
10470 /* set 'binary' encoding */
10471 encobj = rb_enc_from_encoding(rb_enc_from_index(ENCODING_INDEX_BINARY));
10472 rb_hash_aset(table, ENCODING_NAME_BINARY, encobj);
10473 rb_hash_aset(table, encobj, ENCODING_NAME_BINARY);
10474
10475
10476 /* Tcl stub check */
10477 tcl_stubs_check();
10478
10479 /* get Tcl's encoding list */
10480 Tcl_GetEncodingNames(ptr->ip);
10481 enc_list = Tcl_GetObjResult(ptr->ip);
10482 Tcl_IncrRefCount(enc_list);
10483
10484 if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) {
10485 Tcl_DecrRefCount(enc_list);
10486 rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");
10487 }
10488
10489 /* get encoding name and set it to table */
10490 for(i = 0; i < objc; i++) {
10491 int name2obj, obj2name;
10492
10493 name2obj = 1; obj2name = 1;
10494 encname = rb_obj_freeze(rb_str_new2(Tcl_GetString(objv[i])));
10495 idx = rb_enc_find_index(StringValueCStr(encname));
10496 if (idx < 0) {
10497 /* fail to find ruby encoding -> check known encoding */
10498 if (strcmp(RSTRING_PTR(encname), "identity") == 0) {
10499 name2obj = 1; obj2name = 0;
10500 idx = ENCODING_INDEX_BINARY;
10501
10502 } else if (strcmp(RSTRING_PTR(encname), "shiftjis") == 0) {
10503 name2obj = 1; obj2name = 0;
10504 idx = rb_enc_find_index("Shift_JIS");
10505
10506 } else if (strcmp(RSTRING_PTR(encname), "unicode") == 0) {
10507 name2obj = 1; obj2name = 0;
10508 idx = ENCODING_INDEX_UTF8;
10509
10510 } else if (strcmp(RSTRING_PTR(encname), "symbol") == 0) {
10511 name2obj = 1; obj2name = 0;
10512 idx = rb_enc_find_index("ASCII-8BIT");
10513
10514 } else {
10515 /* regist dummy encoding */
10516 name2obj = 1; obj2name = 1;
10517 }
10518 }
10519
10520 if (idx < 0) {
10521 /* unknown encoding -> create dummy */
10522 encobj = create_dummy_encoding_for_tk(interp, encname);
10523 } else {
10524 encobj = rb_enc_from_encoding(rb_enc_from_index(idx));
10525 }
10526
10527 if (name2obj) {
10528 DUMP2("create_encoding_table: name2obj: %s", RSTRING_PTR(encname));
10529 rb_hash_aset(table, encname, encobj);
10530 }
10531 if (obj2name) {
10532 DUMP2("create_encoding_table: obj2name: %s", RSTRING_PTR(encname));
10533 rb_hash_aset(table, encobj, encname);
10534 }
10535 }
10536
10537 Tcl_DecrRefCount(enc_list);
10538
10539 rb_ivar_set(table, ID_at_interp, interp);
10540 rb_ivar_set(interp, ID_encoding_table, table);
10541
10542 return table;
10543 }
10544
10545 #else /* ! HAVE_RUBY_ENCODING_H */
10546 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
10547 static VALUE
10548 create_encoding_table_core(arg, interp)
10549 VALUE arg;
10550 VALUE interp;
10551 {
10552 struct tcltkip *ptr = get_ip(interp);
10553 volatile VALUE table = rb_hash_new();
10554 volatile VALUE encname = Qnil;
10555 int i, objc;
10556 Tcl_Obj **objv;
10557 Tcl_Obj *enc_list;
10558
10559 rb_secure(4);
10560
10561 /* set 'binary' encoding */
10562 rb_hash_aset(table, ENCODING_NAME_BINARY, ENCODING_NAME_BINARY);
10563
10564 /* get Tcl's encoding list */
10565 Tcl_GetEncodingNames(ptr->ip);
10566 enc_list = Tcl_GetObjResult(ptr->ip);
10567 Tcl_IncrRefCount(enc_list);
10568
10569 if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) {
10570 Tcl_DecrRefCount(enc_list);
10571 rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");
10572 }
10573
10574 /* get encoding name and set it to table */
10575 for(i = 0; i < objc; i++) {
10576 encname = rb_obj_freeze(rb_str_new2(Tcl_GetString(objv[i])));
10577 rb_hash_aset(table, encname, encname);
10578 }
10579
10580 Tcl_DecrRefCount(enc_list);
10581
10582 rb_ivar_set(table, ID_at_interp, interp);
10583 rb_ivar_set(interp, ID_encoding_table, table);
10584
10585 return table;
10586 }
10587
10588 #else /* Tcl/Tk 7.x or 8.0 */
10589 static VALUE
10590 create_encoding_table_core(arg, interp)
10591 VALUE arg;
10592 VALUE interp;
10593 {
10594 volatile VALUE table = rb_hash_new();
10595 rb_secure(4);
10596 rb_ivar_set(interp, ID_encoding_table, table);
10597 return table;
10598 }
10599 #endif
10600 #endif
10601
10602 static VALUE
10603 create_encoding_table(interp)
10604 VALUE interp;
10605 {
10606 return rb_funcall(rb_proc_new(create_encoding_table_core, interp),
10607 ID_call, 0);
10608 }
10609
10610 static VALUE
10611 ip_get_encoding_table(interp)
10612 VALUE interp;
10613 {
10614 volatile VALUE table = Qnil;
10615
10616 table = rb_ivar_get(interp, ID_encoding_table);
10617
10618 if (NIL_P(table)) {
10619 /* initialize encoding_table */
10620 table = create_encoding_table(interp);
10621 rb_define_singleton_method(table, "get_name", encoding_table_get_name, 1);
10622 rb_define_singleton_method(table, "get_obj", encoding_table_get_obj, 1);
10623 }
10624
10625 return table;
10626 }
10627
10628
10629 /*###############################################*/
10630
10631 /*
10632 * The following is based on tkMenu.[ch]
10633 * of Tcl/Tk (Tk8.0 -- Tk8.5b1) source code.
10634 */
10635 #if TCL_MAJOR_VERSION >= 8
10636
10637 #define MASTER_MENU 0
10638 #define TEAROFF_MENU 1
10639 #define MENUBAR 2
10640
10641 struct dummy_TkMenuEntry {
10642 int type;
10643 struct dummy_TkMenu *menuPtr;
10644 /* , and etc. */
10645 };
10646
10647 struct dummy_TkMenu {
10648 Tk_Window tkwin;
10649 Display *display;
10650 Tcl_Interp *interp;
10651 Tcl_Command widgetCmd;
10652 struct dummy_TkMenuEntry **entries;
10653 int numEntries;
10654 int active;
10655 int menuType; /* MASTER_MENU, TEAROFF_MENU, or MENUBAR */
10656 Tcl_Obj *menuTypePtr;
10657 /* , and etc. */
10658 };
10659
10660 struct dummy_TkMenuRef {
10661 struct dummy_TkMenu *menuPtr;
10662 char *dummy1;
10663 char *dummy2;
10664 char *dummy3;
10665 };
10666
10667 #if 0 /* was available on Tk8.0 -- Tk8.4 */
10668 EXTERN struct dummy_TkMenuRef *TkFindMenuReferences(Tcl_Interp*, char*);
10669 #else /* based on Tk8.0 -- Tk8.5.0 */
10670 #define MENU_HASH_KEY "tkMenus"
10671 #endif
10672
10673 #endif
10674
10675 static VALUE
10676 ip_make_menu_embeddable_core(interp, argc, argv)
10677 VALUE interp;
10678 int argc;
10679 VALUE *argv;
10680 {
10681 #if TCL_MAJOR_VERSION >= 8
10682 volatile VALUE menu_path;
10683 struct tcltkip *ptr = get_ip(interp);
10684 struct dummy_TkMenuRef *menuRefPtr = NULL;
10685 XEvent event;
10686 Tcl_HashTable *menuTablePtr;
10687 Tcl_HashEntry *hashEntryPtr;
10688
10689 menu_path = argv[0];
10690 StringValue(menu_path);
10691
10692 #if 0 /* was available on Tk8.0 -- Tk8.4 */
10693 menuRefPtr = TkFindMenuReferences(ptr->ip, RSTRING_PTR(menu_path));
10694 #else /* based on Tk8.0 -- Tk8.5b1 */
10695 if ((menuTablePtr
10696 = (Tcl_HashTable *) Tcl_GetAssocData(ptr->ip, MENU_HASH_KEY, NULL))
10697 != NULL) {
10698 if ((hashEntryPtr
10699 = Tcl_FindHashEntry(menuTablePtr, RSTRING_PTR(menu_path)))
10700 != NULL) {
10701 menuRefPtr = (struct dummy_TkMenuRef *) Tcl_GetHashValue(hashEntryPtr);
10702 }
10703 }
10704 #endif
10705
10706 if (menuRefPtr == (struct dummy_TkMenuRef *) NULL) {
10707 rb_raise(rb_eArgError, "not a menu widget, or invalid widget path");
10708 }
10709
10710 if (menuRefPtr->menuPtr == (struct dummy_TkMenu *) NULL) {
10711 rb_raise(rb_eRuntimeError,
10712 "invalid menu widget (maybe already destroyed)");
10713 }
10714
10715 if ((menuRefPtr->menuPtr)->menuType != MENUBAR) {
10716 rb_raise(rb_eRuntimeError,
10717 "target menu widget must be a MENUBAR type");
10718 }
10719
10720 (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU;
10721 #if 0 /* cause SEGV */
10722 {
10723 /* char *s = "tearoff"; */
10724 char *s = "normal";
10725 /* Tcl_SetStringObj((menuRefPtr->menuPtr)->menuTypePtr, s, strlen(s));*/
10726 (menuRefPtr->menuPtr)->menuTypePtr = Tcl_NewStringObj(s, strlen(s));
10727 /* Tcl_IncrRefCount((menuRefPtr->menuPtr)->menuTypePtr); */
10728 /* (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU; */
10729 (menuRefPtr->menuPtr)->menuType = MASTER_MENU;
10730 }
10731 #endif
10732
10733 #if 0 /* was available on Tk8.0 -- Tk8.4 */
10734 TkEventuallyRecomputeMenu(menuRefPtr->menuPtr);
10735 TkEventuallyRedrawMenu(menuRefPtr->menuPtr,
10736 (struct dummy_TkMenuEntry *)NULL);
10737 #else /* based on Tk8.0 -- Tk8.5b1 */
10738 memset((void *) &event, 0, sizeof(event));
10739 event.xany.type = ConfigureNotify;
10740 event.xany.serial = NextRequest(Tk_Display((menuRefPtr->menuPtr)->tkwin));
10741 event.xany.send_event = 0; /* FALSE */
10742 event.xany.window = Tk_WindowId((menuRefPtr->menuPtr)->tkwin);
10743 event.xany.display = Tk_Display((menuRefPtr->menuPtr)->tkwin);
10744 event.xconfigure.window = event.xany.window;
10745 Tk_HandleEvent(&event);
10746 #endif
10747
10748 #else /* TCL_MAJOR_VERSION <= 7 */
10749 rb_notimplement();
10750 #endif
10751
10752 return interp;
10753 }
10754
10755 static VALUE
10756 ip_make_menu_embeddable(interp, menu_path)
10757 VALUE interp;
10758 VALUE menu_path;
10759 {
10760 VALUE argv[1];
10761
10762 argv[0] = menu_path;
10763 return tk_funcall(ip_make_menu_embeddable_core, 1, argv, interp);
10764 }
10765
10766
10767 /*###############################################*/
10768
10769 /*---- initialization ----*/
10770 void
10771 Init_tcltklib()
10772 {
10773 int ret;
10774
10775 VALUE lib = rb_define_module("TclTkLib");
10776 VALUE ip = rb_define_class("TclTkIp", rb_cObject);
10777
10778 VALUE ev_flag = rb_define_module_under(lib, "EventFlag");
10779 VALUE var_flag = rb_define_module_under(lib, "VarAccessFlag");
10780 VALUE release_type = rb_define_module_under(lib, "RELEASE_TYPE");
10781
10782 /* --------------------------------------------------------------- */
10783
10784 tcltkip_class = ip;
10785
10786 /* --------------------------------------------------------------- */
10787
10788 #ifdef HAVE_RUBY_ENCODING_H
10789 rb_global_variable(&cRubyEncoding);
10790 cRubyEncoding = rb_path2class("Encoding");
10791
10792 ENCODING_INDEX_UTF8 = rb_enc_to_index(rb_utf8_encoding());
10793 ENCODING_INDEX_BINARY = rb_enc_find_index("binary");
10794 #endif
10795
10796 rb_global_variable(&ENCODING_NAME_UTF8);
10797 rb_global_variable(&ENCODING_NAME_BINARY);
10798
10799 ENCODING_NAME_UTF8 = rb_obj_freeze(rb_str_new2("utf-8"));
10800 ENCODING_NAME_BINARY = rb_obj_freeze(rb_str_new2("binary"));
10801
10802 /* --------------------------------------------------------------- */
10803
10804 rb_global_variable(&eTkCallbackReturn);
10805 rb_global_variable(&eTkCallbackBreak);
10806 rb_global_variable(&eTkCallbackContinue);
10807
10808 rb_global_variable(&eventloop_thread);
10809 rb_global_variable(&eventloop_stack);
10810 rb_global_variable(&watchdog_thread);
10811
10812 rb_global_variable(&rbtk_pending_exception);
10813
10814 /* --------------------------------------------------------------- */
10815
10816 rb_define_const(lib, "COMPILE_INFO", tcltklib_compile_info());
10817
10818 rb_define_const(lib, "RELEASE_DATE",
10819 rb_obj_freeze(rb_str_new2(tcltklib_release_date)));
10820
10821 rb_define_const(lib, "FINALIZE_PROC_NAME",
10822 rb_str_new2(finalize_hook_name));
10823
10824 /* --------------------------------------------------------------- */
10825
10826 #ifdef __WIN32__
10827 # define TK_WINDOWING_SYSTEM "win32"
10828 #else
10829 # ifdef MAC_TCL
10830 # define TK_WINDOWING_SYSTEM "classic"
10831 # else
10832 # ifdef MAC_OSX_TK
10833 # define TK_WINDOWING_SYSTEM "aqua"
10834 # else
10835 # define TK_WINDOWING_SYSTEM "x11"
10836 # endif
10837 # endif
10838 #endif
10839 rb_define_const(lib, "WINDOWING_SYSTEM",
10840 rb_obj_freeze(rb_str_new2(TK_WINDOWING_SYSTEM)));
10841
10842 /* --------------------------------------------------------------- */
10843
10844 rb_define_const(ev_flag, "NONE", INT2FIX(0));
10845 rb_define_const(ev_flag, "WINDOW", INT2FIX(TCL_WINDOW_EVENTS));
10846 rb_define_const(ev_flag, "FILE", INT2FIX(TCL_FILE_EVENTS));
10847 rb_define_const(ev_flag, "TIMER", INT2FIX(TCL_TIMER_EVENTS));
10848 rb_define_const(ev_flag, "IDLE", INT2FIX(TCL_IDLE_EVENTS));
10849 rb_define_const(ev_flag, "ALL", INT2FIX(TCL_ALL_EVENTS));
10850 rb_define_const(ev_flag, "DONT_WAIT", INT2FIX(TCL_DONT_WAIT));
10851
10852 /* --------------------------------------------------------------- */
10853
10854 rb_define_const(var_flag, "NONE", INT2FIX(0));
10855 rb_define_const(var_flag, "GLOBAL_ONLY", INT2FIX(TCL_GLOBAL_ONLY));
10856 #ifdef TCL_NAMESPACE_ONLY
10857 rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(TCL_NAMESPACE_ONLY));
10858 #else /* probably Tcl7.6 */
10859 rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(0));
10860 #endif
10861 rb_define_const(var_flag, "LEAVE_ERR_MSG", INT2FIX(TCL_LEAVE_ERR_MSG));
10862 rb_define_const(var_flag, "APPEND_VALUE", INT2FIX(TCL_APPEND_VALUE));
10863 rb_define_const(var_flag, "LIST_ELEMENT", INT2FIX(TCL_LIST_ELEMENT));
10864 #ifdef TCL_PARSE_PART1
10865 rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(TCL_PARSE_PART1));
10866 #else /* probably Tcl7.6 */
10867 rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(0));
10868 #endif
10869
10870 /* --------------------------------------------------------------- */
10871
10872 rb_define_module_function(lib, "get_version", lib_getversion, -1);
10873 rb_define_module_function(lib, "get_release_type_name",
10874 lib_get_reltype_name, -1);
10875
10876 rb_define_const(release_type, "ALPHA", INT2FIX(TCL_ALPHA_RELEASE));
10877 rb_define_const(release_type, "BETA", INT2FIX(TCL_BETA_RELEASE));
10878 rb_define_const(release_type, "FINAL", INT2FIX(TCL_FINAL_RELEASE));
10879
10880 /* --------------------------------------------------------------- */
10881
10882 eTkCallbackReturn = rb_define_class("TkCallbackReturn", rb_eStandardError);
10883 eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError);
10884 eTkCallbackContinue = rb_define_class("TkCallbackContinue",
10885 rb_eStandardError);
10886
10887 /* --------------------------------------------------------------- */
10888
10889 eLocalJumpError = rb_const_get(rb_cObject, rb_intern("LocalJumpError"));
10890
10891 eTkLocalJumpError = rb_define_class("TkLocalJumpError", eLocalJumpError);
10892
10893 eTkCallbackRetry = rb_define_class("TkCallbackRetry", eTkLocalJumpError);
10894 eTkCallbackRedo = rb_define_class("TkCallbackRedo", eTkLocalJumpError);
10895 eTkCallbackThrow = rb_define_class("TkCallbackThrow", eTkLocalJumpError);
10896
10897 /* --------------------------------------------------------------- */
10898
10899 ID_at_enc = rb_intern("@encoding");
10900 ID_at_interp = rb_intern("@interp");
10901 ID_encoding_name = rb_intern("encoding_name");
10902 ID_encoding_table = rb_intern("encoding_table");
10903
10904 ID_stop_p = rb_intern("stop?");
10905 ID_alive_p = rb_intern("alive?");
10906 ID_kill = rb_intern("kill");
10907 ID_join = rb_intern("join");
10908 ID_value = rb_intern("value");
10909
10910 ID_call = rb_intern("call");
10911 ID_backtrace = rb_intern("backtrace");
10912 ID_message = rb_intern("message");
10913
10914 ID_at_reason = rb_intern("@reason");
10915 ID_return = rb_intern("return");
10916 ID_break = rb_intern("break");
10917 ID_next = rb_intern("next");
10918
10919 ID_to_s = rb_intern("to_s");
10920 ID_inspect = rb_intern("inspect");
10921
10922 /* --------------------------------------------------------------- */
10923
10924 rb_define_module_function(lib, "mainloop", lib_mainloop, -1);
10925 rb_define_module_function(lib, "mainloop_thread?",
10926 lib_evloop_thread_p, 0);
10927 rb_define_module_function(lib, "mainloop_watchdog",
10928 lib_mainloop_watchdog, -1);
10929 rb_define_module_function(lib, "do_thread_callback",
10930 lib_thread_callback, -1);
10931 rb_define_module_function(lib, "do_one_event", lib_do_one_event, -1);
10932 rb_define_module_function(lib, "mainloop_abort_on_exception",
10933 lib_evloop_abort_on_exc, 0);
10934 rb_define_module_function(lib, "mainloop_abort_on_exception=",
10935 lib_evloop_abort_on_exc_set, 1);
10936 rb_define_module_function(lib, "set_eventloop_window_mode",
10937 set_eventloop_window_mode, 1);
10938 rb_define_module_function(lib, "get_eventloop_window_mode",
10939 get_eventloop_window_mode, 0);
10940 rb_define_module_function(lib, "set_eventloop_tick",set_eventloop_tick,1);
10941 rb_define_module_function(lib, "get_eventloop_tick",get_eventloop_tick,0);
10942 rb_define_module_function(lib, "set_no_event_wait", set_no_event_wait, 1);
10943 rb_define_module_function(lib, "get_no_event_wait", get_no_event_wait, 0);
10944 rb_define_module_function(lib, "set_eventloop_weight",
10945 set_eventloop_weight, 2);
10946 rb_define_module_function(lib, "set_max_block_time", set_max_block_time,1);
10947 rb_define_module_function(lib, "get_eventloop_weight",
10948 get_eventloop_weight, 0);
10949 rb_define_module_function(lib, "num_of_mainwindows",
10950 lib_num_of_mainwindows, 0);
10951
10952 /* --------------------------------------------------------------- */
10953
10954 rb_define_module_function(lib, "_split_tklist", lib_split_tklist, 1);
10955 rb_define_module_function(lib, "_merge_tklist", lib_merge_tklist, -1);
10956 rb_define_module_function(lib, "_conv_listelement",
10957 lib_conv_listelement, 1);
10958 rb_define_module_function(lib, "_toUTF8", lib_toUTF8, -1);
10959 rb_define_module_function(lib, "_fromUTF8", lib_fromUTF8, -1);
10960 rb_define_module_function(lib, "_subst_UTF_backslash",
10961 lib_UTF_backslash, 1);
10962 rb_define_module_function(lib, "_subst_Tcl_backslash",
10963 lib_Tcl_backslash, 1);
10964
10965 rb_define_module_function(lib, "encoding_system",
10966 lib_get_system_encoding, 0);
10967 rb_define_module_function(lib, "encoding_system=",
10968 lib_set_system_encoding, 1);
10969 rb_define_module_function(lib, "encoding",
10970 lib_get_system_encoding, 0);
10971 rb_define_module_function(lib, "encoding=",
10972 lib_set_system_encoding, 1);
10973
10974 /* --------------------------------------------------------------- */
10975
10976 rb_define_alloc_func(ip, ip_alloc);
10977 rb_define_method(ip, "initialize", ip_init, -1);
10978 rb_define_method(ip, "create_slave", ip_create_slave, -1);
10979 rb_define_method(ip, "slave_of?", ip_is_slave_of_p, 1);
10980 rb_define_method(ip, "make_safe", ip_make_safe, 0);
10981 rb_define_method(ip, "safe?", ip_is_safe_p, 0);
10982 rb_define_method(ip, "allow_ruby_exit?", ip_allow_ruby_exit_p, 0);
10983 rb_define_method(ip, "allow_ruby_exit=", ip_allow_ruby_exit_set, 1);
10984 rb_define_method(ip, "delete", ip_delete, 0);
10985 rb_define_method(ip, "deleted?", ip_is_deleted_p, 0);
10986 rb_define_method(ip, "has_mainwindow?", ip_has_mainwindow_p, 0);
10987 rb_define_method(ip, "invalid_namespace?", ip_has_invalid_namespace_p, 0);
10988 rb_define_method(ip, "_eval", ip_eval, 1);
10989 rb_define_method(ip, "_cancel_eval", ip_cancel_eval, -1);
10990 rb_define_method(ip, "_cancel_eval_unwind", ip_cancel_eval_unwind, -1);
10991 rb_define_method(ip, "_toUTF8", ip_toUTF8, -1);
10992 rb_define_method(ip, "_fromUTF8", ip_fromUTF8, -1);
10993 rb_define_method(ip, "_thread_vwait", ip_thread_vwait, 1);
10994 rb_define_method(ip, "_thread_tkwait", ip_thread_tkwait, 2);
10995 rb_define_method(ip, "_invoke", ip_invoke, -1);
10996 rb_define_method(ip, "_immediate_invoke", ip_invoke_immediate, -1);
10997 rb_define_method(ip, "_return_value", ip_retval, 0);
10998
10999 rb_define_method(ip, "_create_console", ip_create_console, 0);
11000
11001 /* --------------------------------------------------------------- */
11002
11003 rb_define_method(ip, "create_dummy_encoding_for_tk",
11004 create_dummy_encoding_for_tk, 1);
11005 rb_define_method(ip, "encoding_table", ip_get_encoding_table, 0);
11006
11007 /* --------------------------------------------------------------- */
11008
11009 rb_define_method(ip, "_get_variable", ip_get_variable, 2);
11010 rb_define_method(ip, "_get_variable2", ip_get_variable2, 3);
11011 rb_define_method(ip, "_set_variable", ip_set_variable, 3);
11012 rb_define_method(ip, "_set_variable2", ip_set_variable2, 4);
11013 rb_define_method(ip, "_unset_variable", ip_unset_variable, 2);
11014 rb_define_method(ip, "_unset_variable2", ip_unset_variable2, 3);
11015 rb_define_method(ip, "_get_global_var", ip_get_global_var, 1);
11016 rb_define_method(ip, "_get_global_var2", ip_get_global_var2, 2);
11017 rb_define_method(ip, "_set_global_var", ip_set_global_var, 2);
11018 rb_define_method(ip, "_set_global_var2", ip_set_global_var2, 3);
11019 rb_define_method(ip, "_unset_global_var", ip_unset_global_var, 1);
11020 rb_define_method(ip, "_unset_global_var2", ip_unset_global_var2, 2);
11021
11022 /* --------------------------------------------------------------- */
11023
11024 rb_define_method(ip, "_make_menu_embeddable", ip_make_menu_embeddable, 1);
11025
11026 /* --------------------------------------------------------------- */
11027
11028 rb_define_method(ip, "_split_tklist", ip_split_tklist, 1);
11029 rb_define_method(ip, "_merge_tklist", lib_merge_tklist, -1);
11030 rb_define_method(ip, "_conv_listelement", lib_conv_listelement, 1);
11031
11032 /* --------------------------------------------------------------- */
11033
11034 rb_define_method(ip, "mainloop", ip_mainloop, -1);
11035 rb_define_method(ip, "mainloop_watchdog", ip_mainloop_watchdog, -1);
11036 rb_define_method(ip, "do_one_event", ip_do_one_event, -1);
11037 rb_define_method(ip, "mainloop_abort_on_exception",
11038 ip_evloop_abort_on_exc, 0);
11039 rb_define_method(ip, "mainloop_abort_on_exception=",
11040 ip_evloop_abort_on_exc_set, 1);
11041 rb_define_method(ip, "set_eventloop_tick", ip_set_eventloop_tick, 1);
11042 rb_define_method(ip, "get_eventloop_tick", ip_get_eventloop_tick, 0);
11043 rb_define_method(ip, "set_no_event_wait", ip_set_no_event_wait, 1);
11044 rb_define_method(ip, "get_no_event_wait", ip_get_no_event_wait, 0);
11045 rb_define_method(ip, "set_eventloop_weight", ip_set_eventloop_weight, 2);
11046 rb_define_method(ip, "get_eventloop_weight", ip_get_eventloop_weight, 0);
11047 rb_define_method(ip, "set_max_block_time", set_max_block_time, 1);
11048 rb_define_method(ip, "restart", ip_restart, 0);
11049
11050 /* --------------------------------------------------------------- */
11051
11052 eventloop_thread = Qnil;
11053 eventloop_interp = (Tcl_Interp*)NULL;
11054
11055 #ifndef DEFAULT_EVENTLOOP_DEPTH
11056 #define DEFAULT_EVENTLOOP_DEPTH 7
11057 #endif
11058 eventloop_stack = rb_ary_new2(DEFAULT_EVENTLOOP_DEPTH);
11059 RbTk_OBJ_UNTRUST(eventloop_stack);
11060
11061 watchdog_thread = Qnil;
11062
11063 rbtk_pending_exception = Qnil;
11064
11065 /* --------------------------------------------------------------- */
11066
11067 #ifdef HAVE_NATIVETHREAD
11068 /* if ruby->nativethread-supprt and tcltklib->doen't,
11069 the following will cause link-error. */
11070 ruby_native_thread_p();
11071 #endif
11072
11073 /* --------------------------------------------------------------- */
11074
11075 rb_set_end_proc(lib_mark_at_exit, 0);
11076
11077 /* --------------------------------------------------------------- */
11078
11079 ret = ruby_open_tcl_dll(rb_argv0 ? RSTRING_PTR(rb_argv0) : 0);
11080 switch(ret) {
11081 case TCLTK_STUBS_OK:
11082 break;
11083 case NO_TCL_DLL:
11084 rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll");
11085 case NO_FindExecutable:
11086 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable");
11087 default:
11088 rb_raise(rb_eLoadError, "tcltklib: unknown error(%d) on ruby_open_tcl_dll", ret);
11089 }
11090
11091 /* --------------------------------------------------------------- */
11092
11093 #if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT
11094 setup_rubytkkit();
11095 #endif
11096
11097 /* --------------------------------------------------------------- */
11098
11099 /* Tcl stub check */
11100 tcl_stubs_check();
11101
11102 Tcl_ObjType_ByteArray = Tcl_GetObjType(Tcl_ObjTypeName_ByteArray);
11103 Tcl_ObjType_String = Tcl_GetObjType(Tcl_ObjTypeName_String);
11104
11105 /* --------------------------------------------------------------- */
11106
11107 (void)call_original_exit;
11108 }
11109
11110 /* eof */
data
VALUE data
Definition: tcltklib.c:3368
enc_arg
VALUE enc_arg
Definition: tcltklib.c:10204
inf
struct invoke_info inf
Definition: tcltklib.c:8574
cmd_body_arg::args
VALUE args
Definition: tcltklib.c:553
RARRAY_PTR
RARRAY_PTR(q->result)[0]
TCL_ERROR
return TCL_ERROR
Definition: tcltklib.c:3954
cmd_body_arg
Definition: tcltklib.c:550
ALLOC
#define ALLOC(type)
tmp
volatile VALUE tmp
Definition: tcltklib.c:10209
rb_eStandardError
VALUE rb_eStandardError
Definition: error.c:509
invoke_queue_mark
void invoke_queue_mark(struct invoke_queue *q)
Definition: tcltklib.c:440
rb_gc_disable
VALUE rb_gc_disable(void)
Definition: gc.c:3283
rb_enc_get_index
int rb_enc_get_index(VALUE obj)
Definition: encoding.c:690
lib_mainloop_watchdog
return lib_mainloop_watchdog(argc, argv, self)
thread_call_proc_arg::proc
VALUE proc
Definition: tcltklib.c:2906
eTkCallbackRetry
static VALUE eTkCallbackRetry
Definition: tcltklib.c:216
thread_call_proc_arg
Definition: tcltklib.c:2905
ary
volatile VALUE ary
Definition: tcltklib.c:9713
rb_thread_check_trap_pending
int rb_thread_check_trap_pending()
Definition: thread.c:1100
int
VP_EXPORT int
Definition: bigdecimal.c:5050
rb_ary_pop
VALUE rb_ary_pop(VALUE ary)
Definition: array.c:879
TCL_FINAL_RELEASE
#define TCL_FINAL_RELEASE
Definition: tcltklib.c:105
rb_debug_bup
VALUE rb_debug_bup
Definition: tcltklib.c:5689
TKWAIT_MODE_VISIBILITY
#define TKWAIT_MODE_VISIBILITY
rb_bug
void rb_bug(const char *fmt,...)
Definition: error.c:290
error_mode
VALUE error_mode
Definition: tcltklib.c:10097
ruby_tcl_stubs_init
int ruby_tcl_stubs_init()
Definition: stubs.c:533
ID_at_reason
static ID ID_at_reason
Definition: tcltklib.c:238
tail
#define tail
Definition: st.c:108
eval_queue::result
VALUE result
Definition: tcltklib.c:423
rb_hash_lookup
#define rb_hash_lookup
Definition: tcltklib.c:268
TAG_RETRY
#define TAG_RETRY
Definition: tcltklib.c:159
eTkCallbackRedo
static VALUE eTkCallbackRedo
Definition: tcltklib.c:217
th
static VALUE VALUE th
Definition: tcltklib.c:2948
code
code
Definition: tcltklib.c:3381
eventloop_interp
static Tcl_Interp * eventloop_interp
Definition: tcltklib.c:471
strlen
size_t strlen(const char *)
evq
VALUE evq
Definition: tcltklib.c:7482
nameString
char * nameString
Definition: tcltklib.c:4482
Tcl_CallWhenDeleted
Tcl_CallWhenDeleted(ptr->ip, ip_CallWhenDeleted,(ClientData) mainWin)
tcltkip::ref_count
int ref_count
Definition: tcltklib.c:764
FAIL_Tcl_InitStubs
#define FAIL_Tcl_InitStubs
Definition: stubs.h:28
encodename
VALUE encodename
Definition: tcltklib.c:7954
TCL_ALPHA_RELEASE
#define TCL_ALPHA_RELEASE
Definition: tcltklib.c:103
invoke_info::ptr
struct tcltkip * ptr
Definition: tcltklib.c:8471
tcl_protect_core
static int tcl_protect_core(Tcl_Interp *interp, VALUE(*proc)(), VALUE data)
Definition: tcltklib.c:3189
rb_iv_set
VALUE rb_iv_set(VALUE, const char *, VALUE)
Definition: variable.c:2591
rb_cEncoding
VALUE rb_cEncoding
Definition: encoding.c:40
ID_at_interp
static ID ID_at_interp
Definition: tcltklib.c:223
minor
int minor
Definition: tcltklib.c:110
ID_break
static ID ID_break
Definition: tcltklib.c:240
rb_tainted_str_new2
#define rb_tainted_str_new2
ruby_open_tcl_dll
int ruby_open_tcl_dll(char *)
chance
int chance
Definition: tcltklib.c:2796
tcltkip_class
static VALUE tcltkip_class
Definition: tcltklib.c:220
rb_define_singleton_method
void rb_define_singleton_method(VALUE obj, const char *name, VALUE(*func)(ANYARGS), int argc)
Defines a singleton method for obj.
Definition: class.c:1497
NO_THREAD_INTERRUPT_TIME
#define NO_THREAD_INTERRUPT_TIME
Definition: tcltklib.c:522
ip_invoke_with_position
return ip_invoke_with_position(2, argv, self, TCL_QUEUE_TAIL)
RUBY_RELEASE_DATE
#define RUBY_RELEASE_DATE
Definition: tcltklib.c:19
TK_WINDOWING_SYSTEM
#define TK_WINDOWING_SYSTEM
invoke_info::cmdinfo
Tcl_CmdInfo cmdinfo
Definition: tcltklib.c:8472
evloop_params::check_root
int check_root
Definition: tcltklib.c:2552
Tcl_AppendResult
Tcl_AppendResult(interp, RSTRING_PTR(msg),(char *) NULL)
thread_call_proc_arg::done
int * done
Definition: tcltklib.c:2907
Tcl_Eval
#define Tcl_Eval
Definition: tcltklib.c:291
TAG_RETURN
#define TAG_RETURN
Definition: tcltklib.c:156
TCLTK_STUBS_OK
return TCLTK_STUBS_OK
Definition: stubs.c:460
interp
static int Tcl_Interp * interp
Definition: tcltklib.c:277
evloop_params::update_flag
int update_flag
Definition: tcltklib.c:2553
DEFAULT_EVENTLOOP_DEPTH
#define DEFAULT_EVENTLOOP_DEPTH
proc
VALUE proc
Definition: tcltklib.c:2959
eval_queue::str
char * str
Definition: tcltklib.c:418
th_update_param
Definition: tcltklib.c:4006
table
static int VALUE table
Definition: tcltklib.c:10138
func
SSL_METHOD *(* func)(void)
Definition: ossl_ssl.c:108
rb_secure
void rb_secure(int)
Definition: safe.c:79
rb_const_get
VALUE rb_const_get(VALUE, ID)
Definition: variable.c:1876
rb_gc_force_recycle
void rb_gc_force_recycle(VALUE)
Definition: gc.c:2961
i
ssize_t i
Definition: bigdecimal.c:5655
rbtk_EventCheckProc
void rbtk_EventCheckProc(ClientData clientData, int flag)
Definition: tcltklib.c:2001
call_queue_mark
void call_queue_mark(struct call_queue *q)
Definition: tcltklib.c:456
Tcl_DoWhenIdle
Tcl_DoWhenIdle(rb_threadUpdateProc,(ClientData) param)
rb_trap_exec
void rb_trap_exec(void)
Tcl_ResetResult
Tcl_ResetResult(interp)
rb_gv_get
VALUE rb_gv_get(const char *)
Definition: variable.c:813
info
Tcl_CmdInfo * info
Definition: tcltklib.c:1463
target
VALUE target
Definition: tcltklib.c:5532
tcltkip::has_orig_exit
int has_orig_exit
Definition: tcltklib.c:762
ruby.h
FAIL_CreateInterp
#define FAIL_CreateInterp
Definition: stubs.h:27
window
Tk_Window window
Definition: tcltklib.c:4475
thr_crit_bup
static int int thr_crit_bup
Definition: tcltklib.c:1416
ret
int ret
Definition: tcltklib.c:280
timer_token
static Tcl_TimerToken timer_token
Definition: tcltklib.c:1606
th_vwait_param::done
int done
Definition: tcltklib.c:4845
safemode
VALUE safemode
Definition: tcltklib.c:6402
rb_enc_from_encoding
VALUE rb_enc_from_encoding(rb_encoding *encoding)
Definition: encoding.c:103
status
int status
Definition: tcltklib.c:2197
rb_obj_freeze
VALUE rb_obj_freeze(VALUE)
Definition: object.c:989
rb_obj_dup
VALUE rb_obj_dup(VALUE)
Definition: object.c:338
ID_encoding_name
static ID ID_encoding_name
Definition: tcltklib.c:225
rb_define_alloc_func
void rb_define_alloc_func(VALUE, rb_alloc_func_t)
invoke_queue::result
VALUE result
Definition: tcltklib.c:412
thread
param thread
Definition: tcltklib.c:4133
Tcl_DeleteEventSource
Tcl_DeleteEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc,(ClientData) args)
OBJ_TAINTED
#define OBJ_TAINTED(x)
UNREACHABLE
#define UNREACHABLE
Definition: ruby.h:40
exc
VALUE exc
Definition: tcltklib.c:3096
enc
VALUE enc
Definition: tcltklib.c:10311
rb_ary_push
VALUE rb_ary_push(VALUE ary, VALUE item)
Definition: array.c:822
RUBY_VERSION
#define RUBY_VERSION
Definition: tcltklib.c:16
path
gz path
Definition: zlib.c:2279
eval_queue_mark
void eval_queue_mark(struct eval_queue *q)
Definition: tcltklib.c:448
TYPE
#define TYPE(x)
Tcl_DeleteTimerHandler
Tcl_DeleteTimerHandler(timer_token)
RSTRING_PTR
#define RSTRING_PTR(str)
CLASS_OF
#define CLASS_OF(v)
tcltkip::ip
Tcl_Interp * ip
Definition: tcltklib.c:755
TKWAIT_MODE_DESTROY
#define TKWAIT_MODE_DESTROY
NIL_P
NIL_P(eventloop_thread)
Definition: tcltklib.c:4068
T_ARRAY
#define T_ARRAY
safe
int safe
Definition: tcltklib.c:6404
check_rootwidget
static VALUE VALUE check_rootwidget
Definition: tcltklib.c:2782
ID_value
static ID ID_value
Definition: tcltklib.c:232
invoke_info::argv
char ** argv
Definition: tcltklib.c:8478
eval_queue::len
int len
Definition: tcltklib.c:419
var
VALUE var
Definition: tcltklib.c:5517
rb_protect
VALUE rb_protect(VALUE(*proc)(VALUE), VALUE data, int *state)
Definition: eval.c:771
callargv
VALUE callargv[2]
Definition: tcltklib.c:6514
xfree
#define xfree
call_queue::ev
Tcl_Event ev
Definition: tcltklib.c:428
is_ip
int is_ip
Definition: tcltklib.c:3022
rbtk_eventloop_depth
static int rbtk_eventloop_depth
Definition: tcltklib.c:1376
rb_funcall
VALUE rb_funcall(VALUE, ID, int,...)
Calls a method.
Definition: vm_eval.c:774
Tcl_Release
Tcl_Release(interp)
cRubyEncoding
static VALUE cRubyEncoding
Definition: tcltklib.c:188
rb_raise
void rb_raise(VALUE exc, const char *fmt,...)
Definition: error.c:1780
rb_proc_new
VALUE rb_proc_new(VALUE(*)(ANYARGS), VALUE)
Definition: proc.c:2018
flag_val
static VALUE VALUE flag_val
Definition: tcltklib.c:2043
Qtrue
return Qtrue
Definition: tcltklib.c:9610
rb_obj_class
VALUE rb_obj_class(VALUE)
Definition: object.c:194
ENCODING_INDEX_BINARY
static int ENCODING_INDEX_BINARY
Definition: tcltklib.c:192
eval_str
char * eval_str
Definition: tcltklib.c:7604
matherr
int matherr()
missing.h
index
int index
Definition: tcltklib.c:4478
rb_ary_new3
VALUE rb_ary_new3(long n,...)
Definition: array.c:432
evloop_params
Definition: tcltklib.c:2551
ip_finalize
ip_finalize(ip)
NO_Tk_Init
#define NO_Tk_Init
Definition: stubs.h:31
receiver
receiver
Definition: tcltklib.c:3576
rb_eSecurityError
VALUE rb_eSecurityError
Definition: error.c:520
T_NIL
#define T_NIL
rb_locale_charmap
VALUE rb_locale_charmap(VALUE klass)
Definition: encoding.c:1479
eLocalJumpError
static VALUE eLocalJumpError
Definition: tcltklib.c:213
free_invoke_arguments
free_invoke_arguments(argc, av)
enc_name
VALUE enc_name
Definition: tcltklib.c:8445
rb_enc_to_index
#define rb_enc_to_index(enc)
old_gc
VALUE old_gc
Definition: tcltklib.c:3608
ID_alive_p
static ID ID_alive_p
Definition: tcltklib.c:229
rb_str_new2
#define rb_str_new2
timeval::tv_sec
long tv_sec
Definition: ossl_asn1.c:17
set_eventloop_weight
return set_eventloop_weight(self, loop_max, no_event)
state
int state
Definition: tcltklib.c:1462
optionStrings
static CONST char * optionStrings[]
Definition: tcltklib.c:4479
varname
volatile VALUE varname
Definition: tcltklib.c:9311
Tcl_GetEncodingNames
Tcl_GetEncodingNames(ptr->ip)
timer_tick
static int timer_tick
Definition: tcltklib.c:530
rb_argv0
RUBY_EXTERN VALUE rb_argv0
Definition: ripper.y:653
rb_path2class
VALUE rb_path2class(const char *)
Definition: variable.c:371
rb_thread_alive_p
static VALUE rb_thread_alive_p(VALUE thread)
Definition: thread.c:2583
ip_replace_wait_commands
ip_replace_wait_commands(slave, mainWin)
call_queue::argc
int argc
Definition: tcltklib.c:430
rb_utf8_encoding
rb_encoding * rb_utf8_encoding(void)
Definition: encoding.c:1168
set_tcltk_version
static void set_tcltk_version()
Definition: tcltklib.c:116
T_FLOAT
#define T_FLOAT
tbl
VALUE tbl
Definition: tkutil.c:1280
args
VALUE VALUE args
Definition: tcltklib.c:2561
LONG2NUM
#define LONG2NUM(x)
rb_str_append
VALUE rb_str_append(VALUE, VALUE)
Definition: string.c:2121
TAG_THROW
#define TAG_THROW
Definition: tcltklib.c:162
menu_path
VALUE menu_path
Definition: tcltklib.c:10758
strval
volatile VALUE strval
Definition: tcltklib.c:9365
Tcl_GetStringResult
#define Tcl_GetStringResult(interp)
Definition: tcltklib.c:322
rb_ivar_get
VALUE rb_ivar_get(VALUE, ID)
Definition: variable.c:1116
argv0
VALUE argv0
Definition: tcltklib.c:6146
flag
flag
Definition: tcltklib.c:2048
einfo
VALUE einfo
Definition: tcltklib.c:847
head
#define head
Definition: st.c:107
fmt
const char * fmt
Definition: tcltklib.c:841
TCL_BETA_RELEASE
#define TCL_BETA_RELEASE
Definition: tcltklib.c:104
check_var
int * check_var
Definition: tcltklib.c:2189
Tcl_AllowExceptions
Tcl_AllowExceptions(interp)
name2
char * name2
Definition: tcltklib.c:4206
finalize_hook_name
static const char finalize_hook_name[]
Definition: tcltklib.c:181
slave_name
char * slave_name
Definition: tcltklib.c:5608
DEFAULT_NO_EVENT_TICK
#define DEFAULT_NO_EVENT_TICK
Definition: tcltklib.c:518
rb_exc_raise
void rb_exc_raise(VALUE mesg)
Definition: eval.c:527
call_queue::result
VALUE result
Definition: tcltklib.c:435
eventloop_thread
static VALUE eventloop_thread
Definition: tcltklib.c:470
tclDummyMathPtr
int * tclDummyMathPtr
Definition: tcltklib.c:395
loop_max
VALUE loop_max
Definition: tcltklib.c:1811
rb_eNameError
VALUE rb_eNameError
Definition: error.c:516
list_enc_idx
int list_enc_idx
Definition: tcltklib.c:9719
WATCHDOG_INTERVAL
#define WATCHDOG_INTERVAL
Definition: tcltklib.c:520
done
*q done
Definition: tcltklib.c:2929
RbTk_OBJ_UNTRUST
#define RbTk_OBJ_UNTRUST(x)
Definition: tcltklib.c:43
watchdog_thread
static VALUE watchdog_thread
Definition: tcltklib.c:478
call_queue
Definition: tcltklib.c:427
rb_to_encoding_index
int rb_to_encoding_index(VALUE enc)
Definition: encoding.c:146
memset
memset(y->frac+ix+1, 0,(y->Prec-(ix+1))*sizeof(BDIGIT))
rb_block_proc
VALUE rb_block_proc(void)
Definition: proc.c:479
Data_Wrap_Struct
return Data_Wrap_Struct(CLASS_OF(interp), 0, ip_free, slave)
have_rb_thread_waiting_for_value
static int have_rb_thread_waiting_for_value
Definition: tcltklib.c:499
check_root
static int int check_root
Definition: tcltklib.c:2187
Qfalse
return Qfalse
Definition: tcltklib.c:6779
slave_list
char * slave_list
Definition: tcltklib.c:5607
Tcl_CreateCommand
Tcl_CreateCommand(interp,"vwait", ip_rbVwaitCommand,(ClientData) NULL,(Tcl_CmdDeleteProc *) NULL)
evloop_params::thr_crit_bup
int thr_crit_bup
Definition: tcltklib.c:2556
invoke_queue::safe_level
int safe_level
Definition: tcltklib.c:411
th_update_param::thread
VALUE thread
Definition: tcltklib.c:4007
call_queue::done
int * done
Definition: tcltklib.c:433
ip_wrap_namespace_command
ip_wrap_namespace_command(ptr->ip)
NUM2DBL
#define NUM2DBL(x)
Qnil
#define Qnil
Definition: tcltklib.c:1896
StringValuePtr
#define StringValuePtr(v)
elem
volatile VALUE elem
Definition: tcltklib.c:9713
val
#define val
Definition: tcltklib.c:1949
timeval::tv_usec
long tv_usec
Definition: ossl_asn1.c:18
rb_eRuntimeError
VALUE rb_eRuntimeError
Definition: error.c:510
TAG_RAISE
#define TAG_RAISE
Definition: tcltklib.c:161
RARRAY
#define RARRAY(obj)
depth
int depth
Definition: tcltklib.c:2198
update_flag
int update_flag
Definition: tcltklib.c:2188
rb_eval_string_protect
VALUE rb_eval_string_protect(const char *, int *)
Evaluates the given string in an isolated binding.
Definition: vm_eval.c:1403
vsnprintf
vsnprintf(buf, BUFSIZ, fmt, args)
invoke_queue::ev
Tcl_Event ev
Definition: tcltklib.c:402
str
static VALUE char * str
Definition: tcltklib.c:3547
TKWAIT_WINDOW
Definition: tcltklib.c:4481
invoke_queue
Definition: tcltklib.c:401
ckfree
ckfree((char *) param)
Check_Type
#define Check_Type(v, t)
StringValueCStr
#define StringValueCStr(v)
flags
int flags
Definition: tcltklib.c:3023
ID
unsigned long ID
Definition: ripper.y:105
rb_enc_default_external
VALUE rb_enc_default_external(void)
Definition: encoding.c:1302
va_end
va_end(args)
rb_gc_mark
void rb_gc_mark(VALUE)
Definition: gc.c:2598
rb_define_const
void rb_define_const(VALUE, const char *, VALUE)
Definition: variable.c:2202
wait
VALUE wait
Definition: tcltklib.c:1759
rb_define_class
VALUE rb_define_class(const char *name, VALUE super)
Defines a top-level class.
Definition: class.c:499
obj
static VALUE VALUE obj
Definition: tcltklib.c:3158
RSTRING_LEN
#define RSTRING_LEN(str)
FIX2INT
#define FIX2INT(x)
lib_toUTF8_core
return lib_toUTF8_core(Qnil, str, encodename)
INT2FIX
#define INT2FIX(i)
idx
int idx
Definition: tcltklib.c:9716
encobj
volatile VALUE encobj
Definition: tcltklib.c:10156
eventloop_stack
static VALUE eventloop_stack
Definition: tcltklib.c:475
is_tk_evloop_thread
int is_tk_evloop_thread
Definition: tcltklib.c:7111
prev_val
int prev_val
Definition: tcltklib.c:2795
Tcl_IncrRefCount
#define Tcl_IncrRefCount(obj)
Definition: tcltklib.c:316
current_thread
volatile VALUE current_thread
Definition: tcltklib.c:4050
ANYARGS
#define ANYARGS
T_STRING
#define T_STRING
ID_encoding_table
static ID ID_encoding_table
Definition: tcltklib.c:226
th_update_param::done
int done
Definition: tcltklib.c:4008
rb_thread_alone
int rb_thread_alone(void)
Definition: thread.c:2904
rbtk_preserve_ip
rbtk_preserve_ip(ptr)
current_evloop
volatile VALUE current_evloop
Definition: tcltklib.c:2619
param
pure parser lex param
Definition: ripper.y:686
no_event_tick
static int no_event_tick
Definition: tcltklib.c:528
lib_restart
return lib_restart(self)
method
volatile ID method
Definition: tcltklib.c:3599
ip
static void Tcl_Interp * ip
Definition: tcltklib.c:5601
window_event_mode
static int window_event_mode
Definition: tcltklib.c:476
rb_sourcefile
#define rb_sourcefile()
Definition: tcltklib.c:97
va_dcl
va_dcl
Definition: tcltklib.c:844
FAIL_Tk_Init
#define FAIL_Tk_Init
Definition: stubs.h:32
ivq
VALUE ivq
Definition: tcltklib.c:8974
enc_list
Tcl_Obj * enc_list
Definition: tcltklib.c:10154
buf
unsigned char buf[MIME_BUF_SIZE]
Definition: nkf.c:4308
TAG_FATAL
#define TAG_FATAL
Definition: tcltklib.c:163
ID_to_s
static ID ID_to_s
Definition: tcltklib.c:243
rb_enc_associate_index
VALUE rb_enc_associate_index(VALUE obj, int idx)
Definition: encoding.c:748
slave
Tcl_Interp * slave
Definition: tcltklib.c:5602
rb_thread_check_ints
void rb_thread_check_ints(void)
Definition: thread.c:1090
ID_message
static ID ID_message
Definition: tcltklib.c:236
rb_thread_critical
static int rb_thread_critical
Definition: tcltklib.c:23
cmd_body_arg::receiver
VALUE receiver
Definition: tcltklib.c:551
rb_eLoadError
VALUE rb_eLoadError
Definition: error.c:527
rbtk_release_ip
rbtk_release_ip(ptr)
DUMP1
#define DUMP1(ARG1)
Definition: tcltklib.c:166
call_queue::thread
VALUE thread
Definition: tcltklib.c:436
patchlevel
int patchlevel
Definition: tcltklib.c:112
encoding.h
cmd_body_arg::method
ID method
Definition: tcltklib.c:552
REGEXP_IDLETASKS
Definition: tcltklib.c:3895
rb_eval_string
VALUE rb_eval_string(const char *)
Evaluates the given string in an isolated binding.
Definition: vm_eval.c:1387
Tcl_DecrRefCount
#define Tcl_DecrRefCount(obj)
Definition: tcltklib.c:317
tcltklib_release_date
static const char tcltklib_release_date[]
Definition: tcltklib.c:178
list_str
VALUE list_str
Definition: tcltklib.c:9712
level
gz level
Definition: zlib.c:2264
rb_obj_as_string
VALUE rb_obj_as_string(VALUE)
Definition: string.c:895
argv
VALUE * argv
Definition: tcltklib.c:1971
rb_hash_aset
VALUE rb_hash_aset(VALUE, VALUE, VALUE)
rb_tainted_str_new
VALUE rb_tainted_str_new(const char *, long)
tcltklib_compile_info
static VALUE tcltklib_compile_info()
Definition: tcltklib.c:10029
ID_next
static ID ID_next
Definition: tcltklib.c:241
rb_str_resize
VALUE rb_str_resize(VALUE, long)
Definition: string.c:1853
memcpy
memcpy(buf+1, str, len)
invoke_info
Definition: tcltklib.c:8470
RTEST
#define RTEST(v)
eval_queue::thread
VALUE thread
Definition: tcltklib.c:424
rb_define_module_function
void rb_define_module_function(VALUE module, const char *name, VALUE(*func)(ANYARGS), int argc)
Defines a module function for module.
Definition: class.c:1512
rb_str_export_to_enc
VALUE rb_str_export_to_enc(VALUE, rb_encoding *)
Definition: string.c:632
eventPtr
XEvent * eventPtr
Definition: tcltklib.c:4451
invoke_queue::argc
int argc
Definition: tcltklib.c:403
invoke_info::argc
int argc
Definition: tcltklib.c:8477
timeval
Definition: ossl_asn1.c:16
cmd_len
int cmd_len
Definition: tcltklib.c:7322
result
q result
Definition: tcltklib.c:7070
ruby_tk_stubs_init
int ruby_tk_stubs_init(Tcl_Interp *)
rb_thread_current
VALUE rb_thread_current(void)
Definition: thread.c:2350
DEFAULT_NO_EVENT_WAIT
#define DEFAULT_NO_EVENT_WAIT
Definition: tcltklib.c:519
rbtk_pending_exception
static VALUE rbtk_pending_exception
Definition: tcltklib.c:1375
eval_queue::done
int * done
Definition: tcltklib.c:421
value
volatile VALUE value
Definition: tcltklib.c:9442
unknown_flag
int unknown_flag
Definition: tcltklib.c:8571
StringValue
#define StringValue(v)
encname
volatile VALUE encname
Definition: tcltklib.c:10155
no_event_wait
static int no_event_wait
Definition: tcltklib.c:529
rb_const_defined
int rb_const_defined(VALUE, ID)
Definition: variable.c:2103
foundEvent
int foundEvent
Definition: tcltklib.c:2962
name1
char * name1
Definition: tcltklib.c:4205
const
#define const
Definition: strftime.c:102
s
register char * s
Definition: os2.c:56
check
int check
Definition: tcltklib.c:2797
TKWAIT_VARIABLE
Definition: tcltklib.c:4481
call_queue::interp
VALUE interp
Definition: tcltklib.c:432
tk_funcall
return tk_funcall(ip_create_slave_core, 2, callargv, self)
void
VP_EXPORT void
Definition: bigdecimal.c:5083
mode
VALUE mode
Definition: tcltklib.c:1664
tick
VALUE tick
Definition: tcltklib.c:1680
strdup
#define strdup(s)
Definition: util.h:69
rb_scan_args
int rb_scan_args(int argc, const VALUE *argv, const char *fmt,...)
Definition: class.c:1570
length
size_t length
Definition: tcltklib.c:4559
donePtr
* donePtr
Definition: tcltklib.c:4212
rbtk_internal_eventloop_handler
static int rbtk_internal_eventloop_handler
Definition: tcltklib.c:1377
retval
VALUE retval
Definition: tcltklib.c:7830
event_flag
int event_flag
Definition: tcltklib.c:2194
with_tk
int with_tk
Definition: tcltklib.c:6151
rb_eInterrupt
VALUE rb_eInterrupt
Definition: error.c:506
ruby_tk_stubs_safeinit
int ruby_tk_stubs_safeinit(Tcl_Interp *)
eval_queue::safe_level
int safe_level
Definition: tcltklib.c:422
rb_exc_new2
VALUE rb_exc_new2(VALUE etype, const char *s)
Definition: error.c:542
rb_thread_run
VALUE rb_thread_run(VALUE)
Definition: thread.c:2264
type
int type
Definition: tcltklib.c:111
rb_define_dummy_encoding
int rb_define_dummy_encoding(const char *name)
Definition: encoding.c:400
tcltkip::orig_exit_info
Tcl_CmdInfo orig_exit_info
Definition: tcltklib.c:763
T_FIXNUM
#define T_FIXNUM
tcltkip::return_value
int return_value
Definition: tcltklib.c:766
argc
int argc
Definition: tcltklib.c:1970
eTkCallbackContinue
static VALUE eTkCallbackContinue
Definition: tcltklib.c:211
event_loop_abort_on_exc
static int event_loop_abort_on_exc
Definition: tcltklib.c:535
mainWin
Tk_Window mainWin
Definition: tcltklib.c:5887
eval_queue::interp
VALUE interp
Definition: tcltklib.c:420
rb_set_safe_level_force
void rb_set_safe_level_force(int)
Definition: safe.c:34
NO_TCL_DLL
#define NO_TCL_DLL
Definition: stubs.h:18
RbTk_ALLOC_N
#define RbTk_ALLOC_N(type, n)
Definition: tcltklib.c:47
eval_queue::ev
Tcl_Event ev
Definition: tcltklib.c:417
rb_obj_encoding
VALUE rb_obj_encoding(VALUE obj)
Definition: encoding.c:870
rb_attr_get
VALUE rb_attr_get(VALUE, ID)
Definition: variable.c:1122
ID_call
static ID ID_call
Definition: tcltklib.c:234
rb_ensure
VALUE rb_ensure(VALUE(*b_proc)(ANYARGS), VALUE data1, VALUE(*e_proc)(ANYARGS), VALUE data2)
Definition: eval.c:804
cmd
const char * cmd
Definition: tcltklib.c:278
FAIL_Tk_InitStubs
#define FAIL_Tk_InitStubs
Definition: stubs.h:33
DUMP2
#define DUMP2(ARG1, ARG2)
Definition: tcltklib.c:167
av
char ** av
Definition: tcltklib.c:8852
TCL_NAMESPACE_DEBUG
#define TCL_NAMESPACE_DEBUG
Definition: tcltklib.c:560
rb_thread_schedule
void rb_thread_schedule(void)
Definition: thread.c:1138
ID_inspect
static ID ID_inspect
Definition: tcltklib.c:244
EXTERN
#define EXTERN
Definition: defines.h:192
all_bs
int all_bs
Definition: tcltklib.c:8338
ruby_verbose
ruby_verbose
Definition: tcltklib.c:5818
rb_cString
RUBY_EXTERN VALUE rb_cString
Definition: ripper.y:1456
rb_jump_tag
void rb_jump_tag(int tag)
Definition: eval.c:666
t1
struct timeval t0 t1
Definition: tcltklib.c:2798
ptr
return ptr
Definition: tcltklib.c:784
free
#define free(x)
Definition: dln.c:50
evloop_params::interp
Tcl_Interp * interp
Definition: tcltklib.c:2555
c
VpDivd * c
Definition: bigdecimal.c:1205
ID_kill
static ID ID_kill
Definition: tcltklib.c:230
trap_check
static int trap_check(int *check_var)
Definition: tcltklib.c:2143
cmd_str
volatile VALUE cmd_str
Definition: tcltklib.c:5520
_
#define _(args)
Definition: dln.h:28
msg
volatile VALUE msg
Definition: tcltklib.c:3100
strtol
long strtol(const char *nptr, char **endptr, int base)
Definition: strtol.c:7
T_BIGNUM
#define T_BIGNUM
NO_FindExecutable
#define NO_FindExecutable
Definition: stubs.h:19
rb_set_end_proc
void rb_set_end_proc(void(*func)(VALUE), VALUE data)
Definition: eval_jump.c:60
MEMCPY
#define MEMCPY(p1, p2, type, n)
rb_define_module_under
VALUE rb_define_module_under(VALUE outer, const char *name)
Definition: class.c:637
TCL_CANCEL_UNWIND
#define TCL_CANCEL_UNWIND
Definition: tcltklib.c:7823
T_TRUE
#define T_TRUE
eTkLocalJumpError
static VALUE eTkLocalJumpError
Definition: tcltklib.c:215
rb_cFile
RUBY_EXTERN VALUE rb_cFile
Definition: ripper.y:1437
rb_thread_sleep_forever
void rb_thread_sleep_forever(void)
Definition: thread.c:1020
found_event
int found_event
Definition: tcltklib.c:2193
va_init_list
#define va_init_list(a, b)
Definition: tcltklib.c:61
rb_ivar_set
VALUE rb_ivar_set(VALUE, ID, VALUE)
Definition: variable.c:1128
rb_thread_wakeup
VALUE rb_thread_wakeup(VALUE)
Definition: thread.c:2220
no_event
VALUE no_event
Definition: tcltklib.c:1812
lib_evloop_abort_on_exc
return lib_evloop_abort_on_exc(self)
arg
arg
Definition: ripper.y:1315
src
VALUE src
Definition: tcltklib.c:7953
ENCODING_NAME_BINARY
static VALUE ENCODING_NAME_BINARY
Definition: tcltklib.c:195
T_SYMBOL
#define T_SYMBOL
ruby_tcl_create_ip_and_stubs_init
Tcl_Interp * ruby_tcl_create_ip_and_stubs_init(int *)
delete_slaves
delete_slaves(ip)
Tcl_QueueEvent
Tcl_QueueEvent((Tcl_Event *) callq, TCL_QUEUE_HEAD)
size
int size
Definition: encoding.c:52
NUM2LONG
#define NUM2LONG(x)
pending_exception_check0
static int pending_exception_check0()
Definition: tcltklib.c:1381
at_exit
static int at_exit
Definition: tcltklib.c:185
rb_thread_wait_for
void rb_thread_wait_for(struct timeval)
Definition: thread.c:1066
TRAP_CHECK
#define TRAP_CHECK()
Definition: tcltklib.c:2138
rb_obj_is_kind_of
VALUE rb_obj_is_kind_of(VALUE, VALUE)
Definition: object.c:582
rb_exc_new3
VALUE rb_exc_new3(VALUE etype, VALUE str)
Definition: error.c:548
list_ivar_enc
volatile VALUE list_ivar_enc
Definition: tcltklib.c:9720
eTkCallbackBreak
static VALUE eTkCallbackBreak
Definition: tcltklib.c:210
tcl_stubs_init_p
int tcl_stubs_init_p()
Definition: stubs.c:494
invoke_queue::done
int * done
Definition: tcltklib.c:410
rbtk_EventSetupProc
void rbtk_EventSetupProc(ClientData clientData, int flag)
Definition: tcltklib.c:1992
t
int t
Definition: ripper.c:14699
EVENT_HANDLER_TIMEOUT
#define EVENT_HANDLER_TIMEOUT
Definition: tcltklib.c:525
DUMP3
#define DUMP3(ARG1, ARG2, ARG3)
Definition: tcltklib.c:169
ip_eval_real
return ip_eval_real(q->interp, q->str, q->len)
ID_stop_p
static ID ID_stop_p
Definition: tcltklib.c:228
DATA_PTR
DATA_PTR(self)
rb_set_safe_level
void rb_set_safe_level(int)
Definition: safe.c:40
ruby_debug
ruby_debug
Definition: tcltklib.c:5817
flagPtr
int * flagPtr
Definition: tcltklib.c:9865
req_timer_tick
static int req_timer_tick
Definition: tcltklib.c:531
evloop_params::check_var
int * check_var
Definition: tcltklib.c:2554
clientData
static void ClientData clientData
Definition: tcltklib.c:1612
rb_cObject
RUBY_EXTERN VALUE rb_cObject
Definition: ripper.y:1426
ALLOC_N
#define ALLOC_N(type, n)
ID_at_enc
static ID ID_at_enc
Definition: tcltklib.c:222
NO_DeleteInterp
#define NO_DeleteInterp
Definition: stubs.h:26
set_no_event_wait
return set_no_event_wait(self, wait)
event_loop_wait_event
static int event_loop_wait_event
Definition: tcltklib.c:534
CONST84
#define CONST84
Definition: tcltklib.c:143
klass
klass
Definition: tcltklib.c:3504
INT2NUM
#define INT2NUM(x)
ENCODING_NAME_UTF8
static VALUE ENCODING_NAME_UTF8
Definition: tcltklib.c:194
Data_Get_Struct
#define Data_Get_Struct(obj, type, sval)
eTkCallbackReturn
static VALUE eTkCallbackReturn
Definition: tcltklib.c:209
rb_respond_to
int rb_respond_to(VALUE, ID)
Definition: vm_method.c:1564
taint_flag
int taint_flag
Definition: tcltklib.c:9717
set_eventloop_tick
return set_eventloop_tick(self, tick)
call_queue::argv
VALUE * argv
Definition: tcltklib.c:431
rb_notimplement
void rb_notimplement(void)
Definition: error.c:1826
rb_apply
VALUE rb_apply(VALUE, ID, VALUE)
Calls a method.
Definition: vm_eval.c:745
q_dat
volatile VALUE q_dat
Definition: tcltklib.c:7004
RSTRING_LENINT
#define RSTRING_LENINT(str)
endptr
char * endptr
Definition: tcltklib.c:3782
rb_ary_join
VALUE rb_ary_join(VALUE ary, VALUE sep)
Definition: array.c:1886
rb_eNotImpError
VALUE rb_eNotImpError
Definition: error.c:521
rb_enc_default_internal
VALUE rb_enc_default_internal(void)
Definition: encoding.c:1382
current_interp
Tcl_Interp * current_interp
Definition: tcltklib.c:480
rb_ary_new2
VALUE rb_ary_new2(long capa)
Definition: array.c:417
rb_verbose_bup
VALUE rb_verbose_bup
Definition: tcltklib.c:5689
rb_str_new
VALUE rb_str_new(const char *, long)
Definition: string.c:425
ip_obj
volatile VALUE ip_obj
Definition: tcltklib.c:7113
TAG_BREAK
#define TAG_BREAK
Definition: tcltklib.c:157
rb_safe_level
#define rb_safe_level()
Definition: tcltklib.c:94
th_vwait_param
Definition: tcltklib.c:4843
dstr
Tcl_DString dstr
Definition: tcltklib.c:3097
th_vwait_param::thread
VALUE thread
Definition: tcltklib.c:4844
DEFAULT_EVENT_LOOP_MAX
#define DEFAULT_EVENT_LOOP_MAX
Definition: tcltklib.c:517
lib_eventloop_launcher
return lib_eventloop_launcher(RTEST(check_rootwidget), 0,(int *) NULL,(Tcl_Interp *) NULL)
eTkCallbackThrow
static VALUE eTkCallbackThrow
Definition: tcltklib.c:218
NUM2INT
#define NUM2INT(x)
callq
VALUE callq
Definition: tcltklib.c:6986
rb_hash_new
VALUE rb_hash_new(void)
Definition: hash.c:234
objc
int objc
Definition: tcltklib.c:3887
rb_errinfo
#define rb_errinfo()
Definition: tcltklib.c:89
self
static struct tcltkip *VALUE self
Definition: tcltklib.c:769
CONST
#define CONST
Definition: tcltklib.c:142
rb_eFatal
VALUE rb_eFatal
Definition: error.c:508
alloc_done
int * alloc_done
Definition: tcltklib.c:7109
cnt
int cnt
Definition: tcltklib.c:6149
Tcl_GlobalEval
#define Tcl_GlobalEval
Definition: tcltklib.c:312
check_rootwidget_flag
static int check_rootwidget_flag
Definition: tcltklib.c:538
call_queue::func
VALUE(* func)()
Definition: tcltklib.c:429
ruby_native_thread_p
#define ruby_native_thread_p()
Definition: tcltklib.c:82
CONST86
#define CONST86
Definition: tcltklib.c:151
Tcl_Preserve
Tcl_Preserve(interp)
rb_global_variable
void rb_global_variable(VALUE *)
Definition: gc.c:426
Init_tcltklib
void Init_tcltklib()
Definition: tcltklib.c:10771
invoke_queue::thread
VALUE thread
Definition: tcltklib.c:413
TAG_REDO
#define TAG_REDO
Definition: tcltklib.c:160
TCL_OK
return TCL_OK
Definition: tcltklib.c:3999
tcltkip
Definition: tcltklib.c:754
opts
VALUE opts
Definition: tcltklib.c:6146
tcltkip::allow_ruby_exit
int allow_ruby_exit
Definition: tcltklib.c:765
VALUE
unsigned long VALUE
Definition: ripper.y:104
options
options
Definition: tcltklib.c:4481
event_loop_max
static int event_loop_max
Definition: tcltklib.c:527
rb_fix2str
VALUE rb_fix2str(VALUE, int)
Definition: numeric.c:2546
rb_warning
void rb_warning(const char *fmt,...)
Definition: error.c:229
TCLTKLIB_RELEASE_DATE
#define TCLTKLIB_RELEASE_DATE
Definition: tcltklib.c:7
rb_enc_find_index
int rb_enc_find_index(const char *name)
Definition: encoding.c:635
objv
char * objv[]
Definition: tcltklib.c:3888
NO_CreateInterp
#define NO_CreateInterp
Definition: stubs.h:25
rb_thread_create
VALUE rb_thread_create(VALUE(*)(ANYARGS), void *)
Definition: thread.c:722
tkwin
Tk_Window tkwin
Definition: tcltklib.c:5090
lib_fromUTF8_core
return lib_fromUTF8_core(Qnil, str, encodename)
_thread_call_proc_arg_mark
void _thread_call_proc_arg_mark(struct thread_call_proc_arg *q)
Definition: tcltklib.c:2911
major
int major
Definition: tcltklib.c:109
run_timer_flag
static int run_timer_flag
Definition: tcltklib.c:532
Tcl_GetCommandInfo
&& Tcl_GetCommandInfo(ip,"after",&info))
Definition: tcltklib.c:5805
divmod
VALUE divmod
Definition: tcltklib.c:1867
position
Tcl_QueuePosition position
Definition: tcltklib.c:7616
rb_define_module
VALUE rb_define_module(const char *name)
Definition: class.c:617
tcl_stubs_check
static void tcl_stubs_check()
Definition: tcltklib.c:1280
tcltk_version
static struct @84 tcltk_version
rb_intern
#define rb_intern(str)
ID_backtrace
static ID ID_backtrace
Definition: tcltklib.c:235
v
BDIGIT v
Definition: bigdecimal.c:5656
rb_cData
RUBY_EXTERN VALUE rb_cData
Definition: ripper.y:1433
CHECK_INTS
#define CHECK_INTS
Definition: rubysig.h:43
rb_eSystemExit
VALUE rb_eSystemExit
Definition: error.c:505
NULL
#define NULL
Definition: _sdbm.c:103
time
VALUE time
Definition: tcltklib.c:1866
q
q
Definition: tcltklib.c:2968
name
const char * name
Definition: nkf.c:208
invoke_queue::interp
VALUE interp
Definition: tcltklib.c:409
stubs.h
check_eventloop_interp
static int check_eventloop_interp()
Definition: tcltklib.c:2173
updateOptions
updateOptions
Definition: tcltklib.c:3895
ip_get_result_string_obj
return ip_get_result_string_obj(ptr->ip)
call_queue::safe_level
int safe_level
Definition: tcltklib.c:434
tk_stubs_init_p
int tk_stubs_init_p()
Definition: stubs.c:500
rb_define_method
void rb_define_method(VALUE klass, const char *name, VALUE(*func)(ANYARGS), int argc)
Definition: class.c:1344
retry
int retry
Definition: tcltklib.c:10151
ip_invoke_core
return ip_invoke_core(q->interp, q->argc, q->argv)
current
volatile VALUE current
Definition: tcltklib.c:7112
dst
char * dst
Definition: tcltklib.c:9868
rb_warn
void rb_warn(const char *fmt,...)
Definition: error.c:216
SYM2ID
#define SYM2ID(x)
tcl_time
Tcl_SetMaxBlockTime & tcl_time
Definition: tcltklib.c:1894
rb_eArgError
VALUE rb_eArgError
Definition: error.c:512
loop_counter
static int loop_counter
Definition: tcltklib.c:536
evPtr
static int Tcl_Event * evPtr
Definition: tcltklib.c:6999
TKWAIT_VISIBILITY
Definition: tcltklib.c:4481
no_ev
int no_ev
Definition: tcltklib.c:1815
TAG_NEXT
#define TAG_NEXT
Definition: tcltklib.c:158
lib_evloop_abort_on_exc_set
return lib_evloop_abort_on_exc_set(self, val)
st
Tcl_Interp *int * st
Definition: stubs.c:510
EVLOOP_WAKEUP_CHANCE
#define EVLOOP_WAKEUP_CHANCE
Definition: tcltklib.c:2788
ENCODING_INDEX_UTF8
static int ENCODING_INDEX_UTF8
Definition: tcltklib.c:191
rubysig.h
T_FALSE
#define T_FALSE
ID_return
static ID ID_return
Definition: tcltklib.c:239
dummy
int dummy
Definition: tcltklib.c:4483
invoke_queue::argv
char ** argv
Definition: tcltklib.c:407
ID_join
static ID ID_join
Definition: tcltklib.c:231
master
static VALUE VALUE master
Definition: tcltklib.c:6542
HAVE_NATIVETHREAD
#define HAVE_NATIVETHREAD
eval_queue
Definition: tcltklib.c:416
rb_gc_enable
VALUE rb_gc_enable(void)
Definition: gc.c:3261
rb_eException
VALUE rb_eException
Definition: error.c:504
DEFAULT_TIMER_TICK
#define DEFAULT_TIMER_TICK
Definition: tcltklib.c:521
rb_enc_from_index
rb_encoding * rb_enc_from_index(int index)
Definition: encoding.c:548
Tcl_CreateEventSource
Tcl_CreateEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc,(ClientData) args)
len
size_t len
Definition: tcltklib.c:3568