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