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