/* * 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 #ifndef RUBY_VERSION #define RUBY_VERSION "(unknown version)" #endif #ifndef RUBY_RELEASE_DATE #define RUBY_RELEASE_DATE "unknown release-date" #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 #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 #ifdef HAVE_STDARG_PROTOTYPES #include #define va_init_list(a,b) va_start(a,b) #else #include #define va_init_list(a,b) va_start(a) #endif #include #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 #include #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__ && !defined __BORLANDC__ /* * The following variable is a special hack that is needed in order for * Sun shared libraries to be used for Tcl. */ extern int matherr(); int *tclDummyMathPtr = (int *) matherr; # endif #endif /*---- module TclTkLib ----*/ struct invoke_queue { Tcl_Event ev; int argc; #if TCL_MAJOR_VERSION >= 8 Tcl_Obj **argv; #else /* TCL_MAJOR_VERSION < 8 */ char **argv; #endif VALUE interp; int *done; int safe_level; VALUE result; VALUE thread; }; struct eval_queue { Tcl_Event ev; char *str; int len; VALUE interp; int *done; int safe_level; VALUE result; VALUE thread; }; 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 #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 *//* conflict definition of struct timezone */ /* #include */ /* #include */ 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"); */ { volatile VALUE basename; basename = rb_funcall(rb_cFile, rb_intern("basename"), 1, rb_str_new2(rb_sourcefile())); rbtk_win32_SetHINSTANCE(RSTRING_PTR(basename)); } #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_PTR(divmod)[0]); tcl_time.usec = NUM2LONG(RARRAY_PTR(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_PTR(divmod)[0]); tcl_time.usec = (long)(NUM2DBL(RARRAY_PTR(divmod)[1]) * 1000000); default: { VALUE tmp = rb_funcallv(time, ID_inspect, 0, 0); rb_raise(rb_eArgError, "invalid value for time: '%s'", StringValuePtr(tmp)); } } 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; { volatile 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 = FIX2INT(vflags); } if (rb_safe_level() >= 4 || (rb_safe_level() >=1 && OBJ_TAINTED(vflags))) { flags |= TCL_DONT_WAIT; } if (is_ip) { /* check IP */ struct tcltkip *ptr = get_ip(self); /* ip is deleted? */ if (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, StringValuePtr(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); #ifndef HAVE_STRUCT_RARRAY_LEN rb_ary_push(args, s); #else RARRAY(args)->ptr[RARRAY(args)->len++] = s; #endif } 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 (rb_safe_level() >= 4 || 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: /* arguemnt 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; /* security check */ if (rb_safe_level() >= 4) { rb_raise(rb_eSecurityError, "Cannot create a TclTkIp object at level %d", rb_safe_level()); } /* create object */ TypedData_Get_Struct(self, struct tcltkip, &tcltkip_type, ptr); 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", StringValuePtr(opts), 0); */ Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), TCL_GLOBAL_ONLY); Tcl_Eval(ptr->ip, "set argc [llength $argv]"); } case 1: /* argv0 */ if (!NIL_P(argv0)) { if (strncmp(StringValuePtr(argv0), "-e", 3) == 0 || strncmp(StringValuePtr(argv0), "-", 2) == 0) { Tcl_SetVar(ptr->ip, "argv0", "ruby", TCL_GLOBAL_ONLY); } else { /* Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0); */ Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), TCL_GLOBAL_ONLY); } } case 0: /* no args */ ; } /* from Tcl_AppInit() */ 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 = ALLOC(struct tcltkip); /* struct tcltkip *slave = RbTk_ALLOC_N(struct tcltkip, 1); */ VALUE safemode; VALUE name; 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 /* 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, StringValuePtr(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 TypedData_Wrap_Struct(CLASS_OF(interp), &tcltkip_type, slave); } 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 = StringValuePtr(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_PTR(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_PTR(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_PTR(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_PTR(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 { msg_obj = Tcl_NewStringObj(RSTRING_PTR(msg), RSTRING_LEN(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, StringValuePtr(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 arguemnts"); 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(StringValuePtr(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_PTR(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_PTR(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 = StringValuePtr(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) { volatile VALUE ret; size_t size; static CONST char form[] = "tcltklib %s :: Ruby%s (%s) %s pthread :: Tcl%s(%s)/Tk%s(%s) %s"; char *info; size = strlen(form) + strlen(TCLTKLIB_RELEASE_DATE) + strlen(RUBY_VERSION) + strlen(RUBY_RELEASE_DATE) + strlen("without") + strlen(TCL_PATCH_LEVEL) + strlen("without stub") + strlen(TK_PATCH_LEVEL) + strlen("without stub") + strlen("unknown tcl_threads"); info = ALLOC_N(char, size); /* info = ckalloc(sizeof(char) * size); */ /* SEGV */ sprintf(info, form, TCLTKLIB_RELEASE_DATE, RUBY_VERSION, RUBY_RELEASE_DATE, #ifdef HAVE_NATIVETHREAD "with", #else "without", #endif TCL_PATCH_LEVEL, #ifdef USE_TCL_STUBS "with stub", #else "without stub", #endif TK_PATCH_LEVEL, #ifdef USE_TK_STUBS "with stub", #else "without stub", #endif #ifdef WITH_TCL_ENABLE_THREAD # if WITH_TCL_ENABLE_THREAD "with tcl_threads" # else "without tcl_threads" # endif #else "unknown tcl_threads" #endif ); ret = rb_obj_freeze(rb_str_new2(info)); xfree(info); /* ckfree(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 */