diff options
author | nagai <nagai@b2dd03c8-39d4-4d8f-98ff-823fe69b080e> | 2005-11-02 11:19:30 +0000 |
---|---|---|
committer | nagai <nagai@b2dd03c8-39d4-4d8f-98ff-823fe69b080e> | 2005-11-02 11:19:30 +0000 |
commit | a2af997b7e79bca00ad7555447b738d0e041a76e (patch) | |
tree | 77452e34b93358f16499b0025c551d5771abfdb7 /ext | |
parent | 6f2cce43a1a0cc21456b83a00bf84065b6f53fd7 (diff) |
* ext/tcltklib: merge into ext/tk and remove.
git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/branches/ruby_1_8@9496 b2dd03c8-39d4-4d8f-98ff-823fe69b080e
Diffstat (limited to 'ext')
-rw-r--r-- | ext/tcltklib/MANUAL.eng | 445 | ||||
-rw-r--r-- | ext/tcltklib/MANUAL.euc | 557 | ||||
-rw-r--r-- | ext/tcltklib/README.1st | 72 | ||||
-rw-r--r-- | ext/tcltklib/README.ActiveTcl | 49 | ||||
-rw-r--r-- | ext/tcltklib/README.euc | 159 | ||||
-rw-r--r-- | ext/tcltklib/demo/lines0.tcl | 42 | ||||
-rw-r--r-- | ext/tcltklib/demo/lines1.rb | 50 | ||||
-rw-r--r-- | ext/tcltklib/demo/lines2.rb | 54 | ||||
-rw-r--r-- | ext/tcltklib/demo/lines3.rb | 54 | ||||
-rw-r--r-- | ext/tcltklib/demo/lines4.rb | 54 | ||||
-rw-r--r-- | ext/tcltklib/demo/safeTk.rb | 22 | ||||
-rw-r--r-- | ext/tcltklib/depend | 2 | ||||
-rw-r--r-- | ext/tcltklib/extconf.rb | 300 | ||||
-rw-r--r-- | ext/tcltklib/lib/tcltk.rb | 367 | ||||
-rw-r--r-- | ext/tcltklib/sample/batsu.gif | bin | 538 -> 0 bytes | |||
-rw-r--r-- | ext/tcltklib/sample/maru.gif | bin | 481 -> 0 bytes | |||
-rw-r--r-- | ext/tcltklib/sample/sample0.rb | 39 | ||||
-rw-r--r-- | ext/tcltklib/sample/sample1.rb | 634 | ||||
-rw-r--r-- | ext/tcltklib/sample/sample2.rb | 451 | ||||
-rw-r--r-- | ext/tcltklib/stubs.c | 507 | ||||
-rw-r--r-- | ext/tcltklib/stubs.h | 33 | ||||
-rw-r--r-- | ext/tcltklib/tcltklib.c | 7860 | ||||
-rw-r--r-- | ext/tk/depend | 3 | ||||
-rw-r--r-- | ext/tk/extconf.rb | 311 | ||||
-rw-r--r-- | ext/tk/tkutil.c | 1637 |
25 files changed, 310 insertions, 13392 deletions
diff --git a/ext/tcltklib/MANUAL.eng b/ext/tcltklib/MANUAL.eng deleted file mode 100644 index 1db61f228e..0000000000 --- a/ext/tcltklib/MANUAL.eng +++ /dev/null @@ -1,445 +0,0 @@ -(tof) - 2005/07/05 Hidetoshi NAGAI - -This document discribes about the 'tcltklib' library. Although there -is the 'tcltk' library (tcltk.rb) under this directory, no description -in this document (because it is not maintained recently). - -============================================================== -module TclTklib - : Defines methods to do operations which are independed on - : Tcl/Tk interpreters - - module TclTkLib::EventFlag - : Defines flags to define taget events on 'do_one_event' methos. - : When to give, please use bit-operator (e.g. WINDOW | DONT_WAIT). - - [constants] - NONE - : Is 0. It means "there is no target". But on the real - : operation, it is same to ALL. - - WINDOW - : 'window' event is processed. - - FILE - : 'file' event is processed. - - TIMER - : 'timer' event is processed. - - IDLE - : 'idle' operation (e.g. 're-draw'; the operations when the - : other kinds of events doesn't occur) is processed. - - ALL - : All kinds of events are processed. - : Same to 'WINDOW | FILE | TIMER | IDLE'. - - DONT_WAIT - : Without this flag, 'do_one_event' waits the occurence of - : a target event. With this flag, doesn't wait and returns - : false if there is no target event for processing. - - 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_thread? - : Returns whether the current thread executes the eventloop. - : If true, the eventloop is working on the current thread. - : If no eventloop is working, this method returns nil. - : And if the other thread executes the eventloop, returns false. - : - : *** ATTENTION *** - : When this methods returns false, it is dangerous to call a Tk - : interpreter directly. - - 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=nil) - _fromUTF8(str, encoding=nil) - : 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. - - encoding_system - encoding_system=(encoding) - : Get and set Tcl's system encoding. - - encoding - encoding=(encoding) - : alias of encoding_system / encoding_system= - : ( probably, Ruby/Tk's tk.rb will override them ) - - -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. - - allow_ruby_exit? - : Return the mode whether 'exit' function of ruby or 'exit' - : command of Tcl/Tk can quit the ruby process or not on the - : interpreter. If false, such a command quit the interpreter - : only. - : The default value for a master interpreter is true, and - : for a slave interpreter is false. - - allow_ruby_exit=(mode) - : Change the mode of 'allow_ruby_exit?'. - : If $SAFE >= 4 or the interpreter is a "safe" interpreter, - : this is not permitted (raise an exception). - - 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. - - has_mainwindow? - : Check whether the interpreter has a MainWindow (root widget). - : If has, returns true. If doesn't, returns false. - : If IP is already deleted, returns nil. - - 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=nil) - _fromUTF8(str, encoding=nil) - : 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). - -(eof) diff --git a/ext/tcltklib/MANUAL.euc b/ext/tcltklib/MANUAL.euc deleted file mode 100644 index 5dd36726ba..0000000000 --- a/ext/tcltklib/MANUAL.euc +++ /dev/null @@ -1,557 +0,0 @@ -(tof) - 2005/07/05 Hidetoshi NAGAI - -本ドキュメントには古い tcltk ライブラリ,tcltklib ライブラリの説明 -が含まれていますが,その記述内容は古いものとなっています. - -tcltk ライブラリ(tcltk.rb)は現在ではメンテナンスが事実上行われて -いないため,古いドキュメントの説明がそのまま有効です.それに対し, -tcltklib ライブラリについては,現在の Ruby/Tk(tk.rb 以下のライブラ -リ群)を稼働させるための中心としてメンテナンスされているため,少々 -違いが生じています. - -そこで,まず古い説明文書を示した後,現在の tcltklib ライブラリにつ -いての説明を加えます. - -以下がライブラリの古い説明文書です. -============================================================== - MANUAL.euc - Sep. 19, 1997 Y. Shigehiro - -以下, 「tcl/tk」という表記は, tclsh や wish を実現している, 一般でいう -ところの tcl/tk を指します. 「tcltk ライブラリ」, 「tcltklib ライブラ -リ」という表記は, 本パッケージに含まれる ruby 用のライブラリを指します. - -<< tcltk ライブラリ >> - -tcl/tk の C ライブラリを利用するための高(中?)水準インターフェースを提 -供します. - -このライブラリは ruby から tcl/tk ライブラリを利用するためのもので, 内 -部で tcltklib ライブラリを利用しています. - -[説明] - -tcl/tk インタプリタでは, ウィジェットに何か指示を送るには, ウィジェッ -ト名に続いてパラメータを書きます. したがって, ウィジェットがオブジェク -トであり, それに対してメソッドを送っている, とみなすことができます. さ -て, tcl/tk インタプリタでは, 組み込みコマンドも, 前述のウィジェットと -同じような書式の命令で実行されます. すなわち, コマンドもオブジェクトで -あると考えることができます. - -このような考えに基づき, tcltk ライブラリでは, tcl/tk のコマンドやウィ -ジェットに対応するオブジェクトを生成します. オブジェクトに対するメソッ -ド呼び出しは, e() メソッドにより実行されます. 例えば, tcl/tk の info -コマンドに対応する ruby のオブジェクトが info という名前であるとすると, -tcl/tk の - info commands -という命令は tcltk ライブラリでは - info.e("commands") -と記述されます. また, 「.」というウィジェット (wish 実行時に自動的に生 -成されるルートウィジェット) に対応する ruby のオブジェクトが root とい -う名前であるとすると, - . configure -height 300 -width 300 -という tcl/tk の命令は - root.e("configure -height 300 -width 300") -と記述されます. このような記述は, 見ためには美しくありませんが, そして, -スクリプトを読む人には見づらいかも知れませんが, 実際にスクリプトを書い -てみると予想外に手軽です. - -[使用法] - -1. ライブラリを読み込む. - require "tcltk" - -2. tcl/tk インタプリタを生成する. - ip = TclTkInterpreter.new() - -3. tcl/tk のコマンドに対応するオブジェクトを変数に代入しておく. - # コマンドに対応するオブジェクトが入った Hash を取り出す. - c = ip.commands() - # 使いたいコマンドに対応するオブジェクトを個別の変数に代入する. - bind, button, info, wm = c.indexes("bind", "button", "info", "wm") - -4. 必要な処理を行う. - 詳しくは, サンプルを参照のこと. - -5. 準備ができたら, イベントループに入る. - TclTk.mainloop() - -(( 以下, モジュール, クラス等の説明を書く予定.)) - - - -<< tcltklib ライブラリ >> - -tcl/tk の C ライブラリを利用するための低水準インターフェースを提供しま -す. - -コンパイル/実行には, tcl/tk の C ライブラリが必要です. - -[説明] - -このライブラリを用いると, ruby から tcl/tk の C ライブラリを利用できま -す. 具体的には, ruby インタプリタから tcl/tk インタプリタを呼び出すこ -とができます. さらに, その(ruby インタプリタから呼び出した) tcl/tk イ -ンタプリタから, 逆に ruby インタプリタを呼び出すこともできます. - -[使用法] - -require "tcltklib" すると, 以下のモジュール, クラスが利用可能です. - -モジュール TclTkLib - tcl/tk ライブラリを呼び出すメソッドを集めたモジュールです. ただし, - tcl/tk インタプリタ関係のメソッドはクラス TclTkIp にあります. - - モジュールメソッド mainloop() - Tk_MainLoop を実行します. 全ての tk のウインドウが無くなると終了 - します(例えば, tcl/tk で書くところの "destroy ." をした場合等). - 引数: 無し - 戻り値: nil - -クラス TclTkIp - インスタンスが tcl/tk のインタプリタに対応します. tcl/tk のライブ - ラリの仕様通り, インスタンスを複数個生成しても正しく動作します(そ - んなことをする必要はあまり無いはずですが). インタプリタは wish の - tcl/tk コマンドを実行できます. さらに, 以下のコマンドを実行できま - す. - コマンド ruby - 引数を ruby で実行します(ruby_eval_string を実行します). 引数 - は 1 つでなければなりません. 戻り値は ruby の実行結果です. - ruby の実行結果は nil か String でなければなりません. - - クラスメソッド new() - TclTkIp クラスのインスタンスを生成します - 引数: 無し - 戻り値 (TclTkIp): 生成されたインスタンス - - メソッド _eval(script) - インタプリタで script を評価します(Tcl_Eval を実行します). 前述 - のように, ruby コマンドにより script 内から ruby スクリプトを実 - 行できます. - 引数: script (String) - インタプリタで評価するスクリプト文字列 - 戻り値 (String): 評価結果 ((Tcl_Interp *)->result) - - メソッド _return_value() - 直前の Tcl_Eval の戻り値を返します. 0(TCL_OK) で正常終了です. - 引数: 無し - 戻り値 (Fixnum): 直前の Tcl_Eval() が返した値. - -============================================================== - -以下が本ドキュメント作成時点での tcltklib ライブラリの説明です. -============================================================== -モジュール TclTkLib - : 個々の Tcl/Tk インタープリタに依存しない処理 ( == イベントルー - : プに関する処理 ) を呼び出すメソッドを定義したモジュール. - - モジュール TclTkLib::EventFlag - : do_one_event を呼び出す際の処理対象イベントを指定するための - : フラグ ( WINDOW|DONT_WAIT というようにビット演算子で連結して - : 指定 ) を定数として定義したモジュール.以下の定数が含まれる. - - 定数 NONE - : 値は 0 で,値としてはいかなる種類のイベントも指定していない - : ことになるが,実際の処理上は ALL と同じとして扱われる. - - 定数 WINDOW - : window イベントを処理対象とする - - 定数 FILE - : file イベントを処理対象とする - - 定数 TIMER - : timer イベントを処理対象とする - - 定数 IDLE - : アイドルループ処理 ( 再描画など,他の種類のイベントが発生 - : していないときに行われる処理 ) を処理対象とする - - 定数 ALL - : すべての種類のイベントを処理対象とする - : WINDOW|FILE|TIMER|IDLE と同じ - - 定数 DONT_WAIT - : 処理対象イベントが存在しない場合に,イベント発生を待たず - : に 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 であれば, - : root widget が存在する限り,このメソッドは終了しない. - : check_root が false の場合は,root widget が消滅しても - : このメソッドは終了しない ( root widget が消滅しても, - : WINDOW 以外のイベントは発生しうるため ).終了には,外部 - : からの働き掛け ( スレッドを活用するなど ) が必要. - - mainloop_thread? - : カレントスレッドがイベントループを実行しているスレッド - : かどうかを返す. - : イベントループを実行しているスレッドであれば true を, - : どのスレッドでもイベントループが実行されていない場合は - : nil を,他のスレッドでイベントループが実行されている場 - : 合は false を返す. - : false の際に Tk インタープリタを直接呼ぶのは危険である. - - mainloop_watchdog(check_root = true) - : 通常のイベントループでは,イベント処理の内容によっては - : デッドロックを引き起こす可能性がある (例えばイベントに - : 対するコールバック処理中で widget 操作をし,その終了を - : 待つなど).このメソッドは,そうしたデッドロックを回避す - : るための監視スレッド付きでイベントループを起動する - : ( 監視スレッドを生成した後にイベントループを実行する ). - : 引数の意味は mainloop と同じである. - - do_one_event(flag = TclTkLib::EventFlag::ALL | - TclTkLib::EventFlag::DONT_WAIT) - : 処理待ちのイベント 1 個を実行する. - : イベントを処理した場合は true を返す. - : フラグで DONT_WAIT を指定していない場合,フラグで処理対 - : 象となっている種類のイベントが発生するまで待ち続ける. - : DONT_WAIT を指定していた場合,処理対象イベントがなくても - : すぐに終了し false を返す. - : $SAFE >= 4 か,$SAFE >= 1 かつ flag が汚染されているならば - : flag には DONT_WAIT が強制的に付けられる. - - set_eventloop_tick(timer_tick) - : イベントループと同時に別スレッドが稼働している場合に,時 - : 間に基づいた強制的なスレッドスイッチングをどの程度の頻度 - : ( 時間間隔 ) で発生させるかをミリ秒単位の整数値で指定する. - : 0 を指定すると,この強制的なスイッチングは行われない. - : 標準では 0 に設定されており,イベント処理数に基づくスイッ - : チングだけが行われる ( see set_eventloop_weight ). - : ただし,稼働しているスレッドがイベントループだけの場合, - : timer_tick を 0 に設定することはできない.もし設定されて - : いたら,100 ms ( see NO_THREAD_INTERRUPT_TIME ) に自動設 - : 定される. - : 詳細な説明は略すが,これは CPU パワーを節約しつつ安全で - : 安定した動作を実現するために実装した仕様である. - : $SAFE >= 4 では実行が禁止される. - - get_eventloop_tick - : timer_tick の現在値を返す. - - set_no_event_wait(no_event_wait) - : 複数のスレッドが稼働している場合で,処理待ちイベントが全 - : く存在しなかった際に sleep 状態に入る時間長を指定する. - : 稼働スレッドがイベントループだけの場合には意味をなさない. - : デフォルトの値は 20 (ms) - : $SAFE >= 4 では実行が禁止される. - - get_no_event_wait - : no_event_wait の現在値を返す. - - set_eventloop_weight(loop_max, no_event_tick) - : 複数のスレッドが稼働している際に Ruby/Tk のイベントルー - : プに割り当てる比重を定めるためのパラメータを設定する. - : 稼働スレッドがイベントループだけの場合には意味をなさない. - : 一度のスレッド切り替えの間に処理するイベントの最大数と, - : 処理待ちのイベントが存在しない際の加算数とを設定する. - : 処理待ちイベントが存在しない場合は no_event_wait ( see - : set_no_event_wait ) だけの間 sleep 状態に入る. - : デフォルトではそれぞれ 800 回と 10 回,つまり,800 個のイ - : ベント (アイドルイベントを含む) を処理するとか,イベント - : が全く発生しないままに 80 回の処理待ちイベント検査が完了 - : するとかでカウントが 800 以上になるとスレッドスイッチング - : が発生することになる. - : $SAFE >= 4 では実行が禁止される. - - get_eventloop_weight - : 現在の loop_max と no_event_tick との値を返す. - : ( see set_eventloop_wait ) - - mainloop_abort_on_exception=(bool) - : Tk インタープリタ上で例外を発生した際に,イベントループを - : エラー停止させるかどうかを指定する.true を指定した場合は - : エラー停止するが,false の場合は例外を無視してイベントルー - : プを継続する.さらに nil の場合は警告モードでない限りはエ - : ラーメッセージの出力すら省略して,例外を無視する. - : デフォルトでは true に設定されている. - : 1個のインタープリタだけを使っている場合にはエラー時にその - : まま停止しても通常は問題ないが,複数のインタープリタが同時 - : に動作している場合には,それらを管理するイベントループは1 - : 個だけであるため,いずれかのインタープリタのエラーが原因で, - : 他のインタープリタの処理継続が不可能になることがある.その - : ような場合でもエラーを無視してイベントループが稼働を続ける - : ことで,他のインタープリタが正常に動作し続けることができる. - : $SAFE >= 4 では実行が禁止される. - - mainloop_abort_on_exception - : Tk インタープリタ上で例外を発生した際に,イベントループをエ - : ラー停止させるかどうかの設定状態を true/false で得る. - - num_of_mainwindows - : 現在のメインウィンドウ (ルートウィジェット) の数を返す. - : メインウィンドウは一つのインタープリタに付き最大一つである - : ので,この値は現在 Tk の機能が有効であるインタープリタの総 - : 数に等しい. - - _merge_tklist(str, str, ... ) - : Tcl/Tk のライブラリ関数を使って,引数の文字列がそれぞれ - : 正しく一つのリスト要素となるように連結した文字列を返す. - - _conv_listelement(str) - : Tcl/Tk のライブラリ関数を使って,引数の文字列が Tcl の - : 一つのリスト要素として適切な表現になるように変換した文 - : 字列を返す. - - _toUTF8(str, encoding=nil) - _fromUTF8(str, encoding=nil) - : Tcl/Tk が内蔵している UTF8 変換処理を呼び出す. - - _subst_UTF_backslash(str) - _subst_Tcl_backslash(str) - : Tcl のルールでバックスラッシュ記法 ( \uhhhh による - : Unicode 文字表現を含む ) を解析する. - : _subst_Tcl_backslash はすべてのバックスラッシュ記法を - : 置き換えるのに対し,_subst_UTF_backslash は \uhhhh - : による Unicode 文字表現だけを置き換える. - - encoding_system - encoding_system=(encoding) - : Tcl の system encoding の獲得および設定 - - encoding - encoding=(encoding) - : encoding_system / encoding_system= の alias - : ( Ruby/Tk の tk.rb では置き換えられる予定のもの.) - - -クラス TclTkIp - クラスメソッド - new(ip_name=nil, options='') - : TclTkIp クラスのインスタンスを生成する. - : ip_name に文字列を与えた場合は,それが winfo interps などで - : 表示される名前になる. - : options には,-geometry や -use など,wish のコマンドライン - : 引数として与えるオプションと同様の情報を文字列として与える. - : 与えられた情報は,root widget 生成の際に用いられる. - : ( e.g. TclTkIp.new('FOO', '-geometry 500x200 -use 0x2200009') ) - : もし options に敢えて nil または false を与えた場合,Tk ライ - : ブラリが導入されていない (つまりは Tcl のみの) インタープリ - : タを生成する.この場合は GUI 環境は必要ないため,ウインドウ - : システムが存在しない,または使用できない環境でも Tcl インター - : プリタを生成し,Tcl やその拡張ライブラリを活用することができる. - - インスタンスメソッド - create_slave(name, safe=false) - : レシーバを親とする name という名前のスレーブインタープリタを - : 生成する. - : safe には生成するインタープリタを safe インタープリタとする - : かを指定する.デフォルトは false ということになっているが, - : たとえ明確に false を指定していたとしても,親となるインター - : プリタが safe インタープリタであれば,その設定を引き継いで - : safe インタープリタとして生成される. - : $SAFE >= 4 では,safe インタープリタ以外の生成が禁止される. - - make_safe - : Tcl/Tk インタープリタを safe インタープリタに変更する. - : 戻り値はレシーバであるインタープリタ自身である. - : 失敗した場合は RuntimeError の例外を発生する. - - safe? - : Tcl/Tk インタープリタが safe インタープリタであるかを調べる. - : safe インタープリタであれば true を返す. - - allow_ruby_exit? - : 対象となるインタープリタ上の評価で,ruby の exit 関数または - : Tcl/Tk 上の exit コマンドによって ruby 自体を終了させること - : を許すかどうかを返す. - : 許さない場合は対象のインタープリタだけが終了する. - : マスターインタープリタのデフォルト値は true,スレーブインター - : プリタのデフォルト値は false である. - - allow_ruby_exit=(mode) - : 対象となるインタープリタの allow_ruby_exit? の状態を変更する. - : $SAFE >= 4 またはインタープリタが safe インタープリタの場合は - : 変更が許されない (例外を発生). - - delete - : Tcl/Tk インタープリタを delete する. - : delete されたインタープリタは,以後一切の操作ができなくなり, - : コマンドを送っても例外を発生するようになる. - - deleted? - : Tcl/Tk インタープリタがすでに delete されているかを調べる. - : delete 済みでコマンドを受け付けない状態になっているならば - : true を返す. - - has_mainwindow? - : Tcl/Tk インタープリタにメインウィンドウ (root widget) が - : 存在すれば true を,存在しなければ false を返す. - : インタープリタが既に delete 済みであれば nil を返す. - - restart - : Tcl/Tk インタープリタの Tk 部分の初期化,再起動を行う. - : 一旦 root widget を破壊した後に再度 Tk の機能が必要と - : なった場合に用いる. - : $SAFE >= 4 では実行が禁止される. - - _eval(str) - _invoke(*args) - : Tcl/Tk インタープリタ上で評価を行う. - : _eval は評価スクリプトが一つの文字列であることに対し, - : _invoke は評価スクリプトの token ごとに一つの引数とな - : るように与える. - : _invoke の方は Tcl/Tk インタープリタの字句解析器を用い - : ないため,評価の負荷がより少なくてすむ.ただし,その代 - : わりに auto_load のような機構は働かず,load 等によって - : Tcl/Tk インタープリタ上に既に登録済みのコマンドしか呼 - : び出すことができない. - : _eval では auto_load 機構が働くため,一度 _eval を実行 - : して登録に成功しさえすれば,以降は _invoke でも利用で - : きるようになる. - - _toUTF8(str, encoding=nil) - _fromUTF8(str, encoding=nil) - : Tcl/Tk が内蔵している UTF8 変換処理を呼び出す. - - _thread_vwait(var_name) - _thread_tkwait(mode, target) - : スレッド対応の vwait あるいは tkwait 相当のメソッド. - : 通常の vwait あるいは tkwait コマンドと異なるのは,イベン - : トループとは異なるスレッドから呼び出した場合に vwait 等の - : スタックとは独立に条件の成立待ちがなされることである. - : 通常の vwait / tkwait では,vwait / tkwait (1) の待ちの途 - : 中でさらに vwait / tkwait (2) が呼ばれた場合,待ちの対象 - : となっている条件の成立順序がどうあれ,(2)->(1) の順で待ち - : を終了して戻ってくる. - : _thread_vwait / _thread_tkwait は,イベントループのスレッ - : ドで呼ばれた場合は通常の vwait / tkwait と同様に動作する - : が,イベントループ以外のスレッドで呼ばれた場合にはそのス - : レッドを停止させて待ちに入り,条件が成立した時にスレッド - : の実行を再開する.「vwait 等の待ちスタックとは独立」とい - : う意味は,この再開のタイミングが他のスレッドでの待ち状況 - : とは無関係ということである.つまり,イベントループ等の他 - : のスレッドで vwait 等で待ちの状態にあったとしてもその完了 - : を待つことなく,自らの待ち条件が成立次第,処理を継続する - : ことになる. - - _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 を返す. - : それ以外の点では引数を含めて TclTkLib の同名メソッドに同じ. - - do_one_event - : スレーブ IP の場合には引数のイベントフラグに DONT_WAIT が - : 強制的に追加される (イベント待ちでスリープすることは禁止). - : それ以外の点では引数を含めて TclTkLib の同名メソッドに同じ. - - 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= - : スレーブ IP の場合には値の設定が許されない (無視される). - : それ以外の点では引数を含めて TclTkLib の同名メソッドに同じ. - -クラス TkCallbackBreak < StandardError -クラス TkCallbackContinue < StandardError - : これらはイベントコールバックにおいて,コールバック処理を適切に中 - : 断したり,次のバインドタグのバインディング処理に進めたりすること - : を可能にするための例外クラスである. - : コールバックで break や continue を実現するためには,コールバック - : である Ruby 手続きが Tcl/Tk インタープリタ側に適切なリターンコー - : ドを返す必要がある.Ruby の手続きが普通に値を返すのでは,それが普 - : 通の戻り値であるのか否かを区別ができないため,例外発生を利用した - : 実装を行っている. - -(eof) diff --git a/ext/tcltklib/README.1st b/ext/tcltklib/README.1st deleted file mode 100644 index 5d1da48a45..0000000000 --- a/ext/tcltklib/README.1st +++ /dev/null @@ -1,72 +0,0 @@ -To compile 'tcltklib', you must have Tcl/Tk libraries on your environment. -Although 'extconf.rb' script searches Tcl/Tk libraries and header files, -sometimes fails to find them. And then, 'tcltklib' cannot be compiled. If -Tcl/Tk libraries or header files are installed but are not found, you can -give the information by arguments of the 'configure' script. Please give -some or all of the following options. - - --with-tcllib=<libname> (e.g. libtcl8.4.so ==> --with-tcllib=tcl8.4) - --with-tklib=<libname> (e.g. libtk8.4.so ==> --with-tklib=tk8.4) - - --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" - - --with-tk-dir=<path> - equal to "--with-tk-include=<path>/include --with-tk-lib=<path>/lib" - - --with-tcl-include=<dir> the directry containts 'tcl.h' - --with-tk-include=<dir> the directry containts 'tk.h' - - --with-tcl-lib=<dir> the directry containts 'libtcl<version>.so' - --with-tk-lib=<dir> the directry containts 'libtk<version>.so' - - --enable-mac-tcltk-framework (MacOS X) use Tcl/Tk framework - (Obsolete. Please use '--enable-tcltk-framework'.) - - --enable-tcltk-framework use Tcl/Tk framework - - --with-tcltk-framework=<dir> the directory containts Tcl/Tk framework; - "<dir>/Tcl.framework" and "<dir>/Tk.framework". - When this option is given, it is assumed that - --enable-tcltk-framework option is given also. - - --with-tcl-framework-header=<dir> - Tcl framework headers directory - (e.g. "/Library/Frameworks/Tcl.framework/Headers") - - --with-tk-framework-header=<dir> - Tk framework headers directory - (e.g. "/Library/Frameworks/Tk.framework/Headers") - - -If you forgot to give the options when do 'configure' on toplevel -directry of Ruby sources, please try something like as the followings. - - $ cd ext/tcltklib - $ rm Makefile - $ CONFIGURE_ARGS='--with-tcl-include=/usr/local/include/tcl8.4/ --with-tcllib=tcl8.4 --with-tklib=tk8.4' ruby extconf.rb - - - *** ATTENTION *** -When your Tcl/Tk libraries are compiled with "pthread support", -Ruby/Tk may cause "Hang-up" or "Segmentation Fault" frequently. -If you have such a trouble, please try to use the '--enable-pthread' -option of the 'configure' command and re-compile Ruby sources. -It may help you to avoid this trouble. The following configure -options may be useful. - - --enable-tcl-thread/--disable-tcl-thread - --with-tclConfig-file=<path of 'tclConfig.sh'> - -It is not need that 'tclConfig.sh' is a normal Tcl/Tk's tclConfig.sh. -But the file is expected to include the line "TCL_THREADS=0" or "...=1". -When no "TCL_THREADS=?" line, if Tcl version is 7.x or 8.0 which is -given by "TCL_MAJOR_VERSION=?" line and "TCL_MINOR_VERSION=?" line, -then --disable-tcl-thread is expected. Else, ignore the 'tclConfig.sh'. -If --enable-tcl-thread or --disable-tcl-thread option is given, then ---with-tclConfig-file option is ignored. - -========================================================== - Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp) diff --git a/ext/tcltklib/README.ActiveTcl b/ext/tcltklib/README.ActiveTcl deleted file mode 100644 index 3afb3f4cf6..0000000000 --- a/ext/tcltklib/README.ActiveTcl +++ /dev/null @@ -1,49 +0,0 @@ -ActiveTcl is ActiveState's quality-assured distribution of Tcl. - -# see <http://www.activestate.com/Products/ActiveTcl/> -# <http://www.tcl.tk/> - -If you want to use ActiveTcl binary package as the Tcl/Tk libraries, -please use the following configure options. - - --with-tcl-dir=<ActiveTcl_root> - --with-tk-dir=<ActiveTcl_root> - -And use the followings if you need. - - --with-tcllib=<libname> - --with-tklib=<libname> - --enable-tcltk-stubs - -For example, when you install ActiveTcl-8.4.x to '/usr/local/ActiveTcl', - - configure --with-tcl-dir=/usr/local/ActiveTcl/ \ - --with-tk-dir=/usr/local/ActiveTcl/ \ - --with-tcllib=tclstub8.4 \ - --with-tklib=tkstub8.4 \ - --enable-tcltk-stubs - -It depends on your environment that you have to add the directory of -ActiveTcl's libraries to your library path when execute Ruby/Tk. -One of the way is to add entries to TCLLIBPATH environment variable, -and one of the others add to LD_LIBRARY_PATH environment variable - -Probably, using TCLLIBPATH is better. The value is appended at the -head of Tcl's 'auto_path' variable. You can see the value of the -variable by using 'Tk::AUTO_PATH.value' or 'Tk::AUTO_PATH.list'. - -For example, on Linux, one of the ways is to use LD_LIBRARY_PATH -environment variable. -------------------------------------------------------------------------- - [bash]$ LD_LIBRARY_PATH=/usr/local/ActiveTcl/lib:$LD_LIBRARY_PATH \ - ruby your-Ruby/Tk-script - - [bash]$ LD_LIBRARY_PATH=/usr/local/ActiveTcl/lib:$LD_LIBRARY_PATH irb -------------------------------------------------------------------------- -Based on it, the Tcl interpreter changes auto_path variable's value. - -Then, you'll be able to use Tcl/Tk extension libraries included in the -ActiveTcl package (e.g. call TkPackage.require('BWidget'), and then, -use functions/widgets of BWidget extention). - - Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp) diff --git a/ext/tcltklib/README.euc b/ext/tcltklib/README.euc deleted file mode 100644 index fd75202c18..0000000000 --- a/ext/tcltklib/README.euc +++ /dev/null @@ -1,159 +0,0 @@ -(tof) - 2003/06/19 Hidetoshi NAGAI - -本ドキュメントには古い tcltk ライブラリ,tcltklib ライブラリの説明 -が含まれていますが,その記述内容は古いものとなっています. - -まず,現在の Ruby/Tk の中心である tk.rb は wish を呼び出したりはせ -ず,tcltklib ライブラリを wrap して動作するものとなっています.その -ため,古い説明記述で述べられているようなプロセス間通信によるオーバ -ヘッドは存在しません. - -現在の tcltklib ライブラリでも,Tcl/Tk の C ライブラリをリンクして -直接に動かすことで,オーバヘッドを押さえつつ Tcl/Tk インタープリタ -のほぼ全機能(拡張ライブラリを含む)を使える点は同じです.しかし, -その役割はほぼ「tk.rb 以下のライブラリを効果的に働かせるためのもの」 -と見なされており,その目的でメンテナンスされています. - -tk.rb の高機能化に伴って,中水準のライブラリである tcltk ライブラリ -(tcltk.rb)はその存在意義を減じており,現在ではメンテナンスは行わ -れていません. - -なお,古い説明ではバインディングにおけるスクリプトの追加はできないこ -ととなっていますが,現在の tk.rb ではこれも可能であることを補足して -おきます. - -以下がライブラリの古い説明文書です. -============================================================== - tcltk ライブラリ - tcltklib ライブラリ - Sep. 19, 1997 Y. Shigehiro - -以下, 「tcl/tk」という表記は, tclsh や wish を実現している, 一般でいう -ところの tcl/tk を指します. 「tcltk ライブラリ」, 「tcltklib ライブラ -リ」という表記は, 本パッケージに含まれる ruby 用のライブラリを指します. - -[ファイルについて] - -README.euc : このファイル(注意, 特徴, インストールの方法). -MANUAL.euc : マニュアル. - -lib/, ext/ : ライブラリの実体. - -sample/ : マニュアル代わりのサンプルプログラム. -sample/sample0.rb : tcltklib ライブラリのテスト. -sample/sample1.rb : tcltk ライブラリのテスト. - tcl/tk (wish) でできそうなことを一通り書いてみました. -sample/sample2.rb : tcltk ライブラリのサンプル. - maeda shugo (shugo@po.aianet.ne.jp) 氏による - (`rb.tk' で書かれていた) ruby のサンプルプログラム - http://www.aianet.or.jp/~shugo/ruby/othello.rb.gz - を tcltk ライブラリを使うように, 機械的に変更してみました. - -demo/ : 100 本の線を 100 回描くデモプログラム. - 最初に空ループの時間を測定し, 続いて実際に線を引く時間を測定します. - tcl/tk は(再)描画のときに backing store を使わずに律義に 10000 本(?) - 線を引くので, (再)描画を始めると, マシンがかなり重くなります. -demo/lines0.tcl : wish 用のスクリプト. -demo/lines1.rb : `tk.rb' 用のスクリプト. -demo/lines2.rb : tcltk ライブラリ用のスクリプト. - -[注意] - -コンパイル/実行には, tcl/tk の C ライブラリが必要です. - -このライブラリは, - - ruby-1.0-970701, ruby-1.0-970911, ruby-1.0-970919 - FreeBSD 2.2.2-RELEASE - およびそのパッケージ jp-tcl-7.6.tgz, jp-tk-4.2.tgz - -で作成/動作確認しました. 他の環境では動作するかどうかわかりません. - -TclTkLib.mainloop を実行中に Control-C が効かないのは不便なので, ruby -のソースを参考に, #include "sig.h" して trap_immediate を操作していま -すが, ruby の README.EXT にも書いてないのに, こんなことをして良いのか -どうかわかりません. - --d オプションでデバッグ情報を表示させるために, ruby のソースを参考に, -debug という大域変数を参照していますが, ruby の README.EXT にも書いて -ないのに, こんなことをして良いのかどうかわかりません. - -extconf.rb は書きましたが, (いろいろな意味で)これで良いのか良く分かり -ません. - -[特徴] - -ruby から tcl/tk ライブラリを利用できます. - -tcl/tk インタプリタのスクリプトは, 機械的に tcltk ライブラリ用の ruby -スクリプトに変換できます. - -(`tk.rb' との違い) - -1. tcl/tk インタプリタのスクリプトが, どのように, tcltk ライブラリ用の - ruby スクリプトに変換されるかが理解できれば, マニュアル類が無いに等 - しい `tk.rb' とは異なり - - tcl/tk のマニュアルやオンラインドキュメントを用いて - - 効率良くプログラミングを行うことができます. - 記述方法がわからない, コマンドに与えるパラメータがわからない... - - Canvas.new { ... } と, なぜイテレータブロックを書けるの?? - - Canvas の bbox は数値のリストを返すのに, xview は文字列を返すの?? - と, いちいち, ライブラリのソースを追いかける必要はありません. - -2. 個々の機能(オプション)を個別処理によりサポートしており, そのためサ - ポートしていない機能は使うことができない(本当は使えないこともないの - ですが) `tk.rb' とは異なり, tcl/tk インタプリタで可能なことは - - ほとんど - - ruby からも実行できます. 現在, ruby から実行できないことが確認され - ているのは, - - bind コマンドでスクリプトを追加する構文 - 「bind tag sequence +script」 - ^ - - のみです. - - `. configure -width' をしようとして, `Tk.root.height()' と書い - たのに, `undefined method `height'' と怒られてしまった. tk.rb を - 読んでみて, ガーン. できないのか... - ということはありません. - -3. wish プロセスを起動しプロセス間通信で wish を利用する `tk.rb' とは - 異なり, tcl/tk の C ライブラリをリンクし - - より高速に (といっても, 思った程は速くないですが) - - 処理を行います. - -4. `tk.rb' ほど, 高水準なインターフェースを備えていないため, tcl/tk イ - ンタプリタの生成等 - - 何から何まで自分で記述 - - しなければなりません(その代わり, tcl/tk ライブラリの仕様通り, - tcl/tk インタプリタを複数生成することもできますが). - インターフェースは(おそらく) ruby の思想に沿ったものではありません. - また, スクリプトの記述は - - ダサダサ - - です. スクリプトは, 一見, 読みづらいものとなります. が, 書く人にとっ - ては, それほど煩わしいものではないと思います. - -[インストールの方法] - -0. ruby のソースファイル(ruby-1.0-なんたら.tgz)を展開しておきます. - -1. ruby-1.0-なんたら/ext に ext/tcltklib をコピーします. - cp -r ext/tcltklib ???/ruby-1.0-なんたら/ext/ - -2. ruby のインストール法に従い make 等をします. - -3. ruby のライブラリ置場に lib/* をコピーします. - cp lib/* /usr/local/lib/ruby/ - -(eof) diff --git a/ext/tcltklib/demo/lines0.tcl b/ext/tcltklib/demo/lines0.tcl deleted file mode 100644 index 8ed3c5e1c1..0000000000 --- a/ext/tcltklib/demo/lines0.tcl +++ /dev/null @@ -1,42 +0,0 @@ -#! /usr/local/bin/wish - -proc drawlines {} { - puts [clock format [clock seconds]] - - for {set j 0} {$j < 100} {incr j} { - puts -nonewline "*" - flush stdout - if {$j & 1} { - set c "blue" - } { - set c "red" - } - for {set i 0} {$i < 100} {incr i} { -# .a create line $i 0 0 [expr 500 - $i] -fill $c - } - } - - puts [clock format [clock seconds]] - - for {set j 0} {$j < 100} {incr j} { - puts -nonewline "*" - flush stdout - if {$j & 1} { - set c "blue" - } { - set c "red" - } - for {set i 0} {$i < 100} {incr i} { - .a create line $i 0 0 [expr 500 - $i] -fill $c - } - } - - puts [clock format [clock seconds]] -# destroy . -} - -canvas .a -height 500 -width 500 -button .b -text draw -command drawlines -pack .a .b -side left - -# eof diff --git a/ext/tcltklib/demo/lines1.rb b/ext/tcltklib/demo/lines1.rb deleted file mode 100644 index 9f21ae6377..0000000000 --- a/ext/tcltklib/demo/lines1.rb +++ /dev/null @@ -1,50 +0,0 @@ -#! /usr/local/bin/ruby - -require "tcltk" - -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.e("create line", 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.e("create line", i, 0, 0, 500 - i, "-fill", col) - end - end - - print Time.now, "\n" -# $ip.commands()["destroy"].e($root) -end - -$ip = TclTkInterpreter.new() -$root = $ip.rootwidget() -$a = TclTkWidget.new($ip, $root, "canvas", "-height 500 -width 500") -$c = TclTkCallback.new($ip, proc{drawlines()}) -$b = TclTkWidget.new($ip, $root, "button", "-text draw -command", $c) - -$ip.commands()["pack"].e($a, $b, "-side left") - -TclTk.mainloop - -# eof diff --git a/ext/tcltklib/demo/lines2.rb b/ext/tcltklib/demo/lines2.rb deleted file mode 100644 index e459589f50..0000000000 --- a/ext/tcltklib/demo/lines2.rb +++ /dev/null @@ -1,54 +0,0 @@ -#! /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 -# TkcLine.new($a, 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 - TkcLine.new($a, 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/lines3.rb b/ext/tcltklib/demo/lines3.rb deleted file mode 100644 index caa50f92e7..0000000000 --- a/ext/tcltklib/demo/lines3.rb +++ /dev/null @@ -1,54 +0,0 @@ -#! /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 deleted file mode 100644 index 7a1175bce0..0000000000 --- a/ext/tcltklib/demo/lines4.rb +++ /dev/null @@ -1,54 +0,0 @@ -#! /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/demo/safeTk.rb b/ext/tcltklib/demo/safeTk.rb deleted file mode 100644 index 5d2c60e700..0000000000 --- a/ext/tcltklib/demo/safeTk.rb +++ /dev/null @@ -1,22 +0,0 @@ -#!/usr/bin/env ruby -require 'tcltklib' - -master = TclTkIp.new -slave_name = 'slave0' -slave = master.create_slave(slave_name, true) -master._eval("::safe::interpInit #{slave_name}") -master._eval("::safe::loadTk #{slave_name}") - -master._invoke('label', '.l1', '-text', 'master') -master._invoke('pack', '.l1', '-padx', '30', '-pady', '50') -master._eval('label .l2 -text {root widget of master-ip}') -master._eval('pack .l2 -padx 30 -pady 50') - -slave._invoke('label', '.l1', '-text', 'slave') -slave._invoke('pack', '.l1', '-padx', '30', '-pady', '50') -slave._eval('label .l2 -text {root widget of slave-ip}') -slave._eval('pack .l2 -padx 30 -pady 20') -slave._eval('label .l3 -text {( container frame widget of master-ip )}') -slave._eval('pack .l3 -padx 30 -pady 20') - -TclTkLib.mainloop diff --git a/ext/tcltklib/depend b/ext/tcltklib/depend deleted file mode 100644 index 526a7b871c..0000000000 --- a/ext/tcltklib/depend +++ /dev/null @@ -1,2 +0,0 @@ -tcltklib.o: tcltklib.c $(hdrdir)/ruby.h $(topdir)/config.h $(hdrdir)/defines.h -stubs.o: stubs.c stubs.h $(hdrdir)/ruby.h $(topdir)/config.h $(hdrdir)/defines.h diff --git a/ext/tcltklib/extconf.rb b/ext/tcltklib/extconf.rb deleted file mode 100644 index 94c817e39f..0000000000 --- a/ext/tcltklib/extconf.rb +++ /dev/null @@ -1,300 +0,0 @@ -# extconf.rb for tcltklib - -require 'mkmf' - -is_win32 = (/mswin32|mingw|cygwin|bccwin32/ =~ RUBY_PLATFORM) -#is_macosx = (/darwin/ =~ RUBY_PLATFORM) - -def find_framework(tcl_hdr, tk_hdr) - if framework_dir = with_config("tcltk-framework") - paths = [framework_dir] - else - unless tcl_hdr || tk_hdr || - enable_config("tcltk-framework", false) || - enable_config("mac-tcltk-framework", false) - return false - end - paths = ["/Library/Frameworks", "/System/Library/Frameworks"] - end - - checking_for('Tcl/Tk Framework') { - paths.find{|dir| - dir.strip! - dir.chomp!('/') - (tcl_hdr || FileTest.directory?(dir + "/Tcl.framework/") ) && - (tk_hdr || FileTest.directory?(dir + "/Tk.framework/") ) - } - } -end - -tcl_framework_header = with_config("tcl-framework-header") -tk_framework_header = with_config("tk-framework-header") - -tcltk_framework = find_framework(tcl_framework_header, tk_framework_header) - -unless is_win32 - have_library("nsl", "t_open") - have_library("socket", "socket") - have_library("dl", "dlopen") - have_library("m", "log") -end - -dir_config("tk") -dir_config("tcl") -dir_config("X11") - -tklib = with_config("tklib") -tcllib = with_config("tcllib") -stubs = enable_config("tcltk_stubs") || with_config("tcltk_stubs") - -def find_tcl(tcllib, stubs) - paths = ["/usr/local/lib", "/usr/pkg/lib", "/usr/lib"] - if stubs - func = "Tcl_InitStubs" - lib = "tclstub" - else - func = "Tcl_FindExecutable" - lib = "tcl" - end - if tcllib - find_library(tcllib, func, *paths) - elsif find_library(lib, func, *paths) - true - else - %w[8.5 8.4 8.3 8.2 8.1 8.0 7.6].find { |ver| - find_library("#{lib}#{ver}", func, *paths) or - find_library("#{lib}#{ver.delete('.')}", func, *paths) or - find_library("tcl#{ver}", func, *paths) or - find_library("tcl#{ver.delete('.')}", func, *paths) - } - end -end - -def find_tk(tklib, stubs) - paths = ["/usr/local/lib", "/usr/pkg/lib", "/usr/lib"] - if stubs - func = "Tk_InitStubs" - lib = "tkstub" - else - func = "Tk_Init" - lib = "tk" - end - if tklib - find_library(tklib, func, *paths) - elsif find_library(lib, func, *paths) - true - else - %w[8.5 8.4 8.3 8.2 8.1 8.0 4.2].find { |ver| - find_library("#{lib}#{ver}", func, *paths) or - find_library("#{lib}#{ver.delete('.')}", func, *paths) or - find_library("tk#{ver}", func, *paths) or - find_library("tk#{ver.delete('.')}", func, *paths) - } - end -end - -def pthread_check() - tcl_major_ver = nil - tcl_minor_ver = nil - - # Is tcl-thread given by user ? - case enable_config("tcl-thread") - when true - tcl_enable_thread = true - when false - tcl_enable_thread = false - else - tcl_enable_thread = nil - end - - if (tclConfig = with_config("tclConfig-file")) - if tcl_enable_thread == true - puts("Warning: --with-tclConfig-file option is ignored, because --enable-tcl-thread option is given.") - elsif tcl_enable_thread == false - puts("Warning: --with-tclConfig-file option is ignored, because --disable-tcl-thread option is given.") - else - # tcl-thread is unknown and tclConfig.sh is given - begin - open(tclConfig, "r") do |cfg| - while line = cfg.gets() - if line =~ /^\s*TCL_THREADS=(0|1)/ - tcl_enable_thread = ($1 == "1") - break - end - - if line =~ /^\s*TCL_MAJOR_VERSION=("|')(\d+)\1/ - tcl_major_ver = $2 - if tcl_major_ver =~ /^[1-7]$/ - tcl_enable_thread = false - break - end - if tcl_major_ver == "8" && tcl_minor_ver == "0" - tcl_enable_thread = false - break - end - end - - if line =~ /^\s*TCL_MINOR_VERSION=("|')(\d+)\1/ - tcl_minor_ver = $2 - if tcl_major_ver == "8" && tcl_minor_ver == "0" - tcl_enable_thread = false - break - end - end - end - end - - if tcl_enable_thread == nil - # not find definition - if tcl_major_ver - puts("Warning: '#{tclConfig}' doesn't include TCL_THREADS definition.") - else - puts("Warning: '#{tclConfig}' may not be a tclConfig file.") - end - tclConfig = false - end - rescue Exception - puts("Warning: fail to read '#{tclConfig}'!! --> ignore the file") - tclConfig = false - end - end - end - - if tcl_enable_thread == nil && !tclConfig - # tcl-thread is unknown and tclConfig is unavailable - begin - try_run_available = try_run("int main() { exit(0); }") - rescue Exception - # cannot try_run. Is CROSS-COMPILE environment? - puts(%Q'\ -***************************************************************************** -** -** PTHREAD SUPPORT CHECK WARNING: -** -** We cannot check the consistency of pthread support between Ruby -** and the Tcl/Tk library in your environment (are you perhaps -** cross-compiling?). If pthread support for these 2 packages is -** inconsistent you may find you get errors when running Ruby/Tk -** (e.g. hangs or segmentation faults). We strongly recommend -** you to check the consistency manually. -** -***************************************************************************** -') - return true - end - end - - if tcl_enable_thread == nil - # tcl-thread is unknown - if try_run(<<EOF) -#include <tcl.h> -int main() { - Tcl_Interp *ip; - ip = Tcl_CreateInterp(); - exit((Tcl_Eval(ip, "set tcl_platform(threaded)") == TCL_OK)? 0: 1); -} -EOF - tcl_enable_thread = true - elsif 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 - end - - # check pthread mode - if (macro_defined?('HAVE_LIBPTHREAD', '#include "ruby.h"')) - # ruby -> enable - unless tcl_enable_thread - # ruby -> enable && tcl -> disable - puts(%Q'\ -***************************************************************************** -** -** PTHREAD SUPPORT MODE WARNING: -** -** Ruby is compiled with --enable-pthread, but your Tcl/Tk library -** seems to be compiled without pthread support. Although you can -** create the tcltklib library, this combination may cause errors -** (e.g. hangs or segmentation faults). If you have no reason to -** keep the current pthread support status, we recommend you reconfigure -** and recompile the libraries so that both or neither support pthreads. -** -** 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 or equal to Tcl/Tk 8.1). -** -***************************************************************************** -') - end - - # ruby -> enable && tcl -> enable/disable - if tcl_enable_thread - $CPPFLAGS += ' -DWITH_TCL_ENABLE_THREAD=1' - else - $CPPFLAGS += ' -DWITH_TCL_ENABLE_THREAD=0' - end - - return true - - else - # ruby -> disable - if tcl_enable_thread - # ruby -> disable && tcl -> enable - puts(%Q'\ -***************************************************************************** -** -** PTHREAD SUPPORT MODE ERROR: -** -** Ruby is not compiled with --enable-pthread, but your Tcl/Tk -** library seems to be compiled with pthread support. This -** combination may cause frequent hang or segmentation fault -** errors when Ruby/Tk is working. We recommend that you NEVER -** create the library with such a combination of pthread support. -** -** Please recompile Ruby with the "--enable-pthread" configure option -** or recompile Tcl/Tk with the "--disable-threads" configure option. -** -***************************************************************************** -') - $CPPFLAGS += ' -DWITH_TCL_ENABLE_THREAD=1' - return false - else - # ruby -> disable && tcl -> disable - $CPPFLAGS += ' -DWITH_TCL_ENABLE_THREAD=0' - return true - end - end -end - -if tcltk_framework || - (have_header("tcl.h") && have_header("tk.h") && - (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 - - if tcltk_framework - if tcl_framework_header - $CPPFLAGS += " -I#{tcl_framework_header}" - else - $CPPFLAGS += " -I#{tcltk_framework}/Tcl.framework/Headers" - end - - if tk_framework_header - $CPPFLAGS += " -I#{tk_framework_header}" - else - $CPPFLAGS += " -I#{tcltk_framework}/Tk.framework/Headers" - end - - $LDFLAGS += ' -framework Tk -framework Tcl' - end - - create_makefile("tcltklib") if stubs or pthread_check -end diff --git a/ext/tcltklib/lib/tcltk.rb b/ext/tcltklib/lib/tcltk.rb deleted file mode 100644 index 1a6694dbff..0000000000 --- a/ext/tcltklib/lib/tcltk.rb +++ /dev/null @@ -1,367 +0,0 @@ -# tof - -#### tcltk library, more direct manipulation of tcl/tk -#### Sep. 5, 1997 Y. Shigehiro - -require "tcltklib" - -################ - -# module TclTk: collection of tcl/tk utilities (supplies namespace.) -module TclTk - - # initialize Hash to hold unique symbols and such - @namecnt = {} - - # initialize Hash to hold callbacks - @callback = {} -end - -# TclTk.mainloop(): call TclTkLib.mainloop() -def TclTk.mainloop() - print("mainloop: start\n") if $DEBUG - TclTkLib.mainloop() - print("mainloop: end\n") if $DEBUG -end - -# TclTk.deletecallbackkey(ca): remove callback from TclTk module -# this does not remove callbacks from tcl/tk interpreter -# without calling this method, TclTkInterpreter will not be GCed -# ca: callback(TclTkCallback) -def TclTk.deletecallbackkey(ca) - print("deletecallbackkey: ", ca.to_s(), "\n") if $DEBUG - @callback.delete(ca.to_s) -end - -# TclTk.dcb(ca, wid, W): call TclTk.deletecallbackkey() for each callbacks -# in an array. -# this is for callback for top-level <Destroy> -# ca: array of callbacks(TclTkCallback) -# wid: top-level widget(TclTkWidget) -# w: information about window given by %W(String) -def TclTk.dcb(ca, wid, w) - if wid.to_s() == w - ca.each{|i| - TclTk.deletecallbackkey(i) - } - end -end - -# TclTk._addcallback(ca): register callback -# ca: callback(TclTkCallback) -def TclTk._addcallback(ca) - print("_addcallback: ", ca.to_s(), "\n") if $DEBUG - @callback[ca.to_s()] = ca -end - -# TclTk._callcallback(key, arg): invoke registered callback -# key: key to select callback (to_s value of the TclTkCallback) -# arg: parameter from tcl/tk interpreter -def TclTk._callcallback(key, arg) - print("_callcallback: ", @callback[key].inspect, "\n") if $DEBUG - @callback[key]._call(arg) - # throw out callback value - # should return String to satisfy rb_eval_string() - return "" -end - -# TclTk._newname(prefix): generate unique name(String) -# prefix: prefix of the unique name -def TclTk._newname(prefix) - # generated name counter is stored in @namecnt - if !@namecnt.key?(prefix) - # first appearing prefix, initialize - @namecnt[prefix] = 1 - else - # already appeared prefix, generate next name - @namecnt[prefix] += 1 - end - return "#{prefix}#{@namecnt[prefix]}" -end - -################ - -# class TclTkInterpreter: tcl/tk interpreter -class TclTkInterpreter - - # initialize(): - def initialize() - # generate interpreter object - @ip = TclTkIp.new() - - # add ruby_fmt command to tcl interpreter - # ruby_fmt command format arguments by `format' and call `ruby' command - # (notice ruby command receives only one argument) - if $DEBUG - @ip._eval("proc ruby_fmt {fmt args} { puts \"ruby_fmt: $fmt $args\" ; set cmd [list ruby [format $fmt $args]] ; uplevel $cmd }") - else - @ip._eval("proc ruby_fmt {fmt args} { set cmd [list ruby [format $fmt $args]] ; uplevel $cmd }") - end - - # @ip._get_eval_string(*args): generate string to evaluate in tcl interpreter - # *args: script which is going to be evaluated under tcl/tk - def @ip._get_eval_string(*args) - argstr = "" - args.each{|arg| - argstr += " " if argstr != "" - # call to_eval if it is defined - if (arg.respond_to?(:to_eval)) - argstr += arg.to_eval() - else - # call to_s unless defined - argstr += arg.to_s() - end - } - return argstr - end - - # @ip._eval_args(*args): evaluate string under tcl/tk interpreter - # returns result string. - # *args: script which is going to be evaluated under tcl/tk - def @ip._eval_args(*args) - # calculate the string to eval in the interpreter - argstr = _get_eval_string(*args) - - # evaluate under the interpreter - print("_eval: \"", argstr, "\"") if $DEBUG - res = _eval(argstr) - if $DEBUG - print(" -> \"", res, "\"\n") - elsif _return_value() != 0 - print(res, "\n") - end - fail(%Q/can't eval "#{argstr}"/) if _return_value() != 0 #' - return res - end - - # generate tcl/tk command object and register in the hash - @commands = {} - # for all commands registered in tcl/tk interpreter: - @ip._eval("info command").split(/ /).each{|comname| - if comname =~ /^[.]/ - # if command is a widget (path), generate TclTkWidget, - # and register it in the hash - @commands[comname] = TclTkWidget.new(@ip, comname) - else - # otherwise, generate TclTkCommand - @commands[comname] = TclTkCommand.new(@ip, comname) - end - } - end - - # commands(): returns hash of the tcl/tk commands - def commands() - return @commands - end - - # rootwidget(): returns root widget(TclTkWidget) - def rootwidget() - return @commands["."] - end - - # _tcltkip(): returns @ip(TclTkIp) - def _tcltkip() - return @ip - end - - # method_missing(id, *args): execute undefined method as tcl/tk command - # id: method symbol - # *args: method arguments - def method_missing(id, *args) - # if command named by id registered, then execute it - if @commands.key?(id.id2name) - return @commands[id.id2name].e(*args) - else - # otherwise, exception - super - end - end -end - -# class TclTkObject: base class of the tcl/tk objects -class TclTkObject - - # initialize(ip, exp): - # ip: interpreter(TclTkIp) - # exp: tcl/tk representation - def initialize(ip, exp) - fail("type is not TclTkIp") if !ip.kind_of?(TclTkIp) - @ip = ip - @exp = exp - end - - # to_s(): returns tcl/tk representation - def to_s() - return @exp - end -end - -# class TclTkCommand: tcl/tk commands -# you should not call TclTkCommand.new() -# commands are created by TclTkInterpreter:initialize() -class TclTkCommand < TclTkObject - - # e(*args): execute command. returns String (e is for exec or eval) - # *args: command arguments - def e(*args) - return @ip._eval_args(to_s(), *args) - end -end - -# class TclTkLibCommand: tcl/tk commands in the library -class TclTkLibCommand < TclTkCommand - - # initialize(ip, name): - # ip: interpreter(TclTkInterpreter) - # name: command name (String) - def initialize(ip, name) - super(ip._tcltkip, name) - end -end - -# class TclTkVariable: tcl/tk variable -class TclTkVariable < TclTkObject - - # initialize(interp, dat): - # interp: interpreter(TclTkInterpreter) - # dat: the value to set(String) - # if nil, not initialize variable - def initialize(interp, dat) - # auto-generate tcl/tk representation (variable name) - exp = TclTk._newname("v_") - # initialize TclTkObject - super(interp._tcltkip(), exp) - # safe this for `set' command - @set = interp.commands()["set"] - # set value - set(dat) if dat - end - - # although you can set/refer variable by using set in tcl/tk, - # we provide the method for accessing variables - - # set(data): set tcl/tk variable using `set' - # data: new value - def set(data) - @set.e(to_s(), data.to_s()) - end - - # get(): read tcl/tk variable(String) using `set' - def get() - return @set.e(to_s()) - end -end - -# class TclTkWidget: tcl/tk widget -class TclTkWidget < TclTkCommand - - # initialize(*args): - # *args: parameters - def initialize(*args) - if args[0].kind_of?(TclTkIp) - # in case the 1st argument is TclTkIp: - - # Wrap tcl/tk widget by TclTkWidget - # (used in TclTkInterpreter#initialize()) - - # need two arguments - fail("illegal # of parameter") if args.size != 2 - - # ip: interpreter(TclTkIp) - # exp: tcl/tk representation - ip, exp = args - - # initialize TclTkObject - super(ip, exp) - elsif args[0].kind_of?(TclTkInterpreter) - # in case 1st parameter is TclTkInterpreter: - - # generate new widget from parent widget - - # interp: interpreter(TclTkInterpreter) - # parent: parent widget - # command: widget generating tk command(label 等) - # *args: argument to the command - interp, parent, command, *args = args - - # generate widget name - exp = parent.to_s() - exp += "." if exp !~ /[.]$/ - exp += TclTk._newname("w_") - # initialize TclTkObject - super(interp._tcltkip(), exp) - # generate widget - res = @ip._eval_args(command, exp, *args) -# fail("can't create Widget") if res != exp - # for tk_optionMenu, it is legal res != exp - else - fail("first parameter is not TclTkInterpreter") - end - end -end - -# class TclTkCallback: tcl/tk callbacks -class TclTkCallback < TclTkObject - - # initialize(interp, pr, arg): - # interp: interpreter(TclTkInterpreter) - # pr: callback procedure(Proc) - # arg: string to pass as block parameters of pr - # bind command of tcl/tk uses % replacement for parameters - # pr can receive replaced data using block parameter - # its format is specified by arg string - # You should not specify arg for the command like - # scrollbar with -command option, which receives parameters - # without specifying any replacement - def initialize(interp, pr, arg = nil) - # auto-generate tcl/tk representation (variable name) - exp = TclTk._newname("c_") - # initialize TclTkObject - super(interp._tcltkip(), exp) - # save parameters - @pr = pr - @arg = arg - # register in the module - TclTk._addcallback(self) - end - - # to_eval(): retuens string representation for @ip._eval_args - def to_eval() - if @arg - # bind replaces %s before calling ruby_fmt, so %%s is used - s = %Q/{ruby_fmt {TclTk._callcallback("#{to_s()}", "%%s")} #{@arg}}/ - else - s = %Q/{ruby_fmt {TclTk._callcallback("#{to_s()}", "%s")}}/ - end - - return s - end - - # _call(arg): invoke callback - # arg: callback parameter - def _call(arg) - @pr.call(arg) - end -end - -# class TclTkImage: tcl/tk images -class TclTkImage < TclTkCommand - - # initialize(interp, t, *args): - # generating image is done by TclTkImage.new() - # destrying is done by image delete (inconsistent, sigh) - # interp: interpreter(TclTkInterpreter) - # t: image type (photo, bitmap, etc.) - # *args: command argument - def initialize(interp, t, *args) - # auto-generate tcl/tk representation - exp = TclTk._newname("i_") - # initialize TclTkObject - super(interp._tcltkip(), exp) - # generate image - res = @ip._eval_args("image create", t, exp, *args) - fail("can't create Image") if res != exp - end -end - -# eof diff --git a/ext/tcltklib/sample/batsu.gif b/ext/tcltklib/sample/batsu.gif Binary files differdeleted file mode 100644 index 880cc73e09..0000000000 --- a/ext/tcltklib/sample/batsu.gif +++ /dev/null diff --git a/ext/tcltklib/sample/maru.gif b/ext/tcltklib/sample/maru.gif Binary files differdeleted file mode 100644 index 2c0202892e..0000000000 --- a/ext/tcltklib/sample/maru.gif +++ /dev/null diff --git a/ext/tcltklib/sample/sample0.rb b/ext/tcltklib/sample/sample0.rb deleted file mode 100644 index cd4c8069b4..0000000000 --- a/ext/tcltklib/sample/sample0.rb +++ /dev/null @@ -1,39 +0,0 @@ -#! /usr/local/bin/ruby -vd - -# tcltklib ライブラリのテスト - -require "tcltklib" - -def test - # インタプリタを生成する - ip1 = TclTkIp.new() - - # 評価してみる - print ip1._return_value().inspect, "\n" - print ip1._eval("puts {abc}").inspect, "\n" - - # ボタンを作ってみる - print ip1._return_value().inspect, "\n" - print ip1._eval("button .lab -text exit -command \"destroy .\"").inspect, - "\n" - print ip1._return_value().inspect, "\n" - print ip1._eval("pack .lab").inspect, "\n" - print ip1._return_value().inspect, "\n" - - # インタプリタから ruby コマンドを評価してみる -# print ip1._eval(%q/ruby {print "print by ruby\n"}/).inspect, "\n" - print ip1._eval(%q+puts [ruby {print "print by ruby\n"; "puts by tcl/tk"}]+).inspect, "\n" - print ip1._return_value().inspect, "\n" - - # もう一つインタプリタを生成してみる - ip2 = TclTkIp.new() - ip2._eval("button .lab -text test -command \"puts test ; destroy .\"") - ip2._eval("pack .lab") - - TclTkLib.mainloop -end - -test -GC.start - -print "exit\n" diff --git a/ext/tcltklib/sample/sample1.rb b/ext/tcltklib/sample/sample1.rb deleted file mode 100644 index 13df440751..0000000000 --- a/ext/tcltklib/sample/sample1.rb +++ /dev/null @@ -1,634 +0,0 @@ -#! /usr/local/bin/ruby -d -#! /usr/local/bin/ruby -# -d オプションを付けると, デバッグ情報を表示する. - -# tcltk ライブラリのサンプル - -# まず, ライブラリを require する. -require "tcltk" - -# 以下は, Test1 のインスタンスの initialize() で, -# tcl/tk に関する処理を行う例である. -# 必ずしもそのようにする必要は無く, -# (もし, そうしたければ) class の外で tcl/tk に関する処理を行っても良い. - -class Test1 - # 初期化(インタプリタを生成してウィジェットを生成する). - def initialize() - - #### 使う前のおまじない - - # インタプリタの生成. - ip = TclTkInterpreter.new() - # コマンドに対応するオブジェクトを c に設定しておく. - c = ip.commands() - # 使用するコマンドに対応するオブジェクトは変数に入れておく. - append, bind, button, destroy, incr, info, label, place, set, wm = - c.values_at( - "append", "bind", "button", "destroy", "incr", "info", "label", "place", - "set", "wm") - - #### tcl/tk のコマンドに対応するオブジェクト(TclTkCommand)の操作 - - # 実行する時は, e() メソッドを使う. - # (以下は, tcl/tk における info command r* を実行.) - print info.e("command", "r*"), "\n" - # 引数は, まとめた文字列にしても同じ. - print info.e("command r*"), "\n" - # 変数を用いなくとも実行できるが, 見ためが悪い. - print c["info"].e("command", "r*"), "\n" - # インタプリタのメソッドとしても実行できるが, 効率が悪い. - print ip.info("command", "r*"), "\n" - - #### - - # 以下, 生成したオブジェクトは変数に代入しておかないと - # GC の対象になってしまう. - - #### tcl/tk の変数に対応するオブジェクト(TclTkVariable)の操作 - - # 生成と同時に値を設定する. - v1 = TclTkVariable.new(ip, "20") - # 読み出しは get メソッドを使う. - print v1.get(), "\n" - # 設定は set メソッドを使う. - v1.set(40) - print v1.get(), "\n" - # set コマンドを使って読み出し, 設定は可能だが見ためが悪い. - # e() メソッド等の引数に直接 TclTkObject や数値を書いても良い. - set.e(v1, 30) - print set.e(v1), "\n" - # tcl/tk のコマンドで変数を操作できる. - incr.e(v1) - print v1.get(), "\n" - append.e(v1, 10) - print v1.get(), "\n" - - #### tcl/tk のウィジェットに対応するオブジェクト(TclTkWidget)の操作 - - # ルートウィジェットを取り出す. - root = ip.rootwidget() - # ウィジェットの操作. - root.e("configure -height 300 -width 300") - # タイトルを付けるときは wm を使う. - wm.e("title", root, $0) - # 親ウィジェットとコマンドを指定して, ウィジェットを作る. - l1 = TclTkWidget.new(ip, root, label, "-text {type `x' to print}") - # place すると表示される. - place.e(l1, "-x 0 -rely 0.0 -relwidth 1 -relheight 0.1") - # コマンド名は文字列で指定しても良いが, 見ためが悪い. - # (コマンド名は独立した引数でなければならない.) - l2 = TclTkWidget.new(ip, root, "label") - # ウィジェットの操作. - l2.e("configure -text {type `q' to exit}") - place.e(l2, "-x 0 -rely 0.1 -relwidth 1 -relheight 0.1") - - #### tcl/tk のコールバックに対応するオブジェクト(TclTkCallback)の操作 - - # コールバックを生成する. - c1 = TclTkCallback.new(ip, proc{sample(ip, root)}) - # コールバックを持つウィジェットを生成する. - b1 = TclTkWidget.new(ip, root, button, "-text sample -command", c1) - place.e(b1, "-x 0 -rely 0.2 -relwidth 1 -relheight 0.1") - # イベントループを抜けるには destroy.e(root) する. - c2 = TclTkCallback.new(ip, proc{destroy.e(root)}) - b2 = TclTkWidget.new(ip, root, button, "-text exit -command", c2) - place.e(b2, "-x 0 -rely 0.3 -relwidth 1 -relheight 0.1") - - #### イベントのバインド - # script の追加 (bind tag sequence +script) は今のところできない. - # (イテレータ変数の設定がうまくいかない.) - - # 基本的にはウィジェットに対するコールバックと同じ. - c3 = TclTkCallback.new(ip, proc{print("q pressed\n"); destroy.e(root)}) - bind.e(root, "q", c3) - # bind コマンドで % 置換によりパラメータを受け取りたいときは, - # proc{} の後ろに文字列で指定すると, - # 置換結果をイテレータ変数を通して受け取ることができる. - # ただし proc{} の後ろの文字列は, - # bind コマンドに与えるコールバック以外で指定してはいけない. - c4 = TclTkCallback.new(ip, proc{|i| print("#{i} pressed\n")}, "%A") - bind.e(root, "x", c4) - # TclTkCallback を GC の対象にしたければ, - # dcb() (または deletecallbackkeys()) する必要がある. - cb = [c1, c2, c3, c4] - c5 = TclTkCallback.new(ip, proc{|w| TclTk.dcb(cb, root, w)}, "%W") - bind.e(root, "<Destroy>", c5) - cb.push(c5) - - #### tcl/tk のイメージに対応するオブジェクト(TclTkImage)の操作 - - # データを指定して生成する. - i1 = TclTkImage.new(ip, "photo", "-file maru.gif") - # ラベルに張り付けてみる. - l3 = TclTkWidget.new(ip, root, label, "-relief raised -image", i1) - place.e(l3, "-x 0 -rely 0.4 -relwidth 0.2 -relheight 0.2") - # 空のイメージを生成して後で操作する. - i2 = TclTkImage.new(ip, "photo") - # イメージを操作する. - i2.e("copy", i1) - i2.e("configure -gamma 0.5") - l4 = TclTkWidget.new(ip, root, label, "-relief raised -image", i2) - place.e(l4, "-relx 0.2 -rely 0.4 -relwidth 0.2 -relheight 0.2") - - #### - end - - # サンプルのためのウィジェットを生成する. - def sample(ip, parent) - bind, button, destroy, grid, toplevel, wm = ip.commands().values_at( - "bind", "button", "destroy", "grid", "toplevel", "wm") - - ## toplevel - - # 新しいウインドウを開くには, toplevel を使う. - t1 = TclTkWidget.new(ip, parent, toplevel) - # タイトルを付けておく - wm.e("title", t1, "sample") - - # ウィジェットが破壊されたとき, コールバックが GC の対象になるようにする. - cb = [] - cb.push(c = TclTkCallback.new(ip, proc{|w| TclTk.dcb(cb, t1, w)}, "%W")) - bind.e(t1, "<Destroy>", c) - - # ボタンの生成. - wid = [] - # toplevel ウィジェットを破壊するには destroy する. - cb.push(c = TclTkCallback.new(ip, proc{destroy.e(t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text close -command", c)) - cb.push(c = TclTkCallback.new(ip, proc{test_label(ip, t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text label -command", c)) - cb.push(c = TclTkCallback.new(ip, proc{test_button(ip, t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text button -command", c)) - cb.push(c = TclTkCallback.new(ip, proc{test_checkbutton(ip, t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text checkbutton -command", c)) - cb.push(c = TclTkCallback.new(ip, proc{test_radiobutton(ip, t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text radiobutton -command", c)) - cb.push(c = TclTkCallback.new(ip, proc{test_scale(ip, t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text scale -command", c)) - cb.push(c = TclTkCallback.new(ip, proc{test_entry(ip, t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text entry -command", c)) - cb.push(c = TclTkCallback.new(ip, proc{test_text(ip, t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text text -command", c)) - cb.push(c = TclTkCallback.new(ip, proc{test_raise(ip, t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text raise/lower -command", c)) - cb.push(c = TclTkCallback.new(ip, proc{test_modal(ip, t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text message/modal -command", - c)) - cb.push(c = TclTkCallback.new(ip, proc{test_menu(ip, t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text menu -command", c)) - cb.push(c = TclTkCallback.new(ip, proc{test_listbox(ip, t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text listbox/scrollbar", - "-command", c)) - cb.push(c = TclTkCallback.new(ip, proc{test_canvas(ip, t1)})) - wid.push(TclTkWidget.new(ip, t1, button, "-text canvas -command", c)) - - # grid で表示する. - ro = co = 0 - wid.each{|w| - grid.e(w, "-row", ro, "-column", co, "-sticky news") - ro += 1 - if ro == 7 - ro = 0 - co += 1 - end - } - end - - # inittoplevel(ip, parent, title) - # 以下の処理をまとめて行う. - # 1. toplevel ウィジェットを作成する. - # 2. コールバックを登録する配列を用意し, toplevel ウィジェットの - # <Destroy> イベントにコールバックを削除する手続きを登録する. - # 3. クローズボタンを作る. - # 作成した toplevel ウィジェット, クローズボタン, コールバック登録用変数 - # を返す. - # ip: インタプリタ - # parent: 親ウィジェット - # title: toplevel ウィジェットのウインドウのタイトル - def inittoplevel(ip, parent, title) - bind, button, destroy, toplevel, wm = ip.commands().values_at( - "bind", "button", "destroy", "toplevel", "wm") - - # 新しいウインドウを開くには, toplevel を使う. - t1 = TclTkWidget.new(ip, parent, toplevel) - # タイトルを付けておく - wm.e("title", t1, title) - - # ウィジェットが破壊されたとき, コールバックが GC の対象になるようにする. - cb = [] - cb.push(c = TclTkCallback.new(ip, proc{|w| TclTk.dcb(cb, t1, w)}, "%W")) - bind.e(t1, "<Destroy>", c) - # close ボタンを作っておく. - # toplevel ウィジェットを破壊するには destroy する. - cb.push(c = TclTkCallback.new(ip, proc{destroy.e(t1)})) - b1 = TclTkWidget.new(ip, t1, button, "-text close -command", c) - - return t1, b1, cb - end - - # label のサンプル. - def test_label(ip, parent) - button, global, label, pack = ip.commands().values_at( - "button", "global", "label", "pack") - t1, b1, cb = inittoplevel(ip, parent, "label") - - ## label - - # いろいろな形のラベル. - l1 = TclTkWidget.new(ip, t1, label, "-text {default(flat)}") - l2 = TclTkWidget.new(ip, t1, label, "-text raised -relief raised") - l3 = TclTkWidget.new(ip, t1, label, "-text sunken -relief sunken") - l4 = TclTkWidget.new(ip, t1, label, "-text groove -relief groove") - l5 = TclTkWidget.new(ip, t1, label, "-text ridge -relief ridge") - l6 = TclTkWidget.new(ip, t1, label, "-bitmap error") - l7 = TclTkWidget.new(ip, t1, label, "-bitmap questhead") - - # pack しても表示される. - pack.e(b1, l1, l2, l3, l4, l5, l6, l7, "-pady 3") - - ## -textvariable - - # tcltk ライブラリの実装では, コールバックは tcl/tk の``手続き''を通して - # 呼ばれる. したがって, コールバックの中で(大域)変数にアクセスするときは, - # global する必要がある. - # global する前に変数に値を設定してしまうとエラーになるので, - # tcl/tk における表現形だけ生成して, 実際に値を設定しないように, - # 2 番目の引数には nil を与える. - v1 = TclTkVariable.new(ip, nil) - global.e(v1) - v1.set(100) - # -textvariable で変数を設定する. - l6 = TclTkWidget.new(ip, t1, label, "-textvariable", v1) - # コールバックの中から変数を操作する. - cb.push(c = TclTkCallback.new(ip, proc{ - global.e(v1); v1.set(v1.get().to_i + 10)})) - b2 = TclTkWidget.new(ip, t1, button, "-text +10 -command", c) - cb.push(c = TclTkCallback.new(ip, proc{ - global.e(v1); v1.set(v1.get().to_i - 10)})) - b3 = TclTkWidget.new(ip, t1, button, "-text -10 -command", c) - pack.e(l6, b2, b3) - end - - # button のサンプル. - def test_button(ip, parent) - button, pack = ip.commands().values_at("button", "pack") - t1, b1, cb = inittoplevel(ip, parent, "button") - - ## button - - # コールバック内で参照する変数は先に宣言しておかなければならない. - b3 = b4 = nil - cb.push(c = TclTkCallback.new(ip, proc{b3.e("flash"); b4.e("flash")})) - b2 = TclTkWidget.new(ip, t1, button, "-text flash -command", c) - cb.push(c = TclTkCallback.new(ip, proc{b2.e("configure -state normal")})) - b3 = TclTkWidget.new(ip, t1, button, "-text normal -command", c) - cb.push(c = TclTkCallback.new(ip, proc{b2.e("configure -state disabled")})) - b4 = TclTkWidget.new(ip, t1, button, "-text disable -command", c) - pack.e(b1, b2, b3, b4) - end - - # checkbutton のサンプル. - def test_checkbutton(ip, parent) - checkbutton, global, pack = ip.commands().values_at( - "checkbutton", "global", "pack") - t1, b1, cb = inittoplevel(ip, parent, "checkbutton") - - ## checkbutton - - v1 = TclTkVariable.new(ip, nil) - global.e(v1) - # -variable で変数を設定する. - ch1 = TclTkWidget.new(ip, t1, checkbutton, "-onvalue on -offvalue off", - "-textvariable", v1, "-variable", v1) - pack.e(b1, ch1) - end - - # radiobutton のサンプル. - def test_radiobutton(ip, parent) - global, label, pack, radiobutton = ip.commands().values_at( - "global", "label", "pack", "radiobutton") - t1, b1, cb = inittoplevel(ip, parent, "radiobutton") - - ## radiobutton - - v1 = TclTkVariable.new(ip, nil) - global.e(v1) - # ヌルストリングは "{}" で指定する. - v1.set("{}") - l1 = TclTkWidget.new(ip, t1, label, "-textvariable", v1) - # -variable で同じ変数を指定すると同じグループになる. - ra1 = TclTkWidget.new(ip, t1, radiobutton, - "-text radio1 -value r1 -variable", v1) - ra2 = TclTkWidget.new(ip, t1, radiobutton, - "-text radio2 -value r2 -variable", v1) - cb.push(c = TclTkCallback.new(ip, proc{global.e(v1); v1.set("{}")})) - ra3 = TclTkWidget.new(ip, t1, radiobutton, - "-text clear -value r3 -variable", v1, "-command", c) - pack.e(b1, l1, ra1, ra2, ra3) - end - - # scale のサンプル. - def test_scale(ip, parent) - global, pack, scale = ip.commands().values_at( - "global", "pack", "scale") - t1, b1, cb = inittoplevel(ip, parent, "scale") - - ## scale - - v1 = TclTkVariable.new(ip, nil) - global.e(v1) - v1.set(219) - # コールバック内で参照する変数は先に宣言しておかなければならない. - sca1 = nil - cb.push(c = TclTkCallback.new(ip, proc{global.e(v1); v = v1.get(); - sca1.e("configure -background", format("#%02x%02x%02x", v, v, v))})) - sca1 = TclTkWidget.new(ip, t1, scale, - "-label scale -orient h -from 0 -to 255 -variable", v1, "-command", c) - pack.e(b1, sca1) - end - - # entry のサンプル. - def test_entry(ip, parent) - button, entry, global, pack = ip.commands().values_at( - "button", "entry", "global", "pack") - t1, b1, cb = inittoplevel(ip, parent, "entry") - - ## entry - - v1 = TclTkVariable.new(ip, nil) - global.e(v1) - # ヌルストリングは "{}" で指定する. - v1.set("{}") - en1 = TclTkWidget.new(ip, t1, entry, "-textvariable", v1) - cb.push(c = TclTkCallback.new(ip, proc{ - global.e(v1); print(v1.get(), "\n"); v1.set("{}")})) - b2 = TclTkWidget.new(ip, t1, button, "-text print -command", c) - pack.e(b1, en1, b2) - end - - # text のサンプル. - def test_text(ip, parent) - button, pack, text = ip.commands().values_at( - "button", "pack", "text") - t1, b1, cb = inittoplevel(ip, parent, "text") - - ## text - - te1 = TclTkWidget.new(ip, t1, text) - cb.push(c = TclTkCallback.new(ip, proc{ - # 1 行目の 0 文字目から最後までを表示し, 削除する. - print(te1.e("get 1.0 end")); te1.e("delete 1.0 end")})) - b2 = TclTkWidget.new(ip, t1, button, "-text print -command", c) - pack.e(b1, te1, b2) - end - - # raise/lower のサンプル. - def test_raise(ip, parent) - button, frame, lower, pack, raise = ip.commands().values_at( - "button", "frame", "lower", "pack", "raise") - t1, b1, cb = inittoplevel(ip, parent, "raise/lower") - - ## raise/lower - - # button を隠すテストのために, frame を使う. - f1 = TclTkWidget.new(ip, t1, frame) - # コールバック内で参照する変数は先に宣言しておかなければならない. - b2 = nil - cb.push(c = TclTkCallback.new(ip, proc{raise.e(f1, b2)})) - b2 = TclTkWidget.new(ip, t1, button, "-text raise -command", c) - cb.push(c = TclTkCallback.new(ip, proc{lower.e(f1, b2)})) - b3 = TclTkWidget.new(ip, t1, button, "-text lower -command", c) - lower.e(f1, b3) - - pack.e(b2, b3, "-in", f1) - pack.e(b1, f1) - end - - # modal なウィジェットのサンプル. - def test_modal(ip, parent) - button, frame, message, pack, tk_chooseColor, tk_getOpenFile, - tk_messageBox = ip.commands().values_at( - "button", "frame", "message", "pack", "tk_chooseColor", - "tk_getOpenFile", "tk_messageBox") - # 最初に load されていないライブラリは ip.commands() に存在しないので, - # TclTkLibCommand を生成する必要がある. - tk_dialog = TclTkLibCommand.new(ip, "tk_dialog") - t1, b1, cb = inittoplevel(ip, parent, "message/modal") - - ## message - - mes = "これは message ウィジェットのテストです." - mes += "以下は modal なウィジェットのテストです." - me1 = TclTkWidget.new(ip, t1, message, "-text {#{mes}}") - - ## modal - - # tk_messageBox - cb.push(c = TclTkCallback.new(ip, proc{ - print tk_messageBox.e("-type yesnocancel -message messageBox", - "-icon error -default cancel -title messageBox"), "\n"})) - b2 = TclTkWidget.new(ip, t1, button, "-text messageBox -command", c) - # tk_dialog - cb.push(c = TclTkCallback.new(ip, proc{ - # ウィジェット名を生成するためにダミーの frame を生成. - print tk_dialog.e(TclTkWidget.new(ip, t1, frame), - "dialog dialog error 2 yes no cancel"), "\n"})) - b3 = TclTkWidget.new(ip, t1, button, "-text dialog -command", c) - # tk_chooseColor - cb.push(c = TclTkCallback.new(ip, proc{ - print tk_chooseColor.e("-title chooseColor"), "\n"})) - b4 = TclTkWidget.new(ip, t1, button, "-text chooseColor -command", c) - # tk_getOpenFile - cb.push(c = TclTkCallback.new(ip, proc{ - print tk_getOpenFile.e("-defaultextension .rb", - "-filetypes {{{Ruby Script} {.rb}} {{All Files} {*}}}", - "-title getOpenFile"), "\n"})) - b5 = TclTkWidget.new(ip, t1, button, "-text getOpenFile -command", c) - - pack.e(b1, me1, b2, b3, b4, b5) - end - - # menu のサンプル. - def test_menu(ip, parent) - global, menu, menubutton, pack = ip.commands().values_at( - "global", "menu", "menubutton", "pack") - tk_optionMenu = TclTkLibCommand.new(ip, "tk_optionMenu") - t1, b1, cb = inittoplevel(ip, parent, "menu") - - ## menu - - # menubutton を生成する. - mb1 = TclTkWidget.new(ip, t1, menubutton, "-text menu") - # menu を生成する. - me1 = TclTkWidget.new(ip, mb1, menu) - # mb1 から me1 が起動されるようにする. - mb1.e("configure -menu", me1) - - # cascade で起動される menu を生成する. - me11 = TclTkWidget.new(ip, me1, menu) - # radiobutton のサンプル. - v1 = TclTkVariable.new(ip, nil); global.e(v1); v1.set("r1") - me11.e("add radiobutton -label radio1 -value r1 -variable", v1) - me11.e("add radiobutton -label radio2 -value r2 -variable", v1) - me11.e("add radiobutton -label radio3 -value r3 -variable", v1) - # cascade により mb11 が起動されるようにする. - me1.e("add cascade -label cascade -menu", me11) - - # checkbutton のサンプル. - v2 = TclTkVariable.new(ip, nil); global.e(v2); v2.set("none") - me1.e("add checkbutton -label check -variable", v2) - # separator のサンプル. - me1.e("add separator") - # command のサンプル. - v3 = nil - cb.push(c = TclTkCallback.new(ip, proc{ - global.e(v1, v2, v3); print "v1: ", v1.get(), ", v2: ", v2.get(), - ", v3: ", v3.get(), "\n"})) - me1.e("add command -label print -command", c) - - ## tk_optionMenu - - v3 = TclTkVariable.new(ip, nil); global.e(v3); v3.set("opt2") - om1 = TclTkWidget.new(ip, t1, tk_optionMenu, v3, "opt1 opt2 opt3 opt4") - - pack.e(b1, mb1, om1, "-side left") - end - - # listbox のサンプル. - def test_listbox(ip, parent) - clipboard, frame, grid, listbox, lower, menu, menubutton, pack, scrollbar, - selection = ip.commands().values_at( - "clipboard", "frame", "grid", "listbox", "lower", "menu", "menubutton", - "pack", "scrollbar", "selection") - t1, b1, cb = inittoplevel(ip, parent, "listbox") - - ## listbox/scrollbar - - f1 = TclTkWidget.new(ip, t1, frame) - # コールバック内で参照する変数は先に宣言しておかなければならない. - li1 = sc1 = sc2 = nil - # 実行時に, 後ろにパラメータがつくコールバックは, - # イテレータ変数でそのパラメータを受け取ることができる. - # (複数のパラメータはひとつの文字列にまとめられる.) - cb.push(c1 = TclTkCallback.new(ip, proc{|i| li1.e("xview", i)})) - cb.push(c2 = TclTkCallback.new(ip, proc{|i| li1.e("yview", i)})) - cb.push(c3 = TclTkCallback.new(ip, proc{|i| sc1.e("set", i)})) - cb.push(c4 = TclTkCallback.new(ip, proc{|i| sc2.e("set", i)})) - # listbox - li1 = TclTkWidget.new(ip, f1, listbox, - "-xscrollcommand", c3, "-yscrollcommand", c4, - "-selectmode extended -exportselection true") - for i in 1..20 - li1.e("insert end {line #{i} line #{i} line #{i} line #{i} line #{i}}") - end - # scrollbar - sc1 = TclTkWidget.new(ip, f1, scrollbar, "-orient horizontal -command", c1) - sc2 = TclTkWidget.new(ip, f1, scrollbar, "-orient vertical -command", c2) - - ## selection/clipboard - - mb1 = TclTkWidget.new(ip, t1, menubutton, "-text edit") - me1 = TclTkWidget.new(ip, mb1, menu) - mb1.e("configure -menu", me1) - cb.push(c = TclTkCallback.new(ip, proc{ - # clipboard をクリア. - clipboard.e("clear") - # selection から文字列を読み込み clipboard に追加する. - clipboard.e("append {#{selection.e('get')}}")})) - me1.e("add command -label {selection -> clipboard} -command",c) - cb.push(c = TclTkCallback.new(ip, proc{ - # li1 をクリア. - li1.e("delete 0 end") - # clipboard から文字列を取り出し, 1 行ずつ - selection.e("get -selection CLIPBOARD").split(/\n/).each{|line| - # li1 に挿入する. - li1.e("insert end {#{line}}")}})) - me1.e("add command -label {clipboard -> listbox} -command",c) - - grid.e(li1, "-row 0 -column 0 -sticky news") - grid.e(sc1, "-row 1 -column 0 -sticky ew") - grid.e(sc2, "-row 0 -column 1 -sticky ns") - grid.e("rowconfigure", f1, "0 -weight 100") - grid.e("columnconfigure", f1, "0 -weight 100") - f2 = TclTkWidget.new(ip, t1, frame) - lower.e(f2, b1) - pack.e(b1, mb1, "-in", f2, "-side left") - pack.e(f2, f1) - end - - # canvas のサンプル. - def test_canvas(ip, parent) - canvas, lower, pack = ip.commands().values_at("canvas", "lower", "pack") - t1, b1, cb = inittoplevel(ip, parent, "canvas") - - ## canvas - - ca1 = TclTkWidget.new(ip, t1, canvas, "-width 400 -height 300") - lower.e(ca1, b1) - # rectangle を作る. - idr = ca1.e("create rectangle 10 10 20 20") - # oval を作る. - ca1.e("create oval 60 10 100 50") - # polygon を作る. - ca1.e("create polygon 110 10 110 30 140 10") - # line を作る. - ca1.e("create line 150 10 150 30 190 10") - # arc を作る. - ca1.e("create arc 200 10 250 50 -start 0 -extent 90 -style pieslice") - # i1 は本当は, どこかで破壊しなければならないが, 面倒なので放ってある. - i1 = TclTkImage.new(ip, "photo", "-file maru.gif") - # image を作る. - ca1.e("create image 100 100 -image", i1) - # bitmap を作る. - ca1.e("create bitmap 260 50 -bitmap questhead") - # text を作る. - ca1.e("create text 320 50 -text {drag rectangle}") - # window を作る(クローズボタン). - ca1.e("create window 200 200 -window", b1) - - # bind により rectangle を drag できるようにする. - cb.push(c = TclTkCallback.new(ip, proc{|i| - # i に x と y を受け取るので, 取り出す. - x, y = i.split(/ /); x = x.to_f; y = y.to_f - # 座標を変更する. - ca1.e("coords current #{x - 5} #{y - 5} #{x + 5} #{y + 5}")}, - # x, y 座標を空白で区切ったものをイテレータ変数へ渡すように指定. - "%x %y")) - # rectangle に bind する. - ca1.e("bind", idr, "<B1-Motion>", c) - - pack.e(ca1) - end -end - -# test driver - -if ARGV.size == 0 - print "#{$0} n で, n 個のインタプリタを起動します.\n" - n = 1 -else - n = ARGV[0].to_i -end - -print "start\n" -ip = [] - -# インタプリタ, ウィジェット等の生成. -for i in 1 .. n - ip.push(Test1.new()) -end - -# 用意ができたらイベントループに入る. -TclTk.mainloop() -print "exit from mainloop\n" - -# インタプリタが GC されるかのテスト. -ip = [] -print "GC.start\n" if $DEBUG -GC.start() if $DEBUG -print "end\n" - -exit - -# end diff --git a/ext/tcltklib/sample/sample2.rb b/ext/tcltklib/sample/sample2.rb deleted file mode 100644 index 444bb1eef7..0000000000 --- a/ext/tcltklib/sample/sample2.rb +++ /dev/null @@ -1,451 +0,0 @@ -#!/usr/local/bin/ruby -#----------------------> pretty simple othello game <----------------------- -# othello.rb -# -# version 0.3 -# maeda shugo (shuto@po.aianet.ne.jp) -#--------------------------------------------------------------------------- - -# Sep. 17, 1997 modified by Y. Shigehiro for tcltk library -# maeda shugo (shugo@po.aianet.ne.jp) 氏による -# (ruby/tk で書かれていた) ruby のサンプルプログラム -# http://www.aianet.or.jp/~shugo/ruby/othello.rb.gz -# を tcltk ライブラリを使うように, 機械的に変更してみました. -# -# なるべくオリジナルと同じになるようにしてあります. - -require "observer" -require "tcltk" -$ip = TclTkInterpreter.new() -$root = $ip.rootwidget() -$button, $canvas, $checkbutton, $frame, $label, $pack, $update, $wm = - $ip.commands().values_at( - "button", "canvas", "checkbutton", "frame", "label", "pack", "update", "wm") - -class Othello - - EMPTY = 0 - BLACK = 1 - WHITE = - BLACK - - attr :in_com_turn - attr :game_over - - class Board - - include Observable - - DIRECTIONS = [ - [-1, -1], [-1, 0], [-1, 1], - [ 0, -1], [ 0, 1], - [ 1, -1], [ 1, 0], [ 1, 1] - ] - - attr :com_disk, TRUE - - def initialize(othello) - @othello = othello - reset - end - - def notify_observers(*arg) - if @observer_peers != nil - super(*arg) - end - end - - def reset - @data = [ - [EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY], - [EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY], - [EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY], - [EMPTY, EMPTY, EMPTY, WHITE, BLACK, EMPTY, EMPTY, EMPTY], - [EMPTY, EMPTY, EMPTY, BLACK, WHITE, EMPTY, EMPTY, EMPTY], - [EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY], - [EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY], - [EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY] - ] - changed - notify_observers - end - - def man_disk - return - @com_disk - end - - def other_disk(disk) - return - disk - end - - def get_disk(row, col) - return @data[row][col] - end - - def reverse_to(row, col, my_disk, dir_y, dir_x) - y = row - x = col - begin - y += dir_y - x += dir_x - if y < 0 || x < 0 || y > 7 || x > 7 || - @data[y][x] == EMPTY - return - end - end until @data[y][x] == my_disk - begin - @data[y][x] = my_disk - changed - notify_observers(y, x) - y -= dir_y - x -= dir_x - end until y == row && x == col - end - - def put_disk(row, col, disk) - @data[row][col] = disk - changed - notify_observers(row, col) - DIRECTIONS.each do |dir| - reverse_to(row, col, disk, *dir) - end - end - - def count_disk(disk) - num = 0 - @data.each do |rows| - rows.each do |d| - if d == disk - num += 1 - end - end - end - return num - end - - def count_point_to(row, col, my_disk, dir_y, dir_x) - return 0 if @data[row][col] != EMPTY - count = 0 - loop do - row += dir_y - col += dir_x - break if row < 0 || col < 0 || row > 7 || col > 7 - case @data[row][col] - when my_disk - return count - when other_disk(my_disk) - count += 1 - when EMPTY - break - end - end - return 0 - end - - def count_point(row, col, my_disk) - count = 0 - DIRECTIONS.each do |dir| - count += count_point_to(row, col, my_disk, *dir) - end - return count - end - - def corner?(row, col) - return (row == 0 && col == 0) || - (row == 0 && col == 7) || - (row == 7 && col == 0) || - (row == 7 && col == 7) - end - - def search(my_disk) - max = 0 - max_row = nil - max_col = nil - for row in 0 .. 7 - for col in 0 .. 7 - buf = count_point(row, col, my_disk) - if (corner?(row, col) && buf > 0) || max < buf - max = buf - max_row = row - max_col = col - end - end - end - return max_row, max_col - end - end #--------------------------> class Board ends here - - class BoardView < TclTkWidget - - BACK_GROUND_COLOR = "DarkGreen" - HILIT_BG_COLOR = "green" - BORDER_COLOR = "black" - BLACK_COLOR = "black" - WHITE_COLOR = "white" - STOP_COLOR = "red" - - attr :left - attr :top - attr :right - attr :bottom - - class Square - - attr :oval, TRUE - attr :row - attr :col - - def initialize(view, row, col) - @view = view - @id = @view.e("create rectangle", - *(view.tk_rect(view.left + col, - view.top + row, - view.left + col + 1, - view.top + row + 1) \ - << "-fill #{BACK_GROUND_COLOR}") ) - @row = row - @col = col - @view.e("itemconfigure", @id, - "-width 0.5m -outline #{BORDER_COLOR}") - @view.e("bind", @id, "<Any-Enter>", TclTkCallback.new($ip, proc{ - if @oval == nil - view.e("itemconfigure", @id, "-fill #{HILIT_BG_COLOR}") - end - })) - @view.e("bind", @id, "<Any-Leave>", TclTkCallback.new($ip, proc{ - view.e("itemconfigure", @id, "-fill #{BACK_GROUND_COLOR}") - })) - @view.e("bind", @id, "<ButtonRelease-1>", TclTkCallback.new($ip, - proc{ - view.click_square(self) - })) - end - - def blink(color) - @view.e("itemconfigure", @id, "-fill #{color}") - $update.e() - sleep(0.1) - @view.e("itemconfigure", @id, "-fill #{BACK_GROUND_COLOR}") - end - end #-----------------------> class Square ends here - - def initialize(othello, board) - super($ip, $root, $canvas) - @othello = othello - @board = board - @board.add_observer(self) - - @squares = Array.new(8) - for i in 0 .. 7 - @squares[i] = Array.new(8) - end - @left = 1 - @top = 0.5 - @right = @left + 8 - @bottom = @top + 8 - - i = self.e("create rectangle", *tk_rect(@left, @top, @right, @bottom)) - self.e("itemconfigure", i, - "-width 1m -outline #{BORDER_COLOR} -fill #{BACK_GROUND_COLOR}") - - for row in 0 .. 7 - for col in 0 .. 7 - @squares[row][col] = Square.new(self, row, col) - end - end - - update - end - - def tk_rect(left, top, right, bottom) - return left.to_s + "c", top.to_s + "c", - right.to_s + "c", bottom.to_s + "c" - end - - def clear - each_square do |square| - if square.oval != nil - self.e("delete", square.oval) - square.oval = nil - end - end - end - - def draw_disk(row, col, disk) - if disk == EMPTY - if @squares[row][col].oval != nil - self.e("delete", @squares[row][col].oval) - @squares[row][col].oval = nil - end - return - end - - $update.e() - sleep(0.05) - oval = @squares[row][col].oval - if oval == nil - oval = self.e("create oval", *tk_rect(@left + col + 0.2, - @top + row + 0.2, - @left + col + 0.8, - @top + row + 0.8)) - @squares[row][col].oval = oval - end - case disk - when BLACK - color = BLACK_COLOR - when WHITE - color = WHITE_COLOR - else - fail format("Unknown disk type: %d", disk) - end - self.e("itemconfigure", oval, "-outline #{color} -fill #{color}") - end - - def update(row = nil, col = nil) - if row && col - draw_disk(row, col, @board.get_disk(row, col)) - else - each_square do |square| - draw_disk(square.row, square.col, - @board.get_disk(square.row, square.col)) - end - end - @othello.show_point - end - - def each_square - @squares.each do |rows| - rows.each do |square| - yield(square) - end - end - end - - def click_square(square) - if @othello.in_com_turn || @othello.game_over || - @board.count_point(square.row, - square.col, - @board.man_disk) == 0 - square.blink(STOP_COLOR) - return - end - @board.put_disk(square.row, square.col, @board.man_disk) - @othello.com_turn - end - - private :draw_disk - public :update - end #----------------------> class BoardView ends here - - def initialize - @msg_label = TclTkWidget.new($ip, $root, $label) - $pack.e(@msg_label) - - @board = Board.new(self) - @board_view = BoardView.new(self, @board) - #### added by Y. Shigehiro - ## board_view の大きさを設定する. - x1, y1, x2, y2 = @board_view.e("bbox all").split(/ /).collect{|i| i.to_f} - @board_view.e("configure -width", x2 - x1) - @board_view.e("configure -height", y2 - y1) - ## scrollregion を設定する. - @board_view.e("configure -scrollregion {", @board_view.e("bbox all"), - "}") - #### ここまで - $pack.e(@board_view, "-fill both -expand true") - - panel = TclTkWidget.new($ip, $root, $frame) - - @play_black = TclTkWidget.new($ip, panel, $checkbutton, - "-text {com is black} -command", TclTkCallback.new($ip, proc{ - switch_side - })) - $pack.e(@play_black, "-side left") - - quit = TclTkWidget.new($ip, panel, $button, "-text Quit -command", - TclTkCallback.new($ip, proc{ - exit - })) - $pack.e(quit, "-side right -fill x") - - reset = TclTkWidget.new($ip, panel, $button, "-text Reset -command", - TclTkCallback.new($ip, proc{ - reset_game - })) - $pack.e(reset, "-side right -fill x") - - $pack.e(panel, "-side bottom -fill x") - -# root = Tk.root - $wm.e("title", $root, "Othello") - $wm.e("iconname", $root, "Othello") - - @board.com_disk = WHITE - @game_over = FALSE - - TclTk.mainloop - end - - def switch_side - if @in_com_turn - @play_black.e("toggle") - else - @board.com_disk = @board.man_disk - com_turn unless @game_over - end - end - - def reset_game - if @board.com_disk == BLACK - @board.com_disk = WHITE - @play_black.e("toggle") - end - @board_view.clear - @board.reset - $wm.e("title", $root, "Othello") - @game_over = FALSE - end - - def com_turn - @in_com_turn = TRUE - $update.e() - sleep(0.5) - begin - com_disk = @board.count_disk(@board.com_disk) - man_disk = @board.count_disk(@board.man_disk) - if @board.count_disk(EMPTY) == 0 - if man_disk == com_disk - $wm.e("title", $root, "{Othello - Draw!}") - elsif man_disk > com_disk - $wm.e("title", $root, "{Othello - You Win!}") - else - $wm.e("title", $root, "{Othello - You Loose!}") - end - @game_over = TRUE - break - elsif com_disk == 0 - $wm.e("title", $root, "{Othello - You Win!}") - @game_over = TRUE - break - elsif man_disk == 0 - $wm.e("title", $root, "{Othello - You Loose!}") - @game_over = TRUE - break - end - row, col = @board.search(@board.com_disk) - break if row == nil || col == nil - @board.put_disk(row, col, @board.com_disk) - end while @board.search(@board.man_disk) == [nil, nil] - @in_com_turn = FALSE - end - - def show_point - black = @board.count_disk(BLACK) - white = @board.count_disk(WHITE) - @msg_label.e("configure -text", - %Q/{#{format("BLACK: %.2d WHITE: %.2d", black, white)}}/) - end -end #----------------------> class Othello ends here - -Othello.new - -#----------------------------------------------> othello.rb ends here diff --git a/ext/tcltklib/stubs.c b/ext/tcltklib/stubs.c deleted file mode 100644 index 050333cf63..0000000000 --- a/ext/tcltklib/stubs.c +++ /dev/null @@ -1,507 +0,0 @@ -#include "stubs.h" -#include "ruby.h" -#include <tcl.h> -#include <tk.h> - -/*------------------------------*/ - -#ifdef __MACOS__ -# include <tkMac.h> -# include <Quickdraw.h> - -static int call_macinit = 0; - -static void -_macinit() -{ - if (!call_macinit) { - tcl_macQdPtr = &qd; /* setup QuickDraw globals */ - Tcl_MacSetEventProc(TkMacConvertEvent); /* setup event handler */ - call_macinit = 1; - } -} -#endif - -/*------------------------------*/ - -static int nativethread_checked = 0; - -static void -_nativethread_consistency_check(ip) - Tcl_Interp *ip; -{ - if (nativethread_checked || ip == (Tcl_Interp *)NULL) { - return; - } - - if (Tcl_Eval(ip, "set ::tcl_platform(threaded)") == TCL_OK) { -#ifdef HAVE_NATIVETHREAD - /* consistent */ -#else - rb_warn("Inconsistency. Loaded Tcl/Tk libraries are enabled nativethread-support. But `tcltklib' is not. The inconsistency causes SEGV or other troubles frequently."); -#endif - } else { -#ifdef HAVE_NATIVETHREAD - rb_warning("Inconsistency.`tcltklib' is enabled nativethread-support. But loaded Tcl/Tk libraries are not. (Probably, the inconsistency doesn't cause any troubles.)"); -#else - /* consistent */ -#endif - } - - Tcl_ResetResult(ip); - - nativethread_checked = 1; -} - -/*------------------------------*/ - -#if defined USE_TCL_STUBS && defined USE_TK_STUBS - -#if defined _WIN32 || defined __CYGWIN__ -# include "util.h" -# include <windows.h> - typedef HINSTANCE DL_HANDLE; -# define DL_OPEN LoadLibrary -# define DL_SYM GetProcAddress -# define TCL_INDEX 4 -# define TK_INDEX 3 -# define TCL_NAME "tcl89%s" -# define TK_NAME "tk89%s" -# undef DLEXT -# define DLEXT ".dll" -#elif defined HAVE_DLOPEN -# include <dlfcn.h> - typedef void *DL_HANDLE; -# define DL_OPEN(file) dlopen(file, RTLD_LAZY|RTLD_GLOBAL) -# define DL_SYM dlsym -# define TCL_INDEX 8 -# define TK_INDEX 7 -# define TCL_NAME "libtcl8.9%s" -# define TK_NAME "libtk8.9%s" -#endif - -static DL_HANDLE tcl_dll = (DL_HANDLE)0; -static DL_HANDLE tk_dll = (DL_HANDLE)0; - -int -ruby_open_tcl_dll(appname) - char *appname; -{ - void (*p_Tcl_FindExecutable)(const char *); - int n; - char *ruby_tcl_dll = 0; - char tcl_name[20]; - - if (tcl_dll) return TCLTK_STUBS_OK; - - ruby_tcl_dll = getenv("RUBY_TCL_DLL"); -#if defined _WIN32 - if (ruby_tcl_dll) ruby_tcl_dll = ruby_strdup(ruby_tcl_dll); -#endif - if (ruby_tcl_dll) { - tcl_dll = (DL_HANDLE)DL_OPEN(ruby_tcl_dll); - } else { - snprintf(tcl_name, sizeof tcl_name, TCL_NAME, DLEXT); - /* examine from 8.9 to 8.1 */ - for (n = '9'; n > '0'; n--) { - tcl_name[TCL_INDEX] = n; - tcl_dll = (DL_HANDLE)DL_OPEN(tcl_name); - if (tcl_dll) - break; - } - } - -#if defined _WIN32 - if (ruby_tcl_dll) ruby_xfree(ruby_tcl_dll); -#endif - - if (!tcl_dll) - return NO_TCL_DLL; - - p_Tcl_FindExecutable = (void (*)(const char *))DL_SYM(tcl_dll, "Tcl_FindExecutable"); - if (!p_Tcl_FindExecutable) - return NO_FindExecutable; - - if (appname) { - p_Tcl_FindExecutable(appname); - } else { - p_Tcl_FindExecutable("ruby"); - } - - return TCLTK_STUBS_OK; -} - -int -ruby_open_tk_dll() -{ - int n; - char *ruby_tk_dll = 0; - char tk_name[20]; - - if (!tcl_dll) { - int ret = ruby_open_tcl_dll(RSTRING(rb_argv0)->ptr); - if (ret != TCLTK_STUBS_OK) return ret; - } - - if (tk_dll) return TCLTK_STUBS_OK; - - ruby_tk_dll = getenv("RUBY_TK_DLL"); - if (ruby_tk_dll) { - tk_dll = (DL_HANDLE)DL_OPEN(ruby_tk_dll); - } else { - snprintf(tk_name, sizeof tk_name, TK_NAME, DLEXT); - /* examine from 8.9 to 8.1 */ - for (n = '9'; n > '0'; n--) { - tk_name[TK_INDEX] = n; - tk_dll = (DL_HANDLE)DL_OPEN(tk_name); - if (tk_dll) - break; - } - } - - if (!tk_dll) - return NO_TK_DLL; - - return TCLTK_STUBS_OK; -} - -int -ruby_open_tcltk_dll(appname) - char *appname; -{ - return( ruby_open_tcl_dll(appname) || ruby_open_tk_dll() ); -} - -int -tcl_stubs_init_p() -{ - return(tclStubsPtr != (TclStubs*)NULL); -} - -int -tk_stubs_init_p() -{ - return(tkStubsPtr != (TkStubs*)NULL); -} - - -Tcl_Interp * -ruby_tcl_create_ip_and_stubs_init(st) - int *st; -{ - Tcl_Interp *tcl_ip; - - if (st) *st = 0; - - if (tcl_stubs_init_p()) { - tcl_ip = Tcl_CreateInterp(); - - if (!tcl_ip) { - if (st) *st = FAIL_CreateInterp; - return (Tcl_Interp*)NULL; - } - - _nativethread_consistency_check(tcl_ip); - - return tcl_ip; - - } else { - Tcl_Interp *(*p_Tcl_CreateInterp)(); - Tcl_Interp *(*p_Tcl_DeleteInterp)(); - - if (!tcl_dll) { - int ret = ruby_open_tcl_dll(RSTRING(rb_argv0)->ptr); - if (ret != TCLTK_STUBS_OK) { - if (st) *st = ret; - return (Tcl_Interp*)NULL; - } - } - - p_Tcl_CreateInterp - = (Tcl_Interp *(*)())DL_SYM(tcl_dll, "Tcl_CreateInterp"); - if (!p_Tcl_CreateInterp) { - if (st) *st = NO_CreateInterp; - return (Tcl_Interp*)NULL; - } - - p_Tcl_DeleteInterp - = (Tcl_Interp *(*)())DL_SYM(tcl_dll, "Tcl_DeleteInterp"); - if (!p_Tcl_DeleteInterp) { - if (st) *st = NO_DeleteInterp; - return (Tcl_Interp*)NULL; - } - - tcl_ip = (*p_Tcl_CreateInterp)(); - if (!tcl_ip) { - if (st) *st = FAIL_CreateInterp; - return (Tcl_Interp*)NULL; - } - - _nativethread_consistency_check(tcl_ip); - - if (!Tcl_InitStubs(tcl_ip, "8.1", 0)) { - if (st) *st = FAIL_Tcl_InitStubs; - (*p_Tcl_DeleteInterp)(tcl_ip); - return (Tcl_Interp*)NULL; - } - - return tcl_ip; - } -} - -int -ruby_tcl_stubs_init() -{ - int st; - Tcl_Interp *tcl_ip; - - if (!tcl_stubs_init_p()) { - tcl_ip = ruby_tcl_create_ip_and_stubs_init(&st); - - if (!tcl_ip) return st; - - Tcl_DeleteInterp(tcl_ip); - } - - return TCLTK_STUBS_OK; -} - -int -ruby_tk_stubs_init(tcl_ip) - Tcl_Interp *tcl_ip; -{ - Tcl_ResetResult(tcl_ip); - - if (tk_stubs_init_p()) { - if (Tk_Init(tcl_ip) == TCL_ERROR) { - return FAIL_Tk_Init; - } - } else { - int (*p_Tk_Init)(Tcl_Interp *); - - if (!tk_dll) { - int ret = ruby_open_tk_dll(); - if (ret != TCLTK_STUBS_OK) return ret; - } - - p_Tk_Init = (int (*)(Tcl_Interp *))DL_SYM(tk_dll, "Tk_Init"); - if (!p_Tk_Init) - return NO_Tk_Init; - - if ((*p_Tk_Init)(tcl_ip) == TCL_ERROR) - return FAIL_Tk_Init; - - if (!Tk_InitStubs(tcl_ip, "8.1", 0)) - return FAIL_Tk_InitStubs; - -#ifdef __MACOS__ - _macinit(); -#endif - } - - return TCLTK_STUBS_OK; -} - -int -ruby_tk_stubs_safeinit(tcl_ip) - Tcl_Interp *tcl_ip; -{ - Tcl_ResetResult(tcl_ip); - - if (tk_stubs_init_p()) { - if (Tk_SafeInit(tcl_ip) == TCL_ERROR) - return FAIL_Tk_Init; - } else { - int (*p_Tk_SafeInit)(Tcl_Interp *); - - if (!tk_dll) { - int ret = ruby_open_tk_dll(); - if (ret != TCLTK_STUBS_OK) return ret; - } - - p_Tk_SafeInit = (int (*)(Tcl_Interp *))DL_SYM(tk_dll, "Tk_SafeInit"); - if (!p_Tk_SafeInit) - return NO_Tk_Init; - - if ((*p_Tk_SafeInit)(tcl_ip) == TCL_ERROR) - return FAIL_Tk_Init; - - if (!Tk_InitStubs(tcl_ip, "8.1", 0)) - return FAIL_Tk_InitStubs; - -#ifdef __MACOS__ - _macinit(); -#endif - } - - return TCLTK_STUBS_OK; -} - -int -ruby_tcltk_stubs() -{ - int st; - Tcl_Interp *tcl_ip; - - st = ruby_open_tcltk_dll(RSTRING(rb_argv0)->ptr); - switch(st) { - case NO_FindExecutable: - return -7; - case NO_TCL_DLL: - case NO_TK_DLL: - return -1; - } - - tcl_ip = ruby_tcl_create_ip_and_stubs_init(&st); - if (!tcl_ip) { - switch(st) { - case NO_CreateInterp: - case NO_DeleteInterp: - return -2; - case FAIL_CreateInterp: - return -3; - case FAIL_Tcl_InitStubs: - return -5; - } - } - - st = ruby_tk_stubs_init(tcl_ip); - switch(st) { - case NO_Tk_Init: - Tcl_DeleteInterp(tcl_ip); - return -4; - case FAIL_Tk_Init: - case FAIL_Tk_InitStubs: - Tcl_DeleteInterp(tcl_ip); - return -6; - } - - Tcl_DeleteInterp(tcl_ip); - - return 0; -} - -/*###################################################*/ -#else /* ! USE_TCL_STUBS || ! USE_TK_STUBS) */ -/*###################################################*/ - -static int open_tcl_dll = 0; -static int call_tk_stubs_init = 0; - -int -ruby_open_tcl_dll(appname) - char *appname; -{ - if (appname) { - Tcl_FindExecutable(appname); - } else { - Tcl_FindExecutable("ruby"); - } - open_tcl_dll = 1; - - return TCLTK_STUBS_OK; -} - -int ruby_open_tk_dll() -{ - if (!open_tcl_dll) { - ruby_open_tcl_dll(RSTRING(rb_argv0)->ptr); - } - - return TCLTK_STUBS_OK; -} - -int ruby_open_tcltk_dll(appname) - char *appname; -{ - return( ruby_open_tcl_dll(appname) || ruby_open_tk_dll() ); -} - -int -tcl_stubs_init_p() -{ - return 1; -} - -int -tk_stubs_init_p() -{ - return call_tk_stubs_init; -} - -Tcl_Interp * -ruby_tcl_create_ip_and_stubs_init(st) - int *st; -{ - Tcl_Interp *tcl_ip; - - if (!open_tcl_dll) { - ruby_open_tcl_dll(RSTRING(rb_argv0)->ptr); - } - - if (st) *st = 0; - tcl_ip = Tcl_CreateInterp(); - if (!tcl_ip) { - if (st) *st = FAIL_CreateInterp; - return (Tcl_Interp*)NULL; - } - - _nativethread_consistency_check(tcl_ip); - - return tcl_ip; -} - -int -ruby_tcl_stubs_init() -{ - return TCLTK_STUBS_OK; -} - -int -ruby_tk_stubs_init(tcl_ip) - Tcl_Interp *tcl_ip; -{ - if (Tk_Init(tcl_ip) == TCL_ERROR) - return FAIL_Tk_Init; - - if (!call_tk_stubs_init) { -#ifdef __MACOS__ - _macinit(); -#endif - call_tk_stubs_init = 1; - } - - return TCLTK_STUBS_OK; -} - -int -ruby_tk_stubs_safeinit(tcl_ip) - Tcl_Interp *tcl_ip; -{ -#if TCL_MAJOR_VERSION >= 8 - if (Tk_SafeInit(tcl_ip) == TCL_ERROR) - return FAIL_Tk_Init; - - if (!call_tk_stubs_init) { -#ifdef __MACOS__ - _macinit(); -#endif - call_tk_stubs_init = 1; - } - - return TCLTK_STUBS_OK; - -#else /* TCL_MAJOR_VERSION < 8 */ - - return FAIL_Tk_Init; -#endif -} - -int -ruby_tcltk_stubs() -{ - Tcl_FindExecutable(RSTRING(rb_argv0)->ptr); - return 0; -} - -#endif diff --git a/ext/tcltklib/stubs.h b/ext/tcltklib/stubs.h deleted file mode 100644 index 7c913fb393..0000000000 --- a/ext/tcltklib/stubs.h +++ /dev/null @@ -1,33 +0,0 @@ -#include <tcl.h> - -extern int ruby_open_tcl_dll(char *); -extern int ruby_open_tk_dll(); -extern int ruby_open_tcltk_dll(char *); -extern int tcl_stubs_init_p(); -extern int tk_stubs_init_p(); -extern Tcl_Interp *ruby_tcl_create_ip_and_stubs_init(int*); -extern int ruby_tcl_stubs_init(); -extern int ruby_tk_stubs_init(Tcl_Interp*); -extern int ruby_tk_stubs_safeinit(Tcl_Interp*); -extern int ruby_tcltk_stubs(); - -/* no error */ -#define TCLTK_STUBS_OK (0) - -/* return value of ruby_open_tcl_dll() */ -#define NO_TCL_DLL (1) -#define NO_FindExecutable (2) - -/* return value of ruby_open_tk_dll() */ -#define NO_TK_DLL (-1) - -/* status value of ruby_tcl_create_ip_and_stubs_init(st) */ -#define NO_CreateInterp (3) -#define NO_DeleteInterp (4) -#define FAIL_CreateInterp (5) -#define FAIL_Tcl_InitStubs (6) - -/* return value of ruby_tk_stubs_init() */ -#define NO_Tk_Init (7) -#define FAIL_Tk_Init (8) -#define FAIL_Tk_InitStubs (9) diff --git a/ext/tcltklib/tcltklib.c b/ext/tcltklib/tcltklib.c deleted file mode 100644 index 131dcd3993..0000000000 --- a/ext/tcltklib/tcltklib.c +++ /dev/null @@ -1,7860 +0,0 @@ -/* - * tcltklib.c - * Aug. 27, 1997 Y. Shigehiro - * Oct. 24, 1997 Y. Matsumoto - */ - -#define TCLTKLIB_RELEASE_DATE "2005-11-02" - -#include "ruby.h" -#include "rubysig.h" -#include "version.h" -#undef EXTERN /* avoid conflict with tcl.h of tcl8.2 or before */ -#include <stdio.h> -#ifdef HAVE_STDARG_PROTOTYPES -#include <stdarg.h> -#define va_init_list(a,b) va_start(a,b) -#else -#include <varargs.h> -#define va_init_list(a,b) va_start(a) -#endif -#include <string.h> -#include <tcl.h> -#include <tk.h> - -#include "stubs.h" - -#ifndef TCL_ALPHA_RELEASE -#define TCL_ALPHA_RELEASE 0 -#define TCL_BETA_RELEASE 1 -#define TCL_FINAL_RELEASE 2 -#endif - -#if TCL_MAJOR_VERSION >= 8 -# ifndef CONST84 -# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 4 /* Tcl8.0.x -- 8.4b1 */ -# define CONST84 -# else /* unknown (maybe TCL_VERSION >= 8.5) */ -# ifdef CONST -# define CONST84 CONST -# else -# define CONST84 -# endif -# endif -# endif -#else /* TCL_MAJOR_VERSION < 8 */ -# ifdef CONST -# define CONST84 CONST -# else -# define CONST -# define CONST84 -# endif -#endif - -/* copied from eval.c */ -#define TAG_RETURN 0x1 -#define TAG_BREAK 0x2 -#define TAG_NEXT 0x3 -#define TAG_RETRY 0x4 -#define TAG_REDO 0x5 -#define TAG_RAISE 0x6 -#define TAG_THROW 0x7 -#define TAG_FATAL 0x8 - -/* for ruby_debug */ -#define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1); fflush(stderr); } -#define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\ -fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); fflush(stderr); } -#define DUMP3(ARG1, ARG2, ARG3) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\ -fprintf(stderr, ARG1, ARG2, ARG3); fprintf(stderr, "\n"); fflush(stderr); } -/* -#define DUMP1(ARG1) -#define DUMP2(ARG1, ARG2) -#define DUMP3(ARG1, ARG2, ARG3) -*/ - -/* release date */ -const char tcltklib_release_date[] = TCLTKLIB_RELEASE_DATE; - -/* finalize_proc_name */ -static char *finalize_hook_name = "INTERP_FINALIZE_HOOK"; - -static void ip_finalize _((Tcl_Interp*)); - - -/* for callback break & continue */ -static VALUE eTkCallbackReturn; -static VALUE eTkCallbackBreak; -static VALUE eTkCallbackContinue; - -static VALUE eLocalJumpError; - -static VALUE eTkLocalJumpError; -static VALUE eTkCallbackRetry; -static VALUE eTkCallbackRedo; -static VALUE eTkCallbackThrow; - -static ID ID_at_enc; -static ID ID_at_interp; - -static ID ID_stop_p; -static ID ID_alive_p; -static ID ID_kill; -static ID ID_join; -static ID ID_value; - -static ID ID_call; -static ID ID_backtrace; -static ID ID_message; - -static ID ID_at_reason; -static ID ID_return; -static ID ID_break; -static ID ID_next; - -static ID ID_to_s; -static ID ID_inspect; - -static VALUE ip_invoke_real _((int, VALUE*, VALUE)); -static VALUE ip_invoke _((int, VALUE*, VALUE)); - -static VALUE tk_funcall _((VALUE(), int, VALUE*, VALUE)); - -/* safe Tcl_Eval and Tcl_GlobalEval */ -static int -tcl_eval(interp, cmd) - Tcl_Interp *interp; - const char *cmd; /* don't have to be writable */ -{ - char *buf = strdup(cmd); - const int ret = Tcl_Eval(interp, buf); - free(buf); - return ret; -} - -#undef Tcl_Eval -#define Tcl_Eval tcl_eval - -static int -tcl_global_eval(interp, cmd) - Tcl_Interp *interp; - const char *cmd; /* don't have to be writable */ -{ - char *buf = strdup(cmd); - const int ret = Tcl_GlobalEval(interp, buf); - free(buf); - return ret; -} - -#undef Tcl_GlobalEval -#define Tcl_GlobalEval tcl_global_eval - -/* Tcl_{Incr|Decr}RefCount for tcl7.x or earlier */ -#if TCL_MAJOR_VERSION < 8 -#define Tcl_IncrRefCount(obj) (1) -#define Tcl_DecrRefCount(obj) (1) -#endif - -/* Tcl_GetStringResult for tcl7.x or earlier */ -#if TCL_MAJOR_VERSION < 8 -#define Tcl_GetStringResult(interp) ((interp)->result) -#endif - -/* Tcl_[GS]etVar2Ex for tcl8.0 */ -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 -static Tcl_Obj * -Tcl_GetVar2Ex(interp, name1, name2, flags) - Tcl_Interp *interp; - CONST char *name1; - CONST char *name2; - int flags; -{ - Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj; - - nameObj1 = Tcl_NewStringObj((char*)name1, -1); - Tcl_IncrRefCount(nameObj1); - - if (name2) { - nameObj2 = Tcl_NewStringObj((char*)name2, -1); - Tcl_IncrRefCount(nameObj2); - } - - retObj = Tcl_ObjGetVar2(interp, nameObj1, nameObj2, flags); - - if (name2) { - Tcl_DecrRefCount(nameObj2); - } - - Tcl_DecrRefCount(nameObj1); - - return retObj; -} - -static Tcl_Obj * -Tcl_SetVar2Ex(interp, name1, name2, newValObj, flags) - Tcl_Interp *interp; - CONST char *name1; - CONST char *name2; - Tcl_Obj *newValObj; - int flags; -{ - Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj; - - nameObj1 = Tcl_NewStringObj((char*)name1, -1); - Tcl_IncrRefCount(nameObj1); - - if (name2) { - nameObj2 = Tcl_NewStringObj((char*)name2, -1); - Tcl_IncrRefCount(nameObj2); - } - - retObj = Tcl_ObjSetVar2(interp, nameObj1, nameObj2, newValObj, flags); - - if (name2) { - Tcl_DecrRefCount(nameObj2); - } - - Tcl_DecrRefCount(nameObj1); - - return retObj; -} -#endif - -/* from tkAppInit.c */ - -#if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 4) -# if !defined __MINGW32__ && !defined __BORLANDC__ -/* - * The following variable is a special hack that is needed in order for - * Sun shared libraries to be used for Tcl. - */ - -extern int matherr(); -int *tclDummyMathPtr = (int *) matherr; -# endif -#endif - -/*---- module TclTkLib ----*/ - -struct invoke_queue { - Tcl_Event ev; - int argc; -#if TCL_MAJOR_VERSION >= 8 - Tcl_Obj **argv; -#else /* TCL_MAJOR_VERSION < 8 */ - char **argv; -#endif - VALUE interp; - int *done; - int safe_level; - VALUE result; - VALUE thread; -}; - -struct eval_queue { - Tcl_Event ev; - char *str; - int len; - VALUE interp; - int *done; - int safe_level; - VALUE result; - VALUE thread; -}; - -struct call_queue { - Tcl_Event ev; - VALUE (*func)(); - int argc; - VALUE *argv; - VALUE interp; - int *done; - int safe_level; - VALUE result; - VALUE thread; -}; - -void -invoke_queue_mark(struct invoke_queue *q) -{ - rb_gc_mark(q->interp); - rb_gc_mark(q->result); - rb_gc_mark(q->thread); -} - -void -eval_queue_mark(struct eval_queue *q) -{ - rb_gc_mark(q->interp); - rb_gc_mark(q->result); - rb_gc_mark(q->thread); -} - -void -call_queue_mark(struct call_queue *q) -{ - int i; - - for(i = 0; i < q->argc; i++) { - rb_gc_mark(q->argv[i]); - } - - rb_gc_mark(q->interp); - rb_gc_mark(q->result); - rb_gc_mark(q->thread); -} - - -static VALUE eventloop_thread; -static VALUE eventloop_stack; - -static VALUE watchdog_thread; - -Tcl_Interp *current_interp; - - -/* - * 'event_loop_max' is a maximum events which the eventloop processes in one - * term of thread scheduling. 'no_event_tick' is the count-up value when - * there are no event for processing. - * 'timer_tick' is a limit of one term of thread scheduling. - * If 'timer_tick' == 0, then not use the timer for thread scheduling. - */ -#define DEFAULT_EVENT_LOOP_MAX 800/*counts*/ -#define DEFAULT_NO_EVENT_TICK 10/*counts*/ -#define DEFAULT_NO_EVENT_WAIT 20/*milliseconds ( 1 -- 999 ) */ -#define WATCHDOG_INTERVAL 10/*milliseconds ( 1 -- 999 ) */ -#define DEFAULT_TIMER_TICK 0/*milliseconds ( 0 -- 999 ) */ -#define NO_THREAD_INTERRUPT_TIME 100/*milliseconds ( 1 -- 999 ) */ - -static int event_loop_max = DEFAULT_EVENT_LOOP_MAX; -static int no_event_tick = DEFAULT_NO_EVENT_TICK; -static int no_event_wait = DEFAULT_NO_EVENT_WAIT; -static int timer_tick = DEFAULT_TIMER_TICK; -static int req_timer_tick = DEFAULT_TIMER_TICK; -static int run_timer_flag = 0; - -static int event_loop_wait_event = 0; -static int event_loop_abort_on_exc = 1; -static int loop_counter = 0; - -static int check_rootwidget_flag = 0; - - -/* call ruby interpreter */ -#if TCL_MAJOR_VERSION >= 8 -static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*)); -static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*)); -#else /* TCL_MAJOR_VERSION < 8 */ -static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, char **)); -static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, char **)); -#endif - -struct cmd_body_arg { - VALUE receiver; - ID method; - VALUE args; -}; - - -/*----------------------------*/ -/* use Tcl internal functions */ -/*----------------------------*/ -#ifndef TCL_NAMESPACE_DEBUG -#define TCL_NAMESPACE_DEBUG 0 -#endif - -#if TCL_NAMESPACE_DEBUG - -#if TCL_MAJOR_VERSION >= 8 -EXTERN struct TclIntStubs *tclIntStubsPtr; -#endif - -/*-- Tcl_GetCurrentNamespace --*/ -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5 -/* Tcl7.x doesn't have namespace support. */ -/* Tcl8.5+ has definition of Tcl_GetCurrentNamespace() in tclDecls.h */ -# ifndef Tcl_GetCurrentNamespace -EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace _((Tcl_Interp *)); -# endif -# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) -# ifndef Tcl_GetCurrentNamespace -# ifndef FunctionNum_of_GetCurrentNamespace -#define FunctionNum_of_GetCurrentNamespace 124 -# endif -struct DummyTclIntStubs_for_GetCurrentNamespace { - int magic; - struct TclIntStubHooks *hooks; - void (*func[FunctionNum_of_GetCurrentNamespace])(); - Tcl_Namespace * (*tcl_GetCurrentNamespace) _((Tcl_Interp *)); -}; - -#define Tcl_GetCurrentNamespace \ - (((struct DummyTclIntStubs_for_GetCurrentNamespace *)tclIntStubsPtr)->tcl_GetCurrentNamespace) -# endif -# endif -#endif - -/* namespace check */ -/* ip_null_namespace(Tcl_Interp *interp) */ -#if TCL_MAJOR_VERSION < 8 -#define ip_null_namespace(interp) (0) -#else /* support namespace */ -#define ip_null_namespace(interp) \ - (Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL) -#endif - -/* rbtk_invalid_namespace(tcltkip *ptr) */ -#if TCL_MAJOR_VERSION < 8 -#define rbtk_invalid_namespace(ptr) (0) -#else /* support namespace */ -#define rbtk_invalid_namespace(ptr) \ - ((ptr)->default_ns == (Tcl_Namespace*)NULL || Tcl_GetCurrentNamespace((ptr)->ip) != (ptr)->default_ns) -#endif - -/*-- Tcl_PopCallFrame & Tcl_PushCallFrame --*/ -#if TCL_MAJOR_VERSION >= 8 -# ifndef CallFrame -typedef struct CallFrame { - Tcl_Namespace *nsPtr; - int dummy1; - int dummy2; - char *dummy3; - struct CallFrame *callerPtr; - struct CallFrame *callerVarPtr; - int level; - char *dummy7; - char *dummy8; - int dummy9; - char* dummy10; -} CallFrame; -# endif - -# if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED) -EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **)); -# endif -# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) -# ifndef TclGetFrame -# ifndef FunctionNum_of_GetFrame -#define FunctionNum_of_GetFrame 32 -# endif -struct DummyTclIntStubs_for_GetFrame { - int magic; - struct TclIntStubHooks *hooks; - void (*func[FunctionNum_of_GetFrame])(); - int (*tclGetFrame) _((Tcl_Interp *, CONST char *, CallFrame **)); -}; -#define TclGetFrame \ - (((struct DummyTclIntStubs_for_GetFrame *)tclIntStubsPtr)->tclGetFrame) -# endif -# endif - -# if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED) -EXTERN void Tcl_PopCallFrame _((Tcl_Interp *)); -EXTERN int Tcl_PushCallFrame _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int)); -# endif -# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) -# ifndef Tcl_PopCallFrame -# ifndef FunctionNum_of_PopCallFrame -#define FunctionNum_of_PopCallFrame 128 -# endif -struct DummyTclIntStubs_for_PopCallFrame { - int magic; - struct TclIntStubHooks *hooks; - void (*func[FunctionNum_of_PopCallFrame])(); - void (*tcl_PopCallFrame) _((Tcl_Interp *)); - int (*tcl_PushCallFrame) _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int)); -}; - -#define Tcl_PopCallFrame \ - (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PopCallFrame) -#define Tcl_PushCallFrame \ - (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PushCallFrame) -# endif -# endif - -#else /* Tcl7.x */ -# ifndef CallFrame -typedef struct CallFrame { - Tcl_HashTable varTable; - int level; - int argc; - char **argv; - struct CallFrame *callerPtr; - struct CallFrame *callerVarPtr; -} CallFrame; -# endif -# ifndef Tcl_CallFrame -#define Tcl_CallFrame CallFrame -# endif - -# if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED) -EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **)); -# endif - -# if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED) -typedef struct DummyInterp { - char *dummy1; - char *dummy2; - int dummy3; - Tcl_HashTable dummy4; - Tcl_HashTable dummy5; - Tcl_HashTable dummy6; - int numLevels; - int maxNestingDepth; - CallFrame *framePtr; - CallFrame *varFramePtr; -} DummyInterp; - -static void -Tcl_PopCallFrame(interp) - Tcl_Interp *interp; -{ - DummyInterp *iPtr = (DummyInterp*)interp; - CallFrame *frame = iPtr->varFramePtr; - - /* **** DUMMY **** */ - iPtr->framePtr = frame.callerPtr; - iPtr->varFramePtr = frame.callerVarPtr; - - return TCL_OK; -} - -/* dummy */ -#define Tcl_Namespace char - -static int -Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame) - Tcl_Interp *interp; - Tcl_CallFrame *framePtr; - Tcl_Namespace *nsPtr; - int isProcCallFrame; -{ - DummyInterp *iPtr = (DummyInterp*)interp; - CallFrame *frame = (CallFrame *)framePtr; - - /* **** DUMMY **** */ - Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS); - if (iPtr->varFramePtr != NULL) { - frame.level = iPtr->varFramePtr->level + 1; - } else { - frame.level = 1; - } - frame.callerPtr = iPtr->framePtr; - frame.callerVarPtr = iPtr->varFramePtr; - iPtr->framePtr = &frame; - iPtr->varFramePtr = &frame; - - return TCL_OK; -} -# endif - -#endif - -#endif /* TCL_NAMESPACE_DEBUG */ - - -/*---- class TclTkIp ----*/ -struct tcltkip { - Tcl_Interp *ip; /* the interpreter */ -#if TCL_NAMESPACE_DEBUG - Tcl_Namespace *default_ns; /* default namespace */ -#endif - int has_orig_exit; /* has original 'exit' command ? */ - Tcl_CmdInfo orig_exit_info; /* command info of original 'exit' command */ - int ref_count; /* reference count of rbtk_preserve_ip call */ - int allow_ruby_exit; /* allow exiting ruby by 'exit' function */ - int return_value; /* return value */ -}; - -static struct tcltkip * -get_ip(self) - VALUE self; -{ - struct tcltkip *ptr; - - Data_Get_Struct(self, struct tcltkip, ptr); - if (ptr == 0) { - /* rb_raise(rb_eTypeError, "uninitialized TclTkIp"); */ - return((struct tcltkip *)NULL); - } - if (ptr->ip == (Tcl_Interp*)NULL) { - /* rb_raise(rb_eRuntimeError, "deleted IP"); */ - return((struct tcltkip *)NULL); - } - return ptr; -} - -static int -deleted_ip(ptr) - struct tcltkip *ptr; -{ - if (!ptr || !ptr->ip || Tcl_InterpDeleted(ptr->ip) -#if TCL_NAMESPACE_DEBUG - || rbtk_invalid_namespace(ptr) -#endif - ) { - DUMP1("ip is deleted"); - return Qtrue; - } - return Qfalse; -} - -/* increment/decrement reference count of tcltkip */ -static int -rbtk_preserve_ip(ptr) - struct tcltkip *ptr; -{ - ptr->ref_count++; - if (ptr->ip == (Tcl_Interp*)NULL) { - /* deleted IP */ - ptr->ref_count = 0; - } else { - Tcl_Preserve((ClientData)ptr->ip); - } - return(ptr->ref_count); -} - -static int -rbtk_release_ip(ptr) - struct tcltkip *ptr; -{ - ptr->ref_count--; - if (ptr->ref_count < 0) { - ptr->ref_count = 0; - } else if (ptr->ip == (Tcl_Interp*)NULL) { - /* deleted IP */ - ptr->ref_count = 0; - } else { - Tcl_Release((ClientData)ptr->ip); - } - return(ptr->ref_count); -} - - -static VALUE -#ifdef HAVE_STDARG_PROTOTYPES -create_ip_exc(VALUE interp, VALUE exc, const char *fmt, ...) -#else -create_ip_exc(interp, exc, fmt, va_alist) - VALUE interp: - VALUE exc; - const char *fmt; - va_dcl -#endif -{ - va_list args; - char buf[BUFSIZ]; - VALUE einfo; - struct tcltkip *ptr = get_ip(interp); - - 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); - if (ptr) { - Tcl_ResetResult(ptr->ip); - } - - return einfo; -} - - -/* stub status */ -static void -tcl_stubs_check() -{ - if (!tcl_stubs_init_p()) { - int st = ruby_tcl_stubs_init(); - switch(st) { - case TCLTK_STUBS_OK: - break; - case NO_TCL_DLL: - rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll"); - case NO_FindExecutable: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable"); - case NO_CreateInterp: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()"); - case NO_DeleteInterp: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()"); - case FAIL_CreateInterp: - rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP to call Tcl_InitStubs()"); - case FAIL_Tcl_InitStubs: - rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()"); - default: - rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_stubs_init()", st); - } - } -} - - -static VALUE -tcltkip_init_tk(interp) - VALUE interp; -{ - struct tcltkip *ptr = get_ip(interp); - -#if TCL_MAJOR_VERSION >= 8 - int st; - - if (Tcl_IsSafe(ptr->ip)) { - DUMP1("Tk_SafeInit"); - st = ruby_tk_stubs_safeinit(ptr->ip); - switch(st) { - case TCLTK_STUBS_OK: - break; - case NO_Tk_Init: - return rb_exc_new2(rb_eLoadError, - "tcltklib: can't find Tk_SafeInit()"); - case FAIL_Tk_Init: - return create_ip_exc(interp, rb_eRuntimeError, - "tcltklib: fail to Tk_SafeInit(). %s", - Tcl_GetStringResult(ptr->ip)); - case FAIL_Tk_InitStubs: - return create_ip_exc(interp, rb_eRuntimeError, - "tcltklib: fail to Tk_InitStubs(). %s", - Tcl_GetStringResult(ptr->ip)); - default: - return create_ip_exc(interp, rb_eRuntimeError, - "tcltklib: unknown error(%d) on ruby_tk_stubs_safeinit", st); - } - } else { - DUMP1("Tk_Init"); - st = ruby_tk_stubs_init(ptr->ip); - switch(st) { - case TCLTK_STUBS_OK: - break; - case NO_Tk_Init: - return rb_exc_new2(rb_eLoadError, - "tcltklib: can't find Tk_Init()"); - case FAIL_Tk_Init: - return create_ip_exc(interp, rb_eRuntimeError, - "tcltklib: fail to Tk_Init(). %s", - Tcl_GetStringResult(ptr->ip)); - case FAIL_Tk_InitStubs: - return create_ip_exc(interp, rb_eRuntimeError, - "tcltklib: fail to Tk_InitStubs(). %s", - Tcl_GetStringResult(ptr->ip)); - default: - return create_ip_exc(interp, rb_eRuntimeError, - "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st); - } - } - -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tk_Init"); - if (ruby_tk_stubs_init(ptr->ip) != TCLTK_STUBS_OK) { - return rb_exc_new2(rb_eRuntimeError, ptr->ip->result); - } -#endif - - return Qnil; -} - - -/* treat excetiopn on Tcl side */ -static VALUE rbtk_pending_exception; -static int rbtk_eventloop_depth = 0; - - -static int -pending_exception_check0() -{ - volatile VALUE exc = rbtk_pending_exception; - - if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) { - DUMP1("find a pending exception"); - if (rbtk_eventloop_depth > 0) { - return 1; /* pending */ - } else { - rbtk_pending_exception = Qnil; - - if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) { - DUMP1("pending_exception_check0: call rb_jump_tag(retry)"); - rb_jump_tag(TAG_RETRY); - } else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) { - DUMP1("pending_exception_check0: call rb_jump_tag(redo)"); - rb_jump_tag(TAG_REDO); - } else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) { - DUMP1("pending_exception_check0: call rb_jump_tag(throw)"); - rb_jump_tag(TAG_THROW); - } - - rb_exc_raise(exc); - } - } else { - return 0; - } -} - -static int -pending_exception_check1(thr_crit_bup, ptr) - int thr_crit_bup; - struct tcltkip *ptr; -{ - volatile VALUE exc = rbtk_pending_exception; - - if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) { - DUMP1("find a pending exception"); - - if (rbtk_eventloop_depth > 0) { - return 1; /* pending */ - } else { - rbtk_pending_exception = Qnil; - - if (ptr != (struct tcltkip *)NULL) { - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - } - - rb_thread_critical = thr_crit_bup; - - if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) { - DUMP1("pending_exception_check1: call rb_jump_tag(retry)"); - rb_jump_tag(TAG_RETRY); - } else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) { - DUMP1("pending_exception_check1: call rb_jump_tag(redo)"); - rb_jump_tag(TAG_REDO); - } else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) { - DUMP1("pending_exception_check1: call rb_jump_tag(throw)"); - rb_jump_tag(TAG_THROW); - } - rb_exc_raise(exc); - } - } else { - return 0; - } -} - - -/* call original 'exit' command */ -static void -call_original_exit(ptr, state) - struct tcltkip *ptr; - int state; -{ - int thr_crit_bup; - Tcl_CmdInfo *info; -#if TCL_MAJOR_VERSION >= 8 - Tcl_Obj *state_obj; -#endif - - if (!(ptr->has_orig_exit)) return; - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - Tcl_ResetResult(ptr->ip); - - info = &(ptr->orig_exit_info); - - /* memory allocation for arguments of this command */ -#if TCL_MAJOR_VERSION >= 8 - state_obj = Tcl_NewIntObj(state); - Tcl_IncrRefCount(state_obj); - - if (info->isNativeObjectProc) { - Tcl_Obj **argv; - argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3); - argv[0] = Tcl_NewStringObj("exit", 4); - argv[1] = state_obj; - argv[2] = (Tcl_Obj *)NULL; - - ptr->return_value - = (*(info->objProc))(info->objClientData, ptr->ip, 2, argv); - - free(argv); - - } else { - /* string interface */ - char **argv; - argv = (char **)ALLOC_N(char *, 3); - argv[0] = "exit"; - /* argv[1] = Tcl_GetString(state_obj); */ - argv[1] = Tcl_GetStringFromObj(state_obj, (int*)NULL); - argv[2] = (char *)NULL; - - ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, - 2, (CONST84 char **)argv); - - free(argv); - } - - Tcl_DecrRefCount(state_obj); - -#else /* TCL_MAJOR_VERSION < 8 */ - { - /* string interface */ - char **argv; - argv = (char **)ALLOC_N(char *, 3); - argv[0] = "exit"; - argv[1] = RSTRING(rb_fix2str(INT2NUM(state), 10))->ptr; - argv[2] = (char *)NULL; - - ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, - 2, argv); - - free(argv); - } -#endif - - rb_thread_critical = thr_crit_bup; -} - -/* Tk_ThreadTimer */ -static Tcl_TimerToken timer_token = (Tcl_TimerToken)NULL; - -/* timer callback */ -static void _timer_for_tcl _((ClientData)); -static void -_timer_for_tcl(clientData) - ClientData clientData; -{ - int thr_crit_bup; - - /* struct invoke_queue *q, *tmp; */ - /* VALUE thread; */ - - DUMP1("call _timer_for_tcl"); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - Tcl_DeleteTimerHandler(timer_token); - - run_timer_flag = 1; - - if (timer_tick > 0) { - timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl, - (ClientData)0); - } else { - timer_token = (Tcl_TimerToken)NULL; - } - - rb_thread_critical = thr_crit_bup; - - /* rb_thread_schedule(); */ - /* tick_counter += event_loop_max; */ -} - -static VALUE -set_eventloop_tick(self, tick) - VALUE self; - VALUE tick; -{ - int ttick = NUM2INT(tick); - int thr_crit_bup; - - rb_secure(4); - - if (ttick < 0) { - rb_raise(rb_eArgError, - "timer-tick parameter must be 0 or positive number"); - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* delete old timer callback */ - Tcl_DeleteTimerHandler(timer_token); - - timer_tick = req_timer_tick = ttick; - if (timer_tick > 0) { - /* start timer callback */ - timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl, - (ClientData)0); - } else { - timer_token = (Tcl_TimerToken)NULL; - } - - rb_thread_critical = thr_crit_bup; - - return tick; -} - -static VALUE -get_eventloop_tick(self) - VALUE self; -{ - return INT2NUM(timer_tick); -} - -static VALUE -ip_set_eventloop_tick(self, tick) - VALUE self; - VALUE tick; -{ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return get_eventloop_tick(self); - } - - if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { - /* slave IP */ - return get_eventloop_tick(self); - } - return set_eventloop_tick(self, tick); -} - -static VALUE -ip_get_eventloop_tick(self) - VALUE self; -{ - return get_eventloop_tick(self); -} - -static VALUE -set_no_event_wait(self, wait) - VALUE self; - VALUE wait; -{ - int t_wait = NUM2INT(wait); - - rb_secure(4); - - if (t_wait <= 0) { - rb_raise(rb_eArgError, - "no_event_wait parameter must be positive number"); - } - - no_event_wait = t_wait; - - return wait; -} - -static VALUE -get_no_event_wait(self) - VALUE self; -{ - return INT2NUM(no_event_wait); -} - -static VALUE -ip_set_no_event_wait(self, wait) - VALUE self; - VALUE wait; -{ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return get_no_event_wait(self); - } - - if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { - /* slave IP */ - return get_no_event_wait(self); - } - return set_no_event_wait(self, wait); -} - -static VALUE -ip_get_no_event_wait(self) - VALUE self; -{ - return get_no_event_wait(self); -} - -static VALUE -set_eventloop_weight(self, loop_max, no_event) - VALUE self; - VALUE loop_max; - VALUE no_event; -{ - int lpmax = NUM2INT(loop_max); - int no_ev = NUM2INT(no_event); - - rb_secure(4); - - if (lpmax <= 0 || no_ev <= 0) { - rb_raise(rb_eArgError, "weight parameters must be positive numbers"); - } - - event_loop_max = lpmax; - no_event_tick = no_ev; - - return rb_ary_new3(2, loop_max, no_event); -} - -static VALUE -get_eventloop_weight(self) - VALUE self; -{ - return rb_ary_new3(2, INT2NUM(event_loop_max), INT2NUM(no_event_tick)); -} - -static VALUE -ip_set_eventloop_weight(self, loop_max, no_event) - VALUE self; - VALUE loop_max; - VALUE no_event; -{ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return get_eventloop_weight(self); - } - - if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { - /* slave IP */ - return get_eventloop_weight(self); - } - return set_eventloop_weight(self, loop_max, no_event); -} - -static VALUE -ip_get_eventloop_weight(self) - VALUE self; -{ - return get_eventloop_weight(self); -} - -static VALUE -set_max_block_time(self, time) - VALUE self; - VALUE time; -{ - struct Tcl_Time tcl_time; - VALUE divmod; - - switch(TYPE(time)) { - case T_FIXNUM: - case T_BIGNUM: - /* time is micro-second value */ - divmod = rb_funcall(time, rb_intern("divmod"), 1, LONG2NUM(1000000)); - tcl_time.sec = NUM2LONG(RARRAY(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_thread_p(self) - VALUE self; -{ - if (NIL_P(eventloop_thread)) { - return Qnil; /* no eventloop */ - } else if (rb_thread_current() == eventloop_thread) { - return Qtrue; /* is eventloop */ - } else { - return Qfalse; /* not eventloop */ - } -} - -static VALUE -lib_evloop_abort_on_exc(self) - VALUE self; -{ - if (event_loop_abort_on_exc > 0) { - return Qtrue; - } else if (event_loop_abort_on_exc == 0) { - return Qfalse; - } else { - return Qnil; - } -} - -static VALUE -ip_evloop_abort_on_exc(self) - VALUE self; -{ - return lib_evloop_abort_on_exc(self); -} - -static VALUE -lib_evloop_abort_on_exc_set(self, val) - VALUE self, val; -{ - rb_secure(4); - if (RTEST(val)) { - event_loop_abort_on_exc = 1; - } else if (NIL_P(val)) { - event_loop_abort_on_exc = -1; - } else { - event_loop_abort_on_exc = 0; - } - return lib_evloop_abort_on_exc(self); -} - -static VALUE -ip_evloop_abort_on_exc_set(self, val) - VALUE self, val; -{ - struct tcltkip *ptr = get_ip(self); - - rb_secure(4); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return lib_evloop_abort_on_exc(self); - } - - if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { - /* slave IP */ - return lib_evloop_abort_on_exc(self); - } - return lib_evloop_abort_on_exc_set(self, val); -} - -static VALUE -lib_num_of_mainwindows(self) - VALUE self; -{ - if (tk_stubs_init_p()) { - return INT2FIX(Tk_GetNumMainWindows()); - } else { - return INT2FIX(0); - } -} - - -static VALUE -call_DoOneEvent(flag_val) - VALUE flag_val; -{ - int flag; - - flag = FIX2INT(flag_val); - if (Tcl_DoOneEvent(flag)) { - return Qtrue; - } else { - return Qfalse; - } -} - -static VALUE -eventloop_sleep(dummy) - VALUE dummy; -{ - struct timeval t; - - t.tv_sec = (time_t)0; - t.tv_usec = (time_t)(no_event_wait*1000.0); - -#ifdef HAVE_NATIVETHREAD - if (!is_ruby_native_thread()) { - rb_bug("cross-thread violation on eventloop_sleep()"); - } -#endif - - rb_thread_wait_for(t); - -#ifdef HAVE_NATIVETHREAD - if (!is_ruby_native_thread()) { - rb_bug("cross-thread violation on eventloop_sleep()"); - } -#endif - - return Qnil; -} - - -static int -lib_eventloop_core(check_root, update_flag, check_var) - int check_root; - int update_flag; - int *check_var; -{ - volatile VALUE current = eventloop_thread; - int found_event = 1; - int event_flag; - struct timeval t; - int thr_crit_bup; - int status; - int depth = rbtk_eventloop_depth; - - - if (update_flag) DUMP1("update loop start!!"); - - t.tv_sec = (time_t)0; - t.tv_usec = (time_t)(no_event_wait*1000.0); - - Tcl_DeleteTimerHandler(timer_token); - run_timer_flag = 0; - if (timer_tick > 0) { - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl, - (ClientData)0); - rb_thread_critical = thr_crit_bup; - } else { - timer_token = (Tcl_TimerToken)NULL; - } - - for(;;) { - if (rb_thread_alone()) { - DUMP1("no other thread"); - event_loop_wait_event = 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 = Tcl_CreateTimerHandler(timer_tick, - _timer_for_tcl, - (ClientData)0); - } - - if (check_var != (int *)NULL) { - if (*check_var || !found_event) { - return found_event; - } - } - - /* found_event = Tcl_DoOneEvent(event_flag); */ - found_event = RTEST(rb_protect(call_DoOneEvent, - INT2FIX(event_flag), &status)); - if (status) { - switch (status) { - case TAG_RAISE: - if (NIL_P(ruby_errinfo)) { - rbtk_pending_exception - = rb_exc_new2(rb_eException, "unknown exception"); - } else { - rbtk_pending_exception = ruby_errinfo; - - if (!NIL_P(rbtk_pending_exception)) { - if (rbtk_eventloop_depth == 0) { - VALUE exc = rbtk_pending_exception; - rbtk_pending_exception = Qnil; - rb_exc_raise(exc); - } else { - return 0; - } - } - } - break; - - case TAG_FATAL: - if (NIL_P(ruby_errinfo)) { - rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL")); - } else { - rb_exc_raise(ruby_errinfo); - } - } - } - - if (depth != rbtk_eventloop_depth) { - DUMP2("DoOneEvent(1) abnormal exit!! %d", - rbtk_eventloop_depth); - } - - if (check_var != (int*)NULL && !NIL_P(rbtk_pending_exception)) { - DUMP1("exception on wait"); - return 0; - } - - if (pending_exception_check0()) { - /* pending -> upper level */ - return 0; - } - - if (update_flag != 0) { - if (found_event) { - DUMP1("next update loop"); - continue; - } else { - DUMP1("update complete"); - return 0; - } - } - - DUMP1("trap check"); - if (rb_trap_pending) { - run_timer_flag = 0; - if (rb_prohibit_interrupt || check_var != (int*)NULL) { - /* pending or on wait command */ - return 0; - } else { - rb_trap_exec(); - } - } - - DUMP1("check Root Widget"); - if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) { - run_timer_flag = 0; - if (rb_trap_pending) { - if (rb_prohibit_interrupt || check_var != (int*)NULL) { - /* pending or on wait command */ - return 0; - } else { - rb_trap_exec(); - } - } - return 1; - } - - if (loop_counter++ > 30000) { - /* fprintf(stderr, "loop_counter > 30000\n"); */ - loop_counter = 0; - } - - } else { - int tick_counter; - - DUMP1("there are other threads"); - event_loop_wait_event = 1; - - found_event = 1; - - if (update_flag) { - event_flag = update_flag | 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) { - if (check_var != (int *)NULL) { - if (*check_var || !found_event) { - return found_event; - } - } - - if (NIL_P(eventloop_thread) || current == eventloop_thread) { - int st; - int status; - - /* st = Tcl_DoOneEvent(event_flag); */ - st = RTEST(rb_protect(call_DoOneEvent, - INT2FIX(event_flag), &status)); - if (status) { - switch (status) { - case TAG_RAISE: - if (NIL_P(ruby_errinfo)) { - rbtk_pending_exception - = rb_exc_new2(rb_eException, - "unknown exception"); - } else { - rbtk_pending_exception = ruby_errinfo; - - if (!NIL_P(rbtk_pending_exception)) { - if (rbtk_eventloop_depth == 0) { - VALUE exc = rbtk_pending_exception; - rbtk_pending_exception = Qnil; - rb_exc_raise(exc); - } else { - return 0; - } - } - } - break; - - case TAG_FATAL: - if (NIL_P(ruby_errinfo)) { - rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL")); - } else { - rb_exc_raise(ruby_errinfo); - } - } - } - - if (depth != rbtk_eventloop_depth) { - DUMP2("DoOneEvent(2) abnormal exit!! %d", - rbtk_eventloop_depth); - return 0; - } - - DUMP1("trap check"); - if (rb_trap_pending) { - run_timer_flag = 0; - if (rb_prohibit_interrupt || check_var != (int*)NULL) { - /* pending or on wait command */ - return 0; - } else { - rb_trap_exec(); - } - } - - if (check_var != (int*)NULL - && !NIL_P(rbtk_pending_exception)) { - DUMP1("exception on wait"); - return 0; - } - - if (pending_exception_check0()) { - /* pending -> upper level */ - return 0; - } - - if (st) { - tick_counter++; - } else { - if (update_flag != 0) { - DUMP1("update complete"); - return 0; - } - - tick_counter += no_event_tick; - - /* rb_thread_wait_for(t); */ - rb_protect(eventloop_sleep, Qnil, &status); - - if (status) { - switch (status) { - case TAG_RAISE: - if (NIL_P(ruby_errinfo)) { - rbtk_pending_exception - = rb_exc_new2(rb_eException, - "unknown exception"); - } else { - rbtk_pending_exception = ruby_errinfo; - - if (!NIL_P(rbtk_pending_exception)) { - if (rbtk_eventloop_depth == 0) { - VALUE exc = rbtk_pending_exception; - rbtk_pending_exception = Qnil; - rb_exc_raise(exc); - } else { - return 0; - } - } - } - break; - - case TAG_FATAL: - if (NIL_P(ruby_errinfo)) { - rb_exc_raise(rb_exc_new2(rb_eFatal, - "FATAL")); - } else { - rb_exc_raise(ruby_errinfo); - } - } - } - } - - } else { - DUMP2("sleep eventloop %lx", current); - DUMP2("eventloop thread is %lx", eventloop_thread); - rb_thread_stop(); - } - - if (!NIL_P(watchdog_thread) && eventloop_thread != current) { - return 1; - } - - DUMP1("trap check"); - if (rb_trap_pending) { - run_timer_flag = 0; - if (rb_prohibit_interrupt || check_var != (int*)NULL) { - /* pending or on wait command */ - return 0; - } else { - rb_trap_exec(); - } - } - - DUMP1("check Root Widget"); - if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) { - run_timer_flag = 0; - if (rb_trap_pending) { - if (rb_prohibit_interrupt || check_var != (int*)NULL) { - /* pending or on wait command */ - return 0; - } else { - rb_trap_exec(); - } - } - return 1; - } - - if (loop_counter++ > 30000) { - /* fprintf(stderr, "loop_counter > 30000\n"); */ - loop_counter = 0; - } - - if (run_timer_flag) { - /* - DUMP1("timer interrupt"); - run_timer_flag = 0; - */ - break; /* switch to other thread */ - } - } - } - - DUMP1("trap check & thread scheduling"); - if (update_flag == 0) CHECK_INTS; - - } - return 1; -} - - -struct evloop_params { - int check_root; - int update_flag; - int *check_var; -}; - -VALUE -lib_eventloop_main_core(args) - VALUE args; -{ - struct evloop_params *params = (struct evloop_params *)args; - - check_rootwidget_flag = params->check_root; - - if (lib_eventloop_core(params->check_root, - params->update_flag, - params->check_var)) { - return Qtrue; - } else { - return Qfalse; - } -} - -VALUE -lib_eventloop_main(args) - VALUE args; -{ - volatile VALUE ret; - int status = 0; - - /* ret = rb_protect(lib_eventloop_main_core, args, &status); */ - ret = lib_eventloop_main_core(args); - - switch (status) { - case TAG_RAISE: - if (NIL_P(ruby_errinfo)) { - rbtk_pending_exception - = rb_exc_new2(rb_eException, "unknown exception"); - } else { - rbtk_pending_exception = ruby_errinfo; - } - return Qnil; - - case TAG_FATAL: - if (NIL_P(ruby_errinfo)) { - rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL"); - } else { - rbtk_pending_exception = ruby_errinfo; - } - return Qnil; - } - - return ret; -} - -VALUE -lib_eventloop_ensure(args) - VALUE args; -{ - struct evloop_params *ptr = (struct evloop_params *)args; - volatile VALUE current_evloop = rb_thread_current(); - - DUMP2("eventloop_ensure: current-thread : %lx", current_evloop); - DUMP2("eventloop_ensure: eventloop-thread : %lx", eventloop_thread); - if (eventloop_thread != current_evloop) { - DUMP2("finish eventloop %lx (NOT current eventloop)", current_evloop); - return Qnil; - } - - while(eventloop_thread = rb_ary_pop(eventloop_stack)) { - DUMP2("eventloop-ensure: new eventloop-thread -> %lx", - eventloop_thread); - - if (eventloop_thread == current_evloop) { - rbtk_eventloop_depth--; - DUMP2("eventloop %lx : back from recursive call", current_evloop); - break; - } - - if (NIL_P(eventloop_thread)) { - Tcl_DeleteTimerHandler(timer_token); - timer_token = (Tcl_TimerToken)NULL; - - break; - } - - if (RTEST(rb_funcall(eventloop_thread, ID_alive_p, 0, 0))) { - DUMP2("eventloop-enshure: wake up parent %lx", eventloop_thread); - rb_thread_wakeup(eventloop_thread); - - break; - } - } - - free(ptr); - - DUMP2("finish current eventloop %lx", current_evloop); - return Qnil; -} - -static VALUE -lib_eventloop_launcher(check_root, update_flag, check_var) - int check_root; - int update_flag; - int *check_var; -{ - volatile VALUE parent_evloop = eventloop_thread; - int depth = rbtk_eventloop_depth; - struct evloop_params *args = ALLOC(struct evloop_params); - - tcl_stubs_check(); - - eventloop_thread = rb_thread_current(); - - if (parent_evloop == eventloop_thread) { - DUMP2("eventloop: recursive call on %lx", parent_evloop); - rbtk_eventloop_depth++; - } - - if (!NIL_P(parent_evloop) && parent_evloop != eventloop_thread) { - DUMP2("wait for stop of parent_evloop %lx", parent_evloop); - while(!RTEST(rb_funcall(parent_evloop, ID_stop_p, 0))) { - DUMP2("parent_evloop %lx doesn't stop", parent_evloop); - rb_thread_run(parent_evloop); - } - DUMP1("succeed to stop parent"); - } - - rb_ary_push(eventloop_stack, parent_evloop); - - DUMP3("tcltklib: eventloop-thread : %lx -> %lx\n", - parent_evloop, eventloop_thread); - - args->check_root = check_root; - args->update_flag = update_flag; - args->check_var = check_var; - - return rb_ensure(lib_eventloop_main, (VALUE)args, - lib_eventloop_ensure, (VALUE)args); -} - -/* execute Tk_MainLoop */ -static VALUE -lib_mainloop(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - VALUE check_rootwidget; - - if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) { - check_rootwidget = Qtrue; - } else if (RTEST(check_rootwidget)) { - check_rootwidget = Qtrue; - } else { - check_rootwidget = Qfalse; - } - - return lib_eventloop_launcher(RTEST(check_rootwidget), 0, (int*)NULL); -} - -static VALUE -ip_mainloop(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return Qnil; - } - - if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { - /* slave IP */ - return Qnil; - } - return lib_mainloop(argc, argv, self); -} - - -static VALUE -watchdog_evloop_launcher(check_rootwidget) - VALUE check_rootwidget; -{ - return lib_eventloop_launcher(RTEST(check_rootwidget), 0, (int*)NULL); -} - -#define EVLOOP_WAKEUP_CHANCE 3 - -static VALUE -lib_watchdog_core(check_rootwidget) - VALUE check_rootwidget; -{ - VALUE evloop; - int prev_val = -1; - int chance = 0; - int check = RTEST(check_rootwidget); - struct timeval t0, t1; - - t0.tv_sec = (time_t)0; - t0.tv_usec = (time_t)((NO_THREAD_INTERRUPT_TIME)*1000.0); - t1.tv_sec = (time_t)0; - t1.tv_usec = (time_t)((WATCHDOG_INTERVAL)*1000.0); - - /* check other watchdog thread */ - if (!NIL_P(watchdog_thread)) { - if (RTEST(rb_funcall(watchdog_thread, ID_stop_p, 0))) { - rb_funcall(watchdog_thread, ID_kill, 0); - } else { - return Qnil; - } - } - watchdog_thread = rb_thread_current(); - - /* watchdog start */ - do { - if (NIL_P(eventloop_thread) - || (loop_counter == prev_val && chance >= EVLOOP_WAKEUP_CHANCE)) { - /* start new eventloop thread */ - DUMP2("eventloop thread %lx is sleeping or dead", - eventloop_thread); - evloop = rb_thread_create(watchdog_evloop_launcher, - (void*)&check_rootwidget); - DUMP2("create new eventloop thread %lx", evloop); - loop_counter = -1; - chance = 0; - rb_thread_run(evloop); - } else { - prev_val = loop_counter; - if (RTEST(rb_funcall(eventloop_thread, ID_stop_p, 0))) { - ++chance; - } else { - chance = 0; - } - if (event_loop_wait_event) { - rb_thread_wait_for(t0); - } else { - rb_thread_wait_for(t1); - } - /* rb_thread_schedule(); */ - } - } while(!check || !tk_stubs_init_p() || Tk_GetNumMainWindows() != 0); - - return Qnil; -} - -VALUE -lib_watchdog_ensure(arg) - VALUE arg; -{ - eventloop_thread = Qnil; /* stop eventloops */ - return Qnil; -} - -static VALUE -lib_mainloop_watchdog(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - VALUE check_rootwidget; - - if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) { - check_rootwidget = Qtrue; - } else if (RTEST(check_rootwidget)) { - check_rootwidget = Qtrue; - } else { - check_rootwidget = Qfalse; - } - - return rb_ensure(lib_watchdog_core, check_rootwidget, - lib_watchdog_ensure, Qnil); -} - -static VALUE -ip_mainloop_watchdog(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return Qnil; - } - - if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { - /* slave IP */ - return Qnil; - } - return lib_mainloop_watchdog(argc, argv, self); -} - - -/* thread-safe(?) interaction between Ruby and Tk */ -struct thread_call_proc_arg { - VALUE proc; - int *done; -}; - -void -_thread_call_proc_arg_mark(struct thread_call_proc_arg *q) -{ - rb_gc_mark(q->proc); -} - -static VALUE -_thread_call_proc_core(arg) - VALUE arg; -{ - struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg; - return rb_funcall(q->proc, ID_call, 0); -} - -static VALUE -_thread_call_proc_ensure(arg) - VALUE arg; -{ - struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg; - *(q->done) = 1; - return Qnil; -} - -static VALUE -_thread_call_proc(arg) - VALUE arg; -{ - struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg; - - return rb_ensure(_thread_call_proc_core, (VALUE)q, - _thread_call_proc_ensure, (VALUE)q); -} - -static VALUE -_thread_call_proc_value(th) - VALUE th; -{ - return rb_funcall(th, ID_value, 0); -} - -static VALUE -lib_thread_callback(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - struct thread_call_proc_arg *q; - VALUE proc, th, ret; - int status, foundEvent; - - if (rb_scan_args(argc, argv, "01", &proc) == 0) { - proc = rb_block_proc(); - } - - q = (struct thread_call_proc_arg *)ALLOC(struct thread_call_proc_arg); - q->proc = proc; - q->done = (int*)ALLOC(int); - *(q->done) = 0; - - /* create call-proc thread */ - th = rb_thread_create(_thread_call_proc, (void*)q); - - rb_thread_schedule(); - - /* start sub-eventloop */ - foundEvent = lib_eventloop_launcher(/* not check root-widget */0, 0, - q->done); - - if (RTEST(rb_funcall(th, ID_alive_p, 0))) { - rb_funcall(th, ID_kill, 0); - ret = Qnil; - } else { - ret = rb_protect(_thread_call_proc_value, th, &status); - } - - free(q->done); - free(q); - - if (NIL_P(rbtk_pending_exception)) { - /* return ruby_errinfo; */ - if (status) { - rb_exc_raise(ruby_errinfo); - } - } else { - VALUE exc = rbtk_pending_exception; - rbtk_pending_exception = Qnil; - /* return exc; */ - rb_exc_raise(exc); - } - - return ret; -} - - -/* do_one_event */ -static VALUE -lib_do_one_event_core(argc, argv, self, is_ip) - int argc; - VALUE *argv; - VALUE self; - int is_ip; -{ - volatile VALUE vflags; - int flags; - int found_event; - - if (!NIL_P(eventloop_thread)) { - rb_raise(rb_eRuntimeError, "eventloop is already running"); - } - - tcl_stubs_check(); - - if (rb_scan_args(argc, argv, "01", &vflags) == 0) { - flags = TCL_ALL_EVENTS | TCL_DONT_WAIT; - } else { - Check_Type(vflags, T_FIXNUM); - flags = FIX2INT(vflags); - } - - if (rb_safe_level() >= 4 || (rb_safe_level() >=1 && OBJ_TAINTED(vflags))) { - flags |= TCL_DONT_WAIT; - } - - if (is_ip) { - /* check IP */ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return Qfalse; - } - - if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { - /* slave IP */ - flags |= TCL_DONT_WAIT; - } - } - - /* found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); */ - found_event = Tcl_DoOneEvent(flags); - - if (pending_exception_check0()) { - return Qfalse; - } - - if (found_event) { - return Qtrue; - } else { - return Qfalse; - } -} - -static VALUE -lib_do_one_event(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - return lib_do_one_event_core(argc, argv, self, 0); -} - -static VALUE -ip_do_one_event(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - return lib_do_one_event_core(argc, argv, self, 0); -} - - -static void -ip_set_exc_message(interp, exc) - Tcl_Interp *interp; - VALUE exc; -{ - char *buf; - Tcl_DString dstr; - volatile VALUE msg; - int thr_crit_bup; - -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) - volatile VALUE enc; - Tcl_Encoding encoding; -#endif - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - msg = rb_funcall(exc, ID_message, 0, 0); - -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) - enc = rb_attr_get(exc, ID_at_enc); - if (NIL_P(enc)) { - enc = rb_attr_get(msg, ID_at_enc); - } - if (NIL_P(enc)) { - encoding = (Tcl_Encoding)NULL; - } else if (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); - memcpy(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)); - Tcl_DStringFree(&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); -} - -static int -tcl_protect_core(interp, proc, data) /* should not raise exception */ - Tcl_Interp *interp; - VALUE (*proc)(); - VALUE data; -{ - volatile VALUE ret, exc = Qnil; - int status = 0; - int thr_crit_bup = rb_thread_critical; - - rb_thread_critical = Qfalse; - ret = rb_protect(proc, data, &status); - rb_thread_critical = Qtrue; - if (status) { - char *buf; - VALUE old_gc, type, str; - - old_gc = rb_gc_disable(); - - switch(status) { - case TAG_RETURN: - type = eTkCallbackReturn; - goto error; - case TAG_BREAK: - type = eTkCallbackBreak; - goto error; - case TAG_NEXT: - type = eTkCallbackContinue; - goto error; - error: - str = rb_str_new2("LocalJumpError: "); - rb_str_append(str, rb_obj_as_string(ruby_errinfo)); - exc = rb_exc_new3(type, str); - break; - - case TAG_RETRY: - if (NIL_P(ruby_errinfo)) { - DUMP1("rb_protect: retry"); - exc = rb_exc_new2(eTkCallbackRetry, "retry jump error"); - } else { - exc = ruby_errinfo; - } - break; - - case TAG_REDO: - if (NIL_P(ruby_errinfo)) { - DUMP1("rb_protect: redo"); - exc = rb_exc_new2(eTkCallbackRedo, "redo jump error"); - } else { - exc = ruby_errinfo; - } - break; - - case TAG_RAISE: - if (NIL_P(ruby_errinfo)) { - exc = rb_exc_new2(rb_eException, "unknown exception"); - } else { - exc = ruby_errinfo; - } - break; - - case TAG_FATAL: - if (NIL_P(ruby_errinfo)) { - exc = rb_exc_new2(rb_eFatal, "FATAL"); - } else { - exc = ruby_errinfo; - } - break; - - case TAG_THROW: - if (NIL_P(ruby_errinfo)) { - DUMP1("rb_protect: throw"); - exc = rb_exc_new2(eTkCallbackThrow, "throw jump error"); - } else { - exc = ruby_errinfo; - } - break; - - default: - buf = ALLOC_N(char, 256); - sprintf(buf, "unknown loncaljmp status %d", status); - exc = rb_exc_new2(rb_eException, buf); - free(buf); - break; - } - - if (old_gc == Qfalse) rb_gc_enable(); - - ret = Qnil; - } - - rb_thread_critical = thr_crit_bup; - - Tcl_ResetResult(interp); - - /* status check */ - if (!NIL_P(exc)) { - volatile VALUE eclass = rb_obj_class(exc); - volatile VALUE backtrace; - - DUMP1("(failed)"); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - DUMP1("set backtrace"); - if (!NIL_P(backtrace = rb_funcall(exc, ID_backtrace, 0, 0))) { - backtrace = rb_ary_join(backtrace, rb_str_new2("\n")); - Tcl_AddErrorInfo(interp, StringValuePtr(backtrace)); - } - - rb_thread_critical = thr_crit_bup; - - ip_set_exc_message(interp, exc); - - if (eclass == eTkCallbackReturn) - return TCL_RETURN; - - if (eclass == eTkCallbackBreak) - return TCL_BREAK; - - if (eclass == eTkCallbackContinue) - return TCL_CONTINUE; - - if (eclass == rb_eSystemExit || eclass == rb_eInterrupt) { - rbtk_pending_exception = exc; - return TCL_RETURN; - } - - if (rb_obj_is_kind_of(exc, eTkLocalJumpError)) { - rbtk_pending_exception = exc; - return TCL_ERROR; - } - - if (rb_obj_is_kind_of(exc, eLocalJumpError)) { - VALUE reason = rb_ivar_get(exc, ID_at_reason); - - if (TYPE(reason) == T_SYMBOL) { - if (SYM2ID(reason) == ID_return) - return TCL_RETURN; - - if (SYM2ID(reason) == ID_break) - return TCL_BREAK; - - if (SYM2ID(reason) == ID_next) - return TCL_CONTINUE; - } - } - - return TCL_ERROR; - } - - /* result must be string or nil */ - if (!NIL_P(ret)) { - /* copy result to the tcl interpreter */ - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - ret = TkStringValue(ret); - DUMP1("Tcl_AppendResult"); - Tcl_AppendResult(interp, RSTRING(ret)->ptr, (char *)NULL); - - rb_thread_critical = thr_crit_bup; - } - - DUMP2("(result) %s", NIL_P(ret) ? "nil" : RSTRING(ret)->ptr); - - return TCL_OK; -} - -static int -tcl_protect(interp, proc, data) - Tcl_Interp *interp; - VALUE (*proc)(); - VALUE data; -{ - int old_trapflag = rb_trap_immediate; - int code; - -#ifdef HAVE_NATIVETHREAD - if (!is_ruby_native_thread()) { - rb_bug("cross-thread violation on tcl_protect()"); - } -#endif - - rb_trap_immediate = 0; - code = tcl_protect_core(interp, proc, data); - rb_trap_immediate = old_trapflag; - - return code; -} - -static int -#if TCL_MAJOR_VERSION >= 8 -ip_ruby_eval(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - Tcl_Obj *CONST argv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -ip_ruby_eval(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -#endif -{ - char *arg; - int thr_crit_bup; - int code; - - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } - - /* ruby command has 1 arg. */ - if (argc != 2) { -#if 0 - rb_raise(rb_eArgError, - "wrong number of arguments (%d for 1)", argc - 1); -#else - char buf[sizeof(int)*8 + 1]; - Tcl_ResetResult(interp); - sprintf(buf, "%d", argc-1); - Tcl_AppendResult(interp, "wrong number of arguments (", - buf, " for 1)", (char *)NULL); - rbtk_pending_exception = rb_exc_new2(rb_eArgError, - Tcl_GetStringResult(interp)); - return TCL_ERROR; -#endif - } - - /* get C string from Tcl object */ -#if TCL_MAJOR_VERSION >= 8 - { - char *str; - int len; - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - str = Tcl_GetStringFromObj(argv[1], &len); - arg = ALLOC_N(char, len + 1); - memcpy(arg, str, len); - arg[len] = 0; - - rb_thread_critical = thr_crit_bup; - - } -#else /* TCL_MAJOR_VERSION < 8 */ - arg = argv[1]; -#endif - - /* evaluate the argument string by ruby */ - DUMP2("rb_eval_string(%s)", arg); - - code = tcl_protect(interp, rb_eval_string, (VALUE)arg); - -#if TCL_MAJOR_VERSION >= 8 - free(arg); -#endif - - return code; -} - - -/* Tcl command `ruby_cmd' */ -static VALUE -ip_ruby_cmd_core(arg) - struct cmd_body_arg *arg; -{ - volatile VALUE ret; - int thr_crit_bup; - - DUMP1("call ip_ruby_cmd_core"); - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qfalse; - ret = rb_apply(arg->receiver, arg->method, arg->args); - rb_thread_critical = thr_crit_bup; - DUMP1("finish ip_ruby_cmd_core"); - - return ret; -} - -/* ruby_cmd receiver method arg ... */ -static int -#if TCL_MAJOR_VERSION >= 8 -ip_ruby_cmd(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - Tcl_Obj *CONST argv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -ip_ruby_cmd(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -#endif -{ - volatile VALUE receiver; - volatile ID method; - volatile VALUE args; - char *str; - int i; - int len; - struct cmd_body_arg *arg; - int thr_crit_bup; - VALUE old_gc; - int code; - - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } - - if (argc < 3) { -#if 0 - rb_raise(rb_eArgError, "too few arguments"); -#else - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "too few arguments", (char *)NULL); - rbtk_pending_exception = rb_exc_new2(rb_eArgError, - Tcl_GetStringResult(interp)); - return TCL_ERROR; -#endif - } - - /* 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] = '$'; - memcpy(buf + 1, str, len); - buf[len + 1] = 0; - receiver = rb_gv_get(buf); - free(buf); - } - if (NIL_P(receiver)) { -#if 0 - rb_raise(rb_eArgError, - "unknown class/module/global-variable '%s'", str); -#else - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown class/module/global-variable '", - str, "'", (char *)NULL); - rbtk_pending_exception = rb_exc_new2(rb_eArgError, - Tcl_GetStringResult(interp)); - return TCL_ERROR; -#endif - } - - /* get metrhod */ -#if TCL_MAJOR_VERSION >= 8 - str = Tcl_GetStringFromObj(argv[2], &len); -#else /* TCL_MAJOR_VERSION < 8 */ - str = argv[2]; -#endif - method = rb_intern(str); - - /* get args */ - args = rb_ary_new2(argc - 2); - 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; - - arg->receiver = receiver; - arg->method = method; - arg->args = args; - - /* evaluate the argument string by ruby */ - code = tcl_protect(interp, ip_ruby_cmd_core, (VALUE)arg); - - free(arg); - - return code; -} - - -/*****************************/ -/* relpace of 'exit' command */ -/*****************************/ -static int -#if TCL_MAJOR_VERSION >= 8 -ip_InterpExitObjCmd(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - Tcl_Obj *CONST argv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -ip_InterpExitCommand(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -#endif -{ - DUMP1("start ip_InterpExitCommand"); - if (interp != (Tcl_Interp*)NULL - && !Tcl_InterpDeleted(interp) -#if TCL_NAMESPACE_DEBUG - && !ip_null_namespace(interp) -#endif - ) { - Tcl_ResetResult(interp); - /* Tcl_Preserve(interp); */ - /* Tcl_Eval(interp, "interp eval {} {destroy .}; interp delete {}"); */ - ip_finalize(interp); - Tcl_DeleteInterp(interp); - Tcl_Release(interp); - } - return TCL_OK; -} - -static int -#if TCL_MAJOR_VERSION >= 8 -ip_RubyExitObjCmd(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - Tcl_Obj *CONST argv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -ip_RubyExitCommand(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -#endif -{ - int state; - char *cmd, *param; -#if TCL_MAJOR_VERSION < 8 - char *endptr; - cmd = argv[0]; -#endif - - DUMP1("start ip_RubyExitCommand"); - -#if TCL_MAJOR_VERSION >= 8 - /* cmd = Tcl_GetString(argv[0]); */ - cmd = Tcl_GetStringFromObj(argv[0], (int*)NULL); -#endif - - if (argc < 1 || argc > 2) { - /* arguemnt error */ - Tcl_AppendResult(interp, - "wrong number of arguments: should be \"", - cmd, " ?returnCode?\"", (char *)NULL); - return TCL_ERROR; - } - - if (interp == (Tcl_Interp*)NULL) return TCL_OK; - - Tcl_ResetResult(interp); - - if (rb_safe_level() >= 4 || Tcl_IsSafe(interp)) { - ip_finalize(interp); - Tcl_DeleteInterp(interp); - Tcl_Release(interp); - return TCL_OK; - } - - switch(argc) { - case 1: - /* rb_exit(0); */ /* not return if succeed */ - Tcl_AppendResult(interp, - "fail to call \"", cmd, "\"", (char *)NULL); - - rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, - Tcl_GetStringResult(interp)); - rb_iv_set(rbtk_pending_exception, "status", INT2FIX(0)); - - return TCL_RETURN; - - case 2: -#if TCL_MAJOR_VERSION >= 8 - if (Tcl_GetIntFromObj(interp, argv[1], &state) == TCL_ERROR) { - return TCL_ERROR; - } - /* param = Tcl_GetString(argv[1]); */ - param = Tcl_GetStringFromObj(argv[1], (int*)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - state = (int)strtol(argv[1], &endptr, 0); - if (*endptr) { - Tcl_AppendResult(interp, - "expected integer but got \"", - argv[1], "\"", (char *)NULL); - return TCL_ERROR; - } - param = argv[1]; -#endif - /* rb_exit(state); */ /* not return if succeed */ - - Tcl_AppendResult(interp, "fail to call \"", cmd, " ", - param, "\"", (char *)NULL); - - rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, - Tcl_GetStringResult(interp)); - rb_iv_set(rbtk_pending_exception, "status", INT2FIX(state)); - - return TCL_RETURN; - - default: - /* arguemnt error */ - Tcl_AppendResult(interp, - "wrong number of arguments: should be \"", - cmd, " ?returnCode?\"", (char *)NULL); - return TCL_ERROR; - } -} - - -/**************************/ -/* based on tclEvent.c */ -/**************************/ - -/*********************/ -/* replace of update */ -/*********************/ -#if TCL_MAJOR_VERSION >= 8 -static int ip_rbUpdateObjCmd _((ClientData, Tcl_Interp *, int, - Tcl_Obj *CONST [])); -static int -ip_rbUpdateObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -static int ip_rbUpdateCommand _((ClientData, Tcl_Interp *, int, char *[])); -static int -ip_rbUpdateCommand(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - char *objv[]; -#endif -{ - int optionIndex; - int ret; - int flags = 0; - static CONST char *updateOptions[] = {"idletasks", (char *) NULL}; - enum updateOptions {REGEXP_IDLETASKS}; - int dummy; - - DUMP1("Ruby's 'update' is called"); - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } -#ifdef HAVE_NATIVETHREAD - if (!is_ruby_native_thread()) { - rb_bug("cross-thread violation on ip_ruby_eval()"); - } -#endif - - if (objc == 1) { - flags = TCL_DONT_WAIT; - - } else if (objc == 2) { -#if TCL_MAJOR_VERSION >= 8 - if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions, - "option", 0, &optionIndex) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum updateOptions) optionIndex) { - case REGEXP_IDLETASKS: { - flags = TCL_IDLE_EVENTS; - break; - } - default: { - rb_bug("ip_rbUpdateObjCmd: bad option index to UpdateOptions"); - } - } -#else - if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) { - Tcl_AppendResult(interp, "bad option \"", objv[1], - "\": must be idletasks", (char *) NULL); - return TCL_ERROR; - } - flags = TCL_IDLE_EVENTS; -#endif - } else { -#ifdef Tcl_WrongNumArgs - Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]"); -#else -# if TCL_MAJOR_VERSION >= 8 - Tcl_AppendResult(interp, "wrong number of arguments: should be \"", - Tcl_GetStringFromObj(objv[0], &dummy), - " [ idletasks ]\"", - (char *) NULL); -# else /* TCL_MAJOR_VERSION < 8 */ - Tcl_AppendResult(interp, "wrong number of arguments: should be \"", - objv[0], " [ idletasks ]\"", (char *) NULL); -# endif -#endif - return TCL_ERROR; - } - - Tcl_Preserve(interp); - - /* call eventloop */ - /* ret = lib_eventloop_core(0, flags, (int *)NULL);*/ /* ignore result */ - ret = lib_eventloop_launcher(0, flags, (int *)NULL); /* ignore result */ - - /* exception check */ - if (!NIL_P(rbtk_pending_exception)) { - Tcl_Release(interp); - - /* - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { - */ - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) - || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { - return TCL_RETURN; - } else{ - return TCL_ERROR; - } - } - - /* trap check */ - if (rb_trap_pending) { - Tcl_Release(interp); - - return TCL_RETURN; - } - - /* - * Must clear the interpreter's result because event handlers could - * have executed commands. - */ - - DUMP2("last result '%s'", Tcl_GetStringResult(interp)); - Tcl_ResetResult(interp); - Tcl_Release(interp); - - DUMP1("finish Ruby's 'update'"); - return TCL_OK; -} - - -/**********************/ -/* update with thread */ -/**********************/ -struct th_update_param { - VALUE thread; - int done; -}; - -static void rb_threadUpdateProc _((ClientData)); -static void -rb_threadUpdateProc(clientData) - ClientData clientData; /* Pointer to integer to set to 1. */ -{ - struct th_update_param *param = (struct th_update_param *) clientData; - - DUMP1("threadUpdateProc is called"); - param->done = 1; - rb_thread_wakeup(param->thread); - - return; -} - -#if TCL_MAJOR_VERSION >= 8 -static int ip_rb_threadUpdateObjCmd _((ClientData, Tcl_Interp *, int, - Tcl_Obj *CONST [])); -static int -ip_rb_threadUpdateObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -static int ip_rb_threadUpdateCommand _((ClientData, Tcl_Interp *, int, - char *[])); -static int -ip_rb_threadUpdateCommand(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - char *objv[]; -#endif -{ - int optionIndex; - int ret; - 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 (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } -#ifdef HAVE_NATIVETHREAD - if (!is_ruby_native_thread()) { - rb_bug("cross-thread violation on ip_ruby_eval()"); - } -#endif - - if (rb_thread_alone() - || NIL_P(eventloop_thread) || eventloop_thread == current_thread) { -#if TCL_MAJOR_VERSION >= 8 - DUMP1("call ip_rbUpdateObjCmd"); - return ip_rbUpdateObjCmd(clientData, interp, objc, objv); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("call ip_rbUpdateCommand"); - return ip_rbUpdateCommand(clientData, interp, objc, objv); -#endif - } - - DUMP1("start Ruby's 'thread_update' body"); - - if (objc == 1) { - flags = TCL_DONT_WAIT; - - } else if (objc == 2) { -#if TCL_MAJOR_VERSION >= 8 - if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions, - "option", 0, &optionIndex) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum updateOptions) optionIndex) { - case REGEXP_IDLETASKS: { - flags = TCL_IDLE_EVENTS; - break; - } - default: { - rb_bug("ip_rb_threadUpdateObjCmd: bad option index to UpdateOptions"); - } - } -#else - if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) { - Tcl_AppendResult(interp, "bad option \"", objv[1], - "\": must be idletasks", (char *) NULL); - return TCL_ERROR; - } - flags = TCL_IDLE_EVENTS; -#endif - } 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)); - Tcl_Preserve(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_Release(param); - Tcl_Free((char *)param); - - DUMP1("finish Ruby's 'thread_update'"); - return TCL_OK; -} - - -/***************************/ -/* 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. */ - Tcl_Interp *interp; /* Interpreter containing variable. */ - CONST84 char *name1; /* Name of variable. */ - CONST84 char *name2; /* Second part of variable name. */ - int flags; /* Information about what happened. */ -#else /* TCL_MAJOR_VERSION < 8 */ -static char *VwaitVarProc _((ClientData, Tcl_Interp *, char *, char *, int)); -static char * -VwaitVarProc(clientData, interp, name1, name2, flags) - ClientData clientData; /* Pointer to integer to set to 1. */ - Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Name of variable. */ - char *name2; /* Second part of variable name. */ - int flags; /* Information about what happened. */ -#endif -{ - int *donePtr = (int *) clientData; - - *donePtr = 1; - return (char *) NULL; -} - - -#if TCL_MAJOR_VERSION >= 8 -static int ip_rbVwaitObjCmd _((ClientData, Tcl_Interp *, int, - Tcl_Obj *CONST [])); -static int -ip_rbVwaitObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -static int ip_rbVwaitCommand _((ClientData, Tcl_Interp *, int, char *[])); -static int -ip_rbVwaitCommand(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - char *objv[]; -#endif -{ - int ret, done, foundEvent; - char *nameString; - int dummy; - int thr_crit_bup; - - DUMP1("Ruby's 'vwait' is called"); - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } - - Tcl_Preserve(interp); -#ifdef HAVE_NATIVETHREAD - if (!is_ruby_native_thread()) { - rb_bug("cross-thread violation on ip_ruby_eval()"); - } -#endif - - if (objc != 2) { -#ifdef Tcl_WrongNumArgs - Tcl_WrongNumArgs(interp, 1, objv, "name"); -#else - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - -#if TCL_MAJOR_VERSION >= 8 - /* nameString = Tcl_GetString(objv[0]); */ - nameString = Tcl_GetStringFromObj(objv[0], &dummy); -#else /* TCL_MAJOR_VERSION < 8 */ - nameString = objv[0]; -#endif - Tcl_AppendResult(interp, "wrong number of arguments: should be \"", - nameString, " name\"", (char *) NULL); - - rb_thread_critical = thr_crit_bup; -#endif - - Tcl_Release(interp); - return TCL_ERROR; - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - -#if TCL_MAJOR_VERSION >= 8 - Tcl_IncrRefCount(objv[1]); - /* nameString = Tcl_GetString(objv[1]); */ - nameString = Tcl_GetStringFromObj(objv[1], &dummy); -#else /* TCL_MAJOR_VERSION < 8 */ - nameString = objv[1]; -#endif - - /* - if (Tcl_TraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, (ClientData) &done) != TCL_OK) { - return TCL_ERROR; - } - */ - ret = Tcl_TraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, (ClientData) &done); - - rb_thread_critical = thr_crit_bup; - - if (ret != TCL_OK) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[1]); -#endif - Tcl_Release(interp); - return TCL_ERROR; - } - - done = 0; - - foundEvent - = lib_eventloop_launcher(/* 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; - - /* exception check */ - if (!NIL_P(rbtk_pending_exception)) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[1]); -#endif - Tcl_Release(interp); - -/* - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { -*/ - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) - || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { - return TCL_RETURN; - } else{ - return TCL_ERROR; - } - } - - /* trap check */ - if (rb_trap_pending) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[1]); -#endif - Tcl_Release(interp); - - return TCL_RETURN; - } - - /* - * Clear out the interpreter's result, since it may have been set - * by event handlers. - */ - - Tcl_ResetResult(interp); - if (!foundEvent) { - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - Tcl_AppendResult(interp, "can't wait for variable \"", nameString, - "\": would wait forever", (char *) NULL); - - rb_thread_critical = thr_crit_bup; - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[1]); -#endif - Tcl_Release(interp); - return TCL_ERROR; - } - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[1]); -#endif - Tcl_Release(interp); - return TCL_OK; -} - - -/**************************/ -/* based on tkCmd.c */ -/**************************/ -#if TCL_MAJOR_VERSION >= 8 -static char *WaitVariableProc _((ClientData, Tcl_Interp *, - CONST84 char *,CONST84 char *, int)); -static char * -WaitVariableProc(clientData, interp, name1, name2, flags) - ClientData clientData; /* Pointer to integer to set to 1. */ - Tcl_Interp *interp; /* Interpreter containing variable. */ - CONST84 char *name1; /* Name of variable. */ - CONST84 char *name2; /* Second part of variable name. */ - int flags; /* Information about what happened. */ -#else /* TCL_MAJOR_VERSION < 8 */ -static char *WaitVariableProc _((ClientData, Tcl_Interp *, - char *, char *, int)); -static char * -WaitVariableProc(clientData, interp, name1, name2, flags) - ClientData clientData; /* Pointer to integer to set to 1. */ - Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Name of variable. */ - char *name2; /* Second part of variable name. */ - int flags; /* Information about what happened. */ -#endif -{ - int *donePtr = (int *) clientData; - - *donePtr = 1; - return (char *) NULL; -} - -static void WaitVisibilityProc _((ClientData, XEvent *)); -static void -WaitVisibilityProc(clientData, eventPtr) - ClientData clientData; /* Pointer to integer to set to 1. */ - XEvent *eventPtr; /* Information about event (not used). */ -{ - int *donePtr = (int *) clientData; - - if (eventPtr->type == VisibilityNotify) { - *donePtr = 1; - } - if (eventPtr->type == DestroyNotify) { - *donePtr = 2; - } -} - -static void WaitWindowProc _((ClientData, XEvent *)); -static void -WaitWindowProc(clientData, eventPtr) - ClientData clientData; /* Pointer to integer to set to 1. */ - XEvent *eventPtr; /* Information about event. */ -{ - int *donePtr = (int *) clientData; - - if (eventPtr->type == DestroyNotify) { - *donePtr = 1; - } -} - -#if TCL_MAJOR_VERSION >= 8 -static int ip_rbTkWaitObjCmd _((ClientData, Tcl_Interp *, int, - Tcl_Obj *CONST [])); -static int -ip_rbTkWaitObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -static int ip_rbTkWaitCommand _((ClientData, Tcl_Interp *, int, char *[])); -static int -ip_rbTkWaitCommand(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - char *objv[]; -#endif -{ - Tk_Window tkwin = (Tk_Window) clientData; - Tk_Window window; - int done, index; - static CONST char *optionStrings[] = { "variable", "visibility", "window", - (char *) NULL }; - enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW }; - char *nameString; - int ret, dummy; - int thr_crit_bup; - - DUMP1("Ruby's 'tkwait' is called"); - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } - - Tcl_Preserve(interp); - - if (objc != 3) { -#ifdef Tcl_WrongNumArgs - Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); -#else - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - -#if TCL_MAJOR_VERSION >= 8 - Tcl_AppendResult(interp, "wrong number of arguments: should be \"", - Tcl_GetStringFromObj(objv[0], &dummy), - " variable|visibility|window name\"", - (char *) NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - Tcl_AppendResult(interp, "wrong number of arguments: should be \"", - objv[0], " variable|visibility|window name\"", - (char *) NULL); -#endif - - rb_thread_critical = thr_crit_bup; -#endif - - Tcl_Release(interp); - return TCL_ERROR; - } - -#if TCL_MAJOR_VERSION >= 8 - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* - if (Tcl_GetIndexFromObj(interp, objv[1], - (CONST84 char **)optionStrings, - "option", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - */ - ret = Tcl_GetIndexFromObj(interp, objv[1], - (CONST84 char **)optionStrings, - "option", 0, &index); - - rb_thread_critical = thr_crit_bup; - - if (ret != TCL_OK) { - Tcl_Release(interp); - return TCL_ERROR; - } -#else /* TCL_MAJOR_VERSION < 8 */ - { - int c = objv[1][0]; - size_t length = strlen(objv[1]); - - if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0) - && (length >= 2)) { - index = TKWAIT_VARIABLE; - } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0) - && (length >= 2)) { - index = TKWAIT_VISIBILITY; - } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) { - index = TKWAIT_WINDOW; - } else { - Tcl_AppendResult(interp, "bad option \"", objv[1], - "\": must be variable, visibility, or window", - (char *) NULL); - Tcl_Release(interp); - return TCL_ERROR; - } - } -#endif - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - -#if TCL_MAJOR_VERSION >= 8 - Tcl_IncrRefCount(objv[2]); - /* nameString = Tcl_GetString(objv[2]); */ - nameString = Tcl_GetStringFromObj(objv[2], &dummy); -#else /* TCL_MAJOR_VERSION < 8 */ - nameString = objv[2]; -#endif - - rb_thread_critical = thr_crit_bup; - - switch ((enum options) index) { - case TKWAIT_VARIABLE: - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - /* - if (Tcl_TraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - WaitVariableProc, (ClientData) &done) != TCL_OK) { - return TCL_ERROR; - } - */ - ret = Tcl_TraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - WaitVariableProc, (ClientData) &done); - - rb_thread_critical = thr_crit_bup; - - if (ret != TCL_OK) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - Tcl_Release(interp); - return TCL_ERROR; - } - - done = 0; - /* lib_eventloop_core(check_rootwidget_flag, 0, &done); */ - lib_eventloop_launcher(check_rootwidget_flag, 0, &done); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - Tcl_UntraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - WaitVariableProc, (ClientData) &done); - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - - rb_thread_critical = thr_crit_bup; - - /* exception check */ - if (!NIL_P(rbtk_pending_exception)) { - Tcl_Release(interp); - - /* - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { - */ - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) - || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { - return TCL_RETURN; - } else{ - return TCL_ERROR; - } - } - - /* trap check */ - if (rb_trap_pending) { - Tcl_Release(interp); - - return TCL_RETURN; - } - - break; - - case TKWAIT_VISIBILITY: - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) { - window = NULL; - } else { - window = Tk_NameToWindow(interp, nameString, tkwin); - } - - if (window == NULL) { - Tcl_AppendResult(interp, "tkwait: ", - "no main-window (not Tk application?)", - (char*)NULL); - rb_thread_critical = thr_crit_bup; -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - Tcl_Release(interp); - return TCL_ERROR; - } - - Tk_CreateEventHandler(window, - VisibilityChangeMask|StructureNotifyMask, - WaitVisibilityProc, (ClientData) &done); - - rb_thread_critical = thr_crit_bup; - - done = 0; - /* lib_eventloop_core(check_rootwidget_flag, 0, &done); */ - lib_eventloop_launcher(check_rootwidget_flag, 0, &done); - - /* exception check */ - if (!NIL_P(rbtk_pending_exception)) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - Tcl_Release(interp); - - /* - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { - */ - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) - || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { - return TCL_RETURN; - } else{ - return TCL_ERROR; - } - } - - /* trap check */ - if (rb_trap_pending) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - Tcl_Release(interp); - - return TCL_RETURN; - } - - if (done != 1) { - /* - * Note that we do not delete the event handler because it - * was deleted automatically when the window was destroyed. - */ - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "window \"", nameString, - "\" was deleted before its visibility changed", - (char *) NULL); - - rb_thread_critical = thr_crit_bup; - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - Tcl_Release(interp); - return TCL_ERROR; - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - - Tk_DeleteEventHandler(window, - VisibilityChangeMask|StructureNotifyMask, - WaitVisibilityProc, (ClientData) &done); - - rb_thread_critical = thr_crit_bup; - - break; - - case TKWAIT_WINDOW: - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) { - window = NULL; - } else { - window = Tk_NameToWindow(interp, nameString, tkwin); - } - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - - if (window == NULL) { - Tcl_AppendResult(interp, "tkwait: ", - "no main-window (not Tk application?)", - (char*)NULL); - rb_thread_critical = thr_crit_bup; - Tcl_Release(interp); - return TCL_ERROR; - } - - Tk_CreateEventHandler(window, StructureNotifyMask, - WaitWindowProc, (ClientData) &done); - - rb_thread_critical = thr_crit_bup; - - done = 0; - /* lib_eventloop_core(check_rootwidget_flag, 0, &done); */ - lib_eventloop_launcher(check_rootwidget_flag, 0, &done); - - /* exception check */ - if (!NIL_P(rbtk_pending_exception)) { - Tcl_Release(interp); - - /* - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { - */ - if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) - || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { - return TCL_RETURN; - } else{ - return TCL_ERROR; - } - } - - /* trap check */ - if (rb_trap_pending) { - Tcl_Release(interp); - - return TCL_RETURN; - } - - /* - * Note: there's no need to delete the event handler. It was - * deleted automatically when the window was destroyed. - */ - break; - } - - /* - * Clear out the interpreter's result, since it may have been set - * by event handlers. - */ - - Tcl_ResetResult(interp); - Tcl_Release(interp); - return TCL_OK; -} - -/****************************/ -/* vwait/tkwait with thread */ -/****************************/ -struct th_vwait_param { - VALUE thread; - int done; -}; - -#if TCL_MAJOR_VERSION >= 8 -static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *, - CONST84 char *,CONST84 char *, int)); -static char * -rb_threadVwaitProc(clientData, interp, name1, name2, flags) - ClientData clientData; /* Pointer to integer to set to 1. */ - Tcl_Interp *interp; /* Interpreter containing variable. */ - CONST84 char *name1; /* Name of variable. */ - CONST84 char *name2; /* Second part of variable name. */ - int flags; /* Information about what happened. */ -#else /* TCL_MAJOR_VERSION < 8 */ -static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *, - char *, char *, int)); -static char * -rb_threadVwaitProc(clientData, interp, name1, name2, flags) - ClientData clientData; /* Pointer to integer to set to 1. */ - Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Name of variable. */ - char *name2; /* Second part of variable name. */ - int flags; /* Information about what happened. */ -#endif -{ - struct th_vwait_param *param = (struct th_vwait_param *) clientData; - - if (flags & (TCL_INTERP_DESTROYED | TCL_TRACE_DESTROYED)) { - param->done = -1; - } else { - param->done = 1; - } - rb_thread_wakeup(param->thread); - - return (char *)NULL; -} - -#define TKWAIT_MODE_VISIBILITY 1 -#define TKWAIT_MODE_DESTROY 2 - -static void rb_threadWaitVisibilityProc _((ClientData, XEvent *)); -static void -rb_threadWaitVisibilityProc(clientData, eventPtr) - ClientData clientData; /* Pointer to integer to set to 1. */ - XEvent *eventPtr; /* Information about event (not used). */ -{ - struct th_vwait_param *param = (struct th_vwait_param *) clientData; - - if (eventPtr->type == VisibilityNotify) { - param->done = TKWAIT_MODE_VISIBILITY; - } - if (eventPtr->type == DestroyNotify) { - param->done = TKWAIT_MODE_DESTROY; - } - rb_thread_wakeup(param->thread); -} - -static void rb_threadWaitWindowProc _((ClientData, XEvent *)); -static void -rb_threadWaitWindowProc(clientData, eventPtr) - ClientData clientData; /* Pointer to integer to set to 1. */ - XEvent *eventPtr; /* Information about event. */ -{ - struct th_vwait_param *param = (struct th_vwait_param *) clientData; - - if (eventPtr->type == DestroyNotify) { - param->done = TKWAIT_MODE_DESTROY; - } - rb_thread_wakeup(param->thread); -} - -#if TCL_MAJOR_VERSION >= 8 -static int ip_rb_threadVwaitObjCmd _((ClientData, Tcl_Interp *, int, - Tcl_Obj *CONST [])); -static int -ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -static int ip_rb_threadVwaitCommand _((ClientData, Tcl_Interp *, int, - char *[])); -static int -ip_rb_threadVwaitCommand(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - char *objv[]; -#endif -{ - struct th_vwait_param *param; - char *nameString; - int ret, dummy; - int thr_crit_bup; - volatile VALUE current_thread = rb_thread_current(); - - DUMP1("Ruby's 'thread_vwait' is called"); - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } - - if (rb_thread_alone() || eventloop_thread == current_thread) { -#if TCL_MAJOR_VERSION >= 8 - DUMP1("call ip_rbVwaitObjCmd"); - return ip_rbVwaitObjCmd(clientData, interp, objc, objv); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("call ip_rbVwaitCommand"); - return ip_rbVwaitCommand(clientData, interp, objc, objv); -#endif - } - - Tcl_Preserve(interp); - - if (objc != 2) { -#ifdef Tcl_WrongNumArgs - Tcl_WrongNumArgs(interp, 1, objv, "name"); -#else - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - -#if TCL_MAJOR_VERSION >= 8 - /* nameString = Tcl_GetString(objv[0]); */ - nameString = Tcl_GetStringFromObj(objv[0], &dummy); -#else /* TCL_MAJOR_VERSION < 8 */ - nameString = objv[0]; -#endif - Tcl_AppendResult(interp, "wrong number of arguments: should be \"", - nameString, " name\"", (char *) NULL); - - rb_thread_critical = thr_crit_bup; -#endif - - Tcl_Release(interp); - return TCL_ERROR; - } - -#if TCL_MAJOR_VERSION >= 8 - Tcl_IncrRefCount(objv[1]); - /* nameString = Tcl_GetString(objv[1]); */ - nameString = Tcl_GetStringFromObj(objv[1], &dummy); -#else /* TCL_MAJOR_VERSION < 8 */ - nameString = objv[1]; -#endif - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); - Tcl_Preserve(param); - 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) { - Tcl_Release(param); - Tcl_Free((char *)param); - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[1]); -#endif - Tcl_Release(interp); - return TCL_ERROR; - } - - /* if (!param->done) { */ - while(!param->done) { - rb_thread_stop(); - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if (param->done > 0) { - Tcl_UntraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - rb_threadVwaitProc, (ClientData) param); - } - - Tcl_Release(param); - Tcl_Free((char *)param); - - rb_thread_critical = thr_crit_bup; - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[1]); -#endif - Tcl_Release(interp); - return TCL_OK; -} - -#if TCL_MAJOR_VERSION >= 8 -static int ip_rb_threadTkWaitObjCmd _((ClientData, Tcl_Interp *, int, - Tcl_Obj *CONST [])); -static int -ip_rb_threadTkWaitObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -#else /* TCL_MAJOR_VERSION < 8 */ -static int ip_rb_threadTkWaitCommand _((ClientData, Tcl_Interp *, int, - char *[])); -static int -ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - char *objv[]; -#endif -{ - struct th_vwait_param *param; - Tk_Window tkwin = (Tk_Window) clientData; - Tk_Window window; - int index; - static CONST char *optionStrings[] = { "variable", "visibility", "window", - (char *) NULL }; - enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW }; - char *nameString; - int ret, dummy; - int thr_crit_bup; - volatile VALUE current_thread = rb_thread_current(); - - DUMP1("Ruby's 'thread_tkwait' is called"); - if (interp == (Tcl_Interp*)NULL) { - rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, - "IP is deleted"); - return TCL_ERROR; - } - - if (rb_thread_alone() || eventloop_thread == current_thread) { -#if TCL_MAJOR_VERSION >= 8 - DUMP1("call ip_rbTkWaitObjCmd"); - return ip_rbTkWaitObjCmd(clientData, interp, objc, objv); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("call rb_VwaitCommand"); - return ip_rbTkWaitCommand(clientData, interp, objc, objv); -#endif - } - - Tcl_Preserve(interp); - Tcl_Preserve(tkwin); - - if (objc != 3) { -#ifdef Tcl_WrongNumArgs - Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); -#else - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - -#if TCL_MAJOR_VERSION >= 8 - Tcl_AppendResult(interp, "wrong number of arguments: should be \"", - Tcl_GetStringFromObj(objv[0], &dummy), - " variable|visibility|window name\"", - (char *) NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - Tcl_AppendResult(interp, "wrong number of arguments: should be \"", - objv[0], " variable|visibility|window name\"", - (char *) NULL); -#endif - - rb_thread_critical = thr_crit_bup; -#endif - - Tcl_Release(tkwin); - Tcl_Release(interp); - return TCL_ERROR; - } - -#if TCL_MAJOR_VERSION >= 8 - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - /* - if (Tcl_GetIndexFromObj(interp, objv[1], - (CONST84 char **)optionStrings, - "option", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - */ - ret = Tcl_GetIndexFromObj(interp, objv[1], - (CONST84 char **)optionStrings, - "option", 0, &index); - - rb_thread_critical = thr_crit_bup; - - if (ret != TCL_OK) { - Tcl_Release(tkwin); - Tcl_Release(interp); - return TCL_ERROR; - } -#else /* TCL_MAJOR_VERSION < 8 */ - { - int c = objv[1][0]; - size_t length = strlen(objv[1]); - - if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0) - && (length >= 2)) { - index = TKWAIT_VARIABLE; - } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0) - && (length >= 2)) { - index = TKWAIT_VISIBILITY; - } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) { - index = TKWAIT_WINDOW; - } else { - Tcl_AppendResult(interp, "bad option \"", objv[1], - "\": must be variable, visibility, or window", - (char *) NULL); - Tcl_Release(tkwin); - Tcl_Release(interp); - return TCL_ERROR; - } - } -#endif - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - -#if TCL_MAJOR_VERSION >= 8 - Tcl_IncrRefCount(objv[2]); - /* nameString = Tcl_GetString(objv[2]); */ - nameString = Tcl_GetStringFromObj(objv[2], &dummy); -#else /* TCL_MAJOR_VERSION < 8 */ - nameString = objv[2]; -#endif - - param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); - Tcl_Preserve(param); - param->thread = current_thread; - param->done = 0; - - rb_thread_critical = thr_crit_bup; - - switch ((enum options) index) { - case TKWAIT_VARIABLE: - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - /* - if (Tcl_TraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - rb_threadVwaitProc, (ClientData) param) != TCL_OK) { - return TCL_ERROR; - } - */ - ret = Tcl_TraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - rb_threadVwaitProc, (ClientData) param); - - rb_thread_critical = thr_crit_bup; - - if (ret != TCL_OK) { - Tcl_Release(param); - Tcl_Free((char *)param); - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - - Tcl_Release(tkwin); - Tcl_Release(interp); - return TCL_ERROR; - } - - /* if (!param->done) { */ - while(!param->done) { - rb_thread_stop(); - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if (param->done > 0) { - Tcl_UntraceVar(interp, nameString, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - rb_threadVwaitProc, (ClientData) param); - } - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - - rb_thread_critical = thr_crit_bup; - - break; - - case TKWAIT_VISIBILITY: - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) { - window = NULL; - } else { - window = Tk_NameToWindow(interp, nameString, tkwin); - } - - if (window == NULL) { - Tcl_AppendResult(interp, "thread_tkwait: ", - "no main-window (not Tk application?)", - (char*)NULL); - - rb_thread_critical = thr_crit_bup; - - Tcl_Release(param); - Tcl_Free((char *)param); - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - Tcl_Release(tkwin); - Tcl_Release(interp); - return TCL_ERROR; - } - Tcl_Preserve(window); - - Tk_CreateEventHandler(window, - VisibilityChangeMask|StructureNotifyMask, - rb_threadWaitVisibilityProc, (ClientData) param); - - rb_thread_critical = thr_crit_bup; - - /* if (!param->done) { */ - /* - while(!param->done) { - rb_thread_stop(); - } - */ - while(param->done != TKWAIT_MODE_VISIBILITY) { - if (param->done == TKWAIT_MODE_DESTROY) break; - rb_thread_stop(); - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* when a window is destroyed, no need to call Tk_DeleteEventHandler */ - if (param->done != TKWAIT_MODE_DESTROY) { - Tk_DeleteEventHandler(window, - VisibilityChangeMask|StructureNotifyMask, - rb_threadWaitVisibilityProc, - (ClientData) param); - } - - if (param->done != 1) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "window \"", nameString, - "\" was deleted before its visibility changed", - (char *) NULL); - - rb_thread_critical = thr_crit_bup; - - Tcl_Release(window); - - Tcl_Release(param); - Tcl_Free((char *)param); - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - - Tcl_Release(tkwin); - Tcl_Release(interp); - return TCL_ERROR; - } - - Tcl_Release(window); - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - - rb_thread_critical = thr_crit_bup; - - break; - - case TKWAIT_WINDOW: - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) { - window = NULL; - } else { - window = Tk_NameToWindow(interp, nameString, tkwin); - } - -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[2]); -#endif - - if (window == NULL) { - Tcl_AppendResult(interp, "thread_tkwait: ", - "no main-window (not Tk application?)", - (char*)NULL); - - rb_thread_critical = thr_crit_bup; - - Tcl_Release(param); - Tcl_Free((char *)param); - - Tcl_Release(tkwin); - Tcl_Release(interp); - return TCL_ERROR; - } - - Tcl_Preserve(window); - - Tk_CreateEventHandler(window, StructureNotifyMask, - rb_threadWaitWindowProc, (ClientData) param); - - rb_thread_critical = thr_crit_bup; - - /* if (!param->done) { */ - /* - while(!param->done) { - rb_thread_stop(); - } - */ - while(param->done != TKWAIT_MODE_DESTROY) { - rb_thread_stop(); - } - - Tcl_Release(window); - - /* when a window is destroyed, no need to call Tk_DeleteEventHandler - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - Tk_DeleteEventHandler(window, StructureNotifyMask, - rb_threadWaitWindowProc, (ClientData) param); - - rb_thread_critical = thr_crit_bup; - */ - - break; - } /* end of 'switch' statement */ - - Tcl_Release(param); - Tcl_Free((char *)param); - - /* - * Clear out the interpreter's result, since it may have been set - * by event handlers. - */ - - Tcl_ResetResult(interp); - - Tcl_Release(tkwin); - Tcl_Release(interp); - return TCL_OK; -} - -static VALUE -ip_thread_vwait(self, var) - VALUE self; - VALUE var; -{ - VALUE argv[2]; - volatile VALUE cmd_str = rb_str_new2("thread_vwait"); - - argv[0] = cmd_str; - argv[1] = var; - - return ip_invoke_real(2, argv, self); -} - -static VALUE -ip_thread_tkwait(self, mode, target) - VALUE self; - VALUE mode; - VALUE target; -{ - VALUE argv[3]; - volatile VALUE cmd_str = rb_str_new2("thread_tkwait"); - - argv[0] = cmd_str; - argv[1] = mode; - argv[2] = target; - - return ip_invoke_real(3, argv, self); -} - - -/* delete slave interpreters */ -#if TCL_MAJOR_VERSION >= 8 -static void -delete_slaves(ip) - Tcl_Interp *ip; -{ - int thr_crit_bup; - Tcl_Interp *slave; - Tcl_Obj *slave_list, *elem; - char *slave_name; - int i, len; - - DUMP1("delete slaves"); - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) { - slave_list = Tcl_GetObjResult(ip); - Tcl_IncrRefCount(slave_list); - - if (Tcl_ListObjLength((Tcl_Interp*)NULL, slave_list, &len) == TCL_OK) { - for(i = 0; i < len; i++) { - Tcl_ListObjIndex((Tcl_Interp*)NULL, slave_list, i, &elem); - Tcl_IncrRefCount(elem); - - if (elem == (Tcl_Obj*)NULL) continue; - - /* get slave */ - /* slave_name = Tcl_GetString(elem); */ - slave_name = Tcl_GetStringFromObj(elem, (int*)NULL); - DUMP2("delete slave:'%s'", slave_name); - - Tcl_DecrRefCount(elem); - - slave = Tcl_GetSlave(ip, slave_name); - if (slave == (Tcl_Interp*)NULL) continue; - - /* call ip_finalize */ - ip_finalize(slave); - - Tcl_DeleteInterp(slave); - /* Tcl_Release(slave); */ - } - } - - Tcl_DecrRefCount(slave_list); - } - - rb_thread_critical = thr_crit_bup; -} -#else /* TCL_MAJOR_VERSION < 8 */ -static void -delete_slaves(ip) - Tcl_Interp *ip; -{ - int thr_crit_bup; - Tcl_Interp *slave; - int argc; - char **argv; - char *slave_list; - char *slave_name; - int i, len; - - DUMP1("delete slaves"); - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) { - slave_list = ip->result; - if (Tcl_SplitList((Tcl_Interp*)NULL, - slave_list, &argc, &argv) == TCL_OK) { - for(i = 0; i < argc; i++) { - slave_name = argv[i]; - - DUMP2("delete slave:'%s'", slave_name); - - slave = Tcl_GetSlave(ip, slave_name); - if (slave == (Tcl_Interp*)NULL) continue; - - /* call ip_finalize */ - ip_finalize(slave); - - Tcl_DeleteInterp(slave); - } - } - } - - rb_thread_critical = thr_crit_bup; -} -#endif - - -/* finalize operation */ -static void -ip_finalize(ip) - Tcl_Interp *ip; -{ - Tcl_CmdInfo info; - int thr_crit_bup; - int rb_debug_bup; /* When ruby is exiting, printing debug messages in - some callback operations from Tcl-IP sometimes - cause SEGV. I don't know the reason. But I got - SEGV when calling "rb_io_write(rb_stdout, ...)". - So, in some part of this function, debug mode is - disabled. If you know the reason, please fix it. - -- Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp) */ - - DUMP1("start ip_finalize"); - - if (ip == (Tcl_Interp*)NULL) { - DUMP1("ip is NULL"); - return; - } - -#if TCL_NAMESPACE_DEBUG - if (ip_null_namespace(ip)) { - DUMP2("ip(%lx) has null namespace", ip); - return; - } -#endif - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - rb_debug_bup = ruby_debug; - - Tcl_Preserve(ip); - - /* delete slaves */ - delete_slaves(ip); - - /* delete root widget */ -#if 0 - DUMP1("check `destroy'"); - if (Tcl_GetCommandInfo(ip, "destroy", &info)) { - DUMP1("call `destroy'"); - Tcl_GlobalEval(ip, "destroy ."); - } -#endif -#if 1 - DUMP1("destroy root widget"); - if (tk_stubs_init_p() && Tk_MainWindow(ip) != (Tk_Window)NULL) { - DUMP1("call Tk_DestroyWindow"); - ruby_debug = 0; - Tk_DestroyWindow(Tk_MainWindow(ip)); - ruby_debug = rb_debug_bup; - } -#endif - - /* call finalize-hook-proc */ - DUMP1("check `finalize-hook-proc'"); - if (Tcl_GetCommandInfo(ip, finalize_hook_name, &info)) { - DUMP2("call finalize hook proc '%s'", finalize_hook_name); - ruby_debug = 0; - Tcl_GlobalEval(ip, finalize_hook_name); - ruby_debug = rb_debug_bup; - } - - DUMP1("check `foreach' & `after'"); - if ( Tcl_GetCommandInfo(ip, "foreach", &info) - && Tcl_GetCommandInfo(ip, "after", &info) ) { - DUMP1("cancel after callbacks"); - ruby_debug = 0; - Tcl_GlobalEval(ip, "foreach id [after info] {after cancel $id}"); - ruby_debug = rb_debug_bup; - } - - Tcl_Release(ip); - - DUMP1("finish ip_finalize"); - ruby_debug = rb_debug_bup; - rb_thread_critical = thr_crit_bup; -} - - -/* destroy interpreter */ -static void -ip_free(ptr) - struct tcltkip *ptr; -{ - int thr_crit_bup; - - DUMP2("free Tcl Interp %lx", ptr->ip); - if (ptr) { - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if ( ptr->ip != (Tcl_Interp*)NULL - && !Tcl_InterpDeleted(ptr->ip) - && Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL - && !Tcl_InterpDeleted(Tcl_GetMaster(ptr->ip)) ) { - DUMP2("parent IP(%lx) is not deleted", Tcl_GetMaster(ptr->ip)); - DUMP2("slave IP(%lx) should not be deleted", ptr->ip); - free(ptr); - rb_thread_critical = thr_crit_bup; - return; - } - - if (ptr->ip == (Tcl_Interp*)NULL) { - DUMP1("ip_free is called for deleted IP"); - free(ptr); - rb_thread_critical = thr_crit_bup; - return; - } - - ip_finalize(ptr->ip); - Tcl_DeleteInterp(ptr->ip); - Tcl_Release(ptr->ip); - - free(ptr); - - rb_thread_critical = thr_crit_bup; - } - - DUMP1("complete freeing Tcl Interp"); -} - - -/* create and initialize interpreter */ -static VALUE ip_alloc _((VALUE)); -static VALUE -ip_alloc(self) - VALUE self; -{ - return Data_Wrap_Struct(self, 0, ip_free, 0); -} - -static void -ip_replace_wait_commands(interp, mainWin) - Tcl_Interp *interp; - Tk_Window mainWin; -{ - /* replace 'vwait' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"vwait\")"); - Tcl_CreateObjCommand(interp, "vwait", ip_rbVwaitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"vwait\")"); - Tcl_CreateCommand(interp, "vwait", ip_rbVwaitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* replace 'tkwait' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"tkwait\")"); - Tcl_CreateObjCommand(interp, "tkwait", ip_rbTkWaitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"tkwait\")"); - Tcl_CreateCommand(interp, "tkwait", ip_rbTkWaitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* add 'thread_vwait' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"thread_vwait\")"); - Tcl_CreateObjCommand(interp, "thread_vwait", ip_rb_threadVwaitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"thread_vwait\")"); - Tcl_CreateCommand(interp, "thread_vwait", ip_rb_threadVwaitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* add 'thread_tkwait' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"thread_tkwait\")"); - Tcl_CreateObjCommand(interp, "thread_tkwait", ip_rb_threadTkWaitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"thread_tkwait\")"); - Tcl_CreateCommand(interp, "thread_tkwait", ip_rb_threadTkWaitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* replace 'update' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"update\")"); - Tcl_CreateObjCommand(interp, "update", ip_rbUpdateObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"update\")"); - Tcl_CreateCommand(interp, "update", ip_rbUpdateCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* add 'thread_update' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"thread_update\")"); - Tcl_CreateObjCommand(interp, "thread_update", ip_rb_threadUpdateObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"thread_update\")"); - Tcl_CreateCommand(interp, "thread_update", ip_rb_threadUpdateCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif -} - - - -#if TCL_MAJOR_VERSION >= 8 -static int ip_rbNamespaceObjCmd _((ClientData, Tcl_Interp *, int, - Tcl_Obj *CONST [])); -static int -ip_rbNamespaceObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - Tcl_CmdInfo info; - int ret; - - if (!Tcl_GetCommandInfo(interp, "__orig_namespace_command__", &(info))) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "invalid command name \"namespace\"", (char*)NULL); - return TCL_ERROR; - } - - rbtk_eventloop_depth++; - DUMP2("namespace wrapper enter depth == %d", rbtk_eventloop_depth); - - if (info.isNativeObjectProc) { - ret = (*(info.objProc))(info.objClientData, interp, objc, objv); - } else { - /* string interface */ - int i; - char **argv; - - argv = (char **)Tcl_Alloc(sizeof(char *) * (objc + 1)); - - for(i = 0; i < objc; i++) { - /* argv[i] = Tcl_GetString(objv[i]); */ - argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL); - } - argv[objc] = (char *)NULL; - - ret = (*(info.proc))(info.clientData, interp, - objc, (CONST84 char **)argv); - - Tcl_Free((char*)argv); - } - - DUMP2("namespace wrapper exit depth == %d", rbtk_eventloop_depth); - rbtk_eventloop_depth--; - - return ret; -} -#endif - -static void -ip_wrap_namespace_command(interp) - Tcl_Interp *interp; -{ -#if TCL_MAJOR_VERSION >= 8 - Tcl_CmdInfo orig_info; - - if (!Tcl_GetCommandInfo(interp, "namespace", &(orig_info))) { - return; - } - - if (orig_info.isNativeObjectProc) { - Tcl_CreateObjCommand(interp, "__orig_namespace_command__", - orig_info.objProc, orig_info.objClientData, - orig_info.deleteProc); - } else { - Tcl_CreateCommand(interp, "__orig_namespace_command__", - orig_info.proc, orig_info.clientData, - orig_info.deleteProc); - } - - Tcl_CreateObjCommand(interp, "namespace", ip_rbNamespaceObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *)NULL); -#endif -} - - -/* call when interpreter is deleted */ -static void -ip_CallWhenDeleted(clientData, ip) - ClientData clientData; - Tcl_Interp *ip; -{ - int thr_crit_bup; - Tcl_CmdInfo info; - Tk_Window main_win = (Tk_Window) clientData; - - DUMP1("start ip_CallWhenDeleted"); - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - ip_finalize(ip); - - DUMP1("finish ip_CallWhenDeleted"); - rb_thread_critical = thr_crit_bup; -} - - -/* initialize interpreter */ -static VALUE -ip_init(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - struct tcltkip *ptr; /* tcltkip data struct */ - VALUE argv0, opts; - int cnt; - int st; - int with_tk = 1; - Tk_Window mainWin = (Tk_Window)NULL; - - /* security check */ - if (ruby_safe_level >= 4) { - rb_raise(rb_eSecurityError, - "Cannot create a TclTkIp object at level %d", - ruby_safe_level); - } - - /* create object */ - Data_Get_Struct(self, struct tcltkip, ptr); - ptr = ALLOC(struct tcltkip); - DATA_PTR(self) = ptr; - ptr->ref_count = 0; - ptr->allow_ruby_exit = 1; - ptr->return_value = 0; - - /* from Tk_Main() */ - DUMP1("Tcl_CreateInterp"); - ptr->ip = ruby_tcl_create_ip_and_stubs_init(&st); - if (ptr->ip == NULL) { - switch(st) { - case TCLTK_STUBS_OK: - break; - case NO_TCL_DLL: - rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll"); - case NO_FindExecutable: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable"); - case NO_CreateInterp: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()"); - case NO_DeleteInterp: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()"); - case FAIL_CreateInterp: - rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP"); - case FAIL_Tcl_InitStubs: - rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()"); - default: - rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_create_ip_and_stubs_init", st); - } - } - -#if TCL_MAJOR_VERSION >= 8 -#if TCL_NAMESPACE_DEBUG - DUMP1("get current namespace"); - if ((ptr->default_ns = Tcl_GetCurrentNamespace(ptr->ip)) - == (Tcl_Namespace*)NULL) { - rb_raise(rb_eRuntimeError, "a new Tk interpreter has a NULL namespace"); - } -#endif -#endif - - rbtk_preserve_ip(ptr); - DUMP2("IP ref_count = %d", ptr->ref_count); - current_interp = ptr->ip; - - ptr->has_orig_exit - = Tcl_GetCommandInfo(ptr->ip, "exit", &(ptr->orig_exit_info)); - - /* from Tcl_AppInit() */ - DUMP1("Tcl_Init"); - if (Tcl_Init(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); - } - - /* set variables */ - cnt = rb_scan_args(argc, argv, "02", &argv0, &opts); - switch(cnt) { - case 2: - /* options */ - if (NIL_P(opts) || opts == Qfalse) { - /* without Tk */ - with_tk = 0; - } else { - /* Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), 0); */ - Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), TCL_GLOBAL_ONLY); - } - case 1: - /* argv0 */ - if (!NIL_P(argv0)) { - if (strncmp(StringValuePtr(argv0), "-e", 3) == 0 - || strncmp(StringValuePtr(argv0), "-", 2) == 0) { - Tcl_SetVar(ptr->ip, "argv0", "ruby", TCL_GLOBAL_ONLY); - } else { - /* Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0); */ - Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), - TCL_GLOBAL_ONLY); - } - } - case 0: - /* no args */ - ; - } - - /* from Tcl_AppInit() */ - if (with_tk) { - DUMP1("Tk_Init"); - st = ruby_tk_stubs_init(ptr->ip); - switch(st) { - case TCLTK_STUBS_OK: - break; - case NO_Tk_Init: - rb_raise(rb_eLoadError, "tcltklib: can't find Tk_Init()"); - case FAIL_Tk_Init: - rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_Init(). %s", - Tcl_GetStringResult(ptr->ip)); - case FAIL_Tk_InitStubs: - rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_InitStubs(). %s", - Tcl_GetStringResult(ptr->ip)); - default: - rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st); - } - - DUMP1("Tcl_StaticPackage(\"Tk\")"); -#if TCL_MAJOR_VERSION >= 8 - Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, Tk_SafeInit); -#else /* TCL_MAJOR_VERSION < 8 */ - Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, - (Tcl_PackageInitProc *) NULL); -#endif - - /* get main window */ - mainWin = Tk_MainWindow(ptr->ip); - Tk_Preserve((ClientData)mainWin); - } - - /* add ruby command to the interpreter */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"ruby\")"); - Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL, - (Tcl_CmdDeleteProc *)NULL); - DUMP1("Tcl_CreateObjCommand(\"ruby_eval\")"); - Tcl_CreateObjCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL, - (Tcl_CmdDeleteProc *)NULL); - DUMP1("Tcl_CreateObjCommand(\"ruby_cmd\")"); - Tcl_CreateObjCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL, - (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"ruby\")"); - Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL, - (Tcl_CmdDeleteProc *)NULL); - DUMP1("Tcl_CreateCommand(\"ruby_eval\")"); - Tcl_CreateCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL, - (Tcl_CmdDeleteProc *)NULL); - DUMP1("Tcl_CreateCommand(\"ruby_cmd\")"); - Tcl_CreateCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL, - (Tcl_CmdDeleteProc *)NULL); -#endif - - /* add 'interp_exit', 'ruby_exit' and replace 'exit' command */ -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"interp_exit\")"); - Tcl_CreateObjCommand(ptr->ip, "interp_exit", ip_InterpExitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); - DUMP1("Tcl_CreateObjCommand(\"ruby_exit\")"); - Tcl_CreateObjCommand(ptr->ip, "ruby_exit", ip_RubyExitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); - DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\""); - Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"interp_exit\")"); - Tcl_CreateCommand(ptr->ip, "interp_exit", ip_InterpExitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); - DUMP1("Tcl_CreateCommand(\"ruby_exit\")"); - Tcl_CreateCommand(ptr->ip, "ruby_exit", ip_RubyExitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); - DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\""); - Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* replace vwait and tkwait */ - ip_replace_wait_commands(ptr->ip, mainWin); - - /* wrap namespace command */ - ip_wrap_namespace_command(ptr->ip); - - /* set finalizer */ - Tcl_CallWhenDeleted(ptr->ip, ip_CallWhenDeleted, (ClientData)mainWin); - - if (mainWin != (Tk_Window)NULL) { - Tk_Release((ClientData)mainWin); - } - - return self; -} - -static VALUE -ip_create_slave_core(interp, argc, argv) - VALUE interp; - int argc; - VALUE *argv; -{ - struct tcltkip *master = get_ip(interp); - struct tcltkip *slave = ALLOC(struct tcltkip); - VALUE safemode; - VALUE name; - int safe; - int thr_crit_bup; - Tk_Window mainWin; - - /* ip is deleted? */ - if (deleted_ip(master)) { - return rb_exc_new2(rb_eRuntimeError, - "deleted master cannot create a new slave"); - } - - name = argv[0]; - safemode = argv[1]; - - if (Tcl_IsSafe(master->ip) == 1) { - safe = 1; - } else if (safemode == Qfalse || NIL_P(safemode)) { - safe = 0; - /* rb_secure(4); */ /* already checked */ - } else { - safe = 1; - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - -#if 0 - /* init Tk */ - if (RTEST(with_tk)) { - volatile VALUE exc; - if (!tk_stubs_init_p()) { - exc = tcltkip_init_tk(interp); - if (!NIL_P(exc)) { - rb_thread_critical = thr_crit_bup; - return exc; - } - } - } -#endif - - /* create slave-ip */ - slave->ref_count = 0; - slave->allow_ruby_exit = 0; - slave->return_value = 0; - - slave->ip = Tcl_CreateSlave(master->ip, RSTRING(name)->ptr, safe); - if (slave->ip == NULL) { - rb_thread_critical = thr_crit_bup; - return rb_exc_new2(rb_eRuntimeError, - "fail to create the new slave interpreter"); - } -#if TCL_MAJOR_VERSION >= 8 -#if TCL_NAMESPACE_DEBUG - slave->default_ns = Tcl_GetCurrentNamespace(slave->ip); -#endif -#endif - rbtk_preserve_ip(slave); - - slave->has_orig_exit - = Tcl_GetCommandInfo(slave->ip, "exit", &(slave->orig_exit_info)); - - /* replace 'exit' command --> 'interp_exit' command */ - mainWin = (tk_stubs_init_p())? Tk_MainWindow(slave->ip): (Tk_Window)NULL; -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\""); - Tcl_CreateObjCommand(slave->ip, "exit", ip_InterpExitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\""); - Tcl_CreateCommand(slave->ip, "exit", ip_InterpExitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif - - /* replace vwait and tkwait */ - ip_replace_wait_commands(slave->ip, mainWin); - - /* wrap namespace command */ - ip_wrap_namespace_command(slave->ip); - - /* set finalizer */ - Tcl_CallWhenDeleted(slave->ip, ip_CallWhenDeleted, (ClientData)mainWin); - - rb_thread_critical = thr_crit_bup; - - return Data_Wrap_Struct(CLASS_OF(interp), 0, ip_free, slave); -} - -static VALUE -ip_create_slave(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - struct tcltkip *master = get_ip(self); - VALUE safemode; - VALUE name; - VALUE callargv[2]; - - /* ip is deleted? */ - if (deleted_ip(master)) { - rb_raise(rb_eRuntimeError, - "deleted master cannot create a new slave interpreter"); - } - - /* argument check */ - if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) { - safemode = Qfalse; - } - if (Tcl_IsSafe(master->ip) != 1 - && (safemode == Qfalse || NIL_P(safemode))) { - rb_secure(4); - } - - StringValue(name); - callargv[0] = name; - callargv[1] = safemode; - - return tk_funcall(ip_create_slave_core, 2, callargv, self); -} - -#if defined(MAC_TCL) || defined(__WIN32__) -#if TCL_MAJOR_VERSION < 8 \ - || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0) \ - || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \ - && (TCL_RELEASE_LEVEL == TCL_ALPHA_RELEASE \ - || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \ - && TCL_RELEASE_SERIAL < 2) ) ) -EXTERN void TkConsoleCreate _((void)); -#endif -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \ - && ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \ - && TCL_RELEASE_SERIAL == 0) \ - || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \ - && TCL_RELEASE_SERIAL >= 2) ) -EXTERN void TkConsoleCreate_ _((void)); -#endif -#endif -static VALUE -ip_create_console_core(interp, argc, argv) - VALUE interp; - int argc; /* dummy */ - VALUE *argv; /* dummy */ -{ - struct tcltkip *ptr = get_ip(interp); - - if (!tk_stubs_init_p()) { - tcltkip_init_tk(interp); - } - - if (Tcl_GetVar(ptr->ip,"tcl_interactive",TCL_GLOBAL_ONLY) == (char*)NULL) { - Tcl_SetVar(ptr->ip, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - } - -#if TCL_MAJOR_VERSION > 8 \ - || (TCL_MAJOR_VERSION == 8 \ - && (TCL_MINOR_VERSION > 1 \ - || (TCL_MINOR_VERSION == 1 \ - && TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \ - && TCL_RELEASE_SERIAL >= 1) ) ) - Tk_InitConsoleChannels(ptr->ip); - - if (Tk_CreateConsoleWindow(ptr->ip) != TCL_OK) { - rb_raise(rb_eRuntimeError, "fail to create console-window"); - } -#else -#if defined(MAC_TCL) || defined(__WIN32__) -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \ - && ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE && TCL_RELEASE_SERIAL == 0) \ - || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE && TCL_RELEASE_SERIAL >= 2) ) - TkConsoleCreate_(); -#else - TkConsoleCreate(); -#endif - - if (TkConsoleInit(ptr->ip) != TCL_OK) { - rb_raise(rb_eRuntimeError, "fail to create console-window"); - } -#else - rb_notimplement(); -#endif -#endif - - return interp; -} - -static VALUE -ip_create_console(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_raise(rb_eRuntimeError, "interpreter is deleted"); - } - - return tk_funcall(ip_create_console_core, 0, (VALUE*)NULL, self); -} - -/* make ip "safe" */ -static VALUE -ip_make_safe_core(interp, argc, argv) - VALUE interp; - int argc; /* dummy */ - VALUE *argv; /* dummy */ -{ - struct tcltkip *ptr = get_ip(interp); - Tk_Window mainWin; - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted"); - } - - if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) { - return rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); - } - - ptr->allow_ruby_exit = 0; - - /* replace 'exit' command --> 'interp_exit' command */ - mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL; -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\""); - Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\""); - Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif - - return interp; -} - -static VALUE -ip_make_safe(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_raise(rb_eRuntimeError, "interpreter is deleted"); - } - - return tk_funcall(ip_make_safe_core, 0, (VALUE*)NULL, self); -} - -/* is safe? */ -static VALUE -ip_is_safe_p(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_raise(rb_eRuntimeError, "interpreter is deleted"); - } - - if (Tcl_IsSafe(ptr->ip)) { - return Qtrue; - } else { - return Qfalse; - } -} - -/* allow_ruby_exit? */ -static VALUE -ip_allow_ruby_exit_p(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_raise(rb_eRuntimeError, "interpreter is deleted"); - } - - if (ptr->allow_ruby_exit) { - return Qtrue; - } else { - return Qfalse; - } -} - -/* allow_ruby_exit = mode */ -static VALUE -ip_allow_ruby_exit_set(self, val) - VALUE self, val; -{ - struct tcltkip *ptr = get_ip(self); - Tk_Window mainWin; - - rb_secure(4); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_raise(rb_eRuntimeError, "interpreter is deleted"); - } - - if (Tcl_IsSafe(ptr->ip)) { - rb_raise(rb_eSecurityError, - "insecure operation on a safe interpreter"); - } - - mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL; - - if (RTEST(val)) { - ptr->allow_ruby_exit = 1; -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\""); - Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\""); - Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif - return Qtrue; - - } else { - ptr->allow_ruby_exit = 0; -#if TCL_MAJOR_VERSION >= 8 - DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\""); - Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\""); - Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand, - (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); -#endif - return Qfalse; - } -} - -/* delete interpreter */ -static VALUE -ip_delete(self) - VALUE self; -{ - int thr_crit_bup; - struct tcltkip *ptr = get_ip(self); - Tcl_CmdInfo info; - - if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL) { - DUMP1("delete deleted IP"); - return Qnil; - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - DUMP1("call ip_finalize"); - ip_finalize(ptr->ip); - - DUMP1("delete interp"); - Tcl_DeleteInterp(ptr->ip); - Tcl_Release(ptr->ip); - - ptr->ip = (Tcl_Interp*)NULL; - - rb_thread_critical = thr_crit_bup; - - return Qnil; -} - - -/* is deleted? */ -static VALUE -ip_has_invalid_namespace_p(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL) { - /* deleted IP */ - return Qtrue; - } - -#if TCL_NAMESPACE_DEBUG - if (rbtk_invalid_namespace(ptr)) { - return Qtrue; - } else { - return Qfalse; - } -#else - return Qfalse; -#endif -} - -static VALUE -ip_is_deleted_p(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - if (deleted_ip(ptr)) { - return Qtrue; - } else { - return Qfalse; - } -} - -static VALUE -ip_has_mainwindow_p(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - if (deleted_ip(ptr) || !tk_stubs_init_p()) { - return Qnil; - } else if (Tk_MainWindow(ptr->ip) == (Tk_Window)NULL) { - return Qfalse; - } else { - return Qtrue; - } -} - -/*** ruby string <=> tcl object ***/ -#if TCL_MAJOR_VERSION >= 8 -static VALUE -get_str_from_obj(obj) - Tcl_Obj *obj; -{ - int len, binary = 0; - const char *s; - volatile VALUE str; - -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 - s = Tcl_GetStringFromObj(obj, &len); -#else /* TCL_VERSION >= 8.1 */ - if (Tcl_GetCharLength(obj) != Tcl_UniCharLen(Tcl_GetUnicode(obj))) { - /* possibly binary string */ - s = Tcl_GetByteArrayFromObj(obj, &len); - binary = 1; - } else { - /* possibly text string */ - s = Tcl_GetStringFromObj(obj, &len); - } -#endif - str = s ? rb_str_new(s, len) : rb_str_new2(""); - if (binary) rb_ivar_set(str, ID_at_enc, rb_str_new2("binary")); - return str; -} - -static Tcl_Obj * -get_obj_from_str(str) - VALUE str; -{ - const char *s = StringValuePtr(str); - -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 - return Tcl_NewStringObj((char*)s, RSTRING(str)->len); -#else /* TCL_VERSION >= 8.1 */ - VALUE enc = rb_attr_get(str, ID_at_enc); - - if (!NIL_P(enc)) { - StringValue(enc); - if (strcmp(RSTRING(enc)->ptr, "binary") == 0) { - /* binary string */ - return Tcl_NewByteArrayObj(s, RSTRING(str)->len); - } else { - /* text string */ - return Tcl_NewStringObj(s, RSTRING(str)->len); - } - } else if (strlen(s) != RSTRING(str)->len) { - /* probably binary string */ - return Tcl_NewByteArrayObj(s, RSTRING(str)->len); - } else { - /* probably text string */ - return Tcl_NewStringObj(s, RSTRING(str)->len); - } -#endif -} -#endif /* ruby string <=> tcl object */ - -static VALUE -ip_get_result_string_obj(interp) - Tcl_Interp *interp; -{ -#if TCL_MAJOR_VERSION >= 8 - Tcl_Obj *retObj; - volatile VALUE strval; - - retObj = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(retObj); - strval = get_str_from_obj(retObj); - OBJ_TAINT(strval); - Tcl_DecrRefCount(retObj); - return strval; -#else - return rb_tainted_str_new2(interp->result); -#endif -} - -/* call Tcl/Tk functions on the eventloop thread */ -static VALUE -callq_safelevel_handler(arg, callq) - VALUE arg; - VALUE callq; -{ - struct call_queue *q; - - Data_Get_Struct(callq, struct call_queue, q); - DUMP2("(safe-level handler) $SAFE = %d", q->safe_level); - rb_set_safe_level(q->safe_level); - return((q->func)(q->interp, q->argc, q->argv)); -} - -static int call_queue_handler _((Tcl_Event *, int)); -static int -call_queue_handler(evPtr, flags) - Tcl_Event *evPtr; - int flags; -{ - struct call_queue *q = (struct call_queue *)evPtr; - volatile VALUE ret; - volatile VALUE q_dat; - struct tcltkip *ptr; - - DUMP2("do_call_queue_handler : evPtr = %p", evPtr); - DUMP2("queue_handler thread : %lx", rb_thread_current()); - DUMP2("added by thread : %lx", q->thread); - - if (*(q->done)) { - DUMP1("processed by another event-loop"); - return 0; - } else { - DUMP1("process it on current event-loop"); - } - - /* process it */ - *(q->done) = 1; - - /* deleted ipterp ? */ - ptr = get_ip(q->interp); - if (deleted_ip(ptr)) { - /* deleted IP --> ignore */ - return 1; - } - - /* check safe-level */ - if (rb_safe_level() != q->safe_level) { - /* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */ - q_dat = Data_Wrap_Struct(rb_cData,call_queue_mark,0,q); - ret = rb_funcall(rb_proc_new(callq_safelevel_handler, q_dat), - ID_call, 0); - rb_gc_force_recycle(q_dat); - } else { - DUMP2("call function (for caller thread:%lx)", q->thread); - DUMP2("call function (current thread:%lx)", rb_thread_current()); - ret = (q->func)(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()); - rb_thread_run(q->thread); - DUMP1("finish back to caller"); - - /* end of handler : remove it */ - return 1; -} - -static VALUE -tk_funcall(func, argc, argv, obj) - VALUE (*func)(); - int argc; - VALUE *argv; - VALUE obj; -{ - struct call_queue *callq; - int *alloc_done; - int thr_crit_bup; - volatile VALUE current = rb_thread_current(); - volatile VALUE ip_obj = obj; - volatile VALUE result; - volatile VALUE ret; - - - if (!NIL_P(ip_obj) && deleted_ip(get_ip(ip_obj))) { - return Qnil; - } - - if (NIL_P(eventloop_thread) || current == eventloop_thread) { - if (NIL_P(eventloop_thread)) { - DUMP2("tk_funcall from thread:%lx but no eventloop", current); - } else { - DUMP2("tk_funcall from current eventloop %lx", current); - } - result = (func)(ip_obj, argc, argv); - if (rb_obj_is_kind_of(result, rb_eException)) { - rb_exc_raise(result); - } - return result; - } - - DUMP2("tk_funcall from thread %lx (NOT current eventloop)", current); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* allocate memory (argv cross over thread : must be in heap) */ - if (argv) { - VALUE *temp = ALLOC_N(VALUE, argc); - MEMCPY(temp, argv, VALUE, argc); - argv = temp; - } - - /* allocate memory (keep result) */ - alloc_done = (int*)ALLOC(int); - *alloc_done = 0; - - /* allocate memory (freed by Tcl_ServiceEvent) */ - callq = (struct call_queue *)Tcl_Alloc(sizeof(struct call_queue)); - Tcl_Preserve(callq); - - /* allocate result obj */ - result = rb_ary_new2(1); - RARRAY(result)->ptr[0] = Qnil; - RARRAY(result)->len = 1; - - /* construct event data */ - callq->done = alloc_done; - callq->func = func; - callq->argc = argc; - callq->argv = argv; - callq->interp = ip_obj; - callq->result = result; - callq->thread = current; - callq->safe_level = rb_safe_level(); - callq->ev.proc = call_queue_handler; - - /* add the handler to Tcl event queue */ - DUMP1("add handler"); - Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); - - rb_thread_critical = thr_crit_bup; - - /* wait for the handler to be processed */ - DUMP2("wait for handler (current thread:%lx)", current); - while(*alloc_done >= 0) { - rb_thread_stop(); - } - DUMP2("back from handler (current thread:%lx)", current); - - /* get result & free allocated memory */ - ret = RARRAY(result)->ptr[0]; - free(alloc_done); - if (argv) free(argv); - - Tcl_Release(callq); - - /* exception? */ - if (rb_obj_is_kind_of(ret, rb_eException)) { - DUMP1("raise exception"); - rb_exc_raise(ret); - } - - DUMP1("exit tk_funcall"); - return ret; -} - - -/* eval string in tcl by Tcl_Eval() */ -#if TCL_MAJOR_VERSION >= 8 -struct call_eval_info { - struct tcltkip *ptr; - Tcl_Obj *cmd; -}; - -static VALUE -call_tcl_eval(arg) - VALUE arg; -{ - struct call_eval_info *inf = (struct call_eval_info *)arg; - - inf->ptr->return_value = Tcl_EvalObj(inf->ptr->ip, inf->cmd); - - return Qnil; -} -#endif - -static VALUE -ip_eval_real(self, cmd_str, cmd_len) - VALUE self; - char *cmd_str; - int cmd_len; -{ - volatile VALUE ret; - struct tcltkip *ptr = get_ip(self); - int thr_crit_bup; - -#if TCL_MAJOR_VERSION >= 8 - /* call Tcl_EvalObj() */ - { - Tcl_Obj *cmd; - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - cmd = Tcl_NewStringObj(cmd_str, cmd_len); - Tcl_IncrRefCount(cmd); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - Tcl_DecrRefCount(cmd); - rb_thread_critical = thr_crit_bup; - ptr->return_value = TCL_OK; - return rb_tainted_str_new2(""); - } else { - int status; - struct call_eval_info inf; - - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - -#if 0 - ptr->return_value = Tcl_EvalObj(ptr->ip, cmd); - /* ptr->return_value = Tcl_GlobalEvalObj(ptr->ip, cmd); */ -#else - inf.ptr = ptr; - inf.cmd = cmd; - ret = rb_protect(call_tcl_eval, (VALUE)&inf, &status); - switch(status) { - case TAG_RAISE: - if (NIL_P(ruby_errinfo)) { - rbtk_pending_exception = rb_exc_new2(rb_eException, - "unknown exception"); - } else { - rbtk_pending_exception = ruby_errinfo; - } - break; - - case TAG_FATAL: - if (NIL_P(ruby_errinfo)) { - rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL"); - } else { - rbtk_pending_exception = ruby_errinfo; - } - } -#endif - } - - Tcl_DecrRefCount(cmd); - - } - - if (pending_exception_check1(thr_crit_bup, ptr)) { - rbtk_release_ip(ptr); - return rbtk_pending_exception; - } - - if (ptr->return_value == TCL_ERROR) { - if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) { - volatile VALUE exc; - exc = create_ip_exc(self, rb_eRuntimeError, - "%s", Tcl_GetStringResult(ptr->ip)); - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return exc; - } else { - if (event_loop_abort_on_exc < 0) { - rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip)); - } else { - rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip)); - } - Tcl_ResetResult(ptr->ip); - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return rb_tainted_str_new2(""); - } - } - - /* pass back the result (as string) */ - ret = ip_get_result_string_obj(ptr->ip); - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return ret; - -#else /* TCL_MAJOR_VERSION < 8 */ - DUMP2("Tcl_Eval(%s)", cmd_str); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - ptr->return_value = TCL_OK; - return rb_tainted_str_new2(""); - } else { - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - ptr->return_value = Tcl_Eval(ptr->ip, cmd_str); - /* ptr->return_value = Tcl_GlobalEval(ptr->ip, cmd_str); */ - } - - if (pending_exception_check1(thr_crit_bup, ptr)) { - rbtk_release_ip(ptr); - return rbtk_pending_exception; - } - - if (ptr->return_value == TCL_ERROR) { - volatile VALUE exc; - - exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result); - - rbtk_release_ip(ptr); - return exc; - } - DUMP2("(TCL_Eval result) %d", ptr->return_value); - - /* pass back the result (as string) */ - ret = ip_get_result_string_obj(ptr->ip); - rbtk_release_ip(ptr); - return ret; -#endif -} - -static VALUE -evq_safelevel_handler(arg, evq) - VALUE arg; - VALUE evq; -{ - struct eval_queue *q; - - Data_Get_Struct(evq, struct eval_queue, q); - DUMP2("(safe-level handler) $SAFE = %d", q->safe_level); - rb_set_safe_level(q->safe_level); - return ip_eval_real(q->interp, q->str, q->len); -} - -int eval_queue_handler _((Tcl_Event *, int)); -int -eval_queue_handler(evPtr, flags) - Tcl_Event *evPtr; - int flags; -{ - struct eval_queue *q = (struct eval_queue *)evPtr; - volatile VALUE ret; - volatile VALUE q_dat; - - if (*(q->done)) { - DUMP1("processed by another event-loop"); - return 0; - } else { - DUMP1("process it on current event-loop"); - } - - /* process it */ - *(q->done) = 1; - - /* check safe-level */ - if (rb_safe_level() != q->safe_level) { -#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,0,0,q); */ - 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); - rb_gc_force_recycle(q_dat); - } else { - 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()); - rb_thread_run(q->thread); - DUMP1("finish back to caller"); - - /* end of handler : remove it */ - return 1; -} - -static VALUE -ip_eval(self, str) - VALUE self; - VALUE str; -{ - struct eval_queue *evq; - char *eval_str; - int *alloc_done; - int thr_crit_bup; - volatile VALUE current = rb_thread_current(); - volatile VALUE ip_obj = self; - volatile VALUE result; - volatile VALUE ret; - Tcl_QueuePosition position; - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - StringValue(str); - rb_thread_critical = thr_crit_bup; - - if (NIL_P(eventloop_thread) || current == eventloop_thread) { - if (NIL_P(eventloop_thread)) { - DUMP2("eval from thread:%lx but no eventloop", current); - } else { - DUMP2("eval from current eventloop %lx", current); - } - result = ip_eval_real(self, RSTRING(str)->ptr, RSTRING(str)->len); - if (rb_obj_is_kind_of(result, rb_eException)) { - rb_exc_raise(result); - } - return result; - } - - 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_done = (int*)ALLOC(int); - *alloc_done = 0; - - eval_str = ALLOC_N(char, RSTRING(str)->len + 1); - memcpy(eval_str, RSTRING(str)->ptr, RSTRING(str)->len); - eval_str[RSTRING(str)->len] = 0; - - /* allocate memory (freed by Tcl_ServiceEvent) */ - evq = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); - Tcl_Preserve(evq); - - /* allocate result obj */ - result = rb_ary_new2(1); - RARRAY(result)->ptr[0] = Qnil; - RARRAY(result)->len = 1; - - /* construct event data */ - evq->done = alloc_done; - evq->str = eval_str; - evq->len = RSTRING(str)->len; - evq->interp = ip_obj; - evq->result = result; - evq->thread = current; - evq->safe_level = rb_safe_level(); - evq->ev.proc = eval_queue_handler; - - position = TCL_QUEUE_TAIL; - - /* add the handler to Tcl event queue */ - DUMP1("add handler"); - 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); - while(*alloc_done >= 0) { - rb_thread_stop(); - } - DUMP2("back from handler (current thread:%lx)", current); - - /* get result & free allocated memory */ - ret = RARRAY(result)->ptr[0]; - - free(alloc_done); - free(eval_str); - Tcl_Release(evq); - - if (rb_obj_is_kind_of(ret, rb_eException)) { - rb_exc_raise(ret); - } - - return ret; -} - - -/* restart Tk */ -static VALUE -lib_restart_core(interp, argc, argv) - VALUE interp; - int argc; /* dummy */ - VALUE *argv; /* dummy */ -{ - volatile VALUE exc; - struct tcltkip *ptr = get_ip(interp); - int thr_crit_bup; - int st; - - /* rb_secure(4); */ /* already checked */ - - /* tcl_stubs_check(); */ /* already checked */ - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted"); - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - - /* destroy the root wdiget */ - ptr->return_value = Tcl_Eval(ptr->ip, "destroy ."); - /* ignore ERROR */ - DUMP2("(TCL_Eval result) %d", ptr->return_value); - Tcl_ResetResult(ptr->ip); - -#if TCL_MAJOR_VERSION >= 8 - /* delete namespace ( tested on tk8.4.5 ) */ - ptr->return_value = Tcl_Eval(ptr->ip, "namespace delete ::tk::msgcat"); - /* ignore ERROR */ - DUMP2("(TCL_Eval result) %d", ptr->return_value); - Tcl_ResetResult(ptr->ip); -#endif - - /* delete trace proc ( tested on tk8.4.5 ) */ - ptr->return_value = Tcl_Eval(ptr->ip, "trace vdelete ::tk_strictMotif w ::tk::EventMotifBindings"); - /* ignore ERROR */ - DUMP2("(TCL_Eval result) %d", ptr->return_value); - Tcl_ResetResult(ptr->ip); - - /* execute Tk_Init or Tk_SafeInit */ - exc = tcltkip_init_tk(interp); - if (!NIL_P(exc)) { - rb_thread_critical = thr_crit_bup; - rbtk_release_ip(ptr); - return exc; - } - - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - - rb_thread_critical = thr_crit_bup; - - /* return Qnil; */ - return interp; -} - -static VALUE -lib_restart(self) - VALUE self; -{ - volatile VALUE exc; - struct tcltkip *ptr = get_ip(self); - int thr_crit_bup; - - rb_secure(4); - - tcl_stubs_check(); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_raise(rb_eRuntimeError, "interpreter is deleted"); - } - - return tk_funcall(lib_restart_core, 0, (VALUE*)NULL, self); -} - - -static VALUE -ip_restart(self) - VALUE self; -{ - struct tcltkip *ptr = get_ip(self); - - rb_secure(4); - - tcl_stubs_check(); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_raise(rb_eRuntimeError, "interpreter is deleted"); - } - - if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { - /* slave IP */ - return Qnil; - } - return lib_restart(self); -} - -static VALUE -lib_toUTF8_core(ip_obj, src, encodename) - VALUE ip_obj; - VALUE src; - VALUE encodename; -{ - volatile VALUE str = src; - -#ifdef TCL_UTF_MAX - Tcl_Interp *interp; - Tcl_Encoding encoding; - Tcl_DString dstr; - int taint_flag = OBJ_TAINTED(str); - struct tcltkip *ptr; - char *buf; - int thr_crit_bup; -#endif - - tcl_stubs_check(); - - if (NIL_P(src)) { - return rb_str_new2(""); - } - -#ifdef TCL_UTF_MAX - if (NIL_P(ip_obj)) { - interp = (Tcl_Interp *)NULL; - } else { - ptr = get_ip(ip_obj); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - interp = (Tcl_Interp *)NULL; - } else { - interp = ptr->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_attr_get(str, ID_at_enc); - if (NIL_P(enc)) { - if (NIL_P(ip_obj)) { - encoding = (Tcl_Encoding)NULL; - } else { - enc = rb_attr_get(ip_obj, ID_at_enc); - if (NIL_P(enc)) { - encoding = (Tcl_Encoding)NULL; - } else { - StringValue(enc); - 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); - */ - rb_raise(rb_eArgError, "unknown encoding name '%s'", - RSTRING(encodename)->ptr); - } - } - - StringValue(str); - if (!RSTRING(str)->len) { - rb_thread_critical = thr_crit_bup; - return str; - } - buf = ALLOC_N(char,(RSTRING(str)->len)+1); - memcpy(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); */ - Tcl_ExternalToUtfDString(encoding, buf, RSTRING(str)->len, &dstr); - - /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */ - /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */ - str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)); - rb_ivar_set(str, ID_at_enc, rb_tainted_str_new2("utf-8")); - if (taint_flag) OBJ_TAINT(str); - - 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_toUTF8(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - VALUE str, encodename; - - if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { - encodename = Qnil; - } - return lib_toUTF8_core(Qnil, str, encodename); -} - -static VALUE -ip_toUTF8(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - VALUE str, encodename; - - if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { - encodename = Qnil; - } - return lib_toUTF8_core(self, str, encodename); -} - -static VALUE -lib_fromUTF8_core(ip_obj, src, encodename) - VALUE ip_obj; - VALUE src; - VALUE encodename; -{ - volatile VALUE str = src; - -#ifdef TCL_UTF_MAX - Tcl_Interp *interp; - Tcl_Encoding encoding; - Tcl_DString dstr; - int taint_flag = OBJ_TAINTED(str); - char *buf; - int thr_crit_bup; -#endif - - tcl_stubs_check(); - - if (NIL_P(src)) { - return rb_str_new2(""); - } - -#ifdef TCL_UTF_MAX - if (NIL_P(ip_obj)) { - interp = (Tcl_Interp *)NULL; - } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) { - interp = (Tcl_Interp *)NULL; - } else { - interp = get_ip(ip_obj)->ip; - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - if (NIL_P(encodename)) { - volatile VALUE enc; - - if (TYPE(str) == T_STRING) { - enc = rb_attr_get(str, ID_at_enc); - if (!NIL_P(enc)) { - StringValue(enc); - if (strcmp(RSTRING(enc)->ptr, "binary") == 0) { - rb_thread_critical = thr_crit_bup; - return str; - } - } - } - - if (NIL_P(ip_obj)) { - encoding = (Tcl_Encoding)NULL; - } else { - enc = rb_attr_get(ip_obj, ID_at_enc); - if (NIL_P(enc)) { - encoding = (Tcl_Encoding)NULL; - } else { - StringValue(enc); - 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; - */ - rb_raise(rb_eArgError, "unknown encoding name '%s'", - RSTRING(encodename)->ptr); - } - } - - StringValue(str); - - 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); - memcpy(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); */ - Tcl_UtfToExternalDString(encoding,buf,RSTRING(str)->len,&dstr); - - /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */ - /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */ - str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)); - rb_ivar_set(str, ID_at_enc, encodename); - - if (taint_flag) OBJ_TAINT(str); - - 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 -ip_fromUTF8(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - VALUE str, encodename; - - if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { - encodename = Qnil; - } - return lib_fromUTF8_core(self, str, encodename); -} - -static VALUE -lib_UTF_backslash_core(self, str, all_bs) - VALUE self; - VALUE str; - int all_bs; -{ -#ifdef TCL_UTF_MAX - char *src_buf, *dst_buf, *ptr; - int read_len = 0, dst_len = 0; - int taint_flag = OBJ_TAINTED(str); - int thr_crit_bup; - - tcl_stubs_check(); - - StringValue(str); - if (!RSTRING(str)->len) { - return str; - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - src_buf = ALLOC_N(char,(RSTRING(str)->len)+1); - memcpy(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); -} - -static VALUE -lib_get_system_encoding(self) - VALUE self; -{ -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) - tcl_stubs_check(); - return rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL)); -#else - return Qnil; -#endif -} - -static VALUE -lib_set_system_encoding(self, enc_name) - VALUE self; - VALUE enc_name; -{ -#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) - tcl_stubs_check(); - - if (NIL_P(enc_name)) { - Tcl_SetSystemEncoding((Tcl_Interp *)NULL, (CONST char *)NULL); - return lib_get_system_encoding(self); - } - - enc_name = rb_funcall(enc_name, ID_to_s, 0, 0); - if (Tcl_SetSystemEncoding((Tcl_Interp *)NULL, - RSTRING(enc_name)->ptr) != TCL_OK) { - rb_raise(rb_eArgError, "unknown encoding name '%s'", - RSTRING(enc_name)->ptr); - } - - return enc_name; -#else - return Qnil; -#endif -} - - -/* invoke Tcl proc */ -struct invoke_info { - struct tcltkip *ptr; - Tcl_CmdInfo cmdinfo; -#if TCL_MAJOR_VERSION >= 8 - int objc; - Tcl_Obj **objv; -#else - int argc; - char **argv; -#endif -}; - -static VALUE -invoke_tcl_proc(arg) - VALUE arg; -{ - struct invoke_info *inf = (struct invoke_info *)arg; - int i, len; -#if TCL_MAJOR_VERSION >= 8 - int argc = inf->objc; - char **argv = (char **)NULL; -#endif - - /* memory allocation for arguments of this command */ -#if TCL_MAJOR_VERSION >= 8 - if (!inf->cmdinfo.isNativeObjectProc) { - /* string interface */ - argv = (char **)ALLOC_N(char *, argc+1); - for (i = 0; i < argc; ++i) { - argv[i] = Tcl_GetStringFromObj(inf->objv[i], &len); - } - argv[argc] = (char *)NULL; - } -#endif - - Tcl_ResetResult(inf->ptr->ip); - - /* Invoke the C procedure */ -#if TCL_MAJOR_VERSION >= 8 - if (inf->cmdinfo.isNativeObjectProc) { - inf->ptr->return_value - = (*(inf->cmdinfo.objProc))(inf->cmdinfo.objClientData, - inf->ptr->ip, inf->objc, inf->objv); - } - else -#endif - { -#if TCL_MAJOR_VERSION >= 8 - inf->ptr->return_value - = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip, - argc, (CONST84 char **)argv); - - free(argv); - -#else /* TCL_MAJOR_VERSION < 8 */ - inf->ptr->return_value - = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip, - inf->argc, inf->argv); -#endif - } - - return Qnil; -} - - -#if TCL_MAJOR_VERSION >= 8 -static VALUE -ip_invoke_core(interp, objc, objv) - VALUE interp; - int objc; - Tcl_Obj **objv; -#else -static VALUE -ip_invoke_core(interp, argc, argv) - VALUE interp; - int argc; - char **argv; -#endif -{ - struct tcltkip *ptr; - int i; - Tcl_CmdInfo info; - char *cmd; - char *s; - int len; - int thr_crit_bup; - struct invoke_info inf; - int status; - int unknown_flag = 0; - VALUE ret; - -#if TCL_MAJOR_VERSION >= 8 - int argc = objc; - char **argv = (char **)NULL; - Tcl_Obj *resultPtr; -#endif - - /* get the command name string */ -#if TCL_MAJOR_VERSION >= 8 - cmd = Tcl_GetStringFromObj(objv[0], &len); -#else /* TCL_MAJOR_VERSION < 8 */ - cmd = argv[0]; -#endif - - /* get the data struct */ - ptr = get_ip(interp); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return rb_tainted_str_new2(""); - } - - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - - /* map from the command name to a C procedure */ - DUMP2("call Tcl_GetCommandInfo, %s", cmd); - if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) { - DUMP1("error Tcl_GetCommandInfo"); - DUMP1("try auto_load (call 'unknown' command)"); - if (!Tcl_GetCommandInfo(ptr->ip, -#if TCL_MAJOR_VERSION >= 8 - "::unknown", -#else - "unknown", -#endif - &info)) { - DUMP1("fail to get 'unknown' command"); - /* if (event_loop_abort_on_exc || cmd[0] != '.') { */ - if (event_loop_abort_on_exc > 0) { - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - /*rb_ip_raise(obj,rb_eNameError,"invalid command name `%s'",cmd);*/ - return create_ip_exc(interp, rb_eNameError, - "invalid command name `%s'", cmd); - } else { - if (event_loop_abort_on_exc < 0) { - rb_warning("invalid command name `%s' (ignore)", cmd); - } else { - rb_warn("invalid command name `%s' (ignore)", cmd); - } - Tcl_ResetResult(ptr->ip); - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - return rb_tainted_str_new2(""); - } - } else { -#if TCL_MAJOR_VERSION >= 8 - Tcl_Obj **unknown_objv; -#else - char **unknown_argv; -#endif - DUMP1("find 'unknown' command -> set arguemnts"); - unknown_flag = 1; - -#if TCL_MAJOR_VERSION >= 8 - unknown_objv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, objc+2); - unknown_objv[0] = Tcl_NewStringObj("::unknown", 9); - Tcl_IncrRefCount(unknown_objv[0]); - memcpy(unknown_objv + 1, objv, sizeof(Tcl_Obj *)*objc); - unknown_objv[++objc] = (Tcl_Obj*)NULL; - objv = unknown_objv; -#else - unknown_argv = (char **)ALLOC_N(char *, argc+2); - unknown_argv[0] = strdup("unknown"); - memcpy(unknown_argv + 1, argv, sizeof(char *)*argc); - unknown_argv[++argc] = (char *)NULL; - argv = unknown_argv; -#endif - } - } - DUMP1("end Tcl_GetCommandInfo"); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - -#if 1 /* wrap tcl-proc call */ - /* setup params */ - inf.ptr = ptr; - inf.cmdinfo = info; -#if TCL_MAJOR_VERSION >= 8 - inf.objc = objc; - inf.objv = objv; -#else - inf.argc = argc; - inf.argv = argv; -#endif - - /* invoke tcl-proc */ - ret = rb_protect(invoke_tcl_proc, (VALUE)&inf, &status); - switch(status) { - case TAG_RAISE: - if (NIL_P(ruby_errinfo)) { - rbtk_pending_exception = rb_exc_new2(rb_eException, - "unknown exception"); - } else { - rbtk_pending_exception = ruby_errinfo; - } - break; - - case TAG_FATAL: - if (NIL_P(ruby_errinfo)) { - rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL"); - } else { - rbtk_pending_exception = ruby_errinfo; - } - } - -#else /* !wrap tcl-proc call */ - - /* memory allocation for arguments of this command */ -#if TCL_MAJOR_VERSION >= 8 - if (!info.isNativeObjectProc) { - /* string interface */ - argv = (char **)ALLOC_N(char *, argc+1); - for (i = 0; i < argc; ++i) { - argv[i] = Tcl_GetStringFromObj(objv[i], &len); - } - argv[argc] = (char *)NULL; - } -#endif - - Tcl_ResetResult(ptr->ip); - - /* Invoke the C procedure */ -#if TCL_MAJOR_VERSION >= 8 - if (info.isNativeObjectProc) { - ptr->return_value = (*info.objProc)(info.objClientData, ptr->ip, - objc, objv); -#if 0 - /* get the string value from the result object */ - resultPtr = Tcl_GetObjResult(ptr->ip); - Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &len), - TCL_VOLATILE); -#endif - } - else -#endif - { -#if TCL_MAJOR_VERSION >= 8 - ptr->return_value = (*info.proc)(info.clientData, ptr->ip, - argc, (CONST84 char **)argv); - - free(argv); - -#else /* TCL_MAJOR_VERSION < 8 */ - ptr->return_value = (*info.proc)(info.clientData, ptr->ip, - argc, argv); -#endif - } -#endif /* ! wrap tcl-proc call */ - - /* free allocated memory for calling 'unknown' command */ - if (unknown_flag) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(objv[0]); - free(objv); -#else - free(argv[0]); - free(argv); -#endif - } - - /* exception on mainloop */ - if (pending_exception_check1(thr_crit_bup, ptr)) { - return rbtk_pending_exception; - } - - rb_thread_critical = thr_crit_bup; - - if (ptr->return_value == TCL_ERROR) { - if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) { - - return create_ip_exc(interp, rb_eRuntimeError, - "%s", Tcl_GetStringResult(ptr->ip)); - } else { - if (event_loop_abort_on_exc < 0) { - rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip)); - } else { - rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip)); - } - Tcl_ResetResult(ptr->ip); - return rb_tainted_str_new2(""); - } - } - - /* pass back the result (as string) */ - return ip_get_result_string_obj(ptr->ip); -} - - -#if TCL_MAJOR_VERSION >= 8 -static Tcl_Obj ** -#else /* TCL_MAJOR_VERSION < 8 */ -static char ** -#endif -alloc_invoke_arguments(argc, argv) - int argc; - VALUE *argv; -{ - int i; - int thr_crit_bup; - -#if TCL_MAJOR_VERSION >= 8 - Tcl_Obj **av; -#else /* TCL_MAJOR_VERSION < 8 */ - char **av; -#endif - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* memory allocation */ -#if TCL_MAJOR_VERSION >= 8 - av = ALLOC_N(Tcl_Obj *, argc+1); - for (i = 0; i < argc; ++i) { - av[i] = get_obj_from_str(argv[i]); - Tcl_IncrRefCount(av[i]); - } - av[argc] = NULL; - -#else /* TCL_MAJOR_VERSION < 8 */ - /* string interface */ - av = ALLOC_N(char *, argc+1); - for (i = 0; i < argc; ++i) { - av[i] = strdup(StringValuePtr(argv[i])); - } - av[argc] = NULL; -#endif - - rb_thread_critical = thr_crit_bup; - - return av; -} - -static void -free_invoke_arguments(argc, av) - int argc; -#if TCL_MAJOR_VERSION >= 8 - Tcl_Obj **av; -#else /* TCL_MAJOR_VERSION < 8 */ - char **av; -#endif -{ - int i; - - for (i = 0; i < argc; ++i) { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DecrRefCount(av[i]); -#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 */ - -#if TCL_MAJOR_VERSION >= 8 - Tcl_Obj **av = (Tcl_Obj **)NULL; -#else /* TCL_MAJOR_VERSION < 8 */ - char **av = (char **)NULL; -#endif - - DUMP2("invoke_real called by thread:%lx", rb_thread_current()); - - /* get the data struct */ - ptr = get_ip(interp); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return rb_tainted_str_new2(""); - } - - /* allocate memory for arguments */ - av = alloc_invoke_arguments(argc, argv); - - /* Invoke the C procedure */ - Tcl_ResetResult(ptr->ip); - v = ip_invoke_core(interp, argc, av); - - /* free allocated memory */ - free_invoke_arguments(argc, av); - - return v; -} - -VALUE -ivq_safelevel_handler(arg, ivq) - VALUE arg; - VALUE ivq; -{ - struct invoke_queue *q; - - Data_Get_Struct(ivq, struct invoke_queue, q); - DUMP2("(safe-level handler) $SAFE = %d", q->safe_level); - rb_set_safe_level(q->safe_level); - return ip_invoke_core(q->interp, q->argc, q->argv); -} - -int invoke_queue_handler _((Tcl_Event *, int)); -int -invoke_queue_handler(evPtr, flags) - Tcl_Event *evPtr; - int flags; -{ - struct invoke_queue *q = (struct invoke_queue *)evPtr; - volatile VALUE ret; - volatile VALUE q_dat; - - 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)) { - DUMP1("processed by another event-loop"); - return 0; - } else { - DUMP1("process it on current event-loop"); - } - - /* process it */ - *(q->done) = 1; - - /* check safe-level */ - if (rb_safe_level() != q->safe_level) { - /* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */ - q_dat = Data_Wrap_Struct(rb_cData,invoke_queue_mark,0,q); - ret = rb_funcall(rb_proc_new(ivq_safelevel_handler, q_dat), - ID_call, 0); - rb_gc_force_recycle(q_dat); - } else { - 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()); - rb_thread_run(q->thread); - DUMP1("finish back to caller"); - - /* end of handler : remove it */ - return 1; -} - -static VALUE -ip_invoke_with_position(argc, argv, obj, position) - int argc; - VALUE *argv; - VALUE obj; - Tcl_QueuePosition position; -{ - struct invoke_queue *ivq; - char *s; - int len; - int i; - int *alloc_done; - int thr_crit_bup; - volatile VALUE current = rb_thread_current(); - volatile VALUE ip_obj = obj; - volatile VALUE result; - 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"); - } - if (NIL_P(eventloop_thread) || current == eventloop_thread) { - if (NIL_P(eventloop_thread)) { - DUMP2("invoke from thread:%lx but no eventloop", current); - } else { - DUMP2("invoke from current eventloop %lx", current); - } - result = ip_invoke_real(argc, argv, ip_obj); - if (rb_obj_is_kind_of(result, rb_eException)) { - rb_exc_raise(result); - } - return result; - } - - DUMP2("invoke from thread %lx (NOT current eventloop)", current); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* allocate memory (for arguments) */ - av = alloc_invoke_arguments(argc, argv); - - /* allocate memory (keep result) */ - alloc_done = (int*)ALLOC(int); - *alloc_done = 0; - - /* allocate memory (freed by Tcl_ServiceEvent) */ - ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); - Tcl_Preserve(ivq); - - /* allocate result obj */ - result = rb_ary_new2(1); - RARRAY(result)->ptr[0] = Qnil; - RARRAY(result)->len = 1; - - /* construct event data */ - ivq->done = alloc_done; - ivq->argc = argc; - ivq->argv = av; - ivq->interp = ip_obj; - ivq->result = result; - ivq->thread = current; - ivq->safe_level = rb_safe_level(); - ivq->ev.proc = invoke_queue_handler; - - /* add the handler to Tcl event queue */ - DUMP1("add handler"); - 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); - while(*alloc_done >= 0) { - rb_thread_stop(); - } - DUMP2("back from handler (current thread:%lx)", current); - - /* get result & free allocated memory */ - ret = RARRAY(result)->ptr[0]; - free(alloc_done); - - Tcl_Release(ivq); - - /* 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); - } - - DUMP1("exit ip_invoke"); - return ret; -} - - -/* get return code from Tcl_Eval() */ -static VALUE -ip_retval(self) - VALUE self; -{ - struct tcltkip *ptr; /* tcltkip data struct */ - - /* get the data strcut */ - ptr = get_ip(self); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return rb_tainted_str_new2(""); - } - - return (INT2FIX(ptr->return_value)); -} - -static VALUE -ip_invoke(argc, argv, obj) - int argc; - VALUE *argv; - VALUE obj; -{ - return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_TAIL); -} - -static VALUE -ip_invoke_immediate(argc, argv, obj) - int argc; - VALUE *argv; - VALUE obj; -{ - return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_HEAD); -} - - -/* access Tcl variables */ -static VALUE -ip_get_variable2_core(interp, argc, argv) - VALUE interp; - int argc; - VALUE *argv; -{ - struct tcltkip *ptr = get_ip(interp); - int thr_crit_bup; - volatile VALUE varname, index, flag; - - varname = argv[0]; - index = argv[1]; - flag = argv[2]; - - /* - StringValue(varname); - if (!NIL_P(index)) StringValue(index); - */ - -#if TCL_MAJOR_VERSION >= 8 - { - Tcl_Obj *ret; - volatile VALUE strval; - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - rb_thread_critical = thr_crit_bup; - return rb_tainted_str_new2(""); - } else { - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - ret = Tcl_GetVar2Ex(ptr->ip, RSTRING(varname)->ptr, - NIL_P(index) ? NULL : RSTRING(index)->ptr, - FIX2INT(flag)); - } - - if (ret == (Tcl_Obj*)NULL) { - volatile VALUE exc; - exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return exc; - } - - Tcl_IncrRefCount(ret); - strval = get_str_from_obj(ret); - OBJ_TAINT(strval); - Tcl_DecrRefCount(ret); - - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return(strval); - } -#else /* TCL_MAJOR_VERSION < 8 */ - { - char *ret; - volatile VALUE strval; - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return rb_tainted_str_new2(""); - } else { - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - ret = Tcl_GetVar2(ptr->ip, RSTRING(varname)->ptr, - NIL_P(index) ? NULL : RSTRING(index)->ptr, - FIX2INT(flag)); - } - - if (ret == (char*)NULL) { - volatile VALUE exc; - exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return exc; - } - - strval = rb_tainted_str_new2(ret); - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - - return(strval); - } -#endif -} - -static VALUE -ip_get_variable2(self, varname, index, flag) - VALUE self; - VALUE varname; - VALUE index; - VALUE flag; -{ - VALUE argv[3]; - VALUE retval; - - StringValue(varname); - if (!NIL_P(index)) StringValue(index); - - argv[0] = varname; - argv[1] = index; - argv[2] = flag; - - retval = tk_funcall(ip_get_variable2_core, 3, argv, self); - - if (NIL_P(retval)) { - return rb_tainted_str_new2(""); - } else { - return retval; - } -} - -static VALUE -ip_get_variable(self, varname, flag) - VALUE self; - VALUE varname; - VALUE flag; -{ - return ip_get_variable2(self, varname, Qnil, flag); -} - -static VALUE -ip_set_variable2_core(interp, argc, argv) - VALUE interp; - int argc; - VALUE *argv; -{ - struct tcltkip *ptr = get_ip(interp); - int thr_crit_bup; - volatile VALUE varname, index, value, flag; - - varname = argv[0]; - index = argv[1]; - value = argv[2]; - flag = argv[3]; - - /* - StringValue(varname); - if (!NIL_P(index)) StringValue(index); - StringValue(value); - */ - -#if TCL_MAJOR_VERSION >= 8 - { - Tcl_Obj *valobj, *ret; - volatile VALUE strval; - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - valobj = get_obj_from_str(value); - Tcl_IncrRefCount(valobj); - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - Tcl_DecrRefCount(valobj); - rb_thread_critical = thr_crit_bup; - return rb_tainted_str_new2(""); - } else { - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - ret = Tcl_SetVar2Ex(ptr->ip, RSTRING(varname)->ptr, - NIL_P(index) ? NULL : RSTRING(index)->ptr, - valobj, FIX2INT(flag)); - } - - Tcl_DecrRefCount(valobj); - - if (ret == (Tcl_Obj*)NULL) { - volatile VALUE exc; - exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - return exc; - } - - Tcl_IncrRefCount(ret); - strval = get_str_from_obj(ret); - OBJ_TAINT(strval); - Tcl_DecrRefCount(ret); - - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - - return(strval); - } -#else /* TCL_MAJOR_VERSION < 8 */ - { - CONST char *ret; - volatile VALUE strval; - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return rb_tainted_str_new2(""); - } else { - /* Tcl_Preserve(ptr->ip); */ - rbtk_preserve_ip(ptr); - ret = Tcl_SetVar2(ptr->ip, RSTRING(varname)->ptr, - NIL_P(index) ? NULL : RSTRING(index)->ptr, - RSTRING(value)->ptr, FIX2INT(flag)); - } - - if (ret == (char*)NULL) { - return rb_exc_new2(rb_eRuntimeError, ptr->ip->result); - } - - strval = rb_tainted_str_new2(ret); - - /* Tcl_Release(ptr->ip); */ - rbtk_release_ip(ptr); - rb_thread_critical = thr_crit_bup; - - return(strval); - } -#endif -} - -static VALUE -ip_set_variable2(self, varname, index, value, flag) - VALUE self; - VALUE varname; - VALUE index; - VALUE value; - VALUE flag; -{ - VALUE argv[4]; - VALUE retval; - - StringValue(varname); - if (!NIL_P(index)) StringValue(index); - StringValue(value); - - argv[0] = varname; - argv[1] = index; - argv[2] = value; - argv[3] = flag; - - retval = tk_funcall(ip_set_variable2_core, 4, argv, self); - - if (NIL_P(retval)) { - return rb_tainted_str_new2(""); - } else { - return retval; - } -} - -static VALUE -ip_set_variable(self, varname, value, flag) - VALUE self; - VALUE varname; - VALUE value; - VALUE flag; -{ - return ip_set_variable2(self, varname, Qnil, value, flag); -} - -static VALUE -ip_unset_variable2_core(interp, argc, argv) - VALUE interp; - int argc; - VALUE *argv; -{ - struct tcltkip *ptr = get_ip(interp); - volatile VALUE varname, index, flag; - - varname = argv[0]; - index = argv[1]; - flag = argv[2]; - - /* - StringValue(varname); - if (!NIL_P(index)) StringValue(index); - */ - - /* ip is deleted? */ - if (deleted_ip(ptr)) { - return Qtrue; - } - - ptr->return_value = Tcl_UnsetVar2(ptr->ip, RSTRING(varname)->ptr, - NIL_P(index) ? NULL : RSTRING(index)->ptr, - FIX2INT(flag)); - - if (ptr->return_value == TCL_ERROR) { - if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) { - return rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); - } - return Qfalse; - } - return Qtrue; -} - -static VALUE -ip_unset_variable2(self, varname, index, flag) - VALUE self; - VALUE varname; - VALUE index; - VALUE flag; -{ - VALUE argv[3]; - VALUE retval; - - StringValue(varname); - if (!NIL_P(index)) StringValue(index); - - argv[0] = varname; - argv[1] = index; - argv[2] = flag; - - retval = tk_funcall(ip_unset_variable2_core, 3, argv, self); - - if (NIL_P(retval)) { - return rb_tainted_str_new2(""); - } else { - return retval; - } -} - -static VALUE -ip_unset_variable(self, varname, flag) - VALUE self; - VALUE varname; - VALUE flag; -{ - return ip_unset_variable2(self, varname, Qnil, flag); -} - -static VALUE -ip_get_global_var(self, varname) - VALUE self; - VALUE varname; -{ - return ip_get_variable(self, varname, - INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); -} - -static VALUE -ip_get_global_var2(self, varname, index) - VALUE self; - VALUE varname; - VALUE index; -{ - return ip_get_variable2(self, varname, index, - INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); -} - -static VALUE -ip_set_global_var(self, varname, value) - VALUE self; - VALUE varname; - VALUE value; -{ - return ip_set_variable(self, varname, value, - INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); -} - -static VALUE -ip_set_global_var2(self, varname, index, value) - VALUE self; - VALUE varname; - VALUE index; - VALUE value; -{ - return ip_set_variable2(self, varname, index, value, - INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); -} - -static VALUE -ip_unset_global_var(self, varname) - VALUE self; - VALUE varname; -{ - return ip_unset_variable(self, varname, - INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); -} - -static VALUE -ip_unset_global_var2(self, varname, index) - VALUE self; - VALUE varname; - VALUE index; -{ - return ip_unset_variable2(self, varname, index, - INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); -} - - -/* treat Tcl_List */ -static VALUE -lib_split_tklist_core(ip_obj, list_str) - VALUE ip_obj; - VALUE list_str; -{ - Tcl_Interp *interp; - volatile VALUE ary, elem; - int idx; - int taint_flag = OBJ_TAINTED(list_str); - int result; - VALUE old_gc; - - tcl_stubs_check(); - - if (NIL_P(ip_obj)) { - interp = (Tcl_Interp *)NULL; - } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) { - interp = (Tcl_Interp *)NULL; - } else { - interp = get_ip(ip_obj)->ip; - } - - StringValue(list_str); - - { -#if TCL_MAJOR_VERSION >= 8 - /* object style interface */ - Tcl_Obj *listobj; - int objc; - Tcl_Obj **objv; - int thr_crit_bup; - - listobj = get_obj_from_str(list_str); - - Tcl_IncrRefCount(listobj); - - result = Tcl_ListObjGetElements(interp, listobj, &objc, &objv); - - if (result == TCL_ERROR) { - Tcl_DecrRefCount(listobj); - if (interp == (Tcl_Interp*)NULL) { - rb_raise(rb_eRuntimeError, "can't get elements from list"); - } else { - rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(interp)); - } - } - - for(idx = 0; idx < objc; idx++) { - Tcl_IncrRefCount(objv[idx]); - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - ary = rb_ary_new2(objc); - if (taint_flag) OBJ_TAINT(ary); - - old_gc = rb_gc_disable(); - - for(idx = 0; idx < objc; idx++) { - elem = get_str_from_obj(objv[idx]); - 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, "can't 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(""); - - tcl_stubs_check(); - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - old_gc = rb_gc_disable(); - - /* based on Tcl/Tk's Tcl_Merge() */ - flagPtr = ALLOC_N(int, argc); - - /* 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; - - tcl_stubs_check(); - - 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; -} - - -static VALUE -tcltklib_compile_info() -{ - volatile VALUE ret; - int size; - char form[] - = "tcltklib %s :: Ruby%s (%s) %s pthread :: Tcl%s(%s)/Tk%s(%s) %s"; - char *info; - - size = strlen(form) - + strlen(TCLTKLIB_RELEASE_DATE) - + strlen(RUBY_VERSION) - + strlen(RUBY_RELEASE_DATE) - + strlen("without") - + strlen(TCL_PATCH_LEVEL) - + strlen("without stub") - + strlen(TK_PATCH_LEVEL) - + strlen("without stub") - + strlen("unknown tcl_threads"); - - info = ALLOC_N(char, size); - - sprintf(info, form, - TCLTKLIB_RELEASE_DATE, - RUBY_VERSION, RUBY_RELEASE_DATE, -#ifdef HAVE_NATIVETHREAD - "with", -#else - "without", -#endif - TCL_PATCH_LEVEL, -#ifdef USE_TCL_STUBS - "with stub", -#else - "without stub", -#endif - TK_PATCH_LEVEL, -#ifdef USE_TK_STUBS - "with stub", -#else - "without stub", -#endif -#ifdef WITH_TCL_ENABLE_THREAD -# if WITH_TCL_ENABLE_THREAD - "with tcl_threads" -# else - "without tcl_threads" -# endif -#else - "unknown tcl_threads" -#endif - ); - - ret = rb_obj_freeze(rb_str_new2(info)); - - free(info); - - return ret; -} - - -/*---- initialization ----*/ -void -Init_tcltklib() -{ - int thr_crit_bup; - int ret; - - VALUE lib = rb_define_module("TclTkLib"); - VALUE ip = rb_define_class("TclTkIp", rb_cObject); - - VALUE ev_flag = rb_define_module_under(lib, "EventFlag"); - VALUE var_flag = rb_define_module_under(lib, "VarAccessFlag"); - - /* --------------------------------------------------------------- */ - - rb_global_variable(&eTkCallbackReturn); - rb_global_variable(&eTkCallbackBreak); - rb_global_variable(&eTkCallbackContinue); - - rb_global_variable(&eventloop_thread); - rb_global_variable(&eventloop_stack); - rb_global_variable(&watchdog_thread); - - rb_global_variable(&rbtk_pending_exception); - - /* --------------------------------------------------------------- */ - - rb_define_const(lib, "COMPILE_INFO", tcltklib_compile_info()); - - rb_define_const(lib, "RELEASE_DATE", - rb_obj_freeze(rb_str_new2(tcltklib_release_date))); - - rb_define_const(lib, "FINALIZE_PROC_NAME", - rb_str_new2(finalize_hook_name)); - - /* --------------------------------------------------------------- */ - - rb_define_const(ev_flag, "NONE", INT2FIX(0)); - rb_define_const(ev_flag, "WINDOW", INT2FIX(TCL_WINDOW_EVENTS)); - rb_define_const(ev_flag, "FILE", INT2FIX(TCL_FILE_EVENTS)); - rb_define_const(ev_flag, "TIMER", INT2FIX(TCL_TIMER_EVENTS)); - rb_define_const(ev_flag, "IDLE", INT2FIX(TCL_IDLE_EVENTS)); - rb_define_const(ev_flag, "ALL", INT2FIX(TCL_ALL_EVENTS)); - rb_define_const(ev_flag, "DONT_WAIT", INT2FIX(TCL_DONT_WAIT)); - - /* --------------------------------------------------------------- */ - - rb_define_const(var_flag, "NONE", INT2FIX(0)); - rb_define_const(var_flag, "GLOBAL_ONLY", INT2FIX(TCL_GLOBAL_ONLY)); -#ifdef TCL_NAMESPACE_ONLY - rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(TCL_NAMESPACE_ONLY)); -#else /* probably Tcl7.6 */ - rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(0)); -#endif - rb_define_const(var_flag, "LEAVE_ERR_MSG", INT2FIX(TCL_LEAVE_ERR_MSG)); - rb_define_const(var_flag, "APPEND_VALUE", INT2FIX(TCL_APPEND_VALUE)); - rb_define_const(var_flag, "LIST_ELEMENT", INT2FIX(TCL_LIST_ELEMENT)); -#ifdef TCL_PARSE_PART1 - rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(TCL_PARSE_PART1)); -#else /* probably Tcl7.6 */ - rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(0)); -#endif - - /* --------------------------------------------------------------- */ - - eTkCallbackReturn = rb_define_class("TkCallbackReturn", rb_eStandardError); - eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError); - eTkCallbackContinue = rb_define_class("TkCallbackContinue", - rb_eStandardError); - - /* --------------------------------------------------------------- */ - - eLocalJumpError = rb_const_get(rb_cObject, rb_intern("LocalJumpError")); - - eTkLocalJumpError = rb_define_class("TkLocalJumpError", eLocalJumpError); - - eTkCallbackRetry = rb_define_class("TkCallbackRetry", eTkLocalJumpError); - eTkCallbackRedo = rb_define_class("TkCallbackRedo", eTkLocalJumpError); - eTkCallbackThrow = rb_define_class("TkCallbackThrow", eTkLocalJumpError); - - /* --------------------------------------------------------------- */ - - ID_at_enc = rb_intern("@encoding"); - ID_at_interp = rb_intern("@interp"); - - ID_stop_p = rb_intern("stop?"); - ID_alive_p = rb_intern("alive?"); - ID_kill = rb_intern("kill"); - ID_join = rb_intern("join"); - ID_value = rb_intern("value"); - - ID_call = rb_intern("call"); - ID_backtrace = rb_intern("backtrace"); - ID_message = rb_intern("message"); - - ID_at_reason = rb_intern("@reason"); - ID_return = rb_intern("return"); - ID_break = rb_intern("break"); - ID_next = rb_intern("next"); - - ID_to_s = rb_intern("to_s"); - ID_inspect = rb_intern("inspect"); - - /* --------------------------------------------------------------- */ - - rb_define_module_function(lib, "mainloop", lib_mainloop, -1); - rb_define_module_function(lib, "mainloop_thread?", - lib_evloop_thread_p, 0); - rb_define_module_function(lib, "mainloop_watchdog", - lib_mainloop_watchdog, -1); - rb_define_module_function(lib, "do_thread_callback", - lib_thread_callback, -1); - rb_define_module_function(lib, "do_one_event", lib_do_one_event, -1); - rb_define_module_function(lib, "mainloop_abort_on_exception", - lib_evloop_abort_on_exc, 0); - rb_define_module_function(lib, "mainloop_abort_on_exception=", - lib_evloop_abort_on_exc_set, 1); - rb_define_module_function(lib, "set_eventloop_tick",set_eventloop_tick,1); - rb_define_module_function(lib, "get_eventloop_tick",get_eventloop_tick,0); - rb_define_module_function(lib, "set_no_event_wait", set_no_event_wait, 1); - rb_define_module_function(lib, "get_no_event_wait", get_no_event_wait, 0); - rb_define_module_function(lib, "set_eventloop_weight", - set_eventloop_weight, 2); - rb_define_module_function(lib, "set_max_block_time", set_max_block_time,1); - rb_define_module_function(lib, "get_eventloop_weight", - get_eventloop_weight, 0); - rb_define_module_function(lib, "num_of_mainwindows", - lib_num_of_mainwindows, 0); - - /* --------------------------------------------------------------- */ - - rb_define_module_function(lib, "_split_tklist", lib_split_tklist, 1); - rb_define_module_function(lib, "_merge_tklist", lib_merge_tklist, -1); - rb_define_module_function(lib, "_conv_listelement", - lib_conv_listelement, 1); - rb_define_module_function(lib, "_toUTF8", lib_toUTF8, -1); - rb_define_module_function(lib, "_fromUTF8", lib_fromUTF8, -1); - rb_define_module_function(lib, "_subst_UTF_backslash", - lib_UTF_backslash, 1); - rb_define_module_function(lib, "_subst_Tcl_backslash", - lib_Tcl_backslash, 1); - - rb_define_module_function(lib, "encoding_system", - lib_get_system_encoding, 0); - rb_define_module_function(lib, "encoding_system=", - lib_set_system_encoding, 1); - rb_define_module_function(lib, "encoding", - lib_get_system_encoding, 0); - rb_define_module_function(lib, "encoding=", - lib_set_system_encoding, 1); - - /* --------------------------------------------------------------- */ - - rb_define_alloc_func(ip, ip_alloc); - rb_define_method(ip, "initialize", ip_init, -1); - rb_define_method(ip, "create_slave", ip_create_slave, -1); - rb_define_method(ip, "make_safe", ip_make_safe, 0); - rb_define_method(ip, "safe?", ip_is_safe_p, 0); - rb_define_method(ip, "allow_ruby_exit?", ip_allow_ruby_exit_p, 0); - rb_define_method(ip, "allow_ruby_exit=", ip_allow_ruby_exit_set, 1); - rb_define_method(ip, "delete", ip_delete, 0); - rb_define_method(ip, "deleted?", ip_is_deleted_p, 0); - rb_define_method(ip, "has_mainwindow?", ip_has_mainwindow_p, 0); - rb_define_method(ip, "invalid_namespace?", ip_has_invalid_namespace_p, 0); - rb_define_method(ip, "_eval", ip_eval, 1); - rb_define_method(ip, "_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, "_create_console", ip_create_console, 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); - rb_define_method(ip, "mainloop_abort_on_exception", - ip_evloop_abort_on_exc, 0); - rb_define_method(ip, "mainloop_abort_on_exception=", - ip_evloop_abort_on_exc_set, 1); - rb_define_method(ip, "set_eventloop_tick", ip_set_eventloop_tick, 1); - rb_define_method(ip, "get_eventloop_tick", ip_get_eventloop_tick, 0); - rb_define_method(ip, "set_no_event_wait", ip_set_no_event_wait, 1); - rb_define_method(ip, "get_no_event_wait", ip_get_no_event_wait, 0); - rb_define_method(ip, "set_eventloop_weight", ip_set_eventloop_weight, 2); - rb_define_method(ip, "get_eventloop_weight", ip_get_eventloop_weight, 0); - rb_define_method(ip, "set_max_block_time", set_max_block_time, 1); - rb_define_method(ip, "restart", ip_restart, 0); - - /* --------------------------------------------------------------- */ - - eventloop_thread = Qnil; - -#ifndef DEFAULT_EVENTLOOP_DEPTH -#define DEFAULT_EVENTLOOP_DEPTH 7 -#endif - eventloop_stack = rb_ary_new2(DEFAULT_EVENTLOOP_DEPTH); - OBJ_TAINT(eventloop_stack); - - watchdog_thread = Qnil; - - rbtk_pending_exception = Qnil; - - /* --------------------------------------------------------------- */ - - /* if ruby->nativethread-supprt and tcltklib->doen't, - the following will cause link-error. */ - is_ruby_native_thread(); - - /* --------------------------------------------------------------- */ - - ret = ruby_open_tcl_dll(RSTRING(rb_argv0)->ptr); - switch(ret) { - case TCLTK_STUBS_OK: - break; - case NO_TCL_DLL: - rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll"); - case NO_FindExecutable: - rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable"); - default: - rb_raise(rb_eLoadError, "tcltklib: unknown error(%d) on ruby_open_tcl_dll", ret); - } - - /* --------------------------------------------------------------- */ -} - -/* eof */ diff --git a/ext/tk/depend b/ext/tk/depend index fd63e230f0..2cd9c400f7 100644 --- a/ext/tk/depend +++ b/ext/tk/depend @@ -1 +1,2 @@ -tkutil.o: tkutil.c $(hdrdir)/ruby.h $(topdir)/config.h $(hdrdir)/defines.h +tcltklib.o: tcltklib.c $(hdrdir)/ruby.h $(topdir)/config.h $(hdrdir)/defines.h +stubs.o: stubs.c $(hdrdir)/ruby.h $(topdir)/config.h $(hdrdir)/defines.h diff --git a/ext/tk/extconf.rb b/ext/tk/extconf.rb index 8b10353d1a..95fdef7968 100644 --- a/ext/tk/extconf.rb +++ b/ext/tk/extconf.rb @@ -1,4 +1,309 @@ +# extconf.rb for tcltklib + require 'mkmf' -$preload = ["tcltklib"] -($INSTALLFILES||=[]) << ["lib/tkextlib/SUPPORT_STATUS", "$(RUBYLIBDIR)", "lib"] -create_makefile("tkutil") + +is_win32 = (/mswin32|mingw|cygwin|bccwin32/ =~ RUBY_PLATFORM) +#is_macosx = (/darwin/ =~ RUBY_PLATFORM) + +def find_framework(tcl_hdr, tk_hdr) + if framework_dir = with_config("tcltk-framework") + paths = [framework_dir] + else + unless tcl_hdr || tk_hdr || + enable_config("tcltk-framework", false) || + enable_config("mac-tcltk-framework", false) + return false + end + paths = ["/Library/Frameworks", "/System/Library/Frameworks"] + end + + checking_for('Tcl/Tk Framework') { + paths.find{|dir| + dir.strip! + dir.chomp!('/') + (tcl_hdr || FileTest.directory?(dir + "/Tcl.framework/") ) && + (tk_hdr || FileTest.directory?(dir + "/Tk.framework/") ) + } + } +end + +tcl_framework_header = with_config("tcl-framework-header") +tk_framework_header = with_config("tk-framework-header") + +tcltk_framework = find_framework(tcl_framework_header, tk_framework_header) + +unless is_win32 + have_library("nsl", "t_open") + have_library("socket", "socket") + have_library("dl", "dlopen") + have_library("m", "log") +end + +dir_config("tk") +dir_config("tcl") +dir_config("X11") + +tklib = with_config("tklib") +tcllib = with_config("tcllib") +stubs = enable_config("tcltk_stubs") || with_config("tcltk_stubs") + +def find_tcl(tcllib, stubs) + paths = ["/usr/local/lib", "/usr/pkg/lib", "/usr/lib"] + if stubs + func = "Tcl_InitStubs" + lib = "tclstub" + else + func = "Tcl_FindExecutable" + lib = "tcl" + end + if tcllib + find_library(tcllib, func, *paths) + elsif find_library(lib, func, *paths) + true + else + %w[8.5 8.4 8.3 8.2 8.1 8.0 7.6].find { |ver| + find_library("#{lib}#{ver}", func, *paths) or + find_library("#{lib}#{ver.delete('.')}", func, *paths) or + find_library("tcl#{ver}", func, *paths) or + find_library("tcl#{ver.delete('.')}", func, *paths) + } + end +end + +def find_tk(tklib, stubs) + paths = ["/usr/local/lib", "/usr/pkg/lib", "/usr/lib"] + if stubs + func = "Tk_InitStubs" + lib = "tkstub" + else + func = "Tk_Init" + lib = "tk" + end + if tklib + find_library(tklib, func, *paths) + elsif find_library(lib, func, *paths) + true + else + %w[8.5 8.4 8.3 8.2 8.1 8.0 4.2].find { |ver| + find_library("#{lib}#{ver}", func, *paths) or + find_library("#{lib}#{ver.delete('.')}", func, *paths) or + find_library("tk#{ver}", func, *paths) or + find_library("tk#{ver.delete('.')}", func, *paths) + } + end +end + +def pthread_check() + tcl_major_ver = nil + tcl_minor_ver = nil + + # Is tcl-thread given by user ? + case enable_config("tcl-thread") + when true + tcl_enable_thread = true + when false + tcl_enable_thread = false + else + tcl_enable_thread = nil + end + + if (tclConfig = with_config("tclConfig-file")) + if tcl_enable_thread == true + puts("Warning: --with-tclConfig-file option is ignored, because --enable-tcl-thread option is given.") + elsif tcl_enable_thread == false + puts("Warning: --with-tclConfig-file option is ignored, because --disable-tcl-thread option is given.") + else + # tcl-thread is unknown and tclConfig.sh is given + begin + open(tclConfig, "r") do |cfg| + while line = cfg.gets() + if line =~ /^\s*TCL_THREADS=(0|1)/ + tcl_enable_thread = ($1 == "1") + break + end + + if line =~ /^\s*TCL_MAJOR_VERSION=("|')(\d+)\1/ + tcl_major_ver = $2 + if tcl_major_ver =~ /^[1-7]$/ + tcl_enable_thread = false + break + end + if tcl_major_ver == "8" && tcl_minor_ver == "0" + tcl_enable_thread = false + break + end + end + + if line =~ /^\s*TCL_MINOR_VERSION=("|')(\d+)\1/ + tcl_minor_ver = $2 + if tcl_major_ver == "8" && tcl_minor_ver == "0" + tcl_enable_thread = false + break + end + end + end + end + + if tcl_enable_thread == nil + # not find definition + if tcl_major_ver + puts("Warning: '#{tclConfig}' doesn't include TCL_THREADS definition.") + else + puts("Warning: '#{tclConfig}' may not be a tclConfig file.") + end + tclConfig = false + end + rescue Exception + puts("Warning: fail to read '#{tclConfig}'!! --> ignore the file") + tclConfig = false + end + end + end + + if tcl_enable_thread == nil && !tclConfig + # tcl-thread is unknown and tclConfig is unavailable + begin + try_run_available = try_run("int main() { exit(0); }") + rescue Exception + # cannot try_run. Is CROSS-COMPILE environment? + puts(%Q'\ +***************************************************************************** +** +** PTHREAD SUPPORT CHECK WARNING: +** +** We cannot check the consistency of pthread support between Ruby +** and the Tcl/Tk library in your environment (are you perhaps +** cross-compiling?). If pthread support for these 2 packages is +** inconsistent you may find you get errors when running Ruby/Tk +** (e.g. hangs or segmentation faults). We strongly recommend +** you to check the consistency manually. +** +***************************************************************************** +') + return true + end + end + + if tcl_enable_thread == nil + # tcl-thread is unknown + if try_run(<<EOF) +#include <tcl.h> +int main() { + Tcl_Interp *ip; + ip = Tcl_CreateInterp(); + exit((Tcl_Eval(ip, "set tcl_platform(threaded)") == TCL_OK)? 0: 1); +} +EOF + tcl_enable_thread = true + elsif 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 + end + + # check pthread mode + if (macro_defined?('HAVE_LIBPTHREAD', '#include "ruby.h"')) + # ruby -> enable + unless tcl_enable_thread + # ruby -> enable && tcl -> disable + puts(%Q'\ +***************************************************************************** +** +** PTHREAD SUPPORT MODE WARNING: +** +** Ruby is compiled with --enable-pthread, but your Tcl/Tk library +** seems to be compiled without pthread support. Although you can +** create the tcltklib library, this combination may cause errors +** (e.g. hangs or segmentation faults). If you have no reason to +** keep the current pthread support status, we recommend you reconfigure +** and recompile the libraries so that both or neither support pthreads. +** +** 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 or equal to Tcl/Tk 8.1). +** +***************************************************************************** +') + end + + # ruby -> enable && tcl -> enable/disable + if tcl_enable_thread + $CPPFLAGS += ' -DWITH_TCL_ENABLE_THREAD=1' + else + $CPPFLAGS += ' -DWITH_TCL_ENABLE_THREAD=0' + end + + return true + + else + # ruby -> disable + if tcl_enable_thread + # ruby -> disable && tcl -> enable + puts(%Q'\ +***************************************************************************** +** +** PTHREAD SUPPORT MODE ERROR: +** +** Ruby is not compiled with --enable-pthread, but your Tcl/Tk +** library seems to be compiled with pthread support. This +** combination may cause frequent hang or segmentation fault +** errors when Ruby/Tk is working. We recommend that you NEVER +** create the library with such a combination of pthread support. +** +** Please recompile Ruby with the "--enable-pthread" configure option +** or recompile Tcl/Tk with the "--disable-threads" configure option. +** +***************************************************************************** +') + $CPPFLAGS += ' -DWITH_TCL_ENABLE_THREAD=1' + return false + else + # ruby -> disable && tcl -> disable + $CPPFLAGS += ' -DWITH_TCL_ENABLE_THREAD=0' + return true + end + end +end + +if tcltk_framework || + (have_header("tcl.h") && have_header("tk.h") && + (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 + + if tcltk_framework + if tcl_framework_header + $CPPFLAGS += " -I#{tcl_framework_header}" + else + $CPPFLAGS += " -I#{tcltk_framework}/Tcl.framework/Headers" + end + + if tk_framework_header + $CPPFLAGS += " -I#{tk_framework_header}" + else + $CPPFLAGS += " -I#{tcltk_framework}/Tk.framework/Headers" + end + + $LDFLAGS += ' -framework Tk -framework Tcl' + end + + if stubs or pthread_check + # create Makefile + + # for SUPPORT_STATUS + $INSTALLFILES ||= [] + $INSTALLFILES << ["lib/tkextlib/SUPPORT_STATUS", "$(RUBYLIBDIR)", "lib"] + + # create + create_makefile("tcltklib") + end +end diff --git a/ext/tk/tkutil.c b/ext/tk/tkutil.c deleted file mode 100644 index 7fbf3fc07c..0000000000 --- a/ext/tk/tkutil.c +++ /dev/null @@ -1,1637 +0,0 @@ -/************************************************ - - tkutil.c - - - $Author$ - $Date$ - created at: Fri Nov 3 00:47:54 JST 1995 - -************************************************/ - -#define TKUTIL_RELEASE_DATE "2005-11-02" - -#include "ruby.h" -#include "rubysig.h" -#include "st.h" - -static VALUE cMethod; - -static VALUE cTclTkLib; - -static VALUE cTkObject; -static VALUE cTkCallbackEntry; - -static VALUE TK_None; - -static VALUE cCB_SUBST; -static VALUE cSUBST_INFO; - -static ID ID_split_tklist; -static ID ID_toUTF8; -static ID ID_fromUTF8; -static ID ID_path; -static ID ID_at_path; -static ID ID_at_enc; -static ID ID_to_eval; -static ID ID_to_s; -static ID ID_source; -static ID ID_downcase; -static ID ID_install_cmd; -static ID ID_merge_tklist; -static ID ID_encoding; -static ID ID_encoding_system; -static ID ID_call; - -static ID ID_SUBST_INFO; - -static VALUE CALLBACK_TABLE; -static unsigned long CALLBACK_ID_NUM = 0; - -/*************************************/ - -static VALUE -tk_s_new(argc, argv, klass) - int argc; - VALUE *argv; - VALUE klass; -{ - VALUE obj = rb_class_new_instance(argc, argv, klass); - - if (rb_block_given_p()) rb_obj_instance_eval(0, 0, obj); - return obj; -} - -/*************************************/ - -static VALUE -tkNone_to_s(self) - VALUE self; -{ - return rb_str_new2("None"); -} - -/*************************************/ - -static VALUE -tk_eval_cmd(argc, argv, self) - int argc; - VALUE argv[]; - VALUE self; -{ - volatile VALUE cmd, rest, arg; - volatile VALUE ret; - int status; - - rb_scan_args(argc, argv, "1*", &cmd, &rest); - return rb_eval_cmd(cmd, rest, 0); -} - -static VALUE -tk_do_callback(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ -#if 0 - volatile VALUE id; - volatile VALUE rest; - - rb_scan_args(argc, argv, "1*", &id, &rest); - return rb_apply(rb_hash_aref(CALLBACK_TABLE, id), ID_call, rest); -#endif - return rb_funcall2(rb_hash_aref(CALLBACK_TABLE, argv[0]), - ID_call, argc - 1, argv + 1); -} - -static char *cmd_id_head = "ruby_cmd TkUtil callback "; -static char *cmd_id_prefix = "cmd"; - -static VALUE -tk_install_cmd_core(cmd) - VALUE cmd; -{ - volatile VALUE id_num; - - id_num = ULONG2NUM(CALLBACK_ID_NUM++); - id_num = rb_funcall(id_num, ID_to_s, 0, 0); - id_num = rb_str_append(rb_str_new2(cmd_id_prefix), id_num); - rb_hash_aset(CALLBACK_TABLE, id_num, cmd); - return rb_str_append(rb_str_new2(cmd_id_head), id_num); -} - -static VALUE -tk_install_cmd(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - volatile VALUE cmd; - -#if 0 - if (rb_scan_args(argc, argv, "01", &cmd) == 0) { - cmd = rb_block_proc(); - } - return tk_install_cmd_core(cmd); -#endif - if (argc == 0) { - cmd = rb_block_proc(); - } else { - cmd = argv[0]; - } - return tk_install_cmd_core(cmd); -} - -static VALUE -tk_uninstall_cmd(self, cmd_id) - VALUE self; - VALUE cmd_id; -{ - int head_len = strlen(cmd_id_head); - int prefix_len = strlen(cmd_id_prefix); - - StringValue(cmd_id); - if (strncmp(cmd_id_head, RSTRING(cmd_id)->ptr, head_len) != 0) { - return Qnil; - } - if (strncmp(cmd_id_prefix, - RSTRING(cmd_id)->ptr + head_len, prefix_len) != 0) { - return Qnil; - } - - return rb_hash_delete(CALLBACK_TABLE, - rb_str_new2(RSTRING(cmd_id)->ptr + head_len)); -} - -static VALUE -tk_toUTF8(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - return rb_funcall2(cTclTkLib, ID_toUTF8, argc, argv); -} - -static VALUE -tk_fromUTF8(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - return rb_funcall2(cTclTkLib, ID_fromUTF8, argc, argv); -} - -static VALUE -fromDefaultEnc_toUTF8(str, self) - VALUE str; - VALUE self; -{ - VALUE argv[1]; - - argv[0] = str; - return tk_toUTF8(1, argv, self); -} - -static VALUE -fromUTF8_toDefaultEnc(str, self) - VALUE str; - VALUE self; -{ - VALUE argv[1]; - - argv[0] = str; - return tk_fromUTF8(1, argv, self); -} - -static int -to_strkey(key, value, hash) - VALUE key; - VALUE value; - VALUE hash; -{ - if (key == Qundef) return ST_CONTINUE; - rb_hash_aset(hash, rb_funcall(key, ID_to_s, 0, 0), value); - return ST_CHECK; -} - -static VALUE -tk_symbolkey2str(self, keys) - VALUE self; - VALUE keys; -{ - volatile VALUE new_keys = rb_hash_new(); - - if NIL_P(keys) return new_keys; - keys = rb_convert_type(keys, T_HASH, "Hash", "to_hash"); - st_foreach(RHASH(keys)->tbl, to_strkey, new_keys); - return new_keys; -} - -static VALUE get_eval_string_core _((VALUE, VALUE, VALUE)); -static VALUE ary2list _((VALUE, VALUE, VALUE)); -static VALUE ary2list2 _((VALUE, VALUE, VALUE)); -static VALUE hash2list _((VALUE, VALUE)); -static VALUE hash2list_enc _((VALUE, VALUE)); -static VALUE hash2kv _((VALUE, VALUE, VALUE)); -static VALUE hash2kv_enc _((VALUE, VALUE, VALUE)); - -static VALUE -ary2list(ary, enc_flag, self) - VALUE ary; - VALUE enc_flag; - VALUE self; -{ - int idx, idx2, size, size2, req_chk_flag; - volatile VALUE val, val2, str_val; - volatile VALUE dst; - volatile VALUE sys_enc, dst_enc, str_enc; - - sys_enc = rb_funcall(cTclTkLib, ID_encoding, 0, 0); - if (NIL_P(sys_enc)) { - sys_enc = rb_funcall(cTclTkLib, ID_encoding_system, 0, 0); - sys_enc = rb_funcall(sys_enc, ID_to_s, 0, 0); - } - - if NIL_P(enc_flag) { - dst_enc = sys_enc; - req_chk_flag = 1; - } else if (TYPE(enc_flag) == T_TRUE || TYPE(enc_flag) == T_FALSE) { - dst_enc = enc_flag; - req_chk_flag = 0; - } else { - dst_enc = rb_funcall(enc_flag, ID_to_s, 0, 0); - req_chk_flag = 0; - } - - /* size = RARRAY(ary)->len; */ - size = 0; - for(idx = 0; idx < RARRAY(ary)->len; idx++) { - if (TYPE(RARRAY(ary)->ptr[idx]) == T_HASH) { - size += 2 * RHASH(RARRAY(ary)->ptr[idx])->tbl->num_entries; - } else { - size++; - } - } - - dst = rb_ary_new2(size); - RARRAY(dst)->len = 0; - for(idx = 0; idx < RARRAY(ary)->len; idx++) { - val = RARRAY(ary)->ptr[idx]; - str_val = Qnil; - switch(TYPE(val)) { - case T_ARRAY: - str_val = ary2list(val, enc_flag, self); - RARRAY(dst)->ptr[RARRAY(dst)->len++] = str_val; - - if (req_chk_flag) { - str_enc = rb_ivar_get(str_val, ID_at_enc); - if (!NIL_P(str_enc)) { - str_enc = rb_funcall(str_enc, ID_to_s, 0, 0); - } else { - str_enc = sys_enc; - } - if (!rb_str_cmp(str_enc, dst_enc)) { - dst_enc = Qtrue; - req_chk_flag = 0; - } - } - - break; - - case T_HASH: - /* RARRAY(dst)->ptr[RARRAY(dst)->len++] = hash2list(val, self); */ - if (RTEST(enc_flag)) { - val = hash2kv_enc(val, Qnil, self); - } else { - val = hash2kv(val, Qnil, self); - } - size2 = RARRAY(val)->len; - for(idx2 = 0; idx2 < size2; idx2++) { - val2 = RARRAY(val)->ptr[idx2]; - switch(TYPE(val2)) { - case T_ARRAY: - str_val = ary2list(val2, enc_flag, self); - RARRAY(dst)->ptr[RARRAY(dst)->len++] = str_val; - break; - - case T_HASH: - if (RTEST(enc_flag)) { - str_val = hash2list_enc(val2, self); - } else { - str_val = hash2list(val2, self); - } - RARRAY(dst)->ptr[RARRAY(dst)->len++] = str_val; - break; - - default: - if (val2 != TK_None) { - str_val = get_eval_string_core(val2, enc_flag, self); - RARRAY(dst)->ptr[RARRAY(dst)->len++] = str_val; - } - } - - if (req_chk_flag) { - str_enc = rb_ivar_get(str_val, ID_at_enc); - if (!NIL_P(str_enc)) { - str_enc = rb_funcall(str_enc, ID_to_s, 0, 0); - } else { - str_enc = sys_enc; - } - if (!rb_str_cmp(str_enc, dst_enc)) { - dst_enc = Qtrue; - req_chk_flag = 0; - } - } - } - break; - - default: - if (val != TK_None) { - str_val = get_eval_string_core(val, enc_flag, self); - RARRAY(dst)->ptr[RARRAY(dst)->len++] = str_val; - - if (req_chk_flag) { - str_enc = rb_ivar_get(str_val, ID_at_enc); - if (!NIL_P(str_enc)) { - str_enc = rb_funcall(str_enc, ID_to_s, 0, 0); - } else { - str_enc = sys_enc; - } - if (!rb_str_cmp(str_enc, dst_enc)) { - dst_enc = Qtrue; - req_chk_flag = 0; - } - } - } - } - } - - if (RTEST(dst_enc) && !NIL_P(sys_enc)) { - for(idx = 0; idx < RARRAY(dst)->len; idx++) { - str_val = RARRAY(dst)->ptr[idx]; - if (rb_obj_respond_to(self, ID_toUTF8, Qtrue)) { - str_val = rb_funcall(self, ID_toUTF8, 1, str_val); - } else { - str_val = rb_funcall(cTclTkLib, ID_toUTF8, 1, str_val); - } - RARRAY(dst)->ptr[idx] = str_val; - } - val = rb_apply(cTclTkLib, ID_merge_tklist, dst); - if (TYPE(dst_enc) == T_STRING) { - val = rb_funcall(cTclTkLib, ID_fromUTF8, 2, val, dst_enc); - rb_ivar_set(val, ID_at_enc, dst_enc); - } else { - rb_ivar_set(val, ID_at_enc, rb_str_new2("utf-8")); - } - return val; - } else { - return rb_apply(cTclTkLib, ID_merge_tklist, dst); - } -} - -static VALUE -ary2list2(ary, enc_flag, self) - VALUE ary; - VALUE enc_flag; - VALUE self; -{ - int idx, size, req_chk_flag; - volatile VALUE val, str_val; - volatile VALUE dst; - volatile VALUE sys_enc, dst_enc, str_enc; - - sys_enc = rb_funcall(cTclTkLib, ID_encoding, 0, 0); - if NIL_P(sys_enc) { - sys_enc = rb_funcall(cTclTkLib, ID_encoding_system, 0, 0); - sys_enc = rb_funcall(sys_enc, ID_to_s, 0, 0); - } - - if NIL_P(enc_flag) { - dst_enc = sys_enc; - req_chk_flag = 1; - } else if (TYPE(enc_flag) == T_TRUE || TYPE(enc_flag) == T_FALSE) { - dst_enc = enc_flag; - req_chk_flag = 0; - } else { - dst_enc = rb_funcall(enc_flag, ID_to_s, 0, 0); - req_chk_flag = 0; - } - - size = RARRAY(ary)->len; - dst = rb_ary_new2(size); - RARRAY(dst)->len = 0; - for(idx = 0; idx < RARRAY(ary)->len; idx++) { - val = RARRAY(ary)->ptr[idx]; - str_val = Qnil; - switch(TYPE(val)) { - case T_ARRAY: - str_val = ary2list(val, enc_flag, self); - break; - - case T_HASH: - if (RTEST(enc_flag)) { - str_val = hash2list(val, self); - } else { - str_val = hash2list_enc(val, self); - } - break; - - default: - if (val != TK_None) { - str_val = get_eval_string_core(val, enc_flag, self); - } - } - - if (!NIL_P(str_val)) { - RARRAY(dst)->ptr[RARRAY(dst)->len++] = str_val; - - if (req_chk_flag) { - str_enc = rb_ivar_get(str_val, ID_at_enc); - if (!NIL_P(str_enc)) { - str_enc = rb_funcall(str_enc, ID_to_s, 0, 0); - } else { - str_enc = sys_enc; - } - if (!rb_str_cmp(str_enc, dst_enc)) { - dst_enc = Qtrue; - req_chk_flag = 0; - } - } - } - } - - if (RTEST(dst_enc) && !NIL_P(sys_enc)) { - for(idx = 0; idx < RARRAY(dst)->len; idx++) { - str_val = RARRAY(dst)->ptr[idx]; - if (rb_obj_respond_to(self, ID_toUTF8, Qtrue)) { - str_val = rb_funcall(self, ID_toUTF8, 1, str_val); - } else { - str_val = rb_funcall(cTclTkLib, ID_toUTF8, 1, str_val); - } - RARRAY(dst)->ptr[idx] = str_val; - } - val = rb_apply(cTclTkLib, ID_merge_tklist, dst); - if (TYPE(dst_enc) == T_STRING) { - val = rb_funcall(cTclTkLib, ID_fromUTF8, 2, val, dst_enc); - rb_ivar_set(val, ID_at_enc, dst_enc); - } else { - rb_ivar_set(val, ID_at_enc, rb_str_new2("utf-8")); - } - return val; - } else { - return rb_apply(cTclTkLib, ID_merge_tklist, dst); - } -} - -static VALUE -key2keyname(key) - VALUE key; -{ - return rb_str_append(rb_str_new2("-"), rb_funcall(key, ID_to_s, 0, 0)); -} - -static VALUE -assoc2kv(assoc, ary, self) - VALUE assoc; - VALUE ary; - VALUE self; -{ - int i, j, len; - volatile VALUE pair; - volatile VALUE val; - volatile VALUE dst = rb_ary_new2(2 * RARRAY(assoc)->len); - - len = RARRAY(assoc)->len; - - for(i = 0; i < len; i++) { - pair = RARRAY(assoc)->ptr[i]; - if (TYPE(pair) != T_ARRAY) { - RARRAY(dst)->ptr[RARRAY(dst)->len++] = key2keyname(pair); - continue; - } - switch(RARRAY(assoc)->len) { - case 2: - RARRAY(dst)->ptr[RARRAY(dst)->len++] = RARRAY(pair)->ptr[2]; - - case 1: - RARRAY(dst)->ptr[RARRAY(dst)->len++] - = key2keyname(RARRAY(pair)->ptr[0]); - - case 0: - continue; - - default: - RARRAY(dst)->ptr[RARRAY(dst)->len++] - = key2keyname(RARRAY(pair)->ptr[0]); - - val = rb_ary_new2(RARRAY(pair)->len - 1); - RARRAY(val)->len = 0; - for(j = 1; j < RARRAY(pair)->len; j++) { - RARRAY(val)->ptr[RARRAY(val)->len++] = RARRAY(pair)->ptr[j]; - } - - RARRAY(dst)->ptr[RARRAY(dst)->len++] = val; - } - } - - if (NIL_P(ary)) { - return dst; - } else { - return rb_ary_plus(ary, dst); - } -} - -static VALUE -assoc2kv_enc(assoc, ary, self) - VALUE assoc; - VALUE ary; - VALUE self; -{ - int i, j, len; - volatile VALUE pair; - volatile VALUE val; - volatile VALUE dst = rb_ary_new2(2 * RARRAY(assoc)->len); - - len = RARRAY(assoc)->len; - - for(i = 0; i < len; i++) { - pair = RARRAY(assoc)->ptr[i]; - if (TYPE(pair) != T_ARRAY) { - RARRAY(dst)->ptr[RARRAY(dst)->len++] = key2keyname(pair); - continue; - } - switch(RARRAY(assoc)->len) { - case 2: - RARRAY(dst)->ptr[RARRAY(dst)->len++] - = get_eval_string_core(RARRAY(pair)->ptr[2], Qtrue, self); - - case 1: - RARRAY(dst)->ptr[RARRAY(dst)->len++] - = key2keyname(RARRAY(pair)->ptr[0]); - - case 0: - continue; - - default: - RARRAY(dst)->ptr[RARRAY(dst)->len++] - = key2keyname(RARRAY(pair)->ptr[0]); - - val = rb_ary_new2(RARRAY(pair)->len - 1); - RARRAY(val)->len = 0; - for(j = 1; j < RARRAY(pair)->len; j++) { - RARRAY(val)->ptr[RARRAY(val)->len++] = RARRAY(pair)->ptr[j]; - } - - RARRAY(dst)->ptr[RARRAY(dst)->len++] - = get_eval_string_core(val, Qtrue, self); - } - } - - if (NIL_P(ary)) { - return dst; - } else { - return rb_ary_plus(ary, dst); - } -} - -static int -push_kv(key, val, args) - VALUE key; - VALUE val; - VALUE args; -{ - volatile VALUE ary; - - ary = RARRAY(args)->ptr[0]; - - if (key == Qundef) return ST_CONTINUE; -#if 0 - rb_ary_push(ary, key2keyname(key)); - if (val != TK_None) rb_ary_push(ary, val); -#endif - RARRAY(ary)->ptr[RARRAY(ary)->len++] = key2keyname(key); - - if (val == TK_None) return ST_CHECK; - - RARRAY(ary)->ptr[RARRAY(ary)->len++] - = get_eval_string_core(val, Qnil, RARRAY(args)->ptr[1]); - - return ST_CHECK; -} - -static VALUE -hash2kv(hash, ary, self) - VALUE hash; - VALUE ary; - VALUE self; -{ - volatile VALUE args = rb_ary_new2(2); - volatile VALUE dst = rb_ary_new2(2 * RHASH(hash)->tbl->num_entries); - - RARRAY(dst)->len = 0; - - RARRAY(args)->ptr[0] = dst; - RARRAY(args)->ptr[1] = self; - RARRAY(args)->len = 2; - st_foreach(RHASH(hash)->tbl, push_kv, args); - - if (NIL_P(ary)) { - return dst; - } else { - return rb_ary_concat(ary, dst); - } -} - -static int -push_kv_enc(key, val, args) - VALUE key; - VALUE val; - VALUE args; -{ - volatile VALUE ary; - - ary = RARRAY(args)->ptr[0]; - - if (key == Qundef) return ST_CONTINUE; -#if 0 - rb_ary_push(ary, key2keyname(key)); - if (val != TK_None) { - rb_ary_push(ary, get_eval_string_core(val, Qtrue, - RARRAY(args)->ptr[1])); - } -#endif - RARRAY(ary)->ptr[RARRAY(ary)->len++] = key2keyname(key); - - if (val == TK_None) return ST_CHECK; - - RARRAY(ary)->ptr[RARRAY(ary)->len++] - = get_eval_string_core(val, Qtrue, RARRAY(args)->ptr[1]); - - return ST_CHECK; -} - -static VALUE -hash2kv_enc(hash, ary, self) - VALUE hash; - VALUE ary; - VALUE self; -{ - volatile VALUE args = rb_ary_new2(2); - volatile VALUE dst = rb_ary_new2(2 * RHASH(hash)->tbl->num_entries); - - RARRAY(dst)->len = 0; - - RARRAY(args)->ptr[0] = dst; - RARRAY(args)->ptr[1] = self; - RARRAY(args)->len = 2; - st_foreach(RHASH(hash)->tbl, push_kv_enc, args); - - if (NIL_P(ary)) { - return dst; - } else { - return rb_ary_concat(ary, dst); - } -} - -static VALUE -hash2list(hash, self) - VALUE hash; - VALUE self; -{ - return ary2list2(hash2kv(hash, Qnil, self), Qfalse, self); -} - - -static VALUE -hash2list_enc(hash, self) - VALUE hash; - VALUE self; -{ - return ary2list2(hash2kv_enc(hash, Qnil, self), Qfalse, self); -} - -static VALUE -tk_hash_kv(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - volatile VALUE hash, enc_flag, ary; - - ary = Qnil; - enc_flag = Qnil; - switch(argc) { - case 3: - ary = argv[2]; - case 2: - enc_flag = argv[1]; - case 1: - hash = argv[0]; - break; - case 0: - rb_raise(rb_eArgError, "too few arguments"); - default: /* >= 3 */ - rb_raise(rb_eArgError, "too many arguments"); - } - - switch(TYPE(hash)) { - case T_ARRAY: - if (RTEST(enc_flag)) { - return assoc2kv_enc(hash, ary, self); - } else { - return assoc2kv(hash, ary, self); - } - - case T_HASH: - if (RTEST(enc_flag)) { - return hash2kv_enc(hash, ary, self); - } else { - return hash2kv(hash, ary, self); - } - - case T_NIL: - if (NIL_P(ary)) { - return rb_ary_new(); - } else { - return ary; - } - - default: - if (hash == TK_None) { - if (NIL_P(ary)) { - return rb_ary_new(); - } else { - return ary; - } - } - rb_raise(rb_eArgError, "Hash is expected for 1st argument"); - } -} - -static VALUE -get_eval_string_core(obj, enc_flag, self) - VALUE obj; - VALUE enc_flag; - VALUE self; -{ - switch(TYPE(obj)) { - case T_FLOAT: - case T_FIXNUM: - case T_BIGNUM: - return rb_funcall(obj, ID_to_s, 0, 0); - - case T_STRING: - if (RTEST(enc_flag)) { - if (rb_obj_respond_to(self, ID_toUTF8, Qtrue)) { - return rb_funcall(self, ID_toUTF8, 1, obj); - } else { - return fromDefaultEnc_toUTF8(obj, self); - } - } else { - return obj; - } - - case T_SYMBOL: - if (RTEST(enc_flag)) { - if (rb_obj_respond_to(self, ID_toUTF8, Qtrue)) { - return rb_funcall(self, ID_toUTF8, 1, - rb_str_new2(rb_id2name(SYM2ID(obj)))); - } else { - return fromDefaultEnc_toUTF8(rb_str_new2(rb_id2name(SYM2ID(obj))), self); - } - } else { - return rb_str_new2(rb_id2name(SYM2ID(obj))); - } - - case T_HASH: - if (RTEST(enc_flag)) { - return hash2list_enc(obj, self); - } else { - return hash2list(obj, self); - } - - case T_ARRAY: - return ary2list(obj, enc_flag, self); - - case T_FALSE: - return rb_str_new2("0"); - - case T_TRUE: - return rb_str_new2("1"); - - case T_NIL: - return rb_str_new2(""); - - case T_REGEXP: - return rb_funcall(obj, ID_source, 0, 0); - - default: - if (rb_obj_is_kind_of(obj, cTkObject)) { - /* return rb_str_new3(rb_funcall(obj, ID_path, 0, 0)); */ - return get_eval_string_core(rb_funcall(obj, ID_path, 0, 0), - enc_flag, self); - } - - if (rb_obj_is_kind_of(obj, rb_cProc) - || rb_obj_is_kind_of(obj, cMethod) - || rb_obj_is_kind_of(obj, cTkCallbackEntry)) { - if (rb_obj_respond_to(self, ID_install_cmd, Qtrue)) { - return rb_funcall(self, ID_install_cmd, 1, obj); - } else { - return tk_install_cmd_core(obj); - } - } - - if (obj == TK_None) return Qnil; - - if (rb_obj_respond_to(obj, ID_to_eval, Qtrue)) { - /* return rb_funcall(obj, ID_to_eval, 0, 0); */ - return get_eval_string_core(rb_funcall(obj, ID_to_eval, 0, 0), - enc_flag, self); - } else if (rb_obj_respond_to(obj, ID_path, Qtrue)) { - /* return rb_funcall(obj, ID_path, 0, 0); */ - return get_eval_string_core(rb_funcall(obj, ID_path, 0, 0), - enc_flag, self); - } else if (rb_obj_respond_to(obj, ID_to_s, Qtrue)) { - return rb_funcall(obj, ID_to_s, 0, 0); - } - } - - rb_warning("fail to convert '%s' to string for Tk", - RSTRING(rb_funcall(obj, rb_intern("inspect"), 0, 0))->ptr); - - return obj; -} - -static VALUE -tk_get_eval_string(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - volatile VALUE obj, enc_flag; - - if (rb_scan_args(argc, argv, "11", &obj, &enc_flag) == 1) { - enc_flag = Qnil; - } - - return get_eval_string_core(obj, enc_flag, self); -} - -static VALUE -tk_get_eval_enc_str(self, obj) - VALUE self; - VALUE obj; -{ - if (obj == TK_None) { - return obj; - } else { - return get_eval_string_core(obj, Qtrue, self); - } -} - -static VALUE -tk_conv_args(argc, argv, self) - int argc; - VALUE *argv; /* [0]:base_array, [1]:enc_mode, [2]..[n]:args */ - VALUE self; -{ - int idx, size; - volatile VALUE dst; - int thr_crit_bup; - VALUE old_gc; - - if (argc < 2) { - rb_raise(rb_eArgError, "too few arguments"); - } - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - old_gc = rb_gc_disable(); - - for(size = 0, idx = 2; idx < argc; idx++) { - if (TYPE(argv[idx]) == T_HASH) { - size += 2 * RHASH(argv[idx])->tbl->num_entries; - } else { - size++; - } - } - /* dst = rb_ary_new2(argc - 2); */ - dst = rb_ary_new2(size); - RARRAY(dst)->len = 0; - for(idx = 2; idx < argc; idx++) { - if (TYPE(argv[idx]) == T_HASH) { - if (RTEST(argv[1])) { - hash2kv_enc(argv[idx], dst, self); - } else { - hash2kv(argv[idx], dst, self); - } - } else if (argv[idx] != TK_None) { - RARRAY(dst)->ptr[RARRAY(dst)->len++] - = get_eval_string_core(argv[idx], argv[1], self); - } - } - - if (old_gc == Qfalse) rb_gc_enable(); - rb_thread_critical = thr_crit_bup; - - return rb_ary_plus(argv[0], dst); -} - - -/*************************************/ - -static VALUE -tcl2rb_bool(self, value) - VALUE self; - VALUE value; -{ - if (TYPE(value) == T_FIXNUM) { - if (NUM2INT(value) == 0) { - return Qfalse; - } else { - return Qtrue; - } - } - - if (TYPE(value) == T_TRUE || TYPE(value) == T_FALSE) { - return value; - } - - rb_check_type(value, T_STRING); - - value = rb_funcall(value, ID_downcase, 0); - - if (RSTRING(value)->ptr == (char*)NULL) return Qnil; - - if (RSTRING(value)->ptr[0] == '\0' - || strcmp(RSTRING(value)->ptr, "0") == 0 - || strcmp(RSTRING(value)->ptr, "no") == 0 - || strcmp(RSTRING(value)->ptr, "off") == 0 - || strcmp(RSTRING(value)->ptr, "false") == 0) { - return Qfalse; - } else { - return Qtrue; - } -} - -static VALUE -tkstr_to_dec(value) - VALUE value; -{ - return rb_cstr_to_inum(RSTRING(value)->ptr, 10, 1); -} - -static VALUE -tkstr_to_int(value) - VALUE value; -{ - return rb_cstr_to_inum(RSTRING(value)->ptr, 0, 1); -} - -static VALUE -tkstr_to_float(value) - VALUE value; -{ - return rb_float_new(rb_cstr_to_dbl(RSTRING(value)->ptr, 1)); -} - -static VALUE -tkstr_invalid_numstr(value) - VALUE value; -{ - rb_raise(rb_eArgError, - "invalid value for Number: '%s'", RSTRING(value)->ptr); - return Qnil; /*dummy*/ -} - -static VALUE -tkstr_rescue_float(value) - VALUE value; -{ - return rb_rescue2(tkstr_to_float, value, - tkstr_invalid_numstr, value, - rb_eArgError, 0); -} - -static VALUE -tkstr_to_number(value) - VALUE value; -{ - rb_check_type(value, T_STRING); - - if (RSTRING(value)->ptr == (char*)NULL) return INT2FIX(0); - - return rb_rescue2(tkstr_to_int, value, - tkstr_rescue_float, value, - rb_eArgError, 0); -} - -static VALUE -tcl2rb_number(self, value) - VALUE self; - VALUE value; -{ - return tkstr_to_number(value); -} - -static VALUE -tkstr_to_str(value) - VALUE value; -{ - char * ptr; - int len; - - ptr = RSTRING(value)->ptr; - len = RSTRING(value)->len; - - if (len > 1 && *ptr == '{' && *(ptr + len - 1) == '}') { - return rb_str_new(ptr + 1, len - 2); - } - return value; -} - -static VALUE -tcl2rb_string(self, value) - VALUE self; - VALUE value; -{ - rb_check_type(value, T_STRING); - - if (RSTRING(value)->ptr == (char*)NULL) return rb_tainted_str_new2(""); - - return tkstr_to_str(value); -} - -static VALUE -tcl2rb_num_or_str(self, value) - VALUE self; - VALUE value; -{ - rb_check_type(value, T_STRING); - - if (RSTRING(value)->ptr == (char*)NULL) return rb_tainted_str_new2(""); - - return rb_rescue2(tkstr_to_number, value, - tkstr_to_str, value, - rb_eArgError, 0); -} - - -/*************************************/ - -struct cbsubst_info { - int size; - char *key; - char *type; - ID *ivar; - VALUE proc; - VALUE aliases; -}; - -static void -subst_mark(ptr) - struct cbsubst_info *ptr; -{ - rb_gc_mark(ptr->proc); - rb_gc_mark(ptr->aliases); -} - -static void -subst_free(ptr) - struct cbsubst_info *ptr; -{ - if (ptr) { - if (ptr->key != (char*)NULL) free(ptr->key); - if (ptr->type != (char*)NULL) free(ptr->type); - if (ptr->ivar != (ID*)NULL) free(ptr->ivar); - free(ptr); - } -} - -static void -cbsubst_init() -{ - struct cbsubst_info *inf; - ID *ivar; - volatile VALUE proc, aliases; - - inf = ALLOC(struct cbsubst_info); - - inf->size = 0; - - inf->key = ALLOC_N(char, 1); - inf->key[0] = '\0'; - - inf->type = ALLOC_N(char, 1); - inf->type[0] = '\0'; - - ivar = ALLOC_N(ID, 1); - inf->ivar = ivar; - - proc = rb_hash_new(); - inf->proc = proc; - - aliases = rb_hash_new(); - inf->aliases = aliases; - - rb_const_set(cCB_SUBST, ID_SUBST_INFO, - Data_Wrap_Struct(cSUBST_INFO, subst_mark, subst_free, inf)); -} - -static VALUE -cbsubst_initialize(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - struct cbsubst_info *inf; - volatile VALUE proc; - int idx; - - Data_Get_Struct(rb_const_get(rb_obj_class(self), ID_SUBST_INFO), - struct cbsubst_info, inf); - - for(idx = 0; idx < argc; idx++) { - rb_ivar_set(self, inf->ivar[idx], argv[idx]); - } - - return self; -} - - -static VALUE -cbsubst_ret_val(self, val) - VALUE self; - VALUE val; -{ - return val; -} - -static int -each_attr_def(key, value, klass) - VALUE key, value, klass; -{ - ID key_id, value_id; - - if (key == Qundef) return ST_CONTINUE; - - switch(TYPE(key)) { - case T_STRING: - key_id = rb_intern(RSTRING(key)->ptr); - break; - case T_SYMBOL: - key_id = SYM2ID(key); - break; - default: - rb_raise(rb_eArgError, - "includes invalid key(s). expected a String or a Symbol"); - } - - switch(TYPE(value)) { - case T_STRING: - value_id = rb_intern(RSTRING(value)->ptr); - break; - case T_SYMBOL: - value_id = SYM2ID(value); - break; - default: - rb_raise(rb_eArgError, - "includes invalid value(s). expected a String or a Symbol"); - } - - rb_alias(klass, key_id, value_id); - - return ST_CONTINUE; -} - -static VALUE -cbsubst_def_attr_aliases(self, tbl) - VALUE self; - VALUE tbl; -{ - struct cbsubst_info *inf; - - if (TYPE(tbl) != T_HASH) { - rb_raise(rb_eArgError, "expected a Hash"); - } - - Data_Get_Struct(rb_const_get(self, ID_SUBST_INFO), - struct cbsubst_info, inf); - - rb_hash_foreach(tbl, each_attr_def, self); - - return rb_funcall(inf->aliases, rb_intern("update"), 1, tbl); -} - -static VALUE -cbsubst_get_subst_arg(argc, argv, self) - int argc; - VALUE *argv; - VALUE self; -{ - struct cbsubst_info *inf; - char *str, *buf, *ptr; - int i, j, len; - ID id; - volatile VALUE arg_sym, ret; - - Data_Get_Struct(rb_const_get(self, ID_SUBST_INFO), - struct cbsubst_info, inf); - - buf = ALLOC_N(char, 3*argc + 1); - ptr = buf; - len = strlen(inf->key); - - for(i = 0; i < argc; i++) { - switch(TYPE(argv[i])) { - case T_STRING: - str = RSTRING(argv[i])->ptr; - arg_sym = ID2SYM(rb_intern(str)); - break; - case T_SYMBOL: - arg_sym = argv[i]; - str = rb_id2name(SYM2ID(arg_sym)); - break; - default: - rb_raise(rb_eArgError, "arg #%d is not a String or a Symbol", i); - } - - if (!NIL_P(ret = rb_hash_aref(inf->aliases, arg_sym))) { - str = rb_id2name(SYM2ID(ret)); - } - - id = rb_intern(RSTRING(rb_str_cat2(rb_str_new2("@"), str))->ptr); - - for(j = 0; j < len; j++) { - if (inf->ivar[j] == id) break; - } - - if (j >= len) { - rb_raise(rb_eArgError, "cannot find attribute :%s", str); - } - - *(ptr++) = '%'; - *(ptr++) = *(inf->key + j); - *(ptr++) = ' '; - } - - *ptr = '\0'; - - ret = rb_str_new2(buf); - - free(buf); - - return ret; -} - -static VALUE -cbsubst_get_subst_key(self, str) - VALUE self; - VALUE str; -{ - volatile VALUE list; - volatile VALUE ret; - int i, len; - char *buf, *ptr; - - list = rb_funcall(cTclTkLib, ID_split_tklist, 1, str); - - len = RARRAY(list)->len; - buf = ALLOC_N(char, len + 1); - - for(i = 0; i < len; i++) { - ptr = RSTRING(RARRAY(list)->ptr[i])->ptr; - if (*ptr == '%' && *(ptr + 2) == '\0') { - *(buf + i) = *(ptr + 1); - } else { - *(buf + i) = ' '; - } - } - *(buf + len) = '\0'; - - ret = rb_str_new2(buf); - free(buf); - return ret; -} - -static VALUE -cbsubst_get_all_subst_keys(self) - VALUE self; -{ - struct cbsubst_info *inf; - char *buf, *ptr; - int i, len; - volatile VALUE ret; - - Data_Get_Struct(rb_const_get(self, ID_SUBST_INFO), - struct cbsubst_info, inf); - - len = strlen(inf->key); - buf = ALLOC_N(char, 3*len + 1); - ptr = buf; - for(i = 0; i < len; i++) { - *(ptr++) = '%'; - *(ptr++) = *(inf->key + i); - *(ptr++) = ' '; - } - *(buf + 3*len) = '\0'; - - ret = rb_ary_new3(2, rb_str_new2(inf->key), rb_str_new2(buf)); - - free(buf); - - return ret; -} - -static VALUE -cbsubst_table_setup(self, key_inf, proc_inf) - VALUE self; - VALUE key_inf; - VALUE proc_inf; -{ - struct cbsubst_info *subst_inf; - int idx; - int len = RARRAY(key_inf)->len; - int real_len = 0; - char *key = ALLOC_N(char, len + 1); - char *type = ALLOC_N(char, len + 1); - ID *ivar = ALLOC_N(ID, len + 1); - volatile VALUE proc = rb_hash_new(); - volatile VALUE aliases = rb_hash_new(); - volatile VALUE inf; - - /* init */ - subst_inf = ALLOC(struct cbsubst_info); - /* subst_inf->size = len; */ - subst_inf->key = key; - subst_inf->type = type; - subst_inf->ivar = ivar; - subst_inf->proc = proc; - subst_inf->aliases = aliases; - - /* - * keys : array of [subst, type, ivar] - * subst ==> char code - * type ==> char code - * ivar ==> symbol - */ - for(idx = 0; idx < len; idx++) { - inf = RARRAY(key_inf)->ptr[idx]; - if (TYPE(inf) != T_ARRAY) continue; - *(key + real_len) = (char)NUM2INT(RARRAY(inf)->ptr[0]); - *(type + real_len) = (char)NUM2INT(RARRAY(inf)->ptr[1]); - - *(ivar + real_len) - = rb_intern( - RSTRING( - rb_str_cat2(rb_str_new2("@"), - rb_id2name(SYM2ID(RARRAY(inf)->ptr[2]))) - )->ptr - ); - - rb_attr(self, SYM2ID(RARRAY(inf)->ptr[2]), 1, 0, Qtrue); - real_len++; - } - *(key + real_len) = '\0'; - *(type + real_len) = '\0'; - subst_inf->size = real_len; - - /* - * procs : array of [type, proc] - * type ==> char code - * proc ==> proc/method/obj (must respond to 'call') - */ - len = RARRAY(proc_inf)->len; - for(idx = 0; idx < len; idx++) { - inf = RARRAY(proc_inf)->ptr[idx]; - if (TYPE(inf) != T_ARRAY) continue; - rb_hash_aset(proc, RARRAY(inf)->ptr[0], RARRAY(inf)->ptr[1]); - } - - rb_const_set(self, ID_SUBST_INFO, - Data_Wrap_Struct(cSUBST_INFO, subst_mark, - subst_free, subst_inf)); - - return self; -} - -static VALUE -cbsubst_get_extra_args_tbl(self) - VALUE self; -{ - return rb_ary_new(); -} - -static VALUE -cbsubst_scan_args(self, arg_key, val_ary) - VALUE self; - VALUE arg_key; - VALUE val_ary; -{ - struct cbsubst_info *inf; - int idx; - int len = RARRAY(val_ary)->len; - char c; - char *ptr; - volatile VALUE dst = rb_ary_new2(len); - volatile VALUE proc; - int thr_crit_bup; - VALUE old_gc; - - thr_crit_bup = rb_thread_critical; - rb_thread_critical = Qtrue; - - old_gc = rb_gc_disable(); - - Data_Get_Struct(rb_const_get(self, ID_SUBST_INFO), - struct cbsubst_info, inf); - - RARRAY(dst)->len = 0; - for(idx = 0; idx < len; idx++) { - if (idx >= RSTRING(arg_key)->len) { - proc = Qnil; - } else if (*(RSTRING(arg_key)->ptr + idx) == ' ') { - proc = Qnil; - } else { - ptr = strchr(inf->key, *(RSTRING(arg_key)->ptr + idx)); - if (ptr == (char*)NULL) { - proc = Qnil; - } else { - c = *(inf->type + (ptr - inf->key)); - proc = rb_hash_aref(inf->proc, INT2FIX(c)); - } - } - - if (NIL_P(proc)) { - RARRAY(dst)->ptr[RARRAY(dst)->len++] = RARRAY(val_ary)->ptr[idx]; - } else { - RARRAY(dst)->ptr[RARRAY(dst)->len++] - = rb_funcall(proc, ID_call, 1, RARRAY(val_ary)->ptr[idx]); - } - } - - if (old_gc == Qfalse) rb_gc_enable(); - rb_thread_critical = thr_crit_bup; - - return dst; -} - -static VALUE -cbsubst_inspect(self) - VALUE self; -{ - return rb_str_new2("CallbackSubst"); -} - -static VALUE -substinfo_inspect(self) - VALUE self; -{ - return rb_str_new2("SubstInfo"); -} - -/*************************************/ - -static VALUE -tk_cbe_inspect(self) - VALUE self; -{ - return rb_str_new2("TkCallbackEntry"); -} - -/*************************************/ - -static VALUE -tkobj_path(self) - VALUE self; -{ - return rb_ivar_get(self, ID_at_path); -} - -/*************************************/ -/* release date */ -const char tkutil_release_date[] = TKUTIL_RELEASE_DATE; - -void -Init_tkutil() -{ - volatile VALUE tmp; - - VALUE cTK = rb_define_class("TkKernel", rb_cObject); - VALUE mTK = rb_define_module("TkUtil"); - - /* --------------------- */ - - rb_define_const(mTK, "RELEASE_DATE", - rb_obj_freeze(rb_str_new2(tkutil_release_date))); - - /* --------------------- */ - rb_global_variable(&cMethod); - cMethod = rb_const_get(rb_cObject, rb_intern("Method")); - - ID_path = rb_intern("path"); - ID_at_path = rb_intern("@path"); - ID_at_enc = rb_intern("@encoding"); - ID_to_eval = rb_intern("to_eval"); - ID_to_s = rb_intern("to_s"); - ID_source = rb_intern("source"); - ID_downcase = rb_intern("downcase"); - ID_install_cmd = rb_intern("install_cmd"); - ID_merge_tklist = rb_intern("_merge_tklist"); - ID_encoding = rb_intern("encoding"); - ID_encoding_system = rb_intern("encoding_system"); - ID_call = rb_intern("call"); - - /* --------------------- */ - cCB_SUBST = rb_define_class_under(mTK, "CallbackSubst", rb_cObject); - rb_define_singleton_method(cCB_SUBST, "inspect", cbsubst_inspect, 0); - - cSUBST_INFO = rb_define_class_under(cCB_SUBST, "Info", rb_cObject); - rb_define_singleton_method(cSUBST_INFO, "inspect", substinfo_inspect, 0); - - ID_SUBST_INFO = rb_intern("SUBST_INFO"); - rb_define_singleton_method(cCB_SUBST, "ret_val", cbsubst_ret_val, 1); - rb_define_singleton_method(cCB_SUBST, "scan_args", cbsubst_scan_args, 2); - rb_define_singleton_method(cCB_SUBST, "subst_arg", - cbsubst_get_subst_arg, -1); - rb_define_singleton_method(cCB_SUBST, "_get_subst_key", - cbsubst_get_subst_key, 1); - rb_define_singleton_method(cCB_SUBST, "_get_all_subst_keys", - cbsubst_get_all_subst_keys, 0); - rb_define_singleton_method(cCB_SUBST, "_setup_subst_table", - cbsubst_table_setup, 2); - rb_define_singleton_method(cCB_SUBST, "_get_extra_args_tbl", - cbsubst_get_extra_args_tbl, 0); - rb_define_singleton_method(cCB_SUBST, "_define_attribute_aliases", - cbsubst_def_attr_aliases, 1); - - rb_define_method(cCB_SUBST, "initialize", cbsubst_initialize, -1); - - cbsubst_init(); - - /* --------------------- */ - rb_global_variable(&cTkCallbackEntry); - cTkCallbackEntry = rb_define_class("TkCallbackEntry", cTK); - rb_define_singleton_method(cTkCallbackEntry, "inspect", tk_cbe_inspect, 0); - - /* --------------------- */ - rb_global_variable(&cTkObject); - cTkObject = rb_define_class("TkObject", cTK); - rb_define_method(cTkObject, "path", tkobj_path, 0); - - /* --------------------- */ - rb_require("tcltklib"); - rb_global_variable(&cTclTkLib); - cTclTkLib = rb_const_get(rb_cObject, rb_intern("TclTkLib")); - ID_split_tklist = rb_intern("_split_tklist"); - ID_toUTF8 = rb_intern("_toUTF8"); - ID_fromUTF8 = rb_intern("_fromUTF8"); - - /* --------------------- */ - rb_define_singleton_method(cTK, "new", tk_s_new, -1); - - /* --------------------- */ - rb_global_variable(&TK_None); - TK_None = rb_obj_alloc(rb_cObject); - rb_define_const(mTK, "None", TK_None); - rb_define_singleton_method(TK_None, "to_s", tkNone_to_s, 0); - rb_define_singleton_method(TK_None, "inspect", tkNone_to_s, 0); - OBJ_FREEZE(TK_None); - - /* --------------------- */ - rb_global_variable(&CALLBACK_TABLE); - CALLBACK_TABLE = rb_hash_new(); - - /* --------------------- */ - rb_define_singleton_method(mTK, "eval_cmd", tk_eval_cmd, -1); - rb_define_singleton_method(mTK, "callback", tk_do_callback, -1); - rb_define_singleton_method(mTK, "install_cmd", tk_install_cmd, -1); - rb_define_singleton_method(mTK, "uninstall_cmd", tk_uninstall_cmd, 1); - rb_define_singleton_method(mTK, "_symbolkey2str", tk_symbolkey2str, 1); - rb_define_singleton_method(mTK, "hash_kv", tk_hash_kv, -1); - rb_define_singleton_method(mTK, "_get_eval_string", - tk_get_eval_string, -1); - rb_define_singleton_method(mTK, "_get_eval_enc_str", - tk_get_eval_enc_str, 1); - rb_define_singleton_method(mTK, "_conv_args", tk_conv_args, -1); - - rb_define_singleton_method(mTK, "bool", tcl2rb_bool, 1); - rb_define_singleton_method(mTK, "number", tcl2rb_number, 1); - rb_define_singleton_method(mTK, "string", tcl2rb_string, 1); - rb_define_singleton_method(mTK, "num_or_str", tcl2rb_num_or_str, 1); - - rb_define_method(mTK, "_toUTF8", tk_toUTF8, -1); - rb_define_method(mTK, "_fromUTF8", tk_fromUTF8, -1); - rb_define_method(mTK, "_symbolkey2str", tk_symbolkey2str, 1); - rb_define_method(mTK, "hash_kv", tk_hash_kv, -1); - rb_define_method(mTK, "_get_eval_string", tk_get_eval_string, -1); - rb_define_method(mTK, "_get_eval_enc_str", tk_get_eval_enc_str, 1); - rb_define_method(mTK, "_conv_args", tk_conv_args, -1); - - rb_define_method(mTK, "bool", tcl2rb_bool, 1); - rb_define_method(mTK, "number", tcl2rb_number, 1); - rb_define_method(mTK, "string", tcl2rb_string, 1); - rb_define_method(mTK, "num_or_str", tcl2rb_num_or_str, 1); - - /* --------------------- */ -} |