diff options
| author | nagai <nagai@b2dd03c8-39d4-4d8f-98ff-823fe69b080e> | 2008-03-29 05:25:12 +0000 |
|---|---|---|
| committer | nagai <nagai@b2dd03c8-39d4-4d8f-98ff-823fe69b080e> | 2008-03-29 05:25:12 +0000 |
| commit | 3024ffdc3a5fdb115de651edae9e3d7a335a6614 (patch) | |
| tree | acfc67e481cd24c5e1ca2a344bd97e514fb26246 /ext/tk/tcltklib.c | |
| parent | b62af05a98bc3ebbbca546270e7efa5abd3a17f5 (diff) | |
* ext/tk/*: full update Ruby/Tk to support Ruby(1.9|1.8) and Tc/Tk8.5.
* ext/tk/lib/tkextlib/tile.rb: [incompatible] remove TileWidgets'
instate/state/identify method to avoid the conflict with standard
widget options. Those methods are renamed to ttk_instate/ttk_state/
ttk_identify (tile_instate/tile_state/tile_identify are available
too). Although I don't recommend, if you realy need old methods,
please define "Tk::USE_OBSOLETE_TILE_STATE_METHOD = true" before
"require 'tkextlib/tile'".
* ext/tk/lib/tkextlib/tile.rb: "Tk::Tile::__Import_Tile_Widgets__!"
is obsolete. It outputs warning. To control default widget set,
use "Tk.default_widget_set = :Ttk".
* ext/tk/lib/tk.rb: __IGNORE_UNKNOWN_CONFIGURE_OPTION__ method and
__set_IGNORE_UNKNOWN_CONFIGURE_OPTION__!(mode) method are defind
as module methods of TkConfigMethod. It may help users to wrap old
Ruby/Tk scripts (use standard widgets) to force to use Ttk widgets.
Ttk widgets don't have some options of standard widgets which are
control the view of widgets. When set ignore-mode true, configure
method tries to ignoure such unknown options with no exception.
Of course, it may raise other troubles on the GUI design.
So, those are a little danger methods.
* ext/tk/lib/tk/itemconfig.rb: __IGNORE_UNKNOWN_CONFIGURE_OPTION__
method and __set_IGNORE_UNKNOWN_CONFIGURE_OPTION__!(mode) method
are defind as module methods of TkItemConfigMethod as the same
purpose as TkConfigMethod's ones.
* ext/tk/sample/ttk_wrapper.rb: A new example. This is a tool for
wrapping old Ruby/Tk scripts (which use standard widgets) to use
Ttk (Tile) widgets as default.
* ext/tk/sample/tkextlib/tile/demo.rb: use ttk_instate/ttk_state
method instead of instate/state method.
* ext/tk/lib/tk/root, ext/tk/lib/tk/namespace.rb,
ext/tk/lib/tk/text.rb, ext/tk/lib/tkextlib/*: some 'instance_eval's
are replaced to "instance_exec(self)".
* ext/tk/lib/tk/event.rb: bug fix on KEY_TBL and PROC_TBL (?x is not
a character code on Ruby1.9).
* ext/tk/lib/tk/variable.rb: support new style of operation argument
on Tcl/Tk's 'trace' command for variables.
* ext/tk/sample/demos-jp/widget, ext/tk/sample/demos-en/widget: bug fix
* ext/tk/sammple/demos-jp/textpeer.rb,
ext/tk/sammple/demos-en/textpeer.rb: new widget demo.
* ext/tk/tcltklib.c: decrase SEGV troubles (probably)
* ext/tk/lib/tk.rb: remove Thread.critical access if Ruby1.9
* ext/tk/lib/tk/multi-tk.rb: support Ruby1.9 (probably)
* ext/tk/lib/tkextlib/tile.rb: add method to define Tcl/Tk command
to make Tcl/Tk theme sources (based on different version of Tile
extension) available.
(Tk::Tile::__define_LoadImages_proc_for_comaptibility__)
* ext/tk/lib/tk.rb, ext/tk/lib/tk/wm.rb: support dockable frames
(Tcl/Tk8.5 feature). 'wm' command can treat many kinds of widgets
as toplevel widgets.
* ext/tk/lib/tkextlib/tile/style.rb: ditto.
(Tk::Tile::Style.__define_wrapper_proc_for_compatibility__)
* ext/tk/lib/tk/font.rb: add actual_hash and metrics_hash to get
properties as a hash. metrics_hash method returns a boolean value
for 'fixed' option. But metrics method returns numeric value
(0 or 1) for 'fixed' option, because of backward compatibility.
* ext/tk/lib/tk/timer.rb: somtimes fail to set callback procedure.
* ext/tk/lib/tk.rb: add Tk.sleep and Tk.wakeup method. Tk.sleep
doesn't block the eventloop. It will be better to use the method
in event callbacks.
* ext/tk/sample/tksleep_sample.rb: sample script about Tk.sleep.
git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/trunk@15848 b2dd03c8-39d4-4d8f-98ff-823fe69b080e
Diffstat (limited to 'ext/tk/tcltklib.c')
| -rw-r--r-- | ext/tk/tcltklib.c | 2053 |
1 files changed, 1850 insertions, 203 deletions
diff --git a/ext/tk/tcltklib.c b/ext/tk/tcltklib.c index df70e67c9d..18e0fd76fb 100644 --- a/ext/tk/tcltklib.c +++ b/ext/tk/tcltklib.c @@ -4,10 +4,20 @@ * Oct. 24, 1997 Y. Matsumoto */ -#define TCLTKLIB_RELEASE_DATE "2007-12-21" +#define TCLTKLIB_RELEASE_DATE "2008-03-29" -#include "ruby/ruby.h" +#include "ruby.h" + +#ifdef RUBY_VM +/* #include "ruby/ruby.h" */ #include "ruby/signal.h" +#include "ruby/encoding.h" +#else +/* #include "ruby.h" */ +#include "rubysig.h" +#include "version.h" +#endif + #undef EXTERN /* avoid conflict with tcl.h of tcl8.2 or before */ #include <stdio.h> #ifdef HAVE_STDARG_PROTOTYPES @@ -29,6 +39,24 @@ #define TCL_FINAL_RELEASE 2 #endif +static struct { + int major; + int minor; + int patchlevel; + int type; +} tcltk_version = {0, 0, 0, 0}; + +static void +set_tcltk_version() +{ + 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 */ @@ -82,6 +110,26 @@ static void ip_finalize _((Tcl_Interp*)); static int at_exit = 0; +#ifdef RUBY_VM +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; @@ -100,6 +148,9 @@ 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; @@ -123,9 +174,30 @@ static VALUE ip_invoke _((int, VALUE*, VALUE)); static VALUE tk_funcall _((VALUE(), int, VALUE*, VALUE)); +/* Tcl's object type */ +#if TCL_MAJOR_VERSION >= 8 +static char *Tcl_ObjTypeName_ByteArray = "bytearray"; +static Tcl_ObjType *Tcl_ObjType_ByteArray; + +static char *Tcl_ObjTypeName_String = "string"; +static 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 + /* safe Tcl_Eval and Tcl_GlobalEval */ static int +#ifdef RUBY_VM 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; @@ -140,7 +212,13 @@ tcl_eval(Tcl_Interp *interp, const char *cmd) #define Tcl_Eval tcl_eval static int +#ifdef RUBY_VM 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; @@ -311,13 +389,24 @@ call_queue_mark(struct call_queue *q) static VALUE eventloop_thread; +#ifdef RUBY_VM +Tcl_ThreadId tk_eventloop_thread_id; /* native thread ID of Tcl interpreter */ +#endif static VALUE eventloop_stack; static int window_event_mode = ~(TCL_WINDOW_EVENTS | TCL_IDLE_EVENTS); static VALUE watchdog_thread; Tcl_Interp *current_interp; - + +/* thread control strategy */ +#define CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE 0 +#define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0 +#define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 1 + +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE +static int have_rb_thread_waited_for_value = 0; +#endif /* * 'event_loop_max' is a maximum events which the eventloop processes in one @@ -326,12 +415,27 @@ Tcl_Interp *current_interp; * 'timer_tick' is a limit of one term of thread scheduling. * If 'timer_tick' == 0, then not use the timer for thread scheduling. */ -#define DEFAULT_EVENT_LOOP_MAX 800/*counts*/ -#define DEFAULT_NO_EVENT_TICK 10/*counts*/ -#define DEFAULT_NO_EVENT_WAIT 20/*milliseconds ( 1 -- 999 ) */ -#define WATCHDOG_INTERVAL 10/*milliseconds ( 1 -- 999 ) */ -#define DEFAULT_TIMER_TICK 0/*milliseconds ( 0 -- 999 ) */ -#define NO_THREAD_INTERRUPT_TIME 100/*milliseconds ( 1 -- 999 ) */ +#ifdef RUBY_VM +#define DEFAULT_EVENT_LOOP_MAX 800/*counts*/ +#define DEFAULT_NO_EVENT_TICK 10/*counts*/ +#define DEFAULT_NO_EVENT_WAIT 10/*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 ) */ +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE +#define DEFAULT_HAS_WAIT_THREAD_TICK 50/*counts*/ +#endif +#else /* ! RUBY_VM */ +#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 ) */ +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE +#define DEFAULT_HAS_WAIT_THREAD_TICK 50/*counts*/ +#endif +#endif static int event_loop_max = DEFAULT_EVENT_LOOP_MAX; static int no_event_tick = DEFAULT_NO_EVENT_TICK; @@ -339,6 +443,9 @@ 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; +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE +static int has_wait_thread_tick = DEFAULT_HAS_WAIT_THREAD_TICK; +#endif static int event_loop_wait_event = 0; static int event_loop_abort_on_exc = 1; @@ -567,7 +674,7 @@ struct tcltkip { Tcl_Namespace *default_ns; /* default namespace */ #endif #ifdef RUBY_VM - Tcl_ThreadId tk_thread_id; /* default namespace */ + 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 */ @@ -604,9 +711,9 @@ deleted_ip(ptr) #endif ) { DUMP1("ip is deleted"); - return Qtrue; + return 1; } - return Qfalse; + return 0; } /* increment/decrement reference count of tcltkip */ @@ -770,6 +877,7 @@ tcltkip_init_tk(interp) /* treat excetiopn on Tcl side */ static VALUE rbtk_pending_exception; static int rbtk_eventloop_depth = 0; +static int rbtk_internal_eventloop_handler = 0; static int @@ -779,7 +887,9 @@ pending_exception_check0() if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) { DUMP1("find a pending exception"); - if (rbtk_eventloop_depth > 0) { + if (rbtk_eventloop_depth > 0 + || rbtk_internal_eventloop_handler > 0 + ) { return 1; /* pending */ } else { rbtk_pending_exception = Qnil; @@ -812,7 +922,9 @@ pending_exception_check1(thr_crit_bup, ptr) if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) { DUMP1("find a pending exception"); - if (rbtk_eventloop_depth > 0) { + if (rbtk_eventloop_depth > 0 + || rbtk_internal_eventloop_handler > 0 + ) { return 1; /* pending */ } else { rbtk_pending_exception = Qnil; @@ -870,8 +982,11 @@ call_original_exit(ptr, state) if (info->isNativeObjectProc) { Tcl_Obj **argv; - // argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3); /* XXXXXXXXXX */ + /* argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3); */ /* XXXXXXXXXX */ argv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 3); +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ +#endif argv[0] = Tcl_NewStringObj("exit", 4); argv[1] = state_obj; argv[2] = (Tcl_Obj *)NULL; @@ -879,13 +994,24 @@ call_original_exit(ptr, state) ptr->return_value = (*(info->objProc))(info->objClientData, ptr->ip, 2, argv); - free(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 */ +#endif + /* free(argv); */ + ckfree((char*)argv); +#endif } else { /* string interface */ char **argv; - //argv = (char **)ALLOC_N(char *, 3); /* XXXXXXXXXX */ - argv = (char **)ckalloc(sizeof(char *) * 3); + /* argv = (char **)ALLOC_N(char *, 3); */ /* XXXXXXXXXX */ + argv = (char **)ckalloc(sizeof(char *) * 3); +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ +#endif argv[0] = "exit"; /* argv[1] = Tcl_GetString(state_obj); */ argv[1] = Tcl_GetStringFromObj(state_obj, (int*)NULL); @@ -894,7 +1020,15 @@ call_original_exit(ptr, state) ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, 2, (CONST84 char **)argv); - free(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 */ +#endif + /* free(argv); */ + ckfree((char*)argv); +#endif } Tcl_DecrRefCount(state_obj); @@ -903,7 +1037,11 @@ call_original_exit(ptr, state) { /* string interface */ char **argv; - argv = (char **)ALLOC_N(char *, 3); + /* argv = (char **)ALLOC_N(char *, 3); */ + argv = (char **)ckalloc(sizeof(char *) * 3); +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ +#endif argv[0] = "exit"; argv[1] = RSTRING_PTR(rb_fix2str(INT2NUM(state), 10)); argv[2] = (char *)NULL; @@ -911,7 +1049,15 @@ call_original_exit(ptr, state) ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, 2, argv); - free(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 */ +#endif + /* free(argv); */ + ckfree(argv); +#endif } #endif @@ -954,6 +1100,21 @@ _timer_for_tcl(clientData) /* tick_counter += event_loop_max; */ } +#ifdef RUBY_VM +#if USE_TOGGLE_WINDOW_MODE_FOR_IDLE +static int +toggle_eventloop_window_mode_for_idle() +{ + if (window_event_mode & TCL_IDLE_EVENTS) { + window_event_mode &= ~TCL_IDLE_EVENTS; + return 1; + } else { + window_event_mode |= TCL_IDLE_EVENTS; + return 0; + } +} +#endif +#endif static VALUE set_eventloop_window_mode(self, mode) @@ -1262,8 +1423,10 @@ ip_evloop_abort_on_exc_set(self, val) } static VALUE -lib_num_of_mainwindows(self) +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()); @@ -1272,7 +1435,37 @@ lib_num_of_mainwindows(self) } } +static VALUE +lib_num_of_mainwindows(self) + VALUE self; +{ + return tk_funcall(lib_num_of_mainwindows_core, 0, (VALUE*)NULL, self); +} + + +#ifdef RUBY_VM /* Ruby 1.9+ !!! */ +static VALUE +call_DoOneEvent_core(flag_val) + VALUE flag_val; +{ + int flag; + + flag = FIX2INT(flag_val); + if (Tcl_DoOneEvent(flag)) { + return Qtrue; + } else { + return Qfalse; + } +} + +static VALUE +call_DoOneEvent(flag_val) + VALUE flag_val; +{ + return tk_funcall(call_DoOneEvent_core, 0, (VALUE*)NULL, flag_val); +} +#else /* Ruby 1.8- */ static VALUE call_DoOneEvent(flag_val) VALUE flag_val; @@ -1286,6 +1479,8 @@ call_DoOneEvent(flag_val) return Qfalse; } } +#endif + static VALUE eventloop_sleep(dummy) @@ -1296,29 +1491,78 @@ eventloop_sleep(dummy) t.tv_sec = (time_t)0; t.tv_usec = (time_t)(no_event_wait*1000.0); -#if 0 #ifdef HAVE_NATIVETHREAD +#ifdef RUBY_VM +#if 0 if (!ruby_native_thread_p()) { rb_bug("cross-thread violation on eventloop_sleep()"); } #endif +#else + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on eventloop_sleep()"); + } +#endif #endif DUMP2("eventloop_sleep: rb_thread_wait_for() at thread : %lx", rb_thread_current()); rb_thread_wait_for(t); DUMP2("eventloop_sleep: finish at thread : %lx", rb_thread_current()); -#if 0 #ifdef HAVE_NATIVETHREAD +#ifdef RUBY_VM +#if 0 if (!ruby_native_thread_p()) { rb_bug("cross-thread violation on eventloop_sleep()"); } #endif +#else + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on eventloop_sleep()"); + } +#endif #endif return Qnil; } +#define USE_EVLOOP_THREAD_ALONE_CHECK_FLAG 0 + +#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG +static int +get_thread_alone_check_flag() +{ +#ifdef RUBY_VM + 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 static int lib_eventloop_core(check_root, update_flag, check_var, interp) @@ -1334,7 +1578,9 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) int thr_crit_bup; int status; int depth = rbtk_eventloop_depth; - +#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG + int thread_alone_check_flag = 1; +#endif if (update_flag) DUMP1("update loop start!!"); @@ -1353,9 +1599,14 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) 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(;;) { -#ifdef RUBY_VM - if (0) { +#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG + if (thread_alone_check_flag && rb_thread_alone()) { #else if (rb_thread_alone()) { #endif @@ -1365,8 +1616,8 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) if (update_flag) { event_flag = update_flag | TCL_DONT_WAIT; /* for safety */ } else { - // event_flag = TCL_ALL_EVENTS; - event_flag = TCL_FILE_EVENTS | TCL_TIMER_EVENTS | TCL_DONT_WAIT; + event_flag = TCL_ALL_EVENTS; + /* event_flag = TCL_ALL_EVENTS | TCL_DONT_WAIT; */ } if (timer_tick == 0 && update_flag == 0) { @@ -1393,11 +1644,19 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) if (status) { switch (status) { case TAG_RAISE: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif rbtk_pending_exception = rb_exc_new2(rb_eException, "unknown exception"); } else { +#ifdef RUBY_VM rbtk_pending_exception = rb_errinfo(); +#else + rbtk_pending_exception = ruby_errinfo; +#endif if (!NIL_P(rbtk_pending_exception)) { if (rbtk_eventloop_depth == 0) { @@ -1412,10 +1671,18 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) break; case TAG_FATAL: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL")); } else { +#ifdef RUBY_VM rb_exc_raise(rb_errinfo()); +#else + rb_exc_raise(ruby_errinfo); +#endif } } } @@ -1514,6 +1781,17 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) 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 = 0; + } else { + /* event-mode -> idle-mode */ + tick_counter = event_loop_max; + } + } +#endif } #else /* st = Tcl_DoOneEvent(event_flag); */ @@ -1523,12 +1801,20 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) if (status) { switch (status) { case TAG_RAISE: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif rbtk_pending_exception = rb_exc_new2(rb_eException, "unknown exception"); } else { +#ifdef RUBY_VM rbtk_pending_exception = rb_errinfo(); +#else + rbtk_pending_exception = ruby_errinfo; +#endif if (!NIL_P(rbtk_pending_exception)) { if (rbtk_eventloop_depth == 0) { @@ -1543,10 +1829,18 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) break; case TAG_FATAL: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL")); } else { +#ifdef RUBY_VM rb_exc_raise(rb_errinfo()); +#else + rb_exc_raise(ruby_errinfo); +#endif } } } @@ -1579,6 +1873,13 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) return 0; } +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE + if (have_rb_thread_waited_for_value) { + tick_counter += no_event_tick; + have_rb_thread_waited_for_value = 0; + } +#endif + if (st) { tick_counter++; } else { @@ -1590,19 +1891,26 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) tick_counter += no_event_tick; /* rb_thread_wait_for(t); */ -#if 0 + rb_protect(eventloop_sleep, Qnil, &status); -#endif if (status) { switch (status) { case TAG_RAISE: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif rbtk_pending_exception = rb_exc_new2(rb_eException, "unknown exception"); } else { +#ifdef RUBY_VM rbtk_pending_exception = rb_errinfo(); +#else + rbtk_pending_exception = ruby_errinfo; +#endif if (!NIL_P(rbtk_pending_exception)) { if (rbtk_eventloop_depth == 0) { @@ -1617,11 +1925,19 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) break; case TAG_FATAL: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL")); } else { +#ifdef RUBY_VM rb_exc_raise(rb_errinfo()); +#else + rb_exc_raise(ruby_errinfo); +#endif } } } @@ -1676,12 +1992,16 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) } } - DUMP1("thread scheduling"); - rb_thread_schedule(); + DUMP1("thread scheduling"); + rb_thread_schedule(); } DUMP1("trap check & thread scheduling"); - if (update_flag == 0) ; // TODO: CHECK_INTS +#ifdef RUBY_VM + /* if (update_flag == 0) CHECK_INTS; */ /*XXXXXXXXXXXXX TODO !!!! */ +#else + if (update_flag == 0) CHECK_INTS; +#endif } return 1; @@ -1728,19 +2048,35 @@ lib_eventloop_main(args) switch (status) { case TAG_RAISE: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif rbtk_pending_exception = rb_exc_new2(rb_eException, "unknown exception"); } else { +#ifdef RUBY_VM rbtk_pending_exception = rb_errinfo(); +#else + rbtk_pending_exception = ruby_errinfo; +#endif } return Qnil; case TAG_FATAL: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL"); } else { +#ifdef RUBY_VM rbtk_pending_exception = rb_errinfo(); +#else + rbtk_pending_exception = ruby_errinfo; +#endif } return Qnil; } @@ -1764,6 +2100,7 @@ lib_eventloop_ensure(args) rb_thread_critical = ptr->thr_crit_bup; free(ptr); + /* ckfree((char*)ptr); */ return Qnil; } @@ -1793,9 +2130,16 @@ lib_eventloop_ensure(args) } } +#ifdef RUBY_VM + if (NIL_P(eventloop_thread)) { + tk_eventloop_thread_id = (Tcl_ThreadId) 0; + } +#endif + rb_thread_critical = ptr->thr_crit_bup; free(ptr); + /* ckfree((char*)ptr);*/ DUMP2("finish current eventloop %lx", current_evloop); return Qnil; @@ -1810,10 +2154,14 @@ lib_eventloop_launcher(check_root, update_flag, check_var, interp) { volatile VALUE parent_evloop = eventloop_thread; struct evloop_params *args = ALLOC(struct evloop_params); + /* struct evloop_params *args = (struct evloop_params *)ckalloc(sizeof(struct evloop_params)); */ tcl_stubs_check(); eventloop_thread = rb_thread_current(); +#ifdef RUBY_VM + tk_eventloop_thread_id = Tcl_GetCurrentThread(); +#endif if (parent_evloop == eventloop_thread) { DUMP2("eventloop: recursive call on %lx", parent_evloop); @@ -1964,6 +2312,9 @@ lib_watchdog_ensure(arg) VALUE arg; { eventloop_thread = Qnil; /* stop eventloops */ +#ifdef RUBY_VM + tk_eventloop_thread_id = (Tcl_ThreadId) 0; +#endif return Qnil; } @@ -1975,6 +2326,11 @@ lib_mainloop_watchdog(argc, argv, 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)) { @@ -2068,11 +2424,11 @@ lib_thread_callback(argc, argv, self) proc = rb_block_proc(); } - //q = (struct thread_call_proc_arg *)ALLOC(struct thread_call_proc_arg); - q = (struct thread_call_proc_arg *)ckalloc(sizeof(struct thread_call_proc_arg)); + q = (struct thread_call_proc_arg *)ALLOC(struct thread_call_proc_arg); + /* q = (struct thread_call_proc_arg *)ckalloc(sizeof(struct thread_call_proc_arg)); */ q->proc = proc; - //q->done = (int*)ALLOC(int); - q->done = (int*)ckalloc(sizeof(int)); + q->done = (int*)ALLOC(int); + /* q->done = (int*)ckalloc(sizeof(int)); */ *(q->done) = 0; /* create call-proc thread */ @@ -2091,16 +2447,23 @@ lib_thread_callback(argc, argv, self) ret = rb_protect(_thread_call_proc_value, th, &status); } - //free(q->done); - //free(q); - ckfree((char*)q->done); - ckfree((char*)q); + free(q->done); + free(q); + /* ckfree((char*)q->done); */ + /* ckfree((char*)q); */ if (NIL_P(rbtk_pending_exception)) { +#ifdef RUBY_VM /* return rb_errinfo(); */ if (status) { rb_exc_raise(rb_errinfo()); } +#else + /* return ruby_errinfo; */ + if (status) { + rb_exc_raise(ruby_errinfo); + } +#endif } else { VALUE exc = rbtk_pending_exception; rbtk_pending_exception = Qnil; @@ -2225,8 +2588,11 @@ ip_set_exc_message(interp, exc) } /* to avoid a garbled error message dialog */ - // buf = ALLOC_N(char, (RSTRING_LEN(msg))+1); - buf = ckalloc(sizeof(char)*((RSTRING_LEN(msg))+1)); + /* 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_LEN(msg)+1); + /* buf = ckalloc(sizeof(char)*((RSTRING_LEN(msg))+1)); */ memcpy(buf, RSTRING_PTR(msg), RSTRING_LEN(msg)); buf[RSTRING_LEN(msg)] = 0; @@ -2237,8 +2603,8 @@ ip_set_exc_message(interp, exc) Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL); DUMP2("error message:%s", Tcl_DStringValue(&dstr)); Tcl_DStringFree(&dstr); - //free(buf); - ckfree(buf); + free(buf); + /* ckfree(buf); */ #else /* TCL_VERSION <= 8.0 */ Tcl_AppendResult(interp, RSTRING_PTR(msg), (char*)NULL); @@ -2307,58 +2673,104 @@ tcl_protect_core(interp, proc, data) /* should not raise exception */ goto error; error: str = rb_str_new2("LocalJumpError: "); +#ifdef RUBY_VM rb_str_append(str, rb_obj_as_string(rb_errinfo())); +#else + rb_str_append(str, rb_obj_as_string(ruby_errinfo)); +#endif exc = rb_exc_new3(type, str); break; case TAG_RETRY: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif DUMP1("rb_protect: retry"); exc = rb_exc_new2(eTkCallbackRetry, "retry jump error"); } else { +#ifdef RUBY_VM exc = rb_errinfo(); +#else + exc = ruby_errinfo; +#endif } break; case TAG_REDO: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif DUMP1("rb_protect: redo"); exc = rb_exc_new2(eTkCallbackRedo, "redo jump error"); } else { +#ifdef RUBY_VM exc = rb_errinfo(); +#else + exc = ruby_errinfo; +#endif } break; case TAG_RAISE: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif exc = rb_exc_new2(rb_eException, "unknown exception"); } else { +#ifdef RUBY_VM exc = rb_errinfo(); +#else + exc = ruby_errinfo; +#endif } break; case TAG_FATAL: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif exc = rb_exc_new2(rb_eFatal, "FATAL"); } else { +#ifdef RUBY_VM exc = rb_errinfo(); +#else + exc = ruby_errinfo; +#endif } break; case TAG_THROW: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif DUMP1("rb_protect: throw"); exc = rb_exc_new2(eTkCallbackThrow, "throw jump error"); } else { +#ifdef RUBY_VM exc = rb_errinfo(); +#else + exc = ruby_errinfo; +#endif } 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); free(buf); + /* ckfree(buf); */ break; } @@ -2455,12 +2867,18 @@ tcl_protect(interp, proc, data) int old_trapflag = rb_trap_immediate; int code; -#if 0 #ifdef HAVE_NATIVETHREAD +#ifdef RUBY_VM +#if 0 if (!ruby_native_thread_p()) { rb_bug("cross-thread violation on tcl_protect()"); } #endif +#else + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on tcl_protect()"); + } +#endif #endif rb_trap_immediate = 0; @@ -2523,6 +2941,7 @@ ip_ruby_eval(clientData, interp, argc, argv) 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; @@ -2540,6 +2959,7 @@ ip_ruby_eval(clientData, interp, argc, argv) #if TCL_MAJOR_VERSION >= 8 free(arg); + /* ckfree(arg); */ #endif return code; @@ -2564,6 +2984,96 @@ ip_ruby_cmd_core(arg) return ret; } +#define SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER 1 + +static VALUE +ip_ruby_cmd_receiver_const_get(name) + char *name; +{ + volatile VALUE klass = rb_cObject; + char *head, *tail; + int state; + +#if SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER + klass = rb_eval_string_protect(name, &state); + if (state) { + return Qnil; + } else { + return klass; + } +#else + return rb_const_get(klass, rb_intern(name)); +#endif + + /* TODO!!!!!! */ + /* support nest of classes/modules */ + + /* return rb_eval_string(name); */ + /* return rb_eval_string_protect(name, &state); */ + +#if 0 /* doesn't work!! (fail to autoload?) */ + /* duplicate */ + head = name = strdup(name); + + /* has '::' at head ? */ + if (*head == ':') head += 2; + tail = head; + + /* search */ + while(*tail) { + if (*tail == ':') { + *tail = '\0'; + klass = rb_const_get(klass, rb_intern(head)); + tail += 2; + head = tail; + } else { + tail++; + } + } + + free(name); + return rb_const_get(klass, rb_intern(head)); +#endif +} + +static VALUE +ip_ruby_cmd_receiver_get(str) + char *str; +{ + volatile VALUE receiver; + volatile VALUE klass = rb_cObject; + int state; + + if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) { + /* class | module | constant */ +#if SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER + receiver = ip_ruby_cmd_receiver_const_get(str); +#else + receiver = rb_protect(ip_ruby_cmd_receiver_const_get, (VALUE)str, &state); + if (state) return Qnil; +#endif + } else if (str[0] == '$') { + /* global variable */ + receiver = rb_gv_get(str); + } else { + /* global variable omitted '$' */ + char *buf; + int 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); + free(buf); + /* ckfree(buf); */ + } + + return receiver; +} + /* ruby_cmd receiver method arg ... */ static int #if TCL_MAJOR_VERSION >= 8 @@ -2611,6 +3121,7 @@ ip_ruby_cmd(clientData, interp, argc, argv) /* allocate */ arg = ALLOC(struct cmd_body_arg); + /* arg = (struct cmd_body_arg *)ckalloc(sizeof(struct cmd_body_arg)); */ /* get arguments from Tcl objects */ thr_crit_bup = rb_thread_critical; @@ -2624,24 +3135,8 @@ ip_ruby_cmd(clientData, interp, argc, argv) str = argv[1]; #endif DUMP2("receiver:%s",str); - if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) { - /* class | module | constant */ - receiver = rb_const_get(rb_cObject, rb_intern(str)); - } else if (str[0] == '$') { - /* global variable */ - receiver = rb_gv_get(str); - } else { - /* global variable omitted '$' */ - char *buf; - - len = strlen(str); - buf = ALLOC_N(char, len + 2); - buf[0] = '$'; - memcpy(buf + 1, str, len); - buf[len + 1] = 0; - receiver = rb_gv_get(buf); - free(buf); - } + /* 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, @@ -2666,14 +3161,26 @@ ip_ruby_cmd(clientData, interp, argc, argv) /* get args */ args = rb_ary_new2(argc - 2); +#ifdef RUBY_VM +#else + RARRAY(args)->len = 0; +#endif for(i = 3; i < argc; i++) { #if TCL_MAJOR_VERSION >= 8 str = Tcl_GetStringFromObj(argv[i], &len); DUMP2("arg:%s",str); +#ifdef RUBY_VM rb_ary_push(args, rb_tainted_str_new(str, len)); +#else + RARRAY(args)->ptr[RARRAY(args)->len++] = rb_tainted_str_new(str, len); +#endif #else /* TCL_MAJOR_VERSION < 8 */ DUMP2("arg:%s",argv[i]); +#ifdef RUBY_VM rb_ary_push(args, rb_tainted_str_new2(argv[i])); +#else + RARRAY(args)->ptr[RARRAY(args)->len++] = rb_tainted_str_new2(argv[i]); +#endif #endif } @@ -2688,6 +3195,7 @@ ip_ruby_cmd(clientData, interp, argc, argv) code = tcl_protect(interp, ip_ruby_cmd_core, (VALUE)arg); free(arg); + /* ckfree((char*)arg); */ return code; } @@ -2864,12 +3372,18 @@ ip_rbUpdateCommand(clientData, interp, objc, objv) "IP is deleted"); return TCL_ERROR; } -#if 0 #ifdef HAVE_NATIVETHREAD +#ifdef RUBY_VM +#if 0 if (!ruby_native_thread_p()) { rb_bug("cross-thread violation on ip_ruby_eval()"); } #endif +#else + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on ip_ruby_eval()"); + } +#endif #endif if (objc == 1) { @@ -3013,10 +3527,16 @@ ip_rb_threadUpdateCommand(clientData, interp, objc, objv) "IP is deleted"); return TCL_ERROR; } -#if 0 #ifdef HAVE_NATIVETHREAD +#ifdef RUBY_VM +#if 0 if (!ruby_native_thread_p()) { - rb_bug("cross-thread violation on ip_ruby_eval()"); + rb_bug("cross-thread violation on ip_rb_threadUpdateCommand()"); + } +#endif +#else + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on ip_rb_threadUpdateCommand()"); } #endif #endif @@ -3080,8 +3600,11 @@ ip_rb_threadUpdateCommand(clientData, interp, objc, objv) DUMP1("pass argument check"); - param = (struct th_update_param *)Tcl_Alloc(sizeof(struct th_update_param)); - Tcl_Preserve(param); + /* param = (struct th_update_param *)Tcl_Alloc(sizeof(struct th_update_param)); */ + param = (struct th_update_param *)ckalloc(sizeof(struct th_update_param)); +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Preserve((ClientData)param); +#endif param->thread = current_thread; param->done = 0; @@ -3093,8 +3616,15 @@ ip_rb_threadUpdateCommand(clientData, interp, objc, objv) rb_thread_stop(); } - Tcl_Release(param); - Tcl_Free((char *)param); +#if 0 /* use Tcl_EventuallyFree */ + Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ +#else +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Release((ClientData)param); +#endif + /* Tcl_Free((char *)param); */ + ckfree((char *)param); +#endif DUMP1("finish Ruby's 'thread_update'"); return TCL_OK; @@ -3192,10 +3722,16 @@ ip_rbVwaitCommand(clientData, interp, objc, objv) #endif Tcl_Preserve(interp); -#if 0 #ifdef HAVE_NATIVETHREAD +#ifdef RUBY_VM +#if 0 if (!ruby_native_thread_p()) { - rb_bug("cross-thread violation on ip_ruby_eval()"); + rb_bug("cross-thread violation on ip_rbVwaitCommand()"); + } +#endif +#else + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on ip_rbVwaitCommand()"); } #endif #endif @@ -3588,6 +4124,7 @@ ip_rbTkWaitCommand(clientData, interp, objc, objv) 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 { @@ -3595,7 +4132,7 @@ ip_rbTkWaitCommand(clientData, interp, objc, objv) } if (window == NULL) { - Tcl_AppendResult(interp, "tkwait: ", + Tcl_AppendResult(interp, ": tkwait: ", "no main-window (not Tk application?)", (char*)NULL); rb_thread_critical = thr_crit_bup; @@ -3684,7 +4221,8 @@ ip_rbTkWaitCommand(clientData, interp, objc, objv) 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 { @@ -3696,7 +4234,7 @@ ip_rbTkWaitCommand(clientData, interp, objc, objv) #endif if (window == NULL) { - Tcl_AppendResult(interp, "tkwait: ", + Tcl_AppendResult(interp, ": tkwait: ", "no main-window (not Tk application?)", (char*)NULL); rb_thread_critical = thr_crit_bup; @@ -3902,8 +4440,11 @@ ip_rb_threadVwaitCommand(clientData, interp, objc, objv) thr_crit_bup = rb_thread_critical; rb_thread_critical = Qtrue; - param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); - Tcl_Preserve(param); + /* param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); */ + param = (struct th_vwait_param *)ckalloc(sizeof(struct th_vwait_param)); +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Preserve((ClientData)param); +#endif param->thread = current_thread; param->done = 0; @@ -3921,8 +4462,15 @@ ip_rb_threadVwaitCommand(clientData, interp, objc, objv) rb_thread_critical = thr_crit_bup; if (ret != TCL_OK) { - Tcl_Release(param); - Tcl_Free((char *)param); +#if 0 /* use Tcl_EventuallyFree */ + Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ +#else +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Release((ClientData)param); +#endif + /* Tcl_Free((char *)param); */ + ckfree((char *)param); +#endif #if TCL_MAJOR_VERSION >= 8 Tcl_DecrRefCount(objv[1]); @@ -3945,8 +4493,15 @@ ip_rb_threadVwaitCommand(clientData, interp, objc, objv) rb_threadVwaitProc, (ClientData) param); } - Tcl_Release(param); - Tcl_Free((char *)param); +#if 0 /* use Tcl_EventuallyFree */ + Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ +#else +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Release((ClientData)param); +#endif + /* Tcl_Free((char *)param); */ + ckfree((char *)param); +#endif rb_thread_critical = thr_crit_bup; @@ -4087,8 +4642,11 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) nameString = objv[2]; #endif - param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); - Tcl_Preserve(param); + /* param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); */ + param = (struct th_vwait_param *)ckalloc(sizeof(struct th_vwait_param)); +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Preserve((ClientData)param); +#endif param->thread = current_thread; param->done = 0; @@ -4112,8 +4670,15 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) rb_thread_critical = thr_crit_bup; if (ret != TCL_OK) { +#if 0 /* use Tcl_EventuallyFree */ + Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ +#else +#if 0 /* use Tcl_Preserve/Release */ Tcl_Release(param); - Tcl_Free((char *)param); +#endif + /* Tcl_Free((char *)param); */ + ckfree((char *)param); +#endif #if TCL_MAJOR_VERSION >= 8 Tcl_DecrRefCount(objv[2]); @@ -4150,21 +4715,42 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) 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: ", + 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 0 /* use Tcl_Preserve/Release */ Tcl_Release(param); - Tcl_Free((char *)param); +#endif + /* Tcl_Free((char *)param); */ + ckfree((char *)param); +#endif #if TCL_MAJOR_VERSION >= 8 Tcl_DecrRefCount(objv[2]); @@ -4213,8 +4799,15 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) Tcl_Release(window); +#if 0 /* use Tcl_EventuallyFree */ + Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ +#else +#if 0 /* use Tcl_Preserve/Release */ Tcl_Release(param); - Tcl_Free((char *)param); +#endif + /* Tcl_Free((char *)param); */ + ckfree((char *)param); +#endif #if TCL_MAJOR_VERSION >= 8 Tcl_DecrRefCount(objv[2]); @@ -4239,25 +4832,46 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) 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: ", + 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 0 /* use Tcl_Preserve/Release */ Tcl_Release(param); - Tcl_Free((char *)param); +#endif + /* Tcl_Free((char *)param); */ + ckfree((char *)param); +#endif Tcl_Release(tkwin); Tcl_Release(interp); @@ -4296,8 +4910,15 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) break; } /* end of 'switch' statement */ - Tcl_Release(param); - Tcl_Free((char *)param); +#if 0 /* use Tcl_EventuallyFree */ + Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ +#else +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Release((ClientData)param); +#endif + /* Tcl_Free((char *)param); */ + ckfree((char *)param); +#endif /* * Clear out the interpreter's result, since it may have been set @@ -4541,6 +5162,18 @@ ip_finalize(ip) #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. + */ DUMP1("call Tk_DestroyWindow"); ruby_debug = Qfalse; ruby_verbose = Qnil; @@ -4602,13 +5235,15 @@ ip_free(ptr) DUMP2("slave IP(%lx) should not be deleted", (unsigned long)ptr->ip); free(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"); - free(ptr); + /* free(ptr); */ + ckfree((char*)ptr); rb_thread_critical = thr_crit_bup; return; } @@ -4619,6 +5254,7 @@ ip_free(ptr) ptr->ip = (Tcl_Interp*)NULL; free(ptr); + /* ckfree((char*)ptr); */ rb_thread_critical = thr_crit_bup; } @@ -4740,7 +5376,11 @@ ip_rbNamespaceObjCmd(clientData, interp, objc, objv) int i; char **argv; - argv = (char **)Tcl_Alloc(sizeof(char *) * (objc + 1)); + /* argv = (char **)Tcl_Alloc(sizeof(char *) * (objc + 1)); */ + argv = (char **)ckalloc(sizeof(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]); */ @@ -4751,7 +5391,15 @@ ip_rbNamespaceObjCmd(clientData, interp, objc, objv) ret = (*(info.proc))(info.clientData, interp, objc, (CONST84 char **)argv); - Tcl_Free((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 */ +#endif + /* Tcl_Free((char*)argv); */ + ckfree((char*)argv); +#endif } DUMP2("namespace wrapper exit depth == %d", rbtk_eventloop_depth); @@ -4822,15 +5470,25 @@ ip_init(argc, argv, self) Tk_Window mainWin = (Tk_Window)NULL; /* security check */ +#ifdef RUBY_VM if (rb_safe_level() >= 4) { +#else + if (ruby_safe_level >= 4) { +#endif rb_raise(rb_eSecurityError, "Cannot create a TclTkIp object at level %d", - rb_safe_level()); +#ifdef RUBY_VM + rb_safe_level() +#else + ruby_safe_level +#endif + ); } /* create object */ Data_Get_Struct(self, struct tcltkip, ptr); ptr = ALLOC(struct tcltkip); + /* ptr = (struct tcltkip *)ckalloc(sizeof(struct tcltkip)); */ DATA_PTR(self) = ptr; #ifdef RUBY_VM ptr->tk_thread_id = 0; @@ -4943,7 +5601,8 @@ ip_init(argc, argv, self) #endif #ifdef RUBY_VM - ptr->tk_thread_id = Tcl_GetCurrentThread(); + /* set Tk thread ID */ + ptr->tk_thread_id = Tcl_GetCurrentThread(); #endif /* get main window */ mainWin = Tk_MainWindow(ptr->ip); @@ -5008,7 +5667,7 @@ ip_init(argc, argv, self) if (mainWin != (Tk_Window)NULL) { Tk_Release((ClientData)mainWin); } - + return self; } @@ -5020,6 +5679,7 @@ ip_create_slave_core(interp, argc, argv) { struct tcltkip *master = get_ip(interp); struct tcltkip *slave = ALLOC(struct tcltkip); + /* struct tcltkip *slave = (struct tcltkip *)ckalloc(sizeof(struct tcltkip)); */ VALUE safemode; VALUE name; int safe; @@ -5062,6 +5722,10 @@ ip_create_slave_core(interp, argc, argv) #endif /* create slave-ip */ +#ifdef RUBY_VM + /* 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; @@ -5350,6 +6014,12 @@ ip_allow_ruby_exit_set(self, val) "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)) { @@ -5446,8 +6116,10 @@ ip_is_deleted_p(self) } static VALUE -ip_has_mainwindow_p(self) +ip_has_mainwindow_p_core(self, argc, argv) VALUE self; + int argc; /* dummy */ + VALUE *argv; /* dummy */ { struct tcltkip *ptr = get_ip(self); @@ -5460,6 +6132,14 @@ ip_has_mainwindow_p(self) } } +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 @@ -5469,12 +6149,16 @@ get_str_from_obj(obj) int len, binary = 0; const char *s; volatile VALUE str; +#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 4) + int len2; + const char *s2; +#endif #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 s = Tcl_GetStringFromObj(obj, &len); #else -#if 0 - /* TCL_VERSION >= 8.1 */ +#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 = Tcl_GetByteArrayFromObj(obj, &len); @@ -5483,29 +6167,30 @@ get_str_from_obj(obj) /* possibly text string */ s = Tcl_GetStringFromObj(obj, &len); } -#else -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 4 - if (Tcl_GetCharLength(obj) != Tcl_UniCharLen(Tcl_GetUnicode(obj))) { - /* possibly binary string */ - s = Tcl_GetByteArrayFromObj(obj, &len); - binary = 1; +#else /* TCL_VERSION >= 8.4 */ + if (IS_TCL_BYTEARRAY(obj)) { + s = Tcl_GetByteArrayFromObj(obj, &len); + binary = 1; } else { - /* possibly text string */ - s = Tcl_GetStringFromObj(obj, &len); - } -#else /* TCL_VERSION >= 8.5 */ - /* TODO: Known BUG: - Tcl_GetByteArrayFromObj() returns "alloc: invalid block" */ - if (Tcl_GetCharLength(obj) != Tcl_UniCharLen(Tcl_GetUnicode(obj))) { - /* possibly binary string */ - binary = 1; + s = Tcl_GetStringFromObj(obj, &len); } - s = Tcl_GetStringFromObj(obj, &len); -#endif + #endif #endif str = s ? rb_str_new(s, len) : rb_str_new2(""); - if (binary) rb_ivar_set(str, ID_at_enc, rb_str_new2("binary")); + if (binary) { +#ifdef RUBY_VM + 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 RUBY_VM + rb_enc_associate_index(str, ENCODING_INDEX_UTF8); +#endif + rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8); +#endif + } return str; } @@ -5529,6 +6214,11 @@ get_obj_from_str(str) /* text string */ return Tcl_NewStringObj(s, RSTRING_LEN(str)); } +#ifdef RUBY_VM + } else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) { + /* binary string */ + return Tcl_NewByteArrayObj(s, RSTRING_LEN(str)); +#endif } else if (strlen(s) != RSTRING_LEN(str)) { /* probably binary string */ return Tcl_NewByteArrayObj(s, RSTRING_LEN(str)); @@ -5589,6 +6279,7 @@ call_queue_handler(evPtr, flags) DUMP2("call_queue_handler thread : %lx", rb_thread_current()); DUMP2("added by thread : %lx", q->thread); + if (*(q->done)) { DUMP1("processed by another event-loop"); return 0; @@ -5606,10 +6297,13 @@ call_queue_handler(evPtr, flags) 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(rb_cData,call_queue_mark,0,q); + /* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */ + q_dat = Data_Wrap_Struct(rb_cData,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); @@ -5622,6 +6316,9 @@ call_queue_handler(evPtr, flags) /* set result */ RARRAY_PTR(q->result)[0] = ret; + /* decr internal handler mark */ + rbtk_internal_eventloop_handler--; + /* complete */ *(q->done) = -1; @@ -5629,8 +6326,16 @@ call_queue_handler(evPtr, flags) if (RTEST(rb_funcall(q->thread, ID_alive_p, 0, 0))) { DUMP2("back to caller (caller thread:%lx)", q->thread); DUMP2(" (current thread:%lx)", rb_thread_current()); +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE + have_rb_thread_waited_for_value = 1; + rb_thread_wakeup(q->thread); +#else rb_thread_run(q->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:%lx)", q->thread); DUMP2(" (current thread:%lx)", rb_thread_current()); @@ -5648,32 +6353,39 @@ tk_funcall(func, argc, argv, obj) VALUE obj; { struct call_queue *callq; -#ifdef RUBY_VM struct tcltkip *ptr; -#endif 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; - - if (!NIL_P(ip_obj) && deleted_ip(get_ip(ip_obj))) { - return Qnil; + 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_VM - ptr = get_ip(ip_obj); + 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 ( -#ifdef RUBY_VM - (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread()) - && -#endif - (NIL_P(eventloop_thread) || current == eventloop_thread) - ) { + if (is_tk_evloop_thread + && (NIL_P(eventloop_thread) || current == eventloop_thread) + ) { if (NIL_P(eventloop_thread)) { DUMP2("tk_funcall from thread:%lx but no eventloop", current); } else { @@ -5693,18 +6405,29 @@ tk_funcall(func, argc, argv, obj) /* allocate memory (argv cross over thread : must be in heap) */ if (argv) { - VALUE *temp = ALLOC_N(VALUE, argc); + /* VALUE *temp = ALLOC_N(VALUE, argc); */ + VALUE *temp = (VALUE*)ckalloc(sizeof(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 = (int*)ALLOC(int); */ + alloc_done = (int*)ckalloc(sizeof(int)); +#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 = (struct call_queue *)Tcl_Alloc(sizeof(struct call_queue)); */ + callq = (struct call_queue *)ckalloc(sizeof(struct call_queue)); +#if 1 /* use Tcl_Preserve/Release */ Tcl_Preserve(callq); +#endif /* allocate result obj */ result = rb_ary_new3(1, Qnil); @@ -5723,9 +6446,13 @@ tk_funcall(func, argc, argv, obj) /* add the handler to Tcl event queue */ DUMP1("add handler"); #ifdef RUBY_VM - if (ptr->tk_thread_id) { + if (ptr && ptr->tk_thread_id) { Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(callq->ev), 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_ThreadAlert(tk_eventloop_thread_id); } else { Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); } @@ -5739,22 +6466,47 @@ tk_funcall(func, argc, argv, obj) DUMP2("wait for handler (current thread:%lx)", current); while(*alloc_done >= 0) { DUMP2("*** wait for handler (current thread:%lx)", current); - rb_thread_stop(); + rb_thread_stop(); DUMP2("*** wakeup (current thread:%lx)", current); } DUMP2("back from handler (current thread:%lx)", current); /* get result & free allocated memory */ ret = RARRAY_PTR(result)[0]; - free(alloc_done); - if (argv) free(argv); +#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 */ +#endif + /* free(alloc_done); */ + ckfree((char*)alloc_done); +#endif + /* if (argv) free(argv); */ + if (argv) { + /* if argv != NULL, alloc as 'temp' */ +#if 0 /* use Tcl_EventuallyFree */ + Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ +#else +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Release((ClientData)argv); /* XXXXXXXX */ +#endif + ckfree((char*)argv); +#endif + } +#if 1 /* use Tcl_Preserve/Release */ Tcl_Release(callq); +#else + ckfree((char*)callq); +#endif /* exception? */ if (rb_obj_is_kind_of(ret, rb_eException)) { DUMP1("raise exception"); - rb_exc_raise(ret); + /* rb_exc_raise(ret); */ + rb_exc_raise(rb_exc_new3(rb_obj_class(ret), + rb_funcall(ret, ID_to_s, 0, 0))); } DUMP1("exit tk_funcall"); @@ -5825,19 +6577,35 @@ ip_eval_real(self, cmd_str, cmd_len) ret = rb_protect(call_tcl_eval, (VALUE)&inf, &status); switch(status) { case TAG_RAISE: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif rbtk_pending_exception = rb_exc_new2(rb_eException, "unknown exception"); } else { +#ifdef RUBY_VM rbtk_pending_exception = rb_errinfo(); +#else + rbtk_pending_exception = ruby_errinfo; +#endif } break; case TAG_FATAL: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL"); } else { +#ifdef RUBY_VM rbtk_pending_exception = rb_errinfo(); +#else + rbtk_pending_exception = ruby_errinfo; +#endif } } #endif @@ -5960,17 +6728,26 @@ eval_queue_handler(evPtr, flags) return 1; } + /* incr internal handler mark */ + rbtk_internal_eventloop_handler++; + /* check safe-level */ if (rb_safe_level() != q->safe_level) { -#if 0 #ifdef HAVE_NATIVETHREAD - if (!ruby_native_thread_p()) { - rb_bug("cross-thread violation on eval_queue_handler()"); - } +#ifdef RUBY_VM +#if 0 + if (!ruby_native_thread_p()) { + rb_bug("cross-thread violation on eval_queue_handler()"); + } +#endif +#else + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on eval_queue_handler()"); + } #endif #endif - /* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */ - q_dat = Data_Wrap_Struct(rb_cData,eval_queue_mark,0,q); + /* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */ + q_dat = Data_Wrap_Struct(rb_cData,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); @@ -5981,6 +6758,9 @@ eval_queue_handler(evPtr, flags) /* set result */ RARRAY_PTR(q->result)[0] = ret; + /* decr internal handler mark */ + rbtk_internal_eventloop_handler--; + /* complete */ *(q->done) = -1; @@ -5988,8 +6768,16 @@ eval_queue_handler(evPtr, flags) if (RTEST(rb_funcall(q->thread, ID_alive_p, 0, 0))) { DUMP2("back to caller (caller thread:%lx)", q->thread); DUMP2(" (current thread:%lx)", rb_thread_current()); +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE + have_rb_thread_waited_for_value = 1; + rb_thread_wakeup(q->thread); +#else rb_thread_run(q->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:%lx)", q->thread); DUMP2(" (current thread:%lx)", rb_thread_current()); @@ -6051,16 +6839,27 @@ ip_eval(self, str) rb_thread_critical = Qtrue; /* allocate memory (protected from Tcl_ServiceEvent) */ - alloc_done = (int*)ALLOC(int); + /* alloc_done = (int*)ALLOC(int); */ + alloc_done = (int*)ckalloc(sizeof(int)); +#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 = ALLOC_N(char, RSTRING_LEN(str) + 1); */ + eval_str = ckalloc(sizeof(char) * (RSTRING_LEN(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 = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); */ + evq = (struct eval_queue *)ckalloc(sizeof(struct eval_queue)); +#if 1 /* use Tcl_Preserve/Release */ Tcl_Preserve(evq); +#endif /* allocate result obj */ result = rb_ary_new3(1, Qnil); @@ -6096,7 +6895,7 @@ ip_eval(self, str) DUMP2("wait for handler (current thread:%lx)", current); while(*alloc_done >= 0) { DUMP2("*** wait for handler (current thread:%lx)", current); - rb_thread_stop(); + rb_thread_stop(); DUMP2("*** wakeup (current thread:%lx)", current); } DUMP2("back from handler (current thread:%lx)", current); @@ -6104,12 +6903,35 @@ ip_eval(self, str) /* get result & free allocated memory */ ret = RARRAY_PTR(result)[0]; - free(alloc_done); - free(eval_str); +#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 */ +#endif + /* free(alloc_done); */ + ckfree((char*)alloc_done); +#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 */ +#endif + /* free(eval_str); */ + ckfree(eval_str); +#endif +#if 1 /* use Tcl_Preserve/Release */ Tcl_Release(evq); +#else + ckfree((char*)evq); +#endif if (rb_obj_is_kind_of(ret, rb_eException)) { - rb_exc_raise(ret); + DUMP1("raise exception"); + /* rb_exc_raise(ret); */ + rb_exc_raise(rb_exc_new3(rb_obj_class(ret), + rb_funcall(ret, ID_to_s, 0, 0))); } return ret; @@ -6264,7 +7086,12 @@ lib_toUTF8_core(ip_obj, src, encodename) if (NIL_P(encodename)) { if (TYPE(str) == T_STRING) { volatile VALUE enc; + +#ifdef RUBY_VM + enc = rb_funcall(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; @@ -6283,6 +7110,10 @@ lib_toUTF8_core(ip_obj, src, encodename) } else { StringValue(enc); if (strcmp(RSTRING_PTR(enc), "binary") == 0) { +#ifdef RUBY_VM + 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; } @@ -6296,6 +7127,14 @@ lib_toUTF8_core(ip_obj, src, encodename) } } else { StringValue(encodename); + if (strcmp(RSTRING_PTR(encodename), "binary") == 0) { +#ifdef RUBY_VM + 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)); if (encoding == (Tcl_Encoding)NULL) { /* @@ -6312,7 +7151,8 @@ lib_toUTF8_core(ip_obj, src, encodename) rb_thread_critical = thr_crit_bup; return str; } - buf = ALLOC_N(char,RSTRING_LEN(str)+1); + buf = ALLOC_N(char, RSTRING_LEN(str)+1); + /* buf = ckalloc(sizeof(char) * (RSTRING_LEN(str)+1)); */ memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str)); buf[RSTRING_LEN(str)] = 0; @@ -6324,7 +7164,10 @@ lib_toUTF8_core(ip_obj, src, encodename) /* 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)); - rb_ivar_set(str, ID_at_enc, rb_tainted_str_new2("utf-8")); +#ifdef RUBY_VM + rb_enc_associate_index(str, ENCODING_INDEX_UTF8); +#endif + rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8); if (taint_flag) OBJ_TAINT(str); if (encoding != (Tcl_Encoding)NULL) { @@ -6333,6 +7176,7 @@ lib_toUTF8_core(ip_obj, src, encodename) Tcl_DStringFree(&dstr); free(buf); + /* ckfree(buf); */ rb_thread_critical = thr_crit_bup; #endif @@ -6411,9 +7255,20 @@ lib_fromUTF8_core(ip_obj, src, encodename) if (!NIL_P(enc)) { StringValue(enc); if (strcmp(RSTRING_PTR(enc), "binary") == 0) { +#ifdef RUBY_VM + 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 RUBY_VM + } 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 } } @@ -6446,7 +7301,10 @@ lib_fromUTF8_core(ip_obj, src, encodename) RSTRING_LEN(str)), &len); str = rb_tainted_str_new(s, len); - rb_ivar_set(str, ID_at_enc, rb_tainted_str_new2("binary")); +#ifdef RUBY_VM + 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; @@ -6471,7 +7329,8 @@ lib_fromUTF8_core(ip_obj, src, encodename) return rb_tainted_str_new2(""); } - buf = ALLOC_N(char,strlen(RSTRING_PTR(str))+1); + buf = ALLOC_N(char, RSTRING_LEN(str)+1); + /* buf = ckalloc(sizeof(char) * (RSTRING_LEN(str)+1)); */ memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str)); buf[RSTRING_LEN(str)] = 0; @@ -6483,6 +7342,19 @@ lib_fromUTF8_core(ip_obj, src, encodename) /* 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 RUBY_VM + 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 rb_ivar_set(str, ID_at_enc, encodename); if (taint_flag) OBJ_TAINT(str); @@ -6493,6 +7365,7 @@ lib_fromUTF8_core(ip_obj, src, encodename) Tcl_DStringFree(&dstr); free(buf); + /* ckfree(buf); */ rb_thread_critical = thr_crit_bup; #endif @@ -6550,11 +7423,19 @@ lib_UTF_backslash_core(self, str, all_bs) thr_crit_bup = rb_thread_critical; rb_thread_critical = Qtrue; - src_buf = ALLOC_N(char,RSTRING_LEN(str)+1); + /* src_buf = ALLOC_N(char, RSTRING_LEN(str)+1); */ + src_buf = ckalloc(sizeof(char) * (RSTRING_LEN(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 = ALLOC_N(char, RSTRING_LEN(str)+1); */ + dst_buf = ckalloc(sizeof(char) * (RSTRING_LEN(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) { @@ -6568,9 +7449,29 @@ lib_UTF_backslash_core(self, str, all_bs) str = rb_str_new(dst_buf, dst_len); if (taint_flag) OBJ_TAINT(str); +#ifdef RUBY_VM + rb_enc_associate_index(str, ENCODING_INDEX_UTF8); +#endif + rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8); - free(src_buf); - free(dst_buf); +#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 */ +#endif + /* free(src_buf); */ + ckfree(src_buf); +#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 */ +#endif + /* free(dst_buf); */ + ckfree(dst_buf); +#endif rb_thread_critical = thr_crit_bup; #endif @@ -6661,8 +7562,11 @@ invoke_tcl_proc(arg) #if TCL_MAJOR_VERSION >= 8 if (!inf->cmdinfo.isNativeObjectProc) { /* string interface */ - // argv = (char **)ALLOC_N(char *, argc+1); /* XXXXXXXXXX */ + /* argv = (char **)ALLOC_N(char *, argc+1);*/ /* XXXXXXXXXX */ argv = (char **)ckalloc(sizeof(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); } @@ -6675,7 +7579,6 @@ invoke_tcl_proc(arg) /* Invoke the C procedure */ #if TCL_MAJOR_VERSION >= 8 if (inf->cmdinfo.isNativeObjectProc) { - int ret_val; inf->ptr->return_value = (*(inf->cmdinfo.objProc))(inf->cmdinfo.objClientData, inf->ptr->ip, inf->objc, inf->objv); @@ -6688,8 +7591,15 @@ invoke_tcl_proc(arg) = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip, argc, (CONST84 char **)argv); - //free(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 */ +#endif + /* free(argv); */ ckfree((char*)argv); +#endif #else /* TCL_MAJOR_VERSION < 8 */ inf->ptr->return_value @@ -6745,6 +7655,9 @@ ip_invoke_core(interp, argc, argv) cmd = argv[0]; #endif + /* get the data struct */ + ptr = get_ip(interp); + /* ip is deleted? */ if (deleted_ip(ptr)) { return rb_tainted_str_new2(""); @@ -6794,15 +7707,22 @@ ip_invoke_core(interp, argc, argv) unknown_flag = 1; #if TCL_MAJOR_VERSION >= 8 - //unknown_objv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, objc+2); + /* unknown_objv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, objc+2); */ unknown_objv = (Tcl_Obj **)ckalloc(sizeof(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 = (char **)ALLOC_N(char *, argc+2); */ + unknown_argv = (char **)ckalloc(sizeof(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; @@ -6831,19 +7751,35 @@ ip_invoke_core(interp, argc, argv) ret = rb_protect(invoke_tcl_proc, (VALUE)&inf, &status); switch(status) { case TAG_RAISE: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif rbtk_pending_exception = rb_exc_new2(rb_eException, "unknown exception"); } else { +#ifdef RUBY_VM rbtk_pending_exception = rb_errinfo(); +#else + rbtk_pending_exception = ruby_errinfo; +#endif } break; case TAG_FATAL: +#ifdef RUBY_VM if (NIL_P(rb_errinfo())) { +#else + if (NIL_P(ruby_errinfo)) { +#endif rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL"); } else { +#ifdef RUBY_VM rbtk_pending_exception = rb_errinfo(); +#else + rbtk_pending_exception = ruby_errinfo; +#endif } } @@ -6855,8 +7791,11 @@ ip_invoke_core(interp, argc, argv) int i; /* string interface */ - //argv = (char **)ALLOC_N(char *, argc+1); + /* argv = (char **)ALLOC_N(char *, argc+1); */ argv = (char **)ckalloc(sizeof(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); } @@ -6885,8 +7824,15 @@ ip_invoke_core(interp, argc, argv) ptr->return_value = (*info.proc)(info.clientData, ptr->ip, argc, (CONST84 char **)argv); - //free(argv); - ckfree(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 */ +#endif + /* free(argv); */ + ckfree((char*)argv); +#endif #else /* TCL_MAJOR_VERSION < 8 */ ptr->return_value = (*info.proc)(info.clientData, ptr->ip, @@ -6899,10 +7845,27 @@ ip_invoke_core(interp, argc, argv) if (unknown_flag) { #if TCL_MAJOR_VERSION >= 8 Tcl_DecrRefCount(objv[0]); - free(objv); +#if 0 /* use Tcl_EventuallyFree */ + Tcl_EventuallyFree((ClientData)objv, TCL_DYNAMIC); /* XXXXXXXX */ +#else +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Release((ClientData)objv); /* XXXXXXXX */ +#endif + /* free(objv); */ + ckfree((char*)objv); +#endif #else free(argv[0]); - free(argv); + /* 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 */ +#endif + /* free(argv); */ + ckfree((char*)argv); +#endif #endif } @@ -6957,8 +7920,11 @@ alloc_invoke_arguments(argc, argv) /* memory allocation */ #if TCL_MAJOR_VERSION >= 8 - //av = ALLOC_N(Tcl_Obj *, argc+1); /* XXXXXXXXXX */ + /* av = ALLOC_N(Tcl_Obj *, argc+1);*/ /* XXXXXXXXXX */ av = (Tcl_Obj**)ckalloc(sizeof(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]); @@ -6967,7 +7933,11 @@ alloc_invoke_arguments(argc, argv) #else /* TCL_MAJOR_VERSION < 8 */ /* string interface */ - av = ALLOC_N(char *, argc+1); + /* av = ALLOC_N(char *, argc+1); */ + av = (char**)ckalloc(sizeof(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])); } @@ -6998,9 +7968,24 @@ free_invoke_arguments(argc, av) #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 */ +#endif ckfree((char*)av); +#endif #else /* TCL_MAJOR_VERSION < 8 */ - free(av); +#if 0 /* use Tcl_EventuallyFree */ + Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC); /* XXXXXXXX */ +#else +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Release((ClientData)av); /* XXXXXXXX */ +#endif + /* free(av); */ + ckfree((char*)av); +#endif #endif } @@ -7064,6 +8049,7 @@ invoke_queue_handler(evPtr, flags) struct invoke_queue *q = (struct invoke_queue *)evPtr; volatile VALUE ret; volatile VALUE q_dat; + struct tcltkip *ptr; DUMP2("do_invoke_queue_handler : evPtr = %p", evPtr); DUMP2("invoke queue_thread : %lx", rb_thread_current()); @@ -7079,10 +8065,20 @@ invoke_queue_handler(evPtr, flags) /* 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(rb_cData,invoke_queue_mark,0,q); + q_dat = Data_Wrap_Struct(rb_cData,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); @@ -7095,6 +8091,9 @@ invoke_queue_handler(evPtr, flags) /* set result */ RARRAY_PTR(q->result)[0] = ret; + /* decr internal handler mark */ + rbtk_internal_eventloop_handler--; + /* complete */ *(q->done) = -1; @@ -7102,8 +8101,16 @@ invoke_queue_handler(evPtr, flags) if (RTEST(rb_funcall(q->thread, ID_alive_p, 0, 0))) { DUMP2("back to caller (caller thread:%lx)", q->thread); DUMP2(" (current thread:%lx)", rb_thread_current()); +#if CONTROL_BY_STATUS_OF_RB_THREAD_WAIT_FOR_VALUE + have_rb_thread_waited_for_value = 1; + rb_thread_wakeup(q->thread); +#else rb_thread_run(q->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:%lx)", q->thread); DUMP2(" (current thread:%lx)", rb_thread_current()); @@ -7143,8 +8150,8 @@ ip_invoke_with_position(argc, argv, obj, position) #ifdef RUBY_VM ptr = get_ip(ip_obj); -#endif DUMP2("status: ptr->tk_thread_id %d", ptr->tk_thread_id); +#endif DUMP2("status: Tcl_GetCurrentThread %d", Tcl_GetCurrentThread()); DUMP2("status: eventloopt_thread %lx", eventloop_thread); @@ -7167,6 +8174,8 @@ ip_invoke_with_position(argc, argv, obj, position) return result; } + DUMP2("invoke from thread %lx (NOT current eventloop)", current); + thr_crit_bup = rb_thread_critical; rb_thread_critical = Qtrue; @@ -7174,13 +8183,19 @@ ip_invoke_with_position(argc, argv, obj, position) av = alloc_invoke_arguments(argc, argv); /* allocate memory (keep result) */ - //alloc_done = (int*)ALLOC(int); + /* alloc_done = (int*)ALLOC(int); */ alloc_done = (int*)ckalloc(sizeof(int)); +#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 = (struct invoke_queue *)ckalloc(sizeof(struct invoke_queue)); - Tcl_Preserve(ivq); +#if 1 /* use Tcl_Preserve/Release */ + Tcl_Preserve((ClientData)ivq); /* XXXXXXXX */ +#endif /* allocate result obj */ result = rb_ary_new3(1, Qnil); @@ -7213,16 +8228,31 @@ ip_invoke_with_position(argc, argv, obj, position) /* wait for the handler to be processed */ DUMP2("wait for handler (current thread:%lx)", current); while(*alloc_done >= 0) { - rb_thread_stop(); + rb_thread_stop(); } DUMP2("back from handler (current thread:%lx)", current); /* get result & free allocated memory */ - ret = RARRAY_PTR(result)[0]; - //free(alloc_done); + ret = RARRAY(result)->ptr[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 */ +#endif + /* free(alloc_done); */ ckfree((char*)alloc_done); +#endif +#if 0 /* use Tcl_EventuallyFree */ + Tcl_EventuallyFree((ClientData)ivq, TCL_DYNAMIC); /* XXXXXXXX */ +#else +#if 1 /* use Tcl_Preserve/Release */ Tcl_Release(ivq); +#else + ckfree((char*)ivq); +#endif +#endif /* free allocated memory */ free_invoke_arguments(argc, av); @@ -7230,9 +8260,12 @@ ip_invoke_with_position(argc, argv, obj, position) /* exception? */ if (rb_obj_is_kind_of(ret, rb_eException)) { DUMP1("raise exception"); - rb_exc_raise(ret); + /* rb_exc_raise(ret); */ + rb_exc_raise(rb_exc_new3(rb_obj_class(ret), + rb_funcall(ret, ID_to_s, 0, 0))); } + DUMP1("exit ip_invoke"); return ret; } @@ -7692,6 +8725,10 @@ lib_split_tklist_core(ip_obj, list_str) volatile VALUE ary, elem; int idx; int taint_flag = OBJ_TAINTED(list_str); +#ifdef RUBY_VM + int list_enc_idx; + volatile VALUE list_ivar_enc; +#endif int result; VALUE old_gc; @@ -7706,6 +8743,10 @@ lib_split_tklist_core(ip_obj, list_str) } StringValue(list_str); +#ifdef RUBY_VM + 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 @@ -7744,10 +8785,22 @@ lib_split_tklist_core(ip_obj, list_str) for(idx = 0; idx < objc; idx++) { elem = get_str_from_obj(objv[idx]); +#ifdef RUBY_VM + 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 if (taint_flag) OBJ_TAINT(elem); + /* 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; @@ -7784,8 +8837,11 @@ lib_split_tklist_core(ip_obj, list_str) elem = rb_str_new2(argv[idx]); } /* rb_ivar_set(elem, ID_at_enc, rb_str_new2("binary")); */ - rb_ary_push(ary, elem); + /* RARRAY(ary)->ptr[idx] = elem; */ + rb_ary_push(ary, elem) } + /* RARRAY(ary)->len = argc; */ + if (old_gc == Qfalse) rb_gc_enable(); #endif } @@ -7833,7 +8889,11 @@ lib_merge_tklist(argc, argv, obj) old_gc = rb_gc_disable(); /* based on Tcl/Tk's Tcl_Merge() */ - flagPtr = ALLOC_N(int, argc); + /* flagPtr = ALLOC_N(int, argc); */ + flagPtr = (int *)ckalloc(sizeof(int) * argc); +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Preserve((ClientData)flagPtr); /* XXXXXXXXXX */ +#endif /* pass 1 */ len = 1; @@ -7841,7 +8901,7 @@ lib_merge_tklist(argc, argv, obj) if (OBJ_TAINTED(argv[num])) taint_flag = 1; dst = StringValuePtr(argv[num]); #if TCL_MAJOR_VERSION >= 8 - len += Tcl_ScanCountedElement(dst, RSTRING_LEN(argv[num]), + len += Tcl_ScanCountedElement(dst, RSTRING_LEN(argv[num]), &flagPtr[num]) + 1; #else /* TCL_MAJOR_VERSION < 8 */ len += Tcl_ScanElement(dst, &flagPtr[num]) + 1; @@ -7849,7 +8909,11 @@ lib_merge_tklist(argc, argv, obj) } /* 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 @@ -7869,12 +8933,28 @@ lib_merge_tklist(argc, argv, obj) dst[-1] = 0; } - free(flagPtr); +#if 0 /* use Tcl_EventuallyFree */ + Tcl_EventuallyFree((ClientData)flagPtr, TCL_DYNAMIC); /* XXXXXXXX */ +#else +#if 0 /* use Tcl_Preserve/Release */ + Tcl_Release((ClientData)flagPtr); +#endif + /* free(flagPtr); */ + ckfree((char*)flagPtr); +#endif /* create object */ str = rb_str_new(result, dst - result - 1); if (taint_flag) OBJ_TAINT(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 */ +#endif + /* Tcl_Free(result); */ ckfree(result); +#endif if (old_gc == Qfalse) rb_gc_enable(); rb_thread_critical = thr_crit_bup; @@ -7919,17 +8999,15 @@ lib_conv_listelement(self, src) return dst; } - static VALUE lib_getversion(self) VALUE self; { - int major, minor, patchlevel, type; volatile VALUE type_name; - Tcl_GetVersion(&major, &minor, &patchlevel, &type); + set_tcltk_version(); - switch(type) { + switch(tcltk_version.type) { case TCL_ALPHA_RELEASE: type_name = rb_str_new2("alpha"); break; @@ -7943,9 +9021,10 @@ lib_getversion(self) type_name = rb_str_new2("unknown"); } - return rb_ary_new3(5, INT2NUM(major), INT2NUM(minor), - INT2NUM(type), type_name, - INT2NUM(patchlevel)); + return rb_ary_new3(5, INT2NUM(tcltk_version.major), + INT2NUM(tcltk_version.minor), + INT2NUM(tcltk_version.type), type_name, + INT2NUM(tcltk_version.patchlevel)); } @@ -7970,6 +9049,7 @@ tcltklib_compile_info() + strlen("unknown tcl_threads"); info = ALLOC_N(char, size); + /* info = ckalloc(sizeof(char) * size); */ /* SEGV */ sprintf(info, form, TCLTKLIB_RELEASE_DATE, @@ -8005,10 +9085,527 @@ tcltklib_compile_info() ret = rb_obj_freeze(rb_str_new2(info)); free(info); + /* ckfree(info); */ return ret; } + +/*###############################################*/ + +static VALUE +create_dummy_encoding_for_tk_core(interp, name, error_mode) + VALUE interp; + VALUE name; + VALUE error_mode; +{ + struct tcltkip *ptr = get_ip(interp); + + rb_secure(4); + + StringValue(name); + +#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) + if (Tcl_GetEncoding(ptr->ip, 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 RUBY_VM + 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; + } + } +#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 RUBY_VM +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_funcall(interp, ID_encoding_name, 0, 0); + } + } + /* 2nd: encoding system of Tcl/Tk */ + if (NIL_P(enc)) { + enc = rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL)); + } + /* 3rd: Encoding.default_external */ + if (NIL_P(enc)) { + enc = rb_enc_default_external(); + } + + 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_funcall(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_funcall(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 /* ! RUBY_VM */ +#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, 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; + } + + /* 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; + int retry = 0; + + enc = rb_funcall(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 RUBY_VM +static VALUE +create_encoding_table(interp) + 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; + + rb_secure(4); + + /* 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 /* ! RUBY_VM */ +#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) +static VALUE +create_encoding_table(interp) + 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; + + rb_secure(4); + + /* 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(interp) + VALUE interp; +{ + volatile VALUE table = rb_hash_new(); + rb_secure(4); + rb_ivar_set(interp, ID_encoding_table, table); + return table; +} +#endif +#endif + +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; +} + + /*###############################################*/ /* @@ -8047,26 +9644,29 @@ struct dummy_TkMenuRef { char *dummy3; }; -#if 0 +#if 0 /* was available on Tk8.0 -- Tk8.4 */ EXTERN struct dummy_TkMenuRef *TkFindMenuReferences(Tcl_Interp*, char*); -#else -#define MENU_HASH_KEY "tkMenus" /* based on Tk8.0 - Tk8.5b1 */ +#else /* based on Tk8.0 -- Tk8.5.0 */ +#define MENU_HASH_KEY "tkMenus" #endif #endif static VALUE -ip_make_menu_embeddable(interp, menu_path) +ip_make_menu_embeddable_core(interp, argc, argv) VALUE interp; - VALUE menu_path; + 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 */ @@ -8131,6 +9731,18 @@ ip_make_menu_embeddable(interp, menu_path) 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 ----*/ @@ -8152,6 +9764,22 @@ Init_tcltklib() /* --------------------------------------------------------------- */ +#ifdef RUBY_VM + rb_global_variable(&cRubyEncoding); + cRubyEncoding = rb_const_get(rb_cObject, rb_intern("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); @@ -8229,6 +9857,8 @@ Init_tcltklib() 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?"); ID_alive_p = rb_intern("alive?"); @@ -8262,8 +9892,10 @@ Init_tcltklib() 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_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); @@ -8325,6 +9957,12 @@ Init_tcltklib() /* --------------------------------------------------------------- */ + 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); @@ -8384,7 +10022,11 @@ Init_tcltklib() /* if ruby->nativethread-supprt and tcltklib->doen't, the following will cause link-error. */ +#ifdef RUBY_VM ruby_native_thread_p(); +#else + is_ruby_native_thread(); +#endif /* --------------------------------------------------------------- */ @@ -8405,6 +10047,11 @@ Init_tcltklib() } /* --------------------------------------------------------------- */ + + Tcl_ObjType_ByteArray = Tcl_GetObjType(Tcl_ObjTypeName_ByteArray); + Tcl_ObjType_String = Tcl_GetObjType(Tcl_ObjTypeName_String); + + /* --------------------------------------------------------------- */ } /* eof */ |