diff options
Diffstat (limited to 'ext/tcltklib/tcltklib.c')
| -rw-r--r-- | ext/tcltklib/tcltklib.c | 2396 |
1 files changed, 0 insertions, 2396 deletions
diff --git a/ext/tcltklib/tcltklib.c b/ext/tcltklib/tcltklib.c deleted file mode 100644 index 50c654d814..0000000000 --- a/ext/tcltklib/tcltklib.c +++ /dev/null @@ -1,2396 +0,0 @@ -/* - * tcltklib.c - * Aug. 27, 1997 Y. Shigehiro - * Oct. 24, 1997 Y. Matsumoto - */ - -#include "ruby.h" -#include "rubysig.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 -#endif - -/* for ruby_debug */ - -#define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);} -#define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\ -fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); } -/* -#define DUMP1(ARG1) -#define DUMP2(ARG1, ARG2) -*/ - -/* for callback break & continue */ -static VALUE eTkCallbackBreak; -static VALUE eTkCallbackContinue; - -static VALUE ip_invoke_real _((int, VALUE*, VALUE)); -static VALUE ip_invoke _((int, VALUE*, VALUE)); - -/* from tkAppInit.c */ - -#if !defined __MINGW32__ -/* - * 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 - -/*---- module TclTkLib ----*/ - -struct invoke_queue { - Tcl_Event ev; - int argc; - VALUE *argv; - VALUE obj; - int done; - int safe_level; - VALUE *result; - VALUE thread; -}; - -struct eval_queue { - Tcl_Event ev; - VALUE str; - VALUE obj; - int done; - int safe_level; - VALUE *result; - VALUE 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 _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*)); -#else -static int ip_ruby _((ClientData, Tcl_Interp *, int, char **)); -#endif - -/*---- class TclTkIp ----*/ -struct tcltkip { - Tcl_Interp *ip; /* the interpreter */ - 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; -} - -/* 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; -{ - /* struct invoke_queue *q, *tmp; */ - /* VALUE thread; */ - - DUMP1("called timer_for_tcl"); - 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_schedule(); */ - /* tick_counter += event_loop_max; */ -} - -static VALUE -set_eventloop_tick(self, tick) - VALUE self; - VALUE tick; -{ - int ttick = NUM2INT(tick); - - rb_secure(4); - - if (ttick < 0) { - rb_raise(rb_eArgError, - "timer-tick parameter must be 0 or positive number"); - } - - /* 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; - } - - 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); - - 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); - - 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); - - 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 -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 (val == Qnil) { - 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); - 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, check_var) - int check_root; - int *check_var; -{ - VALUE current = eventloop_thread; - int found_event = 1; - struct timeval t; - - 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) { - timer_token = Tk_CreateTimerHandler(timer_tick, _timer_for_tcl, - (ClientData)0); - } else { - timer_token = (Tcl_TimerToken)NULL; - } - - for(;;) { - if (rb_thread_alone()) { - DUMP1("no other thread"); - event_loop_wait_event = 0; - - if (timer_tick == 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(TCL_ALL_EVENTS); - - if (loop_counter++ > 30000) { - loop_counter = 0; - } - - if (run_timer_flag) { - /* - DUMP1("timer interrupt"); - run_timer_flag = 0; - DUMP1("call rb_trap_exec()"); - rb_trap_exec(); - */ - DUMP1("check Root Widget"); - if (check_root && Tk_GetNumMainWindows() == 0) { - run_timer_flag = 0; - rb_trap_exec(); - return 1; - } - } - - } else { - int tick_counter; - - DUMP1("there are other threads"); - event_loop_wait_event = 1; - - found_event = 1; - - 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(TCL_ALL_EVENTS | TCL_DONT_WAIT)) { - tick_counter++; - } else { - tick_counter += no_event_tick; - - DUMP1("check Root Widget"); - if (check_root && Tk_GetNumMainWindows() == 0) { - return 1; - } - - rb_thread_wait_for(t); - } - - if (loop_counter++ > 30000) { - loop_counter = 0; - } - - if (watchdog_thread != 0 && eventloop_thread != current) { - return 1; - } - - if (run_timer_flag) { - /* - DUMP1("timer interrupt"); - run_timer_flag = 0; - */ - break; /* switch to other thread */ - } - } - - DUMP1("check Root Widget"); - if (check_root && Tk_GetNumMainWindows() == 0) { - return 1; - } - } - - /* rb_thread_schedule(); */ - if (run_timer_flag) { - run_timer_flag = 0; - rb_trap_exec(); - } else { - DUMP1("thread scheduling"); - if (is_ruby_native_thread()) { - rb_thread_schedule(); - } - } - } - return 1; -} - -VALUE -lib_eventloop_main(check_rootwidget) - VALUE check_rootwidget; -{ - check_rootwidget_flag = RTEST(check_rootwidget); - - if (lib_eventloop_core(check_rootwidget_flag, (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); - - 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, rb_intern("stop?"), 0))) { - rb_funcall(watchdog_thread, rb_intern("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, rb_intern("stop?"), 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); - - 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; -{ - 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); - if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { - /* slave IP */ - flags |= TCL_DONT_WAIT; - } - } - - found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); - - 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); -} - - -/* Tcl command `ruby' */ -static VALUE -ip_ruby_eval_rescue(failed, einfo) - VALUE *failed; - VALUE einfo; -{ - *failed = einfo; - return Qnil; -} - -struct eval_body_arg { - char *string; - VALUE failed; -}; - -static VALUE -ip_ruby_eval_body(arg) - struct eval_body_arg *arg; -{ - rb_trap_immediate = 0; - return rb_rescue2(rb_eval_string, (VALUE)arg->string, - ip_ruby_eval_rescue, (VALUE)&(arg->failed), - rb_eStandardError, rb_eScriptError, rb_eSystemExit, - (VALUE)0); -} - -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(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - Tcl_Obj *CONST argv[]; -#else -ip_ruby(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -#endif -{ - VALUE res; - int old_trapflag; - struct eval_body_arg arg; - int dummy; - - /* ruby command has 1 arg. */ - if (argc != 2) { - rb_raise(rb_eArgError, "wrong # of arguments (%d for 1)", argc); - } - - /* get C string from Tcl object */ -#if TCL_MAJOR_VERSION >= 8 - arg.string = Tcl_GetStringFromObj(argv[1], &dummy); -#else - arg.string = argv[1]; -#endif - arg.failed = 0; - - /* evaluate the argument string by ruby */ - DUMP2("rb_eval_string(%s)", arg); - old_trapflag = rb_trap_immediate; - res = rb_ensure(ip_ruby_eval_body, (VALUE)&arg, - ip_ruby_eval_ensure, INT2FIX(old_trapflag)); - - /* status check */ - if (arg.failed) { - VALUE eclass = CLASS_OF(arg.failed); - DUMP1("(rb_eval_string result) failed"); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, StringValuePtr(arg.failed), (char*)NULL); - if (eclass == eTkCallbackBreak) { - return TCL_BREAK; - } else if (eclass == eTkCallbackContinue) { - return TCL_CONTINUE; - } else if (eclass == rb_eSystemExit) { - Tcl_Eval(interp, "destroy ."); - rb_raise(rb_eSystemExit, StringValuePtr(arg.failed)); - } else { - 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 */ - DUMP2("(rb_eval_string result) %s", StringValuePtr(res)); - DUMP1("Tcl_AppendResult"); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, StringValuePtr(res), (char *)NULL); - - return TCL_OK; -} - - -/**************************/ -/* based on tclEvent.c */ -/**************************/ -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. */ -{ - 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 -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 done, foundEvent; - char *nameString; - int dummy; - - DUMP1("Ruby's 'vwait' is called"); - if (objc != 2) { -#ifdef Tcl_WrongNumArgs - Tcl_WrongNumArgs(interp, 1, objv, "name"); -#else -#if TCL_MAJOR_VERSION >= 8 - /* nameString = Tcl_GetString(objv[0]); */ - nameString = Tcl_GetStringFromObj(objv[0], &dummy); -#else - nameString = objv[0]; -#endif - Tcl_AppendResult(interp, "wrong # args: should be \"", - nameString, " name\"", (char *) NULL); -#endif - return TCL_ERROR; - } -#if TCL_MAJOR_VERSION >= 8 - /* nameString = Tcl_GetString(objv[1]); */ - nameString = Tcl_GetStringFromObj(objv[1], &dummy); -#else - 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; - }; - done = 0; - foundEvent = lib_eventloop_core(/* not check root-widget */0, &done); - Tcl_UntraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, (ClientData) &done); - - /* - * Clear out the interpreter's result, since it may have been set - * by event handlers. - */ - - Tcl_ResetResult(interp); - if (!foundEvent) { - Tcl_AppendResult(interp, "can't wait for variable \"", nameString, - "\": would wait forever", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - - -/**************************/ -/* based on tkCmd.c */ -/**************************/ -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. */ -{ - 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 -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; - int done, index; - static CONST char *optionStrings[] = { "variable", "visibility", "window", - (char *) NULL }; - enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW }; - char *nameString; - int dummy; - - DUMP1("Ruby's 'tkwait' is called"); - - if (objc != 3) { -#ifdef Tcl_WrongNumArgs - Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); -#else -#if TCL_MAJOR_VERSION >= 8 - Tcl_AppendResult(interp, "wrong # args: should be \"", - Tcl_GetStringFromObj(objv[0], &dummy), - " variable|visibility|window name\"", - (char *) NULL); -#else - Tcl_AppendResult(interp, "wrong # args: should be \"", - objv[0], " variable|visibility|window name\"", - (char *) NULL); -#endif -#endif - return TCL_ERROR; - } - -#if TCL_MAJOR_VERSION >= 8 - if (Tcl_GetIndexFromObj(interp, objv[1], - (CONST84 char **)optionStrings, - "option", 0, &index) != TCL_OK) { - return TCL_ERROR; - } -#else - { - 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); - return TCL_ERROR; - } - } -#endif - -#if TCL_MAJOR_VERSION >= 8 - /* nameString = Tcl_GetString(objv[2]); */ - nameString = Tcl_GetStringFromObj(objv[2], &dummy); -#else - nameString = objv[2]; -#endif - - switch ((enum options) index) { - case TKWAIT_VARIABLE: { - if (Tcl_TraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - WaitVariableProc, (ClientData) &done) != TCL_OK) { - return TCL_ERROR; - } - done = 0; - lib_eventloop_core(check_rootwidget_flag, &done); - Tcl_UntraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - WaitVariableProc, (ClientData) &done); - break; - } - - case TKWAIT_VISIBILITY: { - Tk_Window window; - - window = Tk_NameToWindow(interp, nameString, tkwin); - if (window == NULL) { - return TCL_ERROR; - } - Tk_CreateEventHandler(window, - VisibilityChangeMask|StructureNotifyMask, - WaitVisibilityProc, (ClientData) &done); - done = 0; - lib_eventloop_core(check_rootwidget_flag, &done); - if (done != 1) { - /* - * Note that we do not delete the event handler because it - * was deleted automatically when the window was destroyed. - */ - - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "window \"", nameString, - "\" was deleted before its visibility changed", - (char *) NULL); - return TCL_ERROR; - } - Tk_DeleteEventHandler(window, - VisibilityChangeMask|StructureNotifyMask, - WaitVisibilityProc, (ClientData) &done); - break; - } - - case TKWAIT_WINDOW: { - Tk_Window window; - - window = Tk_NameToWindow(interp, nameString, tkwin); - if (window == NULL) { - return TCL_ERROR; - } - Tk_CreateEventHandler(window, StructureNotifyMask, - WaitWindowProc, (ClientData) &done); - done = 0; - lib_eventloop_core(check_rootwidget_flag, &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); - return TCL_OK; -} - -/****************************/ -/* vwait/tkwait with thread */ -/****************************/ -struct th_vwait_param { - VALUE thread; - int done; -}; - -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. */ -{ - struct th_vwait_param *param = (struct th_vwait_param *) clientData; - - param->done = 1; - rb_thread_run(param->thread); - - return (char *)NULL; -} - -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 = 1; - } - if (eventPtr->type == DestroyNotify) { - param->done = 2; - } -} - -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 = 1; - } -} - -#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 -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 dummy; - - DUMP1("Ruby's 'thread_vwait' is called"); - - if (eventloop_thread == rb_thread_current()) { -#if TCL_MAJOR_VERSION >= 8 - DUMP1("call ip_rbVwaitObjCmd"); - return ip_rbVwaitObjCmd(clientData, interp, objc, objv); -#else - DUMP1("call ip_rbVwaitCommand"); - return ip_rbVwaitCommand(clientData, interp, objc, objv); -#endif - } - - if (objc != 2) { -#ifdef Tcl_WrongNumArgs - Tcl_WrongNumArgs(interp, 1, objv, "name"); -#else -#if TCL_MAJOR_VERSION >= 8 - /* nameString = Tcl_GetString(objv[0]); */ - nameString = Tcl_GetStringFromObj(objv[0], &dummy); -#else - nameString = objv[0]; -#endif - Tcl_AppendResult(interp, "wrong # args: should be \"", - nameString, " name\"", (char *) NULL); -#endif - return TCL_ERROR; - } -#if TCL_MAJOR_VERSION >= 8 - /* nameString = Tcl_GetString(objv[1]); */ - nameString = Tcl_GetStringFromObj(objv[1], &dummy); -#else - nameString = objv[1]; -#endif - - param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); - param->thread = rb_thread_current(); - 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; - }; - - if (!param->done) { - rb_thread_stop(); - } - - Tcl_UntraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - rb_threadVwaitProc, (ClientData) param); - - Tcl_Free((char *)param); - - 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 -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; - int index; - static CONST char *optionStrings[] = { "variable", "visibility", "window", - (char *) NULL }; - enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW }; - char *nameString; - int dummy; - - DUMP1("Ruby's 'thread_tkwait' is called"); - - if (eventloop_thread == rb_thread_current()) { -#if TCL_MAJOR_VERSION >= 8 - DUMP1("call ip_rbTkWaitObjCmd"); - return ip_rbTkWaitObjCmd(clientData, interp, objc, objv); -#else - DUMP1("call rb_VwaitCommand"); - return ip_rbTkWaitCommand(clientData, interp, objc, objv); -#endif - } - - if (objc != 3) { -#ifdef Tcl_WrongNumArgs - Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); -#else -#if TCL_MAJOR_VERSION >= 8 - Tcl_AppendResult(interp, "wrong # args: should be \"", - Tcl_GetStringFromObj(objv[0], &dummy), - " variable|visibility|window name\"", - (char *) NULL); -#else - Tcl_AppendResult(interp, "wrong # args: should be \"", - objv[0], " variable|visibility|window name\"", - (char *) NULL); -#endif -#endif - return TCL_ERROR; - } - -#if TCL_MAJOR_VERSION >= 8 - if (Tcl_GetIndexFromObj(interp, objv[1], - (CONST84 char **)optionStrings, - "option", 0, &index) != TCL_OK) { - return TCL_ERROR; - } -#else - { - 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); - return TCL_ERROR; - } - } -#endif - -#if TCL_MAJOR_VERSION >= 8 - /* nameString = Tcl_GetString(objv[2]); */ - nameString = Tcl_GetStringFromObj(objv[2], &dummy); -#else - nameString = objv[2]; -#endif - - param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); - param->thread = rb_thread_current(); - param->done = 0; - - switch ((enum options) index) { - case TKWAIT_VARIABLE: { - if (Tcl_TraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - rb_threadVwaitProc, (ClientData) param) != TCL_OK) { - return TCL_ERROR; - }; - - if (!param->done) { - rb_thread_stop(); - } - - Tcl_UntraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - rb_threadVwaitProc, (ClientData) param); - break; - } - - case TKWAIT_VISIBILITY: { - Tk_Window window; - - window = Tk_NameToWindow(interp, nameString, tkwin); - if (window == NULL) { - return TCL_ERROR; - } - Tk_CreateEventHandler(window, - VisibilityChangeMask|StructureNotifyMask, - rb_threadWaitVisibilityProc, (ClientData) param); - if (!param->done) { - rb_thread_stop(); - } - if (param->done != 1) { - /* - * Note that we do not delete the event handler because it - * was deleted automatically when the window was destroyed. - */ - - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "window \"", nameString, - "\" was deleted before its visibility changed", - (char *) NULL); - return TCL_ERROR; - } - Tk_DeleteEventHandler(window, - VisibilityChangeMask|StructureNotifyMask, - rb_threadWaitVisibilityProc, (ClientData) param); - break; - } - - case TKWAIT_WINDOW: { - Tk_Window window; - - window = Tk_NameToWindow(interp, nameString, tkwin); - if (window == NULL) { - return TCL_ERROR; - } - Tk_CreateEventHandler(window, StructureNotifyMask, - rb_threadWaitWindowProc, (ClientData) param); - if (!param->done) { - rb_thread_stop(); - } - /* - * Note: there's no need to delete the event handler. It was - * deleted automatically when the window was destroyed. - */ - break; - } - } - - Tcl_Free((char *)param); - - /* - * Clear out the interpreter's result, since it may have been set - * by event handlers. - */ - - Tcl_ResetResult(interp); - return TCL_OK; -} - -static VALUE -ip_thread_vwait(self, var) - VALUE self; - VALUE var; -{ - VALUE argv[2]; - - argv[0] = rb_str_new2("thread_vwait"); - 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]; - - argv[0] = rb_str_new2("thread_tkwait"); - argv[1] = mode; - argv[2] = target; - return ip_invoke_real(3, argv, self); -} - - -/* destroy interpreter */ -static void -ip_free(ptr) - struct tcltkip *ptr; -{ - DUMP1("Tcl_DeleteInterp"); - if (ptr) { - Tcl_Release((ClientData)ptr->ip); - Tcl_DeleteInterp(ptr->ip); - free(ptr); - } -} - -/* 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; - - /* create object */ - Data_Get_Struct(self, struct tcltkip, ptr); - ptr = ALLOC(struct tcltkip); - DATA_PTR(self) = ptr; - ptr->return_value = 0; - - /* from Tk_Main() */ - DUMP1("Tcl_CreateInterp"); - ptr->ip = Tcl_CreateInterp(); - Tcl_Preserve((ClientData)ptr->ip); - current_interp = ptr->ip; - - /* from Tcl_AppInit() */ - DUMP1("Tcl_Init"); - if (Tcl_Init(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); - } - - /* set variables */ - cnt = rb_scan_args(argc, argv, "02", &argv0, &opts); - switch(cnt) { - case 2: - /* options */ - if (opts == Qnil || opts == Qfalse) { - /* without Tk */ - with_tk = 0; - } else { - Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), 0); - } - case 1: - /* argv0 */ - if (argv0 != Qnil) { - Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0); - } - case 0: - /* no args */ - ; - } - - /* from Tcl_AppInit() */ - if (with_tk) { - DUMP1("Tk_Init"); - if (Tk_Init(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); - } - DUMP1("Tcl_StaticPackage(\"Tk\")"); -#if TCL_MAJOR_VERSION >= 8 - Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, Tk_SafeInit); -#else - Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, - (Tcl_PackageInitProc *) NULL); -#endif - } - - /* add ruby command to the interpreter */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"ruby\")"); - Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby, (ClientData)NULL, - (Tcl_CmdDeleteProc *)NULL); -#else - DUMP1("Tcl_CreateCommand(\"ruby\")"); - Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby, (ClientData)NULL, - (Tcl_CmdDeleteProc *)NULL); -#endif - - /* replace 'vwait' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"vwait\")"); - Tcl_CreateObjCommand(ptr->ip, "vwait", ip_rbVwaitObjCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#else - DUMP1("Tcl_CreateCommand(\"vwait\")"); - Tcl_CreateCommand(ptr->ip, "vwait", ip_rbVwaitCommand, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* replace 'tkwait' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"tkwait\")"); - Tcl_CreateObjCommand(ptr->ip, "tkwait", ip_rbTkWaitObjCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#else - DUMP1("Tcl_CreateCommand(\"tkwait\")"); - Tcl_CreateCommand(ptr->ip, "tkwait", ip_rbTkWaitCommand, - (ClientData)NULL, (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)NULL, (Tcl_CmdDeleteProc *)NULL); -#else - DUMP1("Tcl_CreateCommand(\"thread_vwait\")"); - Tcl_CreateCommand(ptr->ip, "thread_vwait", ip_rb_threadVwaitCommand, - (ClientData)NULL, (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)NULL, (Tcl_CmdDeleteProc *)NULL); -#else - DUMP1("Tcl_CreateCommand(\"thread_tkwait\")"); - Tcl_CreateCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitCommand, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#endif - - 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 name; - VALUE safemode; - int safe; - - /* 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 || safemode == Qnil) { - safe = 0; - rb_secure(4); - } else { - safe = 1; - } - - /* create slave-ip */ - if ((slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe)) - == NULL) { - rb_raise(rb_eRuntimeError, "fail to create the new slave interpreter"); - } - Tcl_Preserve((ClientData)slave->ip); - slave->return_value = 0; - - 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); - - if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); - } - - return self; -} - -/* is safe? */ -static VALUE -ip_is_safe_p(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - if (Tcl_IsSafe(ptr->ip)) { - return Qtrue; - } else { - return Qfalse; - } -} - -/* delete interpreter */ -static VALUE -ip_delete(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - Tcl_DeleteInterp(ptr->ip); - - return Qnil; -} - -/* is deleted? */ -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; - } -} - - -/* eval string in tcl by Tcl_Eval() */ -static VALUE -ip_eval_real(self, str) - VALUE self; - VALUE str; -{ - char *s; - char *buf; /* Tcl_Eval requires re-writable string region */ - struct tcltkip *ptr = get_ip(self); - - /* call Tcl_Eval() */ - s = StringValuePtr(str); - buf = ALLOCA_N(char, strlen(s)+1); - strcpy(buf, s); - DUMP2("Tcl_Eval(%s)", buf); - ptr->return_value = Tcl_Eval(ptr->ip, buf); - if (ptr->return_value == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); - } - DUMP2("(TCL_Eval result) %d", ptr->return_value); - - /* pass back the result (as string) */ - /* return(rb_str_new2(ptr->ip->result)); */ - return(rb_tainted_str_new2(ptr->ip->result)); -} - -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->obj, q->str); -} - -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; - - DUMP2("do_eval_queue_handler : evPtr = %lx", 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) { - *(q->result) - = rb_funcall(rb_proc_new(evq_safelevel_handler, - Data_Wrap_Struct(rb_cData,0,0,q)), - rb_intern("call"), 0); - } else { - DUMP2("call eval_real (for caller thread:%lx)", q->thread); - DUMP2("call eval_real (current thread:%lx)", rb_thread_current()); - *(q->result) = ip_eval_real(q->obj, q->str); - } - - /* 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 *tmp; - VALUE current = rb_thread_current(); - VALUE result; - VALUE *alloc_result; - Tcl_QueuePosition position; - - 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, str); - if (rb_obj_is_kind_of(result, rb_eException)) { - rb_exc_raise(result); - } - return result; - } - - DUMP2("eval from thread %lx (NOT current eventloop)", current); - - /* allocate memory (protected from Tcl_ServiceEvent) */ - alloc_result = ALLOC(VALUE); - - /* allocate memory (freed by Tcl_ServiceEvent) */ - tmp = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); - - /* construct event data */ - tmp->done = 0; - tmp->obj = self; - tmp->str = str; - tmp->result = alloc_result; - tmp->thread = current; - tmp->safe_level = rb_safe_level(); - tmp->ev.proc = eval_queue_handler; - position = TCL_QUEUE_TAIL; - - /* add the handler to Tcl event queue */ - DUMP1("add handler"); - Tcl_QueueEvent(&(tmp->ev), position); - - /* wait for the handler to be processed */ - DUMP2("wait for handler (current thread:%lx)", current); - rb_thread_stop(); - DUMP2("back from handler (current thread:%lx)", current); - - /* get result & free allocated memory */ - result = *alloc_result; - free(alloc_result); - if (rb_obj_is_kind_of(result, rb_eException)) { - rb_exc_raise(result); - } - - return result; -} - - -/* restart Tk */ -static VALUE -lib_restart(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - rb_secure(4); - - /* destroy the root wdiget */ - /* ptr->return_value = Tcl_Eval(ptr->ip, "destroy ."); */ - ptr->return_value = FIX2INT(ip_eval(self, "destroy .")); - /* 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) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); - } - } else { - DUMP1("Tk_Init"); - if (Tk_Init(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); - } - } -#else - DUMP1("Tk_Init"); - if (Tk_Init(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); - } -#endif - - return Qnil; -} - - -static VALUE -ip_restart(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - rb_secure(4); - if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { - /* slave IP */ - return Qnil; - } - return lib_restart(self); -} - -static VALUE -ip_toUTF8(self, str, encodename) - VALUE self; - VALUE str; - VALUE encodename; -{ -#ifdef TCL_UTF_MAX - Tcl_Interp *interp; - Tcl_Encoding encoding; - Tcl_DString dstr; - struct tcltkip *ptr; - char *buf; - - ptr = get_ip(self); - interp = ptr->ip; - - StringValue(encodename); - StringValue(str); - encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr); - if (!RSTRING(str)->len) return str; - buf = ALLOCA_N(char,strlen(RSTRING(str)->ptr)+1); - strcpy(buf, RSTRING(str)->ptr); - - Tcl_DStringInit(&dstr); - Tcl_DStringFree(&dstr); - Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr); - /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */ - str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); - - Tcl_FreeEncoding(encoding); - Tcl_DStringFree(&dstr); -#endif - return str; -} - -static VALUE -ip_fromUTF8(self, str, encodename) - VALUE self; - VALUE str; - VALUE encodename; -{ -#ifdef TCL_UTF_MAX - Tcl_Interp *interp; - Tcl_Encoding encoding; - Tcl_DString dstr; - struct tcltkip *ptr; - char *buf; - - ptr = get_ip(self); - interp = ptr->ip; - - StringValue(encodename); - StringValue(str); - encoding = Tcl_GetEncoding(interp,RSTRING(encodename)->ptr); - if (!RSTRING(str)->len) return str; - buf = ALLOCA_N(char,strlen(RSTRING(str)->ptr)+1); - strcpy(buf,RSTRING(str)->ptr); - - Tcl_DStringInit(&dstr); - Tcl_DStringFree(&dstr); - Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr); - /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */ - str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); - - Tcl_FreeEncoding(encoding); - Tcl_DStringFree(&dstr); - -#endif - return str; -} - - -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_iv_set(einfo, "interp", interp); - Tcl_ResetResult(get_ip(interp)->ip); - return einfo; -} - - -static VALUE -ip_invoke_real(argc, argv, obj) - int argc; - VALUE *argv; - VALUE obj; -{ - VALUE v; - struct tcltkip *ptr; /* tcltkip data struct */ - int i; - Tcl_CmdInfo info; - char *cmd, *s; - char **av = (char **)NULL; -#if TCL_MAJOR_VERSION >= 8 - Tcl_Obj **ov = (Tcl_Obj **)NULL; - Tcl_Obj *resultPtr; -#endif - - DUMP2("invoke_real called by thread:%lx", rb_thread_current()); - /* get the command name string */ - v = argv[0]; - cmd = StringValuePtr(v); - - /* get the data struct */ - ptr = get_ip(obj); - - /* ip is deleted? */ - if (Tcl_InterpDeleted(ptr->ip)) { - 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(obj, 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"); - - /* memory allocation for arguments of this command */ -#if TCL_MAJOR_VERSION >= 8 - if (info.isNativeObjectProc) { - /* object interface */ - ov = (Tcl_Obj **)ALLOCA_N(Tcl_Obj *, argc+1); - for (i = 0; i < argc; ++i) { - v = argv[i]; - s = StringValuePtr(v); - ov[i] = Tcl_NewStringObj(s, RSTRING(v)->len); - Tcl_IncrRefCount(ov[i]); - } - ov[argc] = (Tcl_Obj *)NULL; - } - else -#endif - { - /* string interface */ - av = (char **)ALLOCA_N(char *, argc+1); - for (i = 0; i < argc; ++i) { - v = argv[i]; - s = StringValuePtr(v); - av[i] = ALLOCA_N(char, strlen(s)+1); - strcpy(av[i], s); - } - av[argc] = (char *)NULL; - } - - Tcl_ResetResult(ptr->ip); - - /* Invoke the C procedure */ -#if TCL_MAJOR_VERSION >= 8 - if (info.isNativeObjectProc) { - int dummy; - ptr->return_value = (*info.objProc)(info.objClientData, - ptr->ip, argc, ov); - - /* get the string value from the result object */ - resultPtr = Tcl_GetObjResult(ptr->ip); - Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &dummy), - TCL_VOLATILE); - - for (i=0; i<argc; i++) { - Tcl_DecrRefCount(ov[i]); - } - } - else -#endif - { - TRAP_BEG; -#if TCL_MAJOR_VERSION >= 8 - ptr->return_value = (*info.proc)(info.clientData, ptr->ip, - argc, (CONST84 char **)av); -#else /* TCL_MAJOR_VERSION < 8 */ - ptr->return_value = (*info.proc)(info.clientData, ptr->ip, argc, av); -#endif - TRAP_END; - } - - /* exception on mainloop */ - if (ptr->return_value == TCL_ERROR) { - if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) { - /*rb_ip_raise(obj, rb_eRuntimeError, "%s", ptr->ip->result);*/ - return create_ip_exc(obj, rb_eRuntimeError, "%s", ptr->ip->result); - } else { - if (event_loop_abort_on_exc < 0) { - rb_warning("%s (ignore)", ptr->ip->result); - } else { - rb_warn("%s (ignore)", ptr->ip->result); - } - Tcl_ResetResult(ptr->ip); - return rb_tainted_str_new2(""); - } - } - - /* pass back the result (as string) */ - /* return rb_str_new2(ptr->ip->result); */ - return rb_tainted_str_new2(ptr->ip->result); -} - -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_real(q->argc, q->argv, q->obj); -} - -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; - - DUMP2("do_invoke_queue_handler : evPtr = %lx", 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->result) - = rb_funcall(rb_proc_new(ivq_safelevel_handler, - Data_Wrap_Struct(rb_cData,0,0,q)), - rb_intern("call"), 0); - } else { - DUMP2("call invoke_real (for caller thread:%lx)", q->thread); - DUMP2("call invoke_real (current thread:%lx)", rb_thread_current()); - *(q->result) = ip_invoke_real(q->argc, q->argv, q->obj); - } - - /* 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(argc, argv, obj) - int argc; - VALUE *argv; - VALUE obj; -{ - struct invoke_queue *tmp; - VALUE current = rb_thread_current(); - VALUE result; - VALUE *alloc_argv, *alloc_result; - Tcl_QueuePosition position; - - 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, 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); - - /* allocate memory (protected from Tcl_ServiceEvent) */ - alloc_argv = ALLOC_N(VALUE,argc); - MEMCPY(alloc_argv, argv, VALUE, argc); - alloc_result = ALLOC(VALUE); - - /* allocate memory (freed by Tcl_ServiceEvent) */ - tmp = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); - - /* construct event data */ - tmp->done = 0; - tmp->obj = obj; - tmp->argc = argc; - tmp->argv = alloc_argv; - tmp->result = alloc_result; - tmp->thread = current; - tmp->safe_level = rb_safe_level(); - tmp->ev.proc = invoke_queue_handler; - position = TCL_QUEUE_TAIL; - - /* add the handler to Tcl event queue */ - DUMP1("add handler"); - Tcl_QueueEvent(&(tmp->ev), position); - - /* wait for the handler to be processed */ - DUMP2("wait for handler (current thread:%lx)", current); - rb_thread_stop(); - DUMP2("back from handler (current thread:%lx)", current); - - /* get result & free allocated memory */ - result = *alloc_result; - free(alloc_argv); - free(alloc_result); - if (rb_obj_is_kind_of(result, rb_eException)) { - rb_exc_raise(result); - } - - return result; -} - -/* 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); - - return (INT2FIX(ptr->return_value)); -} - -#ifdef __MACOS__ -static void -_macinit() -{ - tcl_macQdPtr = &qd; /* setup QuickDraw globals */ - Tcl_MacSetEventProc(TkMacConvertEvent); /* setup event handler */ -} -#endif - -/*---- initialization ----*/ -void -Init_tcltklib() -{ - VALUE lib = rb_define_module("TclTkLib"); - VALUE ip = rb_define_class("TclTkIp", rb_cObject); - - VALUE ev_flag = rb_define_module_under(lib, "EventFlag"); - -#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_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)); - - eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError); - eTkCallbackContinue = rb_define_class("TkCallbackContinue", - rb_eStandardError); - - 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, "get_eventloop_weight", - get_eventloop_weight, 0); - rb_define_module_function(lib, "num_of_mainwindows", - lib_num_of_mainwindows, 0); - - 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, "delete", ip_delete, 0); - rb_define_method(ip, "deleted?", ip_is_deleted_p, 0); - rb_define_method(ip, "_eval", ip_eval, 1); - rb_define_method(ip, "_toUTF8",ip_toUTF8, 2); - rb_define_method(ip, "_fromUTF8",ip_fromUTF8, 2); - 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, "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, "restart", ip_restart, 0); - - eventloop_thread = 0; - watchdog_thread = 0; - -#ifdef __MACOS__ - _macinit(); -#endif - - /*---- initialize tcl/tk libraries ----*/ - /* from Tk_Main() */ - DUMP1("Tcl_FindExecutable"); - Tcl_FindExecutable(RSTRING(rb_argv0)->ptr); -} - -/* eof */ |