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