Ruby 2.1.5p273(2014-11-13revision48405)

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