diff options
Diffstat (limited to 'ext/tk/tcltklib.c')
| -rw-r--r-- | ext/tk/tcltklib.c | 6541 |
1 files changed, 6541 insertions, 0 deletions
diff --git a/ext/tk/tcltklib.c b/ext/tk/tcltklib.c new file mode 100644 index 0000000000..c9a72ed4bd --- /dev/null +++ b/ext/tk/tcltklib.c @@ -0,0 +1,6541 @@ +/* + * tcltklib.c + * Aug. 27, 1997 Y. Shigehiro + * Oct. 24, 1997 Y. Matsumoto + */ + +#define TCLTKLIB_RELEASE_DATE "2005-01-25" + +#include "ruby.h" +#include "rubysig.h" +#include "version.h" +#undef EXTERN /* avoid conflict with tcl.h of tcl8.2 or before */ +#include <stdio.h> +#ifdef HAVE_STDARG_PROTOTYPES +#include <stdarg.h> +#define va_init_list(a,b) va_start(a,b) +#else +#include <varargs.h> +#define va_init_list(a,b) va_start(a) +#endif +#include <string.h> +#include <tcl.h> +#include <tk.h> + +#ifdef __MACOS__ +# include <tkMac.h> +# include <Quickdraw.h> +#endif + +#if TCL_MAJOR_VERSION >= 8 +# ifndef CONST84 +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 4 /* Tcl8.0.x -- 8.4b1 */ +# define CONST84 +# else /* unknown (maybe TCL_VERSION >= 8.5) */ +# ifdef CONST +# define CONST84 CONST +# else +# define CONST84 +# endif +# endif +# endif +#else /* TCL_MAJOR_VERSION < 8 */ +# ifdef CONST +# define CONST84 CONST +# else +# define CONST +# define CONST84 +# endif +#endif + +/* copied from eval.c */ +#define TAG_RETURN 0x1 +#define TAG_BREAK 0x2 +#define TAG_NEXT 0x3 +#define TAG_RETRY 0x4 +#define TAG_REDO 0x5 +#define TAG_RAISE 0x6 +#define TAG_THROW 0x7 +#define TAG_FATAL 0x8 + +/* for ruby_debug */ +#define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1); fflush(stderr); } +#define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\ +fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); fflush(stderr); } +/* +#define DUMP1(ARG1) +#define DUMP2(ARG1, ARG2) +*/ + +/* release date */ +const char tcltklib_release_date[] = TCLTKLIB_RELEASE_DATE; + +/* finalize_proc_name */ +static char *finalize_hook_name = "INTERP_FINALIZE_HOOK"; + +/* to cancel remained after-scripts when deleting IP */ +#define CANCEL_AFTER_SCRIPTS "__ruby_tcltklib_cancel_after_scripts__" +#define DEF_CANCEL_AFTER_SCRIPTS_PROC "proc __ruby_tcltklib_cancel_after_scripts__ {} {foreach id [after info] {after cancel $id}}" + +/* for callback break & continue */ +static VALUE eTkCallbackReturn; +static VALUE eTkCallbackBreak; +static VALUE eTkCallbackContinue; + +static VALUE eLocalJumpError; + +static ID ID_at_enc; +static ID ID_at_interp; + +static ID ID_stop_p; +static ID ID_kill; +static ID ID_join; + +static ID ID_call; +static ID ID_backtrace; +static ID ID_message; + +static ID ID_at_reason; +static ID ID_return; +static ID ID_break; +static ID ID_next; + +static ID ID_to_s; +static ID ID_inspect; + +static VALUE ip_invoke_real _((int, VALUE*, VALUE)); +static VALUE ip_invoke _((int, VALUE*, VALUE)); + +/* from tkAppInit.c */ + +#if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 4) +# if !defined __MINGW32__ && !defined __BORLANDC__ +/* + * The following variable is a special hack that is needed in order for + * Sun shared libraries to be used for Tcl. + */ + +extern int matherr(); +int *tclDummyMathPtr = (int *) matherr; +# endif +#endif + +/*---- module TclTkLib ----*/ + +struct invoke_queue { + Tcl_Event ev; + int argc; +#if TCL_MAJOR_VERSION >= 8 + Tcl_Obj **argv; +#else /* TCL_MAJOR_VERSION < 8 */ + char **argv; +#endif + VALUE interp; + int *done; + int safe_level; + VALUE result; + VALUE thread; +}; + +struct eval_queue { + Tcl_Event ev; + char *str; + int len; + VALUE interp; + int *done; + int safe_level; + VALUE result; + VALUE thread; +}; + +void +invoke_queue_mark(struct invoke_queue *q) +{ + rb_gc_mark(q->interp); + rb_gc_mark(q->result); + rb_gc_mark(q->thread); +} + +void +eval_queue_mark(struct eval_queue *q) +{ + rb_gc_mark(q->interp); + rb_gc_mark(q->result); + rb_gc_mark(q->thread); +} + + +static VALUE eventloop_thread; +static VALUE watchdog_thread; +Tcl_Interp *current_interp; + +/* + * 'event_loop_max' is a maximum events which the eventloop processes in one + * term of thread scheduling. 'no_event_tick' is the count-up value when + * there are no event for processing. + * 'timer_tick' is a limit of one term of thread scheduling. + * If 'timer_tick' == 0, then not use the timer for thread scheduling. + */ +#define DEFAULT_EVENT_LOOP_MAX 800/*counts*/ +#define DEFAULT_NO_EVENT_TICK 10/*counts*/ +#define DEFAULT_NO_EVENT_WAIT 20/*milliseconds ( 1 -- 999 ) */ +#define WATCHDOG_INTERVAL 10/*milliseconds ( 1 -- 999 ) */ +#define DEFAULT_TIMER_TICK 0/*milliseconds ( 0 -- 999 ) */ +#define NO_THREAD_INTERRUPT_TIME 100/*milliseconds ( 1 -- 999 ) */ + +static int event_loop_max = DEFAULT_EVENT_LOOP_MAX; +static int no_event_tick = DEFAULT_NO_EVENT_TICK; +static int no_event_wait = DEFAULT_NO_EVENT_WAIT; +static int timer_tick = DEFAULT_TIMER_TICK; +static int req_timer_tick = DEFAULT_TIMER_TICK; +static int run_timer_flag = 0; + +static int event_loop_wait_event = 0; +static int event_loop_abort_on_exc = 1; +static int loop_counter = 0; + +static int check_rootwidget_flag = 0; + +#if TCL_MAJOR_VERSION >= 8 +static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*)); +static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*)); +#else /* TCL_MAJOR_VERSION < 8 */ +static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, char **)); +static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, char **)); +#endif + +static int ip_null_namespace _((Tcl_Interp *)); +#if TCL_MAJOR_VERSION >= 8 +#ifndef Tcl_GetCurrentNamespace +EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace _((Tcl_Interp *)); +#endif +#endif + + +/*---- class TclTkIp ----*/ +struct tcltkip { + Tcl_Interp *ip; /* the interpreter */ + int has_orig_exit; /* has original 'exit' command ? */ + Tcl_CmdInfo orig_exit_info; /* command info of original 'exit' command */ + int ref_count; /* reference count of rbtk_preserve_ip call */ + int allow_ruby_exit; /* allow exiting ruby by 'exit' function */ + int return_value; /* return value */ +}; + +static struct tcltkip * +get_ip(self) + VALUE self; +{ + struct tcltkip *ptr; + + Data_Get_Struct(self, struct tcltkip, ptr); + if (ptr == 0) { + rb_raise(rb_eTypeError, "uninitialized TclTkIp"); + } + return ptr; +} + +/* increment/decrement reference count of tcltkip */ +static int +rbtk_preserve_ip(ptr) + struct tcltkip *ptr; +{ + ptr->ref_count++; + Tcl_Preserve((ClientData)ptr->ip); + return(ptr->ref_count); +} + +static int +rbtk_release_ip(ptr) + struct tcltkip *ptr; +{ + ptr->ref_count--; + if (ptr->ref_count < 0) { + ptr->ref_count = 0; + } else { + Tcl_Release((ClientData)ptr->ip); + } + return(ptr->ref_count); +} + +/* call original 'exit' command */ +static void +call_original_exit(ptr, state) + struct tcltkip *ptr; + int state; +{ + int thr_crit_bup; + Tcl_CmdInfo *info; +#if TCL_MAJOR_VERSION >= 8 + Tcl_Obj *state_obj; +#endif + + if (!(ptr->has_orig_exit)) return; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + Tcl_ResetResult(ptr->ip); + + info = &(ptr->orig_exit_info); + + /* memory allocation for arguments of this command */ +#if TCL_MAJOR_VERSION >= 8 + state_obj = Tcl_NewIntObj(state); + Tcl_IncrRefCount(state_obj); + + if (info->isNativeObjectProc) { + Tcl_Obj **argv; + argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3); + argv[0] = Tcl_NewStringObj("exit", 4); + argv[1] = state_obj; + argv[2] = (Tcl_Obj *)NULL; + + ptr->return_value + = (*(info->objProc))(info->objClientData, ptr->ip, 2, argv); + + free(argv); + + } else { + /* string interface */ + char **argv; + argv = (char **)ALLOC_N(char *, 3); + argv[0] = "exit"; + argv[1] = Tcl_GetString(state_obj); + argv[2] = (char *)NULL; + + ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, + 2, (CONST84 char **)argv); + + free(argv); + } + + Tcl_DecrRefCount(state_obj); + +#else /* TCL_MAJOR_VERSION < 8 */ + { + /* string interface */ + char **argv; + argv = (char **)ALLOC_N(char *, 3); + argv[0] = "exit"; + argv[1] = RSTRING(rb_fix2str(INT2NUM(state), 10))->ptr; + argv[2] = (char *)NULL; + + ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, + 2, argv); + + free(argv); + } +#endif + + rb_thread_critical = thr_crit_bup; +} + +/* Tk_ThreadTimer */ +static Tcl_TimerToken timer_token = (Tcl_TimerToken)NULL; + +/* timer callback */ +static void _timer_for_tcl _((ClientData)); +static void +_timer_for_tcl(clientData) + ClientData clientData; +{ + int thr_crit_bup; + + /* struct invoke_queue *q, *tmp; */ + /* VALUE thread; */ + + DUMP1("called timer_for_tcl"); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + Tk_DeleteTimerHandler(timer_token); + + run_timer_flag = 1; + + if (timer_tick > 0) { + timer_token = Tk_CreateTimerHandler(timer_tick, _timer_for_tcl, + (ClientData)0); + } else { + timer_token = (Tcl_TimerToken)NULL; + } + + rb_thread_critical = thr_crit_bup; + + /* rb_thread_schedule(); */ + /* tick_counter += event_loop_max; */ +} + +static VALUE +set_eventloop_tick(self, tick) + VALUE self; + VALUE tick; +{ + int ttick = NUM2INT(tick); + int thr_crit_bup; + + rb_secure(4); + + if (ttick < 0) { + rb_raise(rb_eArgError, + "timer-tick parameter must be 0 or positive number"); + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* delete old timer callback */ + Tk_DeleteTimerHandler(timer_token); + + timer_tick = req_timer_tick = ttick; + if (timer_tick > 0) { + /* start timer callback */ + timer_token = Tk_CreateTimerHandler(timer_tick, _timer_for_tcl, + (ClientData)0); + } else { + timer_token = (Tcl_TimerToken)NULL; + } + + rb_thread_critical = thr_crit_bup; + + return tick; +} + +static VALUE +get_eventloop_tick(self) + VALUE self; +{ + return INT2NUM(timer_tick); +} + +static VALUE +ip_set_eventloop_tick(self, tick) + VALUE self; + VALUE tick; +{ + struct tcltkip *ptr = get_ip(self); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + return get_eventloop_tick(self); + } + + if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { + /* slave IP */ + return get_eventloop_tick(self); + } + return set_eventloop_tick(self, tick); +} + +static VALUE +ip_get_eventloop_tick(self) + VALUE self; +{ + return get_eventloop_tick(self); +} + +static VALUE +set_no_event_wait(self, wait) + VALUE self; + VALUE wait; +{ + int t_wait = NUM2INT(wait); + + rb_secure(4); + + if (t_wait <= 0) { + rb_raise(rb_eArgError, + "no_event_wait parameter must be positive number"); + } + + no_event_wait = t_wait; + + return wait; +} + +static VALUE +get_no_event_wait(self) + VALUE self; +{ + return INT2NUM(no_event_wait); +} + +static VALUE +ip_set_no_event_wait(self, wait) + VALUE self; + VALUE wait; +{ + struct tcltkip *ptr = get_ip(self); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + return get_no_event_wait(self); + } + + if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { + /* slave IP */ + return get_no_event_wait(self); + } + return set_no_event_wait(self, wait); +} + +static VALUE +ip_get_no_event_wait(self) + VALUE self; +{ + return get_no_event_wait(self); +} + +static VALUE +set_eventloop_weight(self, loop_max, no_event) + VALUE self; + VALUE loop_max; + VALUE no_event; +{ + int lpmax = NUM2INT(loop_max); + int no_ev = NUM2INT(no_event); + + rb_secure(4); + + if (lpmax <= 0 || no_ev <= 0) { + rb_raise(rb_eArgError, "weight parameters must be positive numbers"); + } + + event_loop_max = lpmax; + no_event_tick = no_ev; + + return rb_ary_new3(2, loop_max, no_event); +} + +static VALUE +get_eventloop_weight(self) + VALUE self; +{ + return rb_ary_new3(2, INT2NUM(event_loop_max), INT2NUM(no_event_tick)); +} + +static VALUE +ip_set_eventloop_weight(self, loop_max, no_event) + VALUE self; + VALUE loop_max; + VALUE no_event; +{ + struct tcltkip *ptr = get_ip(self); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + return get_eventloop_weight(self); + } + + if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { + /* slave IP */ + return get_eventloop_weight(self); + } + return set_eventloop_weight(self, loop_max, no_event); +} + +static VALUE +ip_get_eventloop_weight(self) + VALUE self; +{ + return get_eventloop_weight(self); +} + +static VALUE +set_max_block_time(self, time) + VALUE self; + VALUE time; +{ + struct Tcl_Time tcl_time; + VALUE divmod; + + switch(TYPE(time)) { + case T_FIXNUM: + case T_BIGNUM: + /* time is micro-second value */ + divmod = rb_funcall(time, rb_intern("divmod"), 1, LONG2NUM(1000000)); + tcl_time.sec = NUM2LONG(RARRAY(divmod)->ptr[0]); + tcl_time.usec = NUM2LONG(RARRAY(divmod)->ptr[1]); + break; + + case T_FLOAT: + /* time is second value */ + divmod = rb_funcall(time, rb_intern("divmod"), 1, INT2FIX(1)); + tcl_time.sec = NUM2LONG(RARRAY(divmod)->ptr[0]); + tcl_time.usec = (long)(NUM2DBL(RARRAY(divmod)->ptr[1]) * 1000000); + + default: + rb_raise(rb_eArgError, "invalid value for time: '%s'", + RSTRING(rb_funcall(time, ID_inspect, 0, 0))->ptr); + } + + Tcl_SetMaxBlockTime(&tcl_time); + + return Qnil; +} + +static VALUE +lib_evloop_abort_on_exc(self) + VALUE self; +{ + if (event_loop_abort_on_exc > 0) { + return Qtrue; + } else if (event_loop_abort_on_exc == 0) { + return Qfalse; + } else { + return Qnil; + } +} + +static VALUE +ip_evloop_abort_on_exc(self) + VALUE self; +{ + return lib_evloop_abort_on_exc(self); +} + +static VALUE +lib_evloop_abort_on_exc_set(self, val) + VALUE self, val; +{ + rb_secure(4); + if (RTEST(val)) { + event_loop_abort_on_exc = 1; + } else if (NIL_P(val)) { + event_loop_abort_on_exc = -1; + } else { + event_loop_abort_on_exc = 0; + } + return lib_evloop_abort_on_exc(self); +} + +static VALUE +ip_evloop_abort_on_exc_set(self, val) + VALUE self, val; +{ + struct tcltkip *ptr = get_ip(self); + + rb_secure(4); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + return lib_evloop_abort_on_exc(self); + } + + if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { + /* slave IP */ + return lib_evloop_abort_on_exc(self); + } + return lib_evloop_abort_on_exc_set(self, val); +} + +static VALUE +lib_num_of_mainwindows(self) + VALUE self; +{ + return INT2FIX(Tk_GetNumMainWindows()); +} + +static int +lib_eventloop_core(check_root, update_flag, check_var) + int check_root; + int update_flag; + int *check_var; +{ + volatile VALUE current = eventloop_thread; + int found_event = 1; + int event_flag; + struct timeval t; + int thr_crit_bup; + + + if (update_flag) DUMP1("update loop start!!"); + + t.tv_sec = (time_t)0; + t.tv_usec = (time_t)(no_event_wait*1000.0); + + Tk_DeleteTimerHandler(timer_token); + run_timer_flag = 0; + if (timer_tick > 0) { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + timer_token = Tk_CreateTimerHandler(timer_tick, _timer_for_tcl, + (ClientData)0); + rb_thread_critical = thr_crit_bup; + } else { + timer_token = (Tcl_TimerToken)NULL; + } + + for(;;) { + if (rb_thread_alone()) { + DUMP1("no other thread"); + event_loop_wait_event = 0; + + if (update_flag) { + event_flag = update_flag | TCL_DONT_WAIT; /* for safety */ + } else { + event_flag = TCL_ALL_EVENTS; + } + + if (timer_tick == 0 && update_flag == 0) { + timer_tick = NO_THREAD_INTERRUPT_TIME; + timer_token = Tk_CreateTimerHandler(timer_tick, + _timer_for_tcl, + (ClientData)0); + } + + if (check_var != (int *)NULL) { + if (*check_var || !found_event) { + return found_event; + } + } + + found_event = Tcl_DoOneEvent(event_flag); + + if (update_flag != 0) { + if (found_event) { + DUMP1("next update loop"); + continue; + } else { + DUMP1("update complete"); + return 0; + } + } + + DUMP1("check Root Widget"); + if (check_root && Tk_GetNumMainWindows() == 0) { + run_timer_flag = 0; + if (!rb_prohibit_interrupt) { + if (rb_trap_pending) rb_trap_exec(); + } + return 1; + } + + if (loop_counter++ > 30000) { + /* fprintf(stderr, "loop_counter > 30000\n"); */ + loop_counter = 0; + } + + } else { + int tick_counter; + + DUMP1("there are other threads"); + event_loop_wait_event = 1; + + found_event = 1; + + if (update_flag) { + event_flag = update_flag | TCL_DONT_WAIT; /* for safety */ + } else { + event_flag = TCL_ALL_EVENTS | TCL_DONT_WAIT; + } + + timer_tick = req_timer_tick; + tick_counter = 0; + while(tick_counter < event_loop_max) { + if (check_var != (int *)NULL) { + if (*check_var || !found_event) { + return found_event; + } + } + + if (Tcl_DoOneEvent(event_flag)) { + tick_counter++; + } else { + if (update_flag != 0) { + DUMP1("update complete"); + return 0; + } + tick_counter += no_event_tick; + rb_thread_wait_for(t); + } + + if (watchdog_thread != 0 && eventloop_thread != current) { + return 1; + } + + DUMP1("check Root Widget"); + if (check_root && Tk_GetNumMainWindows() == 0) { + run_timer_flag = 0; + if (!rb_prohibit_interrupt) { + if (rb_trap_pending) rb_trap_exec(); + } + return 1; + } + + DUMP1("trap check"); + if (!rb_prohibit_interrupt) { + if (rb_trap_pending) rb_trap_exec(); + } + + if (loop_counter++ > 30000) { + /* fprintf(stderr, "loop_counter > 30000\n"); */ + loop_counter = 0; + } + + if (run_timer_flag) { + /* + DUMP1("timer interrupt"); + run_timer_flag = 0; + */ + break; /* switch to other thread */ + } + } + } + + DUMP1("trap check & thread scheduling"); + if (update_flag == 0) CHECK_INTS; + + } + return 1; +} + +VALUE +lib_eventloop_main(check_rootwidget) + VALUE check_rootwidget; +{ + check_rootwidget_flag = RTEST(check_rootwidget); + + if (lib_eventloop_core(check_rootwidget_flag, 0, (int *)NULL)) { + return Qtrue; + } else { + return Qfalse; + } +} + +VALUE +lib_eventloop_ensure(parent_evloop) + VALUE parent_evloop; +{ + Tk_DeleteTimerHandler(timer_token); + timer_token = (Tcl_TimerToken)NULL; + DUMP2("eventloop-ensure: current-thread : %lx\n", rb_thread_current()); + DUMP2("eventloop-ensure: eventloop-thread : %lx\n", eventloop_thread); + if (eventloop_thread == rb_thread_current()) { + DUMP2("eventloop-thread -> %lx\n", parent_evloop); + eventloop_thread = parent_evloop; + } + return Qnil; +} + +static VALUE +lib_eventloop_launcher(check_rootwidget) + VALUE check_rootwidget; +{ + VALUE parent_evloop = eventloop_thread; + + eventloop_thread = rb_thread_current(); + + if (ruby_debug) { + fprintf(stderr, "tcltklib: eventloop-thread : %lx -> %lx\n", + parent_evloop, eventloop_thread); + } + + return rb_ensure(lib_eventloop_main, check_rootwidget, + lib_eventloop_ensure, parent_evloop); +} + +/* execute Tk_MainLoop */ +static VALUE +lib_mainloop(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + VALUE check_rootwidget; + + if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) { + check_rootwidget = Qtrue; + } else if (RTEST(check_rootwidget)) { + check_rootwidget = Qtrue; + } else { + check_rootwidget = Qfalse; + } + + return lib_eventloop_launcher(check_rootwidget); +} + +static VALUE +ip_mainloop(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + struct tcltkip *ptr = get_ip(self); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + return Qnil; + } + + if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { + /* slave IP */ + return Qnil; + } + return lib_mainloop(argc, argv, self); +} + +VALUE +lib_watchdog_core(check_rootwidget) + VALUE check_rootwidget; +{ + VALUE evloop; + int prev_val = -1; + int chance = 0; + int check = RTEST(check_rootwidget); + struct timeval t0, t1; + + t0.tv_sec = (time_t)0; + t0.tv_usec = (time_t)((NO_THREAD_INTERRUPT_TIME)*1000.0); + t1.tv_sec = (time_t)0; + t1.tv_usec = (time_t)((WATCHDOG_INTERVAL)*1000.0); + + /* check other watchdog thread */ + if (watchdog_thread != 0) { + if (RTEST(rb_funcall(watchdog_thread, ID_stop_p, 0))) { + rb_funcall(watchdog_thread, ID_kill, 0); + } else { + return Qnil; + } + } + watchdog_thread = rb_thread_current(); + + /* watchdog start */ + do { + if (eventloop_thread == 0 + || (loop_counter == prev_val + && RTEST(rb_funcall(eventloop_thread, ID_stop_p, 0)) + && ++chance >= 3 ) + ) { + /* start new eventloop thread */ + DUMP2("eventloop thread %lx is sleeping or dead", + eventloop_thread); + evloop = rb_thread_create(lib_eventloop_launcher, + (void*)&check_rootwidget); + DUMP2("create new eventloop thread %lx", evloop); + loop_counter = -1; + chance = 0; + rb_thread_run(evloop); + } else { + loop_counter = prev_val; + chance = 0; + if (event_loop_wait_event) { + rb_thread_wait_for(t0); + } else { + rb_thread_wait_for(t1); + } + /* rb_thread_schedule(); */ + } + } while(!check || Tk_GetNumMainWindows() != 0); + + return Qnil; +} + +VALUE +lib_watchdog_ensure(arg) + VALUE arg; +{ + eventloop_thread = 0; /* stop eventloops */ + return Qnil; +} + +static VALUE +lib_mainloop_watchdog(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + VALUE check_rootwidget; + + if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) { + check_rootwidget = Qtrue; + } else if (RTEST(check_rootwidget)) { + check_rootwidget = Qtrue; + } else { + check_rootwidget = Qfalse; + } + + return rb_ensure(lib_watchdog_core, check_rootwidget, + lib_watchdog_ensure, Qnil); +} + +static VALUE +ip_mainloop_watchdog(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + struct tcltkip *ptr = get_ip(self); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + return Qnil; + } + + if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { + /* slave IP */ + return Qnil; + } + return lib_mainloop_watchdog(argc, argv, self); +} + +static VALUE +lib_do_one_event_core(argc, argv, self, is_ip) + int argc; + VALUE *argv; + VALUE self; + int is_ip; +{ + volatile VALUE vflags; + int flags; + int found_event; + + if (rb_scan_args(argc, argv, "01", &vflags) == 0) { + flags = TCL_ALL_EVENTS | TCL_DONT_WAIT; + } else { + Check_Type(vflags, T_FIXNUM); + flags = FIX2INT(vflags); + } + + if (rb_safe_level() >= 4 || (rb_safe_level() >=1 && OBJ_TAINTED(vflags))) { + flags |= TCL_DONT_WAIT; + } + + if (is_ip) { + /* check IP */ + struct tcltkip *ptr = get_ip(self); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + return Qfalse; + } + + if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { + /* slave IP */ + flags |= TCL_DONT_WAIT; + } + } + + /* found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); */ + found_event = Tcl_DoOneEvent(flags); + + if (found_event) { + return Qtrue; + } else { + return Qfalse; + } +} + +static VALUE +lib_do_one_event(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + return lib_do_one_event_core(argc, argv, self, 0); +} + +static VALUE +ip_do_one_event(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + return lib_do_one_event_core(argc, argv, self, 0); +} + + +static void +ip_set_exc_message(interp, exc) + Tcl_Interp *interp; + VALUE exc; +{ + char *buf; + Tcl_DString dstr; + volatile VALUE msg; + int thr_crit_bup; + +#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) + volatile VALUE enc; + Tcl_Encoding encoding; +#endif + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + msg = rb_funcall(exc, ID_message, 0, 0); + +#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) + enc = Qnil; + if (RTEST(rb_ivar_defined(exc, ID_at_enc))) { + enc = rb_ivar_get(exc, ID_at_enc); + } + if (NIL_P(enc) && RTEST(rb_ivar_defined(msg, ID_at_enc))) { + enc = rb_ivar_get(msg, ID_at_enc); + } + if (NIL_P(enc)) { + encoding = (Tcl_Encoding)NULL; + } else if (TYPE(enc) == T_STRING) { + encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr); + } else { + enc = rb_funcall(enc, ID_to_s, 0, 0); + encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr); + } + + /* to avoid a garbled error message dialog */ + buf = ALLOC_N(char, (RSTRING(msg)->len)+1); + strncpy(buf, RSTRING(msg)->ptr, RSTRING(msg)->len); + buf[RSTRING(msg)->len] = 0; + + Tcl_DStringInit(&dstr); + Tcl_DStringFree(&dstr); + Tcl_ExternalToUtfDString(encoding, buf, RSTRING(msg)->len, &dstr); + + Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL); + DUMP2("error message:%s", Tcl_DStringValue(&dstr)); + free(buf); + +#else /* TCL_VERSION <= 8.0 */ + Tcl_AppendResult(interp, RSTRING(msg)->ptr, (char*)NULL); +#endif + + rb_thread_critical = thr_crit_bup; +} + +static VALUE +TkStringValue(obj) + VALUE obj; +{ + switch(TYPE(obj)) { + case T_STRING: + return obj; + + case T_NIL: + return rb_str_new2(""); + + case T_TRUE: + return rb_str_new2("1"); + + case T_FALSE: + return rb_str_new2("0"); + + case T_ARRAY: + return rb_funcall(obj, ID_join, 1, rb_str_new2(" ")); + + default: + if (rb_respond_to(obj, ID_to_s)) { + return rb_funcall(obj, ID_to_s, 0, 0); + } + } + + return rb_funcall(obj, ID_inspect, 0, 0); +} + +/* Tcl command `ruby'|`ruby_eval' */ +static VALUE +ip_ruby_eval_rescue(failed, einfo) + VALUE failed; + VALUE einfo; +{ + DUMP1("call ip_ruby_eval_rescue"); + RARRAY(failed)->ptr[0] = einfo; + return Qnil; +} + +struct eval_body_arg { + char *string; + VALUE failed; +}; + +static VALUE +ip_ruby_eval_body(arg) + struct eval_body_arg *arg; +{ + volatile VALUE ret; + int status = 0; + int thr_crit_bup; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + DUMP1("call ip_ruby_eval_body"); + rb_trap_immediate = 0; + +#if 0 + ret = rb_rescue2(rb_eval_string, (VALUE)arg->string, + ip_ruby_eval_rescue, arg->failed, + rb_eStandardError, rb_eScriptError, rb_eSystemExit, + (VALUE)0); +#else + + rb_thread_critical = Qfalse; + ret = rb_eval_string_protect(arg->string, &status); + rb_thread_critical = Qtrue; + if (status) { + char *errtype, *buf; + int errtype_len, len; + VALUE old_gc; + + old_gc = rb_gc_disable(); + + switch(status) { + case TAG_RETURN: + errtype = "LocalJumpError: "; + errtype_len = strlen(errtype); + len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len; + buf = ALLOC_N(char, len + 1); + strncpy(buf, errtype, errtype_len); + strncpy(buf + errtype_len, + RSTRING(rb_obj_as_string(ruby_errinfo))->ptr, + RSTRING(rb_obj_as_string(ruby_errinfo))->len); + *(buf + len) = 0; + + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackReturn, buf); + free(buf); + break; + + case TAG_BREAK: + errtype = "LocalJumpError: "; + errtype_len = strlen(errtype); + len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len; + buf = ALLOC_N(char, len + 1); + strncpy(buf, errtype, errtype_len); + strncpy(buf + errtype_len, + RSTRING(rb_obj_as_string(ruby_errinfo))->ptr, + RSTRING(rb_obj_as_string(ruby_errinfo))->len); + *(buf + len) = 0; + + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackBreak, buf); + free(buf); + break; + + case TAG_NEXT: + errtype = "LocalJumpError: "; + errtype_len = strlen(errtype); + len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len; + buf = ALLOC_N(char, len + 1); + strncpy(buf, errtype, errtype_len); + strncpy(buf + errtype_len, + RSTRING(rb_obj_as_string(ruby_errinfo))->ptr, + RSTRING(rb_obj_as_string(ruby_errinfo))->len); + *(buf + len) = 0; + + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackContinue,buf); + free(buf); + break; + + case TAG_RETRY: + case TAG_REDO: + if (NIL_P(ruby_errinfo)) { + rb_jump_tag(status); + } else { + RARRAY(arg->failed)->ptr[0] = ruby_errinfo; + } + break; + + case TAG_RAISE: + case TAG_FATAL: + if (NIL_P(ruby_errinfo)) { + RARRAY(arg->failed)->ptr[0] + = rb_exc_new2(rb_eException, "unknown exception"); + } else { + RARRAY(arg->failed)->ptr[0] = ruby_errinfo; + } + break; + + case TAG_THROW: + if (NIL_P(ruby_errinfo)) { + rb_jump_tag(TAG_THROW); + } else { + RARRAY(arg->failed)->ptr[0] = ruby_errinfo; + } + break; + + default: + buf = ALLOC_N(char, 256); + sprintf(buf, "unknown loncaljmp status %d", status); + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(rb_eException, buf); + free(buf); + break; + } + + if (old_gc == Qfalse) rb_gc_enable(); + + ret = Qnil; + } +#endif + + rb_thread_critical = thr_crit_bup; + + return ret; +} + +static VALUE +ip_ruby_eval_ensure(trapflag) + VALUE trapflag; +{ + rb_trap_immediate = NUM2INT(trapflag); + return Qnil; +} + + +static int +#if TCL_MAJOR_VERSION >= 8 +ip_ruby_eval(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + Tcl_Obj *CONST argv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +ip_ruby_eval(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + char *argv[]; +#endif +{ + volatile VALUE res; + volatile VALUE exception = rb_ary_new2(1); + int old_trapflag; + struct eval_body_arg *arg; + int thr_crit_bup; + + /* ruby command has 1 arg. */ + if (argc != 2) { + rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)", + argc - 1); + } + + /* allocate */ + arg = ALLOC(struct eval_body_arg); + + /* get C string from Tcl object */ +#if TCL_MAJOR_VERSION >= 8 + { + char *str; + int len; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + str = Tcl_GetStringFromObj(argv[1], &len); + arg->string = ALLOC_N(char, len + 1); + strncpy(arg->string, str, len); + arg->string[len] = 0; + + rb_thread_critical = thr_crit_bup; + + } +#else /* TCL_MAJOR_VERSION < 8 */ + arg->string = argv[1]; +#endif + /* arg.failed = 0; */ + RARRAY(exception)->ptr[0] = Qnil; + RARRAY(exception)->len = 1; + arg->failed = exception; + + /* evaluate the argument string by ruby */ + DUMP2("rb_eval_string(%s)", arg->string); + old_trapflag = rb_trap_immediate; +#ifdef HAVE_NATIVETHREAD + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on ip_ruby_eval()"); + } +#endif + res = rb_ensure(ip_ruby_eval_body, (VALUE)arg, + ip_ruby_eval_ensure, INT2FIX(old_trapflag)); + +#if TCL_MAJOR_VERSION >= 8 + free(arg->string); +#endif + + free(arg); + + /* status check */ + /* if (arg.failed) { */ + if (!NIL_P(RARRAY(exception)->ptr[0])) { + VALUE eclass; + volatile VALUE bt_ary; + volatile VALUE backtrace; + + DUMP1("(rb_eval_string result) failed"); + + Tcl_ResetResult(interp); + + res = RARRAY(exception)->ptr[0]; + eclass = rb_obj_class(res); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + DUMP1("set backtrace"); + if (!NIL_P(bt_ary = rb_funcall(res, ID_backtrace, 0, 0))) { + backtrace = rb_ary_join(bt_ary, rb_str_new2("\n")); + StringValue(backtrace); + Tcl_AddErrorInfo(interp, RSTRING(backtrace)->ptr); + } + + rb_thread_critical = thr_crit_bup; + + if (eclass == eTkCallbackReturn) { + ip_set_exc_message(interp, res); + return TCL_RETURN; + + } else if (eclass == eTkCallbackBreak) { + ip_set_exc_message(interp, res); + return TCL_BREAK; + + } else if (eclass == eTkCallbackContinue) { + ip_set_exc_message(interp, res); + return TCL_CONTINUE; + + } else if (eclass == rb_eSystemExit) { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* Tcl_Eval(interp, "destroy ."); */ + if (Tk_GetNumMainWindows() > 0) { + Tk_Window main_win = Tk_MainWindow(interp); + if (main_win != (Tk_Window)NULL) { + Tk_DestroyWindow(main_win); + } + } + + /* StringValue(res); */ + res = rb_funcall(res, ID_message, 0, 0); + + Tcl_AppendResult(interp, RSTRING(res)->ptr, (char*)NULL); + + rb_thread_critical = thr_crit_bup; + + rb_raise(rb_eSystemExit, RSTRING(res)->ptr); + + } else if (rb_obj_is_kind_of(res, eLocalJumpError)) { + VALUE reason = rb_ivar_get(res, ID_at_reason); + + if (TYPE(reason) != T_SYMBOL) { + ip_set_exc_message(interp, res); + return TCL_ERROR; + } + + if (SYM2ID(reason) == ID_return) { + ip_set_exc_message(interp, res); + return TCL_RETURN; + + } else if (SYM2ID(reason) == ID_break) { + ip_set_exc_message(interp, res); + return TCL_BREAK; + + } else if (SYM2ID(reason) == ID_next) { + ip_set_exc_message(interp, res); + return TCL_CONTINUE; + + } else { + ip_set_exc_message(interp, res); + return TCL_ERROR; + } + } else { + ip_set_exc_message(interp, res); + return TCL_ERROR; + } + } + + /* result must be string or nil */ + if (NIL_P(res)) { + DUMP1("(rb_eval_string result) nil"); + Tcl_ResetResult(interp); + return TCL_OK; + } + + /* copy result to the tcl interpreter */ + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + res = TkStringValue(res); + DUMP2("(rb_eval_string result) %s", RSTRING(res)->ptr); + DUMP1("Tcl_AppendResult"); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, RSTRING(res)->ptr, (char *)NULL); + + rb_thread_critical = thr_crit_bup; + + return TCL_OK; +} + + +/* Tcl command `ruby_cmd' */ +struct cmd_body_arg { + VALUE receiver; + ID method; + VALUE args; + VALUE failed; +}; + +static VALUE +ip_ruby_cmd_core(arg) + struct cmd_body_arg *arg; +{ + volatile VALUE ret; + int thr_crit_bup; + + DUMP1("call ip_ruby_cmd_core"); + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qfalse; + ret = rb_apply(arg->receiver, arg->method, arg->args); + rb_thread_critical = thr_crit_bup; + DUMP1("finish ip_ruby_cmd_core"); + + return ret; +} + +static VALUE +ip_ruby_cmd_rescue(failed, einfo) + VALUE failed; + VALUE einfo; +{ + DUMP1("call ip_ruby_cmd_rescue"); + RARRAY(failed)->ptr[0] = einfo; + return Qnil; +} + +static VALUE +ip_ruby_cmd_body(arg) + struct cmd_body_arg *arg; +{ + volatile VALUE ret; + int status = 0; + int thr_crit_bup; + VALUE old_gc; + + volatile VALUE receiver = arg->receiver; + volatile VALUE args = arg->args; + volatile VALUE failed = arg->failed; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + DUMP1("call ip_ruby_cmd_body"); + rb_trap_immediate = 0; + +#if 0 + ret = rb_rescue2(ip_ruby_cmd_core, (VALUE)arg, + ip_ruby_cmd_rescue, arg->failed, + rb_eStandardError, rb_eScriptError, rb_eSystemExit, + (VALUE)0); +#else + ret = rb_protect(ip_ruby_cmd_core, (VALUE)arg, &status); + + if (status) { + char *errtype, *buf; + int errtype_len, len; + + old_gc = rb_gc_disable(); + + switch(status) { + case TAG_RETURN: + errtype = "LocalJumpError: "; + errtype_len = strlen(errtype); + len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len; + buf = ALLOC_N(char, len + 1); + strncpy(buf, errtype, errtype_len); + strncpy(buf + errtype_len, + RSTRING(rb_obj_as_string(ruby_errinfo))->ptr, + RSTRING(rb_obj_as_string(ruby_errinfo))->len); + *(buf + len) = 0; + + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackReturn, buf); + free(buf); + break; + + case TAG_BREAK: + errtype = "LocalJumpError: "; + errtype_len = strlen(errtype); + len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len; + buf = ALLOC_N(char, len + 1); + strncpy(buf, errtype, errtype_len); + strncpy(buf + errtype_len, + RSTRING(rb_obj_as_string(ruby_errinfo))->ptr, + RSTRING(rb_obj_as_string(ruby_errinfo))->len); + *(buf + len) = 0; + + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackBreak, buf); + free(buf); + break; + + case TAG_NEXT: + errtype = "LocalJumpError: "; + errtype_len = strlen(errtype); + len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len; + buf = ALLOC_N(char, len + 1); + strncpy(buf, errtype, errtype_len); + strncpy(buf + errtype_len, + RSTRING(rb_obj_as_string(ruby_errinfo))->ptr, + RSTRING(rb_obj_as_string(ruby_errinfo))->len); + *(buf + len) = 0; + + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackContinue,buf); + free(buf); + break; + + case TAG_RETRY: + case TAG_REDO: + if (NIL_P(ruby_errinfo)) { + rb_jump_tag(status); + } else { + RARRAY(arg->failed)->ptr[0] = ruby_errinfo; + } + break; + + case TAG_RAISE: + case TAG_FATAL: + if (NIL_P(ruby_errinfo)) { + RARRAY(arg->failed)->ptr[0] + = rb_exc_new2(rb_eException, "unknown exception"); + } else { + RARRAY(arg->failed)->ptr[0] = ruby_errinfo; + } + break; + + case TAG_THROW: + if (NIL_P(ruby_errinfo)) { + rb_jump_tag(TAG_THROW); + } else { + RARRAY(arg->failed)->ptr[0] = ruby_errinfo; + } + break; + + default: + buf = ALLOC_N(char, 256); + rb_warn(buf, "unknown loncaljmp status %d", status); + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(rb_eException, buf); + free(buf); + break; + } + + if (old_gc == Qfalse) rb_gc_enable(); + + ret = Qnil; + } +#endif + + rb_thread_critical = thr_crit_bup; + DUMP1("finish ip_ruby_cmd_body"); + + return ret; +} + +static VALUE +ip_ruby_cmd_ensure(trapflag) + VALUE trapflag; +{ + rb_trap_immediate = NUM2INT(trapflag); + return Qnil; +} + +/* ruby_cmd receiver method arg ... */ +static int +#if TCL_MAJOR_VERSION >= 8 +ip_ruby_cmd(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + Tcl_Obj *CONST argv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +ip_ruby_cmd(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + char *argv[]; +#endif +{ + volatile VALUE res; + volatile VALUE receiver; + volatile ID method; + volatile VALUE args = rb_ary_new2(argc - 2); + volatile VALUE exception = rb_ary_new2(1); + char *str; + int i; + int len; + int old_trapflag; + struct cmd_body_arg *arg; + int thr_crit_bup; + VALUE old_gc; + + if (argc < 3) { + rb_raise(rb_eArgError, "too few arguments"); + } + + /* allocate */ + arg = ALLOC(struct cmd_body_arg); + + /* get arguments from Tcl objects */ + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + old_gc = rb_gc_disable(); + + /* get receiver */ +#if TCL_MAJOR_VERSION >= 8 + str = Tcl_GetStringFromObj(argv[1], &len); +#else /* TCL_MAJOR_VERSION < 8 */ + str = argv[1]; +#endif + DUMP2("receiver:%s",str); + if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) { + /* class | module | constant */ + receiver = rb_const_get(rb_cObject, rb_intern(str)); + } else if (str[0] == '$') { + /* global variable */ + receiver = rb_gv_get(str); + } else { + /* global variable omitted '$' */ + char *buf; + + len = strlen(str); + buf = ALLOC_N(char, len + 2); + buf[0] = '$'; + strncpy(buf + 1, str, len); + buf[len + 1] = 0; + receiver = rb_gv_get(buf); + free(buf); + } + if (NIL_P(receiver)) { + rb_raise(rb_eArgError, "unknown class/module/global-variable '%s'", + str); + } + + /* get metrhod */ +#if TCL_MAJOR_VERSION >= 8 + str = Tcl_GetStringFromObj(argv[2], &len); +#else /* TCL_MAJOR_VERSION < 8 */ + str = argv[2]; +#endif + method = rb_intern(str); + + /* get args */ + RARRAY(args)->len = 0; + for(i = 3; i < argc; i++) { +#if TCL_MAJOR_VERSION >= 8 + str = Tcl_GetStringFromObj(argv[i], &len); + DUMP2("arg:%s",str); + RARRAY(args)->ptr[RARRAY(args)->len++] = rb_tainted_str_new(str, len); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP2("arg:%s",argv[i]); + RARRAY(args)->ptr[RARRAY(args)->len++] = rb_tainted_str_new2(argv[i]); +#endif + } + + if (old_gc == Qfalse) rb_gc_enable(); + rb_thread_critical = thr_crit_bup; + + RARRAY(exception)->ptr[0] = Qnil; + RARRAY(exception)->len = 1; + + arg->receiver = receiver; + arg->method = method; + arg->args = args; + arg->failed = exception; + + /* evaluate the argument string by ruby */ + old_trapflag = rb_trap_immediate; +#ifdef HAVE_NATIVETHREAD + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on ip_ruby_cmd()"); + } +#endif + + res = rb_ensure(ip_ruby_cmd_body, (VALUE)arg, + ip_ruby_cmd_ensure, INT2FIX(old_trapflag)); + + free(arg); + + /* status check */ + /* if (arg.failed) { */ + if (!NIL_P(RARRAY(exception)->ptr[0])) { + VALUE eclass; + volatile VALUE bt_ary; + volatile VALUE backtrace; + + DUMP1("(rb_eval_cmd result) failed"); + + Tcl_ResetResult(interp); + + res = RARRAY(exception)->ptr[0]; + eclass = rb_obj_class(res); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + DUMP1("set backtrace"); + if (!NIL_P(bt_ary = rb_funcall(res, ID_backtrace, 0, 0))) { + backtrace = rb_ary_join(bt_ary, rb_str_new2("\n")); + StringValue(backtrace); + Tcl_AddErrorInfo(interp, RSTRING(backtrace)->ptr); + } + + rb_thread_critical = thr_crit_bup; + + if (eclass == eTkCallbackReturn) { + ip_set_exc_message(interp, res); + return TCL_RETURN; + + } else if (eclass == eTkCallbackBreak) { + ip_set_exc_message(interp, res); + return TCL_BREAK; + + } else if (eclass == eTkCallbackContinue) { + ip_set_exc_message(interp, res); + return TCL_CONTINUE; + + } else if (eclass == rb_eSystemExit) { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* Tcl_Eval(interp, "destroy ."); */ + if (Tk_GetNumMainWindows() > 0) { + Tk_Window main_win = Tk_MainWindow(interp); + if (main_win != (Tk_Window)NULL) { + Tk_DestroyWindow(main_win); + } + } + + /* StringValue(res); */ + res = rb_funcall(res, ID_message, 0, 0); + + Tcl_AppendResult(interp, RSTRING(res)->ptr, (char*)NULL); + + rb_thread_critical = thr_crit_bup; + + rb_raise(rb_eSystemExit, RSTRING(res)->ptr); + + } else if (rb_obj_is_kind_of(res, eLocalJumpError)) { + VALUE reason = rb_ivar_get(res, ID_at_reason); + + if (TYPE(reason) != T_SYMBOL) { + ip_set_exc_message(interp, res); + return TCL_ERROR; + } + + if (SYM2ID(reason) == ID_return) { + ip_set_exc_message(interp, res); + return TCL_RETURN; + + } else if (SYM2ID(reason) == ID_break) { + ip_set_exc_message(interp, res); + return TCL_BREAK; + + } else if (SYM2ID(reason) == ID_next) { + ip_set_exc_message(interp, res); + return TCL_CONTINUE; + + } else { + ip_set_exc_message(interp, res); + return TCL_ERROR; + } + } else { + ip_set_exc_message(interp, res); + return TCL_ERROR; + } + } + + /* result must be string or nil */ + if (NIL_P(res)) { + DUMP1("(rb_eval_cmd result) nil"); + Tcl_ResetResult(interp); + return TCL_OK; + } + + + /* copy result to the tcl interpreter */ + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + old_gc = rb_gc_disable(); + + res = TkStringValue(res); + + if (old_gc == Qfalse) rb_gc_enable(); + DUMP2("(rb_eval_cmd result) '%s'", RSTRING(res)->ptr); + DUMP1("Tcl_AppendResult"); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, RSTRING(res)->ptr, (char *)NULL); + + rb_thread_critical = thr_crit_bup; + + DUMP1("end of ip_ruby_cmd"); + return TCL_OK; +} + + +static int +#if TCL_MAJOR_VERSION >= 8 +ip_InterpExitObjCmd(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + Tcl_Obj *CONST argv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +ip_InterpExitCommand(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + char *argv[]; +#endif +{ + if (!Tcl_InterpDeleted(interp) && !ip_null_namespace(interp)) { + Tcl_Preserve(interp); + Tcl_Eval(interp, "interp eval {} {destroy .}; interp delete {}"); + Tcl_Release(interp); + } + return TCL_OK; +} + +static int +#if TCL_MAJOR_VERSION >= 8 +ip_RubyExitObjCmd(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + Tcl_Obj *CONST argv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +ip_RubyExitCommand(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + char *argv[]; +#endif +{ + int state; + char *cmd, *param; + +#if TCL_MAJOR_VERSION >= 8 + cmd = Tcl_GetString(argv[0]); + +#else /* TCL_MAJOR_VERSION < 8 */ + char *endptr; + cmd = argv[0]; +#endif + + if (rb_safe_level() >= 4) { + rb_raise(rb_eSecurityError, + "Insecure operation `exit' at level %d", + rb_safe_level()); + } else if (Tcl_IsSafe(interp)) { + rb_raise(rb_eSecurityError, + "Insecure operation `exit' on a safe interpreter"); +#if 0 + } else if (Tcl_GetMaster(interp) != (Tcl_Interp *)NULL) { + Tcl_Preserve(interp); + Tcl_Eval(interp, "interp eval {} {destroy .}"); + Tcl_Eval(interp, "interp delete {}"); + Tcl_Release(interp); + return TCL_OK; +#endif + } + + Tcl_ResetResult(interp); + + switch(argc) { + case 1: + rb_exit(0); /* not return if succeed */ + + Tcl_AppendResult(interp, + "fail to call \"", cmd, "\"", (char *)NULL); + return TCL_ERROR; + + case 2: +#if TCL_MAJOR_VERSION >= 8 + if (!Tcl_GetIntFromObj(interp, argv[1], &state)) { + return TCL_ERROR; + } + param = Tcl_GetString(argv[1]); +#else /* TCL_MAJOR_VERSION < 8 */ + state = (int)strtol(argv[1], &endptr, 0); + if (endptr) { + Tcl_AppendResult(interp, + "expected integer but got \"", + argv[1], "\"", (char *)NULL); + } + param = argv[1]; +#endif + rb_exit(state); /* not return if succeed */ + + Tcl_AppendResult(interp, "fail to call \"", cmd, " ", + param, "\"", (char *)NULL); + return TCL_ERROR; + default: + /* arguemnt error */ + Tcl_AppendResult(interp, + "wrong number of arguments: should be \"", + cmd, " ?returnCode?\"", (char *)NULL); + return TCL_ERROR; + } +} + + +/**************************/ +/* based on tclEvent.c */ +/**************************/ + +#if 0 /* + Disable the following "update" and "thread_update". Bcause, + they don't work in a callback-proc. After calling update in + a callback-proc, the callback proc never be worked. + If the problem will be fixed in the future, may enable the + functions. + */ +/*********************/ +/* replace of update */ +/*********************/ +#if TCL_MAJOR_VERSION >= 8 +static int ip_rbUpdateObjCmd _((ClientData, Tcl_Interp *, int, + Tcl_Obj *CONST [])); +static int +ip_rbUpdateObjCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +static int ip_rbUpdateCommand _((ClientData, Tcl_Interp *, int, char *[])); +static int +ip_rbUpdateCommand(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + char *objv[]; +#endif +{ + int optionIndex; + int ret, done; + int flags = 0; + static CONST char *updateOptions[] = {"idletasks", (char *) NULL}; + enum updateOptions {REGEXP_IDLETASKS}; + char *nameString; + int dummy; + + DUMP1("Ruby's 'update' is called"); + if (objc == 1) { + flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; + + } else if (objc == 2) { + if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, + "option", 0, &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum updateOptions) optionIndex) { + case REGEXP_IDLETASKS: { + flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + break; + } + default: { + Tcl_Panic("ip_rbUpdateObjCmd: bad option index to UpdateOptions"); + } + } + } else { +#ifdef Tcl_WrongNumArgs + Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]"); +#else +# if TCL_MAJOR_VERSION >= 8 + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + Tcl_GetStringFromObj(objv[0], &dummy), + " [ idletasks ]\"", + (char *) NULL); +# else /* TCL_MAJOR_VERSION < 8 */ + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + objv[0], " [ idletasks ]\"", (char *) NULL); +# endif +#endif + return TCL_ERROR; + } + + /* call eventloop */ +#if 1 + ret = lib_eventloop_core(0, flags, (int *)NULL); /* ignore result */ +#else + Tcl_UpdateObjCmd(clientData, interp, objc, objv); +#endif + + /* + * Must clear the interpreter's result because event handlers could + * have executed commands. + */ + + DUMP2("last result '%s'", Tcl_GetStringResult(interp)); + Tcl_ResetResult(interp); + DUMP1("finish Ruby's 'update'"); + return TCL_OK; +} + + +/**********************/ +/* update with thread */ +/**********************/ +struct th_update_param { + VALUE thread; + int done; +}; + +static void rb_threadUpdateProc _((ClientData)); +static void +rb_threadUpdateProc(clientData) + ClientData clientData; /* Pointer to integer to set to 1. */ +{ + struct th_update_param *param = (struct th_update_param *) clientData; + + DUMP1("threadUpdateProc is called"); + param->done = 1; + rb_thread_wakeup(param->thread); + + return; +} + +#if TCL_MAJOR_VERSION >= 8 +static int ip_rb_threadUpdateObjCmd _((ClientData, Tcl_Interp *, int, + Tcl_Obj *CONST [])); +static int +ip_rb_threadUpdateObjCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +static int ip_rb_threadUpdateCommand _((ClientData, Tcl_Interp *, int, + char *[])); +static int +ip_rb_threadUpdateCommand(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + char *objv[]; +#endif +{ + int optionIndex; + int ret, done; + int flags = 0; + int dummy; + struct th_update_param *param; + static CONST char *updateOptions[] = {"idletasks", (char *) NULL}; + enum updateOptions {REGEXP_IDLETASKS}; + volatile VALUE current_thread = rb_thread_current(); + + DUMP1("Ruby's 'thread_update' is called"); + + if (rb_thread_alone() || eventloop_thread == current_thread) { +#define USE_TCL_UPDATE 0 +#if TCL_MAJOR_VERSION >= 8 +# if USE_TCL_UPDATE + DUMP1("call Tcl_UpdateObjCmd"); + return Tcl_UpdateObjCmd(clientData, interp, objc, objv); +# else + DUMP1("call ip_rbUpdateObjCmd"); + return ip_rbUpdateObjCmd(clientData, interp, objc, objv); +# endif +#else /* TCL_MAJOR_VERSION < 8 */ +# if USE_TCL_UPDATE + DUMP1("call ip_rbUpdateCommand"); + return Tcl_UpdateCommand(clientData, interp, objc, objv); +# else + DUMP1("call ip_rbUpdateCommand"); + return ip_rbUpdateCommand(clientData, interp, objc, objv); +# endif +#endif + } + + DUMP1("start Ruby's 'thread_update' body"); + + if (objc == 1) { + flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; + + } else if (objc == 2) { + if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, + "option", 0, &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum updateOptions) optionIndex) { + case REGEXP_IDLETASKS: { + flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + break; + } + default: { + Tcl_Panic("ip_rb_threadUpdateObjCmd: bad option index to UpdateOptions"); + } + } + } else { +#ifdef Tcl_WrongNumArgs + Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]"); +#else +# if TCL_MAJOR_VERSION >= 8 + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + Tcl_GetStringFromObj(objv[0], &dummy), + " [ idletasks ]\"", + (char *) NULL); +# else /* TCL_MAJOR_VERSION < 8 */ + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + objv[0], " [ idletasks ]\"", (char *) NULL); +# endif +#endif + return TCL_ERROR; + } + + DUMP1("pass argument check"); + + param = (struct th_update_param *)Tcl_Alloc(sizeof(struct th_update_param)); + Tcl_Preserve(param); + param->thread = current_thread; + param->done = 0; + + DUMP1("set idle proc"); + Tcl_DoWhenIdle(rb_threadUpdateProc, (ClientData) param); + + while(!param->done) { + DUMP1("wait for complete idle proc"); + rb_thread_stop(); + } + + Tcl_Release(param); + Tcl_Free((char *)param); + + DUMP1("finish Ruby's 'thread_update'"); + return TCL_OK; +} +#endif /* update and thread_update don't work */ + + +/***************************/ +/* replace of vwait/tkwait */ +/***************************/ +#if TCL_MAJOR_VERSION >= 8 +static char *VwaitVarProc _((ClientData, Tcl_Interp *, + CONST84 char *,CONST84 char *, int)); +static char * +VwaitVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + CONST84 char *name1; /* Name of variable. */ + CONST84 char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +#else /* TCL_MAJOR_VERSION < 8 */ +static char *VwaitVarProc _((ClientData, Tcl_Interp *, char *, char *, int)); +static char * +VwaitVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +#endif +{ + int *donePtr = (int *) clientData; + + *donePtr = 1; + return (char *) NULL; +} + +#if TCL_MAJOR_VERSION >= 8 +static int ip_rbVwaitObjCmd _((ClientData, Tcl_Interp *, int, + Tcl_Obj *CONST [])); +static int +ip_rbVwaitObjCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +static int ip_rbVwaitCommand _((ClientData, Tcl_Interp *, int, char *[])); +static int +ip_rbVwaitCommand(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + char *objv[]; +#endif +{ + int ret, done, foundEvent; + char *nameString; + int dummy; + int thr_crit_bup; + + DUMP1("Ruby's 'vwait' is called"); + Tcl_Preserve(interp); + + if (objc != 2) { +#ifdef Tcl_WrongNumArgs + Tcl_WrongNumArgs(interp, 1, objv, "name"); +#else + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + +#if TCL_MAJOR_VERSION >= 8 + /* nameString = Tcl_GetString(objv[0]); */ + nameString = Tcl_GetStringFromObj(objv[0], &dummy); +#else /* TCL_MAJOR_VERSION < 8 */ + nameString = objv[0]; +#endif + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + nameString, " name\"", (char *) NULL); + + rb_thread_critical = thr_crit_bup; +#endif + + Tcl_Release(interp); + return TCL_ERROR; + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_IncrRefCount(objv[1]); + /* nameString = Tcl_GetString(objv[1]); */ + nameString = Tcl_GetStringFromObj(objv[1], &dummy); +#else /* TCL_MAJOR_VERSION < 8 */ + nameString = objv[1]; +#endif + + /* + if (Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done) != TCL_OK) { + return TCL_ERROR; + } + */ + ret = Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done); + + rb_thread_critical = thr_crit_bup; + + if (ret != TCL_OK) { +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[1]); +#endif + Tcl_Release(interp); + return TCL_ERROR; + } + done = 0; + foundEvent = lib_eventloop_core(/* not check root-widget */0, 0, &done); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + Tcl_UntraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done); + + rb_thread_critical = thr_crit_bup; + + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + + Tcl_ResetResult(interp); + if (!foundEvent) { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + Tcl_AppendResult(interp, "can't wait for variable \"", nameString, + "\": would wait forever", (char *) NULL); + + rb_thread_critical = thr_crit_bup; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[1]); +#endif + Tcl_Release(interp); + return TCL_ERROR; + } + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[1]); +#endif + Tcl_Release(interp); + return TCL_OK; +} + + +/**************************/ +/* based on tkCmd.c */ +/**************************/ +#if TCL_MAJOR_VERSION >= 8 +static char *WaitVariableProc _((ClientData, Tcl_Interp *, + CONST84 char *,CONST84 char *, int)); +static char * +WaitVariableProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + CONST84 char *name1; /* Name of variable. */ + CONST84 char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +#else /* TCL_MAJOR_VERSION < 8 */ +static char *WaitVariableProc _((ClientData, Tcl_Interp *, + char *, char *, int)); +static char * +WaitVariableProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +#endif +{ + int *donePtr = (int *) clientData; + + *donePtr = 1; + return (char *) NULL; +} + +static void WaitVisibilityProc _((ClientData, XEvent *)); +static void +WaitVisibilityProc(clientData, eventPtr) + ClientData clientData; /* Pointer to integer to set to 1. */ + XEvent *eventPtr; /* Information about event (not used). */ +{ + int *donePtr = (int *) clientData; + + if (eventPtr->type == VisibilityNotify) { + *donePtr = 1; + } + if (eventPtr->type == DestroyNotify) { + *donePtr = 2; + } +} + +static void WaitWindowProc _((ClientData, XEvent *)); +static void +WaitWindowProc(clientData, eventPtr) + ClientData clientData; /* Pointer to integer to set to 1. */ + XEvent *eventPtr; /* Information about event. */ +{ + int *donePtr = (int *) clientData; + + if (eventPtr->type == DestroyNotify) { + *donePtr = 1; + } +} + +#if TCL_MAJOR_VERSION >= 8 +static int ip_rbTkWaitObjCmd _((ClientData, Tcl_Interp *, int, + Tcl_Obj *CONST [])); +static int +ip_rbTkWaitObjCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +static int ip_rbTkWaitCommand _((ClientData, Tcl_Interp *, int, char *[])); +static int +ip_rbTkWaitCommand(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + char *objv[]; +#endif +{ + Tk_Window tkwin = (Tk_Window) clientData; + Tk_Window window; + int done, index; + static CONST char *optionStrings[] = { "variable", "visibility", "window", + (char *) NULL }; + enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW }; + char *nameString; + int ret, dummy; + int thr_crit_bup; + + DUMP1("Ruby's 'tkwait' is called"); + + Tcl_Preserve(interp); + + if (objc != 3) { +#ifdef Tcl_WrongNumArgs + Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); +#else + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + Tcl_GetStringFromObj(objv[0], &dummy), + " variable|visibility|window name\"", + (char *) NULL); +#else /* TCL_MAJOR_VERSION < 8 */ + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + objv[0], " variable|visibility|window name\"", + (char *) NULL); +#endif + + rb_thread_critical = thr_crit_bup; +#endif + + Tcl_Release(interp); + return TCL_ERROR; + } + +#if TCL_MAJOR_VERSION >= 8 + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* + if (Tcl_GetIndexFromObj(interp, objv[1], + (CONST84 char **)optionStrings, + "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + */ + ret = Tcl_GetIndexFromObj(interp, objv[1], + (CONST84 char **)optionStrings, + "option", 0, &index); + + rb_thread_critical = thr_crit_bup; + + if (ret != TCL_OK) { + Tcl_Release(interp); + return TCL_ERROR; + } +#else /* TCL_MAJOR_VERSION < 8 */ + { + int c = objv[1][0]; + size_t length = strlen(objv[1]); + + if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0) + && (length >= 2)) { + index = TKWAIT_VARIABLE; + } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0) + && (length >= 2)) { + index = TKWAIT_VISIBILITY; + } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) { + index = TKWAIT_WINDOW; + } else { + Tcl_AppendResult(interp, "bad option \"", objv[1], + "\": must be variable, visibility, or window", + (char *) NULL); + Tcl_Release(interp); + return TCL_ERROR; + } + } +#endif + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_IncrRefCount(objv[2]); + /* nameString = Tcl_GetString(objv[2]); */ + nameString = Tcl_GetStringFromObj(objv[2], &dummy); +#else /* TCL_MAJOR_VERSION < 8 */ + nameString = objv[2]; +#endif + + rb_thread_critical = thr_crit_bup; + + switch ((enum options) index) { + case TKWAIT_VARIABLE: + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + /* + if (Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + WaitVariableProc, (ClientData) &done) != TCL_OK) { + return TCL_ERROR; + } + */ + ret = Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + WaitVariableProc, (ClientData) &done); + + rb_thread_critical = thr_crit_bup; + + if (ret != TCL_OK) { +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[2]); +#endif + Tcl_Release(interp); + return TCL_ERROR; + } + done = 0; + lib_eventloop_core(check_rootwidget_flag, 0, &done); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + Tcl_UntraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + WaitVariableProc, (ClientData) &done); + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[2]); +#endif + + rb_thread_critical = thr_crit_bup; + + break; + + case TKWAIT_VISIBILITY: + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (Tk_MainWindow(interp) == (Tk_Window)NULL) { + window = NULL; + } else { + window = Tk_NameToWindow(interp, nameString, tkwin); + } + + if (window == NULL) { + rb_thread_critical = thr_crit_bup; +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[2]); +#endif + Tcl_Release(interp); + return TCL_ERROR; + } + + Tk_CreateEventHandler(window, + VisibilityChangeMask|StructureNotifyMask, + WaitVisibilityProc, (ClientData) &done); + + rb_thread_critical = thr_crit_bup; + + done = 0; + lib_eventloop_core(check_rootwidget_flag, 0, &done); + if (done != 1) { + /* + * Note that we do not delete the event handler because it + * was deleted automatically when the window was destroyed. + */ + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "window \"", nameString, + "\" was deleted before its visibility changed", + (char *) NULL); + + rb_thread_critical = thr_crit_bup; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[2]); +#endif + Tcl_Release(interp); + return TCL_ERROR; + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[2]); +#endif + + Tk_DeleteEventHandler(window, + VisibilityChangeMask|StructureNotifyMask, + WaitVisibilityProc, (ClientData) &done); + + rb_thread_critical = thr_crit_bup; + + break; + + case TKWAIT_WINDOW: + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (Tk_MainWindow(interp) == (Tk_Window)NULL) { + window = NULL; + } else { + window = Tk_NameToWindow(interp, nameString, tkwin); + } + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[2]); +#endif + + if (window == NULL) { + rb_thread_critical = thr_crit_bup; + Tcl_Release(interp); + return TCL_ERROR; + } + + Tk_CreateEventHandler(window, StructureNotifyMask, + WaitWindowProc, (ClientData) &done); + + rb_thread_critical = thr_crit_bup; + + done = 0; + lib_eventloop_core(check_rootwidget_flag, 0, &done); + /* + * Note: there's no need to delete the event handler. It was + * deleted automatically when the window was destroyed. + */ + break; + } + + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + + Tcl_ResetResult(interp); + Tcl_Release(interp); + return TCL_OK; +} + +/****************************/ +/* vwait/tkwait with thread */ +/****************************/ +struct th_vwait_param { + VALUE thread; + int done; +}; + +#if TCL_MAJOR_VERSION >= 8 +static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *, + CONST84 char *,CONST84 char *, int)); +static char * +rb_threadVwaitProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + CONST84 char *name1; /* Name of variable. */ + CONST84 char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +#else /* TCL_MAJOR_VERSION < 8 */ +static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *, + char *, char *, int)); +static char * +rb_threadVwaitProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +#endif +{ + struct th_vwait_param *param = (struct th_vwait_param *) clientData; + + if (flags & (TCL_INTERP_DESTROYED | TCL_TRACE_DESTROYED)) { + param->done = -1; + } else { + param->done = 1; + } + rb_thread_wakeup(param->thread); + + return (char *)NULL; +} + +#define TKWAIT_MODE_VISIBILITY 1 +#define TKWAIT_MODE_DESTROY 2 + +static void rb_threadWaitVisibilityProc _((ClientData, XEvent *)); +static void +rb_threadWaitVisibilityProc(clientData, eventPtr) + ClientData clientData; /* Pointer to integer to set to 1. */ + XEvent *eventPtr; /* Information about event (not used). */ +{ + struct th_vwait_param *param = (struct th_vwait_param *) clientData; + + if (eventPtr->type == VisibilityNotify) { + param->done = TKWAIT_MODE_VISIBILITY; + } + if (eventPtr->type == DestroyNotify) { + param->done = TKWAIT_MODE_DESTROY; + } + rb_thread_wakeup(param->thread); +} + +static void rb_threadWaitWindowProc _((ClientData, XEvent *)); +static void +rb_threadWaitWindowProc(clientData, eventPtr) + ClientData clientData; /* Pointer to integer to set to 1. */ + XEvent *eventPtr; /* Information about event. */ +{ + struct th_vwait_param *param = (struct th_vwait_param *) clientData; + + if (eventPtr->type == DestroyNotify) { + param->done = TKWAIT_MODE_DESTROY; + } + rb_thread_wakeup(param->thread); +} + +#if TCL_MAJOR_VERSION >= 8 +static int ip_rb_threadVwaitObjCmd _((ClientData, Tcl_Interp *, int, + Tcl_Obj *CONST [])); +static int +ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +static int ip_rb_threadVwaitCommand _((ClientData, Tcl_Interp *, int, + char *[])); +static int +ip_rb_threadVwaitCommand(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + char *objv[]; +#endif +{ + struct th_vwait_param *param; + char *nameString; + int ret, dummy; + int thr_crit_bup; + volatile VALUE current_thread = rb_thread_current(); + + DUMP1("Ruby's 'thread_vwait' is called"); + + if (rb_thread_alone() || eventloop_thread == current_thread) { +#if TCL_MAJOR_VERSION >= 8 + DUMP1("call ip_rbVwaitObjCmd"); + return ip_rbVwaitObjCmd(clientData, interp, objc, objv); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("call ip_rbVwaitCommand"); + return ip_rbVwaitCommand(clientData, interp, objc, objv); +#endif + } + + Tcl_Preserve(interp); + + if (objc != 2) { +#ifdef Tcl_WrongNumArgs + Tcl_WrongNumArgs(interp, 1, objv, "name"); +#else + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + +#if TCL_MAJOR_VERSION >= 8 + /* nameString = Tcl_GetString(objv[0]); */ + nameString = Tcl_GetStringFromObj(objv[0], &dummy); +#else /* TCL_MAJOR_VERSION < 8 */ + nameString = objv[0]; +#endif + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + nameString, " name\"", (char *) NULL); + + rb_thread_critical = thr_crit_bup; +#endif + + Tcl_Release(interp); + return TCL_ERROR; + } + +#if TCL_MAJOR_VERSION >= 8 + Tcl_IncrRefCount(objv[1]); + /* nameString = Tcl_GetString(objv[1]); */ + nameString = Tcl_GetStringFromObj(objv[1], &dummy); +#else /* TCL_MAJOR_VERSION < 8 */ + nameString = objv[1]; +#endif + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); + Tcl_Preserve(param); + param->thread = current_thread; + param->done = 0; + + /* + if (Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + rb_threadVwaitProc, (ClientData) param) != TCL_OK) { + return TCL_ERROR; + } + */ + ret = Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + rb_threadVwaitProc, (ClientData) param); + + rb_thread_critical = thr_crit_bup; + + if (ret != TCL_OK) { +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[1]); +#endif + Tcl_Release(interp); + return TCL_ERROR; + } + + /* if (!param->done) { */ + while(!param->done) { + rb_thread_stop(); + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (param->done > 0) { + Tcl_UntraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + rb_threadVwaitProc, (ClientData) param); + } + + Tcl_Release(param); + Tcl_Free((char *)param); + + rb_thread_critical = thr_crit_bup; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[1]); +#endif + Tcl_Release(interp); + return TCL_OK; +} + +#if TCL_MAJOR_VERSION >= 8 +static int ip_rb_threadTkWaitObjCmd _((ClientData, Tcl_Interp *, int, + Tcl_Obj *CONST [])); +static int +ip_rb_threadTkWaitObjCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +static int ip_rb_threadTkWaitCommand _((ClientData, Tcl_Interp *, int, + char *[])); +static int +ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + char *objv[]; +#endif +{ + struct th_vwait_param *param; + Tk_Window tkwin = (Tk_Window) clientData; + Tk_Window window; + int index; + static CONST char *optionStrings[] = { "variable", "visibility", "window", + (char *) NULL }; + enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW }; + char *nameString; + int ret, dummy; + int thr_crit_bup; + volatile VALUE current_thread = rb_thread_current(); + + DUMP1("Ruby's 'thread_tkwait' is called"); + + if (rb_thread_alone() || eventloop_thread == current_thread) { +#if TCL_MAJOR_VERSION >= 8 + DUMP1("call ip_rbTkWaitObjCmd"); + return ip_rbTkWaitObjCmd(clientData, interp, objc, objv); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("call rb_VwaitCommand"); + return ip_rbTkWaitCommand(clientData, interp, objc, objv); +#endif + } + + Tcl_Preserve(interp); + Tcl_Preserve(tkwin); + + if (objc != 3) { +#ifdef Tcl_WrongNumArgs + Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); +#else + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + Tcl_GetStringFromObj(objv[0], &dummy), + " variable|visibility|window name\"", + (char *) NULL); +#else /* TCL_MAJOR_VERSION < 8 */ + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + objv[0], " variable|visibility|window name\"", + (char *) NULL); +#endif + + rb_thread_critical = thr_crit_bup; +#endif + + Tcl_Release(tkwin); + Tcl_Release(interp); + return TCL_ERROR; + } + +#if TCL_MAJOR_VERSION >= 8 + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + /* + if (Tcl_GetIndexFromObj(interp, objv[1], + (CONST84 char **)optionStrings, + "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + */ + ret = Tcl_GetIndexFromObj(interp, objv[1], + (CONST84 char **)optionStrings, + "option", 0, &index); + + rb_thread_critical = thr_crit_bup; + + if (ret != TCL_OK) { + Tcl_Release(tkwin); + Tcl_Release(interp); + return TCL_ERROR; + } +#else /* TCL_MAJOR_VERSION < 8 */ + { + int c = objv[1][0]; + size_t length = strlen(objv[1]); + + if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0) + && (length >= 2)) { + index = TKWAIT_VARIABLE; + } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0) + && (length >= 2)) { + index = TKWAIT_VISIBILITY; + } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) { + index = TKWAIT_WINDOW; + } else { + Tcl_AppendResult(interp, "bad option \"", objv[1], + "\": must be variable, visibility, or window", + (char *) NULL); + Tcl_Release(tkwin); + Tcl_Release(interp); + return TCL_ERROR; + } + } +#endif + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_IncrRefCount(objv[2]); + /* nameString = Tcl_GetString(objv[2]); */ + nameString = Tcl_GetStringFromObj(objv[2], &dummy); +#else /* TCL_MAJOR_VERSION < 8 */ + nameString = objv[2]; +#endif + + param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); + Tcl_Preserve(param); + param->thread = current_thread; + param->done = 0; + + rb_thread_critical = thr_crit_bup; + + switch ((enum options) index) { + case TKWAIT_VARIABLE: + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + /* + if (Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + rb_threadVwaitProc, (ClientData) param) != TCL_OK) { + return TCL_ERROR; + } + */ + ret = Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + rb_threadVwaitProc, (ClientData) param); + + rb_thread_critical = thr_crit_bup; + + if (ret != TCL_OK) { + Tcl_Release(param); + Tcl_Free((char *)param); + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[2]); +#endif + + Tcl_Release(tkwin); + Tcl_Release(interp); + return TCL_ERROR; + } + + /* if (!param->done) { */ + while(!param->done) { + rb_thread_stop(); + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (param->done > 0) { + Tcl_UntraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + rb_threadVwaitProc, (ClientData) param); + } + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[2]); +#endif + + rb_thread_critical = thr_crit_bup; + + break; + + case TKWAIT_VISIBILITY: + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (Tk_MainWindow(interp) == (Tk_Window)NULL) { + window = NULL; + } else { + window = Tk_NameToWindow(interp, nameString, tkwin); + } + + if (window == NULL) { + rb_thread_critical = thr_crit_bup; + + Tcl_Release(param); + Tcl_Free((char *)param); + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[2]); +#endif + Tcl_Release(tkwin); + Tcl_Release(interp); + return TCL_ERROR; + } + Tcl_Preserve(window); + + Tk_CreateEventHandler(window, + VisibilityChangeMask|StructureNotifyMask, + rb_threadWaitVisibilityProc, (ClientData) param); + + rb_thread_critical = thr_crit_bup; + + /* if (!param->done) { */ + /* + while(!param->done) { + rb_thread_stop(); + } + */ + while(param->done != TKWAIT_MODE_VISIBILITY) { + if (param->done == TKWAIT_MODE_DESTROY) break; + rb_thread_stop(); + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* when a window is destroyed, no need to call Tk_DeleteEventHandler */ + if (param->done != TKWAIT_MODE_DESTROY) { + Tk_DeleteEventHandler(window, + VisibilityChangeMask|StructureNotifyMask, + rb_threadWaitVisibilityProc, + (ClientData) param); + } + + if (param->done != 1) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "window \"", nameString, + "\" was deleted before its visibility changed", + (char *) NULL); + + rb_thread_critical = thr_crit_bup; + + Tcl_Release(window); + + Tcl_Release(param); + Tcl_Free((char *)param); + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[2]); +#endif + + Tcl_Release(tkwin); + Tcl_Release(interp); + return TCL_ERROR; + } + + Tcl_Release(window); + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[2]); +#endif + + rb_thread_critical = thr_crit_bup; + + break; + + case TKWAIT_WINDOW: + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (Tk_MainWindow(interp) == (Tk_Window)NULL) { + window = NULL; + } else { + window = Tk_NameToWindow(interp, nameString, tkwin); + } + +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(objv[2]); +#endif + + if (window == NULL) { + rb_thread_critical = thr_crit_bup; + + Tcl_Release(param); + Tcl_Free((char *)param); + + Tcl_Release(tkwin); + Tcl_Release(interp); + return TCL_ERROR; + } + + Tcl_Preserve(window); + + Tk_CreateEventHandler(window, StructureNotifyMask, + rb_threadWaitWindowProc, (ClientData) param); + + rb_thread_critical = thr_crit_bup; + + /* if (!param->done) { */ + /* + while(!param->done) { + rb_thread_stop(); + } + */ + while(param->done != TKWAIT_MODE_DESTROY) { + rb_thread_stop(); + } + + Tcl_Release(window); + + /* when a window is destroyed, no need to call Tk_DeleteEventHandler + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + Tk_DeleteEventHandler(window, StructureNotifyMask, + rb_threadWaitWindowProc, (ClientData) param); + + rb_thread_critical = thr_crit_bup; + */ + + break; + } /* end of 'switch' statement */ + + Tcl_Release(param); + Tcl_Free((char *)param); + + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + + Tcl_ResetResult(interp); + + Tcl_Release(tkwin); + Tcl_Release(interp); + return TCL_OK; +} + +static VALUE +ip_thread_vwait(self, var) + VALUE self; + VALUE var; +{ + VALUE argv[2]; + volatile VALUE cmd_str = rb_str_new2("thread_vwait"); + + argv[0] = cmd_str; + argv[1] = var; + return ip_invoke_real(2, argv, self); +} + +static VALUE +ip_thread_tkwait(self, mode, target) + VALUE self; + VALUE mode; + VALUE target; +{ + VALUE argv[3]; + volatile VALUE cmd_str = rb_str_new2("thread_tkwait"); + + argv[0] = cmd_str; + argv[1] = mode; + argv[2] = target; + return ip_invoke_real(3, argv, self); +} + +/* destroy interpreter */ +VALUE del_root(ip) + Tcl_Interp *ip; +{ + Tk_Window main_win; + + if (!Tcl_InterpDeleted(ip)) { + Tcl_Preserve(ip); + + if ( (main_win = Tk_MainWindow(ip)) != (Tk_Window)NULL + && !(((Tk_FakeWin*)main_win)->flags & TK_ALREADY_DEAD) ) { + DUMP1("wait main_win is destroyed"); + Tk_DestroyWindow(main_win); + } + + Tcl_Release(ip); + } + return Qnil; +} + + +static void +delete_slaves(ip) + Tcl_Interp *ip; +{ + Tcl_Interp *slave; + Tcl_Obj *slave_list, *elem; + Tcl_CmdInfo info; + char *slave_name; + int i, len; + + if (Tcl_InterpDeleted(ip) || ip_null_namespace(ip)) { + DUMP2("call delete_slaves() for deleted ip(%lx)", ip); + return; + } + + DUMP2("delete slaves of ip(%lx)", ip); + + Tcl_Preserve(ip); + + if (Tcl_Eval(ip, "info slaves") == TCL_ERROR) { + DUMP2("ip(%lx) cannot get a list of slave IPs", ip); + return; + } + + slave_list = Tcl_GetObjResult(ip); + Tcl_IncrRefCount(slave_list); + + if (Tcl_ListObjLength((Tcl_Interp*)NULL, slave_list, &len) == TCL_ERROR) { + DUMP1("slave_list is not a list object"); + Tcl_DecrRefCount(slave_list); + return; + } + + for(i = 0; i < len; i++) { + Tcl_ListObjIndex((Tcl_Interp*)NULL, slave_list, i, &elem); + Tcl_IncrRefCount(elem); + + if (elem == (Tcl_Obj*)NULL) continue; + + /* get slave */ + slave_name = Tcl_GetString(elem); + slave = Tcl_GetSlave(ip, slave_name); + if (slave == (Tcl_Interp*)NULL) { + DUMP2("slave \"%s\" does not exist", slave_name); + continue; + } + + Tcl_DecrRefCount(elem); + + Tcl_Preserve(slave); + + if (!Tcl_InterpDeleted(slave) && !ip_null_namespace(slave)) { + if (Tcl_Eval(slave, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) { + if (Tcl_GetCommandInfo(slave, CANCEL_AFTER_SCRIPTS, &info)) { + DUMP2("call cancel after scripts proc '%s'", + CANCEL_AFTER_SCRIPTS); + Tcl_Eval(slave, CANCEL_AFTER_SCRIPTS); + } + } + + if (Tcl_GetCommandInfo(slave, finalize_hook_name, &info)) { + DUMP2("call finalize hook proc '%s'", finalize_hook_name); + Tcl_Eval(slave, finalize_hook_name); + } + } + + /* delete slaves of slave */ + delete_slaves(slave); + + /* delete slave */ + del_root(slave); + /* while(!rbtk_InterpDeleted(slave)) { */ + if (!Tcl_InterpDeleted(slave)) { + DUMP1("wait ip is deleted"); + Tcl_DeleteInterp(slave); + } + + Tcl_Release(slave); + + /* delete slave_name command */ + Tcl_DeleteCommand(ip, slave_name); + } + + Tcl_DecrRefCount(slave_list); + + Tcl_Release(ip); +} + +static void +ip_free(ptr) + struct tcltkip *ptr; +{ + Tcl_CmdInfo info; + int thr_crit_bup; + + DUMP2("free Tcl Interp %lx", ptr->ip); + if (ptr) { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + DUMP2("IP ref_count = %d", ptr->ref_count); + + if (!Tcl_InterpDeleted(ptr->ip) && !ip_null_namespace(ptr->ip)) { + DUMP2("IP(%lx) is not deleted", ptr->ip); + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + + delete_slaves(ptr->ip); + + Tcl_ResetResult(ptr->ip); + + if (Tcl_Eval(ptr->ip, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) { + if (Tcl_GetCommandInfo(ptr->ip, CANCEL_AFTER_SCRIPTS, &info)) { + DUMP2("call cancel after scripts proc '%s'", + CANCEL_AFTER_SCRIPTS); + Tcl_Eval(ptr->ip, CANCEL_AFTER_SCRIPTS); + } + } + + if (Tcl_GetCommandInfo(ptr->ip, finalize_hook_name, &info)) { + DUMP2("call finalize hook proc '%s'", finalize_hook_name); + Tcl_Eval(ptr->ip, finalize_hook_name); + } + + /* del_root(ptr->ip); */ + + DUMP1("delete interp"); + /* while(!rbtk_InterpDeleted(ptr->ip)) { */ + if (!Tcl_InterpDeleted(ptr->ip)) { + DUMP1("wait ip is deleted"); + Tcl_DeleteInterp(ptr->ip); + } + + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + } + + rbtk_release_ip(ptr); + DUMP2("IP ref_count = %d", ptr->ref_count); + + free(ptr); + + rb_thread_critical = thr_crit_bup; + } + DUMP1("complete freeing Tcl Interp"); +} + +/* create and initialize interpreter */ +static VALUE ip_alloc _((VALUE)); +static VALUE +ip_alloc(self) + VALUE self; +{ + return Data_Wrap_Struct(self, 0, ip_free, 0); +} + +static VALUE +ip_init(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + struct tcltkip *ptr; /* tcltkip data struct */ + VALUE argv0, opts; + int cnt; + int with_tk = 1; + Tk_Window mainWin; + + /* security check */ + if (ruby_safe_level >= 4) { + rb_raise(rb_eSecurityError, "Cannot create a TclTkIp object at level %d", ruby_safe_level); + } + + /* create object */ + Data_Get_Struct(self, struct tcltkip, ptr); + ptr = ALLOC(struct tcltkip); + DATA_PTR(self) = ptr; + ptr->ref_count = 0; + ptr->allow_ruby_exit = 1; + ptr->return_value = 0; + + /* from Tk_Main() */ + DUMP1("Tcl_CreateInterp"); + ptr->ip = Tcl_CreateInterp(); + if (ptr->ip == NULL) { + rb_raise(rb_eRuntimeError, "fail to create a new Tk interpreter"); + } + + rbtk_preserve_ip(ptr); + DUMP2("IP ref_count = %d", ptr->ref_count); + current_interp = ptr->ip; + + ptr->has_orig_exit + = Tcl_GetCommandInfo(ptr->ip, "exit", &(ptr->orig_exit_info)); + + /* from Tcl_AppInit() */ + DUMP1("Tcl_Init"); + if (Tcl_Init(ptr->ip) == TCL_ERROR) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif + } + + /* set variables */ + cnt = rb_scan_args(argc, argv, "02", &argv0, &opts); + switch(cnt) { + case 2: + /* options */ + if (NIL_P(opts) || opts == Qfalse) { + /* without Tk */ + with_tk = 0; + } else { + /* Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), 0); */ + Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), TCL_GLOBAL_ONLY); + } + case 1: + /* argv0 */ + if (!NIL_P(argv0)) { + if (strncmp(StringValuePtr(argv0), "-e", 3) == 0 + || strncmp(StringValuePtr(argv0), "-", 2) == 0) { + Tcl_SetVar(ptr->ip, "argv0", "ruby", TCL_GLOBAL_ONLY); + } else { + /* Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0); */ + Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), + TCL_GLOBAL_ONLY); + } + } + case 0: + /* no args */ + ; + } + + /* from Tcl_AppInit() */ + if (with_tk) { + DUMP1("Tk_Init"); + if (Tk_Init(ptr->ip) == TCL_ERROR) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif + } + DUMP1("Tcl_StaticPackage(\"Tk\")"); +#if TCL_MAJOR_VERSION >= 8 + Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, Tk_SafeInit); +#else /* TCL_MAJOR_VERSION < 8 */ + Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, + (Tcl_PackageInitProc *) NULL); +#endif + } + + /* get main window */ + mainWin = Tk_MainWindow(ptr->ip); + Tk_Preserve((ClientData)mainWin); + + /* add ruby command to the interpreter */ +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"ruby\")"); + Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL, + (Tcl_CmdDeleteProc *)NULL); + DUMP1("Tcl_CreateObjCommand(\"ruby_eval\")"); + Tcl_CreateObjCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL, + (Tcl_CmdDeleteProc *)NULL); + DUMP1("Tcl_CreateObjCommand(\"ruby_cmd\")"); + Tcl_CreateObjCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL, + (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"ruby\")"); + Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL, + (Tcl_CmdDeleteProc *)NULL); + DUMP1("Tcl_CreateCommand(\"ruby_eval\")"); + Tcl_CreateCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL, + (Tcl_CmdDeleteProc *)NULL); + DUMP1("Tcl_CreateCommand(\"ruby_cmd\")"); + Tcl_CreateCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL, + (Tcl_CmdDeleteProc *)NULL); +#endif + + /* add 'interp_exit', 'ruby_exit' and replace 'exit' command */ +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"interp_exit\")"); + Tcl_CreateObjCommand(ptr->ip, "interp_exit", ip_InterpExitObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); + DUMP1("Tcl_CreateObjCommand(\"ruby_exit\")"); + Tcl_CreateObjCommand(ptr->ip, "ruby_exit", ip_RubyExitObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); + DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\""); + Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"interp_exit\")"); + Tcl_CreateCommand(ptr->ip, "interp_exit", ip_InterpExitCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); + DUMP1("Tcl_CreateCommand(\"ruby_exit\")"); + Tcl_CreateCommand(ptr->ip, "ruby_exit", ip_RubyExitCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); + DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\""); + Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#endif + +#if 0 /* + Disable the following "update" and "thread_update". Bcause, + they don't work in a callback-proc. After calling update in + a callback-proc, the callback proc never be worked. + If the problem will be fixed in the future, may enable the + functions. + */ + /* replace 'update' command */ +# if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"update\")"); + Tcl_CreateObjCommand(ptr->ip, "update", ip_rbUpdateObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +# else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"update\")"); + Tcl_CreateCommand(ptr->ip, "update", ip_rbUpdateCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +# endif + + /* add 'thread_update' command */ +# if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"thread_update\")"); + Tcl_CreateObjCommand(ptr->ip, "thread_update", ip_rb_threadUpdateObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +# else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"thread_update\")"); + Tcl_CreateCommand(ptr->ip, "thread_update", ip_rb_threadUpdateCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +# endif +#endif + + /* replace 'vwait' command */ +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"vwait\")"); + Tcl_CreateObjCommand(ptr->ip, "vwait", ip_rbVwaitObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"vwait\")"); + Tcl_CreateCommand(ptr->ip, "vwait", ip_rbVwaitCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#endif + + /* replace 'tkwait' command */ +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"tkwait\")"); + Tcl_CreateObjCommand(ptr->ip, "tkwait", ip_rbTkWaitObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"tkwait\")"); + Tcl_CreateCommand(ptr->ip, "tkwait", ip_rbTkWaitCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#endif + + /* add 'thread_vwait' command */ +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"thread_vwait\")"); + Tcl_CreateObjCommand(ptr->ip, "thread_vwait", ip_rb_threadVwaitObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"thread_vwait\")"); + Tcl_CreateCommand(ptr->ip, "thread_vwait", ip_rb_threadVwaitCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#endif + + /* add 'thread_tkwait' command */ +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"thread_tkwait\")"); + Tcl_CreateObjCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"thread_tkwait\")"); + Tcl_CreateCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#endif + + Tk_Release((ClientData)mainWin); + + return self; +} + +static VALUE +ip_create_slave(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + struct tcltkip *master = get_ip(self); + struct tcltkip *slave = ALLOC(struct tcltkip); + VALUE safemode; + VALUE name; + int safe; + int thr_crit_bup; + Tk_Window mainWin; + + /* safe-mode check */ + if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) { + safemode = Qfalse; + } + if (Tcl_IsSafe(master->ip) == 1) { + safe = 1; + } else if (safemode == Qfalse || NIL_P(safemode)) { + safe = 0; + rb_secure(4); + } else { + safe = 1; + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* ip is deleted? */ + if (Tcl_InterpDeleted(master->ip)) { + DUMP1("master-ip is deleted"); + rb_thread_critical = thr_crit_bup; + rb_raise(rb_eRuntimeError, "deleted master cannot create a new slave interpreter"); + } + + /* create slave-ip */ + slave->ref_count = 0; + slave->allow_ruby_exit = 0; + slave->return_value = 0; + + slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe); + if (slave->ip == NULL) { + rb_thread_critical = thr_crit_bup; + rb_raise(rb_eRuntimeError, "fail to create the new slave interpreter"); + } + rbtk_preserve_ip(slave); + + slave->has_orig_exit + = Tcl_GetCommandInfo(slave->ip, "exit", &(slave->orig_exit_info)); + + /* replace 'exit' command --> 'interp_exit' command */ + mainWin = Tk_MainWindow(slave->ip); +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\""); + Tcl_CreateObjCommand(slave->ip, "exit", ip_InterpExitObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\""); + Tcl_CreateCommand(slave->ip, "exit", ip_InterpExitCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#endif + + rb_thread_critical = thr_crit_bup; + + return Data_Wrap_Struct(CLASS_OF(self), 0, ip_free, slave); +} + +/* make ip "safe" */ +static VALUE +ip_make_safe(self) + VALUE self; +{ + struct tcltkip *ptr = get_ip(self); + Tk_Window mainWin; + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + rb_raise(rb_eRuntimeError, "interpreter is deleted"); + } + + if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif + } + + ptr->allow_ruby_exit = 0; + + /* replace 'exit' command --> 'interp_exit' command */ + mainWin = Tk_MainWindow(ptr->ip); +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\""); + Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\""); + Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#endif + + return self; +} + +/* is safe? */ +static VALUE +ip_is_safe_p(self) + VALUE self; +{ + struct tcltkip *ptr = get_ip(self); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + rb_raise(rb_eRuntimeError, "interpreter is deleted"); + } + + if (Tcl_IsSafe(ptr->ip)) { + return Qtrue; + } else { + return Qfalse; + } +} + +/* allow_ruby_exit? */ +static VALUE +ip_allow_ruby_exit_p(self) + VALUE self; +{ + struct tcltkip *ptr = get_ip(self); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + rb_raise(rb_eRuntimeError, "interpreter is deleted"); + } + + if (ptr->allow_ruby_exit) { + return Qtrue; + } else { + return Qfalse; + } +} + +/* allow_ruby_exit = mode */ +static VALUE +ip_allow_ruby_exit_set(self, val) + VALUE self, val; +{ + struct tcltkip *ptr = get_ip(self); + Tk_Window mainWin; + + rb_secure(4); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + rb_raise(rb_eRuntimeError, "interpreter is deleted"); + } + + if (Tcl_IsSafe(ptr->ip)) { + rb_raise(rb_eSecurityError, + "insecure operation on a safe interpreter"); + } + + mainWin = Tk_MainWindow(ptr->ip); + + if (RTEST(val)) { + ptr->allow_ruby_exit = 1; +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\""); + Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\""); + Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#endif + return Qtrue; + + } else { + ptr->allow_ruby_exit = 0; +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\""); + Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\""); + Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#endif + return Qfalse; + } +} + +/* delete interpreter */ +static VALUE +ip_delete(self) + VALUE self; +{ + Tcl_CmdInfo info; + struct tcltkip *ptr = get_ip(self); + + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + + DUMP1("delete slaves"); + delete_slaves(ptr->ip); + + DUMP1("finalize operation"); + if (Tcl_Eval(ptr->ip, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) { + if (Tcl_GetCommandInfo(ptr->ip, CANCEL_AFTER_SCRIPTS, &info)) { + DUMP2("call cancel after scripts proc '%s'", + CANCEL_AFTER_SCRIPTS); + Tcl_Eval(ptr->ip, CANCEL_AFTER_SCRIPTS); + } + } + + if (Tcl_GetCommandInfo(ptr->ip, finalize_hook_name, &info)) { + DUMP2("call finalize hook proc '%s'", finalize_hook_name); + Tcl_Eval(ptr->ip, finalize_hook_name); + } + + del_root(ptr->ip); + + DUMP1("delete interp"); + /* while(!rbtk_InterpDeleted(ptr->ip)) { */ + if (!Tcl_InterpDeleted(ptr->ip)) { + DUMP1("wait ip is deleted"); + Tcl_DeleteInterp(ptr->ip); + } + + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + + return Qnil; +} + +/* is deleted? */ +static int +ip_null_namespace(interp) + Tcl_Interp *interp; +{ +#if TCL_MAJOR_VERSION < 8 + return 0; +#else /* support Namespace */ + return ( Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL ); +#endif +} + +static VALUE +ip_has_null_namespace_p(self) + VALUE self; +{ + struct tcltkip *ptr = get_ip(self); + + if (ip_null_namespace(ptr->ip)) { + return Qtrue; + } else { + return Qfalse; + } +} + +static VALUE +ip_is_deleted_p(self) + VALUE self; +{ + struct tcltkip *ptr = get_ip(self); + + if (Tcl_InterpDeleted(ptr->ip)) { + return Qtrue; + } else { + return Qfalse; + } +} + + +static VALUE +#ifdef HAVE_STDARG_PROTOTYPES +create_ip_exc(VALUE interp, VALUE exc, const char *fmt, ...) +#else +create_ip_exc(interp, exc, fmt, va_alist) + VALUE interp: + VALUE exc; + const char *fmt; + va_dcl +#endif +{ + va_list args; + char buf[BUFSIZ]; + VALUE einfo; + + va_init_list(args,fmt); + vsnprintf(buf, BUFSIZ, fmt, args); + buf[BUFSIZ - 1] = '\0'; + va_end(args); + einfo = rb_exc_new2(exc, buf); + rb_ivar_set(einfo, ID_at_interp, interp); + Tcl_ResetResult(get_ip(interp)->ip); + + return einfo; +} + +static VALUE +ip_get_result_string_obj(interp) + Tcl_Interp *interp; +{ +#if TCL_MAJOR_VERSION >= 8 + int len; + char *s; + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + s = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len); + if (s == (char*)NULL) { + return rb_tainted_str_new2(""); + } else { + return(rb_tainted_str_new(s, len)); + } + +# else /* TCL_VERSION >= 8.1 */ + volatile VALUE strval; + Tcl_Obj *retobj = Tcl_GetObjResult(interp); + int thr_crit_bup; + + Tcl_IncrRefCount(retobj); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (Tcl_GetCharLength(retobj) != Tcl_UniCharLen(Tcl_GetUnicode(retobj))) { + /* possibly binary string */ + s = Tcl_GetByteArrayFromObj(retobj, &len); + if (s == (char*)NULL) { + strval = rb_tainted_str_new2(""); + } else { + strval = rb_tainted_str_new(s, len); + } + rb_ivar_set(strval, ID_at_enc, rb_str_new2("binary")); + } else { + /* possibly text string */ + s = Tcl_GetStringFromObj(retobj, &len); + if (s == (char*)NULL) { + strval = rb_tainted_str_new2(""); + } else { + strval = rb_tainted_str_new(s, len); + } + } + + rb_thread_critical = thr_crit_bup; + + Tcl_DecrRefCount(retobj); + + return(strval); + +# endif +#else /* TCL_MAJOR_VERSION < 8 */ + return(rb_tainted_str_new2(interp->result)); +#endif +} + +/* eval string in tcl by Tcl_Eval() */ +static VALUE +ip_eval_real(self, cmd_str, cmd_len) + VALUE self; + char *cmd_str; + int cmd_len; +{ + volatile VALUE ret; + char *s; + int len; + struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; + +#if TCL_MAJOR_VERSION >= 8 + /* call Tcl_EvalObj() */ + { + Tcl_Obj *cmd; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + cmd = Tcl_NewStringObj(cmd_str, cmd_len); + Tcl_IncrRefCount(cmd); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + Tcl_DecrRefCount(cmd); + rb_thread_critical = thr_crit_bup; + ptr->return_value = TCL_OK; + return rb_tainted_str_new2(""); + } else { + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + + ptr->return_value = Tcl_EvalObj(ptr->ip, cmd); + /* ptr->return_value = Tcl_GlobalEvalObj(ptr->ip, cmd); */ + } + + Tcl_DecrRefCount(cmd); + + } + + if (ptr->return_value == TCL_ERROR) { + volatile VALUE exc; + exc = create_ip_exc(self, rb_eRuntimeError, + "%s", Tcl_GetStringResult(ptr->ip)); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + + rb_thread_critical = thr_crit_bup; + rb_exc_raise(exc); + } + DUMP2("(TCL_Eval result) %d", ptr->return_value); + + /* pass back the result (as string) */ + ret = ip_get_result_string_obj(ptr->ip); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + return ret; + +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP2("Tcl_Eval(%s)", cmd_str); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + ptr->return_value = TCL_OK; + return rb_tainted_str_new2(""); + } else { + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + ptr->return_value = Tcl_Eval(ptr->ip, cmd_str); + /* ptr->return_value = Tcl_GlobalEval(ptr->ip, cmd_str); */ + } + + if (ptr->return_value == TCL_ERROR) { + volatile VALUE exc; + exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_exc_raise(exc); + } + DUMP2("(TCL_Eval result) %d", ptr->return_value); + + /* pass back the result (as string) */ + ret = ip_get_result_string_obj(ptr->ip); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + return ret; +#endif +} + +static VALUE +evq_safelevel_handler(arg, evq) + VALUE arg; + VALUE evq; +{ + struct eval_queue *q; + + Data_Get_Struct(evq, struct eval_queue, q); + DUMP2("(safe-level handler) $SAFE = %d", q->safe_level); + rb_set_safe_level(q->safe_level); + return ip_eval_real(q->interp, q->str, q->len); +} + +int eval_queue_handler _((Tcl_Event *, int)); +int +eval_queue_handler(evPtr, flags) + Tcl_Event *evPtr; + int flags; +{ + struct eval_queue *q = (struct eval_queue *)evPtr; + volatile VALUE ret; + volatile VALUE q_dat; + + DUMP2("do_eval_queue_handler : evPtr = %p", evPtr); + DUMP2("eval queue_thread : %lx", rb_thread_current()); + DUMP2("added by thread : %lx", q->thread); + + if (*(q->done)) { + DUMP1("processed by another event-loop"); + return 0; + } else { + DUMP1("process it on current event-loop"); + } + + /* process it */ + *(q->done) = 1; + + /* check safe-level */ + if (rb_safe_level() != q->safe_level) { +#ifdef HAVE_NATIVETHREAD + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on eval_queue_handler()"); + } +#endif + /* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */ + q_dat = Data_Wrap_Struct(rb_cData,eval_queue_mark,0,q); + ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat), + ID_call, 0); + rb_gc_force_recycle(q_dat); + } else { + DUMP2("call eval_real (for caller thread:%lx)", q->thread); + DUMP2("call eval_real (current thread:%lx)", rb_thread_current()); + ret = ip_eval_real(q->interp, q->str, q->len); + } + + /* set result */ + RARRAY(q->result)->ptr[0] = ret; + + /* complete */ + *(q->done) = -1; + + /* back to caller */ + DUMP2("back to caller (caller thread:%lx)", q->thread); + DUMP2(" (current thread:%lx)", rb_thread_current()); + rb_thread_run(q->thread); + DUMP1("finish back to caller"); + + /* end of handler : remove it */ + return 1; +} + +static VALUE +ip_eval(self, str) + VALUE self; + VALUE str; +{ + struct eval_queue *evq; + char *eval_str; + int *alloc_done; + int thr_crit_bup; + volatile VALUE current = rb_thread_current(); + volatile VALUE ip_obj = self; + volatile VALUE result; + volatile VALUE ret; + Tcl_QueuePosition position; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + StringValue(str); + rb_thread_critical = thr_crit_bup; + + if (eventloop_thread == 0 || current == eventloop_thread) { + if (eventloop_thread) { + DUMP2("eval from current eventloop %lx", current); + } else { + DUMP2("eval from thread:%lx but no eventloop", current); + } + result = ip_eval_real(self, RSTRING(str)->ptr, RSTRING(str)->len); + if (rb_obj_is_kind_of(result, rb_eException)) { + rb_exc_raise(result); + } + return result; + } + + DUMP2("eval from thread %lx (NOT current eventloop)", current); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* allocate memory (protected from Tcl_ServiceEvent) */ + alloc_done = (int*)ALLOC(int); + *alloc_done = 0; + + eval_str = ALLOC_N(char, RSTRING(str)->len + 1); + strncpy(eval_str, RSTRING(str)->ptr, RSTRING(str)->len); + eval_str[RSTRING(str)->len] = 0; + + /* allocate memory (freed by Tcl_ServiceEvent) */ + evq = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); + Tcl_Preserve(evq); + + /* allocate result obj */ + result = rb_ary_new2(1); + RARRAY(result)->ptr[0] = Qnil; + RARRAY(result)->len = 1; + + /* construct event data */ + evq->done = alloc_done; + evq->str = eval_str; + evq->len = RSTRING(str)->len; + evq->interp = ip_obj; + evq->result = result; + evq->thread = current; + evq->safe_level = rb_safe_level(); + evq->ev.proc = eval_queue_handler; + position = TCL_QUEUE_TAIL; + + /* add the handler to Tcl event queue */ + DUMP1("add handler"); + Tcl_QueueEvent(&(evq->ev), position); + + rb_thread_critical = thr_crit_bup; + + /* wait for the handler to be processed */ + DUMP2("wait for handler (current thread:%lx)", current); + while(*alloc_done >= 0) { + rb_thread_stop(); + } + DUMP2("back from handler (current thread:%lx)", current); + + /* get result & free allocated memory */ + ret = RARRAY(result)->ptr[0]; + + free(alloc_done); + free(eval_str); + Tcl_Release(evq); + + if (rb_obj_is_kind_of(ret, rb_eException)) { + rb_exc_raise(ret); + } + + return ret; +} + + +/* restart Tk */ +static VALUE +lib_restart(self) + VALUE self; +{ + volatile VALUE exc; + struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; + + rb_secure(4); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + rb_raise(rb_eRuntimeError, "interpreter is deleted"); + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + + /* destroy the root wdiget */ + ptr->return_value = Tcl_Eval(ptr->ip, "destroy ."); + /* ignore ERROR */ + DUMP2("(TCL_Eval result) %d", ptr->return_value); + Tcl_ResetResult(ptr->ip); + + /* delete namespace ( tested on tk8.4.5 ) */ + ptr->return_value = Tcl_Eval(ptr->ip, "namespace delete ::tk::msgcat"); + /* ignore ERROR */ + DUMP2("(TCL_Eval result) %d", ptr->return_value); + Tcl_ResetResult(ptr->ip); + + /* delete trace proc ( tested on tk8.4.5 ) */ + ptr->return_value = Tcl_Eval(ptr->ip, "trace vdelete ::tk_strictMotif w ::tk::EventMotifBindings"); + /* ignore ERROR */ + DUMP2("(TCL_Eval result) %d", ptr->return_value); + Tcl_ResetResult(ptr->ip); + + /* execute Tk_Init of Tk_SafeInit */ +#if TCL_MAJOR_VERSION >= 8 + if (Tcl_IsSafe(ptr->ip)) { + DUMP1("Tk_SafeInit"); + if (Tk_SafeInit(ptr->ip) == TCL_ERROR) { + exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + rb_exc_raise(exc); + } + } else { + DUMP1("Tk_Init"); + if (Tk_Init(ptr->ip) == TCL_ERROR) { + exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + rb_exc_raise(exc); + } + } +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tk_Init"); + if (Tk_Init(ptr->ip) == TCL_ERROR) { + exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_exc_raise(exc); + } +#endif + + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + + rb_thread_critical = thr_crit_bup; + + return Qnil; +} + + +static VALUE +ip_restart(self) + VALUE self; +{ + struct tcltkip *ptr = get_ip(self); + + rb_secure(4); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + rb_raise(rb_eRuntimeError, "interpreter is deleted"); + } + + if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { + /* slave IP */ + return Qnil; + } + return lib_restart(self); +} + +static VALUE +lib_toUTF8_core(ip_obj, src, encodename) + VALUE ip_obj; + VALUE src; + VALUE encodename; +{ + volatile VALUE str = src; + +#ifdef TCL_UTF_MAX + Tcl_Interp *interp; + Tcl_Encoding encoding; + Tcl_DString dstr; + int taint_flag = OBJ_TAINTED(str); + struct tcltkip *ptr; + char *buf; + int thr_crit_bup; + + if (NIL_P(ip_obj)) { + interp = (Tcl_Interp *)NULL; + } else { + interp = get_ip(ip_obj)->ip; + + /* ip is deleted? */ + if (Tcl_InterpDeleted(interp)) { + DUMP1("ip is deleted"); + interp = (Tcl_Interp *)NULL; + } + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (NIL_P(encodename)) { + if (TYPE(str) == T_STRING) { + volatile VALUE enc; + + enc = Qnil; + if (RTEST(rb_ivar_defined(str, ID_at_enc))) { + enc = rb_ivar_get(str, ID_at_enc); + } + if (NIL_P(enc)) { + if (NIL_P(ip_obj)) { + encoding = (Tcl_Encoding)NULL; + } else { + if (RTEST(rb_ivar_defined(ip_obj, ID_at_enc))) { + enc = rb_ivar_get(ip_obj, ID_at_enc); + } + if (NIL_P(enc)) { + encoding = (Tcl_Encoding)NULL; + } else { + StringValue(enc); + encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr); + if (encoding == (Tcl_Encoding)NULL) { + rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING(enc)->ptr); + } + } + } + } else { + StringValue(enc); + if (strcmp(RSTRING(enc)->ptr, "binary") == 0) { + rb_thread_critical = thr_crit_bup; + return str; + } + encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr); + if (encoding == (Tcl_Encoding)NULL) { + rb_warning("string has unknown encoding information (@encoding:'%s')", RSTRING(enc)->ptr); + } + } + } else { + encoding = (Tcl_Encoding)NULL; + } + } else { + StringValue(encodename); + encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr); + if (encoding == (Tcl_Encoding)NULL) { + /* + rb_warning("unknown encoding name '%s'", + RSTRING(encodename)->ptr); + */ + rb_raise(rb_eArgError, "unknown encoding name '%s'", + RSTRING(encodename)->ptr); + } + } + + StringValue(str); + if (!RSTRING(str)->len) { + rb_thread_critical = thr_crit_bup; + return str; + } + + buf = ALLOC_N(char,(RSTRING(str)->len)+1); + strncpy(buf, RSTRING(str)->ptr, RSTRING(str)->len); + buf[RSTRING(str)->len] = 0; + + Tcl_DStringInit(&dstr); + Tcl_DStringFree(&dstr); + /* Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr); */ + Tcl_ExternalToUtfDString(encoding, buf, RSTRING(str)->len, &dstr); + + /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */ + str = rb_str_new2(Tcl_DStringValue(&dstr)); + rb_ivar_set(str, ID_at_enc, rb_tainted_str_new2("utf-8")); + if (taint_flag) OBJ_TAINT(str); + + if (encoding != (Tcl_Encoding)NULL) { + Tcl_FreeEncoding(encoding); + } + Tcl_DStringFree(&dstr); + + free(buf); + + rb_thread_critical = thr_crit_bup; +#endif + + return str; +} + +static VALUE +lib_toUTF8(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + VALUE str, encodename; + + if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { + encodename = Qnil; + } + return lib_toUTF8_core(Qnil, str, encodename); +} + +static VALUE +ip_toUTF8(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + VALUE str, encodename; + + if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { + encodename = Qnil; + } + return lib_toUTF8_core(self, str, encodename); +} + +static VALUE +lib_fromUTF8_core(ip_obj, src, encodename) + VALUE ip_obj; + VALUE src; + VALUE encodename; +{ + volatile VALUE str = src; + +#ifdef TCL_UTF_MAX + Tcl_Interp *interp; + Tcl_Encoding encoding; + Tcl_DString dstr; + int taint_flag = OBJ_TAINTED(str); + char *buf; + int thr_crit_bup; + + if (NIL_P(ip_obj)) { + interp = (Tcl_Interp *)NULL; + } else { + interp = get_ip(ip_obj)->ip; + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (NIL_P(encodename)) { + volatile VALUE enc; + + if (TYPE(str) == T_STRING) { + enc = Qnil; + if (RTEST(rb_ivar_defined(str, ID_at_enc))) { + enc = rb_ivar_get(str, ID_at_enc); + } + if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) { + rb_thread_critical = thr_crit_bup; + return str; + } + } + + if (NIL_P(ip_obj)) { + encoding = (Tcl_Encoding)NULL; + } else { + enc = Qnil; + if (RTEST(rb_ivar_defined(ip_obj, ID_at_enc))) { + enc = rb_ivar_get(ip_obj, ID_at_enc); + } + if (NIL_P(enc)) { + encoding = (Tcl_Encoding)NULL; + } else { + StringValue(enc); + encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr); + if (encoding == (Tcl_Encoding)NULL) { + rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING(enc)->ptr); + } else { + encodename = rb_obj_dup(enc); + } + } + } + + } else { + StringValue(encodename); + + if (strcmp(RSTRING(encodename)->ptr, "binary") == 0) { + char *s; + int len; + + s = Tcl_GetByteArrayFromObj(Tcl_NewStringObj(RSTRING(str)->ptr, + RSTRING(str)->len), + &len); + str = rb_tainted_str_new(s, len); + rb_ivar_set(str, ID_at_enc, rb_tainted_str_new2("binary")); + + rb_thread_critical = thr_crit_bup; + return str; + } + + encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr); + if (encoding == (Tcl_Encoding)NULL) { + /* + rb_warning("unknown encoding name '%s'", + RSTRING(encodename)->ptr); + encodename = Qnil; + */ + rb_raise(rb_eArgError, "unknown encoding name '%s'", + RSTRING(encodename)->ptr); + } + } + + StringValue(str); + + if (RSTRING(str)->len == 0) { + rb_thread_critical = thr_crit_bup; + return rb_tainted_str_new2(""); + } + + buf = ALLOC_N(char,strlen(RSTRING(str)->ptr)+1); + strncpy(buf, RSTRING(str)->ptr, RSTRING(str)->len); + buf[RSTRING(str)->len] = 0; + + Tcl_DStringInit(&dstr); + Tcl_DStringFree(&dstr); + /* Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr); */ + Tcl_UtfToExternalDString(encoding,buf,RSTRING(str)->len,&dstr); + + /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */ + str = rb_str_new2(Tcl_DStringValue(&dstr)); + rb_ivar_set(str, ID_at_enc, encodename); + + if (taint_flag) OBJ_TAINT(str); + + if (encoding != (Tcl_Encoding)NULL) { + Tcl_FreeEncoding(encoding); + } + Tcl_DStringFree(&dstr); + + free(buf); + + rb_thread_critical = thr_crit_bup; +#endif + + return str; +} + +static VALUE +lib_fromUTF8(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + VALUE str, encodename; + + if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { + encodename = Qnil; + } + return lib_fromUTF8_core(Qnil, str, encodename); +} + +static VALUE +ip_fromUTF8(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + VALUE str, encodename; + + if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { + encodename = Qnil; + } + return lib_fromUTF8_core(self, str, encodename); +} + +static VALUE +lib_UTF_backslash_core(self, str, all_bs) + VALUE self; + VALUE str; + int all_bs; +{ +#ifdef TCL_UTF_MAX + char *src_buf, *dst_buf, *ptr; + int read_len = 0, dst_len = 0; + int taint_flag = OBJ_TAINTED(str); + int thr_crit_bup; + + StringValue(str); + if (!RSTRING(str)->len) { + return str; + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + src_buf = ALLOC_N(char,(RSTRING(str)->len)+1); + strncpy(src_buf, RSTRING(str)->ptr, RSTRING(str)->len); + src_buf[RSTRING(str)->len] = 0; + + dst_buf = ALLOC_N(char,(RSTRING(str)->len)+1); + + ptr = src_buf; + while(RSTRING(str)->len > ptr - src_buf) { + if (*ptr == '\\' && (all_bs || *(ptr + 1) == 'u')) { + dst_len += Tcl_UtfBackslash(ptr, &read_len, (dst_buf + dst_len)); + ptr += read_len; + } else { + *(dst_buf + (dst_len++)) = *(ptr++); + } + } + + str = rb_str_new(dst_buf, dst_len); + if (taint_flag) OBJ_TAINT(str); + + free(src_buf); + free(dst_buf); + + rb_thread_critical = thr_crit_bup; +#endif + + return str; +} + +static VALUE +lib_UTF_backslash(self, str) + VALUE self; + VALUE str; +{ + return lib_UTF_backslash_core(self, str, 0); +} + +static VALUE +lib_Tcl_backslash(self, str) + VALUE self; + VALUE str; +{ + return lib_UTF_backslash_core(self, str, 1); +} + +#if TCL_MAJOR_VERSION >= 8 +static VALUE +ip_invoke_core(interp, objc, objv) + VALUE interp; + int objc; + Tcl_Obj **objv; +#else +static VALUE +ip_invoke_core(interp, argc, argv) + VALUE interp; + int argc; + char **argv; +#endif +{ + struct tcltkip *ptr; + int i; + Tcl_CmdInfo info; + char *cmd; + char *s; + int len; + int thr_crit_bup; + +#if TCL_MAJOR_VERSION >= 8 + int argc = objc; + char **argv = (char **)NULL; + Tcl_Obj *resultPtr; +#endif + + /* get the command name string */ +#if TCL_MAJOR_VERSION >= 8 + cmd = Tcl_GetStringFromObj(objv[0], &len); +#else /* TCL_MAJOR_VERSION < 8 */ + cmd = argv[0]; +#endif + + /* get the data struct */ + ptr = get_ip(interp); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + return rb_tainted_str_new2(""); + } + + /* map from the command name to a C procedure */ + DUMP2("call Tcl_GetCommandInfo, %s", cmd); + if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) { + DUMP1("error Tcl_GetCommandInfo"); + /* if (event_loop_abort_on_exc || cmd[0] != '.') { */ + if (event_loop_abort_on_exc > 0) { + /*rb_ip_raise(obj,rb_eNameError,"invalid command name `%s'",cmd);*/ + return create_ip_exc(interp, rb_eNameError, + "invalid command name `%s'", cmd); + } else { + if (event_loop_abort_on_exc < 0) { + rb_warning("invalid command name `%s' (ignore)", cmd); + } else { + rb_warn("invalid command name `%s' (ignore)", cmd); + } + Tcl_ResetResult(ptr->ip); + return rb_tainted_str_new2(""); + } + } + DUMP1("end Tcl_GetCommandInfo"); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* memory allocation for arguments of this command */ +#if TCL_MAJOR_VERSION >= 8 + if (!info.isNativeObjectProc) { + /* string interface */ + argv = (char **)ALLOC_N(char *, argc+1); + for (i = 0; i < argc; ++i) { + argv[i] = Tcl_GetStringFromObj(objv[i], &len); + } + argv[argc] = (char *)NULL; + } +#endif + + Tcl_ResetResult(ptr->ip); + + /* Invoke the C procedure */ +#if TCL_MAJOR_VERSION >= 8 + if (info.isNativeObjectProc) { + ptr->return_value = (*info.objProc)(info.objClientData, ptr->ip, + objc, objv); +#if 0 + /* get the string value from the result object */ + resultPtr = Tcl_GetObjResult(ptr->ip); + Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &len), + TCL_VOLATILE); +#endif + } + else +#endif + { +#if TCL_MAJOR_VERSION >= 8 + ptr->return_value = (*info.proc)(info.clientData, ptr->ip, + argc, (CONST84 char **)argv); + + free(argv); + +#else /* TCL_MAJOR_VERSION < 8 */ + ptr->return_value = (*info.proc)(info.clientData, ptr->ip, + argc, argv); +#endif + } + + rb_thread_critical = thr_crit_bup; + + /* exception on mainloop */ + if (ptr->return_value == TCL_ERROR) { + if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) { +#if TCL_MAJOR_VERSION >= 8 + return create_ip_exc(interp, rb_eRuntimeError, + "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + return create_ip_exc(interp, rb_eRuntimeError, + "%s", ptr->ip->result); +#endif + } else { + if (event_loop_abort_on_exc < 0) { +#if TCL_MAJOR_VERSION >= 8 + rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_warning("%s (ignore)", ptr->ip->result); +#endif + } else { +#if TCL_MAJOR_VERSION >= 8 + rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_warn("%s (ignore)", ptr->ip->result); +#endif + } + Tcl_ResetResult(ptr->ip); + return rb_tainted_str_new2(""); + } + } + + /* pass back the result (as string) */ + return ip_get_result_string_obj(ptr->ip); +} + + +#if TCL_MAJOR_VERSION >= 8 +static Tcl_Obj ** +#else /* TCL_MAJOR_VERSION < 8 */ +static char ** +#endif +alloc_invoke_arguments(argc, argv) + int argc; + VALUE *argv; +{ + int i; + VALUE v; + char *s; + int thr_crit_bup; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_Obj **av = (Tcl_Obj **)NULL; + Tcl_Obj *resultPtr; +#else /* TCL_MAJOR_VERSION < 8 */ + char **av = (char **)NULL; +#endif + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* memory allocation */ +#if TCL_MAJOR_VERSION >= 8 + av = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, argc+1); + for (i = 0; i < argc; ++i) { + VALUE enc; + + v = argv[i]; + s = StringValuePtr(v); + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + av[i] = Tcl_NewStringObj(s, RSTRING(v)->len); +# else /* TCL_VERSION >= 8.1 */ + enc = Qnil; + if (RTEST(rb_ivar_defined(v, ID_at_enc))) { + enc = rb_ivar_get(v, ID_at_enc); + } + if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) { + /* binary string */ + av[i] = Tcl_NewByteArrayObj(s, RSTRING(v)->len); + } else if (strlen(s) != RSTRING(v)->len) { + /* probably binary string */ + av[i] = Tcl_NewByteArrayObj(s, RSTRING(v)->len); + } else { + /* probably text string */ + av[i] = Tcl_NewStringObj(s, RSTRING(v)->len); + } +# endif + Tcl_IncrRefCount(av[i]); + } + av[argc] = (Tcl_Obj *)NULL; + +#else /* TCL_MAJOR_VERSION < 8 */ + /* string interface */ + av = (char **)ALLOC_N(char *, argc+1); + for (i = 0; i < argc; ++i) { + v = argv[i]; + s = StringValuePtr(v); + av[i] = ALLOC_N(char, strlen(s)+1); + strcpy(av[i], s); + } + av[argc] = (char *)NULL; +#endif + + rb_thread_critical = thr_crit_bup; + + return av; +} + +static void +free_invoke_arguments(argc, av) + int argc; +#if TCL_MAJOR_VERSION >= 8 + Tcl_Obj **av; +#else /* TCL_MAJOR_VERSION < 8 */ + char **av; +#endif +{ + int i; + + for (i = 0; i < argc; ++i) { +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(av[i]); +#else /* TCL_MAJOR_VERSION < 8 */ + free(av[i]); +#endif + } + free(av); +} + +static VALUE +ip_invoke_real(argc, argv, interp) + int argc; + VALUE *argv; + VALUE interp; +{ + VALUE v; + struct tcltkip *ptr; /* tcltkip data struct */ + int i; + Tcl_CmdInfo info; + char *s; + int len; + int thr_crit_bup; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_Obj **av = (Tcl_Obj **)NULL; + Tcl_Obj *resultPtr; +#else /* TCL_MAJOR_VERSION < 8 */ + char **av = (char **)NULL; +#endif + + DUMP2("invoke_real called by thread:%lx", rb_thread_current()); + + /* allocate memory for arguments */ + av = alloc_invoke_arguments(argc, argv); + + /* get the data struct */ + ptr = get_ip(interp); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + return rb_tainted_str_new2(""); + } + + /* Invoke the C procedure */ + Tcl_ResetResult(ptr->ip); + v = ip_invoke_core(interp, argc, av); + + /* free allocated memory */ + free_invoke_arguments(argc, av); + + return v; +} + +VALUE +ivq_safelevel_handler(arg, ivq) + VALUE arg; + VALUE ivq; +{ + struct invoke_queue *q; + + Data_Get_Struct(ivq, struct invoke_queue, q); + DUMP2("(safe-level handler) $SAFE = %d", q->safe_level); + rb_set_safe_level(q->safe_level); + return ip_invoke_core(q->interp, q->argc, q->argv); +} + +int invoke_queue_handler _((Tcl_Event *, int)); +int +invoke_queue_handler(evPtr, flags) + Tcl_Event *evPtr; + int flags; +{ + struct invoke_queue *q = (struct invoke_queue *)evPtr; + volatile VALUE ret; + volatile VALUE q_dat; + + DUMP2("do_invoke_queue_handler : evPtr = %p", evPtr); + DUMP2("invoke queue_thread : %lx", rb_thread_current()); + DUMP2("added by thread : %lx", q->thread); + + if (*(q->done)) { + DUMP1("processed by another event-loop"); + return 0; + } else { + DUMP1("process it on current event-loop"); + } + + /* process it */ + *(q->done) = 1; + + /* check safe-level */ + if (rb_safe_level() != q->safe_level) { + /* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */ + q_dat = Data_Wrap_Struct(rb_cData,invoke_queue_mark,0,q); + ret = rb_funcall(rb_proc_new(ivq_safelevel_handler, q_dat), + ID_call, 0); + rb_gc_force_recycle(q_dat); + } else { + DUMP2("call invoke_real (for caller thread:%lx)", q->thread); + DUMP2("call invoke_real (current thread:%lx)", rb_thread_current()); + ret = ip_invoke_core(q->interp, q->argc, q->argv); + } + + /* set result */ + RARRAY(q->result)->ptr[0] = ret; + + /* complete */ + *(q->done) = -1; + + /* back to caller */ + DUMP2("back to caller (caller thread:%lx)", q->thread); + DUMP2(" (current thread:%lx)", rb_thread_current()); + rb_thread_run(q->thread); + DUMP1("finish back to caller"); + + /* end of handler : remove it */ + return 1; +} + +static VALUE +ip_invoke_with_position(argc, argv, obj, position) + int argc; + VALUE *argv; + VALUE obj; + Tcl_QueuePosition position; +{ + struct invoke_queue *ivq; + char *s; + int len; + int i; + int *alloc_done; + int thr_crit_bup; + volatile VALUE current = rb_thread_current(); + volatile VALUE ip_obj = obj; + volatile VALUE result; + volatile VALUE ret; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_Obj **av = (Tcl_Obj **)NULL; +#else /* TCL_MAJOR_VERSION < 8 */ + char **av = (char **)NULL; +#endif + + if (argc < 1) { + rb_raise(rb_eArgError, "command name missing"); + } + if (eventloop_thread == 0 || current == eventloop_thread) { + if (eventloop_thread) { + DUMP2("invoke from current eventloop %lx", current); + } else { + DUMP2("invoke from thread:%lx but no eventloop", current); + } + result = ip_invoke_real(argc, argv, ip_obj); + if (rb_obj_is_kind_of(result, rb_eException)) { + rb_exc_raise(result); + } + return result; + } + + DUMP2("invoke from thread %lx (NOT current eventloop)", current); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* allocate memory (for arguments) */ + av = alloc_invoke_arguments(argc, argv); + + /* allocate memory (keep result) */ + alloc_done = (int*)ALLOC(int); + *alloc_done = 0; + + /* allocate memory (freed by Tcl_ServiceEvent) */ + ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); + Tcl_Preserve(ivq); + + /* allocate result obj */ + result = rb_ary_new2(1); + RARRAY(result)->ptr[0] = Qnil; + RARRAY(result)->len = 1; + + /* construct event data */ + ivq->done = alloc_done; + ivq->argc = argc; + ivq->argv = av; + ivq->interp = ip_obj; + ivq->result = result; + ivq->thread = current; + ivq->safe_level = rb_safe_level(); + ivq->ev.proc = invoke_queue_handler; + + /* add the handler to Tcl event queue */ + DUMP1("add handler"); + Tcl_QueueEvent(&(ivq->ev), position); + + rb_thread_critical = thr_crit_bup; + + /* wait for the handler to be processed */ + DUMP2("wait for handler (current thread:%lx)", current); + while(*alloc_done >= 0) { + rb_thread_stop(); + } + DUMP2("back from handler (current thread:%lx)", current); + + /* get result & free allocated memory */ + ret = RARRAY(result)->ptr[0]; + free(alloc_done); + + Tcl_Release(ivq); + + /* free allocated memory */ + free_invoke_arguments(argc, av); + + /* exception? */ + if (rb_obj_is_kind_of(ret, rb_eException)) { + DUMP1("raise exception"); + rb_exc_raise(ret); + } + + DUMP1("exit ip_invoke"); + return ret; +} + + +/* get return code from Tcl_Eval() */ +static VALUE +ip_retval(self) + VALUE self; +{ + struct tcltkip *ptr; /* tcltkip data struct */ + + /* get the data strcut */ + ptr = get_ip(self); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + return rb_tainted_str_new2(""); + } + + return (INT2FIX(ptr->return_value)); +} + +static VALUE +ip_invoke(argc, argv, obj) + int argc; + VALUE *argv; + VALUE obj; +{ + return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_TAIL); +} + +static VALUE +ip_invoke_immediate(argc, argv, obj) + int argc; + VALUE *argv; + VALUE obj; +{ + return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_HEAD); +} + +/* access Tcl variables */ +static VALUE +ip_get_variable(self, varname_arg, flag_arg) + VALUE self; + VALUE varname_arg; + VALUE flag_arg; +{ + struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; + volatile VALUE varname, flag; + + varname = varname_arg; + flag = flag_arg; + + StringValue(varname); + +#if TCL_MAJOR_VERSION >= 8 + { + Tcl_Obj *nameobj, *ret; + char *s; + int len; + volatile VALUE strval; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr, + RSTRING(varname)->len); + Tcl_IncrRefCount(nameobj); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + Tcl_DecrRefCount(nameobj); + rb_thread_critical = thr_crit_bup; + return rb_tainted_str_new2(""); + } else { + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + ret = Tcl_ObjGetVar2(ptr->ip, nameobj, (Tcl_Obj*)NULL, + FIX2INT(flag)); + } + + Tcl_DecrRefCount(nameobj); + + if (ret == (Tcl_Obj*)NULL) { + volatile VALUE exc; +#if TCL_MAJOR_VERSION >= 8 + exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result); +#endif + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + rb_exc_raise(exc); + } + + Tcl_IncrRefCount(ret); + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + Tcl_DecrRefCount(ret); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + return(strval); + +# else /* TCL_VERSION >= 8.1 */ + if (Tcl_GetCharLength(ret) + != Tcl_UniCharLen(Tcl_GetUnicode(ret))) { + /* possibly binary string */ + s = Tcl_GetByteArrayFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + rb_ivar_set(strval, ID_at_enc, rb_tainted_str_new2("binary")); + } else { + /* possibly text string */ + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + } + + Tcl_DecrRefCount(ret); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + + return(strval); +# endif + } +#else /* TCL_MAJOR_VERSION < 8 */ + { + char *ret; + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + return rb_tainted_str_new2(""); + } else { + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + ret = Tcl_GetVar2(ptr->ip, RSTRING(varname)->ptr, + (char*)NULL, FIX2INT(flag)); + } + + if (ret == (char*)NULL) { + volatile VALUE exc; +#if TCL_MAJOR_VERSION >= 8 + exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result); +#endif + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + rb_exc_raise(exc); + } + + strval = rb_tainted_str_new2(ret); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + + return(strval); + } +#endif +} + +static VALUE +ip_get_variable2(self, varname_arg, index_arg, flag_arg) + VALUE self; + VALUE varname_arg; + VALUE index_arg; + VALUE flag_arg; +{ + struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; + volatile VALUE varname, index, flag; + + if (NIL_P(index_arg)) { + return ip_get_variable(self, varname_arg, flag_arg); + } + + varname = varname_arg; + index = index_arg; + flag = flag_arg; + + StringValue(varname); + StringValue(index); + +#if TCL_MAJOR_VERSION >= 8 + { + Tcl_Obj *nameobj, *idxobj, *ret; + char *s; + int len; + volatile VALUE strval; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr, + RSTRING(varname)->len); + Tcl_IncrRefCount(nameobj); + idxobj = Tcl_NewStringObj(RSTRING(index)->ptr, RSTRING(index)->len); + Tcl_IncrRefCount(idxobj); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + Tcl_DecrRefCount(nameobj); + Tcl_DecrRefCount(idxobj); + rb_thread_critical = thr_crit_bup; + return rb_tainted_str_new2(""); + } else { + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + ret = Tcl_ObjGetVar2(ptr->ip, nameobj, idxobj, FIX2INT(flag)); + } + + Tcl_DecrRefCount(nameobj); + Tcl_DecrRefCount(idxobj); + + if (ret == (Tcl_Obj*)NULL) { + volatile VALUE exc; +#if TCL_MAJOR_VERSION >= 8 + exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result); +#endif + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + rb_exc_raise(exc); + } + + Tcl_IncrRefCount(ret); + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + Tcl_DecrRefCount(ret); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + return(strval); + +# else /* TCL_VERSION >= 8.1 */ + if (Tcl_GetCharLength(ret) + != Tcl_UniCharLen(Tcl_GetUnicode(ret))) { + /* possibly binary string */ + s = Tcl_GetByteArrayFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + rb_ivar_set(strval, ID_at_enc, rb_tainted_str_new2("binary")); + } else { + /* possibly text string */ + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + } + + Tcl_DecrRefCount(ret); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + + return(strval); +# endif + } +#else /* TCL_MAJOR_VERSION < 8 */ + { + char *ret; + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + return rb_tainted_str_new2(""); + } else { + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + ret = Tcl_GetVar2(ptr->ip, RSTRING(varname)->ptr, + RSTRING(index)->ptr, FIX2INT(flag)); + } + + if (ret == (char*)NULL) { + volatile VALUE exc; +#if TCL_MAJOR_VERSION >= 8 + exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result); +#endif + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + rb_exc_raise(exc); + } + + strval = rb_tainted_str_new2(ret); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + + return(strval); + } +#endif +} + +static VALUE +ip_set_variable(self, varname_arg, value_arg, flag_arg) + VALUE self; + VALUE varname_arg; + VALUE value_arg; + VALUE flag_arg; +{ + struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; + volatile VALUE varname, value, flag; + + varname = varname_arg; + value = value_arg; + flag = flag_arg; + + StringValue(varname); + StringValue(value); + +#if TCL_MAJOR_VERSION >= 8 + { + Tcl_Obj *nameobj, *valobj, *ret; + char *s; + int len; + volatile VALUE strval; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr, + RSTRING(varname)->len); + + Tcl_IncrRefCount(nameobj); + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + valobj = Tcl_NewStringObj(RSTRING(value)->ptr, + RSTRING(value)->len); + Tcl_IncrRefCount(valobj); +# else /* TCL_VERSION >= 8.1 */ + { + volatile VALUE enc = Qnil; + + if (RTEST(rb_ivar_defined(value, ID_at_enc))) { + enc = rb_ivar_get(value, ID_at_enc); + } + + if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) { + /* binary string */ + valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr, + RSTRING(value)->len); + } else if (strlen(RSTRING(value)->ptr) != RSTRING(value)->len) { + /* probably binary string */ + valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr, + RSTRING(value)->len); + } else { + /* probably text string */ + valobj = Tcl_NewStringObj(RSTRING(value)->ptr, + RSTRING(value)->len); + } + + Tcl_IncrRefCount(valobj); + } +# endif + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + Tcl_DecrRefCount(nameobj); + Tcl_DecrRefCount(valobj); + rb_thread_critical = thr_crit_bup; + return rb_tainted_str_new2(""); + } else { + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + ret = Tcl_ObjSetVar2(ptr->ip, nameobj, (Tcl_Obj*)NULL, valobj, + FIX2INT(flag)); + } + + Tcl_DecrRefCount(nameobj); + Tcl_DecrRefCount(valobj); + + if (ret == (Tcl_Obj*)NULL) { + volatile VALUE exc; +#if TCL_MAJOR_VERSION >= 8 + exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result); +#endif + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + rb_exc_raise(exc); + } + + Tcl_IncrRefCount(ret); + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); +# else /* TCL_VERSION >= 8.1 */ + { + VALUE old_gc; + + old_gc = rb_gc_disable(); + + if (Tcl_GetCharLength(ret) != Tcl_UniCharLen(Tcl_GetUnicode(ret))) { + /* possibly binary string */ + s = Tcl_GetByteArrayFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + rb_ivar_set(strval, ID_at_enc, rb_str_new2("binary")); + } else { + /* possibly text string */ + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + } + if (old_gc == Qfalse) rb_gc_enable(); + } +# endif + + Tcl_DecrRefCount(ret); + + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + + return(strval); + } +#else /* TCL_MAJOR_VERSION < 8 */ + { + CONST char *ret; + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + return rb_tainted_str_new2(""); + } else { + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + ret = Tcl_SetVar2(ptr->ip, RSTRING(varname)->ptr, (char*)NULL, + RSTRING(value)->ptr, (int)FIX2INT(flag)); + } + + if (ret == NULL) { + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + } + + strval = rb_tainted_str_new2(ret); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + + return(strval); + } +#endif +} + +static VALUE +ip_set_variable2(self, varname_arg, index_arg, value_arg, flag_arg) + VALUE self; + VALUE varname_arg; + VALUE index_arg; + VALUE value_arg; + VALUE flag_arg; +{ + struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; + volatile VALUE varname, index, value, flag; + + if (NIL_P(index_arg)) { + return ip_set_variable(self, varname_arg, value_arg, flag_arg); + } + + varname = varname_arg; + index = index_arg; + value = value_arg; + flag = flag_arg; + + StringValue(varname); + StringValue(index); + StringValue(value); + +#if TCL_MAJOR_VERSION >= 8 + { + Tcl_Obj *nameobj, *idxobj, *valobj, *ret; + char *s; + int len; + volatile VALUE strval; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr, + RSTRING(varname)->len); + Tcl_IncrRefCount(nameobj); + + idxobj = Tcl_NewStringObj(RSTRING(index)->ptr, + RSTRING(index)->len); + Tcl_IncrRefCount(idxobj); + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + valobj = Tcl_NewStringObj(RSTRING(value)->ptr, + RSTRING(value)->len); +# else /* TCL_VERSION >= 8.1 */ + { + VALUE enc = Qnil; + + if (RTEST(rb_ivar_defined(value, ID_at_enc))) { + enc = rb_ivar_get(value, ID_at_enc); + } + + if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) { + /* binary string */ + valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr, + RSTRING(value)->len); + } else if (strlen(RSTRING(value)->ptr) != RSTRING(value)->len) { + /* probably binary string */ + valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr, + RSTRING(value)->len); + } else { + /* probably text string */ + valobj = Tcl_NewStringObj(RSTRING(value)->ptr, + RSTRING(value)->len); + } + } + +# endif + Tcl_IncrRefCount(valobj); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + Tcl_DecrRefCount(nameobj); + Tcl_DecrRefCount(idxobj); + Tcl_DecrRefCount(valobj); + rb_thread_critical = thr_crit_bup; + return rb_tainted_str_new2(""); + } else { + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + ret = Tcl_ObjSetVar2(ptr->ip, nameobj, idxobj, valobj, + FIX2INT(flag)); + } + + Tcl_DecrRefCount(nameobj); + Tcl_DecrRefCount(idxobj); + Tcl_DecrRefCount(valobj); + + if (ret == (Tcl_Obj*)NULL) { + volatile VALUE exc; +#if TCL_MAJOR_VERSION >= 8 + exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result); +#endif + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + rb_exc_raise(exc); + } + + Tcl_IncrRefCount(ret); + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); +# else /* TCL_VERSION >= 8.1 */ + if (Tcl_GetCharLength(ret) != Tcl_UniCharLen(Tcl_GetUnicode(ret))) { + /* possibly binary string */ + s = Tcl_GetByteArrayFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + rb_ivar_set(strval, ID_at_enc, rb_str_new2("binary")); + } else { + /* possibly text string */ + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + } +# endif + + Tcl_DecrRefCount(ret); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + + return(strval); + } +#else /* TCL_MAJOR_VERSION < 8 */ + { + CONST char *ret; + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + return rb_tainted_str_new2(""); + } else { + /* Tcl_Preserve(ptr->ip); */ + rbtk_preserve_ip(ptr); + ret = Tcl_SetVar2(ptr->ip, RSTRING(varname)->ptr, + RSTRING(index)->ptr, + RSTRING(value)->ptr, FIX2INT(flag)); + } + + if (ret == (char*)NULL) { + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + } + + Tcl_IncrRefCount(ret); + + strval = rb_tainted_str_new2(ret); + + Tcl_DecrRefCount(ret); + /* Tcl_Release(ptr->ip); */ + rbtk_release_ip(ptr); + rb_thread_critical = thr_crit_bup; + + return(strval); + } +#endif +} + +static VALUE +ip_unset_variable(self, varname_arg, flag_arg) + VALUE self; + VALUE varname_arg; + VALUE flag_arg; +{ + struct tcltkip *ptr = get_ip(self); + volatile VALUE varname, value, flag; + + varname = varname_arg; + flag = flag_arg; + + StringValue(varname); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + return Qtrue; + } + + ptr->return_value = Tcl_UnsetVar(ptr->ip, RSTRING(varname)->ptr, + FIX2INT(flag)); + if (ptr->return_value == TCL_ERROR) { + if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif + } + return Qfalse; + } + return Qtrue; +} + +static VALUE +ip_unset_variable2(self, varname_arg, index_arg, flag_arg) + VALUE self; + VALUE varname_arg; + VALUE index_arg; + VALUE flag_arg; +{ + struct tcltkip *ptr = get_ip(self); + volatile VALUE varname, index, value, flag; + + if (NIL_P(index_arg)) { + return ip_unset_variable(self, varname_arg, flag_arg); + } + + varname = varname_arg; + index = index_arg; + flag = flag_arg; + + StringValue(varname); + StringValue(index); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) { + DUMP1("ip is deleted"); + return Qtrue; + } + + ptr->return_value = Tcl_UnsetVar2(ptr->ip, RSTRING(varname)->ptr, + RSTRING(index)->ptr, FIX2INT(flag)); + if (ptr->return_value == TCL_ERROR) { + if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif + } + return Qfalse; + } + return Qtrue; +} + +static VALUE +ip_get_global_var(self, varname) + VALUE self; + VALUE varname; +{ + return ip_get_variable(self, varname, + INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); +} + +static VALUE +ip_get_global_var2(self, varname, index) + VALUE self; + VALUE varname; + VALUE index; +{ + return ip_get_variable2(self, varname, index, + INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); +} + +static VALUE +ip_set_global_var(self, varname, value) + VALUE self; + VALUE varname; + VALUE value; +{ + return ip_set_variable(self, varname, value, + INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); +} + +static VALUE +ip_set_global_var2(self, varname, index, value) + VALUE self; + VALUE varname; + VALUE index; + VALUE value; +{ + return ip_set_variable2(self, varname, index, value, + INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); +} + +static VALUE +ip_unset_global_var(self, varname) + VALUE self; + VALUE varname; +{ + return ip_unset_variable(self, varname, + INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); +} + +static VALUE +ip_unset_global_var2(self, varname, index) + VALUE self; + VALUE varname; + VALUE index; +{ + return ip_unset_variable2(self, varname, index, + INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); +} + + +/* treat Tcl_List */ +static VALUE +lib_split_tklist_core(ip_obj, list_str) + VALUE ip_obj; + VALUE list_str; +{ + Tcl_Interp *interp; + volatile VALUE ary, elem; + int idx; + int taint_flag = OBJ_TAINTED(list_str); + int result; + VALUE old_gc; + + if (NIL_P(ip_obj)) { + interp = (Tcl_Interp *)NULL; + } else { + interp = get_ip(ip_obj)->ip; + } + + StringValue(list_str); + + { +#if TCL_MAJOR_VERSION >= 8 + /* object style interface */ + Tcl_Obj *listobj; + int objc; + Tcl_Obj **objv; + int thr_crit_bup; + +# if 1 +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + listobj = Tcl_NewStringObj(RSTRING(list_str)->ptr, + RSTRING(list_str)->len); +# else /* TCL_VERSION >= 8.1 */ + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + { + VALUE enc = Qnil; + + if (RTEST(rb_ivar_defined(list_str, ID_at_enc))) { + enc = rb_ivar_get(list_str, ID_at_enc); + } + + if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) { + /* binary string */ + listobj = Tcl_NewByteArrayObj(RSTRING(list_str)->ptr, + RSTRING(list_str)->len); + } else if (strlen(RSTRING(list_str)->ptr) + != RSTRING(list_str)->len) { + /* probably binary string */ + listobj = Tcl_NewByteArrayObj(RSTRING(list_str)->ptr, + RSTRING(list_str)->len); + } else { + /* probably text string */ + listobj = Tcl_NewStringObj(RSTRING(list_str)->ptr, + RSTRING(list_str)->len); + } + } + + rb_thread_critical = thr_crit_bup; +# endif +# else + listobj = Tcl_NewStringObj(RSTRING(list_str)->ptr, + RSTRING(list_str)->len); +# endif + + Tcl_IncrRefCount(listobj); + + result = Tcl_ListObjGetElements(interp, listobj, &objc, &objv); + + if (result == TCL_ERROR) { + Tcl_DecrRefCount(listobj); + if (interp == (Tcl_Interp*)NULL) { + rb_raise(rb_eRuntimeError, "cannot get elements from list"); + } else { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(interp)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", interp->result); +#endif + } + } + + for(idx = 0; idx < objc; idx++) { + Tcl_IncrRefCount(objv[idx]); + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + ary = rb_ary_new2(objc); + if (taint_flag) OBJ_TAINT(ary); + + old_gc = rb_gc_disable(); + + for(idx = 0; idx < objc; idx++) { + char *str; + int len; + +# if 1 +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + str = Tcl_GetStringFromObj(objv[idx], &len); + elem = rb_str_new(str, len); +# else /* TCL_VERSION >= 8.1 */ + if (Tcl_GetCharLength(objv[idx]) + != Tcl_UniCharLen(Tcl_GetUnicode(objv[idx]))) { + /* possibly binary string */ + str = Tcl_GetByteArrayFromObj(objv[idx], &len); + elem = rb_str_new(str, len); + rb_ivar_set(elem, ID_at_enc, rb_tainted_str_new2("binary")); + } else { + /* possibly text string */ + str = Tcl_GetStringFromObj(objv[idx], &len); + elem = rb_str_new(str, len); + } +# endif +# else + str = Tcl_GetStringFromObj(objv[idx], &len); + elem = rb_str_new(str, len); +# endif + + if (taint_flag) OBJ_TAINT(elem); + RARRAY(ary)->ptr[idx] = elem; + } + + RARRAY(ary)->len = objc; + + if (old_gc == Qfalse) rb_gc_enable(); + + rb_thread_critical = thr_crit_bup; + + for(idx = 0; idx < objc; idx++) { + Tcl_DecrRefCount(objv[idx]); + } + + Tcl_DecrRefCount(listobj); + +#else /* TCL_MAJOR_VERSION < 8 */ + /* string style interface */ + int argc; + char **argv; + + if (Tcl_SplitList(interp, RSTRING(list_str)->ptr, + &argc, &argv) == TCL_ERROR) { + if (interp == (Tcl_Interp*)NULL) { + rb_raise(rb_eRuntimeError, "cannot get elements from list"); + } else { + rb_raise(rb_eRuntimeError, "%s", interp->result); + } + } + + ary = rb_ary_new2(argc); + if (taint_flag) OBJ_TAINT(ary); + + old_gc = rb_gc_disable(); + + for(idx = 0; idx < argc; idx++) { + if (taint_flag) { + elem = rb_tainted_str_new2(argv[idx]); + } else { + elem = rb_str_new2(argv[idx]); + } + /* rb_ivar_set(elem, ID_at_enc, rb_str_new2("binary")); */ + RARRAY(ary)->ptr[idx] = elem; + } + RARRAY(ary)->len = argc; + + if (old_gc == Qfalse) rb_gc_enable(); +#endif + } + + return ary; +} + +static VALUE +lib_split_tklist(self, list_str) + VALUE self; + VALUE list_str; +{ + return lib_split_tklist_core(Qnil, list_str); +} + + +static VALUE +ip_split_tklist(self, list_str) + VALUE self; + VALUE list_str; +{ + return lib_split_tklist_core(self, list_str); +} + +static VALUE +lib_merge_tklist(argc, argv, obj) + int argc; + VALUE *argv; + VALUE obj; +{ + int num, len; + int *flagPtr; + char *dst, *result; + volatile VALUE str; + int taint_flag = 0; + int thr_crit_bup; + VALUE old_gc; + + if (argc == 0) return rb_str_new2(""); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + old_gc = rb_gc_disable(); + + /* based on Tcl/Tk's Tcl_Merge() */ + flagPtr = ALLOC_N(int, argc); + + /* pass 1 */ + len = 1; + for(num = 0; num < argc; num++) { + if (OBJ_TAINTED(argv[num])) taint_flag = 1; + dst = StringValuePtr(argv[num]); +#if TCL_MAJOR_VERSION >= 8 + len += Tcl_ScanCountedElement(dst, RSTRING(argv[num])->len, + &flagPtr[num]) + 1; +#else /* TCL_MAJOR_VERSION < 8 */ + len += Tcl_ScanElement(dst, &flagPtr[num]) + 1; +#endif + } + + /* pass 2 */ + result = (char *)Tcl_Alloc(len); + dst = result; + for(num = 0; num < argc; num++) { +#if TCL_MAJOR_VERSION >= 8 + len = Tcl_ConvertCountedElement(RSTRING(argv[num])->ptr, + RSTRING(argv[num])->len, + dst, flagPtr[num]); +#else /* TCL_MAJOR_VERSION < 8 */ + len = Tcl_ConvertElement(RSTRING(argv[num])->ptr, dst, flagPtr[num]); +#endif + dst += len; + *dst = ' '; + dst++; + } + if (dst == result) { + *dst = 0; + } else { + dst[-1] = 0; + } + + free(flagPtr); + + /* create object */ + str = rb_str_new(result, dst - result - 1); + if (taint_flag) OBJ_TAINT(str); + Tcl_Free(result); + + if (old_gc == Qfalse) rb_gc_enable(); + rb_thread_critical = thr_crit_bup; + + return str; +} + +static VALUE +lib_conv_listelement(self, src) + VALUE self; + VALUE src; +{ + int len, scan_flag; + volatile VALUE dst; + int taint_flag = OBJ_TAINTED(src); + int thr_crit_bup; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + StringValue(src); + +#if TCL_MAJOR_VERSION >= 8 + len = Tcl_ScanCountedElement(RSTRING(src)->ptr, RSTRING(src)->len, + &scan_flag); + dst = rb_str_new(0, len + 1); + len = Tcl_ConvertCountedElement(RSTRING(src)->ptr, RSTRING(src)->len, + RSTRING(dst)->ptr, scan_flag); +#else /* TCL_MAJOR_VERSION < 8 */ + len = Tcl_ScanElement(RSTRING(src)->ptr, &scan_flag); + dst = rb_str_new(0, len + 1); + len = Tcl_ConvertElement(RSTRING(src)->ptr, RSTRING(dst)->ptr, scan_flag); +#endif + + RSTRING(dst)->len = len; + RSTRING(dst)->ptr[len] = '\0'; + if (taint_flag) OBJ_TAINT(dst); + + rb_thread_critical = thr_crit_bup; + + return dst; +} + + +#ifdef __MACOS__ +static void +_macinit() +{ + tcl_macQdPtr = &qd; /* setup QuickDraw globals */ + Tcl_MacSetEventProc(TkMacConvertEvent); /* setup event handler */ +} +#endif + +static VALUE +tcltklib_compile_info() +{ + volatile VALUE ret; + int size; + char form[] + = "tcltklib %s :: Ruby%s (%s) %s pthread :: Tcl%s(%s)/Tk%s(%s) %s"; + char *info; + + size = strlen(form) + + strlen(TCLTKLIB_RELEASE_DATE) + + strlen(RUBY_VERSION) + + strlen(RUBY_RELEASE_DATE) + + strlen("without") + + strlen(TCL_PATCH_LEVEL) + + strlen("without stub") + + strlen(TK_PATCH_LEVEL) + + strlen("without stub") + + strlen("unknown tcl_threads"); + + info = ALLOC_N(char, size); + + sprintf(info, form, + TCLTKLIB_RELEASE_DATE, + RUBY_VERSION, RUBY_RELEASE_DATE, +#ifdef HAVE_NATIVETHREAD + "with", +#else + "without", +#endif + TCL_PATCH_LEVEL, +#ifdef USE_TCL_STUBS + "with stub", +#else + "without stub", +#endif + TK_PATCH_LEVEL, +#ifdef USE_TK_STUBS + "with stub", +#else + "without stub", +#endif +#ifdef WITH_TCL_ENABLE_THREAD +# if WITH_TCL_ENABLE_THREAD + "with tcl_threads" +# else + "without tcl_threads" +# endif +#else + "unknown tcl_threads" +#endif + ); + + ret = rb_obj_freeze(rb_str_new2(info)); + + free(info); + + return ret; +} + +/*---- initialization ----*/ +void +Init_tcltklib() +{ + int thr_crit_bup; + + VALUE lib = rb_define_module("TclTkLib"); + VALUE ip = rb_define_class("TclTkIp", rb_cObject); + + VALUE ev_flag = rb_define_module_under(lib, "EventFlag"); + VALUE var_flag = rb_define_module_under(lib, "VarAccessFlag"); + + /* --------------------------------------------------------------- */ + +#if defined USE_TCL_STUBS && defined USE_TK_STUBS + extern int ruby_tcltk_stubs(); + int ret = ruby_tcltk_stubs(); + + if (ret) + rb_raise(rb_eLoadError, "tcltklib: tcltk_stubs init error(%d)", ret); +#endif + + /* --------------------------------------------------------------- */ + + rb_global_variable(&eTkCallbackReturn); + rb_global_variable(&eTkCallbackBreak); + rb_global_variable(&eTkCallbackContinue); + + rb_global_variable(&eventloop_thread); + rb_global_variable(&watchdog_thread); + + /* --------------------------------------------------------------- */ + + rb_define_const(lib, "COMPILE_INFO", tcltklib_compile_info()); + + rb_define_const(lib, "RELEASE_DATE", + rb_obj_freeze(rb_str_new2(tcltklib_release_date))); + + rb_define_const(lib, "FINALIZE_PROC_NAME", + rb_str_new2(finalize_hook_name)); + + /* --------------------------------------------------------------- */ + + rb_define_const(ev_flag, "NONE", INT2FIX(0)); + rb_define_const(ev_flag, "WINDOW", INT2FIX(TCL_WINDOW_EVENTS)); + rb_define_const(ev_flag, "FILE", INT2FIX(TCL_FILE_EVENTS)); + rb_define_const(ev_flag, "TIMER", INT2FIX(TCL_TIMER_EVENTS)); + rb_define_const(ev_flag, "IDLE", INT2FIX(TCL_IDLE_EVENTS)); + rb_define_const(ev_flag, "ALL", INT2FIX(TCL_ALL_EVENTS)); + rb_define_const(ev_flag, "DONT_WAIT", INT2FIX(TCL_DONT_WAIT)); + + /* --------------------------------------------------------------- */ + + rb_define_const(var_flag, "NONE", INT2FIX(0)); + rb_define_const(var_flag, "GLOBAL_ONLY", INT2FIX(TCL_GLOBAL_ONLY)); +#ifdef TCL_NAMESPACE_ONLY + rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(TCL_NAMESPACE_ONLY)); +#else /* probably Tcl7.6 */ + rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(0)); +#endif + rb_define_const(var_flag, "LEAVE_ERR_MSG", INT2FIX(TCL_LEAVE_ERR_MSG)); + rb_define_const(var_flag, "APPEND_VALUE", INT2FIX(TCL_APPEND_VALUE)); + rb_define_const(var_flag, "LIST_ELEMENT", INT2FIX(TCL_LIST_ELEMENT)); +#ifdef TCL_PARSE_PART1 + rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(TCL_PARSE_PART1)); +#else /* probably Tcl7.6 */ + rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(0)); +#endif + + /* --------------------------------------------------------------- */ + + eTkCallbackBreak = rb_define_class("TkCallbackReturn", rb_eStandardError); + eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError); + eTkCallbackContinue = rb_define_class("TkCallbackContinue", + rb_eStandardError); + + /* --------------------------------------------------------------- */ + + eLocalJumpError = rb_const_get(rb_cObject, rb_intern("LocalJumpError")); + + ID_at_enc = rb_intern("@encoding"); + ID_at_interp = rb_intern("@interp"); + + ID_stop_p = rb_intern("stop?"); + ID_kill = rb_intern("kill"); + ID_join = rb_intern("join"); + + ID_call = rb_intern("call"); + ID_backtrace = rb_intern("backtrace"); + ID_message = rb_intern("message"); + + ID_at_reason = rb_intern("@reason"); + ID_return = rb_intern("return"); + ID_break = rb_intern("break"); + ID_next = rb_intern("next"); + + ID_to_s = rb_intern("to_s"); + ID_inspect = rb_intern("inspect"); + + /* --------------------------------------------------------------- */ + + rb_define_module_function(lib, "mainloop", lib_mainloop, -1); + rb_define_module_function(lib, "mainloop_watchdog", + lib_mainloop_watchdog, -1); + rb_define_module_function(lib, "do_one_event", lib_do_one_event, -1); + rb_define_module_function(lib, "mainloop_abort_on_exception", + lib_evloop_abort_on_exc, 0); + rb_define_module_function(lib, "mainloop_abort_on_exception=", + lib_evloop_abort_on_exc_set, 1); + rb_define_module_function(lib, "set_eventloop_tick",set_eventloop_tick,1); + rb_define_module_function(lib, "get_eventloop_tick",get_eventloop_tick,0); + rb_define_module_function(lib, "set_no_event_wait", set_no_event_wait, 1); + rb_define_module_function(lib, "get_no_event_wait", get_no_event_wait, 0); + rb_define_module_function(lib, "set_eventloop_weight", + set_eventloop_weight, 2); + rb_define_module_function(lib, "set_max_block_time", set_max_block_time,1); + rb_define_module_function(lib, "get_eventloop_weight", + get_eventloop_weight, 0); + rb_define_module_function(lib, "num_of_mainwindows", + lib_num_of_mainwindows, 0); + + /* --------------------------------------------------------------- */ + + rb_define_module_function(lib, "_split_tklist", lib_split_tklist, 1); + rb_define_module_function(lib, "_merge_tklist", lib_merge_tklist, -1); + rb_define_module_function(lib, "_conv_listelement", + lib_conv_listelement, 1); + rb_define_module_function(lib, "_toUTF8", lib_toUTF8, -1); + rb_define_module_function(lib, "_fromUTF8", lib_fromUTF8, -1); + rb_define_module_function(lib, "_subst_UTF_backslash", + lib_UTF_backslash, 1); + rb_define_module_function(lib, "_subst_Tcl_backslash", + lib_Tcl_backslash, 1); + + /* --------------------------------------------------------------- */ + + rb_define_alloc_func(ip, ip_alloc); + rb_define_method(ip, "initialize", ip_init, -1); + rb_define_method(ip, "create_slave", ip_create_slave, -1); + rb_define_method(ip, "make_safe", ip_make_safe, 0); + rb_define_method(ip, "safe?", ip_is_safe_p, 0); + rb_define_method(ip, "allow_ruby_exit?", ip_allow_ruby_exit_p, 0); + rb_define_method(ip, "allow_ruby_exit=", ip_allow_ruby_exit_set, 1); + rb_define_method(ip, "delete", ip_delete, 0); + rb_define_method(ip, "deleted?", ip_is_deleted_p, 0); + rb_define_method(ip, "null_namespace?", ip_has_null_namespace_p, 0); + rb_define_method(ip, "_eval", ip_eval, 1); + rb_define_method(ip, "_toUTF8", ip_toUTF8, -1); + rb_define_method(ip, "_fromUTF8", ip_fromUTF8, -1); + rb_define_method(ip, "_thread_vwait", ip_thread_vwait, 1); + rb_define_method(ip, "_thread_tkwait", ip_thread_tkwait, 2); + rb_define_method(ip, "_invoke", ip_invoke, -1); + rb_define_method(ip, "_return_value", ip_retval, 0); + + /* --------------------------------------------------------------- */ + + rb_define_method(ip, "_get_variable", ip_get_variable, 2); + rb_define_method(ip, "_get_variable2", ip_get_variable2, 3); + rb_define_method(ip, "_set_variable", ip_set_variable, 3); + rb_define_method(ip, "_set_variable2", ip_set_variable2, 4); + rb_define_method(ip, "_unset_variable", ip_unset_variable, 2); + rb_define_method(ip, "_unset_variable2", ip_unset_variable2, 3); + rb_define_method(ip, "_get_global_var", ip_get_global_var, 1); + rb_define_method(ip, "_get_global_var2", ip_get_global_var2, 2); + rb_define_method(ip, "_set_global_var", ip_set_global_var, 2); + rb_define_method(ip, "_set_global_var2", ip_set_global_var2, 3); + rb_define_method(ip, "_unset_global_var", ip_unset_global_var, 1); + rb_define_method(ip, "_unset_global_var2", ip_unset_global_var2, 2); + + /* --------------------------------------------------------------- */ + + rb_define_method(ip, "_split_tklist", ip_split_tklist, 1); + rb_define_method(ip, "_merge_tklist", lib_merge_tklist, -1); + rb_define_method(ip, "_conv_listelement", lib_conv_listelement, 1); + + /* --------------------------------------------------------------- */ + + rb_define_method(ip, "mainloop", ip_mainloop, -1); + rb_define_method(ip, "mainloop_watchdog", ip_mainloop_watchdog, -1); + rb_define_method(ip, "do_one_event", ip_do_one_event, -1); + rb_define_method(ip, "mainloop_abort_on_exception", + ip_evloop_abort_on_exc, 0); + rb_define_method(ip, "mainloop_abort_on_exception=", + ip_evloop_abort_on_exc_set, 1); + rb_define_method(ip, "set_eventloop_tick", ip_set_eventloop_tick, 1); + rb_define_method(ip, "get_eventloop_tick", ip_get_eventloop_tick, 0); + rb_define_method(ip, "set_no_event_wait", ip_set_no_event_wait, 1); + rb_define_method(ip, "get_no_event_wait", ip_get_no_event_wait, 0); + rb_define_method(ip, "set_eventloop_weight", ip_set_eventloop_weight, 2); + rb_define_method(ip, "get_eventloop_weight", ip_get_eventloop_weight, 0); + rb_define_method(ip, "set_max_block_time", set_max_block_time, 1); + rb_define_method(ip, "restart", ip_restart, 0); + + /* --------------------------------------------------------------- */ + + eventloop_thread = 0; + watchdog_thread = 0; + + /* --------------------------------------------------------------- */ + +#ifdef __MACOS__ + _macinit(); +#endif + + /* from Tk_Main() */ + DUMP1("Tcl_FindExecutable"); + Tcl_FindExecutable(RSTRING(rb_argv0)->ptr); + + /* --------------------------------------------------------------- */ +} + +/* eof */ |