diff options
Diffstat (limited to 'ext/tk/tcltklib.c')
-rw-r--r-- | ext/tk/tcltklib.c | 11066 |
1 files changed, 0 insertions, 11066 deletions
diff --git a/ext/tk/tcltklib.c b/ext/tk/tcltklib.c deleted file mode 100644 index 1e425d7654..0000000000 --- a/ext/tk/tcltklib.c +++ /dev/null @@ -1,11066 +0,0 @@ -/* - * tcltklib.c - * Aug. 27, 1997 Y. Shigehiro - * Oct. 24, 1997 Y. Matsumoto - */ - -#define TCLTKLIB_RELEASE_DATE "2010-08-25" -/* #define CREATE_RUBYTK_KIT */ - -#include "ruby.h" - -#ifdef HAVE_RUBY_ENCODING_H -#include "ruby/encoding.h" -#endif -#ifdef HAVE_RUBY_VERSION_H -#include "ruby/version.h" -#endif - -#undef RUBY_UNTYPED_DATA_WARNING -#define RUBY_UNTYPED_DATA_WARNING 0 - -#ifdef HAVE_RB_THREAD_CHECK_TRAP_PENDING -static int rb_thread_critical; /* dummy */ -int rb_thread_check_trap_pending(void); -#else -/* use rb_thread_critical on Ruby 1.8.x */ -#include "rubysig.h" -#define rb_thread_check_trap_pending() (0+rb_trap_pending) -#endif - -#if !defined(RSTRING_PTR) -#define RSTRING_PTR(s) (RSTRING(s)->ptr) -#define RSTRING_LEN(s) (RSTRING(s)->len) -#endif -#if !defined(RSTRING_LENINT) -#define RSTRING_LENINT(s) ((int)RSTRING_LEN(s)) -#endif -#if !defined(RARRAY_PTR) -#define RARRAY_PTR(s) (RARRAY(s)->ptr) -#define RARRAY_LEN(s) (RARRAY(s)->len) -#endif -#if !defined(RARRAY_CONST_PTR) -#define RARRAY_CONST_PTR(s) (const VALUE *)RARRAY_PTR(s) -#endif -#if !defined(RARRAY_AREF) -#define RARRAY_AREF(a, i) RARRAY_CONST_PTR(a)[i] -#endif - -#ifdef OBJ_UNTRUST -#define RbTk_OBJ_UNTRUST(x) do {OBJ_TAINT(x); OBJ_UNTRUST(x);} while (0) -#else -#define RbTk_OBJ_UNTRUST(x) OBJ_TAINT(x) -#endif -#define RbTk_ALLOC_N(type, n) (type *)ckalloc((int)(sizeof(type) * (n))) - -#if defined(HAVE_RB_PROC_NEW) && !defined(RUBY_VM) -/* Ruby 1.8 :: rb_proc_new() was hidden from intern.h at 2008/04/22 */ -extern VALUE rb_proc_new _((VALUE (*)(ANYARGS/* VALUE yieldarg[, VALUE procarg] */), VALUE)); -#endif - -#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> - -#if !defined HAVE_VSNPRINTF && !defined vsnprintf -# ifdef WIN32 - /* In Win32, vsnprintf is available as the "non-ANSI" _vsnprintf. */ -# define vsnprintf _vsnprintf -# else -# ifdef HAVE_RUBY_RUBY_H -# include "ruby/missing.h" -# else -# include "missing.h" -# endif -# endif -#endif - -#include <tcl.h> -#include <tk.h> - -#ifndef HAVE_RUBY_NATIVE_THREAD_P -#define ruby_native_thread_p() is_ruby_native_thread() -#undef RUBY_USE_NATIVE_THREAD -#else -#define RUBY_USE_NATIVE_THREAD 1 -#endif - -#ifndef HAVE_RB_ERRINFO -#define rb_errinfo() (ruby_errinfo+0) /* cannot be l-value */ -#else -VALUE rb_errinfo(void); -#endif -#ifndef HAVE_RB_SAFE_LEVEL -#define rb_safe_level() (ruby_safe_level+0) -#endif -#ifndef HAVE_RB_SOURCEFILE -#define rb_sourcefile() (ruby_sourcefile+0) -#endif - -#include "stubs.h" - -#ifndef TCL_ALPHA_RELEASE -#define TCL_ALPHA_RELEASE 0 /* "alpha" */ -#define TCL_BETA_RELEASE 1 /* "beta" */ -#define TCL_FINAL_RELEASE 2 /* "final" */ -#endif - -static struct { - int major; - int minor; - int type; /* ALPHA==0, BETA==1, FINAL==2 */ - int patchlevel; -} tcltk_version = {0, 0, 0, 0}; - -static void -set_tcltk_version(void) -{ - if (tcltk_version.major) return; - - Tcl_GetVersion(&(tcltk_version.major), - &(tcltk_version.minor), - &(tcltk_version.patchlevel), - &(tcltk_version.type)); -} - -#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 - -#ifndef CONST86 -# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 5 /* Tcl8.0.x -- 8.5.x */ -# define CONST86 -# else -# define CONST86 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 DUMP3(ARG1, ARG2, ARG3) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\ -fprintf(stderr, ARG1, ARG2, ARG3); fprintf(stderr, "\n"); fflush(stderr); } -/* -#define DUMP1(ARG1) -#define DUMP2(ARG1, ARG2) -#define DUMP3(ARG1, ARG2, ARG3) -*/ - -/* release date */ -static const char tcltklib_release_date[] = TCLTKLIB_RELEASE_DATE; - -/* finalize_proc_name */ -static const char finalize_hook_name[] = "INTERP_FINALIZE_HOOK"; - -static void ip_finalize _((Tcl_Interp*)); -static void ip_free _((void *p)); - -static int at_exit = 0; - -#ifdef HAVE_RUBY_ENCODING_H -static VALUE cRubyEncoding; - -/* encoding */ -static int ENCODING_INDEX_UTF8; -static int ENCODING_INDEX_BINARY; -#endif -static VALUE ENCODING_NAME_UTF8; -static VALUE ENCODING_NAME_BINARY; - -static VALUE create_dummy_encoding_for_tk_core _((VALUE, VALUE, VALUE)); -static VALUE create_dummy_encoding_for_tk _((VALUE, VALUE)); -static int update_encoding_table _((VALUE, VALUE, VALUE)); -static VALUE encoding_table_get_name_core _((VALUE, VALUE, VALUE)); -static VALUE encoding_table_get_obj_core _((VALUE, VALUE, VALUE)); -static VALUE encoding_table_get_name _((VALUE, VALUE)); -static VALUE encoding_table_get_obj _((VALUE, VALUE)); -static VALUE create_encoding_table _((VALUE)); -static VALUE ip_get_encoding_table _((VALUE)); - - -/* for callback break & continue */ -static VALUE eTkCallbackReturn; -static VALUE eTkCallbackBreak; -static VALUE eTkCallbackContinue; - -static VALUE eLocalJumpError; - -static VALUE eTkLocalJumpError; -static VALUE eTkCallbackRetry; -static VALUE eTkCallbackRedo; -static VALUE eTkCallbackThrow; - -static VALUE tcltkip_class; - -static ID ID_at_enc; -static ID ID_at_interp; - -static ID ID_encoding_name; -static ID ID_encoding_table; - -static ID ID_stop_p; -static ID ID_alive_p; -static ID ID_kill; -static ID ID_join; -static ID ID_value; - -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)); -static VALUE ip_invoke_with_position _((int, VALUE*, VALUE, Tcl_QueuePosition)); -static VALUE tk_funcall _((VALUE(), int, VALUE*, VALUE)); -static VALUE callq_safelevel_handler _((VALUE, VALUE)); - -/* Tcl's object type */ -#if TCL_MAJOR_VERSION >= 8 -static const char Tcl_ObjTypeName_ByteArray[] = "bytearray"; -static CONST86 Tcl_ObjType *Tcl_ObjType_ByteArray; - -static const char Tcl_ObjTypeName_String[] = "string"; -static CONST86 Tcl_ObjType *Tcl_ObjType_String; - -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) -#define IS_TCL_BYTEARRAY(obj) ((obj)->typePtr == Tcl_ObjType_ByteArray) -#define IS_TCL_STRING(obj) ((obj)->typePtr == Tcl_ObjType_String) -#define IS_TCL_VALID_STRING(obj) ((obj)->bytes != (char*)NULL) -#endif -#endif - -#ifndef HAVE_RB_HASH_LOOKUP -#define rb_hash_lookup rb_hash_aref -#endif - -#ifndef HAVE_RB_THREAD_ALIVE_P -#define rb_thread_alive_p(thread) rb_funcall2((thread), ID_alive_p, 0, NULL) -#endif - -/* safe Tcl_Eval and Tcl_GlobalEval */ -static int -#ifdef HAVE_PROTOTYPES -tcl_eval(Tcl_Interp *interp, const char *cmd) -#else -tcl_eval(interp, cmd) - Tcl_Interp *interp; - const char *cmd; /* don't have to be writable */ -#endif -{ - char *buf = strdup(cmd); - int ret; - - Tcl_AllowExceptions(interp); - ret = Tcl_Eval(interp, buf); - free(buf); - return ret; -} - -#undef Tcl_Eval -#define Tcl_Eval tcl_eval - -static int -#ifdef HAVE_PROTOTYPES -tcl_global_eval(Tcl_Interp *interp, const char *cmd) -#else -tcl_global_eval(interp, cmd) - Tcl_Interp *interp; - const char *cmd; /* don't have to be writable */ -#endif -{ - char *buf = strdup(cmd); - int ret; - - Tcl_AllowExceptions(interp); - ret = Tcl_GlobalEval(interp, buf); - free(buf); - return ret; -} - -#undef Tcl_GlobalEval -#define Tcl_GlobalEval tcl_global_eval - -/* Tcl_{Incr|Decr}RefCount for tcl7.x or earlier */ -#if TCL_MAJOR_VERSION < 8 -#define Tcl_IncrRefCount(obj) (1) -#define Tcl_DecrRefCount(obj) (1) -#endif - -/* Tcl_GetStringResult for tcl7.x or earlier */ -#if TCL_MAJOR_VERSION < 8 -#define Tcl_GetStringResult(interp) ((interp)->result) -#endif - -/* Tcl_[GS]etVar2Ex for tcl8.0 */ -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 -static Tcl_Obj * -Tcl_GetVar2Ex(interp, name1, name2, flags) - Tcl_Interp *interp; - CONST char *name1; - CONST char *name2; - int flags; -{ - Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj; - - nameObj1 = Tcl_NewStringObj((char*)name1, -1); - Tcl_IncrRefCount(nameObj1); - - if (name2) { - nameObj2 = Tcl_NewStringObj((char*)name2, -1); - Tcl_IncrRefCount(nameObj2); - } - - retObj = Tcl_ObjGetVar2(interp, nameObj1, nameObj2, flags); - - if (name2) { - Tcl_DecrRefCount(nameObj2); - } - - Tcl_DecrRefCount(nameObj1); - - return retObj; -} - -static Tcl_Obj * -Tcl_SetVar2Ex(interp, name1, name2, newValObj, flags) - Tcl_Interp *interp; - CONST char *name1; - CONST char *name2; - Tcl_Obj *newValObj; - int flags; -{ - Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj; - - nameObj1 = Tcl_NewStringObj((char*)name1, -1); - Tcl_IncrRefCount(nameObj1); - - if (name2) { - nameObj2 = Tcl_NewStringObj((char*)name2, -1); - Tcl_IncrRefCount(nameObj2); - } - - retObj = Tcl_ObjSetVar2(interp, nameObj1, nameObj2, newValObj, flags); - - if (name2) { - Tcl_DecrRefCount(nameObj2); - } - - Tcl_DecrRefCount(nameObj1); - - return retObj; -} -#endif - -/* from tkAppInit.c */ - -#if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 4) -# 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 -#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; -}; - -struct call_queue { - Tcl_Event ev; - VALUE (*func)(); - int argc; - VALUE *argv; - 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); -} - -void -call_queue_mark(struct call_queue *q) -{ - int i; - - for(i = 0; i < q->argc; i++) { - rb_gc_mark(q->argv[i]); - } - - rb_gc_mark(q->interp); - rb_gc_mark(q->result); - rb_gc_mark(q->thread); -} - - -static VALUE eventloop_thread; -static Tcl_Interp *eventloop_interp; -#ifdef RUBY_USE_NATIVE_THREAD -Tcl_ThreadId tk_eventloop_thread_id; /* native thread ID of Tcl interpreter */ -#endif -static VALUE eventloop_stack; -static int window_event_mode = ~0; - -static VALUE watchdog_thread; - -Tcl_Interp *current_interp; - -/* thread control strategy */ -/* multi-tk works with the following settings only ??? - : CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1 - : USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0 - : DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0 -*/ -#ifdef RUBY_USE_NATIVE_THREAD -#define CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1 -#define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0 -#define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 1 -#else /* ! RUBY_USE_NATIVE_THREAD */ -#define CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1 -#define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0 -#define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0 -#endif - -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE -static int have_rb_thread_waiting_for_value = 0; -#endif - -/* - * '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. - */ -#ifdef RUBY_USE_NATIVE_THREAD -#define DEFAULT_EVENT_LOOP_MAX 800/*counts*/ -#define DEFAULT_NO_EVENT_TICK 10/*counts*/ -#define DEFAULT_NO_EVENT_WAIT 5/*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 ) */ -#else /* ! RUBY_USE_NATIVE_THREAD */ -#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 ) */ -#endif - -#define EVENT_HANDLER_TIMEOUT 100/*milliseconds*/ - -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; - - -/* call ruby interpreter */ -#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 - -struct cmd_body_arg { - VALUE receiver; - ID method; - VALUE args; -}; - -/*----------------------------*/ -/* use Tcl internal functions */ -/*----------------------------*/ -#ifndef TCL_NAMESPACE_DEBUG -#define TCL_NAMESPACE_DEBUG 0 -#endif - -#if TCL_NAMESPACE_DEBUG - -#if TCL_MAJOR_VERSION >= 8 -EXTERN struct TclIntStubs *tclIntStubsPtr; -#endif - -/*-- Tcl_GetCurrentNamespace --*/ -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5 -/* Tcl7.x doesn't have namespace support. */ -/* Tcl8.5+ has definition of Tcl_GetCurrentNamespace() in tclDecls.h */ -# ifndef Tcl_GetCurrentNamespace -EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace _((Tcl_Interp *)); -# endif -# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) -# ifndef Tcl_GetCurrentNamespace -# ifndef FunctionNum_of_GetCurrentNamespace -#define FunctionNum_of_GetCurrentNamespace 124 -# endif -struct DummyTclIntStubs_for_GetCurrentNamespace { - int magic; - struct TclIntStubHooks *hooks; - void (*func[FunctionNum_of_GetCurrentNamespace])(); - Tcl_Namespace * (*tcl_GetCurrentNamespace) _((Tcl_Interp *)); -}; - -#define Tcl_GetCurrentNamespace \ - (((struct DummyTclIntStubs_for_GetCurrentNamespace *)tclIntStubsPtr)->tcl_GetCurrentNamespace) -# endif -# endif -#endif - -/* namespace check */ -/* ip_null_namespace(Tcl_Interp *interp) */ -#if TCL_MAJOR_VERSION < 8 -#define ip_null_namespace(interp) (0) -#else /* support namespace */ -#define ip_null_namespace(interp) \ - (Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL) -#endif - -/* rbtk_invalid_namespace(tcltkip *ptr) */ -#if TCL_MAJOR_VERSION < 8 -#define rbtk_invalid_namespace(ptr) (0) -#else /* support namespace */ -#define rbtk_invalid_namespace(ptr) \ - ((ptr)->default_ns == (Tcl_Namespace*)NULL || Tcl_GetCurrentNamespace((ptr)->ip) != (ptr)->default_ns) -#endif - -/*-- Tcl_PopCallFrame & Tcl_PushCallFrame --*/ -#if TCL_MAJOR_VERSION >= 8 -# ifndef CallFrame -typedef struct CallFrame { - Tcl_Namespace *nsPtr; - int dummy1; - int dummy2; - char *dummy3; - struct CallFrame *callerPtr; - struct CallFrame *callerVarPtr; - int level; - char *dummy7; - char *dummy8; - int dummy9; - char* dummy10; -} CallFrame; -# endif - -# if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED) -EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **)); -# endif -# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) -# ifndef TclGetFrame -# ifndef FunctionNum_of_GetFrame -#define FunctionNum_of_GetFrame 32 -# endif -struct DummyTclIntStubs_for_GetFrame { - int magic; - struct TclIntStubHooks *hooks; - void (*func[FunctionNum_of_GetFrame])(); - int (*tclGetFrame) _((Tcl_Interp *, CONST char *, CallFrame **)); -}; -#define TclGetFrame \ - (((struct DummyTclIntStubs_for_GetFrame *)tclIntStubsPtr)->tclGetFrame) -# endif -# endif - -# if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED) -EXTERN void Tcl_PopCallFrame _((Tcl_Interp *)); -EXTERN int Tcl_PushCallFrame _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int)); -# endif -# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) -# ifndef Tcl_PopCallFrame -# ifndef FunctionNum_of_PopCallFrame -#define FunctionNum_of_PopCallFrame 128 -# endif -struct DummyTclIntStubs_for_PopCallFrame { - int magic; - struct TclIntStubHooks *hooks; - void (*func[FunctionNum_of_PopCallFrame])(); - void (*tcl_PopCallFrame) _((Tcl_Interp *)); - int (*tcl_PushCallFrame) _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int)); -}; - -#define Tcl_PopCallFrame \ - (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PopCallFrame) -#define Tcl_PushCallFrame \ - (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PushCallFrame) -# endif -# endif - -#else /* Tcl7.x */ -# ifndef CallFrame -typedef struct CallFrame { - Tcl_HashTable varTable; - int level; - int argc; - char **argv; - struct CallFrame *callerPtr; - struct CallFrame *callerVarPtr; -} CallFrame; -# endif -# ifndef Tcl_CallFrame -#define Tcl_CallFrame CallFrame -# endif - -# if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED) -EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **)); -# endif - -# if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED) -typedef struct DummyInterp { - char *dummy1; - char *dummy2; - int dummy3; - Tcl_HashTable dummy4; - Tcl_HashTable dummy5; - Tcl_HashTable dummy6; - int numLevels; - int maxNestingDepth; - CallFrame *framePtr; - CallFrame *varFramePtr; -} DummyInterp; - -static void -Tcl_PopCallFrame(interp) - Tcl_Interp *interp; -{ - DummyInterp *iPtr = (DummyInterp*)interp; - CallFrame *frame = iPtr->varFramePtr; - - /* **** DUMMY **** */ - iPtr->framePtr = frame.callerPtr; - iPtr->varFramePtr = frame.callerVarPtr; - - return TCL_OK; -} - -/* dummy */ -#define Tcl_Namespace char - -static int -Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame) - Tcl_Interp *interp; - Tcl_CallFrame *framePtr; - Tcl_Namespace *nsPtr; - int isProcCallFrame; -{ - DummyInterp *iPtr = (DummyInterp*)interp; - CallFrame *frame = (CallFrame *)framePtr; - - /* **** DUMMY **** */ - Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS); - if (iPtr->varFramePtr != NULL) { - frame.level = iPtr->varFramePtr->level + 1; - } else { - frame.level = 1; - } - frame.callerPtr = iPtr->framePtr; - frame.callerVarPtr = iPtr->varFramePtr; - iPtr->framePtr = &frame; - iPtr->varFramePtr = &frame; - - return TCL_OK; -} -# endif - -#endif - -#endif /* TCL_NAMESPACE_DEBUG */ - - -/*---- class TclTkIp ----*/ -struct tcltkip { - Tcl_Interp *ip; /* the interpreter */ -#if TCL_NAMESPACE_DEBUG - Tcl_Namespace *default_ns; /* default namespace */ -#endif -#ifdef RUBY_USE_NATIVE_THREAD - Tcl_ThreadId tk_thread_id; /* native thread ID of Tcl interpreter */ -#endif - 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 const rb_data_type_t tcltkip_type = { - "tcltkip", - {0, ip_free, 0,}, -}; - -static struct tcltkip * -get_ip(self) - VALUE self; -{ - struct tcltkip *ptr; - - TypedData_Get_Struct(self, struct tcltkip, &tcltkip_type, ptr); - if (ptr == 0) { - /* rb_raise(rb_eTypeError, "uninitialized TclTkIp"); */ - return((struct tcltkip *)NULL); - } - if (ptr->ip == (Tcl_Interp*)NULL) { - /* rb_raise(rb_eRuntimeError, "deleted IP"); */ - return((struct tcltkip *)NULL); - } - return ptr; -} - -static int -deleted_ip(ptr) - struct tcltkip *ptr; -{ - if (!ptr || !ptr->ip || Tcl_InterpDeleted(ptr->ip) -#if TCL_NAMESPACE_DEBUG - || rbtk_invalid_namespace(ptr) -#endif - ) { - DUMP1("ip is deleted"); - return 1; - } - return 0; -} - -/* increment/decrement reference count of tcltkip */ -static int -rbtk_preserve_ip(ptr) - struct tcltkip *ptr; -{ - ptr->ref_count++; - if (ptr->ip == (Tcl_Interp*)NULL) { - /* deleted IP */ - ptr->ref_count = 0; - } else { - 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 if (ptr->ip == (Tcl_Interp*)NULL) { - /* deleted IP */ - ptr->ref_count = 0; - } else { - Tcl_Release((ClientData)ptr->ip); - } - return(ptr->ref_count); -} - - -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; - VALUE msg; - VALUE einfo; - struct tcltkip *ptr = get_ip(interp); - - va_init_list(args,fmt); - msg = rb_vsprintf(fmt, args); - va_end(args); - einfo = rb_exc_new_str(exc, msg); - rb_ivar_set(einfo, ID_at_interp, interp); - if (ptr) { - Tcl_ResetResult(ptr->ip); - } - - return einfo; -} - - -/*####################################################################*/ -#if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT - -/*--------------------------------------------------------*/ - -#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 84 -#error Ruby/Tk-Kit requires Tcl/Tk8.4 or later. -#endif - -/*--------------------------------------------------------*/ - -/* Many part of code to support Ruby/Tk-Kit is quoted from Tclkit. */ -/* But, never ask Tclkit community about Ruby/Tk-Kit. */ -/* Please ask Ruby (Ruby/Tk) community (e.g. "ruby-dev" mailing list). */ -/* -----<< license terms of TclKit (from kitgen's "README" file) >>--------------- -The Tclkit-specific sources are license free, they just have a copyright. Hold -the author(s) harmless and any lawful use is permitted. - -This does *not* apply to any of the sources of the other major Open Source -Software used in Tclkit, which each have very liberal BSD/MIT-like licenses: - - * Tcl/Tk, TclVFS, Thread, Vlerq, Zlib ------------------------------------------------------------------------------- - */ -/* Tcl/Tk stubs may work, but probably it is meaningless. */ -#if defined USE_TCL_STUBS || defined USE_TK_STUBS -# error Not support Tcl/Tk stubs with Ruby/Tk-Kit or Rubykit. -#endif - -#ifndef KIT_INCLUDES_ZLIB -#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86 -#define KIT_INCLUDES_ZLIB 1 -#else -#define KIT_INCLUDES_ZLIB 0 -#endif -#endif - -#ifdef _WIN32 -#define WIN32_LEAN_AND_MEAN -#include <windows.h> -#undef WIN32_LEAN_AND_MEAN -#endif - -#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86 -EXTERN Tcl_Obj* TclGetStartupScriptPath(); -EXTERN void TclSetStartupScriptPath _((Tcl_Obj*)); -#define Tcl_GetStartupScript(encPtr) TclGetStartupScriptPath() -#define Tcl_SetStartupScript(path,enc) TclSetStartupScriptPath(path) -#endif -#if !defined(TclSetPreInitScript) && !defined(TclSetPreInitScript_TCL_DECLARED) -EXTERN char* TclSetPreInitScript _((char *)); -#endif - -#ifndef KIT_INCLUDES_TK -# define KIT_INCLUDES_TK 1 -#endif -/* #define KIT_INCLUDES_ITCL 1 */ -/* #define KIT_INCLUDES_THREAD 1 */ - -Tcl_AppInitProc Vfs_Init, Rechan_Init; -#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85 -Tcl_AppInitProc Pwb_Init; -#endif - -#ifdef KIT_LITE -Tcl_AppInitProc Vlerq_Init, Vlerq_SafeInit; -#else -Tcl_AppInitProc Mk4tcl_Init; -#endif - -#if defined TCL_THREADS && defined KIT_INCLUDES_THREAD -Tcl_AppInitProc Thread_Init; -#endif - -#if KIT_INCLUDES_ZLIB -Tcl_AppInitProc Zlib_Init; -#endif - -#ifdef KIT_INCLUDES_ITCL -Tcl_AppInitProc Itcl_Init; -#endif - -#ifdef _WIN32 -Tcl_AppInitProc Dde_Init, Dde_SafeInit, Registry_Init; -#endif - -/*--------------------------------------------------------*/ - -#define RUBYTK_KITPATH_CONST_NAME "RUBYTK_KITPATH" - -static char *rubytk_kitpath = NULL; - -static char rubytkkit_preInitCmd[] = -"proc tclKitPreInit {} {\n" - "rename tclKitPreInit {}\n" - "load {} rubytk_kitpath\n" -#if KIT_INCLUDES_ZLIB - "catch {load {} zlib}\n" -#endif -#ifdef KIT_LITE - "load {} vlerq\n" - "namespace eval ::vlerq {}\n" - "if {[catch { vlerq open $::tcl::kitpath } ::vlerq::starkit_root]} {\n" - "set n -1\n" - "} else {\n" - "set files [vlerq get $::vlerq::starkit_root 0 dirs 0 files]\n" - "set n [lsearch [vlerq get $files * name] boot.tcl]\n" - "}\n" - "if {$n >= 0} {\n" - "array set a [vlerq get $files $n]\n" -#else - "load {} Mk4tcl\n" -#if defined KIT_VFS_WRITABLE && !defined CREATE_RUBYKIT - /* running command cannot open itself for writing */ - "mk::file open exe $::tcl::kitpath\n" -#else - "mk::file open exe $::tcl::kitpath -readonly\n" -#endif - "set n [mk::select exe.dirs!0.files name boot.tcl]\n" - "if {[llength $n] == 1} {\n" - "array set a [mk::get exe.dirs!0.files!$n]\n" -#endif - "if {![info exists a(contents)]} { error {no boot.tcl file} }\n" - "if {$a(size) != [string length $a(contents)]} {\n" - "set a(contents) [zlib decompress $a(contents)]\n" - "}\n" - "if {$a(contents) eq \"\"} { error {empty boot.tcl} }\n" - "uplevel #0 $a(contents)\n" -#if 0 - "} elseif {[lindex $::argv 0] eq \"-init-\"} {\n" - "uplevel #0 { source [lindex $::argv 1] }\n" - "exit\n" -#endif - "} else {\n" - /* When cannot find VFS data, try to use a real directory */ - "set vfsdir \"[file rootname $::tcl::kitpath].vfs\"\n" - "if {[file isdirectory $vfsdir]} {\n" - "set ::tcl_library [file join $vfsdir lib tcl$::tcl_version]\n" - "set ::tcl_libPath [list $::tcl_library [file join $vfsdir lib]]\n" - "catch {uplevel #0 [list source [file join $vfsdir config.tcl]]}\n" - "uplevel #0 [list source [file join $::tcl_library init.tcl]]\n" - "set ::auto_path $::tcl_libPath\n" - "} else {\n" - "error \"\n $::tcl::kitpath has no VFS data to start up\"\n" - "}\n" - "}\n" -"}\n" -"tclKitPreInit" -; - -#if 0 -/* Not use this script. - It's a memo to support an initScript for Tcl interpreters in the future. */ -static const char initScript[] = -"if {[file isfile [file join $::tcl::kitpath main.tcl]]} {\n" - "if {[info commands console] != {}} { console hide }\n" - "set tcl_interactive 0\n" - "incr argc\n" - "set argv [linsert $argv 0 $argv0]\n" - "set argv0 [file join $::tcl::kitpath main.tcl]\n" -"} else continue\n" -; -#endif - -/*--------------------------------------------------------*/ - -static char* -set_rubytk_kitpath(const char *kitpath) -{ - if (kitpath) { - int len = (int)strlen(kitpath); - if (rubytk_kitpath) { - ckfree(rubytk_kitpath); - } - - rubytk_kitpath = (char *)ckalloc(len + 1); - memcpy(rubytk_kitpath, kitpath, len); - rubytk_kitpath[len] = '\0'; - } - return rubytk_kitpath; -} - -/*--------------------------------------------------------*/ - -#ifdef WIN32 -#define DEV_NULL "NUL" -#else -#define DEV_NULL "/dev/null" -#endif - -static void -check_tclkit_std_channels(void) -{ - Tcl_Channel chan; - - /* - * We need to verify if we have the standard channels and create them if - * not. Otherwise internals channels may get used as standard channels - * (like for encodings) and panic. - */ - chan = Tcl_GetStdChannel(TCL_STDIN); - if (chan == NULL) { - chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "r", 0); - if (chan != NULL) { - Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); - } - Tcl_SetStdChannel(chan, TCL_STDIN); - } - chan = Tcl_GetStdChannel(TCL_STDOUT); - if (chan == NULL) { - chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0); - if (chan != NULL) { - Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); - } - Tcl_SetStdChannel(chan, TCL_STDOUT); - } - chan = Tcl_GetStdChannel(TCL_STDERR); - if (chan == NULL) { - chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0); - if (chan != NULL) { - Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); - } - Tcl_SetStdChannel(chan, TCL_STDERR); - } -} - -/*--------------------------------------------------------*/ - -static int -rubytk_kitpathObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -{ - const char* str; - if (objc == 2) { - set_rubytk_kitpath(Tcl_GetString(objv[1])); - } else if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?path?"); - } - str = rubytk_kitpath ? rubytk_kitpath : Tcl_GetNameOfExecutable(); - Tcl_SetObjResult(interp, Tcl_NewStringObj(str, -1)); - return TCL_OK; -} - -/* - * Public entry point for ::tcl::kitpath. - * Creates both link variable name and Tcl command ::tcl::kitpath. - */ -static int -rubytk_kitpath_init(Tcl_Interp *interp) -{ - Tcl_CreateObjCommand(interp, "::tcl::kitpath", rubytk_kitpathObjCmd, 0, 0); - if (Tcl_LinkVar(interp, "::tcl::kitpath", (char *) &rubytk_kitpath, - TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) { - Tcl_ResetResult(interp); - } - - Tcl_CreateObjCommand(interp, "::tcl::rubytk_kitpath", rubytk_kitpathObjCmd, 0, 0); - if (Tcl_LinkVar(interp, "::tcl::rubytk_kitpath", (char *) &rubytk_kitpath, - TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) { - Tcl_ResetResult(interp); - } - - if (rubytk_kitpath == NULL) { - /* - * XXX: We may want to avoid doing this to allow tcl::kitpath calls - * XXX: to obtain changes in nameofexe, if they occur. - */ - set_rubytk_kitpath(Tcl_GetNameOfExecutable()); - } - - return Tcl_PkgProvide(interp, "rubytk_kitpath", "1.0"); -} - -/*--------------------------------------------------------*/ - -static void -init_static_tcltk_packages(void) -{ - /* - * Ensure that std channels exist (creating them if necessary) - */ - check_tclkit_std_channels(); - -#ifdef KIT_INCLUDES_ITCL - Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL); -#endif -#ifdef KIT_LITE - Tcl_StaticPackage(0, "Vlerq", Vlerq_Init, Vlerq_SafeInit); -#else - Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL); -#endif -#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85 - Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL); -#endif - Tcl_StaticPackage(0, "rubytk_kitpath", rubytk_kitpath_init, NULL); - Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL); - Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL); -#if KIT_INCLUDES_ZLIB - Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL); -#endif -#if defined TCL_THREADS && defined KIT_INCLUDES_THREAD - Tcl_StaticPackage(0, "Thread", Thread_Init, Thread_SafeInit); -#endif -#ifdef _WIN32 -#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84 - Tcl_StaticPackage(0, "dde", Dde_Init, Dde_SafeInit); -#else - Tcl_StaticPackage(0, "dde", Dde_Init, NULL); -#endif - Tcl_StaticPackage(0, "registry", Registry_Init, NULL); -#endif -#ifdef KIT_INCLUDES_TK - Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit); -#endif -} - -/*--------------------------------------------------------*/ - -static int -call_tclkit_init_script(Tcl_Interp *interp) -{ -#if 0 - /* Currently, do nothing in this function. - It's a memo (quoted from kitInit.c of Tclkit) - to support an initScript for Tcl interpreters in the future. */ - if (Tcl_EvalEx(interp, initScript, -1, TCL_EVAL_GLOBAL) == TCL_OK) { - const char *encoding = NULL; - Tcl_Obj* path = Tcl_GetStartupScript(&encoding); - Tcl_SetStartupScript(Tcl_GetObjResult(interp), encoding); - if (path == NULL) { - Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]"); - } - } -#endif - - return 1; -} - -/*--------------------------------------------------------*/ - -#ifdef __WIN32__ -/* #include <tkWinInt.h> *//* conflict definition of struct timezone */ -/* #include <tkIntPlatDecls.h> */ -/* #include <windows.h> */ -EXTERN void TkWinSetHINSTANCE(HINSTANCE hInstance); -void rbtk_win32_SetHINSTANCE(const char *module_name) -{ - /* TCHAR szBuf[256]; */ - HINSTANCE hInst; - - /* hInst = GetModuleHandle(NULL); */ - /* hInst = GetModuleHandle("tcltklib.so"); */ - hInst = GetModuleHandle(module_name); - TkWinSetHINSTANCE(hInst); - - /* GetModuleFileName(hInst, szBuf, sizeof(szBuf) / sizeof(TCHAR)); */ - /* MessageBox(NULL, szBuf, TEXT("OK"), MB_OK); */ -} -#endif - -/*--------------------------------------------------------*/ - -static void -setup_rubytkkit(void) -{ - init_static_tcltk_packages(); - - { - ID const_id; - const_id = rb_intern(RUBYTK_KITPATH_CONST_NAME); - - if (rb_const_defined(rb_cObject, const_id)) { - volatile VALUE pathobj; - pathobj = rb_const_get(rb_cObject, const_id); - - if (rb_obj_is_kind_of(pathobj, rb_cString)) { -#ifdef HAVE_RUBY_ENCODING_H - pathobj = rb_str_export_to_enc(pathobj, rb_utf8_encoding()); -#endif - set_rubytk_kitpath(RSTRING_PTR(pathobj)); - } - } - } - -#ifdef CREATE_RUBYTK_KIT - if (rubytk_kitpath == NULL) { -#ifdef __WIN32__ - /* rbtk_win32_SetHINSTANCE("tcltklib.so"); */ - { -# ifdef HAVE_RUBY_ENC_FIND_BASENAME - const char *base = ruby_enc_find_basename(rb_sourcefile(), NULL, NULL, - rb_filesystem_encoding()); - rbtk_win32_SetHINSTANCE(base); -# else - VALUE basename; - basename = rb_funcall(rb_cFile, rb_intern("basename"), 1, - rb_str_new2(rb_sourcefile())); - rbtk_win32_SetHINSTANCE(RSTRING_PTR(basename)); - RB_GC_GUARD(basename); -# endif - } -#endif - set_rubytk_kitpath(rb_sourcefile()); - } -#endif - - if (rubytk_kitpath == NULL) { - set_rubytk_kitpath(Tcl_GetNameOfExecutable()); - } - - TclSetPreInitScript(rubytkkit_preInitCmd); -} - -/*--------------------------------------------------------*/ - -#endif /* defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT */ -/*####################################################################*/ - - -/**********************************************************************/ - -/* stub status */ -static void -tcl_stubs_check(void) -{ - if (!tcl_stubs_init_p()) { - int st = ruby_tcl_stubs_init(); - switch(st) { - case TCLTK_STUBS_OK: - break; - case NO_TCL_DLL: - rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll"); - case NO_FindExecutable: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable"); - case NO_CreateInterp: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()"); - case NO_DeleteInterp: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()"); - case FAIL_CreateInterp: - rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP to call Tcl_InitStubs()"); - case FAIL_Tcl_InitStubs: - rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()"); - default: - rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_stubs_init()", st); - } - } -} - - -static VALUE -tcltkip_init_tk(interp) - VALUE interp; -{ - struct tcltkip *ptr = get_ip(interp); - -#if TCL_MAJOR_VERSION >= 8 - int st; - - if (Tcl_IsSafe(ptr->ip)) { - DUMP1("Tk_SafeInit"); - st = ruby_tk_stubs_safeinit(ptr->ip); - switch(st) { - case TCLTK_STUBS_OK: - break; - case NO_Tk_Init: - return rb_exc_new2(rb_eLoadError, - "tcltklib: can't find Tk_SafeInit()"); - case FAIL_Tk_Init: - return create_ip_exc(interp, rb_eRuntimeError, - "tcltklib: fail to Tk_SafeInit(). %s", - Tcl_GetStringResult(ptr->ip)); - case FAIL_Tk_InitStubs: - return create_ip_exc(interp, rb_eRuntimeError, - "tcltklib: fail to Tk_InitStubs(). %s", - Tcl_GetStringResult(ptr->ip)); - default: - return create_ip_exc(interp, rb_eRuntimeError, - "tcltklib: unknown error(%d) on ruby_tk_stubs_safeinit", st); - } - } else { - DUMP1("Tk_Init"); - st = ruby_tk_stubs_init(ptr->ip); - switch(st) { - case TCLTK_STUBS_OK: - break; - case NO_Tk_Init: - return rb_exc_new2(rb_eLoadError, - "tcltklib: can't find Tk_Init()"); - case FAIL_Tk_Init: - return create_ip_exc(interp, rb_eRuntimeError, - "tcltklib: fail to Tk_Init(). %s", - Tcl_GetStringResult(ptr->ip)); - case FAIL_Tk_InitStubs: - return create_ip_exc(interp, rb_eRuntimeError, - "tcltklib: fail to Tk_InitStubs(). %s", - Tcl_GetStringResult(ptr->ip)); - default: - return create_ip_exc(interp, rb_eRuntimeError, - "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st); - } - } - -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tk_Init"); - if (ruby_tk_stubs_init(ptr->ip) != TCLTK_STUBS_OK) { - return rb_exc_new2(rb_eRuntimeError, ptr->ip->result); - } -#endif - -#ifdef RUBY_USE_NATIVE_THREAD - ptr->tk_thread_id = Tcl_GetCurrentThread(); -#endif - - return Qnil; -} - - -/* treat exception on Tcl side */ -static VALUE rbtk_pending_exception; -static int rbtk_eventloop_depth = 0; -static int rbtk_internal_eventloop_handler = 0; - - -static int -pending_exception_check0(void) -{ - volatile VALUE exc = rbtk_pending_exception; - - if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) { - DUMP1("find a pending exception"); - if (rbtk_eventloop_depth > 0 - || rbtk_internal_eventloop_handler > 0 - ) { - return 1; /* pending */ - } else { - rbtk_pending_exception = Qnil; - - if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) { - DUMP1("pending_exception_check0: call rb_jump_tag(retry)"); - rb_jump_tag(TAG_RETRY); - } else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) { - DUMP1("pending_exception_check0: call rb_jump_tag(redo)"); - rb_jump_tag(TAG_REDO); - } else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) { - DUMP1("pending_exception_check0: call rb_jump_tag(throw)"); - rb_jump_tag(TAG_THROW); - } - - rb_exc_raise(exc); - } - } else { - return 0; - } - - UNREACHABLE; -} - -static int -pending_exception_check1(thr_crit_bup, ptr) - int thr_crit_bup; - struct tcltkip *ptr; -{ - volatile VALUE exc = rbtk_pending_exception; - - if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) { - DUMP1("find a pending exception"); - - if (rbtk_eventloop_depth > 0 - || rbtk_internal_eventloop_handler > 0 - ) { - return 1; /* pending */ - } else { - rbtk_pending_exception = Qnil; - - if (ptr != (struct tcltkip *)NULL) { - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - } - - rb_thread_critical = thr_crit_bup; - - if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) { - DUMP1("pending_exception_check1: call rb_jump_tag(retry)"); - rb_jump_tag(TAG_RETRY); - } else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) { - DUMP1("pending_exception_check1: call rb_jump_tag(redo)"); - rb_jump_tag(TAG_REDO); - } else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) { - DUMP1("pending_exception_check1: call rb_jump_tag(throw)"); - rb_jump_tag(TAG_THROW); - } - rb_exc_raise(exc); - } - } else { - return 0; - } - - UNREACHABLE; -} - - -/* 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 *cmd_obj; - Tcl_Obj *state_obj; -#endif - DUMP1("original_exit is called"); - - 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; -#define USE_RUBY_ALLOC 0 -#if USE_RUBY_ALLOC - argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3); -#else /* not USE_RUBY_ALLOC */ - argv = RbTk_ALLOC_N(Tcl_Obj *, 3); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ -#endif -#endif - cmd_obj = Tcl_NewStringObj("exit", 4); - Tcl_IncrRefCount(cmd_obj); - - argv[0] = cmd_obj; - argv[1] = state_obj; - argv[2] = (Tcl_Obj *)NULL; - - ptr->return_value - = (*(info->objProc))(info->objClientData, ptr->ip, 2, argv); - - Tcl_DecrRefCount(cmd_obj); - -#if USE_RUBY_ALLOC - xfree(argv); -#else /* not USE_RUBY_ALLOC */ -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#else - /* free(argv); */ - ckfree((char*)argv); -#endif -#endif -#endif -#undef USE_RUBY_ALLOC - - } else { - /* string interface */ - CONST84 char **argv; -#define USE_RUBY_ALLOC 0 -#if USE_RUBY_ALLOC - argv = ALLOC_N(char *, 3); /* XXXXXXXXXX */ -#else /* not USE_RUBY_ALLOC */ - argv = RbTk_ALLOC_N(CONST84 char *, 3); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ -#endif -#endif - argv[0] = (char *)"exit"; - /* argv[1] = Tcl_GetString(state_obj); */ - argv[1] = Tcl_GetStringFromObj(state_obj, (int*)NULL); - argv[2] = (char *)NULL; - - ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, 2, argv); - -#if USE_RUBY_ALLOC - xfree(argv); -#else /* not USE_RUBY_ALLOC */ -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#else - /* free(argv); */ - ckfree((char*)argv); -#endif -#endif -#endif -#undef USE_RUBY_ALLOC - } - - Tcl_DecrRefCount(state_obj); - -#else /* TCL_MAJOR_VERSION < 8 */ - { - /* string interface */ - char **argv; -#define USE_RUBY_ALLOC 0 -#if USE_RUBY_ALLOC - argv = (char **)ALLOC_N(char *, 3); -#else /* not USE_RUBY_ALLOC */ - argv = RbTk_ALLOC_N(char *, 3); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ -#endif -#endif - argv[0] = "exit"; - argv[1] = RSTRING_PTR(rb_fix2str(INT2NUM(state), 10)); - argv[2] = (char *)NULL; - - ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, - 2, argv); - -#if USE_RUBY_ALLOC - xfree(argv); -#else /* not USE_RUBY_ALLOC */ -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#else - /* free(argv); */ - ckfree(argv); -#endif -#endif -#endif -#undef USE_RUBY_ALLOC - } -#endif - DUMP1("complete original_exit"); - - 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("call _timer_for_tcl"); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - Tcl_DeleteTimerHandler(timer_token); - - run_timer_flag = 1; - - if (timer_tick > 0) { - timer_token = Tcl_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; */ -} - -#ifdef RUBY_USE_NATIVE_THREAD -#if USE_TOGGLE_WINDOW_MODE_FOR_IDLE -static int -toggle_eventloop_window_mode_for_idle(void) -{ - if (window_event_mode & TCL_IDLE_EVENTS) { - /* idle -> event */ - window_event_mode |= TCL_WINDOW_EVENTS; - window_event_mode &= ~TCL_IDLE_EVENTS; - return 1; - } else { - /* event -> idle */ - window_event_mode |= TCL_IDLE_EVENTS; - window_event_mode &= ~TCL_WINDOW_EVENTS; - return 0; - } -} -#endif -#endif - -static VALUE -set_eventloop_window_mode(self, mode) - VALUE self; - VALUE mode; -{ - - if (RTEST(mode)) { - window_event_mode = ~0; - } else { - window_event_mode = ~TCL_WINDOW_EVENTS; - } - - return mode; -} - -static VALUE -get_eventloop_window_mode(self) - VALUE self; -{ - if ( ~window_event_mode ) { - return Qfalse; - } else { - return Qtrue; - } -} - -static VALUE -set_eventloop_tick(self, tick) - VALUE self; - VALUE tick; -{ - int ttick = NUM2INT(tick); - int thr_crit_bup; - - - 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 */ - Tcl_DeleteTimerHandler(timer_token); - - timer_tick = req_timer_tick = ttick; - if (timer_tick > 0) { - /* start timer callback */ - timer_token = Tcl_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 (deleted_ip(ptr)) { - 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); - - - 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 (deleted_ip(ptr)) { - 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); - - - 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 (deleted_ip(ptr)) { - 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_AREF(divmod, 0)); - tcl_time.usec = NUM2LONG(RARRAY_AREF(divmod, 1)); - break; - - case T_FLOAT: - /* time is second value */ - divmod = rb_funcall(time, rb_intern("divmod"), 1, INT2FIX(1)); - tcl_time.sec = NUM2LONG(RARRAY_AREF(divmod, 0)); - tcl_time.usec = (long)(NUM2DBL(RARRAY_AREF(divmod, 1)) * 1000000); - break; - - default: - rb_raise(rb_eArgError, "invalid value for time: '%+"PRIsVALUE"'", time); - } - - Tcl_SetMaxBlockTime(&tcl_time); - - return Qnil; -} - -static VALUE -lib_evloop_thread_p(self) - VALUE self; -{ - if (NIL_P(eventloop_thread)) { - return Qnil; /* no eventloop */ - } else if (rb_thread_current() == eventloop_thread) { - return Qtrue; /* is eventloop */ - } else { - return Qfalse; /* not eventloop */ - } -} - -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; -{ - 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); - - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - 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_core(self, argc, argv) - VALUE self; - int argc; /* dummy */ - VALUE *argv; /* dummy */ -{ - if (tk_stubs_init_p()) { - return INT2FIX(Tk_GetNumMainWindows()); - } else { - return INT2FIX(0); - } -} - -static VALUE -lib_num_of_mainwindows(self) - VALUE self; -{ -#ifdef RUBY_USE_NATIVE_THREAD /* Ruby 1.9+ !!! */ - return tk_funcall(lib_num_of_mainwindows_core, 0, (VALUE*)NULL, self); -#else - return lib_num_of_mainwindows_core(self, 0, (VALUE*)NULL); -#endif -} - -void -rbtk_EventSetupProc(ClientData clientData, int flag) -{ - Tcl_Time tcl_time; - tcl_time.sec = 0; - tcl_time.usec = 1000L * (long)no_event_tick; - Tcl_SetMaxBlockTime(&tcl_time); -} - -void -rbtk_EventCheckProc(ClientData clientData, int flag) -{ - rb_thread_schedule(); -} - - -#ifdef RUBY_USE_NATIVE_THREAD /* Ruby 1.9+ !!! */ -static VALUE -#ifdef HAVE_PROTOTYPES -call_DoOneEvent_core(VALUE flag_val) -#else -call_DoOneEvent_core(flag_val) - VALUE flag_val; -#endif -{ - int flag; - - flag = FIX2INT(flag_val); - if (Tcl_DoOneEvent(flag)) { - return Qtrue; - } else { - return Qfalse; - } -} - -static VALUE -#ifdef HAVE_PROTOTYPES -call_DoOneEvent(VALUE flag_val) -#else -call_DoOneEvent(flag_val) - VALUE flag_val; -#endif -{ - return tk_funcall(call_DoOneEvent_core, 0, (VALUE*)NULL, flag_val); -} - -#else /* Ruby 1.8- */ -static VALUE -#ifdef HAVE_PROTOTYPES -call_DoOneEvent(VALUE flag_val) -#else -call_DoOneEvent(flag_val) - VALUE flag_val; -#endif -{ - int flag; - - flag = FIX2INT(flag_val); - if (Tcl_DoOneEvent(flag)) { - return Qtrue; - } else { - return Qfalse; - } -} -#endif - - -#if 0 -static VALUE -#ifdef HAVE_PROTOTYPES -eventloop_sleep(VALUE dummy) -#else -eventloop_sleep(dummy) - VALUE dummy; -#endif -{ - struct timeval t; - - if (no_event_wait <= 0) { - return Qnil; - } - - t.tv_sec = 0; - t.tv_usec = (int)(no_event_wait*1000.0); - -#ifdef HAVE_NATIVETHREAD -#ifndef RUBY_USE_NATIVE_THREAD - if (!ruby_native_thread_p()) { - rb_bug("cross-thread violation on eventloop_sleep()"); - } -#endif -#endif - - DUMP2("eventloop_sleep: rb_thread_wait_for() at thread : %"PRIxVALUE, rb_thread_current()); - rb_thread_wait_for(t); - DUMP2("eventloop_sleep: finish at thread : %"PRIxVALUE, rb_thread_current()); - -#ifdef HAVE_NATIVETHREAD -#ifndef RUBY_USE_NATIVE_THREAD - if (!ruby_native_thread_p()) { - rb_bug("cross-thread violation on eventloop_sleep()"); - } -#endif -#endif - - return Qnil; -} -#endif - -#define USE_EVLOOP_THREAD_ALONE_CHECK_FLAG 0 - -#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG -static int -get_thread_alone_check_flag(void) -{ -#ifdef RUBY_USE_NATIVE_THREAD - return 0; -#else - set_tcltk_version(); - - if (tcltk_version.major < 8) { - /* Tcl/Tk 7.x */ - return 1; - } else if (tcltk_version.major == 8) { - if (tcltk_version.minor < 5) { - /* Tcl/Tk 8.0 - 8.4 */ - return 1; - } else if (tcltk_version.minor == 5) { - if (tcltk_version.type < TCL_FINAL_RELEASE) { - /* Tcl/Tk 8.5a? - 8.5b? */ - return 1; - } else { - /* Tcl/Tk 8.5.x */ - return 0; - } - } else { - /* Tcl/Tk 8.6 - 8.9 ?? */ - return 0; - } - } else { - /* Tcl/Tk 9+ ?? */ - return 0; - } -#endif -} -#endif - -#define TRAP_CHECK() do { \ - if (trap_check(check_var) == 0) return 0; \ -} while (0) - -static int -trap_check(int *check_var) -{ - DUMP1("trap check"); - -#ifdef RUBY_VM - if (rb_thread_check_trap_pending()) { - if (check_var != (int*)NULL) { - /* wait command */ - return 0; - } - else { - rb_thread_check_ints(); - } - } -#else - if (rb_trap_pending) { - run_timer_flag = 0; - if (rb_prohibit_interrupt || check_var != (int*)NULL) { - /* pending or on wait command */ - return 0; - } else { - rb_trap_exec(); - } - } -#endif - - return 1; -} - -static int -check_eventloop_interp(void) -{ - DUMP1("check eventloop_interp"); - if (eventloop_interp != (Tcl_Interp*)NULL - && Tcl_InterpDeleted(eventloop_interp)) { - DUMP2("eventloop_interp(%p) was deleted", eventloop_interp); - return 1; - } - - return 0; -} - -static int -lib_eventloop_core(check_root, update_flag, check_var, interp) - int check_root; - int update_flag; - int *check_var; - Tcl_Interp *interp; -{ - volatile VALUE current = eventloop_thread; - int found_event = 1; - int event_flag; -#if 0 - struct timeval t; -#endif - int thr_crit_bup; - int status; - int depth = rbtk_eventloop_depth; -#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG - int thread_alone_check_flag = 1; -#else - enum {thread_alone_check_flag = 1}; -#endif - - if (update_flag) DUMP1("update loop start!!"); - -#if 0 - t.tv_sec = 0; - t.tv_usec = 1000 * no_event_wait; -#endif - - Tcl_DeleteTimerHandler(timer_token); - run_timer_flag = 0; - if (timer_tick > 0) { - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl, - (ClientData)0); - rb_thread_critical = thr_crit_bup; - } else { - timer_token = (Tcl_TimerToken)NULL; - } - -#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG - /* version check */ - thread_alone_check_flag = get_thread_alone_check_flag(); -#endif - - for(;;) { - if (check_eventloop_interp()) return 0; - - if (thread_alone_check_flag && rb_thread_alone()) { - DUMP1("no other thread"); - event_loop_wait_event = 0; - - if (update_flag) { - event_flag = update_flag; - /* event_flag = update_flag | TCL_DONT_WAIT; */ /* for safety */ - } else { - event_flag = TCL_ALL_EVENTS; - /* event_flag = TCL_ALL_EVENTS | TCL_DONT_WAIT; */ - } - - if (timer_tick == 0 && update_flag == 0) { - timer_tick = NO_THREAD_INTERRUPT_TIME; - timer_token = Tcl_CreateTimerHandler(timer_tick, - _timer_for_tcl, - (ClientData)0); - } - - if (check_var != (int *)NULL) { - if (*check_var || !found_event) { - return found_event; - } - if (interp != (Tcl_Interp*)NULL - && Tcl_InterpDeleted(interp)) { - /* IP for check_var is deleted */ - return 0; - } - } - - /* found_event = Tcl_DoOneEvent(event_flag); */ - found_event = RTEST(rb_protect(call_DoOneEvent, - INT2FIX(event_flag), &status)); - if (status) { - switch (status) { - case TAG_RAISE: - if (NIL_P(rb_errinfo())) { - rbtk_pending_exception - = rb_exc_new2(rb_eException, "unknown exception"); - } else { - rbtk_pending_exception = rb_errinfo(); - - if (!NIL_P(rbtk_pending_exception)) { - if (rbtk_eventloop_depth == 0) { - VALUE exc = rbtk_pending_exception; - rbtk_pending_exception = Qnil; - rb_exc_raise(exc); - } else { - return 0; - } - } - } - break; - - case TAG_FATAL: - if (NIL_P(rb_errinfo())) { - rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL")); - } else { - rb_exc_raise(rb_errinfo()); - } - } - } - - if (depth != rbtk_eventloop_depth) { - DUMP2("DoOneEvent(1) abnormal exit!! %d", - rbtk_eventloop_depth); - } - - if (check_var != (int*)NULL && !NIL_P(rbtk_pending_exception)) { - DUMP1("exception on wait"); - return 0; - } - - if (pending_exception_check0()) { - /* pending -> upper level */ - return 0; - } - - if (update_flag != 0) { - if (found_event) { - DUMP1("next update loop"); - continue; - } else { - DUMP1("update complete"); - return 0; - } - } - - TRAP_CHECK(); - if (check_eventloop_interp()) return 0; - - DUMP1("check Root Widget"); - if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) { - run_timer_flag = 0; - TRAP_CHECK(); - 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; /* for safety */ - /* event_flag = update_flag | TCL_DONT_WAIT; */ /* for safety */ - } else { - event_flag = TCL_ALL_EVENTS; - /* 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 (interp != (Tcl_Interp*)NULL - && Tcl_InterpDeleted(interp)) { - /* IP for check_var is deleted */ - return 0; - } - } - - if (NIL_P(eventloop_thread) || current == eventloop_thread) { - int st; - int status; - -#ifdef RUBY_USE_NATIVE_THREAD - if (update_flag) { - st = RTEST(rb_protect(call_DoOneEvent, - INT2FIX(event_flag), &status)); - } else { - st = RTEST(rb_protect(call_DoOneEvent, - INT2FIX(event_flag & window_event_mode), - &status)); -#if USE_TOGGLE_WINDOW_MODE_FOR_IDLE - if (!st) { - if (toggle_eventloop_window_mode_for_idle()) { - /* idle-mode -> event-mode*/ - tick_counter = event_loop_max; - } else { - /* event-mode -> idle-mode */ - tick_counter = 0; - } - } -#endif - } -#else - /* st = Tcl_DoOneEvent(event_flag); */ - st = RTEST(rb_protect(call_DoOneEvent, - INT2FIX(event_flag), &status)); -#endif - -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE - if (have_rb_thread_waiting_for_value) { - have_rb_thread_waiting_for_value = 0; - rb_thread_schedule(); - } -#endif - - if (status) { - switch (status) { - case TAG_RAISE: - if (NIL_P(rb_errinfo())) { - rbtk_pending_exception - = rb_exc_new2(rb_eException, - "unknown exception"); - } else { - rbtk_pending_exception = rb_errinfo(); - - if (!NIL_P(rbtk_pending_exception)) { - if (rbtk_eventloop_depth == 0) { - VALUE exc = rbtk_pending_exception; - rbtk_pending_exception = Qnil; - rb_exc_raise(exc); - } else { - return 0; - } - } - } - break; - - case TAG_FATAL: - if (NIL_P(rb_errinfo())) { - rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL")); - } else { - rb_exc_raise(rb_errinfo()); - } - } - } - - if (depth != rbtk_eventloop_depth) { - DUMP2("DoOneEvent(2) abnormal exit!! %d", - rbtk_eventloop_depth); - return 0; - } - - TRAP_CHECK(); - - if (check_var != (int*)NULL - && !NIL_P(rbtk_pending_exception)) { - DUMP1("exception on wait"); - return 0; - } - - if (pending_exception_check0()) { - /* pending -> upper level */ - return 0; - } - - if (st) { - tick_counter++; - } else { - if (update_flag != 0) { - DUMP1("update complete"); - return 0; - } - - tick_counter += no_event_tick; - -#if 0 - /* rb_thread_wait_for(t); */ - rb_protect(eventloop_sleep, Qnil, &status); - - if (status) { - switch (status) { - case TAG_RAISE: - if (NIL_P(rb_errinfo())) { - rbtk_pending_exception - = rb_exc_new2(rb_eException, - "unknown exception"); - } else { - rbtk_pending_exception = rb_errinfo(); - - if (!NIL_P(rbtk_pending_exception)) { - if (rbtk_eventloop_depth == 0) { - VALUE exc = rbtk_pending_exception; - rbtk_pending_exception = Qnil; - rb_exc_raise(exc); - } else { - return 0; - } - } - } - break; - - case TAG_FATAL: - if (NIL_P(rb_errinfo())) { - rb_exc_raise(rb_exc_new2(rb_eFatal, - "FATAL")); - } else { - rb_exc_raise(rb_errinfo()); - } - } - } -#endif - } - - } else { - DUMP2("sleep eventloop %"PRIxVALUE, current); - DUMP2("eventloop thread is %"PRIxVALUE, eventloop_thread); - /* rb_thread_stop(); */ - rb_thread_sleep_forever(); - } - - if (!NIL_P(watchdog_thread) && eventloop_thread != current) { - return 1; - } - - TRAP_CHECK(); - if (check_eventloop_interp()) return 0; - - DUMP1("check Root Widget"); - if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) { - run_timer_flag = 0; - TRAP_CHECK(); - return 1; - } - - 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("thread scheduling"); - rb_thread_schedule(); - } - - DUMP1("check interrupts"); -#if defined(RUBY_USE_NATIVE_THREAD) || defined(RUBY_VM) - if (update_flag == 0) rb_thread_check_ints(); -#else - if (update_flag == 0) CHECK_INTS; -#endif - - } - return 1; -} - - -struct evloop_params { - int check_root; - int update_flag; - int *check_var; - Tcl_Interp *interp; - int thr_crit_bup; -}; - -VALUE -lib_eventloop_main_core(args) - VALUE args; -{ - struct evloop_params *params = (struct evloop_params *)args; - - check_rootwidget_flag = params->check_root; - - Tcl_CreateEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc, (ClientData)args); - - if (lib_eventloop_core(params->check_root, - params->update_flag, - params->check_var, - params->interp)) { - return Qtrue; - } else { - return Qfalse; - } -} - -VALUE -lib_eventloop_main(args) - VALUE args; -{ - return lib_eventloop_main_core(args); - -#if 0 - volatile VALUE ret; - int status = 0; - - ret = rb_protect(lib_eventloop_main_core, args, &status); - - switch (status) { - case TAG_RAISE: - if (NIL_P(rb_errinfo())) { - rbtk_pending_exception - = rb_exc_new2(rb_eException, "unknown exception"); - } else { - rbtk_pending_exception = rb_errinfo(); - } - return Qnil; - - case TAG_FATAL: - if (NIL_P(rb_errinfo())) { - rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL"); - } else { - rbtk_pending_exception = rb_errinfo(); - } - return Qnil; - } - - return ret; -#endif -} - -VALUE -lib_eventloop_ensure(args) - VALUE args; -{ - struct evloop_params *ptr = (struct evloop_params *)args; - volatile VALUE current_evloop = rb_thread_current(); - - Tcl_DeleteEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc, (ClientData)args); - - DUMP2("eventloop_ensure: current-thread : %"PRIxVALUE, current_evloop); - DUMP2("eventloop_ensure: eventloop-thread : %"PRIxVALUE, eventloop_thread); - if (eventloop_thread != current_evloop) { - DUMP2("finish eventloop %"PRIxVALUE" (NOT current eventloop)", current_evloop); - - rb_thread_critical = ptr->thr_crit_bup; - - xfree(ptr); - /* ckfree((char*)ptr); */ - - return Qnil; - } - - while((eventloop_thread = rb_ary_pop(eventloop_stack))) { - DUMP2("eventloop-ensure: new eventloop-thread -> %"PRIxVALUE, - eventloop_thread); - - if (eventloop_thread == current_evloop) { - rbtk_eventloop_depth--; - DUMP2("eventloop %"PRIxVALUE" : back from recursive call", current_evloop); - break; - } - - if (NIL_P(eventloop_thread)) { - Tcl_DeleteTimerHandler(timer_token); - timer_token = (Tcl_TimerToken)NULL; - - break; - } - - if (RTEST(rb_thread_alive_p(eventloop_thread))) { - DUMP2("eventloop-enshure: wake up parent %"PRIxVALUE, eventloop_thread); - rb_thread_wakeup(eventloop_thread); - - break; - } - } - -#ifdef RUBY_USE_NATIVE_THREAD - if (NIL_P(eventloop_thread)) { - tk_eventloop_thread_id = (Tcl_ThreadId) 0; - } -#endif - - rb_thread_critical = ptr->thr_crit_bup; - - xfree(ptr); - /* ckfree((char*)ptr);*/ - - DUMP2("finish current eventloop %"PRIxVALUE, current_evloop); - return Qnil; -} - -static VALUE -lib_eventloop_launcher(check_root, update_flag, check_var, interp) - int check_root; - int update_flag; - int *check_var; - Tcl_Interp *interp; -{ - volatile VALUE parent_evloop = eventloop_thread; - struct evloop_params *args = ALLOC(struct evloop_params); - /* struct evloop_params *args = RbTk_ALLOC_N(struct evloop_params, 1); */ - - tcl_stubs_check(); - - eventloop_thread = rb_thread_current(); -#ifdef RUBY_USE_NATIVE_THREAD - tk_eventloop_thread_id = Tcl_GetCurrentThread(); -#endif - - if (parent_evloop == eventloop_thread) { - DUMP2("eventloop: recursive call on %"PRIxVALUE, parent_evloop); - rbtk_eventloop_depth++; - } - - if (!NIL_P(parent_evloop) && parent_evloop != eventloop_thread) { - DUMP2("wait for stop of parent_evloop %"PRIxVALUE, parent_evloop); - while(!RTEST(rb_funcall(parent_evloop, ID_stop_p, 0))) { - DUMP2("parent_evloop %"PRIxVALUE" doesn't stop", parent_evloop); - rb_thread_run(parent_evloop); - } - DUMP1("succeed to stop parent"); - } - - rb_ary_push(eventloop_stack, parent_evloop); - - DUMP3("tcltklib: eventloop-thread : %"PRIxVALUE" -> %"PRIxVALUE"\n", - parent_evloop, eventloop_thread); - - args->check_root = check_root; - args->update_flag = update_flag; - args->check_var = check_var; - args->interp = interp; - args->thr_crit_bup = rb_thread_critical; - - rb_thread_critical = Qfalse; - -#if 0 - return rb_ensure(lib_eventloop_main, (VALUE)args, - lib_eventloop_ensure, (VALUE)args); -#endif - return rb_ensure(lib_eventloop_main_core, (VALUE)args, - lib_eventloop_ensure, (VALUE)args); -} - -/* 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(RTEST(check_rootwidget), 0, - (int*)NULL, (Tcl_Interp*)NULL); -} - -static VALUE -ip_mainloop(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - volatile VALUE ret; - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return Qnil; - } - - if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { - /* slave IP */ - return Qnil; - } - - eventloop_interp = ptr->ip; - ret = lib_mainloop(argc, argv, self); - eventloop_interp = (Tcl_Interp*)NULL; - return ret; -} - - -static VALUE -watchdog_evloop_launcher(check_rootwidget) - VALUE check_rootwidget; -{ - return lib_eventloop_launcher(RTEST(check_rootwidget), 0, - (int*)NULL, (Tcl_Interp*)NULL); -} - -#define EVLOOP_WAKEUP_CHANCE 3 - -static 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 = 0; - t0.tv_usec = (long)((NO_THREAD_INTERRUPT_TIME)*1000.0); - t1.tv_sec = 0; - t1.tv_usec = (long)((WATCHDOG_INTERVAL)*1000.0); - - /* check other watchdog thread */ - if (!NIL_P(watchdog_thread)) { - 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 (NIL_P(eventloop_thread) - || (loop_counter == prev_val && chance >= EVLOOP_WAKEUP_CHANCE)) { - /* start new eventloop thread */ - DUMP2("eventloop thread %"PRIxVALUE" is sleeping or dead", - eventloop_thread); - evloop = rb_thread_create(watchdog_evloop_launcher, - (void*)&check_rootwidget); - DUMP2("create new eventloop thread %"PRIxVALUE, evloop); - loop_counter = -1; - chance = 0; - rb_thread_run(evloop); - } else { - prev_val = loop_counter; - if (RTEST(rb_funcall(eventloop_thread, ID_stop_p, 0))) { - ++chance; - } else { - chance = 0; - } - if (event_loop_wait_event) { - rb_thread_wait_for(t0); - } else { - rb_thread_wait_for(t1); - } - /* rb_thread_schedule(); */ - } - } while(!check || !tk_stubs_init_p() || Tk_GetNumMainWindows() != 0); - - return Qnil; -} - -VALUE -lib_watchdog_ensure(arg) - VALUE arg; -{ - eventloop_thread = Qnil; /* stop eventloops */ -#ifdef RUBY_USE_NATIVE_THREAD - tk_eventloop_thread_id = (Tcl_ThreadId) 0; -#endif - return Qnil; -} - -static VALUE -lib_mainloop_watchdog(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - VALUE check_rootwidget; - -#ifdef RUBY_VM - rb_raise(rb_eNotImpError, - "eventloop_watchdog is not implemented on Ruby VM."); -#endif - - 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 (deleted_ip(ptr)) { - return Qnil; - } - - if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { - /* slave IP */ - return Qnil; - } - return lib_mainloop_watchdog(argc, argv, self); -} - - -/* thread-safe(?) interaction between Ruby and Tk */ -struct thread_call_proc_arg { - VALUE proc; - int *done; -}; - -void -_thread_call_proc_arg_mark(struct thread_call_proc_arg *q) -{ - rb_gc_mark(q->proc); -} - -static VALUE -_thread_call_proc_core(arg) - VALUE arg; -{ - struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg; - return rb_funcall(q->proc, ID_call, 0); -} - -static VALUE -_thread_call_proc_ensure(arg) - VALUE arg; -{ - struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg; - *(q->done) = 1; - return Qnil; -} - -static VALUE -_thread_call_proc(arg) - VALUE arg; -{ - struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg; - - return rb_ensure(_thread_call_proc_core, (VALUE)q, - _thread_call_proc_ensure, (VALUE)q); -} - -static VALUE -#ifdef HAVE_PROTOTYPES -_thread_call_proc_value(VALUE th) -#else -_thread_call_proc_value(th) - VALUE th; -#endif -{ - return rb_funcall(th, ID_value, 0); -} - -static VALUE -lib_thread_callback(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - struct thread_call_proc_arg *q; - VALUE proc, th, ret; - int status; - - if (rb_scan_args(argc, argv, "01", &proc) == 0) { - proc = rb_block_proc(); - } - - q = (struct thread_call_proc_arg *)ALLOC(struct thread_call_proc_arg); - /* q = RbTk_ALLOC_N(struct thread_call_proc_arg, 1); */ - q->proc = proc; - q->done = (int*)ALLOC(int); - /* q->done = RbTk_ALLOC_N(int, 1); */ - *(q->done) = 0; - - /* create call-proc thread */ - th = rb_thread_create(_thread_call_proc, (void*)q); - - rb_thread_schedule(); - - /* start sub-eventloop */ - lib_eventloop_launcher(/* not check root-widget */0, 0, - q->done, (Tcl_Interp*)NULL); - - if (RTEST(rb_thread_alive_p(th))) { - rb_funcall(th, ID_kill, 0); - ret = Qnil; - } else { - ret = rb_protect(_thread_call_proc_value, th, &status); - } - - xfree(q->done); - xfree(q); - /* ckfree((char*)q->done); */ - /* ckfree((char*)q); */ - - if (NIL_P(rbtk_pending_exception)) { - /* return rb_errinfo(); */ - if (status) { - rb_exc_raise(rb_errinfo()); - } - } else { - VALUE exc = rbtk_pending_exception; - rbtk_pending_exception = Qnil; - /* return exc; */ - rb_exc_raise(exc); - } - - return ret; -} - - -/* do_one_event */ -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 (!NIL_P(eventloop_thread)) { - rb_raise(rb_eRuntimeError, "eventloop is already running"); - } - - tcl_stubs_check(); - - if (rb_scan_args(argc, argv, "01", &vflags) == 0) { - flags = TCL_ALL_EVENTS | TCL_DONT_WAIT; - } else { - Check_Type(vflags, T_FIXNUM); - flags = (int)FIX2LONG(vflags); - } - - if (is_ip) { - /* check IP */ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - 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 (pending_exception_check0()) { - return Qfalse; - } - - 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_funcallv(exc, ID_message, 0, 0); - StringValue(msg); - -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) - enc = rb_attr_get(exc, ID_at_enc); - if (NIL_P(enc)) { - enc = rb_attr_get(msg, ID_at_enc); - } - if (NIL_P(enc)) { - encoding = (Tcl_Encoding)NULL; - } else if (RB_TYPE_P(enc, T_STRING)) { - /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ - encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc)); - } else { - enc = rb_funcallv(enc, ID_to_s, 0, 0); - /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ - encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc)); - } - - /* to avoid a garbled error message dialog */ - /* buf = ALLOC_N(char, (RSTRING(msg)->len)+1);*/ - /* memcpy(buf, RSTRING(msg)->ptr, RSTRING(msg)->len);*/ - /* buf[RSTRING(msg)->len] = 0; */ - buf = ALLOC_N(char, RSTRING_LENINT(msg)+1); - /* buf = ckalloc(RSTRING_LENINT(msg)+1); */ - memcpy(buf, RSTRING_PTR(msg), RSTRING_LEN(msg)); - buf[RSTRING_LEN(msg)] = 0; - - Tcl_DStringInit(&dstr); - Tcl_DStringFree(&dstr); - Tcl_ExternalToUtfDString(encoding, buf, RSTRING_LENINT(msg), &dstr); - - Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL); - DUMP2("error message:%s", Tcl_DStringValue(&dstr)); - Tcl_DStringFree(&dstr); - xfree(buf); - /* ckfree(buf); */ - -#else /* TCL_VERSION <= 8.0 */ - Tcl_AppendResult(interp, RSTRING_PTR(msg), (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_funcallv(obj, ID_to_s, 0, 0); - } - } - - return rb_funcallv(obj, ID_inspect, 0, 0); -} - -static int -#ifdef HAVE_PROTOTYPES -tcl_protect_core(Tcl_Interp *interp, VALUE (*proc)(VALUE), VALUE data) -#else -tcl_protect_core(interp, proc, data) /* should not raise exception */ - Tcl_Interp *interp; - VALUE (*proc)(); - VALUE data; -#endif -{ - volatile VALUE ret, exc = Qnil; - int status = 0; - int thr_crit_bup = rb_thread_critical; - - Tcl_ResetResult(interp); - - rb_thread_critical = Qfalse; - ret = rb_protect(proc, data, &status); - rb_thread_critical = Qtrue; - if (status) { - char *buf; - VALUE old_gc; - volatile VALUE type, str; - - old_gc = rb_gc_disable(); - - switch(status) { - case TAG_RETURN: - type = eTkCallbackReturn; - goto error; - case TAG_BREAK: - type = eTkCallbackBreak; - goto error; - case TAG_NEXT: - type = eTkCallbackContinue; - goto error; - error: - str = rb_str_new2("LocalJumpError: "); - rb_str_append(str, rb_obj_as_string(rb_errinfo())); - exc = rb_exc_new3(type, str); - break; - - case TAG_RETRY: - if (NIL_P(rb_errinfo())) { - DUMP1("rb_protect: retry"); - exc = rb_exc_new2(eTkCallbackRetry, "retry jump error"); - } else { - exc = rb_errinfo(); - } - break; - - case TAG_REDO: - if (NIL_P(rb_errinfo())) { - DUMP1("rb_protect: redo"); - exc = rb_exc_new2(eTkCallbackRedo, "redo jump error"); - } else { - exc = rb_errinfo(); - } - break; - - case TAG_RAISE: - if (NIL_P(rb_errinfo())) { - exc = rb_exc_new2(rb_eException, "unknown exception"); - } else { - exc = rb_errinfo(); - } - break; - - case TAG_FATAL: - if (NIL_P(rb_errinfo())) { - exc = rb_exc_new2(rb_eFatal, "FATAL"); - } else { - exc = rb_errinfo(); - } - break; - - case TAG_THROW: - if (NIL_P(rb_errinfo())) { - DUMP1("rb_protect: throw"); - exc = rb_exc_new2(eTkCallbackThrow, "throw jump error"); - } else { - exc = rb_errinfo(); - } - break; - - default: - buf = ALLOC_N(char, 256); - /* buf = ckalloc(sizeof(char) * 256); */ - sprintf(buf, "unknown loncaljmp status %d", status); - exc = rb_exc_new2(rb_eException, buf); - xfree(buf); - /* ckfree(buf); */ - break; - } - - if (old_gc == Qfalse) rb_gc_enable(); - - ret = Qnil; - } - - rb_thread_critical = thr_crit_bup; - - Tcl_ResetResult(interp); - - /* status check */ - if (!NIL_P(exc)) { - volatile VALUE eclass = rb_obj_class(exc); - volatile VALUE backtrace; - - DUMP1("(failed)"); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - DUMP1("set backtrace"); - if (!NIL_P(backtrace = rb_funcallv(exc, ID_backtrace, 0, 0))) { - backtrace = rb_ary_join(backtrace, rb_str_new2("\n")); - Tcl_AddErrorInfo(interp, StringValueCStr(backtrace)); - } - - rb_thread_critical = thr_crit_bup; - - ip_set_exc_message(interp, exc); - - if (eclass == eTkCallbackReturn) - return TCL_RETURN; - - if (eclass == eTkCallbackBreak) - return TCL_BREAK; - - if (eclass == eTkCallbackContinue) - return TCL_CONTINUE; - - if (eclass == rb_eSystemExit || eclass == rb_eInterrupt) { - rbtk_pending_exception = exc; - return TCL_RETURN; - } - - if (rb_obj_is_kind_of(exc, eTkLocalJumpError)) { - rbtk_pending_exception = exc; - return TCL_ERROR; - } - - if (rb_obj_is_kind_of(exc, eLocalJumpError)) { - VALUE reason = rb_ivar_get(exc, ID_at_reason); - - if (RB_TYPE_P(reason, T_SYMBOL)) { - if (SYM2ID(reason) == ID_return) - return TCL_RETURN; - - if (SYM2ID(reason) == ID_break) - return TCL_BREAK; - - if (SYM2ID(reason) == ID_next) - return TCL_CONTINUE; - } - } - - return TCL_ERROR; - } - - /* result must be string or nil */ - if (!NIL_P(ret)) { - /* copy result to the tcl interpreter */ - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - ret = TkStringValue(ret); - DUMP1("Tcl_AppendResult"); - Tcl_AppendResult(interp, RSTRING_PTR(ret), (char *)NULL); - - rb_thread_critical = thr_crit_bup; - } - - DUMP2("(result) %s", NIL_P(ret) ? "nil" : RSTRING_PTR(ret)); - - return TCL_OK; -} - -static int -tcl_protect(interp, proc, data) - Tcl_Interp *interp; - VALUE (*proc)(); - VALUE data; -{ - int code; - -#ifdef HAVE_NATIVETHREAD -#ifndef RUBY_USE_NATIVE_THREAD - if (!ruby_native_thread_p()) { - rb_bug("cross-thread violation on tcl_protect()"); - } -#endif -#endif - -#ifdef RUBY_VM - code = tcl_protect_core(interp, proc, data); -#else - do { - int old_trapflag = rb_trap_immediate; - rb_trap_immediate = 0; - code = tcl_protect_core(interp, proc, data); - rb_trap_immediate = old_trapflag; - } while (0); -#endif - - return code; -} - -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 -{ - char *arg; - int thr_crit_bup; - int code; - - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } - - /* ruby command has 1 arg. */ - if (argc != 2) { -#if 0 - rb_raise(rb_eArgError, - "wrong number of arguments (%d for 1)", argc - 1); -#else - char buf[sizeof(int)*8 + 1]; - Tcl_ResetResult(interp); - sprintf(buf, "%d", argc-1); - Tcl_AppendResult(interp, "wrong number of arguments (", - buf, " for 1)", (char *)NULL); - rbtk_pending_exception = rb_exc_new2(rb_eArgError, - Tcl_GetStringResult(interp)); - return TCL_ERROR; -#endif - } - - /* 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 = ALLOC_N(char, len + 1); - /* arg = ckalloc(sizeof(char) * (len + 1)); */ - memcpy(arg, str, len); - arg[len] = 0; - - rb_thread_critical = thr_crit_bup; - - } -#else /* TCL_MAJOR_VERSION < 8 */ - arg = argv[1]; -#endif - - /* evaluate the argument string by ruby */ - DUMP2("rb_eval_string(%s)", arg); - - code = tcl_protect(interp, rb_eval_string, (VALUE)arg); - -#if TCL_MAJOR_VERSION >= 8 - xfree(arg); - /* ckfree(arg); */ -#endif - - return code; -} - - -/* Tcl command `ruby_cmd' */ -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); - DUMP2("rb_apply return:%"PRIxVALUE, ret); - rb_thread_critical = thr_crit_bup; - DUMP1("finish ip_ruby_cmd_core"); - - return ret; -} - -static VALUE -ip_ruby_cmd_receiver_const_get(name) - char *name; -{ - return rb_path2class(name); -} - -static VALUE -ip_ruby_cmd_receiver_get(str) - char *str; -{ - volatile VALUE receiver; - int state; - - if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) { - /* class | module | constant */ - receiver = rb_protect(ip_ruby_cmd_receiver_const_get, (VALUE)str, &state); - if (state) return Qnil; - } else if (str[0] == '$') { - /* global variable */ - receiver = rb_gv_get(str); - } else { - /* global variable omitted '$' */ - char *buf; - size_t len; - - len = strlen(str); - buf = ALLOC_N(char, len + 2); - /* buf = ckalloc(sizeof(char) * (len + 2)); */ - buf[0] = '$'; - memcpy(buf + 1, str, len); - buf[len + 1] = 0; - receiver = rb_gv_get(buf); - xfree(buf); - /* ckfree(buf); */ - } - - return receiver; -} - -/* 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 receiver; - volatile ID method; - volatile VALUE args; - char *str; - int i; - int len; - struct cmd_body_arg *arg; - int thr_crit_bup; - VALUE old_gc; - int code; - - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } - - if (argc < 3) { -#if 0 - rb_raise(rb_eArgError, "too few arguments"); -#else - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "too few arguments", (char *)NULL); - rbtk_pending_exception = rb_exc_new2(rb_eArgError, - Tcl_GetStringResult(interp)); - return TCL_ERROR; -#endif - } - - /* 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); - /* receiver = rb_protect(ip_ruby_cmd_receiver_get, (VALUE)str, &code); */ - receiver = ip_ruby_cmd_receiver_get(str); - if (NIL_P(receiver)) { -#if 0 - rb_raise(rb_eArgError, - "unknown class/module/global-variable '%s'", str); -#else - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown class/module/global-variable '", - str, "'", (char *)NULL); - rbtk_pending_exception = rb_exc_new2(rb_eArgError, - Tcl_GetStringResult(interp)); - if (old_gc == Qfalse) rb_gc_enable(); - return TCL_ERROR; -#endif - } - - /* 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 */ - args = rb_ary_new2(argc - 2); - for(i = 3; i < argc; i++) { - VALUE s; -#if TCL_MAJOR_VERSION >= 8 - str = Tcl_GetStringFromObj(argv[i], &len); - s = rb_tainted_str_new(str, len); -#else /* TCL_MAJOR_VERSION < 8 */ - str = argv[i]; - s = rb_tainted_str_new2(str); -#endif - DUMP2("arg:%s",str); - rb_ary_push(args, s); - } - - if (old_gc == Qfalse) rb_gc_enable(); - rb_thread_critical = thr_crit_bup; - - /* allocate */ - arg = ALLOC(struct cmd_body_arg); - /* arg = RbTk_ALLOC_N(struct cmd_body_arg, 1); */ - - arg->receiver = receiver; - arg->method = method; - arg->args = args; - - /* evaluate the argument string by ruby */ - code = tcl_protect(interp, ip_ruby_cmd_core, (VALUE)arg); - - xfree(arg); - /* ckfree((char*)arg); */ - - return code; -} - - -/*****************************/ -/* relpace of 'exit' command */ -/*****************************/ -static int -#if TCL_MAJOR_VERSION >= 8 -#ifdef HAVE_PROTOTYPES -ip_InterpExitObjCmd(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *CONST argv[]) -#else -ip_InterpExitObjCmd(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - Tcl_Obj *CONST argv[]; -#endif -#else /* TCL_MAJOR_VERSION < 8 */ -#ifdef HAVE_PROTOTYPES -ip_InterpExitCommand(ClientData clientData, Tcl_Interp *interp, - int argc, char *argv[]) -#else -ip_InterpExitCommand(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -#endif -#endif -{ - DUMP1("start ip_InterpExitCommand"); - if (interp != (Tcl_Interp*)NULL - && !Tcl_InterpDeleted(interp) -#if TCL_NAMESPACE_DEBUG - && !ip_null_namespace(interp) -#endif - ) { - Tcl_ResetResult(interp); - /* Tcl_Preserve(interp); */ - /* Tcl_Eval(interp, "interp eval {} {destroy .}; interp delete {}"); */ - if (!Tcl_InterpDeleted(interp)) { - ip_finalize(interp); - - Tcl_DeleteInterp(interp); - Tcl_Release(interp); - } - } - return TCL_OK; -} - -static int -#if TCL_MAJOR_VERSION >= 8 -#ifdef HAVE_PROTOTYPES -ip_RubyExitObjCmd(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *CONST argv[]) -#else -ip_RubyExitObjCmd(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - Tcl_Obj *CONST argv[]; -#endif -#else /* TCL_MAJOR_VERSION < 8 */ -#ifdef HAVE_PROTOTYPES -ip_RubyExitCommand(ClientData clientData, Tcl_Interp *interp, - int argc, char *argv[]) -#else -ip_RubyExitCommand(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -#endif -#endif -{ - int state; - char *cmd, *param; -#if TCL_MAJOR_VERSION < 8 - char *endptr; - cmd = argv[0]; -#endif - - DUMP1("start ip_RubyExitCommand"); - -#if TCL_MAJOR_VERSION >= 8 - /* cmd = Tcl_GetString(argv[0]); */ - cmd = Tcl_GetStringFromObj(argv[0], (int*)NULL); -#endif - - if (argc < 1 || argc > 2) { - /* argument error */ - Tcl_AppendResult(interp, - "wrong number of arguments: should be \"", - cmd, " ?returnCode?\"", (char *)NULL); - return TCL_ERROR; - } - - if (interp == (Tcl_Interp*)NULL) return TCL_OK; - - Tcl_ResetResult(interp); - - if (Tcl_IsSafe(interp)) { - if (!Tcl_InterpDeleted(interp)) { - ip_finalize(interp); - - Tcl_DeleteInterp(interp); - Tcl_Release(interp); - } - return TCL_OK; - } - - switch(argc) { - case 1: - /* rb_exit(0); */ /* not return if succeed */ - Tcl_AppendResult(interp, - "fail to call \"", cmd, "\"", (char *)NULL); - - rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, - Tcl_GetStringResult(interp)); - rb_iv_set(rbtk_pending_exception, "status", INT2FIX(0)); - - return TCL_RETURN; - - case 2: -#if TCL_MAJOR_VERSION >= 8 - if (Tcl_GetIntFromObj(interp, argv[1], &state) == TCL_ERROR) { - return TCL_ERROR; - } - /* param = Tcl_GetString(argv[1]); */ - param = Tcl_GetStringFromObj(argv[1], (int*)NULL); -#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); - return TCL_ERROR; - } - param = argv[1]; -#endif - /* rb_exit(state); */ /* not return if succeed */ - - Tcl_AppendResult(interp, "fail to call \"", cmd, " ", - param, "\"", (char *)NULL); - - rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, - Tcl_GetStringResult(interp)); - rb_iv_set(rbtk_pending_exception, "status", INT2FIX(state)); - - return TCL_RETURN; - - default: - /* argument error */ - Tcl_AppendResult(interp, - "wrong number of arguments: should be \"", - cmd, " ?returnCode?\"", (char *)NULL); - return TCL_ERROR; - } -} - - -/**************************/ -/* based on tclEvent.c */ -/**************************/ - -/*********************/ -/* 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 flags = 0; - static CONST char *updateOptions[] = {"idletasks", (char *) NULL}; - enum updateOptions {REGEXP_IDLETASKS}; - - DUMP1("Ruby's 'update' is called"); - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } -#ifdef HAVE_NATIVETHREAD -#ifndef RUBY_USE_NATIVE_THREAD - if (!ruby_native_thread_p()) { - rb_bug("cross-thread violation on ip_ruby_eval()"); - } -#endif -#endif - - Tcl_ResetResult(interp); - - if (objc == 1) { - flags = TCL_DONT_WAIT; - - } else if (objc == 2) { -#if TCL_MAJOR_VERSION >= 8 - int optionIndex; - if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions, - "option", 0, &optionIndex) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum updateOptions) optionIndex) { - case REGEXP_IDLETASKS: { - flags = TCL_IDLE_EVENTS; - break; - } - default: { - rb_bug("ip_rbUpdateObjCmd: bad option index to UpdateOptions"); - } - } -#else - if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) { - Tcl_AppendResult(interp, "bad option \"", objv[1], - "\": must be idletasks", (char *) NULL); - return TCL_ERROR; - } - flags = TCL_IDLE_EVENTS; -#endif - } else { -#ifdef Tcl_WrongNumArgs - Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]"); -#else -# if TCL_MAJOR_VERSION >= 8 - int dummy; - 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; - } - - Tcl_Preserve(interp); - - /* call eventloop */ - /* ret = lib_eventloop_core(0, flags, (int *)NULL);*/ /* ignore result */ - lib_eventloop_launcher(0, flags, (int *)NULL, interp); /* ignore result */ - - /* exception check */ - if (!NIL_P(rbtk_pending_exception)) { - Tcl_Release(interp); - - /* - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { - */ - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) - || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { - return TCL_RETURN; - } else{ - return TCL_ERROR; - } - } - - /* trap check */ - if (rb_thread_check_trap_pending()) { - Tcl_Release(interp); - - return TCL_RETURN; - } - - /* - * Must clear the interpreter's result because event handlers could - * have executed commands. - */ - - DUMP2("last result '%s'", Tcl_GetStringResult(interp)); - Tcl_ResetResult(interp); - Tcl_Release(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 -{ -# if 0 - int flags = 0; -# endif - struct th_update_param *param; - static CONST char *updateOptions[] = {"idletasks", (char *) NULL}; - enum updateOptions {REGEXP_IDLETASKS}; - volatile VALUE current_thread = rb_thread_current(); - struct timeval t; - - DUMP1("Ruby's 'thread_update' is called"); - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } -#ifdef HAVE_NATIVETHREAD -#ifndef RUBY_USE_NATIVE_THREAD - if (!ruby_native_thread_p()) { - rb_bug("cross-thread violation on ip_rb_threadUpdateCommand()"); - } -#endif -#endif - - if (rb_thread_alone() - || NIL_P(eventloop_thread) || eventloop_thread == current_thread) { -#if TCL_MAJOR_VERSION >= 8 - DUMP1("call ip_rbUpdateObjCmd"); - return ip_rbUpdateObjCmd(clientData, interp, objc, objv); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("call ip_rbUpdateCommand"); - return ip_rbUpdateCommand(clientData, interp, objc, objv); -#endif - } - - DUMP1("start Ruby's 'thread_update' body"); - - Tcl_ResetResult(interp); - - if (objc == 1) { -# if 0 - flags = TCL_DONT_WAIT; -# endif - } else if (objc == 2) { -#if TCL_MAJOR_VERSION >= 8 - int optionIndex; - if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions, - "option", 0, &optionIndex) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum updateOptions) optionIndex) { - case REGEXP_IDLETASKS: { -# if 0 - flags = TCL_IDLE_EVENTS; -# endif - break; - } - default: { - rb_bug("ip_rb_threadUpdateObjCmd: bad option index to UpdateOptions"); - } - } -#else - if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) { - Tcl_AppendResult(interp, "bad option \"", objv[1], - "\": must be idletasks", (char *) NULL); - return TCL_ERROR; - } -# if 0 - flags = TCL_IDLE_EVENTS; -# endif -#endif - } else { -#ifdef Tcl_WrongNumArgs - Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]"); -#else -# if TCL_MAJOR_VERSION >= 8 - int dummy; - 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)); */ - param = RbTk_ALLOC_N(struct th_update_param, 1); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)param); -#endif - param->thread = current_thread; - param->done = 0; - - DUMP1("set idle proc"); - Tcl_DoWhenIdle(rb_threadUpdateProc, (ClientData) param); - - t.tv_sec = 0; - t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); - - while(!param->done) { - DUMP1("wait for complete idle proc"); - /* rb_thread_stop(); */ - /* rb_thread_sleep_forever(); */ - rb_thread_wait_for(t); - if (NIL_P(eventloop_thread)) { - break; - } - } - -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)param); -#else - /* Tcl_Free((char *)param); */ - ckfree((char *)param); -#endif -#endif - - DUMP1("finish Ruby's 'thread_update'"); - return TCL_OK; -} - - -/***************************/ -/* replace of vwait/tkwait */ -/***************************/ -#if TCL_MAJOR_VERSION >= 8 -static int ip_rbVwaitObjCmd _((ClientData, Tcl_Interp *, int, - Tcl_Obj *CONST [])); -static int ip_rb_threadVwaitObjCmd _((ClientData, Tcl_Interp *, int, - Tcl_Obj *CONST [])); -static int ip_rbTkWaitObjCmd _((ClientData, Tcl_Interp *, int, - Tcl_Obj *CONST [])); -static int ip_rb_threadTkWaitObjCmd _((ClientData, Tcl_Interp *, int, - Tcl_Obj *CONST [])); -#else -static int ip_rbVwaitCommand _((ClientData, Tcl_Interp *, int, char *[])); -static int ip_rb_threadVwaitCommand _((ClientData, Tcl_Interp *, int, - char *[])); -static int ip_rbTkWaitCommand _((ClientData, Tcl_Interp *, int, char *[])); -static int ip_rb_threadTkWaitCommand _((ClientData, Tcl_Interp *, int, - char *[])); -#endif - -#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, interp, objc, objv) - ClientData clientData; /* Not used */ - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -static int -ip_rbVwaitCommand(clientData, interp, objc, objv) - ClientData clientData; /* Not used */ - 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"); - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } - -#if 0 - if (!rb_thread_alone() - && eventloop_thread != Qnil - && eventloop_thread != rb_thread_current()) { -#if TCL_MAJOR_VERSION >= 8 - DUMP1("call ip_rb_threadVwaitObjCmd"); - return ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("call ip_rb_threadVwaitCommand"); - return ip_rb_threadVwaitCommand(clientData, interp, objc, objv); -#endif - } -#endif - - Tcl_Preserve(interp); -#ifdef HAVE_NATIVETHREAD -#ifndef RUBY_USE_NATIVE_THREAD - if (!ruby_native_thread_p()) { - rb_bug("cross-thread violation on ip_rbVwaitCommand()"); - } -#endif -#endif - - Tcl_ResetResult(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 = RTEST(lib_eventloop_launcher(/* not check root-widget */0, - 0, &done, interp)); - - 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; - - /* exception check */ - if (!NIL_P(rbtk_pending_exception)) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[1]); -#endif - Tcl_Release(interp); - -/* - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { -*/ - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) - || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { - return TCL_RETURN; - } else{ - return TCL_ERROR; - } - } - - /* trap check */ - if (rb_thread_check_trap_pending()) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[1]); -#endif - Tcl_Release(interp); - - return TCL_RETURN; - } - - /* - * 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, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -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"); - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } - -#if 0 - if (!rb_thread_alone() - && eventloop_thread != Qnil - && eventloop_thread != rb_thread_current()) { -#if TCL_MAJOR_VERSION >= 8 - DUMP1("call ip_rb_threadTkWaitObjCmd"); - return ip_rb_threadTkWaitObjCmd((ClientData)tkwin, interp, objc, objv); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("call ip_rb_threadTkWaitCommand"); - return ip_rb_threadTkWwaitCommand((ClientData)tkwin, interp, objc, objv); -#endif - } -#endif - - Tcl_Preserve(interp); - Tcl_ResetResult(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); */ - lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp); - - 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; - - /* exception check */ - if (!NIL_P(rbtk_pending_exception)) { - Tcl_Release(interp); - - /* - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { - */ - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) - || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { - return TCL_RETURN; - } else{ - return TCL_ERROR; - } - } - - /* trap check */ - if (rb_thread_check_trap_pending()) { - Tcl_Release(interp); - - return TCL_RETURN; - } - - break; - - case TKWAIT_VISIBILITY: - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* This function works on the Tk eventloop thread only. */ - if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) { - window = NULL; - } else { - window = Tk_NameToWindow(interp, nameString, tkwin); - } - - if (window == NULL) { - Tcl_AppendResult(interp, ": tkwait: ", - "no main-window (not Tk application?)", - (char*)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); */ - lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp); - - /* exception check */ - if (!NIL_P(rbtk_pending_exception)) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - Tcl_Release(interp); - - /* - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { - */ - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) - || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { - return TCL_RETURN; - } else{ - return TCL_ERROR; - } - } - - /* trap check */ - if (rb_thread_check_trap_pending()) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - Tcl_Release(interp); - - return TCL_RETURN; - } - - 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; - - /* This function works on the Tk eventloop thread only. */ - if (!tk_stubs_init_p() || 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) { - Tcl_AppendResult(interp, ": tkwait: ", - "no main-window (not Tk application?)", - (char*)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); */ - lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp); - - /* exception check */ - if (!NIL_P(rbtk_pending_exception)) { - Tcl_Release(interp); - - /* - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { - */ - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) - || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { - return TCL_RETURN; - } else{ - return TCL_ERROR; - } - } - - /* trap check */ - if (rb_thread_check_trap_pending()) { - Tcl_Release(interp); - - return TCL_RETURN; - } - - /* - * 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; - } - if (param->done != 0) 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; - } - if (param->done != 0) 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; - } - if (param->done != 0) rb_thread_wakeup(param->thread); -} - -#if TCL_MAJOR_VERSION >= 8 -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, interp, objc, objv) - ClientData clientData; /* Not used */ - 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(); - struct timeval t; - - DUMP1("Ruby's 'thread_vwait' is called"); - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } - - 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); - Tcl_ResetResult(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)); */ - param = RbTk_ALLOC_N(struct th_vwait_param, 1); -#if 1 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)param); -#endif - 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 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 1 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)param); -#else - /* Tcl_Free((char *)param); */ - ckfree((char *)param); -#endif -#endif - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[1]); -#endif - Tcl_Release(interp); - return TCL_ERROR; - } - - t.tv_sec = 0; - t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); - - while(!param->done) { - /* rb_thread_stop(); */ - /* rb_thread_sleep_forever(); */ - rb_thread_wait_for(t); - if (NIL_P(eventloop_thread)) { - break; - } - } - - 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 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 1 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)param); -#else - /* Tcl_Free((char *)param); */ - ckfree((char *)param); -#endif -#endif - - 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, 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, 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(); - struct timeval t; - - DUMP1("Ruby's 'thread_tkwait' is called"); - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } - - if (rb_thread_alone() || eventloop_thread == current_thread) { -#if TCL_MAJOR_VERSION >= 8 - DUMP1("call ip_rbTkWaitObjCmd"); - DUMP2("eventloop_thread %"PRIxVALUE, eventloop_thread); - DUMP2("current_thread %"PRIxVALUE, current_thread); - 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); - - Tcl_ResetResult(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(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)); */ - param = RbTk_ALLOC_N(struct th_vwait_param, 1); -#if 1 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)param); -#endif - 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) { -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 1 /* use Tcl_Preserve/Release */ - Tcl_Release(param); -#else - /* Tcl_Free((char *)param); */ - ckfree((char *)param); -#endif -#endif - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - - Tcl_Release(tkwin); - Tcl_Release(interp); - return TCL_ERROR; - } - - t.tv_sec = 0; - t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); - - while(!param->done) { - /* rb_thread_stop(); */ - /* rb_thread_sleep_forever(); */ - rb_thread_wait_for(t); - if (NIL_P(eventloop_thread)) { - break; - } - } - - 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 0 /* variable 'tkwin' must keep the token of MainWindow */ - if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) { - window = NULL; - } else { - window = Tk_NameToWindow(interp, nameString, tkwin); - } -#else - if (!tk_stubs_init_p() || tkwin == (Tk_Window)NULL) { - window = NULL; - } else { - /* Tk_NameToWindow() returns right token on non-eventloop thread */ - Tcl_CmdInfo info; - if (Tcl_GetCommandInfo(interp, ".", &info)) { /* check root */ - window = Tk_NameToWindow(interp, nameString, tkwin); - } else { - window = NULL; - } - } -#endif - - if (window == NULL) { - Tcl_AppendResult(interp, ": thread_tkwait: ", - "no main-window (not Tk application?)", - (char*)NULL); - - rb_thread_critical = thr_crit_bup; - -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 1 /* use Tcl_Preserve/Release */ - Tcl_Release(param); -#else - /* Tcl_Free((char *)param); */ - ckfree((char *)param); -#endif -#endif - -#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; - - t.tv_sec = 0; - t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); - - while(param->done != TKWAIT_MODE_VISIBILITY) { - if (param->done == TKWAIT_MODE_DESTROY) break; - /* rb_thread_stop(); */ - /* rb_thread_sleep_forever(); */ - rb_thread_wait_for(t); - if (NIL_P(eventloop_thread)) { - break; - } - } - - 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); - -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 1 /* use Tcl_Preserve/Release */ - Tcl_Release(param); -#else - /* Tcl_Free((char *)param); */ - ckfree((char *)param); -#endif -#endif - -#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 0 /* variable 'tkwin' must keep the token of MainWindow */ - if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) { - window = NULL; - } else { - window = Tk_NameToWindow(interp, nameString, tkwin); - } -#else - if (!tk_stubs_init_p() || tkwin == (Tk_Window)NULL) { - window = NULL; - } else { - /* Tk_NameToWindow() returns right token on non-eventloop thread */ - Tcl_CmdInfo info; - if (Tcl_GetCommandInfo(interp, ".", &info)) { /* check root */ - window = Tk_NameToWindow(interp, nameString, tkwin); - } else { - window = NULL; - } - } -#endif - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - - if (window == NULL) { - Tcl_AppendResult(interp, ": thread_tkwait: ", - "no main-window (not Tk application?)", - (char*)NULL); - - rb_thread_critical = thr_crit_bup; - -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 1 /* use Tcl_Preserve/Release */ - Tcl_Release(param); -#else - /* Tcl_Free((char *)param); */ - ckfree((char *)param); -#endif -#endif - - 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; - - t.tv_sec = 0; - t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); - - while(param->done != TKWAIT_MODE_DESTROY) { - /* rb_thread_stop(); */ - /* rb_thread_sleep_forever(); */ - rb_thread_wait_for(t); - if (NIL_P(eventloop_thread)) { - break; - } - } - - 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 */ - -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 1 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)param); -#else - /* Tcl_Free((char *)param); */ - ckfree((char *)param); -#endif -#endif - - /* - * 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_with_position(2, argv, self, TCL_QUEUE_TAIL); -} - -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_with_position(3, argv, self, TCL_QUEUE_TAIL); -} - - -/* delete slave interpreters */ -#if TCL_MAJOR_VERSION >= 8 -static void -delete_slaves(ip) - Tcl_Interp *ip; -{ - int thr_crit_bup; - Tcl_Interp *slave; - Tcl_Obj *slave_list, *elem; - char *slave_name; - int i, len; - - DUMP1("delete slaves"); - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) { - slave_list = Tcl_GetObjResult(ip); - Tcl_IncrRefCount(slave_list); - - if (Tcl_ListObjLength((Tcl_Interp*)NULL, slave_list, &len) == TCL_OK) { - for(i = 0; i < len; i++) { - Tcl_ListObjIndex((Tcl_Interp*)NULL, slave_list, i, &elem); - - if (elem == (Tcl_Obj*)NULL) continue; - - Tcl_IncrRefCount(elem); - - /* get slave */ - /* slave_name = Tcl_GetString(elem); */ - slave_name = Tcl_GetStringFromObj(elem, (int*)NULL); - DUMP2("delete slave:'%s'", slave_name); - - Tcl_DecrRefCount(elem); - - slave = Tcl_GetSlave(ip, slave_name); - if (slave == (Tcl_Interp*)NULL) continue; - - if (!Tcl_InterpDeleted(slave)) { - /* call ip_finalize */ - ip_finalize(slave); - - Tcl_DeleteInterp(slave); - /* Tcl_Release(slave); */ - } - } - } - - Tcl_DecrRefCount(slave_list); - } - - rb_thread_critical = thr_crit_bup; -} -#else /* TCL_MAJOR_VERSION < 8 */ -static void -delete_slaves(ip) - Tcl_Interp *ip; -{ - int thr_crit_bup; - Tcl_Interp *slave; - int argc; - char **argv; - char *slave_list; - char *slave_name; - int i, len; - - DUMP1("delete slaves"); - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) { - slave_list = ip->result; - if (Tcl_SplitList((Tcl_Interp*)NULL, - slave_list, &argc, &argv) == TCL_OK) { - for(i = 0; i < argc; i++) { - slave_name = argv[i]; - - DUMP2("delete slave:'%s'", slave_name); - - slave = Tcl_GetSlave(ip, slave_name); - if (slave == (Tcl_Interp*)NULL) continue; - - if (!Tcl_InterpDeleted(slave)) { - /* call ip_finalize */ - ip_finalize(slave); - - Tcl_DeleteInterp(slave); - } - } - } - } - - rb_thread_critical = thr_crit_bup; -} -#endif - - -/* finalize operation */ -static void -#ifdef HAVE_PROTOTYPES -lib_mark_at_exit(VALUE self) -#else -lib_mark_at_exit(self) - VALUE self; -#endif -{ - at_exit = 1; -} - -static int -#if TCL_MAJOR_VERSION >= 8 -#ifdef HAVE_PROTOTYPES -ip_null_proc(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *CONST argv[]) -#else -ip_null_proc(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - Tcl_Obj *CONST argv[]; -#endif -#else /* TCL_MAJOR_VERSION < 8 */ -#ifdef HAVE_PROTOTYPES -ip_null_proc(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[]) -#else -ip_null_proc(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -#endif -#endif -{ - Tcl_ResetResult(interp); - return TCL_OK; -} - -static void -ip_finalize(ip) - Tcl_Interp *ip; -{ - Tcl_CmdInfo info; - int thr_crit_bup; - - VALUE rb_debug_bup, rb_verbose_bup; - /* When ruby is exiting, printing debug messages in some callback - operations from Tcl-IP sometimes cause SEGV. I don't know the - reason. But I got SEGV when calling "rb_io_write(rb_stdout, ...)". - So, in some part of this function, debug mode and verbose mode - are disabled. If you know the reason, please fix it. - -- Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp) */ - - DUMP1("start ip_finalize"); - - if (ip == (Tcl_Interp*)NULL) { - DUMP1("ip is NULL"); - return; - } - - if (Tcl_InterpDeleted(ip)) { - DUMP2("ip(%p) is already deleted", ip); - return; - } - -#if TCL_NAMESPACE_DEBUG - if (ip_null_namespace(ip)) { - DUMP2("ip(%p) has null namespace", ip); - return; - } -#endif - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - rb_debug_bup = ruby_debug; - rb_verbose_bup = ruby_verbose; - - Tcl_Preserve(ip); - - /* delete slaves */ - delete_slaves(ip); - - /* shut off some connections from Tcl-proc to Ruby */ - if (at_exit) { - /* NOTE: Only when at exit. - Because, ruby removes objects, which depends on the deleted - interpreter, on some callback operations. - It is important for GC. */ -#if TCL_MAJOR_VERSION >= 8 - Tcl_CreateObjCommand(ip, "ruby", ip_null_proc, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); - Tcl_CreateObjCommand(ip, "ruby_eval", ip_null_proc, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); - Tcl_CreateObjCommand(ip, "ruby_cmd", ip_null_proc, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - Tcl_CreateCommand(ip, "ruby", ip_null_proc, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); - Tcl_CreateCommand(ip, "ruby_eval", ip_null_proc, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); - Tcl_CreateCommand(ip, "ruby_cmd", ip_null_proc, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#endif - /* - rb_thread_critical = thr_crit_bup; - return; - */ - } - - /* delete root widget */ -#ifdef RUBY_VM - /* cause SEGV on Ruby 1.9 */ -#else - DUMP1("check `destroy'"); - if (Tcl_GetCommandInfo(ip, "destroy", &info)) { - DUMP1("call `destroy .'"); - Tcl_GlobalEval(ip, "catch {destroy .}"); - } -#endif -#if 1 - DUMP1("destroy root widget"); - if (tk_stubs_init_p() && Tk_MainWindow(ip) != (Tk_Window)NULL) { - /* - * On Ruby VM, this code piece may be not called, because - * Tk_MainWindow() returns NULL on a native thread except - * the thread which initialize Tk environment. - * Of course, that is a problem. But maybe not so serious. - * All widgets are destroyed when the Tcl interp is deleted. - * At then, Ruby may raise exceptions on the delete hook - * callbacks which registered for the deleted widgets, and - * may fail to clear objects which depends on the widgets. - * Although it is the problem, it is possibly avoidable by - * rescuing exceptions and the finalize hook of the interp. - */ - Tk_Window win = Tk_MainWindow(ip); - - DUMP1("call Tk_DestroyWindow"); - ruby_debug = Qfalse; - ruby_verbose = Qnil; - if (! (((Tk_FakeWin*)win)->flags & TK_ALREADY_DEAD)) { - Tk_DestroyWindow(win); - } - ruby_debug = rb_debug_bup; - ruby_verbose = rb_verbose_bup; - } -#endif - - /* call finalize-hook-proc */ - DUMP1("check `finalize-hook-proc'"); - if ( Tcl_GetCommandInfo(ip, finalize_hook_name, &info)) { - DUMP2("call finalize hook proc '%s'", finalize_hook_name); - ruby_debug = Qfalse; - ruby_verbose = Qnil; - Tcl_GlobalEval(ip, finalize_hook_name); - ruby_debug = rb_debug_bup; - ruby_verbose = rb_verbose_bup; - } - - DUMP1("check `foreach' & `after'"); - if ( Tcl_GetCommandInfo(ip, "foreach", &info) - && Tcl_GetCommandInfo(ip, "after", &info) ) { - DUMP1("cancel after callbacks"); - ruby_debug = Qfalse; - ruby_verbose = Qnil; - Tcl_GlobalEval(ip, "catch {foreach id [after info] {after cancel $id}}"); - ruby_debug = rb_debug_bup; - ruby_verbose = rb_verbose_bup; - } - - Tcl_Release(ip); - - DUMP1("finish ip_finalize"); - ruby_debug = rb_debug_bup; - ruby_verbose = rb_verbose_bup; - rb_thread_critical = thr_crit_bup; -} - - -/* destroy interpreter */ -static void -ip_free(p) - void *p; -{ - struct tcltkip *ptr = p; - int thr_crit_bup; - - DUMP2("free Tcl Interp %p", ptr->ip); - if (ptr) { - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if ( ptr->ip != (Tcl_Interp*)NULL - && !Tcl_InterpDeleted(ptr->ip) - && Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL - && !Tcl_InterpDeleted(Tcl_GetMaster(ptr->ip)) ) { - DUMP2("parent IP(%p) is not deleted", - Tcl_GetMaster(ptr->ip)); - DUMP2("slave IP(%p) should not be deleted", - ptr->ip); - xfree(ptr); - /* ckfree((char*)ptr); */ - rb_thread_critical = thr_crit_bup; - return; - } - - if (ptr->ip == (Tcl_Interp*)NULL) { - DUMP1("ip_free is called for deleted IP"); - xfree(ptr); - /* ckfree((char*)ptr); */ - rb_thread_critical = thr_crit_bup; - return; - } - - if (!Tcl_InterpDeleted(ptr->ip)) { - ip_finalize(ptr->ip); - - Tcl_DeleteInterp(ptr->ip); - Tcl_Release(ptr->ip); - } - - ptr->ip = (Tcl_Interp*)NULL; - xfree(ptr); - /* ckfree((char*)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 TypedData_Wrap_Struct(self, &tcltkip_type, 0); -} - -static void -ip_replace_wait_commands(interp, mainWin) - Tcl_Interp *interp; - Tk_Window mainWin; -{ - /* replace 'vwait' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"vwait\")"); - Tcl_CreateObjCommand(interp, "vwait", ip_rbVwaitObjCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"vwait\")"); - Tcl_CreateCommand(interp, "vwait", ip_rbVwaitCommand, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* replace 'tkwait' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"tkwait\")"); - Tcl_CreateObjCommand(interp, "tkwait", ip_rbTkWaitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"tkwait\")"); - Tcl_CreateCommand(interp, "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(interp, "thread_vwait", ip_rb_threadVwaitObjCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"thread_vwait\")"); - Tcl_CreateCommand(interp, "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(interp, "thread_tkwait", ip_rb_threadTkWaitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"thread_tkwait\")"); - Tcl_CreateCommand(interp, "thread_tkwait", ip_rb_threadTkWaitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* replace 'update' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"update\")"); - Tcl_CreateObjCommand(interp, "update", ip_rbUpdateObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"update\")"); - Tcl_CreateCommand(interp, "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(interp, "thread_update", ip_rb_threadUpdateObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"thread_update\")"); - Tcl_CreateCommand(interp, "thread_update", ip_rb_threadUpdateCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif -} - - -#if TCL_MAJOR_VERSION >= 8 -static int -ip_rb_replaceSlaveTkCmdsObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -static int -ip_rb_replaceSlaveTkCmdsCommand(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - char *objv[]; -#endif -{ - char *slave_name; - Tcl_Interp *slave; - Tk_Window mainWin; - - if (objc != 2) { -#ifdef Tcl_WrongNumArgs - Tcl_WrongNumArgs(interp, 1, objv, "slave_name"); -#else - char *nameString; -#if TCL_MAJOR_VERSION >= 8 - nameString = Tcl_GetStringFromObj(objv[0], (int*)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - nameString = objv[0]; -#endif - Tcl_AppendResult(interp, "wrong number of arguments: should be \"", - nameString, " slave_name\"", (char *) NULL); -#endif - } - -#if TCL_MAJOR_VERSION >= 8 - slave_name = Tcl_GetStringFromObj(objv[1], (int*)NULL); -#else - slave_name = objv[1]; -#endif - - slave = Tcl_GetSlave(interp, slave_name); - if (slave == NULL) { - Tcl_AppendResult(interp, "cannot find slave \"", - slave_name, "\"", (char *)NULL); - return TCL_ERROR; - } - mainWin = Tk_MainWindow(slave); - - /* replace 'exit' command --> 'interp_exit' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\""); - Tcl_CreateObjCommand(slave, "exit", ip_InterpExitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\""); - Tcl_CreateCommand(slave, "exit", ip_InterpExitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* replace vwait and tkwait */ - ip_replace_wait_commands(slave, mainWin); - - return TCL_OK; -} - -#ifndef ORIG_NAMESPACE_CMD -#define ORIG_NAMESPACE_CMD "__orig_namespace_command__" -#endif - -#if TCL_MAJOR_VERSION >= 8 -static int ip_rbNamespaceObjCmd _((ClientData, Tcl_Interp *, int, - Tcl_Obj *CONST [])); -static int -ip_rbNamespaceObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - Tcl_CmdInfo info; - int ret; - - DUMP1("call ip_rbNamespaceObjCmd"); - DUMP2("objc = %d", objc); - DUMP2("objv[0] = '%s'", Tcl_GetString(objv[0])); - DUMP2("objv[1] = '%s'", Tcl_GetString(objv[1])); - if (!Tcl_GetCommandInfo(interp, ORIG_NAMESPACE_CMD, &(info))) { - DUMP1("fail to get "ORIG_NAMESPACE_CMD); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "invalid command name \"namespace\"", (char*)NULL); - return TCL_ERROR; - } - - rbtk_eventloop_depth++; - DUMP2("namespace wrapper enter depth == %d", rbtk_eventloop_depth); - - if (info.isNativeObjectProc) { -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6 - DUMP1("call a native-object-proc"); - ret = (*(info.objProc))(info.objClientData, interp, objc, objv); -#else - /* Tcl8.6 or later */ - int i; - Tcl_Obj **cp_objv; - char org_ns_cmd_name[] = ORIG_NAMESPACE_CMD; - - DUMP1("call a native-object-proc for tcl8.6 or later"); - cp_objv = RbTk_ALLOC_N(Tcl_Obj *, (objc + 1)); - - cp_objv[0] = Tcl_NewStringObj(org_ns_cmd_name, strlen(org_ns_cmd_name)); - for(i = 1; i < objc; i++) { - cp_objv[i] = objv[i]; - } - cp_objv[objc] = (Tcl_Obj *)NULL; - - /* ret = Tcl_EvalObjv(interp, objc, cp_objv, TCL_EVAL_DIRECT); */ - ret = Tcl_EvalObjv(interp, objc, cp_objv, 0); - - ckfree((char*)cp_objv); -#endif - } else { - /* string interface */ - int i; - char **argv; - - DUMP1("call with the string-interface"); - /* argv = (char **)Tcl_Alloc(sizeof(char *) * (objc + 1)); */ - argv = RbTk_ALLOC_N(char *, (objc + 1)); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ -#endif - - for(i = 0; i < objc; i++) { - /* argv[i] = Tcl_GetString(objv[i]); */ - argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL); - } - argv[objc] = (char *)NULL; - - ret = (*(info.proc))(info.clientData, interp, - objc, (CONST84 char **)argv); - -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#else - /* Tcl_Free((char*)argv); */ - ckfree((char*)argv); -#endif -#endif - } - - DUMP2("namespace wrapper exit depth == %d", rbtk_eventloop_depth); - rbtk_eventloop_depth--; - - DUMP1("end of ip_rbNamespaceObjCmd"); - return ret; -} -#endif - -static void -ip_wrap_namespace_command(interp) - Tcl_Interp *interp; -{ -#if TCL_MAJOR_VERSION >= 8 - -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6 - Tcl_CmdInfo orig_info; - - if (!Tcl_GetCommandInfo(interp, "namespace", &(orig_info))) { - return; - } - - if (orig_info.isNativeObjectProc) { - Tcl_CreateObjCommand(interp, ORIG_NAMESPACE_CMD, - orig_info.objProc, orig_info.objClientData, - orig_info.deleteProc); - } else { - Tcl_CreateCommand(interp, ORIG_NAMESPACE_CMD, - orig_info.proc, orig_info.clientData, - orig_info.deleteProc); - } - -#else /* tcl8.6 or later */ - Tcl_Eval(interp, "rename namespace "ORIG_NAMESPACE_CMD); - -#endif - - Tcl_CreateObjCommand(interp, "namespace", ip_rbNamespaceObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *)NULL); -#endif -} - - -/* call when interpreter is deleted */ -static void -#ifdef HAVE_PROTOTYPES -ip_CallWhenDeleted(ClientData clientData, Tcl_Interp *ip) -#else -ip_CallWhenDeleted(clientData, ip) - ClientData clientData; - Tcl_Interp *ip; -#endif -{ - int thr_crit_bup; - /* Tk_Window main_win = (Tk_Window) clientData; */ - - DUMP1("start ip_CallWhenDeleted"); - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - ip_finalize(ip); - - DUMP1("finish ip_CallWhenDeleted"); - rb_thread_critical = thr_crit_bup; -} - -/*--------------------------------------------------------*/ - -/* initialize interpreter */ -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 st; - int with_tk = 1; - Tk_Window mainWin = (Tk_Window)NULL; - - /* create object */ - TypedData_Get_Struct(self, struct tcltkip, &tcltkip_type, ptr); - if (DATA_PTR(self)) { - rb_raise(rb_eArgError, "already initialized interpreter"); - } - ptr = ALLOC(struct tcltkip); - /* ptr = RbTk_ALLOC_N(struct tcltkip, 1); */ - DATA_PTR(self) = ptr; -#ifdef RUBY_USE_NATIVE_THREAD - ptr->tk_thread_id = 0; -#endif - ptr->ref_count = 0; - ptr->allow_ruby_exit = 1; - ptr->return_value = 0; - - /* from Tk_Main() */ - DUMP1("Tcl_CreateInterp"); - ptr->ip = ruby_tcl_create_ip_and_stubs_init(&st); - if (ptr->ip == NULL) { - switch(st) { - case TCLTK_STUBS_OK: - break; - case NO_TCL_DLL: - rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll"); - case NO_FindExecutable: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable"); - case NO_CreateInterp: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()"); - case NO_DeleteInterp: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()"); - case FAIL_CreateInterp: - rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP"); - case FAIL_Tcl_InitStubs: - rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()"); - default: - rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_create_ip_and_stubs_init", st); - } - } - -#if TCL_MAJOR_VERSION >= 8 -#if TCL_NAMESPACE_DEBUG - DUMP1("get current namespace"); - if ((ptr->default_ns = Tcl_GetCurrentNamespace(ptr->ip)) - == (Tcl_Namespace*)NULL) { - rb_raise(rb_eRuntimeError, "a new Tk interpreter has a NULL namespace"); - } -#endif -#endif - - 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)); - -#if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT - call_tclkit_init_script(current_interp); - -# if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84 - { - Tcl_DString encodingName; - Tcl_GetEncodingNameFromEnvironment(&encodingName); - if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) { - /* fails, so we set a variable and do it in the boot.tcl script */ - Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName)); - } - Tcl_SetVar(current_interp, "tclkit_system_encoding", Tcl_DStringValue(&encodingName), 0); - Tcl_DStringFree(&encodingName); - } -# endif -#endif - - /* set variables */ - Tcl_Eval(ptr->ip, "set argc 0; set argv {}; set argv0 tcltklib.so"); - - 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", StringValueCStr(opts), 0); */ - Tcl_SetVar(ptr->ip, "argv", StringValueCStr(opts), TCL_GLOBAL_ONLY); - Tcl_Eval(ptr->ip, "set argc [llength $argv]"); - } - case 1: - /* argv0 */ - if (!NIL_P(argv0)) { - const char *name = StringValueCStr(argv0); - long len = RSTRING_LEN(argv0); - int flag = TCL_GLOBAL_ONLY; - if ((len == 2 && memcmp(name, "-e", 2) == 0) - || (len == 1 && memcmp(name, "-", 1) == 0)) { - name = "ruby"; - } else { - /* flag = 0; */ - } - Tcl_SetVar(ptr->ip, "argv0", name, flag); - } - case 0: - /* no args */ - ; - } - - /* from Tcl_AppInit() */ - DUMP1("Tcl_Init"); -#if (defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT) && (!defined KIT_LITE) && (10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION == 85) - /*************************************************************************/ - /* FIX ME (2010/06/28) */ - /* Don't use ::chan command for Mk4tcl + tclvfs-1.4 on Tcl8.5. */ - /* It fails to access VFS files because of vfs::zstream. */ - /* So, force to use ::rechan by temporarily hiding ::chan. */ - /*************************************************************************/ - Tcl_Eval(ptr->ip, "catch {rename ::chan ::_tmp_chan}"); - if (Tcl_Init(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); - } - Tcl_Eval(ptr->ip, "catch {rename ::_tmp_chan ::chan}"); -#else - if (Tcl_Init(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); - } -#endif - - st = ruby_tcl_stubs_init(); - /* from Tcl_AppInit() */ - if (with_tk) { - DUMP1("Tk_Init"); - st = ruby_tk_stubs_init(ptr->ip); - switch(st) { - case TCLTK_STUBS_OK: - break; - case NO_Tk_Init: - rb_raise(rb_eLoadError, "tcltklib: can't find Tk_Init()"); - case FAIL_Tk_Init: - rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_Init(). %s", - Tcl_GetStringResult(ptr->ip)); - case FAIL_Tk_InitStubs: - rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_InitStubs(). %s", - Tcl_GetStringResult(ptr->ip)); - default: - rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st); - } - - 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 - -#ifdef RUBY_USE_NATIVE_THREAD - /* set Tk thread ID */ - ptr->tk_thread_id = Tcl_GetCurrentThread(); -#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 - - /* replace vwait and tkwait */ - ip_replace_wait_commands(ptr->ip, mainWin); - - /* wrap namespace command */ - ip_wrap_namespace_command(ptr->ip); - - /* define command to replace commands which depend on slave's MainWindow */ -#if TCL_MAJOR_VERSION >= 8 - Tcl_CreateObjCommand(ptr->ip, "__replace_slave_tk_commands__", - ip_rb_replaceSlaveTkCmdsObjCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - Tcl_CreateCommand(ptr->ip, "__replace_slave_tk_commands__", - ip_rb_replaceSlaveTkCmdsCommand, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* set finalizer */ - Tcl_CallWhenDeleted(ptr->ip, ip_CallWhenDeleted, (ClientData)mainWin); - - if (mainWin != (Tk_Window)NULL) { - Tk_Release((ClientData)mainWin); - } - - return self; -} - -static VALUE -ip_create_slave_core(interp, argc, argv) - VALUE interp; - int argc; - VALUE *argv; -{ - struct tcltkip *master = get_ip(interp); - struct tcltkip *slave; - /* struct tcltkip *slave = RbTk_ALLOC_N(struct tcltkip, 1); */ - VALUE safemode; - VALUE name; - VALUE new_ip; - int safe; - int thr_crit_bup; - Tk_Window mainWin; - - /* ip is deleted? */ - if (deleted_ip(master)) { - return rb_exc_new2(rb_eRuntimeError, - "deleted master cannot create a new slave"); - } - - name = argv[0]; - safemode = argv[1]; - - if (Tcl_IsSafe(master->ip) == 1) { - safe = 1; - } else if (safemode == Qfalse || NIL_P(safemode)) { - safe = 0; - } else { - safe = 1; - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - -#if 0 - /* init Tk */ - if (RTEST(with_tk)) { - volatile VALUE exc; - if (!tk_stubs_init_p()) { - exc = tcltkip_init_tk(interp); - if (!NIL_P(exc)) { - rb_thread_critical = thr_crit_bup; - return exc; - } - } - } -#endif - - new_ip = TypedData_Make_Struct(CLASS_OF(interp), struct tcltkip, - &tcltkip_type, slave); - /* create slave-ip */ -#ifdef RUBY_USE_NATIVE_THREAD - /* slave->tk_thread_id = 0; */ - slave->tk_thread_id = master->tk_thread_id; /* == current thread */ -#endif - slave->ref_count = 0; - slave->allow_ruby_exit = 0; - slave->return_value = 0; - - slave->ip = Tcl_CreateSlave(master->ip, StringValueCStr(name), safe); - if (slave->ip == NULL) { - rb_thread_critical = thr_crit_bup; - return rb_exc_new2(rb_eRuntimeError, - "fail to create the new slave interpreter"); - } -#if TCL_MAJOR_VERSION >= 8 -#if TCL_NAMESPACE_DEBUG - slave->default_ns = Tcl_GetCurrentNamespace(slave->ip); -#endif -#endif - 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_stubs_init_p())? Tk_MainWindow(slave->ip): (Tk_Window)NULL; -#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 - - /* replace vwait and tkwait */ - ip_replace_wait_commands(slave->ip, mainWin); - - /* wrap namespace command */ - ip_wrap_namespace_command(slave->ip); - - /* define command to replace cmds which depend on slave-slave's MainWin */ -#if TCL_MAJOR_VERSION >= 8 - Tcl_CreateObjCommand(slave->ip, "__replace_slave_tk_commands__", - ip_rb_replaceSlaveTkCmdsObjCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - Tcl_CreateCommand(slave->ip, "__replace_slave_tk_commands__", - ip_rb_replaceSlaveTkCmdsCommand, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* set finalizer */ - Tcl_CallWhenDeleted(slave->ip, ip_CallWhenDeleted, (ClientData)mainWin); - - rb_thread_critical = thr_crit_bup; - - return new_ip; -} - -static VALUE -ip_create_slave(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - struct tcltkip *master = get_ip(self); - VALUE safemode; - VALUE name; - VALUE callargv[2]; - - /* ip is deleted? */ - if (deleted_ip(master)) { - rb_raise(rb_eRuntimeError, - "deleted master cannot create a new slave interpreter"); - } - - /* argument check */ - if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) { - safemode = Qfalse; - } - if (Tcl_IsSafe(master->ip) != 1 - && (safemode == Qfalse || NIL_P(safemode))) { - } - - StringValue(name); - callargv[0] = name; - callargv[1] = safemode; - - return tk_funcall(ip_create_slave_core, 2, callargv, self); -} - - -/* self is slave of master? */ -static VALUE -ip_is_slave_of_p(self, master) - VALUE self, master; -{ - if (!rb_obj_is_kind_of(master, tcltkip_class)) { - rb_raise(rb_eArgError, "expected TclTkIp object"); - } - - if (Tcl_GetMaster(get_ip(self)->ip) == get_ip(master)->ip) { - return Qtrue; - } else { - return Qfalse; - } -} - - -/* create console (if supported) */ -#if defined(MAC_TCL) || defined(__WIN32__) -#if TCL_MAJOR_VERSION < 8 \ - || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0) \ - || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \ - && (TCL_RELEASE_LEVEL == TCL_ALPHA_RELEASE \ - || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \ - && TCL_RELEASE_SERIAL < 2) ) ) -EXTERN void TkConsoleCreate _((void)); -#endif -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \ - && ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \ - && TCL_RELEASE_SERIAL == 0) \ - || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \ - && TCL_RELEASE_SERIAL >= 2) ) -EXTERN void TkConsoleCreate_ _((void)); -#endif -#endif -static VALUE -ip_create_console_core(interp, argc, argv) - VALUE interp; - int argc; /* dummy */ - VALUE *argv; /* dummy */ -{ - struct tcltkip *ptr = get_ip(interp); - - if (!tk_stubs_init_p()) { - tcltkip_init_tk(interp); - } - - if (Tcl_GetVar(ptr->ip,"tcl_interactive",TCL_GLOBAL_ONLY) == (char*)NULL) { - Tcl_SetVar(ptr->ip, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - } - -#if TCL_MAJOR_VERSION > 8 \ - || (TCL_MAJOR_VERSION == 8 \ - && (TCL_MINOR_VERSION > 1 \ - || (TCL_MINOR_VERSION == 1 \ - && TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \ - && TCL_RELEASE_SERIAL >= 1) ) ) - Tk_InitConsoleChannels(ptr->ip); - - if (Tk_CreateConsoleWindow(ptr->ip) != TCL_OK) { - rb_raise(rb_eRuntimeError, "fail to create console-window"); - } -#else -#if defined(MAC_TCL) || defined(__WIN32__) -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \ - && ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE && TCL_RELEASE_SERIAL == 0) \ - || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE && TCL_RELEASE_SERIAL >= 2) ) - TkConsoleCreate_(); -#else - TkConsoleCreate(); -#endif - - if (TkConsoleInit(ptr->ip) != TCL_OK) { - rb_raise(rb_eRuntimeError, "fail to create console-window"); - } -#else - rb_notimplement(); -#endif -#endif - - return interp; -} - -static VALUE -ip_create_console(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_raise(rb_eRuntimeError, "interpreter is deleted"); - } - - return tk_funcall(ip_create_console_core, 0, (VALUE*)NULL, self); -} - -/* make ip "safe" */ -static VALUE -ip_make_safe_core(interp, argc, argv) - VALUE interp; - int argc; /* dummy */ - VALUE *argv; /* dummy */ -{ - struct tcltkip *ptr = get_ip(interp); - Tk_Window mainWin; - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted"); - } - - if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) { - /* return rb_exc_new2(rb_eRuntimeError, - Tcl_GetStringResult(ptr->ip)); */ - return create_ip_exc(interp, rb_eRuntimeError, "%s", - Tcl_GetStringResult(ptr->ip)); - } - - ptr->allow_ruby_exit = 0; - - /* replace 'exit' command --> 'interp_exit' command */ - mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL; -#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 interp; -} - -static VALUE -ip_make_safe(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_raise(rb_eRuntimeError, "interpreter is deleted"); - } - - return tk_funcall(ip_make_safe_core, 0, (VALUE*)NULL, self); -} - -/* is safe? */ -static VALUE -ip_is_safe_p(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - 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 (deleted_ip(ptr)) { - 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; - - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_raise(rb_eRuntimeError, "interpreter is deleted"); - } - - if (Tcl_IsSafe(ptr->ip)) { - rb_raise(rb_eSecurityError, - "insecure operation on a safe interpreter"); - } - - /* - * Because of cross-threading, the following line may fail to find - * the MainWindow, even if the Tcl/Tk interpreter has one or more. - * But it has no problem. Current implementation of both type of - * the "exit" command don't need maiinWin token. - */ - mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL; - - 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; -{ - int thr_crit_bup; - struct tcltkip *ptr = get_ip(self); - - /* if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL) { */ - if (deleted_ip(ptr)) { - DUMP1("delete deleted IP"); - return Qnil; - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - DUMP1("delete interp"); - if (!Tcl_InterpDeleted(ptr->ip)) { - DUMP1("call ip_finalize"); - ip_finalize(ptr->ip); - - Tcl_DeleteInterp(ptr->ip); - Tcl_Release(ptr->ip); - } - - rb_thread_critical = thr_crit_bup; - - return Qnil; -} - - -/* is deleted? */ -static VALUE -ip_has_invalid_namespace_p(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL) { - /* deleted IP */ - return Qtrue; - } - -#if TCL_NAMESPACE_DEBUG - if (rbtk_invalid_namespace(ptr)) { - return Qtrue; - } else { - return Qfalse; - } -#else - return Qfalse; -#endif -} - -static VALUE -ip_is_deleted_p(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - if (deleted_ip(ptr)) { - return Qtrue; - } else { - return Qfalse; - } -} - -static VALUE -ip_has_mainwindow_p_core(self, argc, argv) - VALUE self; - int argc; /* dummy */ - VALUE *argv; /* dummy */ -{ - struct tcltkip *ptr = get_ip(self); - - if (deleted_ip(ptr) || !tk_stubs_init_p()) { - return Qnil; - } else if (Tk_MainWindow(ptr->ip) == (Tk_Window)NULL) { - return Qfalse; - } else { - return Qtrue; - } -} - -static VALUE -ip_has_mainwindow_p(self) - VALUE self; -{ - return tk_funcall(ip_has_mainwindow_p_core, 0, (VALUE*)NULL, self); -} - - -/*** ruby string <=> tcl object ***/ -#if TCL_MAJOR_VERSION >= 8 -static VALUE -get_str_from_obj(obj) - Tcl_Obj *obj; -{ - int len, binary = 0; - const char *s; - volatile VALUE str; - -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 - s = Tcl_GetStringFromObj(obj, &len); -#else -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 3 - /* TCL_VERSION 8.1 -- 8.3 */ - if (Tcl_GetCharLength(obj) != Tcl_UniCharLen(Tcl_GetUnicode(obj))) { - /* possibly binary string */ - s = (char *)Tcl_GetByteArrayFromObj(obj, &len); - binary = 1; - } else { - /* possibly text string */ - s = Tcl_GetStringFromObj(obj, &len); - } -#else /* TCL_VERSION >= 8.4 */ - if (IS_TCL_BYTEARRAY(obj)) { - s = (char *)Tcl_GetByteArrayFromObj(obj, &len); - binary = 1; - } else { - s = Tcl_GetStringFromObj(obj, &len); - } - -#endif -#endif - str = s ? rb_str_new(s, len) : rb_str_new2(""); - if (binary) { -#ifdef HAVE_RUBY_ENCODING_H - rb_enc_associate_index(str, ENCODING_INDEX_BINARY); -#endif - rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY); -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) - } else { -#ifdef HAVE_RUBY_ENCODING_H - rb_enc_associate_index(str, ENCODING_INDEX_UTF8); -#endif - rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8); -#endif - } - return str; -} - -static Tcl_Obj * -get_obj_from_str(str) - VALUE str; -{ - const char *s = StringValueCStr(str); - -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 - return Tcl_NewStringObj((char*)s, RSTRING_LEN(str)); -#else /* TCL_VERSION >= 8.1 */ - VALUE enc = rb_attr_get(str, ID_at_enc); - - if (!NIL_P(enc)) { - StringValue(enc); - if (strcmp(RSTRING_PTR(enc), "binary") == 0) { - /* binary string */ - return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str)); - } else { - /* text string */ - return Tcl_NewStringObj(s, RSTRING_LENINT(str)); - } -#ifdef HAVE_RUBY_ENCODING_H - } else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) { - /* binary string */ - return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str)); -#endif - } else if (memchr(s, 0, RSTRING_LEN(str))) { - /* probably binary string */ - return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str)); - } else { - /* probably text string */ - return Tcl_NewStringObj(s, RSTRING_LENINT(str)); - } -#endif -} -#endif /* ruby string <=> tcl object */ - -static VALUE -ip_get_result_string_obj(interp) - Tcl_Interp *interp; -{ -#if TCL_MAJOR_VERSION >= 8 - Tcl_Obj *retObj; - volatile VALUE strval; - - retObj = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(retObj); - strval = get_str_from_obj(retObj); - RbTk_OBJ_UNTRUST(strval); - Tcl_ResetResult(interp); - Tcl_DecrRefCount(retObj); - return strval; -#else - return rb_tainted_str_new2(interp->result); -#endif -} - -/* call Tcl/Tk functions on the eventloop thread */ -static VALUE -callq_safelevel_handler(arg, callq) - VALUE arg; - VALUE callq; -{ - struct call_queue *q; - - Data_Get_Struct(callq, struct call_queue, q); - DUMP2("(safe-level handler) $SAFE = %d", q->safe_level); - rb_set_safe_level(q->safe_level); - return((q->func)(q->interp, q->argc, q->argv)); -} - -static int call_queue_handler _((Tcl_Event *, int)); -static int -call_queue_handler(evPtr, flags) - Tcl_Event *evPtr; - int flags; -{ - struct call_queue *q = (struct call_queue *)evPtr; - volatile VALUE ret; - volatile VALUE q_dat; - volatile VALUE thread = q->thread; - struct tcltkip *ptr; - - DUMP2("do_call_queue_handler : evPtr = %p", evPtr); - DUMP2("call_queue_handler thread : %"PRIxVALUE, rb_thread_current()); - DUMP2("added by thread : %"PRIxVALUE, thread); - - if (*(q->done)) { - DUMP1("processed by another event-loop"); - return 0; - } else { - DUMP1("process it on current event-loop"); - } - - if (RTEST(rb_thread_alive_p(thread)) - && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { - DUMP1("caller is not yet ready to receive the result -> pending"); - return 0; - } - - /* process it */ - *(q->done) = 1; - - /* deleted ipterp ? */ - ptr = get_ip(q->interp); - if (deleted_ip(ptr)) { - /* deleted IP --> ignore */ - return 1; - } - - /* incr internal handler mark */ - rbtk_internal_eventloop_handler++; - - /* check safe-level */ - if (rb_safe_level() != q->safe_level) { - /* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */ - q_dat = Data_Wrap_Struct(0,call_queue_mark,-1,q); - ret = rb_funcall(rb_proc_new(callq_safelevel_handler, q_dat), - ID_call, 0); - rb_gc_force_recycle(q_dat); - q_dat = (VALUE)NULL; - } else { - DUMP2("call function (for caller thread:%"PRIxVALUE")", thread); - DUMP2("call function (current thread:%"PRIxVALUE")", rb_thread_current()); - ret = (q->func)(q->interp, q->argc, q->argv); - } - - /* set result */ - RARRAY_ASET(q->result, 0, ret); - ret = (VALUE)NULL; - - /* decr internal handler mark */ - rbtk_internal_eventloop_handler--; - - /* complete */ - *(q->done) = -1; - - /* unlink ruby objects */ - q->argv = (VALUE*)NULL; - q->interp = (VALUE)NULL; - q->result = (VALUE)NULL; - q->thread = (VALUE)NULL; - - /* back to caller */ - if (RTEST(rb_thread_alive_p(thread))) { - DUMP2("back to caller (caller thread:%"PRIxVALUE")", thread); - DUMP2(" (current thread:%"PRIxVALUE")", rb_thread_current()); -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE - have_rb_thread_waiting_for_value = 1; - rb_thread_wakeup(thread); -#else - rb_thread_run(thread); -#endif - DUMP1("finish back to caller"); -#if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE - rb_thread_schedule(); -#endif - } else { - DUMP2("caller is dead (caller thread:%"PRIxVALUE")", thread); - DUMP2(" (current thread:%"PRIxVALUE")", rb_thread_current()); - } - - /* end of handler : remove it */ - return 1; -} - -static VALUE -tk_funcall(func, argc, argv, obj) - VALUE (*func)(); - int argc; - VALUE *argv; - VALUE obj; -{ - struct call_queue *callq; - struct tcltkip *ptr; - int *alloc_done; - int thr_crit_bup; - int is_tk_evloop_thread; - volatile VALUE current = rb_thread_current(); - volatile VALUE ip_obj = obj; - volatile VALUE result; - volatile VALUE ret; - struct timeval t; - - if (!NIL_P(ip_obj) && rb_obj_is_kind_of(ip_obj, tcltkip_class)) { - ptr = get_ip(ip_obj); - if (deleted_ip(ptr)) return Qnil; - } else { - ptr = (struct tcltkip *)NULL; - } - -#ifdef RUBY_USE_NATIVE_THREAD - if (ptr) { - /* on Tcl interpreter */ - is_tk_evloop_thread = (ptr->tk_thread_id == (Tcl_ThreadId) 0 - || ptr->tk_thread_id == Tcl_GetCurrentThread()); - } else { - /* on Tcl/Tk library */ - is_tk_evloop_thread = (tk_eventloop_thread_id == (Tcl_ThreadId) 0 - || tk_eventloop_thread_id == Tcl_GetCurrentThread()); - } -#else - is_tk_evloop_thread = 1; -#endif - - if (is_tk_evloop_thread - && (NIL_P(eventloop_thread) || current == eventloop_thread) - ) { - if (NIL_P(eventloop_thread)) { - DUMP2("tk_funcall from thread:%"PRIxVALUE" but no eventloop", current); - } else { - DUMP2("tk_funcall from current eventloop %"PRIxVALUE, current); - } - result = (func)(ip_obj, argc, argv); - if (rb_obj_is_kind_of(result, rb_eException)) { - rb_exc_raise(result); - } - return result; - } - - DUMP2("tk_funcall from thread %"PRIxVALUE" (NOT current eventloop)", current); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* allocate memory (argv cross over thread : must be in heap) */ - if (argv) { - /* VALUE *temp = ALLOC_N(VALUE, argc); */ - VALUE *temp = RbTk_ALLOC_N(VALUE, argc); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)temp); /* XXXXXXXX */ -#endif - MEMCPY(temp, argv, VALUE, argc); - argv = temp; - } - - /* allocate memory (keep result) */ - /* alloc_done = (int*)ALLOC(int); */ - alloc_done = RbTk_ALLOC_N(int, 1); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */ -#endif - *alloc_done = 0; - - /* allocate memory (freed by Tcl_ServiceEvent) */ - /* callq = (struct call_queue *)Tcl_Alloc(sizeof(struct call_queue)); */ - callq = RbTk_ALLOC_N(struct call_queue, 1); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve(callq); -#endif - - /* allocate result obj */ - result = rb_ary_new3(1, Qnil); - - /* construct event data */ - callq->done = alloc_done; - callq->func = func; - callq->argc = argc; - callq->argv = argv; - callq->interp = ip_obj; - callq->result = result; - callq->thread = current; - callq->safe_level = rb_safe_level(); - callq->ev.proc = call_queue_handler; - - /* add the handler to Tcl event queue */ - DUMP1("add handler"); -#ifdef RUBY_USE_NATIVE_THREAD - if (ptr && ptr->tk_thread_id) { - /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, - &(callq->ev), TCL_QUEUE_HEAD); */ - Tcl_ThreadQueueEvent(ptr->tk_thread_id, - (Tcl_Event*)callq, TCL_QUEUE_HEAD); - Tcl_ThreadAlert(ptr->tk_thread_id); - } else if (tk_eventloop_thread_id) { - /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id, - &(callq->ev), TCL_QUEUE_HEAD); */ - Tcl_ThreadQueueEvent(tk_eventloop_thread_id, - (Tcl_Event*)callq, TCL_QUEUE_HEAD); - Tcl_ThreadAlert(tk_eventloop_thread_id); - } else { - /* Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); */ - Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD); - } -#else - /* Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); */ - Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD); -#endif - - rb_thread_critical = thr_crit_bup; - - /* wait for the handler to be processed */ - t.tv_sec = 0; - t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); - - DUMP2("callq wait for handler (current thread:%"PRIxVALUE")", current); - while(*alloc_done >= 0) { - DUMP2("*** callq wait for handler (current thread:%"PRIxVALUE")", current); - /* rb_thread_stop(); */ - /* rb_thread_sleep_forever(); */ - rb_thread_wait_for(t); - DUMP2("*** callq wakeup (current thread:%"PRIxVALUE")", current); - DUMP2("*** (eventloop thread:%"PRIxVALUE")", eventloop_thread); - if (NIL_P(eventloop_thread)) { - DUMP1("*** callq lost eventloop thread"); - break; - } - } - DUMP2("back from handler (current thread:%"PRIxVALUE")", current); - - /* get result & free allocated memory */ - ret = RARRAY_AREF(result, 0); -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */ -#else - /* free(alloc_done); */ - ckfree((char*)alloc_done); -#endif -#endif - /* if (argv) free(argv); */ - if (argv) { - /* if argv != NULL, alloc as 'temp' */ - int i; - for(i = 0; i < argc; i++) { argv[i] = (VALUE)NULL; } - -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#else - ckfree((char*)argv); -#endif -#endif - } - -#if 0 /* callq is freed by Tcl_ServiceEvent */ -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release(callq); -#else - ckfree((char*)callq); -#endif -#endif - - /* exception? */ - if (rb_obj_is_kind_of(ret, rb_eException)) { - DUMP1("raise exception"); - /* rb_exc_raise(ret); */ - rb_exc_raise(rb_exc_new3(rb_obj_class(ret), - rb_funcallv(ret, ID_to_s, 0, 0))); - } - - DUMP1("exit tk_funcall"); - return ret; -} - - -/* eval string in tcl by Tcl_Eval() */ -#if TCL_MAJOR_VERSION >= 8 -struct call_eval_info { - struct tcltkip *ptr; - Tcl_Obj *cmd; -}; - -static VALUE -#ifdef HAVE_PROTOTYPES -call_tcl_eval(VALUE arg) -#else -call_tcl_eval(arg) - VALUE arg; -#endif -{ - struct call_eval_info *inf = (struct call_eval_info *)arg; - - Tcl_AllowExceptions(inf->ptr->ip); - inf->ptr->return_value = Tcl_EvalObj(inf->ptr->ip, inf->cmd); - - return Qnil; -} -#endif - -static VALUE -ip_eval_real(self, cmd_str, cmd_len) - VALUE self; - char *cmd_str; - int cmd_len; -{ - volatile VALUE ret; - 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 (deleted_ip(ptr)) { - Tcl_DecrRefCount(cmd); - rb_thread_critical = thr_crit_bup; - ptr->return_value = TCL_OK; - return rb_tainted_str_new2(""); - } else { - int status; - struct call_eval_info inf; - - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - -#if 0 - ptr->return_value = Tcl_EvalObj(ptr->ip, cmd); - /* ptr->return_value = Tcl_GlobalEvalObj(ptr->ip, cmd); */ -#else - inf.ptr = ptr; - inf.cmd = cmd; - ret = rb_protect(call_tcl_eval, (VALUE)&inf, &status); - switch(status) { - case TAG_RAISE: - if (NIL_P(rb_errinfo())) { - rbtk_pending_exception = rb_exc_new2(rb_eException, - "unknown exception"); - } else { - rbtk_pending_exception = rb_errinfo(); - } - break; - - case TAG_FATAL: - if (NIL_P(rb_errinfo())) { - rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL"); - } else { - rbtk_pending_exception = rb_errinfo(); - } - } -#endif - } - - Tcl_DecrRefCount(cmd); - - } - - if (pending_exception_check1(thr_crit_bup, ptr)) { - rbtk_release_ip(ptr); - return rbtk_pending_exception; - } - - /* if (ptr->return_value == TCL_ERROR) { */ - if (ptr->return_value != TCL_OK) { - if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) { - volatile VALUE exc; - - switch (ptr->return_value) { - case TCL_RETURN: - exc = create_ip_exc(self, eTkCallbackReturn, - "ip_eval_real receives TCL_RETURN"); - case TCL_BREAK: - exc = create_ip_exc(self, eTkCallbackBreak, - "ip_eval_real receives TCL_BREAK"); - case TCL_CONTINUE: - exc = create_ip_exc(self, eTkCallbackContinue, - "ip_eval_real receives TCL_CONTINUE"); - default: - exc = create_ip_exc(self, rb_eRuntimeError, "%s", - Tcl_GetStringResult(ptr->ip)); - } - - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return exc; - } else { - if (event_loop_abort_on_exc < 0) { - rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip)); - } else { - rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip)); - } - Tcl_ResetResult(ptr->ip); - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return rb_tainted_str_new2(""); - } - } - - /* pass back the result (as string) */ - ret = ip_get_result_string_obj(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 (deleted_ip(ptr)) { - 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 (pending_exception_check1(thr_crit_bup, ptr)) { - rbtk_release_ip(ptr); - return rbtk_pending_exception; - } - - /* if (ptr->return_value == TCL_ERROR) { */ - if (ptr->return_value != TCL_OK) { - volatile VALUE exc; - - switch (ptr->return_value) { - case TCL_RETURN: - exc = create_ip_exc(self, eTkCallbackReturn, - "ip_eval_real receives TCL_RETURN"); - case TCL_BREAK: - exc = create_ip_exc(self, eTkCallbackBreak, - "ip_eval_real receives TCL_BREAK"); - case TCL_CONTINUE: - exc = create_ip_exc(self, eTkCallbackContinue, - "ip_eval_real receives TCL_CONTINUE"); - default: - exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result); - } - - rbtk_release_ip(ptr); - return exc; - } - DUMP2("(TCL_Eval result) %d", ptr->return_value); - - /* pass back the result (as string) */ - ret = ip_get_result_string_obj(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; - volatile VALUE thread = q->thread; - struct tcltkip *ptr; - - DUMP2("do_eval_queue_handler : evPtr = %p", evPtr); - DUMP2("eval_queue_thread : %"PRIxVALUE, rb_thread_current()); - DUMP2("added by thread : %"PRIxVALUE, thread); - - if (*(q->done)) { - DUMP1("processed by another event-loop"); - return 0; - } else { - DUMP1("process it on current event-loop"); - } - - if (RTEST(rb_thread_alive_p(thread)) - && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { - DUMP1("caller is not yet ready to receive the result -> pending"); - return 0; - } - - /* process it */ - *(q->done) = 1; - - /* deleted ipterp ? */ - ptr = get_ip(q->interp); - if (deleted_ip(ptr)) { - /* deleted IP --> ignore */ - return 1; - } - - /* incr internal handler mark */ - rbtk_internal_eventloop_handler++; - - /* check safe-level */ - if (rb_safe_level() != q->safe_level) { -#ifdef HAVE_NATIVETHREAD -#ifndef RUBY_USE_NATIVE_THREAD - if (!ruby_native_thread_p()) { - rb_bug("cross-thread violation on eval_queue_handler()"); - } -#endif -#endif - /* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */ - q_dat = Data_Wrap_Struct(0,eval_queue_mark,-1,q); - ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat), - ID_call, 0); - rb_gc_force_recycle(q_dat); - q_dat = (VALUE)NULL; - } else { - ret = ip_eval_real(q->interp, q->str, q->len); - } - - /* set result */ - RARRAY_ASET(q->result, 0, ret); - ret = (VALUE)NULL; - - /* decr internal handler mark */ - rbtk_internal_eventloop_handler--; - - /* complete */ - *(q->done) = -1; - - /* unlink ruby objects */ - q->interp = (VALUE)NULL; - q->result = (VALUE)NULL; - q->thread = (VALUE)NULL; - - /* back to caller */ - if (RTEST(rb_thread_alive_p(thread))) { - DUMP2("back to caller (caller thread:%"PRIxVALUE")", thread); - DUMP2(" (current thread:%"PRIxVALUE")", rb_thread_current()); -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE - have_rb_thread_waiting_for_value = 1; - rb_thread_wakeup(thread); -#else - rb_thread_run(thread); -#endif - DUMP1("finish back to caller"); -#if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE - rb_thread_schedule(); -#endif - } else { - DUMP2("caller is dead (caller thread:%"PRIxVALUE")", thread); - DUMP2(" (current thread:%"PRIxVALUE")", rb_thread_current()); - } - - /* end of handler : remove it */ - return 1; -} - -static VALUE -ip_eval(self, str) - VALUE self; - VALUE str; -{ - struct eval_queue *evq; -#ifdef RUBY_USE_NATIVE_THREAD - struct tcltkip *ptr; -#endif - 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; - struct timeval t; - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - StringValue(str); - rb_thread_critical = thr_crit_bup; - -#ifdef RUBY_USE_NATIVE_THREAD - ptr = get_ip(ip_obj); - DUMP2("eval status: ptr->tk_thread_id %p", ptr->tk_thread_id); - DUMP2("eval status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread()); -#else - DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread()); -#endif - DUMP2("status: eventloopt_thread %"PRIxVALUE, eventloop_thread); - - if ( -#ifdef RUBY_USE_NATIVE_THREAD - (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread()) - && -#endif - (NIL_P(eventloop_thread) || current == eventloop_thread) - ) { - if (NIL_P(eventloop_thread)) { - DUMP2("eval from thread:%"PRIxVALUE" but no eventloop", current); - } else { - DUMP2("eval from current eventloop %"PRIxVALUE, current); - } - result = ip_eval_real(self, RSTRING_PTR(str), RSTRING_LENINT(str)); - if (rb_obj_is_kind_of(result, rb_eException)) { - rb_exc_raise(result); - } - return result; - } - - DUMP2("eval from thread %"PRIxVALUE" (NOT current eventloop)", current); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* allocate memory (keep result) */ - /* alloc_done = (int*)ALLOC(int); */ - alloc_done = RbTk_ALLOC_N(int, 1); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */ -#endif - *alloc_done = 0; - - /* eval_str = ALLOC_N(char, RSTRING_LEN(str) + 1); */ - eval_str = ckalloc(RSTRING_LENINT(str) + 1); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)eval_str); /* XXXXXXXX */ -#endif - memcpy(eval_str, RSTRING_PTR(str), RSTRING_LEN(str)); - eval_str[RSTRING_LEN(str)] = 0; - - /* allocate memory (freed by Tcl_ServiceEvent) */ - /* evq = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); */ - evq = RbTk_ALLOC_N(struct eval_queue, 1); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve(evq); -#endif - - /* allocate result obj */ - result = rb_ary_new3(1, Qnil); - - /* construct event data */ - evq->done = alloc_done; - evq->str = eval_str; - evq->len = RSTRING_LENINT(str); - 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"); -#ifdef RUBY_USE_NATIVE_THREAD - if (ptr->tk_thread_id) { - /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(evq->ev), position); */ - Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)evq, position); - Tcl_ThreadAlert(ptr->tk_thread_id); - } else if (tk_eventloop_thread_id) { - Tcl_ThreadQueueEvent(tk_eventloop_thread_id, (Tcl_Event*)evq, position); - /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id, - &(evq->ev), position); */ - Tcl_ThreadAlert(tk_eventloop_thread_id); - } else { - /* Tcl_QueueEvent(&(evq->ev), position); */ - Tcl_QueueEvent((Tcl_Event*)evq, position); - } -#else - /* Tcl_QueueEvent(&(evq->ev), position); */ - Tcl_QueueEvent((Tcl_Event*)evq, position); -#endif - - rb_thread_critical = thr_crit_bup; - - /* wait for the handler to be processed */ - t.tv_sec = 0; - t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); - - DUMP2("evq wait for handler (current thread:%"PRIxVALUE")", current); - while(*alloc_done >= 0) { - DUMP2("*** evq wait for handler (current thread:%"PRIxVALUE")", current); - /* rb_thread_stop(); */ - /* rb_thread_sleep_forever(); */ - rb_thread_wait_for(t); - DUMP2("*** evq wakeup (current thread:%"PRIxVALUE")", current); - DUMP2("*** (eventloop thread:%"PRIxVALUE")", eventloop_thread); - if (NIL_P(eventloop_thread)) { - DUMP1("*** evq lost eventloop thread"); - break; - } - } - DUMP2("back from handler (current thread:%"PRIxVALUE")", current); - - /* get result & free allocated memory */ - ret = RARRAY_AREF(result, 0); - -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */ -#else - /* free(alloc_done); */ - ckfree((char*)alloc_done); -#endif -#endif -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)eval_str, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)eval_str); /* XXXXXXXX */ -#else - /* free(eval_str); */ - ckfree(eval_str); -#endif -#endif -#if 0 /* evq is freed by Tcl_ServiceEvent */ -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release(evq); -#else - ckfree((char*)evq); -#endif -#endif - - if (rb_obj_is_kind_of(ret, rb_eException)) { - DUMP1("raise exception"); - /* rb_exc_raise(ret); */ - rb_exc_raise(rb_exc_new3(rb_obj_class(ret), - rb_funcallv(ret, ID_to_s, 0, 0))); - } - - return ret; -} - - -static int -ip_cancel_eval_core(interp, msg, flag) - Tcl_Interp *interp; - VALUE msg; - int flag; -{ -#if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6) - rb_raise(rb_eNotImpError, - "cancel_eval is supported Tcl/Tk8.6 or later."); - - UNREACHABLE; -#else - Tcl_Obj *msg_obj; - - if (NIL_P(msg)) { - msg_obj = NULL; - } else { - char *s = StringValueCStr(msg); - msg_obj = Tcl_NewStringObj(s, RSTRING_LENINT(msg)); - Tcl_IncrRefCount(msg_obj); - } - - return Tcl_CancelEval(interp, msg_obj, 0, flag); -#endif -} - -static VALUE -ip_cancel_eval(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - VALUE retval; - - if (rb_scan_args(argc, argv, "01", &retval) == 0) { - retval = Qnil; - } - if (ip_cancel_eval_core(get_ip(self)->ip, retval, 0) == TCL_OK) { - return Qtrue; - } else { - return Qfalse; - } -} - -#ifndef TCL_CANCEL_UNWIND -#define TCL_CANCEL_UNWIND 0x100000 -#endif -static VALUE -ip_cancel_eval_unwind(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - int flag = 0; - VALUE retval; - - if (rb_scan_args(argc, argv, "01", &retval) == 0) { - retval = Qnil; - } - - flag |= TCL_CANCEL_UNWIND; - if (ip_cancel_eval_core(get_ip(self)->ip, retval, flag) == TCL_OK) { - return Qtrue; - } else { - return Qfalse; - } -} - -/* restart Tk */ -static VALUE -lib_restart_core(interp, argc, argv) - VALUE interp; - int argc; /* dummy */ - VALUE *argv; /* dummy */ -{ - volatile VALUE exc; - struct tcltkip *ptr = get_ip(interp); - int thr_crit_bup; - - - /* tcl_stubs_check(); */ /* already checked */ - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return rb_exc_new2(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); - -#if TCL_MAJOR_VERSION >= 8 - /* 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); -#endif - - /* 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 or Tk_SafeInit */ - exc = tcltkip_init_tk(interp); - if (!NIL_P(exc)) { - rb_thread_critical = thr_crit_bup; - rbtk_release_ip(ptr); - return exc; - } - - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - - rb_thread_critical = thr_crit_bup; - - /* return Qnil; */ - return interp; -} - -static VALUE -lib_restart(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - - tcl_stubs_check(); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_raise(rb_eRuntimeError, "interpreter is deleted"); - } - - return tk_funcall(lib_restart_core, 0, (VALUE*)NULL, self); -} - - -static VALUE -ip_restart(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - - tcl_stubs_check(); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - 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 -# if 0 - Tcl_Interp *interp; -# endif - Tcl_Encoding encoding; - Tcl_DString dstr; - int taint_flag = OBJ_TAINTED(str); - struct tcltkip *ptr; - char *buf; - int thr_crit_bup; -#endif - - tcl_stubs_check(); - - if (NIL_P(src)) { - return rb_str_new2(""); - } - -#ifdef TCL_UTF_MAX - if (NIL_P(ip_obj)) { -# if 0 - interp = (Tcl_Interp *)NULL; -# endif - } else { - ptr = get_ip(ip_obj); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { -# if 0 - interp = (Tcl_Interp *)NULL; - } else { - interp = ptr->ip; -# endif - } - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if (NIL_P(encodename)) { - if (RB_TYPE_P(str, T_STRING)) { - volatile VALUE enc; - -#ifdef HAVE_RUBY_ENCODING_H - enc = rb_funcallv(rb_obj_encoding(str), ID_to_s, 0, 0); -#else - enc = rb_attr_get(str, ID_at_enc); -#endif - if (NIL_P(enc)) { - if (NIL_P(ip_obj)) { - encoding = (Tcl_Encoding)NULL; - } else { - enc = rb_attr_get(ip_obj, ID_at_enc); - if (NIL_P(enc)) { - encoding = (Tcl_Encoding)NULL; - } else { - /* StringValue(enc); */ - enc = rb_funcallv(enc, ID_to_s, 0, 0); - /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ - if (!RSTRING_LEN(enc)) { - encoding = (Tcl_Encoding)NULL; - } else { - encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, - RSTRING_PTR(enc)); - if (encoding == (Tcl_Encoding)NULL) { - rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc)); - } - } - } - } - } else { - StringValue(enc); - if (strcmp(RSTRING_PTR(enc), "binary") == 0) { -#ifdef HAVE_RUBY_ENCODING_H - rb_enc_associate_index(str, ENCODING_INDEX_BINARY); -#endif - rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY); - rb_thread_critical = thr_crit_bup; - return str; - } - /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ - encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, - RSTRING_PTR(enc)); - if (encoding == (Tcl_Encoding)NULL) { - rb_warning("string has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc)); - } - } - } else { - encoding = (Tcl_Encoding)NULL; - } - } else { - StringValue(encodename); - if (strcmp(RSTRING_PTR(encodename), "binary") == 0) { -#ifdef HAVE_RUBY_ENCODING_H - rb_enc_associate_index(str, ENCODING_INDEX_BINARY); -#endif - rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY); - rb_thread_critical = thr_crit_bup; - return str; - } - /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); */ - encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename)); - if (encoding == (Tcl_Encoding)NULL) { - /* - rb_warning("unknown encoding name '%s'", - RSTRING_PTR(encodename)); - */ - rb_raise(rb_eArgError, "unknown encoding name '%s'", - RSTRING_PTR(encodename)); - } - } - - StringValue(str); - if (!RSTRING_LEN(str)) { - rb_thread_critical = thr_crit_bup; - return str; - } - buf = ALLOC_N(char, RSTRING_LEN(str)+1); - /* buf = ckalloc(sizeof(char) * (RSTRING_LENINT(str)+1)); */ - memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str)); - buf[RSTRING_LEN(str)] = 0; - - Tcl_DStringInit(&dstr); - Tcl_DStringFree(&dstr); - /* Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr); */ - Tcl_ExternalToUtfDString(encoding, buf, RSTRING_LENINT(str), &dstr); - - /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */ - /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */ - str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)); -#ifdef HAVE_RUBY_ENCODING_H - rb_enc_associate_index(str, ENCODING_INDEX_UTF8); -#endif - if (taint_flag) RbTk_OBJ_UNTRUST(str); - rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8); - - /* - if (encoding != (Tcl_Encoding)NULL) { - Tcl_FreeEncoding(encoding); - } - */ - Tcl_DStringFree(&dstr); - - xfree(buf); - /* ckfree(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; -#endif - - tcl_stubs_check(); - - if (NIL_P(src)) { - return rb_str_new2(""); - } - -#ifdef TCL_UTF_MAX - if (NIL_P(ip_obj)) { - interp = (Tcl_Interp *)NULL; - } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) { - 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 (RB_TYPE_P(str, T_STRING)) { - enc = rb_attr_get(str, ID_at_enc); - if (!NIL_P(enc)) { - StringValue(enc); - if (strcmp(RSTRING_PTR(enc), "binary") == 0) { -#ifdef HAVE_RUBY_ENCODING_H - rb_enc_associate_index(str, ENCODING_INDEX_BINARY); -#endif - rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY); - rb_thread_critical = thr_crit_bup; - return str; - } -#ifdef HAVE_RUBY_ENCODING_H - } else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) { - rb_enc_associate_index(str, ENCODING_INDEX_BINARY); - rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY); - rb_thread_critical = thr_crit_bup; - return str; -#endif - } - } - - if (NIL_P(ip_obj)) { - encoding = (Tcl_Encoding)NULL; - } else { - enc = rb_attr_get(ip_obj, ID_at_enc); - if (NIL_P(enc)) { - encoding = (Tcl_Encoding)NULL; - } else { - /* StringValue(enc); */ - enc = rb_funcallv(enc, ID_to_s, 0, 0); - /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ - if (!RSTRING_LEN(enc)) { - encoding = (Tcl_Encoding)NULL; - } else { - encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, - RSTRING_PTR(enc)); - if (encoding == (Tcl_Encoding)NULL) { - rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc)); - } else { - encodename = rb_obj_dup(enc); - } - } - } - } - - } else { - StringValue(encodename); - - if (strcmp(RSTRING_PTR(encodename), "binary") == 0) { - Tcl_Obj *tclstr; - char *s; - int len; - - StringValue(str); - tclstr = Tcl_NewStringObj(RSTRING_PTR(str), RSTRING_LENINT(str)); - Tcl_IncrRefCount(tclstr); - s = (char*)Tcl_GetByteArrayFromObj(tclstr, &len); - str = rb_tainted_str_new(s, len); - s = (char*)NULL; - Tcl_DecrRefCount(tclstr); -#ifdef HAVE_RUBY_ENCODING_H - rb_enc_associate_index(str, ENCODING_INDEX_BINARY); -#endif - rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY); - - rb_thread_critical = thr_crit_bup; - return str; - } - - /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); */ - encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename)); - if (encoding == (Tcl_Encoding)NULL) { - /* - rb_warning("unknown encoding name '%s'", - RSTRING_PTR(encodename)); - encodename = Qnil; - */ - rb_raise(rb_eArgError, "unknown encoding name '%s'", - RSTRING_PTR(encodename)); - } - } - - StringValue(str); - - if (RSTRING_LEN(str) == 0) { - rb_thread_critical = thr_crit_bup; - return rb_tainted_str_new2(""); - } - - buf = ALLOC_N(char, RSTRING_LEN(str)+1); - /* buf = ckalloc(sizeof(char) * (RSTRING_LENINT(str)+1)); */ - memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str)); - buf[RSTRING_LEN(str)] = 0; - - Tcl_DStringInit(&dstr); - Tcl_DStringFree(&dstr); - /* Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr); */ - Tcl_UtfToExternalDString(encoding,buf,RSTRING_LENINT(str),&dstr); - - /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */ - /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */ - str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)); -#ifdef HAVE_RUBY_ENCODING_H - if (interp) { - /* can access encoding_table of TclTkIp */ - /* -> try to use encoding_table */ - VALUE tbl = ip_get_encoding_table(ip_obj); - VALUE encobj = encoding_table_get_obj(tbl, encodename); - rb_enc_associate_index(str, rb_to_encoding_index(encobj)); - } else { - /* cannot access encoding_table of TclTkIp */ - /* -> try to find on Ruby Encoding */ - rb_enc_associate_index(str, rb_enc_find_index(RSTRING_PTR(encodename))); - } -#endif - - if (taint_flag) RbTk_OBJ_UNTRUST(str); - rb_ivar_set(str, ID_at_enc, encodename); - - /* - if (encoding != (Tcl_Encoding)NULL) { - Tcl_FreeEncoding(encoding); - } - */ - Tcl_DStringFree(&dstr); - - xfree(buf); - /* ckfree(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; - - tcl_stubs_check(); - - StringValue(str); - if (!RSTRING_LEN(str)) { - return str; - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* src_buf = ALLOC_N(char, RSTRING_LEN(str)+1); */ - src_buf = ckalloc(RSTRING_LENINT(str)+1); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)src_buf); /* XXXXXXXX */ -#endif - memcpy(src_buf, RSTRING_PTR(str), RSTRING_LEN(str)); - src_buf[RSTRING_LEN(str)] = 0; - - /* dst_buf = ALLOC_N(char, RSTRING_LEN(str)+1); */ - dst_buf = ckalloc(RSTRING_LENINT(str)+1); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)dst_buf); /* XXXXXXXX */ -#endif - - ptr = src_buf; - while(RSTRING_LEN(str) > 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) RbTk_OBJ_UNTRUST(str); -#ifdef HAVE_RUBY_ENCODING_H - rb_enc_associate_index(str, ENCODING_INDEX_UTF8); -#endif - rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8); - -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)src_buf, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)src_buf); /* XXXXXXXX */ -#else - /* free(src_buf); */ - ckfree(src_buf); -#endif -#endif -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)dst_buf, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)dst_buf); /* XXXXXXXX */ -#else - /* free(dst_buf); */ - ckfree(dst_buf); -#endif -#endif - - 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); -} - -static VALUE -lib_get_system_encoding(self) - VALUE self; -{ -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) - tcl_stubs_check(); - return rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL)); -#else - return Qnil; -#endif -} - -static VALUE -lib_set_system_encoding(self, enc_name) - VALUE self; - VALUE enc_name; -{ -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) - tcl_stubs_check(); - - if (NIL_P(enc_name)) { - Tcl_SetSystemEncoding((Tcl_Interp *)NULL, (CONST char *)NULL); - return lib_get_system_encoding(self); - } - - enc_name = rb_funcallv(enc_name, ID_to_s, 0, 0); - if (Tcl_SetSystemEncoding((Tcl_Interp *)NULL, - StringValueCStr(enc_name)) != TCL_OK) { - rb_raise(rb_eArgError, "unknown encoding name '%s'", - RSTRING_PTR(enc_name)); - } - - return enc_name; -#else - return Qnil; -#endif -} - - -/* invoke Tcl proc */ -struct invoke_info { - struct tcltkip *ptr; - Tcl_CmdInfo cmdinfo; -#if TCL_MAJOR_VERSION >= 8 - int objc; - Tcl_Obj **objv; -#else - int argc; - char **argv; -#endif -}; - -static VALUE -#ifdef HAVE_PROTOTYPES -invoke_tcl_proc(VALUE arg) -#else -invoke_tcl_proc(arg) - VALUE arg; -#endif -{ - struct invoke_info *inf = (struct invoke_info *)arg; -#if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION < 6 - int i, len; - int argc = inf->objc; - char **argv = (char **)NULL; -#endif - - DUMP1("call invoke_tcl_proc"); - -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 6) - /* Tcl/Tk 8.6 or later */ - - /* eval */ - inf->ptr->return_value = Tcl_EvalObjv(inf->ptr->ip, inf->objc, inf->objv, TCL_EVAL_DIRECT); - /* inf->ptr->return_value = Tcl_EvalObjv(inf->ptr->ip, inf->objc, inf->objv, 0); */ - -#else /* Tcl/Tk 7.x, 8.0 -- 8.5 */ - - /* memory allocation for arguments of this command */ -#if TCL_MAJOR_VERSION == 8 - /* Tcl/Tk 8.0 -- 8.5 */ - if (!inf->cmdinfo.isNativeObjectProc) { - DUMP1("called proc is not a native-obj-proc"); - /* string interface */ - /* argv = (char **)ALLOC_N(char *, argc+1);*/ /* XXXXXXXXXX */ - argv = RbTk_ALLOC_N(char *, (argc+1)); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ -#endif - for (i = 0; i < argc; ++i) { - argv[i] = Tcl_GetStringFromObj(inf->objv[i], &len); - } - argv[argc] = (char *)NULL; - } -#endif - - DUMP1("reset result of tcl-interp"); - Tcl_ResetResult(inf->ptr->ip); - - /* Invoke the C procedure */ -#if TCL_MAJOR_VERSION == 8 - /* Tcl/Tk 8.0 -- 8.5 */ - if (inf->cmdinfo.isNativeObjectProc) { - DUMP1("call tcl_proc as a native-obj-proc"); - inf->ptr->return_value - = (*(inf->cmdinfo.objProc))(inf->cmdinfo.objClientData, - inf->ptr->ip, inf->objc, inf->objv); - } - else -#endif - { -#if TCL_MAJOR_VERSION == 8 - /* Tcl/Tk 8.0 -- 8.5 */ - DUMP1("call tcl_proc as not a native-obj-proc"); - inf->ptr->return_value - = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip, - argc, (CONST84 char **)argv); - -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#else - /* free(argv); */ - ckfree((char*)argv); -#endif -#endif - -#else /* TCL_MAJOR_VERSION < 8 */ - inf->ptr->return_value - = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip, - inf->argc, inf->argv); -#endif - } - -#endif /* Tcl/Tk 8.6 or later || Tcl 7.x, 8.0 -- 8.5 */ - - DUMP1("end of invoke_tcl_proc"); - return Qnil; -} - - -#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; - Tcl_CmdInfo info; - char *cmd; - int len; - int thr_crit_bup; - int unknown_flag = 0; - -#if 1 /* wrap tcl-proc call */ - struct invoke_info inf; - int status; -#else -#if TCL_MAJOR_VERSION >= 8 - int argc = objc; - char **argv = (char **)NULL; - /* Tcl_Obj *resultPtr; */ -#endif -#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 (deleted_ip(ptr)) { - return rb_tainted_str_new2(""); - } - - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - - /* 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"); - DUMP1("try auto_load (call 'unknown' command)"); - if (!Tcl_GetCommandInfo(ptr->ip, -#if TCL_MAJOR_VERSION >= 8 - "::unknown", -#else - "unknown", -#endif - &info)) { - DUMP1("fail to get 'unknown' command"); - /* if (event_loop_abort_on_exc || cmd[0] != '.') { */ - if (event_loop_abort_on_exc > 0) { - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - /*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); - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - return rb_tainted_str_new2(""); - } - } else { -#if TCL_MAJOR_VERSION >= 8 - Tcl_Obj **unknown_objv; -#else - char **unknown_argv; -#endif - DUMP1("find 'unknown' command -> set arguments"); - unknown_flag = 1; - -#if TCL_MAJOR_VERSION >= 8 - /* unknown_objv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, objc+2); */ - unknown_objv = RbTk_ALLOC_N(Tcl_Obj *, (objc+2)); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)unknown_objv); /* XXXXXXXX */ -#endif - unknown_objv[0] = Tcl_NewStringObj("::unknown", 9); - Tcl_IncrRefCount(unknown_objv[0]); - memcpy(unknown_objv + 1, objv, sizeof(Tcl_Obj *)*objc); - unknown_objv[++objc] = (Tcl_Obj*)NULL; - objv = unknown_objv; -#else - /* unknown_argv = (char **)ALLOC_N(char *, argc+2); */ - unknown_argv = RbTk_ALLOC_N(char *, (argc+2)); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)unknown_argv); /* XXXXXXXX */ -#endif - unknown_argv[0] = strdup("unknown"); - memcpy(unknown_argv + 1, argv, sizeof(char *)*argc); - unknown_argv[++argc] = (char *)NULL; - argv = unknown_argv; -#endif - } - } - DUMP1("end Tcl_GetCommandInfo"); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - -#if 1 /* wrap tcl-proc call */ - /* setup params */ - inf.ptr = ptr; - inf.cmdinfo = info; -#if TCL_MAJOR_VERSION >= 8 - inf.objc = objc; - inf.objv = objv; -#else - inf.argc = argc; - inf.argv = argv; -#endif - - /* invoke tcl-proc */ - DUMP1("invoke tcl-proc"); - rb_protect(invoke_tcl_proc, (VALUE)&inf, &status); - DUMP2("status of tcl-proc, %d", status); - switch(status) { - case TAG_RAISE: - if (NIL_P(rb_errinfo())) { - rbtk_pending_exception = rb_exc_new2(rb_eException, - "unknown exception"); - } else { - rbtk_pending_exception = rb_errinfo(); - } - break; - - case TAG_FATAL: - if (NIL_P(rb_errinfo())) { - rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL"); - } else { - rbtk_pending_exception = rb_errinfo(); - } - } - -#else /* !wrap tcl-proc call */ - - /* memory allocation for arguments of this command */ -#if TCL_MAJOR_VERSION >= 8 - if (!info.isNativeObjectProc) { - int i; - - /* string interface */ - /* argv = (char **)ALLOC_N(char *, argc+1); */ - argv = RbTk_ALLOC_N(char *, (argc+1)); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ -#endif - 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); - -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#else - /* free(argv); */ - ckfree((char*)argv); -#endif -#endif - -#else /* TCL_MAJOR_VERSION < 8 */ - ptr->return_value = (*info.proc)(info.clientData, ptr->ip, - argc, argv); -#endif - } -#endif /* ! wrap tcl-proc call */ - - /* free allocated memory for calling 'unknown' command */ - if (unknown_flag) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[0]); -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)objv, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)objv); /* XXXXXXXX */ -#else - /* free(objv); */ - ckfree((char*)objv); -#endif -#endif -#else /* TCL_MAJOR_VERSION < 8 */ - free(argv[0]); - /* ckfree(argv[0]); */ -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)argv); /* XXXXXXXX */ -#else - /* free(argv); */ - ckfree((char*)argv); -#endif -#endif -#endif - } - - /* exception on mainloop */ - if (pending_exception_check1(thr_crit_bup, ptr)) { - return rbtk_pending_exception; - } - - rb_thread_critical = thr_crit_bup; - - /* if (ptr->return_value == TCL_ERROR) { */ - if (ptr->return_value != TCL_OK) { - if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) { - switch (ptr->return_value) { - case TCL_RETURN: - return create_ip_exc(interp, eTkCallbackReturn, - "ip_invoke_core receives TCL_RETURN"); - case TCL_BREAK: - return create_ip_exc(interp, eTkCallbackBreak, - "ip_invoke_core receives TCL_BREAK"); - case TCL_CONTINUE: - return create_ip_exc(interp, eTkCallbackContinue, - "ip_invoke_core receives TCL_CONTINUE"); - default: - return create_ip_exc(interp, rb_eRuntimeError, "%s", - Tcl_GetStringResult(ptr->ip)); - } - - } else { - if (event_loop_abort_on_exc < 0) { - rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip)); - } else { - rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip)); - } - 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; - int thr_crit_bup; - -#if TCL_MAJOR_VERSION >= 8 - Tcl_Obj **av; -#else /* TCL_MAJOR_VERSION < 8 */ - char **av; -#endif - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* memory allocation */ -#if TCL_MAJOR_VERSION >= 8 - /* av = ALLOC_N(Tcl_Obj *, argc+1);*/ /* XXXXXXXXXX */ - av = RbTk_ALLOC_N(Tcl_Obj *, (argc+1)); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)av); /* XXXXXXXX */ -#endif - for (i = 0; i < argc; ++i) { - av[i] = get_obj_from_str(argv[i]); - Tcl_IncrRefCount(av[i]); - } - av[argc] = NULL; - -#else /* TCL_MAJOR_VERSION < 8 */ - /* string interface */ - /* av = ALLOC_N(char *, argc+1); */ - av = RbTk_ALLOC_N(char *, (argc+1)); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)av); /* XXXXXXXX */ -#endif - for (i = 0; i < argc; ++i) { - av[i] = strdup(StringValueCStr(argv[i])); - } - av[argc] = 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]); - av[i] = (Tcl_Obj*)NULL; -#else /* TCL_MAJOR_VERSION < 8 */ - free(av[i]); - av[i] = (char*)NULL; -#endif - } -#if TCL_MAJOR_VERSION >= 8 -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)av); /* XXXXXXXX */ -#else - ckfree((char*)av); -#endif -#endif -#else /* TCL_MAJOR_VERSION < 8 */ -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)av); /* XXXXXXXX */ -#else - /* free(av); */ - ckfree((char*)av); -#endif -#endif -#endif -} - -static VALUE -ip_invoke_real(argc, argv, interp) - int argc; - VALUE *argv; - VALUE interp; -{ - VALUE v; - struct tcltkip *ptr; /* tcltkip data struct */ - -#if TCL_MAJOR_VERSION >= 8 - Tcl_Obj **av = (Tcl_Obj **)NULL; -#else /* TCL_MAJOR_VERSION < 8 */ - char **av = (char **)NULL; -#endif - - DUMP2("invoke_real called by thread:%"PRIxVALUE, rb_thread_current()); - - /* get the data struct */ - ptr = get_ip(interp); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return rb_tainted_str_new2(""); - } - - /* allocate memory for arguments */ - av = alloc_invoke_arguments(argc, argv); - - /* 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; - volatile VALUE thread = q->thread; - struct tcltkip *ptr; - - DUMP2("do_invoke_queue_handler : evPtr = %p", evPtr); - DUMP2("invoke queue_thread : %"PRIxVALUE, rb_thread_current()); - DUMP2("added by thread : %"PRIxVALUE, thread); - - if (*(q->done)) { - DUMP1("processed by another event-loop"); - return 0; - } else { - DUMP1("process it on current event-loop"); - } - - if (RTEST(rb_thread_alive_p(thread)) - && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { - DUMP1("caller is not yet ready to receive the result -> pending"); - return 0; - } - - /* process it */ - *(q->done) = 1; - - /* deleted ipterp ? */ - ptr = get_ip(q->interp); - if (deleted_ip(ptr)) { - /* deleted IP --> ignore */ - return 1; - } - - /* incr internal handler mark */ - rbtk_internal_eventloop_handler++; - - /* 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(0,invoke_queue_mark,-1,q); - ret = rb_funcall(rb_proc_new(ivq_safelevel_handler, q_dat), - ID_call, 0); - rb_gc_force_recycle(q_dat); - q_dat = (VALUE)NULL; - } else { - DUMP2("call invoke_real (for caller thread:%"PRIxVALUE")", thread); - DUMP2("call invoke_real (current thread:%"PRIxVALUE")", rb_thread_current()); - ret = ip_invoke_core(q->interp, q->argc, q->argv); - } - - /* set result */ - RARRAY_ASET(q->result, 0, ret); - ret = (VALUE)NULL; - - /* decr internal handler mark */ - rbtk_internal_eventloop_handler--; - - /* complete */ - *(q->done) = -1; - - /* unlink ruby objects */ - q->interp = (VALUE)NULL; - q->result = (VALUE)NULL; - q->thread = (VALUE)NULL; - - /* back to caller */ - if (RTEST(rb_thread_alive_p(thread))) { - DUMP2("back to caller (caller thread:%"PRIxVALUE")", thread); - DUMP2(" (current thread:%"PRIxVALUE")", rb_thread_current()); -#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE - have_rb_thread_waiting_for_value = 1; - rb_thread_wakeup(thread); -#else - rb_thread_run(thread); -#endif - DUMP1("finish back to caller"); -#if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE - rb_thread_schedule(); -#endif - } else { - DUMP2("caller is dead (caller thread:%"PRIxVALUE")", thread); - DUMP2(" (current thread:%"PRIxVALUE")", rb_thread_current()); - } - - /* 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; -#ifdef RUBY_USE_NATIVE_THREAD - struct tcltkip *ptr; -#endif - int *alloc_done; - int thr_crit_bup; - volatile VALUE current = rb_thread_current(); - volatile VALUE ip_obj = obj; - volatile VALUE result; - volatile VALUE ret; - struct timeval t; - -#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"); - } - -#ifdef RUBY_USE_NATIVE_THREAD - ptr = get_ip(ip_obj); - DUMP2("invoke status: ptr->tk_thread_id %p", ptr->tk_thread_id); - DUMP2("invoke status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread()); -#else - DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread()); -#endif - DUMP2("status: eventloopt_thread %"PRIxVALUE, eventloop_thread); - - if ( -#ifdef RUBY_USE_NATIVE_THREAD - (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread()) - && -#endif - (NIL_P(eventloop_thread) || current == eventloop_thread) - ) { - if (NIL_P(eventloop_thread)) { - DUMP2("invoke from thread:%"PRIxVALUE" but no eventloop", current); - } else { - DUMP2("invoke from current eventloop %"PRIxVALUE, 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 %"PRIxVALUE" (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 = RbTk_ALLOC_N(int, 1); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */ -#endif - *alloc_done = 0; - - /* allocate memory (freed by Tcl_ServiceEvent) */ - /* ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); */ - ivq = RbTk_ALLOC_N(struct invoke_queue, 1); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)ivq); /* XXXXXXXX */ -#endif - - /* allocate result obj */ - result = rb_ary_new3(1, Qnil); - - /* 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"); -#ifdef RUBY_USE_NATIVE_THREAD - if (ptr->tk_thread_id) { - /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(ivq->ev), position); */ - Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)ivq, position); - Tcl_ThreadAlert(ptr->tk_thread_id); - } else if (tk_eventloop_thread_id) { - /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id, - &(ivq->ev), position); */ - Tcl_ThreadQueueEvent(tk_eventloop_thread_id, - (Tcl_Event*)ivq, position); - Tcl_ThreadAlert(tk_eventloop_thread_id); - } else { - /* Tcl_QueueEvent(&(ivq->ev), position); */ - Tcl_QueueEvent((Tcl_Event*)ivq, position); - } -#else - /* Tcl_QueueEvent(&(ivq->ev), position); */ - Tcl_QueueEvent((Tcl_Event*)ivq, position); -#endif - - rb_thread_critical = thr_crit_bup; - - /* wait for the handler to be processed */ - t.tv_sec = 0; - t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); - - DUMP2("ivq wait for handler (current thread:%"PRIxVALUE")", current); - while(*alloc_done >= 0) { - /* rb_thread_stop(); */ - /* rb_thread_sleep_forever(); */ - rb_thread_wait_for(t); - DUMP2("*** ivq wakeup (current thread:%"PRIxVALUE")", current); - DUMP2("*** (eventloop thread:%"PRIxVALUE")", eventloop_thread); - if (NIL_P(eventloop_thread)) { - DUMP1("*** ivq lost eventloop thread"); - break; - } - } - DUMP2("back from handler (current thread:%"PRIxVALUE")", current); - - /* get result & free allocated memory */ - ret = RARRAY_AREF(result, 0); -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */ -#else - /* free(alloc_done); */ - ckfree((char*)alloc_done); -#endif -#endif - -#if 0 /* ivq is freed by Tcl_ServiceEvent */ -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)ivq, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release(ivq); -#else - ckfree((char*)ivq); -#endif -#endif -#endif - - /* 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); */ - rb_exc_raise(rb_exc_new3(rb_obj_class(ret), - rb_funcallv(ret, ID_to_s, 0, 0))); - } - - 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 (deleted_ip(ptr)) { - 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; -{ - /* POTENTIALY INSECURE : can create infinite loop */ - return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_HEAD); -} - - -/* access Tcl variables */ -static VALUE -ip_get_variable2_core(interp, argc, argv) - VALUE interp; - int argc; - VALUE *argv; -{ - struct tcltkip *ptr = get_ip(interp); - int thr_crit_bup; - volatile VALUE varname, index, flag; - - varname = argv[0]; - index = argv[1]; - flag = argv[2]; - - /* - StringValue(varname); - if (!NIL_P(index)) StringValue(index); - */ - -#if TCL_MAJOR_VERSION >= 8 - { - Tcl_Obj *ret; - volatile VALUE strval; - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_thread_critical = thr_crit_bup; - return rb_tainted_str_new2(""); - } else { - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - ret = Tcl_GetVar2Ex(ptr->ip, RSTRING_PTR(varname), - NIL_P(index) ? NULL : RSTRING_PTR(index), - FIX2INT(flag)); - } - - if (ret == (Tcl_Obj*)NULL) { - volatile VALUE exc; - /* exc = rb_exc_new2(rb_eRuntimeError, - Tcl_GetStringResult(ptr->ip)); */ - exc = create_ip_exc(interp, rb_eRuntimeError, "%s", - Tcl_GetStringResult(ptr->ip)); - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return exc; - } - - Tcl_IncrRefCount(ret); - strval = get_str_from_obj(ret); - RbTk_OBJ_UNTRUST(strval); - Tcl_DecrRefCount(ret); - - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return(strval); - } -#else /* TCL_MAJOR_VERSION < 8 */ - { - char *ret; - volatile VALUE strval; - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return rb_tainted_str_new2(""); - } else { - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - ret = Tcl_GetVar2(ptr->ip, RSTRING_PTR(varname), - NIL_P(index) ? NULL : RSTRING_PTR(index), - FIX2INT(flag)); - } - - if (ret == (char*)NULL) { - volatile VALUE exc; - exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return 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, index, flag) - VALUE self; - VALUE varname; - VALUE index; - VALUE flag; -{ - VALUE argv[3]; - VALUE retval; - - StringValue(varname); - if (!NIL_P(index)) StringValue(index); - - argv[0] = varname; - argv[1] = index; - argv[2] = flag; - - retval = tk_funcall(ip_get_variable2_core, 3, argv, self); - - if (NIL_P(retval)) { - return rb_tainted_str_new2(""); - } else { - return retval; - } -} - -static VALUE -ip_get_variable(self, varname, flag) - VALUE self; - VALUE varname; - VALUE flag; -{ - return ip_get_variable2(self, varname, Qnil, flag); -} - -static VALUE -ip_set_variable2_core(interp, argc, argv) - VALUE interp; - int argc; - VALUE *argv; -{ - struct tcltkip *ptr = get_ip(interp); - int thr_crit_bup; - volatile VALUE varname, index, value, flag; - - varname = argv[0]; - index = argv[1]; - value = argv[2]; - flag = argv[3]; - - /* - StringValue(varname); - if (!NIL_P(index)) StringValue(index); - StringValue(value); - */ - -#if TCL_MAJOR_VERSION >= 8 - { - Tcl_Obj *valobj, *ret; - volatile VALUE strval; - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - valobj = get_obj_from_str(value); - Tcl_IncrRefCount(valobj); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - 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_SetVar2Ex(ptr->ip, RSTRING_PTR(varname), - NIL_P(index) ? NULL : RSTRING_PTR(index), - valobj, FIX2INT(flag)); - } - - Tcl_DecrRefCount(valobj); - - if (ret == (Tcl_Obj*)NULL) { - volatile VALUE exc; - /* exc = rb_exc_new2(rb_eRuntimeError, - Tcl_GetStringResult(ptr->ip)); */ - exc = create_ip_exc(interp, rb_eRuntimeError, "%s", - Tcl_GetStringResult(ptr->ip)); - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return exc; - } - - Tcl_IncrRefCount(ret); - strval = get_str_from_obj(ret); - RbTk_OBJ_UNTRUST(strval); - 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; - volatile VALUE strval; - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return rb_tainted_str_new2(""); - } else { - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - ret = Tcl_SetVar2(ptr->ip, RSTRING_PTR(varname), - NIL_P(index) ? NULL : RSTRING_PTR(index), - RSTRING_PTR(value), FIX2INT(flag)); - } - - if (ret == (char*)NULL) { - return rb_exc_new2(rb_eRuntimeError, 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, index, value, flag) - VALUE self; - VALUE varname; - VALUE index; - VALUE value; - VALUE flag; -{ - VALUE argv[4]; - VALUE retval; - - StringValue(varname); - if (!NIL_P(index)) StringValue(index); - StringValue(value); - - argv[0] = varname; - argv[1] = index; - argv[2] = value; - argv[3] = flag; - - retval = tk_funcall(ip_set_variable2_core, 4, argv, self); - - if (NIL_P(retval)) { - return rb_tainted_str_new2(""); - } else { - return retval; - } -} - -static VALUE -ip_set_variable(self, varname, value, flag) - VALUE self; - VALUE varname; - VALUE value; - VALUE flag; -{ - return ip_set_variable2(self, varname, Qnil, value, flag); -} - -static VALUE -ip_unset_variable2_core(interp, argc, argv) - VALUE interp; - int argc; - VALUE *argv; -{ - struct tcltkip *ptr = get_ip(interp); - volatile VALUE varname, index, flag; - - varname = argv[0]; - index = argv[1]; - flag = argv[2]; - - /* - StringValue(varname); - if (!NIL_P(index)) StringValue(index); - */ - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return Qtrue; - } - - ptr->return_value = Tcl_UnsetVar2(ptr->ip, RSTRING_PTR(varname), - NIL_P(index) ? NULL : RSTRING_PTR(index), - FIX2INT(flag)); - - if (ptr->return_value == TCL_ERROR) { - if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) { - /* return rb_exc_new2(rb_eRuntimeError, - Tcl_GetStringResult(ptr->ip)); */ - return create_ip_exc(interp, rb_eRuntimeError, "%s", - Tcl_GetStringResult(ptr->ip)); - } - return Qfalse; - } - return Qtrue; -} - -static VALUE -ip_unset_variable2(self, varname, index, flag) - VALUE self; - VALUE varname; - VALUE index; - VALUE flag; -{ - VALUE argv[3]; - VALUE retval; - - StringValue(varname); - if (!NIL_P(index)) StringValue(index); - - argv[0] = varname; - argv[1] = index; - argv[2] = flag; - - retval = tk_funcall(ip_unset_variable2_core, 3, argv, self); - - if (NIL_P(retval)) { - return rb_tainted_str_new2(""); - } else { - return retval; - } -} - -static VALUE -ip_unset_variable(self, varname, flag) - VALUE self; - VALUE varname; - VALUE flag; -{ - return ip_unset_variable2(self, varname, Qnil, flag); -} - -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); -#ifdef HAVE_RUBY_ENCODING_H - int list_enc_idx; - volatile VALUE list_ivar_enc; -#endif - int result; - VALUE old_gc; - - tcl_stubs_check(); - - if (NIL_P(ip_obj)) { - interp = (Tcl_Interp *)NULL; - } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) { - interp = (Tcl_Interp *)NULL; - } else { - interp = get_ip(ip_obj)->ip; - } - - StringValue(list_str); -#ifdef HAVE_RUBY_ENCODING_H - list_enc_idx = rb_enc_get_index(list_str); - list_ivar_enc = rb_ivar_get(list_str, ID_at_enc); -#endif - - { -#if TCL_MAJOR_VERSION >= 8 - /* object style interface */ - Tcl_Obj *listobj; - int objc; - Tcl_Obj **objv; - int thr_crit_bup; - - listobj = get_obj_from_str(list_str); - - 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, "can't get elements from list"); - } else { - rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(interp)); - } - } - - 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) RbTk_OBJ_UNTRUST(ary); - - old_gc = rb_gc_disable(); - - for(idx = 0; idx < objc; idx++) { - elem = get_str_from_obj(objv[idx]); - if (taint_flag) RbTk_OBJ_UNTRUST(elem); - -#ifdef HAVE_RUBY_ENCODING_H - if (rb_enc_get_index(elem) == ENCODING_INDEX_BINARY) { - rb_enc_associate_index(elem, ENCODING_INDEX_BINARY); - rb_ivar_set(elem, ID_at_enc, ENCODING_NAME_BINARY); - } else { - rb_enc_associate_index(elem, list_enc_idx); - rb_ivar_set(elem, ID_at_enc, list_ivar_enc); - } -#endif - /* RARRAY(ary)->ptr[idx] = elem; */ - rb_ary_push(ary, 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_PTR(list_str), - &argc, &argv) == TCL_ERROR) { - if (interp == (Tcl_Interp*)NULL) { - rb_raise(rb_eRuntimeError, "can't get elements from list"); - } else { - rb_raise(rb_eRuntimeError, "%s", interp->result); - } - } - - ary = rb_ary_new2(argc); - if (taint_flag) RbTk_OBJ_UNTRUST(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; */ - rb_ary_push(ary, 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(""); - - tcl_stubs_check(); - - 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); */ - flagPtr = RbTk_ALLOC_N(int, argc); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)flagPtr); /* XXXXXXXXXX */ -#endif - - /* pass 1 */ - len = 1; - for(num = 0; num < argc; num++) { - if (OBJ_TAINTED(argv[num])) taint_flag = 1; - dst = StringValueCStr(argv[num]); -#if TCL_MAJOR_VERSION >= 8 - len += Tcl_ScanCountedElement(dst, RSTRING_LENINT(argv[num]), - &flagPtr[num]) + 1; -#else /* TCL_MAJOR_VERSION < 8 */ - len += Tcl_ScanElement(dst, &flagPtr[num]) + 1; -#endif - } - - /* pass 2 */ - /* result = (char *)Tcl_Alloc(len); */ - result = (char *)ckalloc(len); -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Preserve((ClientData)result); -#endif - dst = result; - for(num = 0; num < argc; num++) { -#if TCL_MAJOR_VERSION >= 8 - len = Tcl_ConvertCountedElement(RSTRING_PTR(argv[num]), - RSTRING_LENINT(argv[num]), - dst, flagPtr[num]); -#else /* TCL_MAJOR_VERSION < 8 */ - len = Tcl_ConvertElement(RSTRING_PTR(argv[num]), dst, flagPtr[num]); -#endif - dst += len; - *dst = ' '; - dst++; - } - if (dst == result) { - *dst = 0; - } else { - dst[-1] = 0; - } - -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)flagPtr, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)flagPtr); -#else - /* free(flagPtr); */ - ckfree((char*)flagPtr); -#endif -#endif - - /* create object */ - str = rb_str_new(result, dst - result - 1); - if (taint_flag) RbTk_OBJ_UNTRUST(str); -#if 0 /* use Tcl_EventuallyFree */ - Tcl_EventuallyFree((ClientData)result, TCL_DYNAMIC); /* XXXXXXXX */ -#else -#if 0 /* use Tcl_Preserve/Release */ - Tcl_Release((ClientData)result); /* XXXXXXXXXXX */ -#else - /* Tcl_Free(result); */ - ckfree(result); -#endif -#endif - - 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; - - tcl_stubs_check(); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - StringValue(src); - -#if TCL_MAJOR_VERSION >= 8 - len = Tcl_ScanCountedElement(RSTRING_PTR(src), RSTRING_LENINT(src), - &scan_flag); - dst = rb_str_new(0, len + 1); - len = Tcl_ConvertCountedElement(RSTRING_PTR(src), RSTRING_LENINT(src), - RSTRING_PTR(dst), scan_flag); -#else /* TCL_MAJOR_VERSION < 8 */ - len = Tcl_ScanElement(RSTRING_PTR(src), &scan_flag); - dst = rb_str_new(0, len + 1); - len = Tcl_ConvertElement(RSTRING_PTR(src), RSTRING_PTR(dst), scan_flag); -#endif - - rb_str_resize(dst, len); - if (taint_flag) RbTk_OBJ_UNTRUST(dst); - - rb_thread_critical = thr_crit_bup; - - return dst; -} - -static VALUE -lib_getversion(self) - VALUE self; -{ - set_tcltk_version(); - - return rb_ary_new3(4, INT2NUM(tcltk_version.major), - INT2NUM(tcltk_version.minor), - INT2NUM(tcltk_version.type), - INT2NUM(tcltk_version.patchlevel)); -} - -static VALUE -lib_get_reltype_name(self) - VALUE self; -{ - set_tcltk_version(); - - switch(tcltk_version.type) { - case TCL_ALPHA_RELEASE: - return rb_str_new2("alpha"); - case TCL_BETA_RELEASE: - return rb_str_new2("beta"); - case TCL_FINAL_RELEASE: - return rb_str_new2("final"); - default: - rb_raise(rb_eRuntimeError, "tcltklib has invalid release type number"); - } - - UNREACHABLE; -} - - -static VALUE -tcltklib_compile_info(void) -{ - VALUE ret; - static const char info[] = - "tcltklib " TCLTKLIB_RELEASE_DATE " " - ":: Ruby" -#ifdef RUBY_API_VERSION_MAJOR - STRINGIZE(RUBY_API_VERSION_MAJOR)"." - STRINGIZE(RUBY_API_VERSION_MINOR)"." - STRINGIZE(RUBY_API_VERSION_TEENY)" " -#else - RUBY_VERSION" " -#endif -#ifdef RUBY_RELEASE_DATE - "("RUBY_RELEASE_DATE") " -#endif -#ifdef HAVE_NATIVETHREAD - "with" -#else - "without" -#endif - " pthread " - ":: Tcl" TCL_PATCH_LEVEL "(" -#ifdef USE_TCL_STUBS - "with" -#else - "without" -#endif - " stub)" - "/" - "Tk" TK_PATCH_LEVEL "(" -#ifdef USE_TK_STUBS - "with" -#else - "without" -#endif - " stub) " -#ifdef WITH_TCL_ENABLE_THREAD -# if WITH_TCL_ENABLE_THREAD - "with" -# else - "without" -# endif -#else - "unknown" -#endif - " tcl_threads"; - ret = rb_obj_freeze(rb_str_new2(info)); - - return ret; -} - - -/*###############################################*/ - -static VALUE -create_dummy_encoding_for_tk_core(interp, name, error_mode) - VALUE interp; - VALUE name; - VALUE error_mode; -{ - get_ip(interp); - - - StringValue(name); - -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) - if (Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(name)) == (Tcl_Encoding)NULL) { - if (RTEST(error_mode)) { - rb_raise(rb_eArgError, "invalid Tk encoding name '%s'", - RSTRING_PTR(name)); - } else { - return Qnil; - } - } -#endif - -#ifdef HAVE_RUBY_ENCODING_H - if (RTEST(rb_define_dummy_encoding(RSTRING_PTR(name)))) { - int idx = rb_enc_find_index(StringValueCStr(name)); - return rb_enc_from_encoding(rb_enc_from_index(idx)); - } else { - if (RTEST(error_mode)) { - rb_raise(rb_eRuntimeError, "fail to create dummy encoding for '%s'", - RSTRING_PTR(name)); - } else { - return Qnil; - } - } - - UNREACHABLE; -#else - return name; -#endif -} -static VALUE -create_dummy_encoding_for_tk(interp, name) - VALUE interp; - VALUE name; -{ - return create_dummy_encoding_for_tk_core(interp, name, Qtrue); -} - - -#ifdef HAVE_RUBY_ENCODING_H -static int -update_encoding_table(table, interp, error_mode) - VALUE table; - VALUE interp; - VALUE error_mode; -{ - struct tcltkip *ptr; - int retry = 0; - int i, idx, objc; - Tcl_Obj **objv; - Tcl_Obj *enc_list; - volatile VALUE encname = Qnil; - volatile VALUE encobj = Qnil; - - /* interpreter check */ - if (NIL_P(interp)) return 0; - ptr = get_ip(interp); - if (ptr == (struct tcltkip *) NULL) return 0; - if (deleted_ip(ptr)) return 0; - - /* get Tcl's encoding list */ - Tcl_GetEncodingNames(ptr->ip); - enc_list = Tcl_GetObjResult(ptr->ip); - Tcl_IncrRefCount(enc_list); - - if (Tcl_ListObjGetElements(ptr->ip, enc_list, - &objc, &objv) != TCL_OK) { - Tcl_DecrRefCount(enc_list); - /* rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");*/ - return 0; - } - - /* check each encoding name */ - for(i = 0; i < objc; i++) { - encname = rb_str_new2(Tcl_GetString(objv[i])); - if (NIL_P(rb_hash_lookup(table, encname))) { - /* new Tk encoding -> add to table */ - idx = rb_enc_find_index(StringValueCStr(encname)); - if (idx < 0) { - encobj = create_dummy_encoding_for_tk_core(interp,encname,error_mode); - } else { - encobj = rb_enc_from_encoding(rb_enc_from_index(idx)); - } - encname = rb_obj_freeze(encname); - rb_hash_aset(table, encname, encobj); - if (!NIL_P(encobj) && NIL_P(rb_hash_lookup(table, encobj))) { - rb_hash_aset(table, encobj, encname); - } - retry = 1; - } - } - - Tcl_DecrRefCount(enc_list); - - return retry; -} - -static VALUE -encoding_table_get_name_core(table, enc_arg, error_mode) - VALUE table; - VALUE enc_arg; - VALUE error_mode; -{ - volatile VALUE enc = enc_arg; - volatile VALUE name = Qnil; - volatile VALUE tmp = Qnil; - volatile VALUE interp = rb_ivar_get(table, ID_at_interp); - struct tcltkip *ptr = (struct tcltkip *) NULL; - int idx; - - /* deleted interp ? */ - if (!NIL_P(interp)) { - ptr = get_ip(interp); - if (deleted_ip(ptr)) { - ptr = (struct tcltkip *) NULL; - } - } - - /* encoding argument check */ - /* 1st: default encoding setting of interp */ - if (ptr && NIL_P(enc)) { - if (rb_respond_to(interp, ID_encoding_name)) { - enc = rb_funcallv(interp, ID_encoding_name, 0, 0); - } - } - /* 2nd: Encoding.default_internal */ - if (NIL_P(enc)) { - enc = rb_enc_default_internal(); - } - /* 3rd: encoding system of Tcl/Tk */ - if (NIL_P(enc)) { - enc = rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL)); - } - /* 4th: Encoding.default_external */ - if (NIL_P(enc)) { - enc = rb_enc_default_external(); - } - /* 5th: Encoding.locale_charmap */ - if (NIL_P(enc)) { - enc = rb_locale_charmap(rb_cEncoding); - } - - if (RTEST(rb_obj_is_kind_of(enc, cRubyEncoding))) { - /* Ruby's Encoding object */ - name = rb_hash_lookup(table, enc); - if (!NIL_P(name)) { - /* find */ - return name; - } - - /* is it new ? */ - /* update check of Tk encoding names */ - if (update_encoding_table(table, interp, error_mode)) { - /* add new relations to the table */ - /* RETRY: registered Ruby encoding? */ - name = rb_hash_lookup(table, enc); - if (!NIL_P(name)) { - /* find */ - return name; - } - } - /* fail to find */ - - } else { - /* String or Symbol? */ - name = rb_funcallv(enc, ID_to_s, 0, 0); - - if (!NIL_P(rb_hash_lookup(table, name))) { - /* find */ - return name; - } - - /* is it new ? */ - idx = rb_enc_find_index(StringValueCStr(name)); - if (idx >= 0) { - enc = rb_enc_from_encoding(rb_enc_from_index(idx)); - - /* registered Ruby encoding? */ - tmp = rb_hash_lookup(table, enc); - if (!NIL_P(tmp)) { - /* find */ - return tmp; - } - - /* update check of Tk encoding names */ - if (update_encoding_table(table, interp, error_mode)) { - /* add new relations to the table */ - /* RETRY: registered Ruby encoding? */ - tmp = rb_hash_lookup(table, enc); - if (!NIL_P(tmp)) { - /* find */ - return tmp; - } - } - } - /* fail to find */ - } - - if (RTEST(error_mode)) { - enc = rb_funcallv(enc_arg, ID_to_s, 0, 0); - rb_raise(rb_eArgError, "unsupported Tk encoding '%s'", RSTRING_PTR(enc)); - } - return Qnil; -} -static VALUE -encoding_table_get_obj_core(table, enc, error_mode) - VALUE table; - VALUE enc; - VALUE error_mode; -{ - volatile VALUE obj = Qnil; - - obj = rb_hash_lookup(table, - encoding_table_get_name_core(table, enc, error_mode)); - if (RTEST(rb_obj_is_kind_of(obj, cRubyEncoding))) { - return obj; - } else { - return Qnil; - } -} - -#else /* ! HAVE_RUBY_ENCODING_H */ -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) -static int -update_encoding_table(table, interp, error_mode) - VALUE table; - VALUE interp; - VALUE error_mode; -{ - struct tcltkip *ptr; - int retry = 0; - int i, objc; - Tcl_Obj **objv; - Tcl_Obj *enc_list; - volatile VALUE encname = Qnil; - - /* interpreter check */ - if (NIL_P(interp)) return 0; - ptr = get_ip(interp); - if (ptr == (struct tcltkip *) NULL) return 0; - if (deleted_ip(ptr)) return 0; - - /* get Tcl's encoding list */ - Tcl_GetEncodingNames(ptr->ip); - enc_list = Tcl_GetObjResult(ptr->ip); - Tcl_IncrRefCount(enc_list); - - if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) { - Tcl_DecrRefCount(enc_list); - /* rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names"); */ - return 0; - } - - /* get encoding name and set it to table */ - for(i = 0; i < objc; i++) { - encname = rb_str_new2(Tcl_GetString(objv[i])); - if (NIL_P(rb_hash_lookup(table, encname))) { - /* new Tk encoding -> add to table */ - encname = rb_obj_freeze(encname); - rb_hash_aset(table, encname, encname); - retry = 1; - } - } - - Tcl_DecrRefCount(enc_list); - - return retry; -} - -static VALUE -encoding_table_get_name_core(table, enc, error_mode) - VALUE table; - VALUE enc; - VALUE error_mode; -{ - volatile VALUE name = Qnil; - - enc = rb_funcallv(enc, ID_to_s, 0, 0); - name = rb_hash_lookup(table, enc); - - if (!NIL_P(name)) { - /* find */ - return name; - } - - /* update check */ - if (update_encoding_table(table, rb_ivar_get(table, ID_at_interp), - error_mode)) { - /* add new relations to the table */ - /* RETRY: registered Ruby encoding? */ - name = rb_hash_lookup(table, enc); - if (!NIL_P(name)) { - /* find */ - return name; - } - } - - if (RTEST(error_mode)) { - rb_raise(rb_eArgError, "unsupported Tk encoding '%s'", RSTRING_PTR(enc)); - } - return Qnil; -} -static VALUE -encoding_table_get_obj_core(table, enc, error_mode) - VALUE table; - VALUE enc; - VALUE error_mode; -{ - return encoding_table_get_name_core(table, enc, error_mode); -} - -#else /* Tcl/Tk 7.x or 8.0 */ -static VALUE -encoding_table_get_name_core(table, enc, error_mode) - VALUE table; - VALUE enc; - VALUE error_mode; -{ - return Qnil; -} -static VALUE -encoding_table_get_obj_core(table, enc, error_mode) - VALUE table; - VALUE enc; - VALUE error_mode; -{ - return Qnil; -} -#endif /* end of dependency for the version of Tcl/Tk */ -#endif - -static VALUE -encoding_table_get_name(table, enc) - VALUE table; - VALUE enc; -{ - return encoding_table_get_name_core(table, enc, Qtrue); -} -static VALUE -encoding_table_get_obj(table, enc) - VALUE table; - VALUE enc; -{ - return encoding_table_get_obj_core(table, enc, Qtrue); -} - -#ifdef HAVE_RUBY_ENCODING_H -static VALUE -create_encoding_table_core(arg, interp) - VALUE arg; - VALUE interp; -{ - struct tcltkip *ptr = get_ip(interp); - volatile VALUE table = rb_hash_new(); - volatile VALUE encname = Qnil; - volatile VALUE encobj = Qnil; - int i, idx, objc; - Tcl_Obj **objv; - Tcl_Obj *enc_list; - -#ifdef HAVE_RB_SET_SAFE_LEVEL_FORCE - rb_set_safe_level_force(0); -#else - rb_set_safe_level(0); -#endif - - /* set 'binary' encoding */ - encobj = rb_enc_from_encoding(rb_enc_from_index(ENCODING_INDEX_BINARY)); - rb_hash_aset(table, ENCODING_NAME_BINARY, encobj); - rb_hash_aset(table, encobj, ENCODING_NAME_BINARY); - - - /* Tcl stub check */ - tcl_stubs_check(); - - /* get Tcl's encoding list */ - Tcl_GetEncodingNames(ptr->ip); - enc_list = Tcl_GetObjResult(ptr->ip); - Tcl_IncrRefCount(enc_list); - - if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) { - Tcl_DecrRefCount(enc_list); - rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names"); - } - - /* get encoding name and set it to table */ - for(i = 0; i < objc; i++) { - int name2obj, obj2name; - - name2obj = 1; obj2name = 1; - encname = rb_obj_freeze(rb_str_new2(Tcl_GetString(objv[i]))); - idx = rb_enc_find_index(StringValueCStr(encname)); - if (idx < 0) { - /* fail to find ruby encoding -> check known encoding */ - if (strcmp(RSTRING_PTR(encname), "identity") == 0) { - name2obj = 1; obj2name = 0; - idx = ENCODING_INDEX_BINARY; - - } else if (strcmp(RSTRING_PTR(encname), "shiftjis") == 0) { - name2obj = 1; obj2name = 0; - idx = rb_enc_find_index("Shift_JIS"); - - } else if (strcmp(RSTRING_PTR(encname), "unicode") == 0) { - name2obj = 1; obj2name = 0; - idx = ENCODING_INDEX_UTF8; - - } else if (strcmp(RSTRING_PTR(encname), "symbol") == 0) { - name2obj = 1; obj2name = 0; - idx = rb_enc_find_index("ASCII-8BIT"); - - } else { - /* regist dummy encoding */ - name2obj = 1; obj2name = 1; - } - } - - if (idx < 0) { - /* unknown encoding -> create dummy */ - encobj = create_dummy_encoding_for_tk(interp, encname); - } else { - encobj = rb_enc_from_encoding(rb_enc_from_index(idx)); - } - - if (name2obj) { - DUMP2("create_encoding_table: name2obj: %s", RSTRING_PTR(encname)); - rb_hash_aset(table, encname, encobj); - } - if (obj2name) { - DUMP2("create_encoding_table: obj2name: %s", RSTRING_PTR(encname)); - rb_hash_aset(table, encobj, encname); - } - } - - Tcl_DecrRefCount(enc_list); - - rb_ivar_set(table, ID_at_interp, interp); - rb_ivar_set(interp, ID_encoding_table, table); - - return table; -} - -#else /* ! HAVE_RUBY_ENCODING_H */ -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) -static VALUE -create_encoding_table_core(arg, interp) - VALUE arg; - VALUE interp; -{ - struct tcltkip *ptr = get_ip(interp); - volatile VALUE table = rb_hash_new(); - volatile VALUE encname = Qnil; - int i, objc; - Tcl_Obj **objv; - Tcl_Obj *enc_list; - - - /* set 'binary' encoding */ - rb_hash_aset(table, ENCODING_NAME_BINARY, ENCODING_NAME_BINARY); - - /* get Tcl's encoding list */ - Tcl_GetEncodingNames(ptr->ip); - enc_list = Tcl_GetObjResult(ptr->ip); - Tcl_IncrRefCount(enc_list); - - if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) { - Tcl_DecrRefCount(enc_list); - rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names"); - } - - /* get encoding name and set it to table */ - for(i = 0; i < objc; i++) { - encname = rb_obj_freeze(rb_str_new2(Tcl_GetString(objv[i]))); - rb_hash_aset(table, encname, encname); - } - - Tcl_DecrRefCount(enc_list); - - rb_ivar_set(table, ID_at_interp, interp); - rb_ivar_set(interp, ID_encoding_table, table); - - return table; -} - -#else /* Tcl/Tk 7.x or 8.0 */ -static VALUE -create_encoding_table_core(arg, interp) - VALUE arg; - VALUE interp; -{ - volatile VALUE table = rb_hash_new(); - rb_ivar_set(interp, ID_encoding_table, table); - return table; -} -#endif -#endif - -static VALUE -create_encoding_table(interp) - VALUE interp; -{ - return rb_funcall(rb_proc_new(create_encoding_table_core, interp), - ID_call, 0); -} - -static VALUE -ip_get_encoding_table(interp) - VALUE interp; -{ - volatile VALUE table = Qnil; - - table = rb_ivar_get(interp, ID_encoding_table); - - if (NIL_P(table)) { - /* initialize encoding_table */ - table = create_encoding_table(interp); - rb_define_singleton_method(table, "get_name", encoding_table_get_name, 1); - rb_define_singleton_method(table, "get_obj", encoding_table_get_obj, 1); - } - - return table; -} - - -/*###############################################*/ - -/* - * The following is based on tkMenu.[ch] - * of Tcl/Tk (Tk8.0 -- Tk8.5b1) source code. - */ -#if TCL_MAJOR_VERSION >= 8 - -#define MASTER_MENU 0 -#define TEAROFF_MENU 1 -#define MENUBAR 2 - -struct dummy_TkMenuEntry { - int type; - struct dummy_TkMenu *menuPtr; - /* , and etc. */ -}; - -struct dummy_TkMenu { - Tk_Window tkwin; - Display *display; - Tcl_Interp *interp; - Tcl_Command widgetCmd; - struct dummy_TkMenuEntry **entries; - int numEntries; - int active; - int menuType; /* MASTER_MENU, TEAROFF_MENU, or MENUBAR */ - Tcl_Obj *menuTypePtr; - /* , and etc. */ -}; - -struct dummy_TkMenuRef { - struct dummy_TkMenu *menuPtr; - char *dummy1; - char *dummy2; - char *dummy3; -}; - -#if 0 /* was available on Tk8.0 -- Tk8.4 */ -EXTERN struct dummy_TkMenuRef *TkFindMenuReferences(Tcl_Interp*, char*); -#else /* based on Tk8.0 -- Tk8.5.0 */ -#define MENU_HASH_KEY "tkMenus" -#endif - -#endif - -static VALUE -ip_make_menu_embeddable_core(interp, argc, argv) - VALUE interp; - int argc; - VALUE *argv; -{ -#if TCL_MAJOR_VERSION >= 8 - volatile VALUE menu_path; - struct tcltkip *ptr = get_ip(interp); - struct dummy_TkMenuRef *menuRefPtr = NULL; - XEvent event; - Tcl_HashTable *menuTablePtr; - Tcl_HashEntry *hashEntryPtr; - - menu_path = argv[0]; - StringValue(menu_path); - -#if 0 /* was available on Tk8.0 -- Tk8.4 */ - menuRefPtr = TkFindMenuReferences(ptr->ip, RSTRING_PTR(menu_path)); -#else /* based on Tk8.0 -- Tk8.5b1 */ - if ((menuTablePtr - = (Tcl_HashTable *) Tcl_GetAssocData(ptr->ip, MENU_HASH_KEY, NULL)) - != NULL) { - if ((hashEntryPtr - = Tcl_FindHashEntry(menuTablePtr, RSTRING_PTR(menu_path))) - != NULL) { - menuRefPtr = (struct dummy_TkMenuRef *) Tcl_GetHashValue(hashEntryPtr); - } - } -#endif - - if (menuRefPtr == (struct dummy_TkMenuRef *) NULL) { - rb_raise(rb_eArgError, "not a menu widget, or invalid widget path"); - } - - if (menuRefPtr->menuPtr == (struct dummy_TkMenu *) NULL) { - rb_raise(rb_eRuntimeError, - "invalid menu widget (maybe already destroyed)"); - } - - if ((menuRefPtr->menuPtr)->menuType != MENUBAR) { - rb_raise(rb_eRuntimeError, - "target menu widget must be a MENUBAR type"); - } - - (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU; -#if 0 /* cause SEGV */ - { - /* char *s = "tearoff"; */ - char *s = "normal"; - /* Tcl_SetStringObj((menuRefPtr->menuPtr)->menuTypePtr, s, strlen(s));*/ - (menuRefPtr->menuPtr)->menuTypePtr = Tcl_NewStringObj(s, strlen(s)); - /* Tcl_IncrRefCount((menuRefPtr->menuPtr)->menuTypePtr); */ - /* (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU; */ - (menuRefPtr->menuPtr)->menuType = MASTER_MENU; - } -#endif - -#if 0 /* was available on Tk8.0 -- Tk8.4 */ - TkEventuallyRecomputeMenu(menuRefPtr->menuPtr); - TkEventuallyRedrawMenu(menuRefPtr->menuPtr, - (struct dummy_TkMenuEntry *)NULL); -#else /* based on Tk8.0 -- Tk8.5b1 */ - memset((void *) &event, 0, sizeof(event)); - event.xany.type = ConfigureNotify; - event.xany.serial = NextRequest(Tk_Display((menuRefPtr->menuPtr)->tkwin)); - event.xany.send_event = 0; /* FALSE */ - event.xany.window = Tk_WindowId((menuRefPtr->menuPtr)->tkwin); - event.xany.display = Tk_Display((menuRefPtr->menuPtr)->tkwin); - event.xconfigure.window = event.xany.window; - Tk_HandleEvent(&event); -#endif - -#else /* TCL_MAJOR_VERSION <= 7 */ - rb_notimplement(); -#endif - - return interp; -} - -static VALUE -ip_make_menu_embeddable(interp, menu_path) - VALUE interp; - VALUE menu_path; -{ - VALUE argv[1]; - - argv[0] = menu_path; - return tk_funcall(ip_make_menu_embeddable_core, 1, argv, interp); -} - - -/*###############################################*/ - -/*---- initialization ----*/ -void -Init_tcltklib(void) -{ - int ret; - - 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"); - VALUE release_type = rb_define_module_under(lib, "RELEASE_TYPE"); - - /* --------------------------------------------------------------- */ - - tcltkip_class = ip; - - /* --------------------------------------------------------------- */ - -#ifdef HAVE_RUBY_ENCODING_H - rb_global_variable(&cRubyEncoding); - cRubyEncoding = rb_path2class("Encoding"); - - ENCODING_INDEX_UTF8 = rb_enc_to_index(rb_utf8_encoding()); - ENCODING_INDEX_BINARY = rb_enc_find_index("binary"); -#endif - - rb_global_variable(&ENCODING_NAME_UTF8); - rb_global_variable(&ENCODING_NAME_BINARY); - - ENCODING_NAME_UTF8 = rb_obj_freeze(rb_str_new2("utf-8")); - ENCODING_NAME_BINARY = rb_obj_freeze(rb_str_new2("binary")); - - /* --------------------------------------------------------------- */ - - rb_global_variable(&eTkCallbackReturn); - rb_global_variable(&eTkCallbackBreak); - rb_global_variable(&eTkCallbackContinue); - - rb_global_variable(&eventloop_thread); - rb_global_variable(&eventloop_stack); - rb_global_variable(&watchdog_thread); - - rb_global_variable(&rbtk_pending_exception); - - /* --------------------------------------------------------------- */ - - 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)); - - /* --------------------------------------------------------------- */ - -#ifdef __WIN32__ -# define TK_WINDOWING_SYSTEM "win32" -#else -# ifdef MAC_TCL -# define TK_WINDOWING_SYSTEM "classic" -# else -# ifdef MAC_OSX_TK -# define TK_WINDOWING_SYSTEM "aqua" -# else -# define TK_WINDOWING_SYSTEM "x11" -# endif -# endif -#endif - rb_define_const(lib, "WINDOWING_SYSTEM", - rb_obj_freeze(rb_str_new2(TK_WINDOWING_SYSTEM))); - - /* --------------------------------------------------------------- */ - - 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 - - /* --------------------------------------------------------------- */ - - rb_define_module_function(lib, "get_version", lib_getversion, -1); - rb_define_module_function(lib, "get_release_type_name", - lib_get_reltype_name, -1); - - rb_define_const(release_type, "ALPHA", INT2FIX(TCL_ALPHA_RELEASE)); - rb_define_const(release_type, "BETA", INT2FIX(TCL_BETA_RELEASE)); - rb_define_const(release_type, "FINAL", INT2FIX(TCL_FINAL_RELEASE)); - - /* --------------------------------------------------------------- */ - - eTkCallbackReturn = 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")); - - eTkLocalJumpError = rb_define_class("TkLocalJumpError", eLocalJumpError); - - eTkCallbackRetry = rb_define_class("TkCallbackRetry", eTkLocalJumpError); - eTkCallbackRedo = rb_define_class("TkCallbackRedo", eTkLocalJumpError); - eTkCallbackThrow = rb_define_class("TkCallbackThrow", eTkLocalJumpError); - - /* --------------------------------------------------------------- */ - - ID_at_enc = rb_intern("@encoding"); - ID_at_interp = rb_intern("@interp"); - ID_encoding_name = rb_intern("encoding_name"); - ID_encoding_table = rb_intern("encoding_table"); - - ID_stop_p = rb_intern("stop?"); -#ifndef HAVE_RB_THREAD_ALIVE_P - ID_alive_p = rb_intern("alive?"); -#endif - ID_kill = rb_intern("kill"); - ID_join = rb_intern("join"); - ID_value = rb_intern("value"); - - 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_thread?", - lib_evloop_thread_p, 0); - rb_define_module_function(lib, "mainloop_watchdog", - lib_mainloop_watchdog, -1); - rb_define_module_function(lib, "do_thread_callback", - lib_thread_callback, -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_window_mode", - set_eventloop_window_mode, 1); - rb_define_module_function(lib, "get_eventloop_window_mode", - get_eventloop_window_mode, 0); - 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_module_function(lib, "encoding_system", - lib_get_system_encoding, 0); - rb_define_module_function(lib, "encoding_system=", - lib_set_system_encoding, 1); - rb_define_module_function(lib, "encoding", - lib_get_system_encoding, 0); - rb_define_module_function(lib, "encoding=", - lib_set_system_encoding, 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, "slave_of?", ip_is_slave_of_p, 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, "has_mainwindow?", ip_has_mainwindow_p, 0); - rb_define_method(ip, "invalid_namespace?", ip_has_invalid_namespace_p, 0); - rb_define_method(ip, "_eval", ip_eval, 1); - rb_define_method(ip, "_cancel_eval", ip_cancel_eval, -1); - rb_define_method(ip, "_cancel_eval_unwind", ip_cancel_eval_unwind, -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, "_immediate_invoke", ip_invoke_immediate, -1); - rb_define_method(ip, "_return_value", ip_retval, 0); - - rb_define_method(ip, "_create_console", ip_create_console, 0); - - /* --------------------------------------------------------------- */ - - rb_define_method(ip, "create_dummy_encoding_for_tk", - create_dummy_encoding_for_tk, 1); - rb_define_method(ip, "encoding_table", ip_get_encoding_table, 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, "_make_menu_embeddable", ip_make_menu_embeddable, 1); - - /* --------------------------------------------------------------- */ - - 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 = Qnil; - eventloop_interp = (Tcl_Interp*)NULL; - -#ifndef DEFAULT_EVENTLOOP_DEPTH -#define DEFAULT_EVENTLOOP_DEPTH 7 -#endif - eventloop_stack = rb_ary_new2(DEFAULT_EVENTLOOP_DEPTH); - RbTk_OBJ_UNTRUST(eventloop_stack); - - watchdog_thread = Qnil; - - rbtk_pending_exception = Qnil; - - /* --------------------------------------------------------------- */ - -#ifdef HAVE_NATIVETHREAD - /* if ruby->nativethread-support and tcltklib->doesn't, - the following will cause link-error. */ - ruby_native_thread_p(); -#endif - - /* --------------------------------------------------------------- */ - - rb_set_end_proc(lib_mark_at_exit, 0); - - /* --------------------------------------------------------------- */ - - ret = ruby_open_tcl_dll(rb_argv0 ? RSTRING_PTR(rb_argv0) : 0); - switch(ret) { - case TCLTK_STUBS_OK: - break; - case NO_TCL_DLL: - rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll"); - case NO_FindExecutable: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable"); - default: - rb_raise(rb_eLoadError, "tcltklib: unknown error(%d) on ruby_open_tcl_dll", ret); - } - - /* --------------------------------------------------------------- */ - -#if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT - setup_rubytkkit(); -#endif - - /* --------------------------------------------------------------- */ - - /* Tcl stub check */ - tcl_stubs_check(); - - Tcl_ObjType_ByteArray = Tcl_GetObjType(Tcl_ObjTypeName_ByteArray); - Tcl_ObjType_String = Tcl_GetObjType(Tcl_ObjTypeName_String); - - /* --------------------------------------------------------------- */ - - (void)call_original_exit; -} - -/* eof */ |