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