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