diff options
Diffstat (limited to 'ext/tcltklib')
| -rw-r--r-- | ext/tcltklib/MANIFEST | 2 | ||||
| -rw-r--r-- | ext/tcltklib/MANUAL.eng | 569 | ||||
| -rw-r--r-- | ext/tcltklib/MANUAL.euc | 114 | ||||
| -rw-r--r-- | ext/tcltklib/README.1st | 2 | ||||
| -rw-r--r-- | ext/tcltklib/demo/lines3.rb | 54 | ||||
| -rw-r--r-- | ext/tcltklib/demo/lines4.rb | 54 | ||||
| -rw-r--r-- | ext/tcltklib/extconf.rb | 76 | ||||
| -rw-r--r-- | ext/tcltklib/tcltklib.c | 3614 |
8 files changed, 3902 insertions, 583 deletions
diff --git a/ext/tcltklib/MANIFEST b/ext/tcltklib/MANIFEST index e06547a6aa..e408dc3ee8 100644 --- a/ext/tcltklib/MANIFEST +++ b/ext/tcltklib/MANIFEST @@ -11,6 +11,8 @@ lib/tcltk.rb demo/lines0.tcl demo/lines1.rb demo/lines2.rb +demo/lines3.rb +demo/lines4.rb demo/safeTk.rb sample/sample0.rb sample/sample1.rb diff --git a/ext/tcltklib/MANUAL.eng b/ext/tcltklib/MANUAL.eng index a037d18d41..20e966d223 100644 --- a/ext/tcltklib/MANUAL.eng +++ b/ext/tcltklib/MANUAL.eng @@ -1,5 +1,5 @@ (tof) - 2003/10/17 Hidetoshi NAGAI + 2004/03/28 Hidetoshi NAGAI This document discribes about the 'tcltklib' library. Although there is the 'tcltk' library (tcltk.rb) under this directory, no description @@ -41,224 +41,367 @@ module TclTklib : a target event. With this flag, doesn't wait and returns : false if there is no target event for processing. - [module methods] - mainloop(check_root = true) - : Starts the eventloop. If 'check_root' is true, this method - : doesn't return when a root widget exists. - : If 'check_root' is false, doen't return by the other - : reasons than exceptions. - - mainloop_watchdog(check_root = true) - : On the normal eventloop, some kinds of callback operations - : cause deadlock. To avoid some of such deadlocks, this - : method starts an eventloop and a watchdog-thread. - - do_one_event(flag = TclTkLib::EventFlag::ALL | - TclTkLib::EventFlag::DONT_WAIT) - : Do one event for processing. When processed an event, - : returns true. - : If NOT set DONT_WAIT flag, this method waits occurrence of - : a target event. - : If set DONT_WAIT flag and no event for processing, returns - : false immediately. - : If $SAFE >= 4, or $SAFE >= 1 and the flag is tainted, - : force to set DONT_WAIT flag. - - set_eventloop_tick(timer_tick) - : Define the interval of thread-switching with an integer - : value of mili-seconds. - : Default timer_tick is 0. It means that thread-switching - : is based on the count of processed events. - : ( see 'set_eventloop_weight' method ) - : However, if the eventloop thread is the only thread, - : timer_tick cannt be set to 0. If 0, then is set to 100 ms - : automatically (see NO_THREAD_INTERRUPT_TIME on tcltklib.c). - : On $SAFE >= 4, cannot call this method. - - get_eventloop_tick - : Get current value of 'timer_tick' - - set_no_event_wait(no_event_wait) - : Define sleeping time of the eventloop when two or more - : thread are running and there is no event for processing. - : Default value is 20 (ms). - : If the eventloop thread is the only thread, this value is - : invalid. - : On $SAFE >= 4, cannot call this method. - - get_no_event_wait - : Get current value of 'no_event_wait'. - - set_eventloop_weight(loop_max, no_event_tick) - : Define the weight parameters for the eventloop thread. - : That is invalid when the eventloop is the only thread. - : 'loop_max' is the max events for thread-switching. - : 'no_event_tick' is the increment value of the event count - : when no event for processing (And then, the eventloop thead - : sleeps 'no_event_wait' mili-seconds). - : 'loop_max == 800' and 'no_event_tick == 10' are defalut. - : On $SAFE >= 4, cannot call this method. - - get_eventloop_weight - : Get current values of 'loop_max' and 'no_event_tick'. - - mainloop_abort_on_exception=(bool) - : Define whether the eventloop stops on exception or not. - : If true (default value), stops on exception. - : If false, show a warinig message but ignore the exception. - : If nil, no warning message and ignore the excepsion. - : This parameter is sometimes useful when multiple Tk - : interpreters are working. Because the only one eventloop - : admins all Tk interpreters, sometimes exception on a - : interpreter kills the eventloop thread. Even if such - : situation, when abort_on_exception == false or nil, - : the eventloop ignores the exception and continue to working. - : On $SAFE >= 4, cannot call this method. - - mainloop_abort_on_exception - : Get current status of that. - - num_of_mainwindows - : Returns the number of main-windows (root-widget). - : Because there is only one main-window for one Tk interpreter, - : the value is same to the number of interpreters which has - : available Tk functions. + module TclTkLib::VarAccessFlag + : Defines flags to give '_get_variable' and so on. When to give, + : please use bit-operator (e.g. GLOBAL_ONLY | LEAVE_ERR_MSG ). + [constants] + NONE + : Is 0. It means "set no flag". + + GLOBAL_ONLY + : (site Tcl/Tk's man page) + : Under normal circumstances the procedures look up + : variables as follows: If a procedure call is active + : in interp, a variable is looked up at the current + : level of procedure call. Otherwise, a variable is + : looked up first in the current namespace, then in + : the global namespace. However, if this bit is set + : in flags then the variable is looked up only in the + : global namespace even if there is a procedure call + : active. If both GLOBAL_ONLY and NAMESPACE_ONLY are + : given, GLOBAL_ONLY is ignored. + : + : *** ATTENTION *** + : Tcl7.6 doesn't have namespaces. So NAMESPACE_ONLY + : is defined as 0, and then GLOBAL_ONLY is available + : even if flag is (GLOBAL_ONLY | NAMESPACE_ONLY). + + NAMESPACE_ONLY + : (site Tcl/Tk's man page) + : Under normal circumstances the procedures look up + : variables as follows: If a procedure call is active + : in interp, a variable is looked up at the current + : level of procedure call. Otherwise, a variable is + : looked up first in the current namespace, then in + : the global namespace. However, if this bit is set + : in flags then the variable is looked up only in the + : current namespace even if there is a procedure call + : active. + : + : *** ATTENTION *** + : Tcl7.6 doesn't have namespaces. So NAMESPACE_ONLY + : is defined as 0. + + LEAVE_ERR_MSG + : (site Tcl/Tk's man page) + : If an error is returned and this bit is set in flags, + : then an error message will be left in the interpreter's + : result, where it can be retrieved with Tcl_GetObjResult + : or Tcl_GetStringResult. If this flag bit isn't set then + : no error message is left and the interpreter's result + : will not be modified. + + APPEND_VALUE + : (site Tcl/Tk's man page) + : If this bit is set then newValue is appended to the + : current value, instead of replacing it. If the variable + : is currently undefined, then this bit is ignored. + + LIST_ELEMENT + : (site Tcl/Tk's man page) + : If this bit is set, then newValue is converted to a + : valid Tcl list element before setting (or appending + : to) the variable. A separator space is appended before + : the new list element unless the list element is going + : to be the first element in a list or sublist (i.e. the + : variable's current value is empty, or contains the + : single character ``{'', or ends in `` }''). + + PARSE_VARNAME + : (site Tcl/Tk's man page) + : If this bit is set when calling _set_variable and so + : on, var_name argument may contain both an array and an + : element name: if the name contains an open parenthesis + : and ends with a close parenthesis, then the value + : between the parentheses is treated as an element name + : (which can have any string value) and the characters + : before the first open parenthesis are treated as the + : name of an array variable. If the flag PARSE_VARNAME + : is given, index_name argument should be 'nil' since the + : array and element names are taken from var_name. + : + : *** ATTENTION *** + : Tcl7.6 doesn't have this flag. So PARSE_VARNAME is + : defined as 0. + + [module methods] + mainloop(check_root = true) + : Starts the eventloop. If 'check_root' is true, this method + : doesn't return when a root widget exists. + : If 'check_root' is false, doen't return by the other + : reasons than exceptions. + + mainloop_watchdog(check_root = true) + : On the normal eventloop, some kinds of callback operations + : cause deadlock. To avoid some of such deadlocks, this + : method starts an eventloop and a watchdog-thread. + + do_one_event(flag = TclTkLib::EventFlag::ALL | + TclTkLib::EventFlag::DONT_WAIT) + : Do one event for processing. When processed an event, + : returns true. + : If NOT set DONT_WAIT flag, this method waits occurrence of + : a target event. + : If set DONT_WAIT flag and no event for processing, returns + : false immediately. + : If $SAFE >= 4, or $SAFE >= 1 and the flag is tainted, + : force to set DONT_WAIT flag. + + set_eventloop_tick(timer_tick) + : Define the interval of thread-switching with an integer + : value of mili-seconds. + : Default timer_tick is 0. It means that thread-switching + : is based on the count of processed events. + : ( see 'set_eventloop_weight' method ) + : However, if the eventloop thread is the only thread, + : timer_tick cannt be set to 0. If 0, then is set to 100 ms + : automatically (see NO_THREAD_INTERRUPT_TIME on tcltklib.c). + : On $SAFE >= 4, cannot call this method. + + get_eventloop_tick + : Get current value of 'timer_tick' + + set_no_event_wait(no_event_wait) + : Define sleeping time of the eventloop when two or more + : thread are running and there is no event for processing. + : Default value is 20 (ms). + : If the eventloop thread is the only thread, this value is + : invalid. + : On $SAFE >= 4, cannot call this method. + + get_no_event_wait + : Get current value of 'no_event_wait'. + + set_eventloop_weight(loop_max, no_event_tick) + : Define the weight parameters for the eventloop thread. + : That is invalid when the eventloop is the only thread. + : 'loop_max' is the max events for thread-switching. + : 'no_event_tick' is the increment value of the event count + : when no event for processing (And then, the eventloop thead + : sleeps 'no_event_wait' mili-seconds). + : 'loop_max == 800' and 'no_event_tick == 10' are defalut. + : On $SAFE >= 4, cannot call this method. + + get_eventloop_weight + : Get current values of 'loop_max' and 'no_event_tick'. + + mainloop_abort_on_exception=(bool) + : Define whether the eventloop stops on exception or not. + : If true (default value), stops on exception. + : If false, show a warinig message but ignore the exception. + : If nil, no warning message and ignore the excepsion. + : This parameter is sometimes useful when multiple Tk + : interpreters are working. Because the only one eventloop + : admins all Tk interpreters, sometimes exception on a + : interpreter kills the eventloop thread. Even if such + : situation, when abort_on_exception == false or nil, + : the eventloop ignores the exception and continue to working. + : On $SAFE >= 4, cannot call this method. + + mainloop_abort_on_exception + : Get current status of that. + + num_of_mainwindows + : Returns the number of main-windows (root-widget). + : Because there is only one main-window for one Tk interpreter, + : the value is same to the number of interpreters which has + : available Tk functions. + + _merge_tklist(str, str, ... ) + : Get a Tcl's list string from arguments with a Tcl/Tk's + : library function. Each arguemnt is converted to a valid + : Tcl list element. + + _conv_listelement(str) + : Convert the argument to a valid Tcl list element with + : Tcl/Tk's library function. + + _toUTF8(str, encoding) + _fromUTF8(str, encoding) + : Call the function (which is internal function of Tcl/Tk) to + : convert to/from a UTF8 string. + + _subst_UTF_backslash(str) + _subst_Tcl_backslash(str) + : Substitute backslash sequence with Tcl's rule (include \uhhhh; + : give a sixteen-bit hexadecimal value for Unicode character). + : _subst_Tcl_backslash method parses all backslash sequence. + : _subst_UTF_backslash method parses \uhhhh only. class TclTkIp [class methods] - new(ip_name=nil, options='') - : Generate an instance of TclTkIp class. - : If 'ip_name' argument is given as a string, it is the name - : of the Tk interpreter which is shown by 'winfo interps' - : command. - : 'options' argument accepts a string which is the command - : line options of wish; such as '-geometry' or '-use'. - : The information is used to generate the root widget of the - : interpreter. - : ( e.g. TclTkIp.new('FOO', '-geometry 500x200 -use 0x2200009') ) - : If is given nil or falsr for the 'option' argument, generates - : the Tcl interpreter without Tk library. Then the interpreter - : doesn't need GUI environment. Therefore, even if a window - : system doesn't exist or cannot be used, Ruby can control the - : Tcl interpreter and the extention libraries loaded on the - : interpreter. - - [instance methods] - create_slave(name, safe=false) - : Create a slave interpreter. - : The parent of the interpreter is the receiver of this method. - : The name of the slave interpreter is given by 'name' argument. - : The 'safe' argument decides whether the slave interpreter is - : created as a safe interpreter or not. If true, create a safe - : interpreter. Default is false. However, if the parent - : interpreter is a safe interpreter, the created interpreter is - : a safe interpreter (ignore 'safe' argument value). - : If $SAFE >= 4, can create a safe interpreter only. - - make_safe - : Make the interpreter to the safe interpreter, and returns - : self. If fail, raise RuntimeError. - - safe? - : Check whether the interpreter is the safe interpreter. - : If is the safe interpreter, returns true. - - delete - : Delete the interpreter. - : The deleted interpreter doesn't accept command and then - : raise an exception. - - deleted? - : Check whether the interpreter is already deleted. - : If deleted, returns true. - - restart - : Restart Tk part of the interpreter. - : Use this when you need Tk functions after destroying the - : root widget. - : On $SAFE >= 4, cannot call this method. - - _eval(str) - _invoke(*args) - : Estimates the arguments as a command on the Tk interpreter. - : The argument of _eval is a script of Tcl/Tk. - : Each argument of _invoke is a token of one command line of - : Tcl/Tk. - : Because the operation of _invoke doesn't through the - : command line parser of Tk interpreter, the cost of - : estimation is smaller than _eval. However, auto_load - : mechanism of the Tk interpreter doesn't work on _invoke. - : So _invoke can call only the command which already - : registered on the interpreter by 'load' command and so on. - : On _eval command, auto_load mechanism words. So if succeed - : to _eval and regist the command once, after that, the - : command can be called by _invoke. - - _toUTF8(str, encoding) - _fromUTF8(str, encoding) - : Call the function (which is internal function of Tcl/Tk) to - : convert to/from a UTF8 string. - - _thread_vwait(var_name) - _thread_tkwait(mode, target) - : 'vwait' or 'tkwait' with thread support. - : The difference from normal 'vwait' or 'tkwait' command is - : doing independent wait from the vwait stack when they are - : called on the other thread than the eventloop thread. - : In the case of Tcl/Tk's vwait / tkwait, if 2nd vwait / - : tkwait is called on waiting for 1st vwait / tkwait, - : returns the order of [2nd]->[1st] regardless of the order - : of when the wait condition was fulfilled. - : If _thread_vwait / _thread_tkwait is called on the - : eventloop thread, there is no difference from vwait / - : tkwait. But if called on the other thread than the - : eventloop, stops the thread. And when the wait condition - : is fulfilled, the thread restarts. The meaning of - : "independent from the vwait stack" is that the timing of - : restarting is independent from the waiting status of the - : other threads. That is, even if the eventloop thread is - : waiting by vwait and is not fulfilled the condition, - : _thread_vwait completes the waiting when its waiting - : condition is fulfilled and the thread which stopped by - : _thread_vwait can continue the operation. - - _return_value - : Get the last result value on the interpreter. - - mainloop - mainloop_watchdog - : If on the slave interpreter, never start an eventloop and - : returns nil. - : With the exception that, same to the TclTkLib module method - : with the same name. - - do_one_event - : With the exception that the argument is forced to set - : DONT_WAIT flag on the slave interpreter, same to - : TclTkLib#do_one_event. - - set_eventloop_tick - get_eventloop_tick - set_no_event_wait - get_no_event_wait - set_eventloop_weight - get_eventloop_weight - mainloop_abort_on_exception - mainloop_abort_on_exception= - : With the exception that it is ignored to set value on the - : slave interpreter, same to the TclTkLib module method with - : the same name. + new(ip_name=nil, options='') + : Generate an instance of TclTkIp class. + : If 'ip_name' argument is given as a string, it is the name + : of the Tk interpreter which is shown by 'winfo interps' + : command. + : 'options' argument accepts a string which is the command + : line options of wish; such as '-geometry' or '-use'. + : The information is used to generate the root widget of the + : interpreter. + : ( e.g. TclTkIp.new('FOO', '-geometry 500x200 -use 0x2200009') ) + : If is given nil or falsr for the 'option' argument, generates + : the Tcl interpreter without Tk library. Then the interpreter + : doesn't need GUI environment. Therefore, even if a window + : system doesn't exist or cannot be used, Ruby can control the + : Tcl interpreter and the extention libraries loaded on the + : interpreter. + + [instance methods] + create_slave(name, safe=false) + : Create a slave interpreter. + : The parent of the interpreter is the receiver of this method. + : The name of the slave interpreter is given by 'name' argument. + : The 'safe' argument decides whether the slave interpreter is + : created as a safe interpreter or not. If true, create a safe + : interpreter. Default is false. However, if the parent + : interpreter is a safe interpreter, the created interpreter is + : a safe interpreter (ignore 'safe' argument value). + : If $SAFE >= 4, can create a safe interpreter only. + + make_safe + : Make the interpreter to the safe interpreter, and returns + : self. If fail, raise RuntimeError. + + safe? + : Check whether the interpreter is the safe interpreter. + : If is the safe interpreter, returns true. + + delete + : Delete the interpreter. + : The deleted interpreter doesn't accept command and then + : raise an exception. + + deleted? + : Check whether the interpreter is already deleted. + : If deleted, returns true. + + restart + : Restart Tk part of the interpreter. + : Use this when you need Tk functions after destroying the + : root widget. + : On $SAFE >= 4, cannot call this method. + + _eval(str) + _invoke(*args) + : Estimates the arguments as a command on the Tk interpreter. + : The argument of _eval is a script of Tcl/Tk. + : Each argument of _invoke is a token of one command line of + : Tcl/Tk. + : Because the operation of _invoke doesn't through the + : command line parser of Tk interpreter, the cost of + : estimation is smaller than _eval. However, auto_load + : mechanism of the Tk interpreter doesn't work on _invoke. + : So _invoke can call only the command which already + : registered on the interpreter by 'load' command and so on. + : On _eval command, auto_load mechanism words. So if succeed + : to _eval and regist the command once, after that, the + : command can be called by _invoke. + + _toUTF8(str, encoding) + _fromUTF8(str, encoding) + : Call the function (which is internal function of Tcl/Tk) to + : convert to/from a UTF8 string. + + _thread_vwait(var_name) + _thread_tkwait(mode, target) + : 'vwait' or 'tkwait' with thread support. + : The difference from normal 'vwait' or 'tkwait' command is + : doing independent wait from the vwait stack when they are + : called on the other thread than the eventloop thread. + : In the case of Tcl/Tk's vwait / tkwait, if 2nd vwait / + : tkwait is called on waiting for 1st vwait / tkwait, + : returns the order of [2nd]->[1st] regardless of the order + : of when the wait condition was fulfilled. + : If _thread_vwait / _thread_tkwait is called on the + : eventloop thread, there is no difference from vwait / + : tkwait. But if called on the other thread than the + : eventloop, stops the thread. And when the wait condition + : is fulfilled, the thread restarts. The meaning of + : "independent from the vwait stack" is that the timing of + : restarting is independent from the waiting status of the + : other threads. That is, even if the eventloop thread is + : waiting by vwait and is not fulfilled the condition, + : _thread_vwait completes the waiting when its waiting + : condition is fulfilled and the thread which stopped by + : _thread_vwait can continue the operation. + + _return_value + : Get the last result value on the interpreter. + + _get_variable(var_name, flag) + _get_variable2(var_name, index_name, flag) + : Get the current value of a variable. If specified a + : index_name (see also the PARSE_VARNAME flag), get the + : value of the index_name element. + + _set_variable(var_name, value, flag) + _set_variable2(var_name, index_name, value, flag) + : Create or modify a variable. If specified a index_name + : (see also the PARSE_VARNAME flag), create or modify the + : index_name element. + + _unset_variable(var_name) + _unset_variable2(var_name, index_name) + : Remove a variable. If specified a index_name (see also + : the PARSE_VARNAME flag), remove the index_name element. + + _get_global_var(var_name) + _get_global_var2(var_name, index_name) + _set_global_var(var_name, value) + _set_global_var2(var_name, index_name, value) + _unset_global_var(var_name) + _unset_global_var2(var_name, index_name) + : Call the associated method with the flag argument + : (GLOBAL_ONLY | LEAVE_ERR_MSG). + + _split_tklist(str) + : Split the argument with Tcl/Tk's library function and + : get an array as a list of Tcl list elements. + + _merge_tklist(str, str, ... ) + : Get a Tcl's list string from arguments with a Tcl/Tk's + : library function. Each arguemnt is converted to a valid + : Tcl list element. + + _conv_listelement(str) + : Convert the argument to a valid Tcl list element with + : Tcl/Tk's library function. + + mainloop + mainloop_watchdog + : If on the slave interpreter, never start an eventloop and + : returns nil. + : With the exception that, same to the TclTkLib module method + : with the same name. + + do_one_event + : With the exception that the argument is forced to set + : DONT_WAIT flag on the slave interpreter, same to + : TclTkLib#do_one_event. + + set_eventloop_tick + get_eventloop_tick + set_no_event_wait + get_no_event_wait + set_eventloop_weight + get_eventloop_weight + mainloop_abort_on_exception + mainloop_abort_on_exception= + : With the exception that it is ignored to set value on the + : slave interpreter, same to the TclTkLib module method with + : the same name. class TkCallbackBreak < StandardError class TkCallbackContinue < StandardError - : They are exception classes to break or continue the Tk callback - : operation. - : If raise TkCallbackBreak on the callback procedure, Ruby returns - : 'break' code to Tk interpreter (Then the Tk interpreter will - : break the operation for the current event). - : If raise TkCallbackContinue, returns 'continue' code (Then the Tk - : interpreter will break the operateion for the current bindtag and - : starts the operation for the next buindtag for the current event). + : They are exception classes to break or continue the Tk callback + : operation. + : If raise TkCallbackBreak on the callback procedure, Ruby returns + : 'break' code to Tk interpreter (Then the Tk interpreter will + : break the operation for the current event). + : If raise TkCallbackContinue, returns 'continue' code (Then the Tk + : interpreter will break the operateion for the current bindtag and + : starts the operation for the next buindtag for the current event). (eof) diff --git a/ext/tcltklib/MANUAL.euc b/ext/tcltklib/MANUAL.euc index 9f9c77da02..baddcaf54b 100644 --- a/ext/tcltklib/MANUAL.euc +++ b/ext/tcltklib/MANUAL.euc @@ -1,5 +1,5 @@ (tof) - 2003/10/17 Hidetoshi NAGAI + 2004/03/28 Hidetoshi NAGAI 本ドキュメントには古い tcltk ライブラリ，tcltklib ライブラリの説明 が含まれていますが，その記述内容は古いものとなっています． @@ -175,6 +175,52 @@ require "tcltklib" すると, 以下のモジュール, クラスが利用可能です. : 処理対象イベントが存在しない場合に，イベント発生を待たず : に do_one_event を終了 ( false を返す ) する + モジュール TclTkLib::VarAccessFlag + : _get_variable などでのフラグを指定するためのもの．フラグに + : は以下の定数を OR で連結して与える． + + 定数 NONE + : 値は 0 で，何もフラグを指定していないのに等しい． + + 定数 GLOBAL_ONLY + : 通常，変数の検索はまず手続き呼び出しを行ったレベルで検 + : 索し，次に現在の名前空間で検索，最後にグローバル空間で + : 検索を行う．しかし，このフラグが指定された場合には，グ + : ローバル空間でのみ検索する． + : もし GLOBAL_ONLY と NAMESPACE_ONLY とが両方指定された場 + : 合には，GLOBAL_ONLY の指定は無視される． + + 定数 NAMESPACE_ONLY + : このフラグが指定された場合には，現在の名前空間でのみ変 + : 数の検索を行う．GLOBAL_ONLY の説明も参照すること． + + 定数 LEAVE_ERR_MSG + : 変数アクセスにおいてエラーが発生した場合，このフラグが + : 指定されていれば，実行結果として Tcl インタープリタにエ + : ラーメッセージが残される．このフラグが指定されていなけ + : れば，エラーメッセージは一切残されない． + + 定数 APPEND_VALUE + : このフラグが指定されていた場合，変数の値を置き換えので + : はなく，現在の値に代入値が追加 (append; 文字列連結) さ + : れる．変数が未定義あった場合，このフラグは無視される． + + 定数 LIST_ELEMENT + : このフラグが指定されていた場合，代入値はまず Tcl のリス + : ト要素として適切となるように変換される．代入値がリスト + : (またはサブリスト) の最初の要素となるのでない限り，代入 + : 値の直前には空白文字が追加される． + + 定数 PARSE_VARNAME + : _set_variable などの呼び出しにおいてこのフラグが指定さ + : れていた場合，var_name 引数が連想配列名と要素名とを両方 + : 含む可能性がある (開き括弧を含み，閉じ括弧で終わる) こ + : とを示す．その場合，括弧の間が要素名指定，最初の開き括 + : 弧までが連想配列名として扱われる．_set_variable2 などで + : このフラグを指定する場合，連想配列名と要素名は var_name + : から抽出されるはずであるから，index_name 引数は nil と + : せねばならない． + モジュールメソッド mainloop(check_root = true) : イベントループを起動する．check_root が true であれば， @@ -277,6 +323,26 @@ require "tcltklib" すると, 以下のモジュール, クラスが利用可能です. : ので，この値は現在 Tk の機能が有効であるインタープリタの総 : 数に等しい． + _merge_tklist(str, str, ... ) + : Tcl/Tk のライブラリ関数を使って，引数の文字列がそれぞれ + : 正しく一つのリスト要素となるように連結した文字列を返す． + + _conv_listelement(str) + : Tcl/Tk のライブラリ関数を使って，引数の文字列が Tcl の + : 一つのリスト要素として適切な表現になるように変換した文 + : 字列を返す． + + _toUTF8(str, encoding) + _fromUTF8(str, encoding) + : Tcl/Tk が内蔵している UTF8 変換処理を呼び出す． + + _subst_UTF_backslash(str) + _subst_Tcl_backslash(str) + : Tcl のルールでバックスラッシュ記法 ( \uhhhh による + : Unicode 文字表現を含む ) を解析する． + : _subst_Tcl_backslash はすべてのバックスラッシュ記法を + : 置き換えるのに対し，_subst_UTF_backslash は \uhhhh + : による Unicode 文字表現だけを置き換える． クラス TclTkIp クラスメソッド @@ -373,6 +439,52 @@ require "tcltklib" すると, 以下のモジュール, クラスが利用可能です. _return_value : 直前の Tcl/Tk 上での評価の実行結果としての戻り値を返す． + _get_variable(var_name, flag) + _get_variable2(var_name, index_name, flag) + : Tcl/Tk 上の var という変数名の変数の値を返す． + : もし index_name が指定 (PARSE_VARNAME フラグの説明も参照) + : された場合は連想配列 var_name の index_name の要素を返す． + : flag には変数を検索する際の条件を指定する．flag に与える + : 値はモジュール TclTkLib::VarAccessFlag を参照すること． + + _set_variable(var_name, value, flag) + _set_variable2(var_name, index_name, value, flag) + : Tcl/Tk 上の var という変数名の変数に値を設定する． + : もし index_name が指定 (PARSE_VARNAME フラグの説明も参照) + : された場合は連想配列 var_name の index_name の要素を設定 + : する． + : flag には変数を検索する際の条件を指定する．flag に与える + : 値はモジュール TclTkLib::VarAccessFlag を参照すること． + + _unset_variable(var_name) + _unset_variable2(var_name, index_name) + : Tcl/Tk 上の var_name という変数名の変数を消去する． + : もし index_name が指定 (PARSE_VARNAME フラグの説明も参照) + : された場合は連想配列 var_name から index_name の要素だけ + : を消去する． + + _get_global_var(var_name) + _get_global_var2(var_name, index_name) + _set_global_var(var_name, value) + _set_global_var2(var_name, index_name, value) + _unset_global_var(var_name) + _unset_global_var2(var_name, index_name) + : それぞれ，対応する変数アクセスメソッドの flag に対して + : (GLOBAL_ONLY | LEAVE_ERR_MSG) を与えたもの． + + _split_tklist(str) + : Tcl/Tk のライブラリ関数を使って，文字列 str をリストに + : 分割する (文字列の配列として返す)． + + _merge_tklist(str, str, ... ) + : Tcl/Tk のライブラリ関数を使って，引数の文字列がそれぞれ + : 正しく一つのリスト要素となるように連結した文字列を返す． + + _conv_listelement(str) + : Tcl/Tk のライブラリ関数を使って，引数の文字列が Tcl の + : 一つのリスト要素として適切な表現になるように変換した文 + : 字列を返す． + mainloop mainloop_watchdog : スレーブ IP の場合にはイベントループを起動せずに nil を返す． diff --git a/ext/tcltklib/README.1st b/ext/tcltklib/README.1st index 510dd1c2cd..48e3a2b668 100644 --- a/ext/tcltklib/README.1st +++ b/ext/tcltklib/README.1st @@ -8,7 +8,7 @@ some or all of the following options. --with-tcllib=<libname> (e.g. libtcl8.3.so ==> --with-tcllib=tcl8.3) --with-tklib=<libname> (e.g. libtk8.3.so ==> --with-tklib=tk8.3) - --enable_tcltk_stubs (if you force to enable stubs) + --enable-tcltk_stubs (if you force to enable stubs) --with-tcl-dir=<path> equal to "--with-tcl-include=<path>/include --with-tcl-lib=<path>/lib" diff --git a/ext/tcltklib/demo/lines3.rb b/ext/tcltklib/demo/lines3.rb new file mode 100644 index 0000000000..caa50f92e7 --- /dev/null +++ b/ext/tcltklib/demo/lines3.rb @@ -0,0 +1,54 @@ +#! /usr/local/bin/ruby + +require "tk" + +def drawlines() + print Time.now, "\n" + + for j in 0 .. 99 + print "*" + $stdout.flush + if (j & 1) != 0 + col = "blue" + else + col = "red" + end + for i in 0 .. 99 +# $a.create(TkcLine, i, 0, 0, 500 - i, "fill"=>col) + end + end + + print Time.now, "\n" + + for j in 0 .. 99 + print "*" + $stdout.flush + if (j & 1) != 0 + col = "blue" + else + col = "red" + end + for i in 0 .. 99 + $a.create(TkcLine, i, 0, 0, 500 - i, "fill"=>col) + end + end + + print Time.now, "\n" +# Tk.root.destroy +end + +$a = TkCanvas.new{ + height(500) + width(500) +} + +$b = TkButton.new{ + text("draw") + command(proc{drawlines()}) +} + +TkPack.configure($a, $b, {"side"=>"left"}) + +Tk.mainloop + +# eof diff --git a/ext/tcltklib/demo/lines4.rb b/ext/tcltklib/demo/lines4.rb new file mode 100644 index 0000000000..7a1175bce0 --- /dev/null +++ b/ext/tcltklib/demo/lines4.rb @@ -0,0 +1,54 @@ +#! /usr/local/bin/ruby + +require "tk" + +def drawlines() + print Time.now, "\n" + + for j in 0 .. 99 + print "*" + $stdout.flush + if (j & 1) != 0 + col = "blue" + else + col = "red" + end + for i in 0 .. 99 +# TkCore::INTERP.__invoke($a.path, "create", "line", i.to_s, '0', '0', (500 - i).to_s, "-fill", col) + end + end + + print Time.now, "\n" + + for j in 0 .. 99 + print "*" + $stdout.flush + if (j & 1) != 0 + col = "blue" + else + col = "red" + end + for i in 0 .. 99 + TkCore::INTERP.__invoke($a.path, "create", "line", i.to_s, '0', '0', (500 - i).to_s, "-fill", col) + end + end + + print Time.now, "\n" +# Tk.root.destroy +end + +$a = TkCanvas.new{ + height(500) + width(500) +} + +$b = TkButton.new{ + text("draw") + command(proc{drawlines()}) +} + +TkPack.configure($a, $b, {"side"=>"left"}) + +Tk.mainloop + +# eof diff --git a/ext/tcltklib/extconf.rb b/ext/tcltklib/extconf.rb index 575bf78034..6b2fcdd4ac 100644 --- a/ext/tcltklib/extconf.rb +++ b/ext/tcltklib/extconf.rb @@ -2,7 +2,9 @@ require 'mkmf' -if RUBY_PLATFORM !~ /mswin32|mingw|cygwin|bccwin32/ +is_win32 = (/mswin32|mingw|cygwin|bccwin32/ =~ RUBY_PLATFORM) + +unless is_win32 have_library("nsl", "t_open") have_library("socket", "socket") have_library("dl", "dlopen") @@ -25,7 +27,7 @@ def find_tcl(tcllib, stubs) elsif find_library("tcl", func, *paths) true else - %w[8.4 8.3 8.2 8.0 7.6].find { |ver| + %w[8.5 8.4 8.3 8.2 8.1 8.0 7.6].find { |ver| find_library("tcl#{ver}", func, *paths) or find_library("tcl#{ver.delete('.')}", func, *paths) } @@ -40,7 +42,7 @@ def find_tk(tklib, stubs) elsif find_library("tk", func, *paths) true else - %w[8.4 8.3 8.2 8.0 4.2].find { |ver| + %w[8.5 8.4 8.3 8.2 8.1 8.0 4.2].find { |ver| find_library("tk#{ver}", func, *paths) or find_library("tk#{ver.delete('.')}", func, *paths) } @@ -48,11 +50,73 @@ def find_tk(tklib, stubs) end if have_header("tcl.h") && have_header("tk.h") && - (/mswin32|mingw|cygwin|bccwin32/ =~ RUBY_PLATFORM || find_library("X11", "XOpenDisplay", - "/usr/X11/lib", "/usr/lib/X11", "/usr/X11R6/lib", "/usr/openwin/lib")) && + (is_win32 || find_library("X11", "XOpenDisplay", + "/usr/X11/lib", "/usr/lib/X11", "/usr/X11R6/lib", "/usr/openwin/lib")) && find_tcl(tcllib, stubs) && find_tk(tklib, stubs) $CPPFLAGS += ' -DUSE_TCL_STUBS -DUSE_TK_STUBS' if stubs $CPPFLAGS += ' -D_WIN32' if /cygwin/ =~ RUBY_PLATFORM - create_makefile("tcltklib") + + pthread_enabled = macro_defined?('HAVE_LIBPTHREAD', '#include "ruby.h"') + + if try_run(<<EOF) +#include <tcl.h> +static Tcl_ThreadDataKey dataKey; +int main() { exit((Tcl_GetThreadData(&dataKey, 1) == dataKey)? 1: 0); } +EOF + tcl_enable_thread = true + else + tcl_enable_thread = false + end + + unless pthread_enabled + if tcl_enable_thread + # ruby -> disable && tcl -> enable + puts(%Q'\ +***************************************************************************** +** +** PTHREAD SUPPORT MODE ERRROR: +** +** Ruby is not compiled with --enable-pthread, but your Tcl/Tk +** libararies seems to be compiled with "pthread support". This +** combination possibly cause "Hang-up" or "Segmentation Fault" +** frequently when Ruby/Tk is working. We NEVER recommend you to +** create the library under such combination of pthread support. +** +** Please recompile Ruby with "--enable-pthread" configure option +** or recompile Tcl/Tk with "--disable-threads" configure option. +** +***************************************************************************** +') + else + # ruby -> disable && tcl -> disable + create_makefile("tcltklib") + end + else + unless tcl_enable_thread + # ruby -> enable && tcl -> disable + puts(%Q'\ +***************************************************************************** +** +** PTHREAD SUPPORT MODE WARNING: +** +** Ruby is compiled with --enable-pthread, but your Tcl/Tk libraries +** seems to be compiled without "pthread support". Although You can +** create tcltklib library, this combination may cause memory trouble +** (e.g. "Hang-up" or "Segmentation Fault"). If you have no reason you +** must have to keep current pthread support status, we recommend you +** to make both or neither libraries to support pthread. +** +** If you want change the status of pthread support, please recompile +** Ruby without "--enable-pthread" configure option or recompile Tcl/Tk +** with "--enable-threads" configure option (if your Tcl/Tk is later +** than Tcl/Tk8.1). +** +***************************************************************************** +') + end + # ruby -> enable && tcl -> enable/disable + + create_makefile("tcltklib") + end end diff --git a/ext/tcltklib/tcltklib.c b/ext/tcltklib/tcltklib.c index 63dd593605..eea7ace7fa 100644 --- a/ext/tcltklib/tcltklib.c +++ b/ext/tcltklib/tcltklib.c @@ -36,28 +36,62 @@ # endif # endif # endif -#else /* TCL_MAJOR_VERSION == 7 */ +#else /* TCL_MAJOR_VERSION < 8 */ # ifdef CONST # define CONST84 CONST # else +# define CONST # define CONST84 # endif #endif -/* for ruby_debug */ +/* copied from eval.c */ +#define TAG_RETURN 0x1 +#define TAG_BREAK 0x2 +#define TAG_NEXT 0x3 +#define TAG_RETRY 0x4 +#define TAG_REDO 0x5 +#define TAG_RAISE 0x6 +#define TAG_FATAL 0x8 -#define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);} +/* for ruby_debug */ +#define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1); fflush(stderr); } #define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\ -fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); } +fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); fflush(stderr); } /* #define DUMP1(ARG1) #define DUMP2(ARG1, ARG2) */ +/* finalize_proc_name */ +static char *finalize_hook_name = "INTERP_FINALIZE_HOOK"; + /* for callback break & continue */ +static VALUE eTkCallbackReturn; static VALUE eTkCallbackBreak; static VALUE eTkCallbackContinue; +static VALUE eLocalJumpError; + +static ID ID_at_enc; +static ID ID_at_interp; + +static ID ID_stop_p; +static ID ID_kill; +static ID ID_join; + +static ID ID_call; +static ID ID_backtrace; +static ID ID_message; + +static ID ID_at_reason; +static ID ID_return; +static ID ID_break; +static ID ID_next; + +static ID ID_to_s; +static ID ID_inspect; + static VALUE ip_invoke_real _((int, VALUE*, VALUE)); static VALUE ip_invoke _((int, VALUE*, VALUE)); @@ -78,23 +112,45 @@ int *tclDummyMathPtr = (int *) matherr; struct invoke_queue { Tcl_Event ev; int argc; - VALUE *argv; - VALUE obj; - int done; +#if TCL_MAJOR_VERSION >= 8 + Tcl_Obj **argv; +#else /* TCL_MAJOR_VERSION < 8 */ + char **argv; +#endif + VALUE interp; + int *done; int safe_level; - VALUE *result; + VALUE result; VALUE thread; }; struct eval_queue { Tcl_Event ev; - VALUE str; - VALUE obj; - int done; + char *str; + int len; + VALUE interp; + int *done; int safe_level; - VALUE *result; + VALUE result; VALUE thread; }; + +void +invoke_queue_mark(struct invoke_queue *q) +{ + rb_gc_mark(q->interp); + rb_gc_mark(q->result); + rb_gc_mark(q->thread); +} + +void +eval_queue_mark(struct eval_queue *q) +{ + rb_gc_mark(q->interp); + rb_gc_mark(q->result); + rb_gc_mark(q->thread); +} + static VALUE eventloop_thread; static VALUE watchdog_thread; @@ -128,9 +184,11 @@ static int loop_counter = 0; static int check_rootwidget_flag = 0; #if TCL_MAJOR_VERSION >= 8 -static int ip_ruby _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*)); -#else -static int ip_ruby _((ClientData, Tcl_Interp *, int, char **)); +static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*)); +static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*)); +#else /* TCL_MAJOR_VERSION < 8 */ +static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, char **)); +static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, char **)); #endif /*---- class TclTkIp ----*/ @@ -161,10 +219,16 @@ static void _timer_for_tcl(clientData) ClientData clientData; { + int thr_crit_bup; + /* struct invoke_queue *q, *tmp; */ /* VALUE thread; */ DUMP1("called timer_for_tcl"); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + Tk_DeleteTimerHandler(timer_token); run_timer_flag = 1; @@ -176,6 +240,8 @@ _timer_for_tcl(clientData) timer_token = (Tcl_TimerToken)NULL; } + rb_thread_critical = thr_crit_bup; + /* rb_thread_schedule(); */ /* tick_counter += event_loop_max; */ } @@ -186,6 +252,7 @@ set_eventloop_tick(self, tick) VALUE tick; { int ttick = NUM2INT(tick); + int thr_crit_bup; rb_secure(4); @@ -194,6 +261,9 @@ set_eventloop_tick(self, tick) "timer-tick parameter must be 0 or positive number"); } + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + /* delete old timer callback */ Tk_DeleteTimerHandler(timer_token); @@ -206,6 +276,8 @@ set_eventloop_tick(self, tick) timer_token = (Tcl_TimerToken)NULL; } + rb_thread_critical = thr_crit_bup; + return tick; } @@ -335,6 +407,39 @@ ip_get_eventloop_weight(self) } static VALUE +set_max_block_time(self, time) + VALUE self; + VALUE time; +{ + struct Tcl_Time tcl_time; + VALUE divmod; + + switch(TYPE(time)) { + case T_FIXNUM: + case T_BIGNUM: + /* time is micro-second value */ + divmod = rb_funcall(time, rb_intern("divmod"), 1, LONG2NUM(1000000)); + tcl_time.sec = NUM2LONG(RARRAY(divmod)->ptr[0]); + tcl_time.usec = NUM2LONG(RARRAY(divmod)->ptr[1]); + break; + + case T_FLOAT: + /* time is second value */ + divmod = rb_funcall(time, rb_intern("divmod"), 1, INT2FIX(1)); + tcl_time.sec = NUM2LONG(RARRAY(divmod)->ptr[0]); + tcl_time.usec = (long)(NUM2DBL(RARRAY(divmod)->ptr[1]) * 1000000); + + default: + rb_raise(rb_eArgError, "invalid value for time: '%s'", + RSTRING(rb_funcall(time, ID_inspect, 0, 0))->ptr); + } + + Tcl_SetMaxBlockTime(&tcl_time); + + return Qnil; +} + +static VALUE lib_evloop_abort_on_exc(self) VALUE self; { @@ -361,7 +466,7 @@ lib_evloop_abort_on_exc_set(self, val) rb_secure(4); if (RTEST(val)) { event_loop_abort_on_exc = 1; - } else if (val == Qnil) { + } else if (NIL_P(val)) { event_loop_abort_on_exc = -1; } else { event_loop_abort_on_exc = 0; @@ -391,13 +496,19 @@ lib_num_of_mainwindows(self) } static int -lib_eventloop_core(check_root, check_var) +lib_eventloop_core(check_root, update_flag, check_var) int check_root; + int update_flag; int *check_var; { VALUE current = eventloop_thread; int found_event = 1; + int event_flag; struct timeval t; + int thr_crit_bup; + + + if (update_flag) DUMP1("update loop start!!"); t.tv_sec = (time_t)0; t.tv_usec = (time_t)(no_event_wait*1000.0); @@ -405,8 +516,11 @@ lib_eventloop_core(check_root, check_var) Tk_DeleteTimerHandler(timer_token); run_timer_flag = 0; if (timer_tick > 0) { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; timer_token = Tk_CreateTimerHandler(timer_tick, _timer_for_tcl, (ClientData)0); + rb_thread_critical = thr_crit_bup; } else { timer_token = (Tcl_TimerToken)NULL; } @@ -416,7 +530,13 @@ lib_eventloop_core(check_root, check_var) DUMP1("no other thread"); event_loop_wait_event = 0; - if (timer_tick == 0) { + if (update_flag) { + event_flag = update_flag | TCL_DONT_WAIT; /* for safety */ + } else { + event_flag = TCL_ALL_EVENTS; + } + + if (timer_tick == 0 && update_flag == 0) { timer_tick = NO_THREAD_INTERRUPT_TIME; timer_token = Tk_CreateTimerHandler(timer_tick, _timer_for_tcl, @@ -429,25 +549,30 @@ lib_eventloop_core(check_root, check_var) } } - found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS); + found_event = Tcl_DoOneEvent(event_flag); - if (loop_counter++ > 30000) { - loop_counter = 0; + if (update_flag != 0) { + if (found_event) { + DUMP1("next update loop"); + continue; + } else { + DUMP1("update complete"); + return 0; + } } - if (run_timer_flag) { - /* - DUMP1("timer interrupt"); + DUMP1("check Root Widget"); + if (check_root && Tk_GetNumMainWindows() == 0) { run_timer_flag = 0; - DUMP1("call rb_trap_exec()"); - rb_trap_exec(); - */ - DUMP1("check Root Widget"); - if (check_root && Tk_GetNumMainWindows() == 0) { - run_timer_flag = 0; - rb_trap_exec(); - return 1; + if (!rb_prohibit_interrupt) { + if (rb_trap_pending) rb_trap_exec(); } + return 1; + } + + if (loop_counter++ > 30000) { + /* fprintf(stderr, "loop_counter > 30000\n"); */ + loop_counter = 0; } } else { @@ -458,6 +583,12 @@ lib_eventloop_core(check_root, check_var) found_event = 1; + if (update_flag) { + event_flag = update_flag | TCL_DONT_WAIT; /* for safety */ + } else { + event_flag = TCL_ALL_EVENTS | TCL_DONT_WAIT; + } + timer_tick = req_timer_tick; tick_counter = 0; while(tick_counter < event_loop_max) { @@ -467,27 +598,40 @@ lib_eventloop_core(check_root, check_var) } } - if (Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)) { + if (Tcl_DoOneEvent(event_flag)) { tick_counter++; } else { + if (update_flag != 0) { + DUMP1("update complete"); + return 0; + } tick_counter += no_event_tick; + rb_thread_wait_for(t); + } + + if (watchdog_thread != 0 && eventloop_thread != current) { + return 1; + } - DUMP1("check Root Widget"); - if (check_root && Tk_GetNumMainWindows() == 0) { - return 1; + DUMP1("check Root Widget"); + if (check_root && Tk_GetNumMainWindows() == 0) { + run_timer_flag = 0; + if (!rb_prohibit_interrupt) { + if (rb_trap_pending) rb_trap_exec(); } + return 1; + } - rb_thread_wait_for(t); + DUMP1("trap check"); + if (!rb_prohibit_interrupt) { + if (rb_trap_pending) rb_trap_exec(); } if (loop_counter++ > 30000) { + /* fprintf(stderr, "loop_counter > 30000\n"); */ loop_counter = 0; } - if (watchdog_thread != 0 && eventloop_thread != current) { - return 1; - } - if (run_timer_flag) { /* DUMP1("timer interrupt"); @@ -496,23 +640,11 @@ lib_eventloop_core(check_root, check_var) break; /* switch to other thread */ } } - - DUMP1("check Root Widget"); - if (check_root && Tk_GetNumMainWindows() == 0) { - return 1; - } } - /* rb_thread_schedule(); */ - if (run_timer_flag) { - run_timer_flag = 0; - rb_trap_exec(); - } else { - DUMP1("thread scheduling"); - if (is_ruby_native_thread()) { - rb_thread_schedule(); - } - } + DUMP1("trap check & thread scheduling"); + if (update_flag == 0) CHECK_INTS; + } return 1; } @@ -523,7 +655,7 @@ lib_eventloop_main(check_rootwidget) { check_rootwidget_flag = RTEST(check_rootwidget); - if (lib_eventloop_core(check_rootwidget_flag, (int *)NULL)) { + if (lib_eventloop_core(check_rootwidget_flag, 0, (int *)NULL)) { return Qtrue; } else { return Qfalse; @@ -614,8 +746,8 @@ lib_watchdog_core(check_rootwidget) /* check other watchdog thread */ if (watchdog_thread != 0) { - if (RTEST(rb_funcall(watchdog_thread, rb_intern("stop?"), 0))) { - rb_funcall(watchdog_thread, rb_intern("kill"), 0); + if (RTEST(rb_funcall(watchdog_thread, ID_stop_p, 0))) { + rb_funcall(watchdog_thread, ID_kill, 0); } else { return Qnil; } @@ -626,7 +758,7 @@ lib_watchdog_core(check_rootwidget) do { if (eventloop_thread == 0 || (loop_counter == prev_val - && RTEST(rb_funcall(eventloop_thread, rb_intern("stop?"), 0)) + && RTEST(rb_funcall(eventloop_thread, ID_stop_p, 0)) && ++chance >= 3 ) ) { /* start new eventloop thread */ @@ -703,7 +835,7 @@ lib_do_one_event_core(argc, argv, self, is_ip) VALUE self; int is_ip; { - VALUE vflags; + volatile VALUE vflags; int flags; int found_event; @@ -727,7 +859,8 @@ lib_do_one_event_core(argc, argv, self, is_ip) } } - found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); + /* found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); */ + found_event = Tcl_DoOneEvent(flags); if (found_event) { return Qtrue; @@ -755,13 +888,97 @@ ip_do_one_event(argc, argv, self) } -/* Tcl command `ruby' */ +static void +ip_set_exc_message(interp, exc) + Tcl_Interp *interp; + VALUE exc; +{ + char *buf; + Tcl_DString dstr; + volatile VALUE msg; + int thr_crit_bup; + +#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) + volatile VALUE enc; + Tcl_Encoding encoding; +#endif + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + msg = rb_funcall(exc, ID_message, 0, 0); + +#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) + enc = rb_ivar_get(exc, ID_at_enc); + if (NIL_P(enc)) { + enc = rb_ivar_get(msg, ID_at_enc); + } + if (NIL_P(enc)) { + encoding = (Tcl_Encoding)NULL; + } else if (TYPE(enc) == T_STRING) { + encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr); + } else { + enc = rb_funcall(enc, ID_to_s, 0, 0); + encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr); + } + + /* to avoid a garbled error message dialog */ + buf = ALLOC_N(char, (RSTRING(msg)->len)+1); + strncpy(buf, RSTRING(msg)->ptr, RSTRING(msg)->len); + buf[RSTRING(msg)->len] = 0; + + Tcl_DStringInit(&dstr); + Tcl_DStringFree(&dstr); + Tcl_ExternalToUtfDString(encoding, buf, RSTRING(msg)->len, &dstr); + + Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL); + DUMP2("error message:%s", Tcl_DStringValue(&dstr)); + free(buf); + +#else /* TCL_VERSION <= 8.0 */ + Tcl_AppendResult(interp, RSTRING(msg)->ptr, (char*)NULL); +#endif + + rb_thread_critical = thr_crit_bup; +} + +static VALUE +TkStringValue(obj) + VALUE obj; +{ + switch(TYPE(obj)) { + case T_STRING: + return obj; + + case T_NIL: + return rb_str_new2(""); + + case T_TRUE: + return rb_str_new2("1"); + + case T_FALSE: + return rb_str_new2("0"); + + case T_ARRAY: + return rb_funcall(obj, ID_join, 1, rb_str_new2(" ")); + + default: + if (rb_respond_to(obj, ID_to_s)) { + return rb_funcall(obj, ID_to_s, 0, 0); + } + } + + return rb_funcall(obj, ID_inspect, 0, 0); +} + +/* Tcl command `ruby'|`ruby_eval' */ static VALUE ip_ruby_eval_rescue(failed, einfo) - VALUE *failed; + VALUE failed; VALUE einfo; { - *failed = einfo; + DUMP1("call ip_ruby_eval_rescue"); + RARRAY(failed)->ptr[0] = einfo; return Qnil; } @@ -772,76 +989,265 @@ struct eval_body_arg { static VALUE ip_ruby_eval_body(arg) - struct eval_body_arg *arg; + struct eval_body_arg *arg; { + VALUE ret; + int status = 0; + int thr_crit_bup; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + DUMP1("call ip_ruby_eval_body"); rb_trap_immediate = 0; - return rb_rescue2(rb_eval_string, (VALUE)arg->string, - ip_ruby_eval_rescue, (VALUE)&(arg->failed), + +#if 0 + ret = rb_rescue2(rb_eval_string, (VALUE)arg->string, + ip_ruby_eval_rescue, arg->failed, rb_eStandardError, rb_eScriptError, rb_eSystemExit, (VALUE)0); +#else + + ret = rb_eval_string_protect(arg->string, &status); + if (status) { + char *errtype, *buf; + int errtype_len, len; + VALUE old_gc; + + old_gc = rb_gc_disable(); + + switch(status) { + case TAG_RETURN: + errtype = "LocalJumpError: "; + errtype_len = strlen(errtype); + len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len; + buf = ALLOC_N(char, len + 1); + strncpy(buf, errtype, errtype_len); + strncpy(buf + errtype_len, + RSTRING(rb_obj_as_string(ruby_errinfo))->ptr, + RSTRING(rb_obj_as_string(ruby_errinfo))->len); + *(buf + len) = 0; + + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackReturn, buf); + free(buf); + break; + + case TAG_BREAK: + errtype = "LocalJumpError: "; + errtype_len = strlen(errtype); + len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len; + buf = ALLOC_N(char, len + 1); + strncpy(buf, errtype, errtype_len); + strncpy(buf + errtype_len, + RSTRING(rb_obj_as_string(ruby_errinfo))->ptr, + RSTRING(rb_obj_as_string(ruby_errinfo))->len); + *(buf + len) = 0; + + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackBreak, buf); + free(buf); + break; + + case TAG_NEXT: + errtype = "LocalJumpError: "; + errtype_len = strlen(errtype); + len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len; + buf = ALLOC_N(char, len + 1); + strncpy(buf, errtype, errtype_len); + strncpy(buf + errtype_len, + RSTRING(rb_obj_as_string(ruby_errinfo))->ptr, + RSTRING(rb_obj_as_string(ruby_errinfo))->len); + *(buf + len) = 0; + + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackContinue,buf); + free(buf); + break; + + case TAG_RETRY: + case TAG_REDO: + RARRAY(arg->failed)->ptr[0] = ruby_errinfo; + break; + + case TAG_RAISE: + case TAG_FATAL: + RARRAY(arg->failed)->ptr[0] = ruby_errinfo; + break; + + default: + buf = ALLOC_N(char, 256); + sprintf(buf, "unknown loncaljmp status %d", status); + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(rb_eException, buf); + free(buf); + break; + } + + if (old_gc == Qfalse) rb_gc_enable(); + + ret = Qnil; + } +#endif + + rb_thread_critical = thr_crit_bup; + + return ret; } static VALUE ip_ruby_eval_ensure(trapflag) - VALUE trapflag; + VALUE trapflag; { rb_trap_immediate = NUM2INT(trapflag); return Qnil; } + static int #if TCL_MAJOR_VERSION >= 8 -ip_ruby(clientData, interp, argc, argv) +ip_ruby_eval(clientData, interp, argc, argv) ClientData clientData; Tcl_Interp *interp; int argc; Tcl_Obj *CONST argv[]; -#else -ip_ruby(clientData, interp, argc, argv) +#else /* TCL_MAJOR_VERSION < 8 */ +ip_ruby_eval(clientData, interp, argc, argv) ClientData clientData; Tcl_Interp *interp; int argc; char *argv[]; #endif { - VALUE res; + volatile VALUE res; + volatile VALUE exception = rb_ary_new2(1); int old_trapflag; - struct eval_body_arg arg; - int dummy; + struct eval_body_arg *arg; + int thr_crit_bup; /* ruby command has 1 arg. */ if (argc != 2) { - rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)", argc); + rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)", + argc - 1); } + /* allocate */ + arg = ALLOC(struct eval_body_arg); + /* get C string from Tcl object */ #if TCL_MAJOR_VERSION >= 8 - arg.string = Tcl_GetStringFromObj(argv[1], &dummy); -#else - arg.string = argv[1]; + { + char *str; + int len; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + str = Tcl_GetStringFromObj(argv[1], &len); + arg->string = ALLOC_N(char, len + 1); + strncpy(arg->string, str, len); + arg->string[len] = 0; + + rb_thread_critical = thr_crit_bup; + + } +#else /* TCL_MAJOR_VERSION < 8 */ + arg->string = argv[1]; #endif - arg.failed = 0; + /* arg.failed = 0; */ + RARRAY(exception)->ptr[0] = Qnil; + arg->failed = exception; /* evaluate the argument string by ruby */ - DUMP2("rb_eval_string(%s)", arg.string); + DUMP2("rb_eval_string(%s)", arg->string); old_trapflag = rb_trap_immediate; - res = rb_ensure(ip_ruby_eval_body, (VALUE)&arg, +#ifdef HAVE_NATIVETHREAD + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on ip_ruby_eval()"); + } +#endif + res = rb_ensure(ip_ruby_eval_body, (VALUE)arg, ip_ruby_eval_ensure, INT2FIX(old_trapflag)); +#if TCL_MAJOR_VERSION >= 8 + free(arg->string); +#endif + + free(arg); + /* status check */ - if (arg.failed) { - VALUE eclass = rb_obj_class(arg.failed); + /* if (arg.failed) { */ + if (!NIL_P(RARRAY(exception)->ptr[0])) { + VALUE eclass; + volatile VALUE backtrace; + DUMP1("(rb_eval_string result) failed"); + Tcl_ResetResult(interp); - Tcl_AppendResult(interp, StringValuePtr(arg.failed), (char*)NULL); - if (eclass == eTkCallbackBreak) { + + res = RARRAY(exception)->ptr[0]; + eclass = rb_obj_class(res); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + DUMP1("set backtrace"); + backtrace = rb_ary_join(rb_funcall(res, ID_backtrace, 0, 0), + rb_str_new2("\n")); + StringValue(backtrace); + Tcl_AddErrorInfo(interp, RSTRING(backtrace)->ptr); + + rb_thread_critical = thr_crit_bup; + + if (eclass == eTkCallbackReturn) { + return TCL_RETURN; + + } else if (eclass == eTkCallbackBreak) { return TCL_BREAK; + } else if (eclass == eTkCallbackContinue) { return TCL_CONTINUE; + } else if (eclass == rb_eSystemExit) { - Tcl_Eval(interp, "destroy ."); - rb_raise(rb_eSystemExit, StringValuePtr(arg.failed)); + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* Tcl_Eval(interp, "destroy ."); */ + if (Tk_GetNumMainWindows() > 0) { + Tk_Window main_win = Tk_MainWindow(interp); + if (main_win != (Tk_Window)NULL) { + Tk_DestroyWindow(main_win); + } + } + + /* StringValue(res); */ + res = rb_funcall(res, ID_message, 0, 0); + + Tcl_AppendResult(interp, RSTRING(res)->ptr, (char*)NULL); + + rb_thread_critical = thr_crit_bup; + + rb_raise(rb_eSystemExit, RSTRING(res)->ptr); + + } else if (rb_obj_is_kind_of(res, eLocalJumpError)) { + VALUE reason = rb_ivar_get(res, ID_at_reason); + + if (TYPE(reason) != T_SYMBOL) { + ip_set_exc_message(interp, res); + return TCL_ERROR; + } + + if (SYM2ID(reason) == ID_return) { + return TCL_RETURN; + + } else if (SYM2ID(reason) == ID_break) { + return TCL_BREAK; + + } else if (SYM2ID(reason) == ID_next) { + return TCL_CONTINUE; + + } else { + ip_set_exc_message(interp, res); + return TCL_ERROR; + } } else { + ip_set_exc_message(interp, res); return TCL_ERROR; } } @@ -854,11 +1260,390 @@ ip_ruby(clientData, interp, argc, argv) } /* copy result to the tcl interpreter */ - DUMP2("(rb_eval_string result) %s", StringValuePtr(res)); + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + res = TkStringValue(res); + DUMP2("(rb_eval_string result) %s", RSTRING(res)->ptr); + DUMP1("Tcl_AppendResult"); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, RSTRING(res)->ptr, (char *)NULL); + + rb_thread_critical = thr_crit_bup; + + return TCL_OK; +} + + +/* Tcl command `ruby_cmd' */ +struct cmd_body_arg { + VALUE receiver; + ID method; + VALUE args; + VALUE failed; +}; + +static VALUE +ip_ruby_cmd_core(arg) + struct cmd_body_arg *arg; +{ + VALUE ret; + + DUMP1("call ip_ruby_cmd_core"); + ret = rb_apply(arg->receiver, arg->method, arg->args); + DUMP1("finish ip_ruby_cmd_core"); + + return ret; +} + +static VALUE +ip_ruby_cmd_rescue(failed, einfo) + VALUE failed; + VALUE einfo; +{ + DUMP1("call ip_ruby_cmd_rescue"); + RARRAY(failed)->ptr[0] = einfo; + return Qnil; +} + +static VALUE +ip_ruby_cmd_body(arg) + struct cmd_body_arg *arg; +{ + VALUE ret; + int status = 0; + int thr_crit_bup; + VALUE old_gc; + + volatile VALUE receiver = arg->receiver; + volatile VALUE args = arg->args; + volatile VALUE failed = arg->failed; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + DUMP1("call ip_ruby_cmd_body"); + rb_trap_immediate = 0; + +#if 0 + ret = rb_rescue2(ip_ruby_cmd_core, (VALUE)arg, + ip_ruby_cmd_rescue, arg->failed, + rb_eStandardError, rb_eScriptError, rb_eSystemExit, + (VALUE)0); +#else + ret = rb_protect(ip_ruby_cmd_core, (VALUE)arg, &status); + + if (status) { + char *errtype, *buf; + int errtype_len, len; + + old_gc = rb_gc_disable(); + + switch(status) { + case TAG_RETURN: + errtype = "LocalJumpError: "; + errtype_len = strlen(errtype); + len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len; + buf = ALLOC_N(char, len + 1); + strncpy(buf, errtype, errtype_len); + strncpy(buf + errtype_len, + RSTRING(rb_obj_as_string(ruby_errinfo))->ptr, + RSTRING(rb_obj_as_string(ruby_errinfo))->len); + *(buf + len) = 0; + + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackReturn, buf); + free(buf); + break; + + case TAG_BREAK: + errtype = "LocalJumpError: "; + errtype_len = strlen(errtype); + len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len; + buf = ALLOC_N(char, len + 1); + strncpy(buf, errtype, errtype_len); + strncpy(buf + errtype_len, + RSTRING(rb_obj_as_string(ruby_errinfo))->ptr, + RSTRING(rb_obj_as_string(ruby_errinfo))->len); + *(buf + len) = 0; + + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackBreak, buf); + free(buf); + break; + + case TAG_NEXT: + errtype = "LocalJumpError: "; + errtype_len = strlen(errtype); + len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len; + buf = ALLOC_N(char, len + 1); + strncpy(buf, errtype, errtype_len); + strncpy(buf + errtype_len, + RSTRING(rb_obj_as_string(ruby_errinfo))->ptr, + RSTRING(rb_obj_as_string(ruby_errinfo))->len); + *(buf + len) = 0; + + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackContinue,buf); + free(buf); + break; + + case TAG_RETRY: + case TAG_REDO: + RARRAY(arg->failed)->ptr[0] = ruby_errinfo; + break; + + case TAG_RAISE: + case TAG_FATAL: + RARRAY(arg->failed)->ptr[0] = ruby_errinfo; + break; + + default: + buf = ALLOC_N(char, 256); + rb_warn(buf, "unknown loncaljmp status %d", status); + RARRAY(arg->failed)->ptr[0] = rb_exc_new2(rb_eException, buf); + free(buf); + break; + } + + if (old_gc == Qfalse) rb_gc_enable(); + + ret = Qnil; + } +#endif + + rb_thread_critical = thr_crit_bup; + DUMP1("finish ip_ruby_cmd_body"); + + return ret; +} + +static VALUE +ip_ruby_cmd_ensure(trapflag) + VALUE trapflag; +{ + rb_trap_immediate = NUM2INT(trapflag); + return Qnil; +} + +/* ruby_cmd receiver method arg ... */ +static int +#if TCL_MAJOR_VERSION >= 8 +ip_ruby_cmd(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + Tcl_Obj *CONST argv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +ip_ruby_cmd(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + char *argv[]; +#endif +{ + volatile VALUE res; + volatile VALUE receiver; + volatile ID method; + volatile VALUE args = rb_ary_new2(argc - 2); + volatile VALUE exception = rb_ary_new2(1); + char *str; + int i; + int len; + int old_trapflag; + struct cmd_body_arg *arg; + int thr_crit_bup; + VALUE old_gc; + + if (argc < 3) { + rb_raise(rb_eArgError, "too few arguments"); + } + + /* allocate */ + arg = ALLOC(struct cmd_body_arg); + + /* get arguments from Tcl objects */ + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + old_gc = rb_gc_disable(); + + /* get receiver */ +#if TCL_MAJOR_VERSION >= 8 + str = Tcl_GetStringFromObj(argv[1], &len); +#else /* TCL_MAJOR_VERSION < 8 */ + str = argv[1]; +#endif + DUMP2("receiver:%s",str); + if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) { + /* class | module | constant */ + receiver = rb_const_get(rb_cObject, rb_intern(str)); + } else if (str[0] == '$') { + /* global variable */ + receiver = rb_gv_get(str); + } else { + /* global variable omitted '$' */ + char *buf; + + len = strlen(str); + buf = ALLOC_N(char, len + 2); + buf[0] = '$'; + strncpy(buf + 1, str, len); + buf[len + 1] = 0; + receiver = rb_gv_get(buf); + free(buf); + } + if (NIL_P(receiver)) { + rb_raise(rb_eArgError, "unknown class/module/global-variable '%s'", + str); + } + + /* get metrhod */ +#if TCL_MAJOR_VERSION >= 8 + str = Tcl_GetStringFromObj(argv[2], &len); +#else /* TCL_MAJOR_VERSION < 8 */ + str = argv[2]; +#endif + method = rb_intern(str); + + /* get args */ + RARRAY(args)->len = 0; + for(i = 3; i < argc; i++) { +#if TCL_MAJOR_VERSION >= 8 + str = Tcl_GetStringFromObj(argv[i], &len); + DUMP2("arg:%s",str); + RARRAY(args)->ptr[RARRAY(args)->len++] = rb_tainted_str_new(str, len); +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP2("arg:%s",argv[i]); + RARRAY(args)->ptr[RARRAY(args)->len++] = rb_tainted_str_new2(argv[i]); +#endif + } + + if (old_gc == Qfalse) rb_gc_enable(); + rb_thread_critical = thr_crit_bup; + + RARRAY(exception)->ptr[0] = Qnil; + + arg->receiver = receiver; + arg->method = method; + arg->args = args; + arg->failed = exception; + + /* evaluate the argument string by ruby */ + old_trapflag = rb_trap_immediate; +#ifdef HAVE_NATIVETHREAD + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on ip_ruby_cmd()"); + } +#endif + + res = rb_ensure(ip_ruby_cmd_body, (VALUE)arg, + ip_ruby_cmd_ensure, INT2FIX(old_trapflag)); + + free(arg); + + /* status check */ + /* if (arg.failed) { */ + if (!NIL_P(RARRAY(exception)->ptr[0])) { + VALUE eclass; + volatile VALUE backtrace; + + DUMP1("(rb_eval_cmd result) failed"); + + Tcl_ResetResult(interp); + + res = RARRAY(exception)->ptr[0]; + eclass = rb_obj_class(res); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + DUMP1("set backtrace"); + backtrace = rb_ary_join(rb_funcall(res, ID_backtrace, 0, 0), + rb_str_new2("\n")); + StringValue(backtrace); + Tcl_AddErrorInfo(interp, RSTRING(backtrace)->ptr); + + rb_thread_critical = thr_crit_bup; + + if (eclass == eTkCallbackReturn) { + return TCL_RETURN; + + } else if (eclass == eTkCallbackBreak) { + return TCL_BREAK; + + } else if (eclass == eTkCallbackContinue) { + return TCL_CONTINUE; + + } else if (eclass == rb_eSystemExit) { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* Tcl_Eval(interp, "destroy ."); */ + if (Tk_GetNumMainWindows() > 0) { + Tk_Window main_win = Tk_MainWindow(interp); + if (main_win != (Tk_Window)NULL) { + Tk_DestroyWindow(main_win); + } + } + + /* StringValue(res); */ + res = rb_funcall(res, ID_message, 0, 0); + + Tcl_AppendResult(interp, RSTRING(res)->ptr, (char*)NULL); + + rb_thread_critical = thr_crit_bup; + + rb_raise(rb_eSystemExit, RSTRING(res)->ptr); + } else if (rb_obj_is_kind_of(res, eLocalJumpError)) { + VALUE reason = rb_ivar_get(res, ID_at_reason); + + if (TYPE(reason) != T_SYMBOL) { + ip_set_exc_message(interp, res); + return TCL_ERROR; + } + + if (SYM2ID(reason) == ID_return) { + return TCL_RETURN; + + } else if (SYM2ID(reason) == ID_break) { + return TCL_BREAK; + + } else if (SYM2ID(reason) == ID_next) { + return TCL_CONTINUE; + + } else { + ip_set_exc_message(interp, res); + return TCL_ERROR; + } + } else { + ip_set_exc_message(interp, res); + return TCL_ERROR; + } + } + + /* result must be string or nil */ + if (NIL_P(res)) { + DUMP1("(rb_eval_cmd result) nil"); + Tcl_ResetResult(interp); + return TCL_OK; + } + + + /* copy result to the tcl interpreter */ + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + + old_gc = rb_gc_disable(); + + res = TkStringValue(res); + + if (old_gc == Qfalse) rb_gc_enable(); + DUMP2("(rb_eval_cmd result) '%s'", RSTRING(res)->ptr); DUMP1("Tcl_AppendResult"); Tcl_ResetResult(interp); - Tcl_AppendResult(interp, StringValuePtr(res), (char *)NULL); + Tcl_AppendResult(interp, RSTRING(res)->ptr, (char *)NULL); + + rb_thread_critical = thr_crit_bup; + DUMP1("end of ip_ruby_cmd"); return TCL_OK; } @@ -866,8 +1651,236 @@ ip_ruby(clientData, interp, argc, argv) /**************************/ /* based on tclEvent.c */ /**************************/ -static char *VwaitVarProc _((ClientData, Tcl_Interp *, CONST84 char *, - CONST84 char *, int)); + +#if 0 /* + Disable the following "update" and "thread_update". Bcause, + they don't work in a callback-proc. After calling update in + a callback-proc, the callback proc never be worked. + If the problem will be fixed in the future, may enable the + functions. + */ +/*********************/ +/* replace of update */ +/*********************/ +#if TCL_MAJOR_VERSION >= 8 +static int ip_rbUpdateObjCmd _((ClientData, Tcl_Interp *, int, + Tcl_Obj *CONST [])); +static int +ip_rbUpdateObjCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +static int ip_rbUpdateCommand _((ClientData, Tcl_Interp *, int, char *[])); +static int +ip_rbUpdateCommand(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + char *objv[]; +#endif +{ + int optionIndex; + int ret, done; + int flags = 0; + static CONST char *updateOptions[] = {"idletasks", (char *) NULL}; + enum updateOptions {REGEXP_IDLETASKS}; + char *nameString; + int dummy; + + DUMP1("Ruby's 'update' is called"); + if (objc == 1) { + flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; + + } else if (objc == 2) { + if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, + "option", 0, &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum updateOptions) optionIndex) { + case REGEXP_IDLETASKS: { + flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + break; + } + default: { + Tcl_Panic("ip_rbUpdateObjCmd: bad option index to UpdateOptions"); + } + } + } else { +#ifdef Tcl_WrongNumArgs + Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]"); +#else +# if TCL_MAJOR_VERSION >= 8 + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + Tcl_GetStringFromObj(objv[0], &dummy), + " [ idletasks ]\"", + (char *) NULL); +# else /* TCL_MAJOR_VERSION < 8 */ + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + objv[0], " [ idletasks ]\"", (char *) NULL); +# endif +#endif + return TCL_ERROR; + } + + /* call eventloop */ +#if 1 + ret = lib_eventloop_core(0, flags, (int *)NULL); /* ignore result */ +#else + Tcl_UpdateObjCmd(clientData, interp, objc, objv); +#endif + + /* + * Must clear the interpreter's result because event handlers could + * have executed commands. + */ + + DUMP2("last result '%s'", Tcl_GetStringResult(interp)); + Tcl_ResetResult(interp); + DUMP1("finish Ruby's 'update'"); + return TCL_OK; +} + + +/**********************/ +/* update with thread */ +/**********************/ +struct th_update_param { + VALUE thread; + int done; +}; + +static void rb_threadUpdateProc _((ClientData)); +static void +rb_threadUpdateProc(clientData) + ClientData clientData; /* Pointer to integer to set to 1. */ +{ + struct th_update_param *param = (struct th_update_param *) clientData; + + DUMP1("threadUpdateProc is called"); + param->done = 1; + rb_thread_run(param->thread); + + return; +} + +#if TCL_MAJOR_VERSION >= 8 +static int ip_rb_threadUpdateObjCmd _((ClientData, Tcl_Interp *, int, + Tcl_Obj *CONST [])); +static int +ip_rb_threadUpdateObjCmd(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +#else /* TCL_MAJOR_VERSION < 8 */ +static int ip_rb_threadUpdateCommand _((ClientData, Tcl_Interp *, int, + char *[])); +static int +ip_rb_threadUpdateCommand(clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int objc; + char *objv[]; +#endif +{ + int optionIndex; + int ret, done; + int flags = 0; + int dummy; + struct th_update_param *param; + static CONST char *updateOptions[] = {"idletasks", (char *) NULL}; + enum updateOptions {REGEXP_IDLETASKS}; + volatile VALUE current_thread = rb_thread_current(); + + DUMP1("Ruby's 'thread_update' is called"); + + if (rb_thread_alone() || eventloop_thread == current_thread) { +#define USE_TCL_UPDATE 0 +#if TCL_MAJOR_VERSION >= 8 +# if USE_TCL_UPDATE + DUMP1("call Tcl_UpdateObjCmd"); + return Tcl_UpdateObjCmd(clientData, interp, objc, objv); +# else + DUMP1("call ip_rbUpdateObjCmd"); + return ip_rbUpdateObjCmd(clientData, interp, objc, objv); +# endif +#else /* TCL_MAJOR_VERSION < 8 */ +# if USE_TCL_UPDATE + DUMP1("call ip_rbUpdateCommand"); + return Tcl_UpdateCommand(clientData, interp, objc, objv); +# else + DUMP1("call ip_rbUpdateCommand"); + return ip_rbUpdateCommand(clientData, interp, objc, objv); +# endif +#endif + } + + DUMP1("start Ruby's 'thread_update' body"); + + if (objc == 1) { + flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; + + } else if (objc == 2) { + if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, + "option", 0, &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum updateOptions) optionIndex) { + case REGEXP_IDLETASKS: { + flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + break; + } + default: { + Tcl_Panic("ip_rb_threadUpdateObjCmd: bad option index to UpdateOptions"); + } + } + } else { +#ifdef Tcl_WrongNumArgs + Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]"); +#else +# if TCL_MAJOR_VERSION >= 8 + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + Tcl_GetStringFromObj(objv[0], &dummy), + " [ idletasks ]\"", + (char *) NULL); +# else /* TCL_MAJOR_VERSION < 8 */ + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", + objv[0], " [ idletasks ]\"", (char *) NULL); +# endif +#endif + return TCL_ERROR; + } + + DUMP1("pass argument check"); + + param = (struct th_update_param *)Tcl_Alloc(sizeof(struct th_update_param)); + param->thread = current_thread; + param->done = 0; + + DUMP1("set idle proc"); + Tcl_DoWhenIdle(rb_threadUpdateProc, (ClientData) param); + + while(!param->done) { + DUMP1("wait for complete idle proc"); + rb_thread_stop(); + } + + Tcl_Free((char *)param); + + DUMP1("finish Ruby's 'thread_update'"); + return TCL_OK; +} +#endif /* update and thread_update don't work internal callback proc */ + + +/***************************/ +/* replace of vwait/tkwait */ +/***************************/ +#if TCL_MAJOR_VERSION >= 8 +static char *VwaitVarProc _((ClientData, Tcl_Interp *, + CONST84 char *,CONST84 char *, int)); static char * VwaitVarProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Pointer to integer to set to 1. */ @@ -875,6 +1888,16 @@ VwaitVarProc(clientData, interp, name1, name2, flags) CONST84 char *name1; /* Name of variable. */ CONST84 char *name2; /* Second part of variable name. */ int flags; /* Information about what happened. */ +#else /* TCL_MAJOR_VERSION < 8 */ +static char *VwaitVarProc _((ClientData, Tcl_Interp *, char *, char *, int)); +static char * +VwaitVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +#endif { int *donePtr = (int *) clientData; @@ -891,7 +1914,7 @@ ip_rbVwaitObjCmd(clientData, interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; -#else +#else /* TCL_MAJOR_VERSION < 8 */ static int ip_rbVwaitCommand _((ClientData, Tcl_Interp *, int, char *[])); static int ip_rbVwaitCommand(clientData, interp, objc, objv) @@ -901,44 +1924,71 @@ ip_rbVwaitCommand(clientData, interp, objc, objv) char *objv[]; #endif { - int done, foundEvent; + int ret, done, foundEvent; char *nameString; int dummy; + int thr_crit_bup; DUMP1("Ruby's 'vwait' is called"); if (objc != 2) { #ifdef Tcl_WrongNumArgs Tcl_WrongNumArgs(interp, 1, objv, "name"); #else + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + #if TCL_MAJOR_VERSION >= 8 /* nameString = Tcl_GetString(objv[0]); */ nameString = Tcl_GetStringFromObj(objv[0], &dummy); -#else +#else /* TCL_MAJOR_VERSION < 8 */ nameString = objv[0]; #endif - Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", nameString, " name\"", (char *) NULL); + + rb_thread_critical = thr_crit_bup; #endif return TCL_ERROR; } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + #if TCL_MAJOR_VERSION >= 8 /* nameString = Tcl_GetString(objv[1]); */ nameString = Tcl_GetStringFromObj(objv[1], &dummy); -#else +#else /* TCL_MAJOR_VERSION < 8 */ nameString = objv[1]; #endif + /* if (Tcl_TraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done) != TCL_OK) { return TCL_ERROR; - }; + } + */ + ret = Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done); + + rb_thread_critical = thr_crit_bup; + + if (ret != TCL_OK) { + return TCL_ERROR; + } done = 0; - foundEvent = lib_eventloop_core(/* not check root-widget */0, &done); + foundEvent = lib_eventloop_core(/* not check root-widget */0, 0, &done); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + Tcl_UntraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done); + rb_thread_critical = thr_crit_bup; + /* * Clear out the interpreter's result, since it may have been set * by event handlers. @@ -946,8 +1996,14 @@ ip_rbVwaitCommand(clientData, interp, objc, objv) Tcl_ResetResult(interp); if (!foundEvent) { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + Tcl_AppendResult(interp, "can't wait for variable \"", nameString, "\": would wait forever", (char *) NULL); + + rb_thread_critical = thr_crit_bup; + return TCL_ERROR; } return TCL_OK; @@ -957,8 +2013,9 @@ ip_rbVwaitCommand(clientData, interp, objc, objv) /**************************/ /* based on tkCmd.c */ /**************************/ -static char *WaitVariableProc _((ClientData, Tcl_Interp *, CONST84 char *, - CONST84 char *, int)); +#if TCL_MAJOR_VERSION >= 8 +static char *WaitVariableProc _((ClientData, Tcl_Interp *, + CONST84 char *,CONST84 char *, int)); static char * WaitVariableProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Pointer to integer to set to 1. */ @@ -966,6 +2023,17 @@ WaitVariableProc(clientData, interp, name1, name2, flags) CONST84 char *name1; /* Name of variable. */ CONST84 char *name2; /* Second part of variable name. */ int flags; /* Information about what happened. */ +#else /* TCL_MAJOR_VERSION < 8 */ +static char *WaitVariableProc _((ClientData, Tcl_Interp *, + char *, char *, int)); +static char * +WaitVariableProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +#endif { int *donePtr = (int *) clientData; @@ -1011,7 +2079,7 @@ ip_rbTkWaitObjCmd(clientData, interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; -#else +#else /* TCL_MAJOR_VERSION < 8 */ static int ip_rbTkWaitCommand _((ClientData, Tcl_Interp *, int, char *[])); static int ip_rbTkWaitCommand(clientData, interp, objc, objv) @@ -1027,7 +2095,8 @@ ip_rbTkWaitCommand(clientData, interp, objc, objv) (char *) NULL }; enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW }; char *nameString; - int dummy; + int ret, dummy; + int thr_crit_bup; DUMP1("Ruby's 'tkwait' is called"); @@ -1035,27 +2104,46 @@ ip_rbTkWaitCommand(clientData, interp, objc, objv) #ifdef Tcl_WrongNumArgs Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); #else + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + #if TCL_MAJOR_VERSION >= 8 - Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", Tcl_GetStringFromObj(objv[0], &dummy), " variable|visibility|window name\"", (char *) NULL); -#else - Tcl_AppendResult(interp, "wrong # args: should be \"", +#else /* TCL_MAJOR_VERSION < 8 */ + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", objv[0], " variable|visibility|window name\"", (char *) NULL); #endif + + rb_thread_critical = thr_crit_bup; #endif return TCL_ERROR; } #if TCL_MAJOR_VERSION >= 8 + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)optionStrings, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } -#else + */ + ret = Tcl_GetIndexFromObj(interp, objv[1], + (CONST84 char **)optionStrings, + "option", 0, &index); + + rb_thread_critical = thr_crit_bup; + + if (ret != TCL_OK) { + return TCL_ERROR; + } +#else /* TCL_MAJOR_VERSION < 8 */ { int c = objv[1][0]; size_t length = strlen(objv[1]); @@ -1077,69 +2165,122 @@ ip_rbTkWaitCommand(clientData, interp, objc, objv) } #endif + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + #if TCL_MAJOR_VERSION >= 8 /* nameString = Tcl_GetString(objv[2]); */ nameString = Tcl_GetStringFromObj(objv[2], &dummy); -#else +#else /* TCL_MAJOR_VERSION < 8 */ nameString = objv[2]; #endif + rb_thread_critical = thr_crit_bup; + switch ((enum options) index) { case TKWAIT_VARIABLE: { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + /* if (Tcl_TraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, WaitVariableProc, (ClientData) &done) != TCL_OK) { return TCL_ERROR; } + */ + ret = Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + WaitVariableProc, (ClientData) &done); + + rb_thread_critical = thr_crit_bup; + + if (ret != TCL_OK) { + return TCL_ERROR; + } done = 0; - lib_eventloop_core(check_rootwidget_flag, &done); + lib_eventloop_core(check_rootwidget_flag, 0, &done); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + Tcl_UntraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, WaitVariableProc, (ClientData) &done); + + rb_thread_critical = thr_crit_bup; + break; } case TKWAIT_VISIBILITY: { Tk_Window window; + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + window = Tk_NameToWindow(interp, nameString, tkwin); if (window == NULL) { + rb_thread_critical = thr_crit_bup; return TCL_ERROR; } + Tk_CreateEventHandler(window, VisibilityChangeMask|StructureNotifyMask, WaitVisibilityProc, (ClientData) &done); + + rb_thread_critical = thr_crit_bup; + done = 0; - lib_eventloop_core(check_rootwidget_flag, &done); + lib_eventloop_core(check_rootwidget_flag, 0, &done); if (done != 1) { /* * Note that we do not delete the event handler because it * was deleted automatically when the window was destroyed. */ + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; Tcl_ResetResult(interp); Tcl_AppendResult(interp, "window \"", nameString, "\" was deleted before its visibility changed", (char *) NULL); + + rb_thread_critical = thr_crit_bup; + return TCL_ERROR; } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + Tk_DeleteEventHandler(window, VisibilityChangeMask|StructureNotifyMask, WaitVisibilityProc, (ClientData) &done); + + rb_thread_critical = thr_crit_bup; + break; } case TKWAIT_WINDOW: { Tk_Window window; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; window = Tk_NameToWindow(interp, nameString, tkwin); if (window == NULL) { + rb_thread_critical = thr_crit_bup; return TCL_ERROR; } + Tk_CreateEventHandler(window, StructureNotifyMask, WaitWindowProc, (ClientData) &done); + + rb_thread_critical = thr_crit_bup; + done = 0; - lib_eventloop_core(check_rootwidget_flag, &done); + lib_eventloop_core(check_rootwidget_flag, 0, &done); /* * Note: there's no need to delete the event handler. It was * deleted automatically when the window was destroyed. @@ -1165,8 +2306,9 @@ struct th_vwait_param { int done; }; -static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *, CONST84 char *, - CONST84 char *, int)); +#if TCL_MAJOR_VERSION >= 8 +static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *, + CONST84 char *,CONST84 char *, int)); static char * rb_threadVwaitProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Pointer to integer to set to 1. */ @@ -1174,6 +2316,17 @@ rb_threadVwaitProc(clientData, interp, name1, name2, flags) CONST84 char *name1; /* Name of variable. */ CONST84 char *name2; /* Second part of variable name. */ int flags; /* Information about what happened. */ +#else /* TCL_MAJOR_VERSION < 8 */ +static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *, + char *, char *, int)); +static char * +rb_threadVwaitProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +#endif { struct th_vwait_param *param = (struct th_vwait_param *) clientData; @@ -1197,6 +2350,7 @@ rb_threadWaitVisibilityProc(clientData, eventPtr) if (eventPtr->type == DestroyNotify) { param->done = 2; } + rb_thread_run(param->thread); } static void rb_threadWaitWindowProc _((ClientData, XEvent *)); @@ -1210,6 +2364,7 @@ rb_threadWaitWindowProc(clientData, eventPtr) if (eventPtr->type == DestroyNotify) { param->done = 1; } + rb_thread_run(param->thread); } #if TCL_MAJOR_VERSION >= 8 @@ -1221,7 +2376,7 @@ ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; -#else +#else /* TCL_MAJOR_VERSION < 8 */ static int ip_rb_threadVwaitCommand _((ClientData, Tcl_Interp *, int, char *[])); static int @@ -1234,15 +2389,17 @@ ip_rb_threadVwaitCommand(clientData, interp, objc, objv) { struct th_vwait_param *param; char *nameString; - int dummy; + int ret, dummy; + int thr_crit_bup; + volatile VALUE current_thread = rb_thread_current(); DUMP1("Ruby's 'thread_vwait' is called"); - if (eventloop_thread == rb_thread_current()) { + if (rb_thread_alone() || eventloop_thread == current_thread) { #if TCL_MAJOR_VERSION >= 8 DUMP1("call ip_rbVwaitObjCmd"); return ip_rbVwaitObjCmd(clientData, interp, objc, objv); -#else +#else /* TCL_MAJOR_VERSION < 8 */ DUMP1("call ip_rbVwaitCommand"); return ip_rbVwaitCommand(clientData, interp, objc, objv); #endif @@ -1252,44 +2409,69 @@ ip_rb_threadVwaitCommand(clientData, interp, objc, objv) #ifdef Tcl_WrongNumArgs Tcl_WrongNumArgs(interp, 1, objv, "name"); #else + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + #if TCL_MAJOR_VERSION >= 8 /* nameString = Tcl_GetString(objv[0]); */ nameString = Tcl_GetStringFromObj(objv[0], &dummy); -#else +#else /* TCL_MAJOR_VERSION < 8 */ nameString = objv[0]; #endif - Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", nameString, " name\"", (char *) NULL); + + rb_thread_critical = thr_crit_bup; #endif return TCL_ERROR; } #if TCL_MAJOR_VERSION >= 8 /* nameString = Tcl_GetString(objv[1]); */ nameString = Tcl_GetStringFromObj(objv[1], &dummy); -#else +#else /* TCL_MAJOR_VERSION < 8 */ nameString = objv[1]; #endif + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); - param->thread = rb_thread_current(); + param->thread = current_thread; param->done = 0; + /* if (Tcl_TraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, rb_threadVwaitProc, (ClientData) param) != TCL_OK) { return TCL_ERROR; - }; + } + */ + ret = Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + rb_threadVwaitProc, (ClientData) param); + + rb_thread_critical = thr_crit_bup; + + if (ret != TCL_OK) { + return TCL_ERROR; + } - if (!param->done) { + /* if (!param->done) { */ + while(!param->done) { rb_thread_stop(); } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + Tcl_UntraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, rb_threadVwaitProc, (ClientData) param); Tcl_Free((char *)param); + rb_thread_critical = thr_crit_bup; + return TCL_OK; } @@ -1302,7 +2484,7 @@ ip_rb_threadTkWaitObjCmd(clientData, interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; -#else +#else /* TCL_MAJOR_VERSION < 8 */ static int ip_rb_threadTkWaitCommand _((ClientData, Tcl_Interp *, int, char *[])); static int @@ -1320,15 +2502,17 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) (char *) NULL }; enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW }; char *nameString; - int dummy; + int ret, dummy; + int thr_crit_bup; + volatile VALUE current_thread = rb_thread_current(); DUMP1("Ruby's 'thread_tkwait' is called"); - if (eventloop_thread == rb_thread_current()) { + if (rb_thread_alone() || eventloop_thread == current_thread) { #if TCL_MAJOR_VERSION >= 8 DUMP1("call ip_rbTkWaitObjCmd"); return ip_rbTkWaitObjCmd(clientData, interp, objc, objv); -#else +#else /* TCL_MAJOR_VERSION < 8 */ DUMP1("call rb_VwaitCommand"); return ip_rbTkWaitCommand(clientData, interp, objc, objv); #endif @@ -1338,27 +2522,45 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) #ifdef Tcl_WrongNumArgs Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); #else + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + #if TCL_MAJOR_VERSION >= 8 - Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", Tcl_GetStringFromObj(objv[0], &dummy), " variable|visibility|window name\"", (char *) NULL); -#else - Tcl_AppendResult(interp, "wrong # args: should be \"", +#else /* TCL_MAJOR_VERSION < 8 */ + Tcl_AppendResult(interp, "wrong number of arguments: should be \"", objv[0], " variable|visibility|window name\"", (char *) NULL); #endif + + rb_thread_critical = thr_crit_bup; #endif return TCL_ERROR; } #if TCL_MAJOR_VERSION >= 8 + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + /* if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)optionStrings, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } -#else + */ + ret = Tcl_GetIndexFromObj(interp, objv[1], + (CONST84 char **)optionStrings, + "option", 0, &index); + + rb_thread_critical = thr_crit_bup; + + if (ret != TCL_OK) { + return TCL_ERROR; + } +#else /* TCL_MAJOR_VERSION < 8 */ { int c = objv[1][0]; size_t length = strlen(objv[1]); @@ -1380,85 +2582,139 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) } #endif + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + #if TCL_MAJOR_VERSION >= 8 /* nameString = Tcl_GetString(objv[2]); */ nameString = Tcl_GetStringFromObj(objv[2], &dummy); -#else +#else /* TCL_MAJOR_VERSION < 8 */ nameString = objv[2]; #endif param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); - param->thread = rb_thread_current(); + param->thread = current_thread; param->done = 0; + rb_thread_critical = thr_crit_bup; + switch ((enum options) index) { case TKWAIT_VARIABLE: { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + /* if (Tcl_TraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, rb_threadVwaitProc, (ClientData) param) != TCL_OK) { return TCL_ERROR; - }; + } + */ + ret = Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + rb_threadVwaitProc, (ClientData) param); - if (!param->done) { + rb_thread_critical = thr_crit_bup; + + if (ret != TCL_OK) { + return TCL_ERROR; + } + + /* if (!param->done) { */ + while(!param->done) { rb_thread_stop(); } + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + Tcl_UntraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, rb_threadVwaitProc, (ClientData) param); + + rb_thread_critical = thr_crit_bup; + break; } case TKWAIT_VISIBILITY: { Tk_Window window; + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + window = Tk_NameToWindow(interp, nameString, tkwin); if (window == NULL) { + rb_thread_critical = thr_crit_bup; return TCL_ERROR; } + Tk_CreateEventHandler(window, VisibilityChangeMask|StructureNotifyMask, rb_threadWaitVisibilityProc, (ClientData) param); - if (!param->done) { + + rb_thread_critical = thr_crit_bup; + + /* if (!param->done) { */ + while(!param->done) { rb_thread_stop(); } - if (param->done != 1) { - /* - * Note that we do not delete the event handler because it - * was deleted automatically when the window was destroyed. - */ + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + Tk_DeleteEventHandler(window, + VisibilityChangeMask|StructureNotifyMask, + rb_threadWaitVisibilityProc, (ClientData) param); + + if (param->done != 1) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "window \"", nameString, "\" was deleted before its visibility changed", (char *) NULL); + + rb_thread_critical = thr_crit_bup; + return TCL_ERROR; } - Tk_DeleteEventHandler(window, - VisibilityChangeMask|StructureNotifyMask, - rb_threadWaitVisibilityProc, (ClientData) param); + + rb_thread_critical = thr_crit_bup; + break; } case TKWAIT_WINDOW: { Tk_Window window; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; window = Tk_NameToWindow(interp, nameString, tkwin); if (window == NULL) { + rb_thread_critical = thr_crit_bup; return TCL_ERROR; } + Tk_CreateEventHandler(window, StructureNotifyMask, rb_threadWaitWindowProc, (ClientData) param); - if (!param->done) { + + rb_thread_critical = thr_crit_bup; + + /* if (!param->done) { */ + while(!param->done) { rb_thread_stop(); } - /* - * Note: there's no need to delete the event handler. It was - * deleted automatically when the window was destroyed. - */ + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + Tk_DeleteEventHandler(window, StructureNotifyMask, + rb_threadWaitWindowProc, (ClientData) param); + + rb_thread_critical = thr_crit_bup; + break; } - } + } /* end of 'switch' statement */ Tcl_Free((char *)param); @@ -1499,16 +2755,48 @@ ip_thread_tkwait(self, mode, target) /* destroy interpreter */ +VALUE del_root(ip) + Tcl_Interp *ip; +{ + Tcl_Preserve(ip); + Tk_DestroyWindow(Tk_MainWindow(ip)); + Tcl_Release(ip); + return Qnil; +} + static void ip_free(ptr) struct tcltkip *ptr; { - DUMP1("Tcl_DeleteInterp"); + int try = 3; + Tcl_CmdInfo info; + int thr_crit_bup; + + DUMP1("free Tcl Interp"); if (ptr) { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (!Tcl_InterpDeleted(ptr->ip)) { + Tcl_ResetResult(ptr->ip); + Tcl_Preserve(ptr->ip); + if (Tcl_GetCommandInfo(ptr->ip, finalize_hook_name, &info)) { + DUMP2("call finalize hook proc '%s'", finalize_hook_name); + Tcl_Eval(ptr->ip, finalize_hook_name); + } + for(; try > 0; try--) { + if (!Tk_GetNumMainWindows()) break; + rb_protect(del_root, (VALUE)(ptr->ip), 0); + } + Tcl_Release(ptr->ip); + Tcl_DeleteInterp(ptr->ip); + } Tcl_Release((ClientData)ptr->ip); - Tcl_DeleteInterp(ptr->ip); free(ptr); + + rb_thread_critical = thr_crit_bup; } + DUMP1("complete freeing Tcl Interp"); } /* create and initialize interpreter */ @@ -1530,6 +2818,7 @@ ip_init(argc, argv, self) VALUE argv0, opts; int cnt; int with_tk = 1; + Tk_Window mainWin; /* create object */ Data_Get_Struct(self, struct tcltkip, ptr); @@ -1546,7 +2835,11 @@ ip_init(argc, argv, self) /* from Tcl_AppInit() */ DUMP1("Tcl_Init"); if (Tcl_Init(ptr->ip) == TCL_ERROR) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif } /* set variables */ @@ -1554,7 +2847,7 @@ ip_init(argc, argv, self) switch(cnt) { case 2: /* options */ - if (opts == Qnil || opts == Qfalse) { + if (NIL_P(opts) || opts == Qfalse) { /* without Tk */ with_tk = 0; } else { @@ -1562,7 +2855,7 @@ ip_init(argc, argv, self) } case 1: /* argv0 */ - if (argv0 != Qnil) { + if (!NIL_P(argv0)) { Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0); } case 0: @@ -1574,70 +2867,119 @@ ip_init(argc, argv, self) if (with_tk) { DUMP1("Tk_Init"); if (Tk_Init(ptr->ip) == TCL_ERROR) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif } DUMP1("Tcl_StaticPackage(\"Tk\")"); #if TCL_MAJOR_VERSION >= 8 Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, Tk_SafeInit); -#else +#else /* TCL_MAJOR_VERSION < 8 */ Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, (Tcl_PackageInitProc *) NULL); #endif } + /* get main window */ + mainWin = Tk_MainWindow(ptr->ip); + /* add ruby command to the interpreter */ #if TCL_MAJOR_VERSION >= 8 DUMP1("Tcl_CreateObjCommand(\"ruby\")"); - Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby, (ClientData)NULL, + Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#else + DUMP1("Tcl_CreateObjCommand(\"ruby_eval\")"); + Tcl_CreateObjCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL, + (Tcl_CmdDeleteProc *)NULL); + DUMP1("Tcl_CreateObjCommand(\"ruby_cmd\")"); + Tcl_CreateObjCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL, + (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ DUMP1("Tcl_CreateCommand(\"ruby\")"); - Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby, (ClientData)NULL, + Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL, + (Tcl_CmdDeleteProc *)NULL); + DUMP1("Tcl_CreateCommand(\"ruby_eval\")"); + Tcl_CreateCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); + DUMP1("Tcl_CreateCommand(\"ruby_cmd\")"); + Tcl_CreateCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL, + (Tcl_CmdDeleteProc *)NULL); +#endif + +#if 0 /* + Disable the following "update" and "thread_update". Bcause, + they don't work in a callback-proc. After calling update in + a callback-proc, the callback proc never be worked. + If the problem will be fixed in the future, may enable the + functions. + */ + /* replace 'update' command */ +# if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"update\")"); + Tcl_CreateObjCommand(ptr->ip, "update", ip_rbUpdateObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +# else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"update\")"); + Tcl_CreateCommand(ptr->ip, "update", ip_rbUpdateCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +# endif + + /* add 'thread_update' command */ +# if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"thread_update\")"); + Tcl_CreateObjCommand(ptr->ip, "thread_update", ip_rb_threadUpdateObjCmd, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +# else /* TCL_MAJOR_VERSION < 8 */ + DUMP1("Tcl_CreateCommand(\"thread_update\")"); + Tcl_CreateCommand(ptr->ip, "thread_update", ip_rb_threadUpdateCommand, + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +# endif #endif /* replace 'vwait' command */ #if TCL_MAJOR_VERSION >= 8 DUMP1("Tcl_CreateObjCommand(\"vwait\")"); Tcl_CreateObjCommand(ptr->ip, "vwait", ip_rbVwaitObjCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#else + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ DUMP1("Tcl_CreateCommand(\"vwait\")"); Tcl_CreateCommand(ptr->ip, "vwait", ip_rbVwaitCommand, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); #endif /* replace 'tkwait' command */ #if TCL_MAJOR_VERSION >= 8 DUMP1("Tcl_CreateObjCommand(\"tkwait\")"); Tcl_CreateObjCommand(ptr->ip, "tkwait", ip_rbTkWaitObjCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#else + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ DUMP1("Tcl_CreateCommand(\"tkwait\")"); Tcl_CreateCommand(ptr->ip, "tkwait", ip_rbTkWaitCommand, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); #endif /* add 'thread_vwait' command */ #if TCL_MAJOR_VERSION >= 8 DUMP1("Tcl_CreateObjCommand(\"thread_vwait\")"); Tcl_CreateObjCommand(ptr->ip, "thread_vwait", ip_rb_threadVwaitObjCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#else + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ DUMP1("Tcl_CreateCommand(\"thread_vwait\")"); Tcl_CreateCommand(ptr->ip, "thread_vwait", ip_rb_threadVwaitCommand, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); #endif /* add 'thread_tkwait' command */ #if TCL_MAJOR_VERSION >= 8 DUMP1("Tcl_CreateObjCommand(\"thread_tkwait\")"); Tcl_CreateObjCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitObjCmd, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); -#else + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); +#else /* TCL_MAJOR_VERSION < 8 */ DUMP1("Tcl_CreateCommand(\"thread_tkwait\")"); Tcl_CreateCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitCommand, - (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); + (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); #endif return self; @@ -1651,9 +2993,10 @@ ip_create_slave(argc, argv, self) { struct tcltkip *master = get_ip(self); struct tcltkip *slave = ALLOC(struct tcltkip); - VALUE name; VALUE safemode; + VALUE name; int safe; + int thr_crit_bup; /* safe-mode check */ if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) { @@ -1661,21 +3004,26 @@ ip_create_slave(argc, argv, self) } if (Tcl_IsSafe(master->ip) == 1) { safe = 1; - } else if (safemode == Qfalse || safemode == Qnil) { + } else if (safemode == Qfalse || NIL_P(safemode)) { safe = 0; rb_secure(4); } else { safe = 1; } + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + /* create slave-ip */ - if ((slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe)) - == NULL) { + slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe); + if (slave->ip == NULL) { rb_raise(rb_eRuntimeError, "fail to create the new slave interpreter"); } Tcl_Preserve((ClientData)slave->ip); slave->return_value = 0; + rb_thread_critical = thr_crit_bup; + return Data_Wrap_Struct(CLASS_OF(self), 0, ip_free, slave); } @@ -1687,7 +3035,11 @@ ip_make_safe(self) struct tcltkip *ptr = get_ip(self); if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif } return self; @@ -1734,30 +3086,124 @@ ip_is_deleted_p(self) } +static VALUE +#ifdef HAVE_STDARG_PROTOTYPES +create_ip_exc(VALUE interp, VALUE exc, const char *fmt, ...) +#else +create_ip_exc(interp, exc, fmt, va_alist) + VALUE interp: + VALUE exc; + const char *fmt; + va_dcl +#endif +{ + va_list args; + char buf[BUFSIZ]; + VALUE einfo; + + va_init_list(args,fmt); + vsnprintf(buf, BUFSIZ, fmt, args); + buf[BUFSIZ - 1] = '\0'; + va_end(args); + einfo = rb_exc_new2(exc, buf); + rb_ivar_set(einfo, ID_at_interp, interp); + Tcl_ResetResult(get_ip(interp)->ip); + + return einfo; +} + +static VALUE +ip_get_result_string_obj(interp) + Tcl_Interp *interp; +{ +#if TCL_MAJOR_VERSION >= 8 + int len; + char *s; + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + s = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len); + return(rb_tainted_str_new(s, len)); + +# else /* TCL_VERSION >= 8.1 */ + volatile VALUE strval; + Tcl_Obj *retobj = Tcl_GetObjResult(interp); + int thr_crit_bup; + + Tcl_IncrRefCount(retobj); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (Tcl_GetCharLength(retobj) != Tcl_UniCharLen(Tcl_GetUnicode(retobj))) { + /* possibly binary string */ + s = Tcl_GetByteArrayFromObj(retobj, &len); + strval = rb_tainted_str_new(s, len); + rb_ivar_set(strval, ID_at_enc, rb_str_new2("binary")); + } else { + /* possibly text string */ + s = Tcl_GetStringFromObj(retobj, &len); + strval = rb_tainted_str_new(s, len); + } + + rb_thread_critical = thr_crit_bup; + + Tcl_DecrRefCount(retobj); + + return(strval); + +# endif +#else /* TCL_MAJOR_VERSION < 8 */ + return(rb_tainted_str_new2(interp->result)); +#endif +} + /* eval string in tcl by Tcl_Eval() */ static VALUE -ip_eval_real(self, str) +ip_eval_real(self, cmd_str, cmd_len) VALUE self; - VALUE str; + char *cmd_str; + int cmd_len; { char *s; - char *buf; /* Tcl_Eval requires re-writable string region */ + int len; struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; + +#if TCL_MAJOR_VERSION >= 8 + /* call Tcl_EvalObj() */ + { + Tcl_Obj *cmd; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + cmd = Tcl_NewStringObj(cmd_str, cmd_len); + Tcl_IncrRefCount(cmd); + ptr->return_value = Tcl_EvalObj(ptr->ip, cmd); + /* ptr->return_value = Tcl_GlobalEvalObj(ptr->ip, cmd); */ + Tcl_DecrRefCount(cmd); + + rb_thread_critical = thr_crit_bup; + } +#else /* TCL_MAJOR_VERSION < 8 */ + DUMP2("Tcl_Eval(%s)", cmd_str); + ptr->return_value = Tcl_Eval(ptr->ip, cmd_str); + /* ptr->return_value = Tcl_GlobalEval(ptr->ip, cmd_str); */ +#endif - /* call Tcl_Eval() */ - s = StringValuePtr(str); - buf = ALLOCA_N(char, strlen(s)+1); - strcpy(buf, s); - DUMP2("Tcl_Eval(%s)", buf); - ptr->return_value = Tcl_Eval(ptr->ip, buf); if (ptr->return_value == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#if TCL_MAJOR_VERSION >= 8 + return create_ip_exc(self, rb_eRuntimeError, + "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + return create_ip_exc(self, rb_eRuntimeError, + "%s", ptr->ip->result); +#endif } DUMP2("(TCL_Eval result) %d", ptr->return_value); /* pass back the result (as string) */ - /* return(rb_str_new2(ptr->ip->result)); */ - return(rb_tainted_str_new2(ptr->ip->result)); + return ip_get_result_string_obj(ptr->ip); } static VALUE @@ -1770,7 +3216,7 @@ evq_safelevel_handler(arg, evq) Data_Get_Struct(evq, struct eval_queue, q); DUMP2("(safe-level handler) $SAFE = %d", q->safe_level); rb_set_safe_level(q->safe_level); - return ip_eval_real(q->obj, q->str); + return ip_eval_real(q->interp, q->str, q->len); } int eval_queue_handler _((Tcl_Event *, int)); @@ -1780,12 +3226,13 @@ eval_queue_handler(evPtr, flags) int flags; { struct eval_queue *q = (struct eval_queue *)evPtr; + volatile VALUE ret; DUMP2("do_eval_queue_handler : evPtr = %p", evPtr); DUMP2("eval queue_thread : %lx", rb_thread_current()); DUMP2("added by thread : %lx", q->thread); - if (q->done) { + if (*(q->done)) { DUMP1("processed by another event-loop"); return 0; } else { @@ -1793,20 +3240,31 @@ eval_queue_handler(evPtr, flags) } /* process it */ - q->done = 1; + *(q->done) = 1; /* check safe-level */ if (rb_safe_level() != q->safe_level) { - *(q->result) - = rb_funcall(rb_proc_new(evq_safelevel_handler, - Data_Wrap_Struct(rb_cData,0,0,q)), - rb_intern("call"), 0); + volatile VALUE q_dat; +#ifdef HAVE_NATIVETHREAD + if (!is_ruby_native_thread()) { + rb_bug("cross-thread violation on eval_queue_handler()"); + } +#endif + q_dat = Data_Wrap_Struct(rb_cData,eval_queue_mark,0,q); + ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat), + ID_call, 0); } else { - DUMP2("call eval_real (for caller thread:%lx)", q->thread); - DUMP2("call eval_real (current thread:%lx)", rb_thread_current()); - *(q->result) = ip_eval_real(q->obj, q->str); + DUMP2("call eval_real (for caller thread:%lx)", q->thread); + DUMP2("call eval_real (current thread:%lx)", rb_thread_current()); + ret = ip_eval_real(q->interp, q->str, q->len); } + /* set result */ + RARRAY(q->result)->ptr[0] = ret; + + /* complete */ + *(q->done) = -1; + /* back to caller */ DUMP2("back to caller (caller thread:%lx)", q->thread); DUMP2(" (current thread:%lx)", rb_thread_current()); @@ -1822,19 +3280,27 @@ ip_eval(self, str) VALUE self; VALUE str; { - struct eval_queue *tmp; + struct eval_queue *evq; + char *eval_str; + int *alloc_done; + int thr_crit_bup; VALUE current = rb_thread_current(); - VALUE result; - VALUE *alloc_result; + volatile VALUE result = rb_ary_new2(1); + volatile VALUE ret; Tcl_QueuePosition position; + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + StringValue(str); + rb_thread_critical = thr_crit_bup; + if (eventloop_thread == 0 || current == eventloop_thread) { if (eventloop_thread) { DUMP2("eval from current eventloop %lx", current); } else { DUMP2("eval from thread:%lx but no eventloop", current); } - result = ip_eval_real(self, str); + result = ip_eval_real(self, RSTRING(str)->ptr, RSTRING(str)->len); if (rb_obj_is_kind_of(result, rb_eException)) { rb_exc_raise(result); } @@ -1843,39 +3309,53 @@ ip_eval(self, str) DUMP2("eval from thread %lx (NOT current eventloop)", current); + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + /* allocate memory (protected from Tcl_ServiceEvent) */ - alloc_result = ALLOC(VALUE); + alloc_done = (int*)ALLOC(int); + *alloc_done = 0; + + eval_str = ALLOC_N(char, RSTRING(str)->len + 1); + strncpy(eval_str, RSTRING(str)->ptr, RSTRING(str)->len); + eval_str[RSTRING(str)->len] = 0; /* allocate memory (freed by Tcl_ServiceEvent) */ - tmp = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); + evq = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); /* construct event data */ - tmp->done = 0; - tmp->obj = self; - tmp->str = str; - tmp->result = alloc_result; - tmp->thread = current; - tmp->safe_level = rb_safe_level(); - tmp->ev.proc = eval_queue_handler; + evq->done = alloc_done; + evq->str = eval_str; + evq->len = RSTRING(str)->len; + evq->interp = self; + evq->result = result; + evq->thread = current; + evq->safe_level = rb_safe_level(); + evq->ev.proc = eval_queue_handler; position = TCL_QUEUE_TAIL; /* add the handler to Tcl event queue */ DUMP1("add handler"); - Tcl_QueueEvent(&(tmp->ev), position); + Tcl_QueueEvent(&(evq->ev), position); + + rb_thread_critical = thr_crit_bup; /* wait for the handler to be processed */ DUMP2("wait for handler (current thread:%lx)", current); - rb_thread_stop(); + while(*alloc_done >= 0) { + rb_thread_stop(); + } DUMP2("back from handler (current thread:%lx)", current); /* get result & free allocated memory */ - result = *alloc_result; - free(alloc_result); - if (rb_obj_is_kind_of(result, rb_eException)) { - rb_exc_raise(result); + ret = RARRAY(result)->ptr[0]; + free(alloc_done); + free(eval_str); + if (rb_obj_is_kind_of(ret, rb_eException)) { + rb_exc_raise(ret); } - return result; + return ret; } @@ -1885,12 +3365,27 @@ lib_restart(self) VALUE self; { struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; rb_secure(4); + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + /* destroy the root wdiget */ - /* ptr->return_value = Tcl_Eval(ptr->ip, "destroy ."); */ - ptr->return_value = FIX2INT(ip_eval(self, "destroy .")); + ptr->return_value = Tcl_Eval(ptr->ip, "destroy ."); + /* ignore ERROR */ + DUMP2("(TCL_Eval result) %d", ptr->return_value); + Tcl_ResetResult(ptr->ip); + + /* delete namespace ( tested on tk8.4.5 ) */ + ptr->return_value = Tcl_Eval(ptr->ip, "namespace delete ::tk::msgcat"); + /* ignore ERROR */ + DUMP2("(TCL_Eval result) %d", ptr->return_value); + Tcl_ResetResult(ptr->ip); + + /* delete trace proc ( tested on tk8.4.5 ) */ + ptr->return_value = Tcl_Eval(ptr->ip, "trace vdelete ::tk_strictMotif w ::tk::EventMotifBindings"); /* ignore ERROR */ DUMP2("(TCL_Eval result) %d", ptr->return_value); Tcl_ResetResult(ptr->ip); @@ -1900,21 +3395,27 @@ lib_restart(self) if (Tcl_IsSafe(ptr->ip)) { DUMP1("Tk_SafeInit"); if (Tk_SafeInit(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + rb_thread_critical = thr_crit_bup; + /* rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); */ + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); } } else { DUMP1("Tk_Init"); if (Tk_Init(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + rb_thread_critical = thr_crit_bup; + /* rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); */ + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); } } -#else +#else /* TCL_MAJOR_VERSION < 8 */ DUMP1("Tk_Init"); if (Tk_Init(ptr->ip) == TCL_ERROR) { rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); } #endif + rb_thread_critical = thr_crit_bup; + return Qnil; } @@ -1934,141 +3435,389 @@ ip_restart(self) } static VALUE -ip_toUTF8(self, str, encodename) - VALUE self; - VALUE str; +lib_toUTF8_core(ip_obj, src, encodename) + VALUE ip_obj; + VALUE src; VALUE encodename; { + volatile VALUE str = src; + #ifdef TCL_UTF_MAX Tcl_Interp *interp; Tcl_Encoding encoding; Tcl_DString dstr; + int taint_flag = OBJ_TAINTED(str); struct tcltkip *ptr; char *buf; + int thr_crit_bup; - ptr = get_ip(self); - interp = ptr->ip; + if (NIL_P(ip_obj)) { + interp = (Tcl_Interp *)NULL; + } else { + interp = get_ip(ip_obj)->ip; + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (NIL_P(encodename)) { + if (TYPE(str) == T_STRING) { + volatile VALUE enc; + + enc = rb_ivar_get(str, ID_at_enc); + if (NIL_P(enc)) { + if (NIL_P(ip_obj)) { + encoding = (Tcl_Encoding)NULL; + } else { + enc = rb_ivar_get(ip_obj, ID_at_enc); + if (NIL_P(enc)) { + encoding = (Tcl_Encoding)NULL; + } else { + StringValue(enc); + encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr); + if (encoding == (Tcl_Encoding)NULL) { + rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING(enc)->ptr); + } + } + } + } else { + StringValue(enc); + if (strcmp(RSTRING(enc)->ptr, "binary") == 0) { + rb_thread_critical = thr_crit_bup; + return str; + } + encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr); + if (encoding == (Tcl_Encoding)NULL) { + rb_warning("string has unknown encoding information (@encoding:'%s')", RSTRING(enc)->ptr); + } + } + } else { + encoding = (Tcl_Encoding)NULL; + } + } else { + StringValue(encodename); + encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr); + if (encoding == (Tcl_Encoding)NULL) { + rb_warning("unknown encoding name '%s'", RSTRING(encodename)->ptr); + } + } - StringValue(encodename); StringValue(str); - encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr); - if (!RSTRING(str)->len) return str; - buf = ALLOCA_N(char,strlen(RSTRING(str)->ptr)+1); - strcpy(buf, RSTRING(str)->ptr); + if (!RSTRING(str)->len) { + rb_thread_critical = thr_crit_bup; + return str; + } + + buf = ALLOC_N(char,(RSTRING(str)->len)+1); + strncpy(buf, RSTRING(str)->ptr, RSTRING(str)->len); + buf[RSTRING(str)->len] = 0; Tcl_DStringInit(&dstr); Tcl_DStringFree(&dstr); - Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr); - /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */ - str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); + /* Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr); */ + Tcl_ExternalToUtfDString(encoding, buf, RSTRING(str)->len, &dstr); + + /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */ + str = rb_str_new2(Tcl_DStringValue(&dstr)); + rb_ivar_set(str, ID_at_enc, rb_tainted_str_new2("utf-8")); + if (taint_flag) OBJ_TAINT(str); - Tcl_FreeEncoding(encoding); + if (encoding != (Tcl_Encoding)NULL) { + Tcl_FreeEncoding(encoding); + } Tcl_DStringFree(&dstr); + + free(buf); + + rb_thread_critical = thr_crit_bup; #endif + return str; } static VALUE -ip_fromUTF8(self, str, encodename) +lib_toUTF8(argc, argv, self) + int argc; + VALUE *argv; VALUE self; - VALUE str; +{ + VALUE str, encodename; + + if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { + encodename = Qnil; + } + return lib_toUTF8_core(Qnil, str, encodename); +} + +static VALUE +ip_toUTF8(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + VALUE str, encodename; + + if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { + encodename = Qnil; + } + return lib_toUTF8_core(self, str, encodename); +} + +static VALUE +lib_fromUTF8_core(ip_obj, src, encodename) + VALUE ip_obj; + VALUE src; VALUE encodename; { + volatile VALUE str = src; + #ifdef TCL_UTF_MAX Tcl_Interp *interp; Tcl_Encoding encoding; Tcl_DString dstr; - struct tcltkip *ptr; + int taint_flag = OBJ_TAINTED(str); char *buf; + int thr_crit_bup; - ptr = get_ip(self); - interp = ptr->ip; + if (NIL_P(ip_obj)) { + interp = (Tcl_Interp *)NULL; + } else { + interp = get_ip(ip_obj)->ip; + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (NIL_P(encodename)) { + volatile VALUE enc; + + if (TYPE(str) == T_STRING) { + enc = rb_ivar_get(str, ID_at_enc); + if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) { + rb_thread_critical = thr_crit_bup; + return str; + } + } + + if (NIL_P(ip_obj)) { + encoding = (Tcl_Encoding)NULL; + } else { + enc = rb_ivar_get(ip_obj, ID_at_enc); + if (NIL_P(enc)) { + encoding = (Tcl_Encoding)NULL; + } else { + StringValue(enc); + encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr); + if (encoding == (Tcl_Encoding)NULL) { + rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING(enc)->ptr); + } else { + encodename = rb_obj_dup(enc); + } + } + } + + } else { + StringValue(encodename); + + if (strcmp(RSTRING(encodename)->ptr, "binary") == 0) { + char *s; + int len; + + s = Tcl_GetByteArrayFromObj(Tcl_NewStringObj(RSTRING(str)->ptr, + RSTRING(str)->len), + &len); + str = rb_tainted_str_new(s, len); + rb_ivar_set(str, ID_at_enc, rb_tainted_str_new2("binary")); + + rb_thread_critical = thr_crit_bup; + return str; + } + + encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr); + if (encoding == (Tcl_Encoding)NULL) { + rb_warning("unknown encoding name '%s'", RSTRING(encodename)->ptr); + encodename = Qnil; + } + } - StringValue(encodename); StringValue(str); - encoding = Tcl_GetEncoding(interp,RSTRING(encodename)->ptr); - if (!RSTRING(str)->len) return str; - buf = ALLOCA_N(char,strlen(RSTRING(str)->ptr)+1); - strcpy(buf,RSTRING(str)->ptr); + + if (RSTRING(str)->len == 0) { + rb_thread_critical = thr_crit_bup; + return rb_tainted_str_new2(""); + } + + buf = ALLOC_N(char,strlen(RSTRING(str)->ptr)+1); + strncpy(buf, RSTRING(str)->ptr, RSTRING(str)->len); + buf[RSTRING(str)->len] = 0; Tcl_DStringInit(&dstr); Tcl_DStringFree(&dstr); - Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr); - /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */ - str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); + /* Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr); */ + Tcl_UtfToExternalDString(encoding,buf,RSTRING(str)->len,&dstr); + + /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */ + str = rb_str_new2(Tcl_DStringValue(&dstr)); + rb_ivar_set(str, ID_at_enc, encodename); + if (taint_flag) OBJ_TAINT(str); - Tcl_FreeEncoding(encoding); + if (encoding != (Tcl_Encoding)NULL) { + Tcl_FreeEncoding(encoding); + } Tcl_DStringFree(&dstr); + free(buf); + + rb_thread_critical = thr_crit_bup; #endif + return str; } +static VALUE +lib_fromUTF8(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; +{ + VALUE str, encodename; + + if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { + encodename = Qnil; + } + return lib_fromUTF8_core(Qnil, str, encodename); +} static VALUE -#ifdef HAVE_STDARG_PROTOTYPES -create_ip_exc(VALUE interp, VALUE exc, const char *fmt, ...) -#else -create_ip_exc(interp, exc, fmt, va_alist) - VALUE interp: - VALUE exc; - const char *fmt; - va_dcl -#endif +ip_fromUTF8(argc, argv, self) + int argc; + VALUE *argv; + VALUE self; { - va_list args; - char buf[BUFSIZ]; - VALUE einfo; + VALUE str, encodename; - va_init_list(args,fmt); - vsnprintf(buf, BUFSIZ, fmt, args); - buf[BUFSIZ - 1] = '\0'; - va_end(args); - einfo = rb_exc_new2(exc, buf); - rb_iv_set(einfo, "interp", interp); - Tcl_ResetResult(get_ip(interp)->ip); - return einfo; + if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { + encodename = Qnil; + } + return lib_fromUTF8_core(self, str, encodename); +} + +static VALUE +lib_UTF_backslash_core(self, str, all_bs) + VALUE self; + VALUE str; + int all_bs; +{ +#ifdef TCL_UTF_MAX + char *src_buf, *dst_buf, *ptr; + int read_len = 0, dst_len = 0; + int taint_flag = OBJ_TAINTED(str); + int thr_crit_bup; + + StringValue(str); + if (!RSTRING(str)->len) { + return str; + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + src_buf = ALLOC_N(char,(RSTRING(str)->len)+1); + strncpy(src_buf, RSTRING(str)->ptr, RSTRING(str)->len); + src_buf[RSTRING(str)->len] = 0; + + dst_buf = ALLOC_N(char,(RSTRING(str)->len)+1); + + ptr = src_buf; + while(RSTRING(str)->len > ptr - src_buf) { + if (*ptr == '\\' && (all_bs || *(ptr + 1) == 'u')) { + dst_len += Tcl_UtfBackslash(ptr, &read_len, (dst_buf + dst_len)); + ptr += read_len; + } else { + *(dst_buf + (dst_len++)) = *(ptr++); + } + } + + str = rb_str_new(dst_buf, dst_len); + if (taint_flag) OBJ_TAINT(str); + + free(src_buf); + free(dst_buf); + + rb_thread_critical = thr_crit_bup; +#endif + + return str; +} + +static VALUE +lib_UTF_backslash(self, str) + VALUE self; + VALUE str; +{ + return lib_UTF_backslash_core(self, str, 0); } +static VALUE +lib_Tcl_backslash(self, str) + VALUE self; + VALUE str; +{ + return lib_UTF_backslash_core(self, str, 1); +} +#if TCL_MAJOR_VERSION >= 8 +static VALUE +ip_invoke_core(interp, objc, objv) + VALUE interp; + int objc; + Tcl_Obj **objv; +#else static VALUE -ip_invoke_real(argc, argv, obj) +ip_invoke_core(interp, argc, argv) + VALUE interp; int argc; - VALUE *argv; - VALUE obj; + char **argv; +#endif { - VALUE v; - struct tcltkip *ptr; /* tcltkip data struct */ + struct tcltkip *ptr; int i; Tcl_CmdInfo info; - char *cmd, *s; - char **av = (char **)NULL; + char *cmd; + char *s; + int len; + int thr_crit_bup; + #if TCL_MAJOR_VERSION >= 8 - Tcl_Obj **ov = (Tcl_Obj **)NULL; + int argc = objc; + char **argv = (char **)NULL; Tcl_Obj *resultPtr; #endif - DUMP2("invoke_real called by thread:%lx", rb_thread_current()); - /* get the command name string */ - v = argv[0]; - cmd = StringValuePtr(v); - /* get the data struct */ - ptr = get_ip(obj); + ptr = get_ip(interp); /* ip is deleted? */ if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); return rb_tainted_str_new2(""); } + /* get the command name string */ +#if TCL_MAJOR_VERSION >= 8 + cmd = Tcl_GetStringFromObj(objv[0], &len); +#else /* TCL_MAJOR_VERSION < 8 */ + cmd = argv[0]; +#endif + /* map from the command name to a C procedure */ DUMP2("call Tcl_GetCommandInfo, %s", cmd); if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) { - DUMP1("error Tcl_GetCommandInfo"); + DUMP1("error Tcl_GetCommandInfo"); /* if (event_loop_abort_on_exc || cmd[0] != '.') { */ if (event_loop_abort_on_exc > 0) { /*rb_ip_raise(obj,rb_eNameError,"invalid command name `%s'",cmd);*/ - return create_ip_exc(obj, rb_eNameError, + return create_ip_exc(interp, rb_eNameError, "invalid command name `%s'", cmd); } else { if (event_loop_abort_on_exc < 0) { @@ -2082,74 +3831,75 @@ ip_invoke_real(argc, argv, obj) } DUMP1("end Tcl_GetCommandInfo"); + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + /* memory allocation for arguments of this command */ #if TCL_MAJOR_VERSION >= 8 - if (info.isNativeObjectProc) { - /* object interface */ - ov = (Tcl_Obj **)ALLOCA_N(Tcl_Obj *, argc+1); - for (i = 0; i < argc; ++i) { - v = argv[i]; - s = StringValuePtr(v); - ov[i] = Tcl_NewStringObj(s, RSTRING(v)->len); - Tcl_IncrRefCount(ov[i]); - } - ov[argc] = (Tcl_Obj *)NULL; - } - else -#endif - { + if (!info.isNativeObjectProc) { /* string interface */ - av = (char **)ALLOCA_N(char *, argc+1); + argv = (char **)ALLOC_N(char *, argc+1); for (i = 0; i < argc; ++i) { - v = argv[i]; - s = StringValuePtr(v); - av[i] = ALLOCA_N(char, strlen(s)+1); - strcpy(av[i], s); + argv[i] = Tcl_GetStringFromObj(objv[i], &len); } - av[argc] = (char *)NULL; + argv[argc] = (char *)NULL; } +#endif Tcl_ResetResult(ptr->ip); /* Invoke the C procedure */ #if TCL_MAJOR_VERSION >= 8 if (info.isNativeObjectProc) { - int dummy; - ptr->return_value = (*info.objProc)(info.objClientData, - ptr->ip, argc, ov); - + ptr->return_value = (*info.objProc)(info.objClientData, ptr->ip, + objc, objv); +#if 0 /* get the string value from the result object */ resultPtr = Tcl_GetObjResult(ptr->ip); - Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &dummy), + Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &len), TCL_VOLATILE); - - for (i=0; i<argc; i++) { - Tcl_DecrRefCount(ov[i]); - } +#endif } else #endif { - TRAP_BEG; #if TCL_MAJOR_VERSION >= 8 ptr->return_value = (*info.proc)(info.clientData, ptr->ip, - argc, (CONST84 char **)av); + argc, (CONST84 char **)argv); + + free(argv); + #else /* TCL_MAJOR_VERSION < 8 */ - ptr->return_value = (*info.proc)(info.clientData, ptr->ip, argc, av); + ptr->return_value = (*info.proc)(info.clientData, ptr->ip, + argc, argv); #endif - TRAP_END; } + rb_thread_critical = thr_crit_bup; + /* exception on mainloop */ if (ptr->return_value == TCL_ERROR) { if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) { - /*rb_ip_raise(obj, rb_eRuntimeError, "%s", ptr->ip->result);*/ - return create_ip_exc(obj, rb_eRuntimeError, "%s", ptr->ip->result); +#if TCL_MAJOR_VERSION >= 8 + return create_ip_exc(interp, rb_eRuntimeError, + "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + return create_ip_exc(interp, rb_eRuntimeError, + "%s", ptr->ip->result); +#endif } else { if (event_loop_abort_on_exc < 0) { +#if TCL_MAJOR_VERSION >= 8 + rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ rb_warning("%s (ignore)", ptr->ip->result); +#endif } else { +#if TCL_MAJOR_VERSION >= 8 + rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ rb_warn("%s (ignore)", ptr->ip->result); +#endif } Tcl_ResetResult(ptr->ip); return rb_tainted_str_new2(""); @@ -2157,8 +3907,143 @@ ip_invoke_real(argc, argv, obj) } /* pass back the result (as string) */ - /* return rb_str_new2(ptr->ip->result); */ - return rb_tainted_str_new2(ptr->ip->result); + return ip_get_result_string_obj(ptr->ip); +} + + +#if TCL_MAJOR_VERSION >= 8 +static Tcl_Obj ** +#else /* TCL_MAJOR_VERSION < 8 */ +static char ** +#endif +alloc_invoke_arguments(argc, argv) + int argc; + VALUE *argv; +{ + int i; + VALUE v; + char *s; + int thr_crit_bup; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_Obj **av = (Tcl_Obj **)NULL; + Tcl_Obj *resultPtr; +#else /* TCL_MAJOR_VERSION < 8 */ + char **av = (char **)NULL; +#endif + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* memory allocation */ +#if TCL_MAJOR_VERSION >= 8 + av = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, argc+1); + for (i = 0; i < argc; ++i) { + VALUE enc; + + v = argv[i]; + s = StringValuePtr(v); + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + av[i] = Tcl_NewStringObj(s, RSTRING(v)->len); +# else /* TCL_VERSION >= 8.1 */ + enc = rb_ivar_get(v, ID_at_enc); + if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) { + /* binary string */ + av[i] = Tcl_NewByteArrayObj(s, RSTRING(v)->len); + } else if (strlen(s) != RSTRING(v)->len) { + /* probably binary string */ + av[i] = Tcl_NewByteArrayObj(s, RSTRING(v)->len); + } else { + /* probably text string */ + av[i] = Tcl_NewStringObj(s, RSTRING(v)->len); + } +# endif + Tcl_IncrRefCount(av[i]); + } + av[argc] = (Tcl_Obj *)NULL; + +#else /* TCL_MAJOR_VERSION < 8 */ + /* string interface */ + av = (char **)ALLOC_N(char *, argc+1); + for (i = 0; i < argc; ++i) { + v = argv[i]; + s = StringValuePtr(v); + av[i] = ALLOC_N(char, strlen(s)+1); + strcpy(av[i], s); + } + av[argc] = (char *)NULL; +#endif + + rb_thread_critical = thr_crit_bup; + + return av; +} + +static void +free_invoke_arguments(argc, av) + int argc; +#if TCL_MAJOR_VERSION >= 8 + Tcl_Obj **av; +#else /* TCL_MAJOR_VERSION < 8 */ + char **av; +#endif +{ + int i; + + for (i = 0; i < argc; ++i) { +#if TCL_MAJOR_VERSION >= 8 + Tcl_DecrRefCount(av[i]); +#else /* TCL_MAJOR_VERSION < 8 */ + free(av[i]); +#endif + } + free(av); +} + +static VALUE +ip_invoke_real(argc, argv, interp) + int argc; + VALUE *argv; + VALUE interp; +{ + VALUE v; + struct tcltkip *ptr; /* tcltkip data struct */ + int i; + Tcl_CmdInfo info; + char *s; + int len; + int thr_crit_bup; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_Obj **av = (Tcl_Obj **)NULL; + Tcl_Obj *resultPtr; +#else /* TCL_MAJOR_VERSION < 8 */ + char **av = (char **)NULL; +#endif + + DUMP2("invoke_real called by thread:%lx", rb_thread_current()); + + /* get the data struct */ + ptr = get_ip(interp); + + /* ip is deleted? */ + if (Tcl_InterpDeleted(ptr->ip)) { + DUMP1("ip is deleted"); + return rb_tainted_str_new2(""); + } + + /* allocate memory for arguments */ + av = alloc_invoke_arguments(argc, argv); + + /* Invoke the C procedure */ + Tcl_ResetResult(ptr->ip); + v = ip_invoke_core(interp, argc, av); + + /* free allocated memory */ + free_invoke_arguments(argc, av); + + return v; } VALUE @@ -2171,7 +4056,7 @@ ivq_safelevel_handler(arg, ivq) Data_Get_Struct(ivq, struct invoke_queue, q); DUMP2("(safe-level handler) $SAFE = %d", q->safe_level); rb_set_safe_level(q->safe_level); - return ip_invoke_real(q->argc, q->argv, q->obj); + return ip_invoke_core(q->interp, q->argc, q->argv); } int invoke_queue_handler _((Tcl_Event *, int)); @@ -2181,12 +4066,13 @@ invoke_queue_handler(evPtr, flags) int flags; { struct invoke_queue *q = (struct invoke_queue *)evPtr; + volatile VALUE ret; DUMP2("do_invoke_queue_handler : evPtr = %p", evPtr); DUMP2("invoke queue_thread : %lx", rb_thread_current()); DUMP2("added by thread : %lx", q->thread); - if (q->done) { + if (*(q->done)) { DUMP1("processed by another event-loop"); return 0; } else { @@ -2194,20 +4080,26 @@ invoke_queue_handler(evPtr, flags) } /* process it */ - q->done = 1; + *(q->done) = 1; /* check safe-level */ if (rb_safe_level() != q->safe_level) { - *(q->result) - = rb_funcall(rb_proc_new(ivq_safelevel_handler, - Data_Wrap_Struct(rb_cData,0,0,q)), - rb_intern("call"), 0); + volatile VALUE q_dat; + q_dat = Data_Wrap_Struct(rb_cData,invoke_queue_mark,0,q); + ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat), + ID_call, 0); } else { - DUMP2("call invoke_real (for caller thread:%lx)", q->thread); - DUMP2("call invoke_real (current thread:%lx)", rb_thread_current()); - *(q->result) = ip_invoke_real(q->argc, q->argv, q->obj); + DUMP2("call invoke_real (for caller thread:%lx)", q->thread); + DUMP2("call invoke_real (current thread:%lx)", rb_thread_current()); + ret = ip_invoke_core(q->interp, q->argc, q->argv); } + /* set result */ + RARRAY(q->result)->ptr[0] = ret; + + /* complete */ + *(q->done) = -1; + /* back to caller */ DUMP2("back to caller (caller thread:%lx)", q->thread); DUMP2(" (current thread:%lx)", rb_thread_current()); @@ -2219,16 +4111,28 @@ invoke_queue_handler(evPtr, flags) } static VALUE -ip_invoke(argc, argv, obj) +ip_invoke_with_position(argc, argv, obj, position) int argc; VALUE *argv; VALUE obj; + Tcl_QueuePosition position; { - struct invoke_queue *tmp; + struct invoke_queue *ivq; + char *s; + int len; + int i; + int *alloc_done; + int thr_crit_bup; + VALUE v; VALUE current = rb_thread_current(); - VALUE result; - VALUE *alloc_argv, *alloc_result; - Tcl_QueuePosition position; + volatile VALUE result = rb_ary_new2(1); + volatile VALUE ret; + +#if TCL_MAJOR_VERSION >= 8 + Tcl_Obj **av = (Tcl_Obj **)NULL; +#else /* TCL_MAJOR_VERSION < 8 */ + char **av = (char **)NULL; +#endif if (argc < 1) { rb_raise(rb_eArgError, "command name missing"); @@ -2248,45 +4152,60 @@ ip_invoke(argc, argv, obj) DUMP2("invoke from thread %lx (NOT current eventloop)", current); - /* allocate memory (protected from Tcl_ServiceEvent) */ - alloc_argv = ALLOC_N(VALUE,argc); - MEMCPY(alloc_argv, argv, VALUE, argc); - alloc_result = ALLOC(VALUE); + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + /* allocate memory (for arguments) */ + av = alloc_invoke_arguments(argc, argv); + + /* allocate memory (keep result) */ + alloc_done = (int*)ALLOC(int); + *alloc_done = 0; /* allocate memory (freed by Tcl_ServiceEvent) */ - tmp = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); + ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); /* construct event data */ - tmp->done = 0; - tmp->obj = obj; - tmp->argc = argc; - tmp->argv = alloc_argv; - tmp->result = alloc_result; - tmp->thread = current; - tmp->safe_level = rb_safe_level(); - tmp->ev.proc = invoke_queue_handler; - position = TCL_QUEUE_TAIL; + ivq->done = alloc_done; + ivq->argc = argc; + ivq->argv = av; + ivq->interp = obj; + ivq->result = result; + ivq->thread = current; + ivq->safe_level = rb_safe_level(); + ivq->ev.proc = invoke_queue_handler; /* add the handler to Tcl event queue */ DUMP1("add handler"); - Tcl_QueueEvent(&(tmp->ev), position); + Tcl_QueueEvent(&(ivq->ev), position); + + rb_thread_critical = thr_crit_bup; /* wait for the handler to be processed */ DUMP2("wait for handler (current thread:%lx)", current); - rb_thread_stop(); + while(*alloc_done >= 0) { + rb_thread_stop(); + } DUMP2("back from handler (current thread:%lx)", current); /* get result & free allocated memory */ - result = *alloc_result; - free(alloc_argv); - free(alloc_result); - if (rb_obj_is_kind_of(result, rb_eException)) { - rb_exc_raise(result); + ret = RARRAY(result)->ptr[0]; + free(alloc_done); + + /* free allocated memory */ + free_invoke_arguments(argc, av); + + /* exception? */ + if (rb_obj_is_kind_of(ret, rb_eException)) { + DUMP1("raise exception"); + rb_exc_raise(ret); } - return result; + DUMP1("exit ip_invoke"); + return ret; } + /* get return code from Tcl_Eval() */ static VALUE ip_retval(self) @@ -2300,6 +4219,864 @@ ip_retval(self) return (INT2FIX(ptr->return_value)); } +static VALUE +ip_invoke(argc, argv, obj) + int argc; + VALUE *argv; + VALUE obj; +{ + return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_TAIL); +} + +static VALUE +ip_invoke_immediate(argc, argv, obj) + int argc; + VALUE *argv; + VALUE obj; +{ + return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_HEAD); +} + +/* access Tcl variables */ +static VALUE +ip_get_variable(self, varname_arg, flag_arg) + VALUE self; + VALUE varname_arg; + VALUE flag_arg; +{ + struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; + volatile VALUE varname, flag; + + varname = varname_arg; + flag = flag_arg; + + StringValue(varname); + +#if TCL_MAJOR_VERSION >= 8 + { + Tcl_Obj *nameobj, *ret; + char *s; + int len; + VALUE strval; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr, + RSTRING(varname)->len); + Tcl_IncrRefCount(nameobj); + + ret = Tcl_ObjGetVar2(ptr->ip, nameobj, (Tcl_Obj*)NULL, FIX2INT(flag)); + + Tcl_DecrRefCount(nameobj); + + rb_thread_critical = thr_crit_bup; + + if (ret == (Tcl_Obj*)NULL) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif + } + + Tcl_IncrRefCount(ret); + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + Tcl_DecrRefCount(ret); + return(strval); +# else /* TCL_VERSION >= 8.1 */ + { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (Tcl_GetCharLength(ret) + != Tcl_UniCharLen(Tcl_GetUnicode(ret))) { + /* possibly binary string */ + s = Tcl_GetByteArrayFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + rb_ivar_set(strval, ID_at_enc, rb_tainted_str_new2("binary")); + } else { + /* possibly text string */ + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + } + + rb_thread_critical = thr_crit_bup; + } + + Tcl_DecrRefCount(ret); + return(strval); +# endif + } +#else /* TCL_MAJOR_VERSION < 8 */ + { + char *ret; + + ret = Tcl_GetVar2(ptr->ip, RSTRING(varname)->ptr, + (char*)NULL, FIX2INT(flag)); + if (ret == (char*)NULL) { + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + } + return(rb_tainted_str_new2(ret)); + } +#endif +} + +static VALUE +ip_get_variable2(self, varname_arg, index_arg, flag_arg) + VALUE self; + VALUE varname_arg; + VALUE index_arg; + VALUE flag_arg; +{ + struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; + volatile VALUE varname, index, flag; + + if (NIL_P(index_arg)) { + return ip_get_variable(self, varname_arg, flag_arg); + } + + varname = varname_arg; + index = index_arg; + flag = flag_arg; + + StringValue(varname); + StringValue(index); + +#if TCL_MAJOR_VERSION >= 8 + { + Tcl_Obj *nameobj, *idxobj, *ret; + char *s; + int len; + volatile VALUE strval; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr, + RSTRING(varname)->len); + Tcl_IncrRefCount(nameobj); + idxobj = Tcl_NewStringObj(RSTRING(index)->ptr, RSTRING(index)->len); + Tcl_IncrRefCount(idxobj); + + ret = Tcl_ObjGetVar2(ptr->ip, nameobj, idxobj, FIX2INT(flag)); + + Tcl_IncrRefCount(ret); + Tcl_DecrRefCount(nameobj); + Tcl_DecrRefCount(idxobj); + + rb_thread_critical = thr_crit_bup; + + if (ret == (Tcl_Obj*)NULL) { + Tcl_DecrRefCount(ret); +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif + } +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + Tcl_DecrRefCount(ret); + return(strval); +# else /* TCL_VERSION >= 8.1 */ + { + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + if (Tcl_GetCharLength(ret) + != Tcl_UniCharLen(Tcl_GetUnicode(ret))) { + /* possibly binary string */ + s = Tcl_GetByteArrayFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + rb_ivar_set(strval, ID_at_enc, rb_tainted_str_new2("binary")); + } else { + /* possibly text string */ + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + } + + rb_thread_critical = thr_crit_bup; + } + + Tcl_DecrRefCount(ret); + return(strval); +# endif + } +#else /* TCL_MAJOR_VERSION < 8 */ + { + char *ret; + + ret = Tcl_GetVar2(ptr->ip, RSTRING(varname)->ptr, RSTRING(index)->ptr, + FIX2INT(flag)); + if (ret == (char*)NULL) { + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + } + return(rb_tainted_str_new2(ret)); + } +#endif +} + +static VALUE +ip_set_variable(self, varname_arg, value_arg, flag_arg) + VALUE self; + VALUE varname_arg; + VALUE value_arg; + VALUE flag_arg; +{ + struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; + volatile VALUE varname, value, flag; + + varname = varname_arg; + value = value_arg; + flag = flag_arg; + + StringValue(varname); + StringValue(value); + +#if TCL_MAJOR_VERSION >= 8 + { + Tcl_Obj *nameobj, *valobj, *ret; + char *s; + int len; + volatile VALUE strval; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr, + RSTRING(varname)->len); + Tcl_IncrRefCount(nameobj); + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + valobj = Tcl_NewStringObj(RSTRING(value)->ptr, + RSTRING(value)->len); + Tcl_IncrRefCount(valobj); +# else /* TCL_VERSION >= 8.1 */ + { + VALUE enc = rb_ivar_get(value, ID_at_enc); + + if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) { + /* binary string */ + valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr, + RSTRING(value)->len); + } else if (strlen(RSTRING(value)->ptr) != RSTRING(value)->len) { + /* probably binary string */ + valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr, + RSTRING(value)->len); + } else { + /* probably text string */ + valobj = Tcl_NewStringObj(RSTRING(value)->ptr, + RSTRING(value)->len); + } + + Tcl_IncrRefCount(valobj); + } +# endif + + ret = Tcl_ObjSetVar2(ptr->ip, nameobj, (Tcl_Obj*)NULL, valobj, + FIX2INT(flag)); + + Tcl_DecrRefCount(nameobj); + Tcl_DecrRefCount(valobj); + + if (ret == (Tcl_Obj*)NULL) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif + } + + Tcl_IncrRefCount(ret); + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); +# else /* TCL_VERSION >= 8.1 */ + if (Tcl_GetCharLength(ret) != Tcl_UniCharLen(Tcl_GetUnicode(ret))) { + /* possibly binary string */ + s = Tcl_GetByteArrayFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + rb_ivar_set(strval, ID_at_enc, rb_str_new2("binary")); + } else { + /* possibly text string */ + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + } +# endif + + rb_thread_critical = thr_crit_bup; + + Tcl_DecrRefCount(ret); + + return(strval); + } +#else /* TCL_MAJOR_VERSION < 8 */ + { + CONST char *ret; + + ret = Tcl_SetVar2(ptr->ip, RSTRING(varname)->ptr, (char*)NULL, + RSTRING(value)->ptr, (int)FIX2INT(flag)); + if (ret == NULL) { + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + } + return(rb_tainted_str_new2(ret)); + } +#endif +} + +static VALUE +ip_set_variable2(self, varname_arg, index_arg, value_arg, flag_arg) + VALUE self; + VALUE varname_arg; + VALUE index_arg; + VALUE value_arg; + VALUE flag_arg; +{ + struct tcltkip *ptr = get_ip(self); + int thr_crit_bup; + volatile VALUE varname, index, value, flag; + + if (NIL_P(index_arg)) { + return ip_set_variable(self, varname_arg, value_arg, flag_arg); + } + + varname = varname_arg; + index = index_arg; + value = value_arg; + flag = flag_arg; + + StringValue(varname); + StringValue(index); + StringValue(value); + +#if TCL_MAJOR_VERSION >= 8 + { + Tcl_Obj *nameobj, *idxobj, *valobj, *ret; + char *s; + int len; + volatile VALUE strval; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr, + RSTRING(varname)->len); + Tcl_IncrRefCount(nameobj); + + idxobj = Tcl_NewStringObj(RSTRING(index)->ptr, + RSTRING(index)->len); + Tcl_IncrRefCount(idxobj); + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + valobj = Tcl_NewStringObj(RSTRING(value)->ptr, + RSTRING(value)->len); +# else /* TCL_VERSION >= 8.1 */ + { + VALUE enc = rb_ivar_get(value, ID_at_enc); + + if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) { + /* binary string */ + valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr, + RSTRING(value)->len); + } else if (strlen(RSTRING(value)->ptr) != RSTRING(value)->len) { + /* probably binary string */ + valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr, + RSTRING(value)->len); + } else { + /* probably text string */ + valobj = Tcl_NewStringObj(RSTRING(value)->ptr, + RSTRING(value)->len); + } + } + +# endif + Tcl_IncrRefCount(valobj); + + ret = Tcl_ObjSetVar2(ptr->ip, nameobj, idxobj, valobj, FIX2INT(flag)); + + Tcl_DecrRefCount(nameobj); + Tcl_DecrRefCount(idxobj); + Tcl_DecrRefCount(valobj); + + rb_thread_critical = thr_crit_bup; + + if (ret == (Tcl_Obj*)NULL) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif + } + + Tcl_IncrRefCount(ret); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); +# else /* TCL_VERSION >= 8.1 */ + if (Tcl_GetCharLength(ret) != Tcl_UniCharLen(Tcl_GetUnicode(ret))) { + /* possibly binary string */ + s = Tcl_GetByteArrayFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + rb_ivar_set(strval, ID_at_enc, rb_str_new2("binary")); + } else { + /* possibly text string */ + s = Tcl_GetStringFromObj(ret, &len); + strval = rb_tainted_str_new(s, len); + } +# endif + + rb_thread_critical = thr_crit_bup; + + Tcl_DecrRefCount(ret); + + return(strval); + } +#else /* TCL_MAJOR_VERSION < 8 */ + { + CONST char *ret; + + ret = Tcl_SetVar2(ptr->ip, RSTRING(varname)->ptr, RSTRING(index)->ptr, + RSTRING(value)->ptr, FIX2INT(flag)); + if (ret == (char*)NULL) { + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + } + return(rb_tainted_str_new2(ret)); + } +#endif +} + +static VALUE +ip_unset_variable(self, varname_arg, flag_arg) + VALUE self; + VALUE varname_arg; + VALUE flag_arg; +{ + struct tcltkip *ptr = get_ip(self); + volatile VALUE varname, value, flag; + + varname = varname_arg; + flag = flag_arg; + + StringValue(varname); + ptr->return_value = Tcl_UnsetVar(ptr->ip, RSTRING(varname)->ptr, + FIX2INT(flag)); + if (ptr->return_value == TCL_ERROR) { + if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif + } + return Qfalse; + } + return Qtrue; +} + +static VALUE +ip_unset_variable2(self, varname_arg, index_arg, flag_arg) + VALUE self; + VALUE varname_arg; + VALUE index_arg; + VALUE flag_arg; +{ + struct tcltkip *ptr = get_ip(self); + volatile VALUE varname, index, value, flag; + + if (NIL_P(index_arg)) { + return ip_unset_variable(self, varname_arg, flag_arg); + } + + varname = varname_arg; + index = index_arg; + flag = flag_arg; + + StringValue(varname); + StringValue(index); + + ptr->return_value = Tcl_UnsetVar2(ptr->ip, RSTRING(varname)->ptr, + RSTRING(index)->ptr, FIX2INT(flag)); + if (ptr->return_value == TCL_ERROR) { + if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); +#endif + } + return Qfalse; + } + return Qtrue; +} + +static VALUE +ip_get_global_var(self, varname) + VALUE self; + VALUE varname; +{ + return ip_get_variable(self, varname, + INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); +} + +static VALUE +ip_get_global_var2(self, varname, index) + VALUE self; + VALUE varname; + VALUE index; +{ + return ip_get_variable2(self, varname, index, + INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); +} + +static VALUE +ip_set_global_var(self, varname, value) + VALUE self; + VALUE varname; + VALUE value; +{ + return ip_set_variable(self, varname, value, + INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); +} + +static VALUE +ip_set_global_var2(self, varname, index, value) + VALUE self; + VALUE varname; + VALUE index; + VALUE value; +{ + return ip_set_variable2(self, varname, index, value, + INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); +} + +static VALUE +ip_unset_global_var(self, varname) + VALUE self; + VALUE varname; +{ + return ip_unset_variable(self, varname, + INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); +} + +static VALUE +ip_unset_global_var2(self, varname, index) + VALUE self; + VALUE varname; + VALUE index; +{ + return ip_unset_variable2(self, varname, index, + INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); +} + + +/* treat Tcl_List */ +static VALUE +lib_split_tklist_core(ip_obj, list_str) + VALUE ip_obj; + VALUE list_str; +{ + Tcl_Interp *interp; + volatile VALUE ary, elem; + int idx; + int taint_flag = OBJ_TAINTED(list_str); + int result; + VALUE old_gc; + + if (NIL_P(ip_obj)) { + interp = (Tcl_Interp *)NULL; + } else { + interp = get_ip(ip_obj)->ip; + } + + StringValue(list_str); + + { +#if TCL_MAJOR_VERSION >= 8 + /* object style interface */ + Tcl_Obj *listobj; + int objc; + Tcl_Obj **objv; + int thr_crit_bup; + +# if 1 +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + listobj = Tcl_NewStringObj(RSTRING(list_str)->ptr, + RSTRING(list_str)->len); +# else /* TCL_VERSION >= 8.1 */ + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + { + VALUE enc = rb_ivar_get(list_str, ID_at_enc); + + if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) { + /* binary string */ + listobj = Tcl_NewByteArrayObj(RSTRING(list_str)->ptr, + RSTRING(list_str)->len); + } else if (strlen(RSTRING(list_str)->ptr) + != RSTRING(list_str)->len) { + /* probably binary string */ + listobj = Tcl_NewByteArrayObj(RSTRING(list_str)->ptr, + RSTRING(list_str)->len); + } else { + /* probably text string */ + listobj = Tcl_NewStringObj(RSTRING(list_str)->ptr, + RSTRING(list_str)->len); + } + } + + rb_thread_critical = thr_crit_bup; +# endif +# else + listobj = Tcl_NewStringObj(RSTRING(list_str)->ptr, + RSTRING(list_str)->len); +# endif + + Tcl_IncrRefCount(listobj); + + result = Tcl_ListObjGetElements(interp, listobj, &objc, &objv); + + if (result == TCL_ERROR) { + Tcl_DecrRefCount(listobj); + if (interp == (Tcl_Interp*)NULL) { + rb_raise(rb_eRuntimeError, "cannot get elements from list"); + } else { +#if TCL_MAJOR_VERSION >= 8 + rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(interp)); +#else /* TCL_MAJOR_VERSION < 8 */ + rb_raise(rb_eRuntimeError, "%s", interp->result); +#endif + } + } + + for(idx = 0; idx < objc; idx++) { + Tcl_IncrRefCount(objv[idx]); + } + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + ary = rb_ary_new2(objc); + if (taint_flag) OBJ_TAINT(ary); + + old_gc = rb_gc_disable(); + + for(idx = 0; idx < objc; idx++) { + char *str; + int len; + +# if 1 +# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + str = Tcl_GetStringFromObj(objv[idx], &len); + elem = rb_str_new(str, len); +# else /* TCL_VERSION >= 8.1 */ + if (Tcl_GetCharLength(objv[idx]) + != Tcl_UniCharLen(Tcl_GetUnicode(objv[idx]))) { + /* possibly binary string */ + str = Tcl_GetByteArrayFromObj(objv[idx], &len); + elem = rb_str_new(str, len); + rb_ivar_set(elem, ID_at_enc, rb_tainted_str_new2("binary")); + } else { + /* possibly text string */ + str = Tcl_GetStringFromObj(objv[idx], &len); + elem = rb_str_new(str, len); + } +# endif +# else + str = Tcl_GetStringFromObj(objv[idx], &len); + elem = rb_str_new(str, len); +# endif + + if (taint_flag) OBJ_TAINT(elem); + RARRAY(ary)->ptr[idx] = elem; + } + + RARRAY(ary)->len = objc; + + if (old_gc == Qfalse) rb_gc_enable(); + + rb_thread_critical = thr_crit_bup; + + for(idx = 0; idx < objc; idx++) { + Tcl_DecrRefCount(objv[idx]); + } + + Tcl_DecrRefCount(listobj); + +#else /* TCL_MAJOR_VERSION < 8 */ + /* string style interface */ + int argc; + char **argv; + + if (Tcl_SplitList(interp, RSTRING(list_str)->ptr, + &argc, &argv) == TCL_ERROR) { + if (interp == (Tcl_Interp*)NULL) { + rb_raise(rb_eRuntimeError, "cannot get elements from list"); + } else { + rb_raise(rb_eRuntimeError, "%s", interp->result); + } + } + + ary = rb_ary_new2(argc); + if (taint_flag) OBJ_TAINT(ary); + + old_gc = rb_gc_disable(); + + for(idx = 0; idx < argc; idx++) { + if (taint_flag) { + elem = rb_tainted_str_new2(argv[idx]); + } else { + elem = rb_str_new2(argv[idx]); + } + /* rb_ivar_set(elem, ID_at_enc, rb_str_new2("binary")); */ + RARRAY(ary)->ptr[idx] = elem; + } + RARRAY(ary)->len = argc; + + if (old_gc == Qfalse) rb_gc_enable(); +#endif + } + + return ary; +} + +static VALUE +lib_split_tklist(self, list_str) + VALUE self; + VALUE list_str; +{ + return lib_split_tklist_core(Qnil, list_str); +} + + +static VALUE +ip_split_tklist(self, list_str) + VALUE self; + VALUE list_str; +{ + return lib_split_tklist_core(self, list_str); +} + +static VALUE +lib_merge_tklist(argc, argv, obj) + int argc; + VALUE *argv; + VALUE obj; +{ + int num, len; + int *flagPtr; + char *dst, *result; + volatile VALUE str; + int taint_flag = 0; + int thr_crit_bup; + VALUE old_gc; + + if (argc == 0) return rb_str_new2(""); + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + old_gc = rb_gc_disable(); + + /* based on Tcl/Tk's Tcl_Merge() */ + flagPtr = ALLOC_N(unsigned, argc); + + /* pass 1 */ + len = 1; + for(num = 0; num < argc; num++) { + if (OBJ_TAINTED(argv[num])) taint_flag = 1; + dst = StringValuePtr(argv[num]); +#if TCL_MAJOR_VERSION >= 8 + len += Tcl_ScanCountedElement(dst, RSTRING(argv[num])->len, + &flagPtr[num]) + 1; +#else /* TCL_MAJOR_VERSION < 8 */ + len += Tcl_ScanElement(dst, &flagPtr[num]) + 1; +#endif + } + + /* pass 2 */ + result = (char *)Tcl_Alloc(len); + dst = result; + for(num = 0; num < argc; num++) { +#if TCL_MAJOR_VERSION >= 8 + len = Tcl_ConvertCountedElement(RSTRING(argv[num])->ptr, + RSTRING(argv[num])->len, + dst, flagPtr[num]); +#else /* TCL_MAJOR_VERSION < 8 */ + len = Tcl_ConvertElement(RSTRING(argv[num])->ptr, dst, flagPtr[num]); +#endif + dst += len; + *dst = ' '; + dst++; + } + if (dst == result) { + *dst = 0; + } else { + dst[-1] = 0; + } + + free(flagPtr); + + /* create object */ + str = rb_str_new(result, dst - result - 1); + if (taint_flag) OBJ_TAINT(str); + Tcl_Free(result); + + if (old_gc == Qfalse) rb_gc_enable(); + rb_thread_critical = thr_crit_bup; + + return str; +} + +static VALUE +lib_conv_listelement(self, src) + VALUE self; + VALUE src; +{ + int len, scan_flag; + volatile VALUE dst; + int taint_flag = OBJ_TAINTED(src); + int thr_crit_bup; + + thr_crit_bup = rb_thread_critical; + rb_thread_critical = Qtrue; + + StringValue(src); + +#if TCL_MAJOR_VERSION >= 8 + len = Tcl_ScanCountedElement(RSTRING(src)->ptr, RSTRING(src)->len, + &scan_flag); + dst = rb_str_new(0, len + 1); + len = Tcl_ConvertCountedElement(RSTRING(src)->ptr, RSTRING(src)->len, + RSTRING(dst)->ptr, scan_flag); +#else /* TCL_MAJOR_VERSION < 8 */ + len = Tcl_ScanElement(RSTRING(src)->ptr, &scan_flag); + dst = rb_str_new(0, len + 1); + len = Tcl_ConvertElement(RSTRING(src)->ptr, RSTRING(dst)->ptr, scan_flag); +#endif + + RSTRING(dst)->len = len; + RSTRING(dst)->ptr[len] = '\0'; + if (taint_flag) OBJ_TAINT(dst); + + rb_thread_critical = thr_crit_bup; + + return dst; +} + + #ifdef __MACOS__ static void _macinit() @@ -2313,18 +5090,40 @@ _macinit() void Init_tcltklib() { + int thr_crit_bup; + VALUE lib = rb_define_module("TclTkLib"); VALUE ip = rb_define_class("TclTkIp", rb_cObject); VALUE ev_flag = rb_define_module_under(lib, "EventFlag"); + VALUE var_flag = rb_define_module_under(lib, "VarAccessFlag"); + + /* --------------------------------------------------------------- */ #if defined USE_TCL_STUBS && defined USE_TK_STUBS extern int ruby_tcltk_stubs(); int ret = ruby_tcltk_stubs(); + if (ret) rb_raise(rb_eLoadError, "tcltklib: tcltk_stubs init error(%d)", ret); #endif + /* --------------------------------------------------------------- */ + + rb_global_variable(&eTkCallbackReturn); + rb_global_variable(&eTkCallbackBreak); + rb_global_variable(&eTkCallbackContinue); + + rb_global_variable(&eventloop_thread); + rb_global_variable(&watchdog_thread); + + /* --------------------------------------------------------------- */ + + rb_define_const(lib, "FINALIZE_PROC_NAME", + rb_str_new2(finalize_hook_name)); + + /* --------------------------------------------------------------- */ + rb_define_const(ev_flag, "NONE", INT2FIX(0)); rb_define_const(ev_flag, "WINDOW", INT2FIX(TCL_WINDOW_EVENTS)); rb_define_const(ev_flag, "FILE", INT2FIX(TCL_FILE_EVENTS)); @@ -2333,10 +5132,56 @@ Init_tcltklib() rb_define_const(ev_flag, "ALL", INT2FIX(TCL_ALL_EVENTS)); rb_define_const(ev_flag, "DONT_WAIT", INT2FIX(TCL_DONT_WAIT)); + /* --------------------------------------------------------------- */ + + rb_define_const(var_flag, "NONE", INT2FIX(0)); + rb_define_const(var_flag, "GLOBAL_ONLY", INT2FIX(TCL_GLOBAL_ONLY)); +#ifdef TCL_NAMESPACE_ONLY + rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(TCL_NAMESPACE_ONLY)); +#else /* probably Tcl7.6 */ + rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(0)); +#endif + rb_define_const(var_flag, "LEAVE_ERR_MSG", INT2FIX(TCL_LEAVE_ERR_MSG)); + rb_define_const(var_flag, "APPEND_VALUE", INT2FIX(TCL_APPEND_VALUE)); + rb_define_const(var_flag, "LIST_ELEMENT", INT2FIX(TCL_LIST_ELEMENT)); +#ifdef TCL_PARSE_PART1 + rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(TCL_PARSE_PART1)); +#else /* probably Tcl7.6 */ + rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(0)); +#endif + + /* --------------------------------------------------------------- */ + + eTkCallbackBreak = rb_define_class("TkCallbackReturn", rb_eStandardError); eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError); eTkCallbackContinue = rb_define_class("TkCallbackContinue", rb_eStandardError); + /* --------------------------------------------------------------- */ + + eLocalJumpError = rb_const_get(rb_cObject, rb_intern("LocalJumpError")); + + ID_at_enc = rb_intern("@encoding"); + ID_at_interp = rb_intern("@interp"); + + ID_stop_p = rb_intern("stop?"); + ID_kill = rb_intern("kill"); + ID_join = rb_intern("join"); + + ID_call = rb_intern("call"); + ID_backtrace = rb_intern("backtrace"); + ID_message = rb_intern("message"); + + ID_at_reason = rb_intern("@reason"); + ID_return = rb_intern("return"); + ID_break = rb_intern("break"); + ID_next = rb_intern("next"); + + ID_to_s = rb_intern("to_s"); + ID_inspect = rb_intern("inspect"); + + /* --------------------------------------------------------------- */ + rb_define_module_function(lib, "mainloop", lib_mainloop, -1); rb_define_module_function(lib, "mainloop_watchdog", lib_mainloop_watchdog, -1); @@ -2351,11 +5196,27 @@ Init_tcltklib() rb_define_module_function(lib, "get_no_event_wait", get_no_event_wait, 0); rb_define_module_function(lib, "set_eventloop_weight", set_eventloop_weight, 2); + rb_define_module_function(lib, "set_max_block_time", set_max_block_time,1); rb_define_module_function(lib, "get_eventloop_weight", get_eventloop_weight, 0); rb_define_module_function(lib, "num_of_mainwindows", lib_num_of_mainwindows, 0); + /* --------------------------------------------------------------- */ + + rb_define_module_function(lib, "_split_tklist", lib_split_tklist, 1); + rb_define_module_function(lib, "_merge_tklist", lib_merge_tklist, -1); + rb_define_module_function(lib, "_conv_listelement", + lib_conv_listelement, 1); + rb_define_module_function(lib, "_toUTF8", lib_toUTF8, -1); + rb_define_module_function(lib, "_fromUTF8", lib_fromUTF8, -1); + rb_define_module_function(lib, "_subst_UTF_backslash", + lib_UTF_backslash, 1); + rb_define_module_function(lib, "_subst_Tcl_backslash", + lib_Tcl_backslash, 1); + + /* --------------------------------------------------------------- */ + rb_define_alloc_func(ip, ip_alloc); rb_define_method(ip, "initialize", ip_init, -1); rb_define_method(ip, "create_slave", ip_create_slave, -1); @@ -2364,13 +5225,36 @@ Init_tcltklib() rb_define_method(ip, "delete", ip_delete, 0); rb_define_method(ip, "deleted?", ip_is_deleted_p, 0); rb_define_method(ip, "_eval", ip_eval, 1); - rb_define_method(ip, "_toUTF8",ip_toUTF8, 2); - rb_define_method(ip, "_fromUTF8",ip_fromUTF8, 2); + rb_define_method(ip, "_toUTF8", ip_toUTF8, -1); + rb_define_method(ip, "_fromUTF8", ip_fromUTF8, -1); rb_define_method(ip, "_thread_vwait", ip_thread_vwait, 1); rb_define_method(ip, "_thread_tkwait", ip_thread_tkwait, 2); rb_define_method(ip, "_invoke", ip_invoke, -1); rb_define_method(ip, "_return_value", ip_retval, 0); + /* --------------------------------------------------------------- */ + + rb_define_method(ip, "_get_variable", ip_get_variable, 2); + rb_define_method(ip, "_get_variable2", ip_get_variable2, 3); + rb_define_method(ip, "_set_variable", ip_set_variable, 3); + rb_define_method(ip, "_set_variable2", ip_set_variable2, 4); + rb_define_method(ip, "_unset_variable", ip_unset_variable, 2); + rb_define_method(ip, "_unset_variable2", ip_unset_variable2, 3); + rb_define_method(ip, "_get_global_var", ip_get_global_var, 1); + rb_define_method(ip, "_get_global_var2", ip_get_global_var2, 2); + rb_define_method(ip, "_set_global_var", ip_set_global_var, 2); + rb_define_method(ip, "_set_global_var2", ip_set_global_var2, 3); + rb_define_method(ip, "_unset_global_var", ip_unset_global_var, 1); + rb_define_method(ip, "_unset_global_var2", ip_unset_global_var2, 2); + + /* --------------------------------------------------------------- */ + + rb_define_method(ip, "_split_tklist", ip_split_tklist, 1); + rb_define_method(ip, "_merge_tklist", lib_merge_tklist, -1); + rb_define_method(ip, "_conv_listelement", lib_conv_listelement, 1); + + /* --------------------------------------------------------------- */ + rb_define_method(ip, "mainloop", ip_mainloop, -1); rb_define_method(ip, "mainloop_watchdog", ip_mainloop_watchdog, -1); rb_define_method(ip, "do_one_event", ip_do_one_event, -1); @@ -2384,19 +5268,25 @@ Init_tcltklib() rb_define_method(ip, "get_no_event_wait", ip_get_no_event_wait, 0); rb_define_method(ip, "set_eventloop_weight", ip_set_eventloop_weight, 2); rb_define_method(ip, "get_eventloop_weight", ip_get_eventloop_weight, 0); + rb_define_method(ip, "set_max_block_time", set_max_block_time, 1); rb_define_method(ip, "restart", ip_restart, 0); + /* --------------------------------------------------------------- */ + eventloop_thread = 0; watchdog_thread = 0; + /* --------------------------------------------------------------- */ + #ifdef __MACOS__ _macinit(); #endif - /*---- initialize tcl/tk libraries ----*/ /* from Tk_Main() */ DUMP1("Tcl_FindExecutable"); Tcl_FindExecutable(RSTRING(rb_argv0)->ptr); + + /* --------------------------------------------------------------- */ } /* eof */ |