summaryrefslogtreecommitdiff
path: root/ext/tk
diff options
context:
space:
mode:
authornagai <nagai@b2dd03c8-39d4-4d8f-98ff-823fe69b080e>2005-01-25 14:31:45 +0000
committernagai <nagai@b2dd03c8-39d4-4d8f-98ff-823fe69b080e>2005-01-25 14:31:45 +0000
commit4116b8b0f5e04347782dfbce5b1ee35134e2a31a (patch)
treed9a3897ffd5f5b93a814e71ad460d654c14684c6 /ext/tk
parent5ff5e1c91d436e44b6ecd2a8c74c191252af2ed6 (diff)
* ext/tk: merge tcltklib for Ruby/Tk installation control
* ext/tcltklib: remove git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/trunk@7826 b2dd03c8-39d4-4d8f-98ff-823fe69b080e
Diffstat (limited to 'ext/tk')
-rw-r--r--ext/tk/.cvsignore2
-rw-r--r--ext/tk/MANUAL_tcltklib.eng420
-rw-r--r--ext/tk/MANUAL_tcltklib.eucj533
-rw-r--r--ext/tk/README.1st28
-rw-r--r--ext/tk/README.ActiveTcl49
-rw-r--r--ext/tk/README.tcltklib55
-rw-r--r--ext/tk/depend2
-rw-r--r--ext/tk/extconf.rb346
-rw-r--r--ext/tk/lib/tcltk.rb367
-rw-r--r--ext/tk/old-README.tcltklib.eucj159
-rw-r--r--ext/tk/sample/tcltklib/batsu.gifbin0 -> 538 bytes
-rw-r--r--ext/tk/sample/tcltklib/lines0.tcl42
-rw-r--r--ext/tk/sample/tcltklib/lines1.rb50
-rw-r--r--ext/tk/sample/tcltklib/lines2.rb54
-rw-r--r--ext/tk/sample/tcltklib/lines3.rb54
-rw-r--r--ext/tk/sample/tcltklib/lines4.rb54
-rw-r--r--ext/tk/sample/tcltklib/maru.gifbin0 -> 481 bytes
-rw-r--r--ext/tk/sample/tcltklib/safeTk.rb22
-rw-r--r--ext/tk/sample/tcltklib/sample0.rb39
-rw-r--r--ext/tk/sample/tcltklib/sample1.rb634
-rw-r--r--ext/tk/sample/tcltklib/sample2.rb451
-rw-r--r--ext/tk/stubs.c104
-rw-r--r--ext/tk/tcltklib.c6541
23 files changed, 9986 insertions, 20 deletions
diff --git a/ext/tk/.cvsignore b/ext/tk/.cvsignore
index 44e7f26..90c83ed 100644
--- a/ext/tk/.cvsignore
+++ b/ext/tk/.cvsignore
@@ -1,3 +1,3 @@
Makefile
-mkmf.log
*.log
+*.def
diff --git a/ext/tk/MANUAL_tcltklib.eng b/ext/tk/MANUAL_tcltklib.eng
new file mode 100644
index 0000000..d3417f5
--- /dev/null
+++ b/ext/tk/MANUAL_tcltklib.eng
@@ -0,0 +1,420 @@
+(tof)
+ 2004/03/28 Hidetoshi NAGAI
+
+This document discribes about the 'tcltklib' library. Although there
+is the 'tcltk' library (tcltk.rb) under this directory, no description
+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_watchdog(check_root = true)
+ : On the normal eventloop, some kinds of callback operations
+ : cause deadlock. To avoid some of such deadlocks, this
+ : method starts an eventloop and a watchdog-thread.
+
+ do_one_event(flag = TclTkLib::EventFlag::ALL |
+ TclTkLib::EventFlag::DONT_WAIT)
+ : Do one event for processing. When processed an event,
+ : returns true.
+ : If NOT set DONT_WAIT flag, this method waits occurrence of
+ : a target event.
+ : If set DONT_WAIT flag and no event for processing, returns
+ : false immediately.
+ : If $SAFE >= 4, or $SAFE >= 1 and the flag is tainted,
+ : force to set DONT_WAIT flag.
+
+ set_eventloop_tick(timer_tick)
+ : Define the interval of thread-switching with an integer
+ : value of mili-seconds.
+ : Default timer_tick is 0. It means that thread-switching
+ : is based on the count of processed events.
+ : ( see 'set_eventloop_weight' method )
+ : However, if the eventloop thread is the only thread,
+ : timer_tick cannt be set to 0. If 0, then is set to 100 ms
+ : automatically (see NO_THREAD_INTERRUPT_TIME on tcltklib.c).
+ : On $SAFE >= 4, cannot call this method.
+
+ get_eventloop_tick
+ : Get current value of 'timer_tick'
+
+ set_no_event_wait(no_event_wait)
+ : Define sleeping time of the eventloop when two or more
+ : thread are running and there is no event for processing.
+ : Default value is 20 (ms).
+ : If the eventloop thread is the only thread, this value is
+ : invalid.
+ : On $SAFE >= 4, cannot call this method.
+
+ get_no_event_wait
+ : Get current value of 'no_event_wait'.
+
+ set_eventloop_weight(loop_max, no_event_tick)
+ : Define the weight parameters for the eventloop thread.
+ : That is invalid when the eventloop is the only thread.
+ : 'loop_max' is the max events for thread-switching.
+ : 'no_event_tick' is the increment value of the event count
+ : when no event for processing (And then, the eventloop thead
+ : sleeps 'no_event_wait' mili-seconds).
+ : 'loop_max == 800' and 'no_event_tick == 10' are defalut.
+ : On $SAFE >= 4, cannot call this method.
+
+ get_eventloop_weight
+ : Get current values of 'loop_max' and 'no_event_tick'.
+
+ mainloop_abort_on_exception=(bool)
+ : Define whether the eventloop stops on exception or not.
+ : If true (default value), stops on exception.
+ : If false, show a warinig message but ignore the exception.
+ : If nil, no warning message and ignore the excepsion.
+ : This parameter is sometimes useful when multiple Tk
+ : interpreters are working. Because the only one eventloop
+ : admins all Tk interpreters, sometimes exception on a
+ : interpreter kills the eventloop thread. Even if such
+ : situation, when abort_on_exception == false or nil,
+ : the eventloop ignores the exception and continue to working.
+ : On $SAFE >= 4, cannot call this method.
+
+ mainloop_abort_on_exception
+ : Get current status of that.
+
+ num_of_mainwindows
+ : Returns the number of main-windows (root-widget).
+ : Because there is only one main-window for one Tk interpreter,
+ : the value is same to the number of interpreters which has
+ : available Tk functions.
+
+ _merge_tklist(str, str, ... )
+ : Get a Tcl's list string from arguments with a Tcl/Tk's
+ : library function. Each arguemnt is converted to a valid
+ : Tcl list element.
+
+ _conv_listelement(str)
+ : Convert the argument to a valid Tcl list element with
+ : Tcl/Tk's library function.
+
+ _toUTF8(str, encoding)
+ _fromUTF8(str, encoding)
+ : Call the function (which is internal function of Tcl/Tk) to
+ : convert to/from a UTF8 string.
+
+ _subst_UTF_backslash(str)
+ _subst_Tcl_backslash(str)
+ : Substitute backslash sequence with Tcl's rule (include \uhhhh;
+ : give a sixteen-bit hexadecimal value for Unicode character).
+ : _subst_Tcl_backslash method parses all backslash sequence.
+ : _subst_UTF_backslash method parses \uhhhh only.
+
+class TclTkIp
+ [class methods]
+ new(ip_name=nil, options='')
+ : Generate an instance of TclTkIp class.
+ : If 'ip_name' argument is given as a string, it is the name
+ : of the Tk interpreter which is shown by 'winfo interps'
+ : command.
+ : 'options' argument accepts a string which is the command
+ : line options of wish; such as '-geometry' or '-use'.
+ : The information is used to generate the root widget of the
+ : interpreter.
+ : ( e.g. TclTkIp.new('FOO', '-geometry 500x200 -use 0x2200009') )
+ : If is given nil or falsr for the 'option' argument, generates
+ : the Tcl interpreter without Tk library. Then the interpreter
+ : doesn't need GUI environment. Therefore, even if a window
+ : system doesn't exist or cannot be used, Ruby can control the
+ : Tcl interpreter and the extention libraries loaded on the
+ : interpreter.
+
+ [instance methods]
+ create_slave(name, safe=false)
+ : Create a slave interpreter.
+ : The parent of the interpreter is the receiver of this method.
+ : The name of the slave interpreter is given by 'name' argument.
+ : The 'safe' argument decides whether the slave interpreter is
+ : created as a safe interpreter or not. If true, create a safe
+ : interpreter. Default is false. However, if the parent
+ : interpreter is a safe interpreter, the created interpreter is
+ : a safe interpreter (ignore 'safe' argument value).
+ : If $SAFE >= 4, can create a safe interpreter only.
+
+ make_safe
+ : Make the interpreter to the safe interpreter, and returns
+ : self. If fail, raise RuntimeError.
+
+ safe?
+ : Check whether the interpreter is the safe interpreter.
+ : If is the safe interpreter, returns true.
+
+ 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.
+
+ restart
+ : Restart Tk part of the interpreter.
+ : Use this when you need Tk functions after destroying the
+ : root widget.
+ : On $SAFE >= 4, cannot call this method.
+
+ _eval(str)
+ _invoke(*args)
+ : Estimates the arguments as a command on the Tk interpreter.
+ : The argument of _eval is a script of Tcl/Tk.
+ : Each argument of _invoke is a token of one command line of
+ : Tcl/Tk.
+ : Because the operation of _invoke doesn't through the
+ : command line parser of Tk interpreter, the cost of
+ : estimation is smaller than _eval. However, auto_load
+ : mechanism of the Tk interpreter doesn't work on _invoke.
+ : So _invoke can call only the command which already
+ : registered on the interpreter by 'load' command and so on.
+ : On _eval command, auto_load mechanism words. So if succeed
+ : to _eval and regist the command once, after that, the
+ : command can be called by _invoke.
+
+ _toUTF8(str, encoding)
+ _fromUTF8(str, encoding)
+ : Call the function (which is internal function of Tcl/Tk) to
+ : convert to/from a UTF8 string.
+
+ _thread_vwait(var_name)
+ _thread_tkwait(mode, target)
+ : 'vwait' or 'tkwait' with thread support.
+ : The difference from normal 'vwait' or 'tkwait' command is
+ : doing independent wait from the vwait stack when they are
+ : called on the other thread than the eventloop thread.
+ : In the case of Tcl/Tk's vwait / tkwait, if 2nd vwait /
+ : tkwait is called on waiting for 1st vwait / tkwait,
+ : returns the order of [2nd]->[1st] regardless of the order
+ : of when the wait condition was fulfilled.
+ : If _thread_vwait / _thread_tkwait is called on the
+ : eventloop thread, there is no difference from vwait /
+ : tkwait. But if called on the other thread than the
+ : eventloop, stops the thread. And when the wait condition
+ : is fulfilled, the thread restarts. The meaning of
+ : "independent from the vwait stack" is that the timing of
+ : restarting is independent from the waiting status of the
+ : other threads. That is, even if the eventloop thread is
+ : waiting by vwait and is not fulfilled the condition,
+ : _thread_vwait completes the waiting when its waiting
+ : condition is fulfilled and the thread which stopped by
+ : _thread_vwait can continue the operation.
+
+ _return_value
+ : Get the last result value on the interpreter.
+
+ _get_variable(var_name, flag)
+ _get_variable2(var_name, index_name, flag)
+ : Get the current value of a variable. If specified a
+ : index_name (see also the PARSE_VARNAME flag), get the
+ : value of the index_name element.
+
+ _set_variable(var_name, value, flag)
+ _set_variable2(var_name, index_name, value, flag)
+ : Create or modify a variable. If specified a index_name
+ : (see also the PARSE_VARNAME flag), create or modify the
+ : index_name element.
+
+ _unset_variable(var_name)
+ _unset_variable2(var_name, index_name)
+ : Remove a variable. If specified a index_name (see also
+ : the PARSE_VARNAME flag), remove the index_name element.
+
+ _get_global_var(var_name)
+ _get_global_var2(var_name, index_name)
+ _set_global_var(var_name, value)
+ _set_global_var2(var_name, index_name, value)
+ _unset_global_var(var_name)
+ _unset_global_var2(var_name, index_name)
+ : Call the associated method with the flag argument
+ : (GLOBAL_ONLY | LEAVE_ERR_MSG).
+
+ _split_tklist(str)
+ : Split the argument with Tcl/Tk's library function and
+ : get an array as a list of Tcl list elements.
+
+ _merge_tklist(str, str, ... )
+ : Get a Tcl's list string from arguments with a Tcl/Tk's
+ : library function. Each arguemnt is converted to a valid
+ : Tcl list element.
+
+ _conv_listelement(str)
+ : Convert the argument to a valid Tcl list element with
+ : Tcl/Tk's library function.
+
+ mainloop
+ mainloop_watchdog
+ : If on the slave interpreter, never start an eventloop and
+ : returns nil.
+ : With the exception that, same to the TclTkLib module method
+ : with the same name.
+
+ do_one_event
+ : With the exception that the argument is forced to set
+ : DONT_WAIT flag on the slave interpreter, same to
+ : TclTkLib#do_one_event.
+
+ set_eventloop_tick
+ get_eventloop_tick
+ set_no_event_wait
+ get_no_event_wait
+ set_eventloop_weight
+ get_eventloop_weight
+ mainloop_abort_on_exception
+ mainloop_abort_on_exception=
+ : With the exception that it is ignored to set value on the
+ : slave interpreter, same to the TclTkLib module method with
+ : the same name.
+
+class TkCallbackBreak < StandardError
+class TkCallbackContinue < StandardError
+ : They are exception classes to break or continue the Tk callback
+ : operation.
+ : If raise TkCallbackBreak on the callback procedure, Ruby returns
+ : 'break' code to Tk interpreter (Then the Tk interpreter will
+ : break the operation for the current event).
+ : If raise TkCallbackContinue, returns 'continue' code (Then the Tk
+ : interpreter will break the operateion for the current bindtag and
+ : starts the operation for the next buindtag for the current event).
+
+(eof)
diff --git a/ext/tk/MANUAL_tcltklib.eucj b/ext/tk/MANUAL_tcltklib.eucj
new file mode 100644
index 0000000..a0d7e42
--- /dev/null
+++ b/ext/tk/MANUAL_tcltklib.eucj
@@ -0,0 +1,533 @@
+(tof)
+ 2004/03/28 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_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)
+ _fromUTF8(str, encoding)
+ : Tcl/Tk が内蔵している UTF8 変換処理を呼び出す.
+
+ _subst_UTF_backslash(str)
+ _subst_Tcl_backslash(str)
+ : Tcl のルールでバックスラッシュ記法 ( \uhhhh による
+ : Unicode 文字表現を含む ) を解析する.
+ : _subst_Tcl_backslash はすべてのバックスラッシュ記法を
+ : 置き換えるのに対し,_subst_UTF_backslash は \uhhhh
+ : による Unicode 文字表現だけを置き換える.
+
+クラス TclTkIp
+ クラスメソッド
+ 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 を返す.
+
+ 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)
+ _fromUTF8(str, encoding)
+ : 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/tk/README.1st b/ext/tk/README.1st
index 038528e..fce5b02 100644
--- a/ext/tk/README.1st
+++ b/ext/tk/README.1st
@@ -1,23 +1,19 @@
-If you want to use Ruby/Tk (tk.rb and so on), you must have
-tcltklib.so which is working collectry. If you fail to call
-'require "tcltklib"', you may not have tcltklib.so.
-( see also README files of tcltklib )
-Even if there is a tcltklib.so on your Ruby library directry,
-it will not work without Tcl/Tk libraries (e.g. libtcl8.4.so)
-on your environment. You must also check that your Tcl/Tk is
-installed properly.
+If you want to use Ruby/Tk (tk.rb and so on), you must have tcltklib.so
+which is working correctly. When you have some troubles on compiling,
+please read README.tcltklib and README.ActiveTcl.
+Even if there is a tcltklib.so on your Ruby library directry, it will not
+work without Tcl/Tk libraries (e.g. libtcl8.4.so) on your environment.
+You must also check that your Tcl/Tk is installed properly.
--------------------------------------------
( the following is written in EUC-JP )
-Ruby/Tk (tk.rb など) を使いたい場合には,tcltklib.so が正しく
-動いていなければなりません.もし require "tcltklib" に失敗する
-ようなら,tcltklib.so が存在していないのかもしれません.
-( tcltklib の README ファイルも見てください )
-たとえ Ruby のライブラリディレクトリに tcltklib.so が存在して
-いたとしても,実行環境に Tcl/Tk ライブラリ (libtcl8.4.so など)
-がなければ機能しません.Tcl/Tk が正しくインストールされているか
-どうかもチェックしてください.
+Ruby/Tk (tk.rb など) を使いたい場合には,tcltklib.so が正しく動いていな
+ければなりません.コンパイル時に何か問題が生じた場合は,README.tcltklib
+や README.ActiveTcl を見てください.
+たとえ Ruby のライブラリディレクトリに tcltklib.so が存在していたとして
+も,実行環境に Tcl/Tk ライブラリ (libtcl8.4.so など) がなければ機能しま
+せん.Tcl/Tk が正しくインストールされているかもチェックしてください.
==========================================================
Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp)
diff --git a/ext/tk/README.ActiveTcl b/ext/tk/README.ActiveTcl
new file mode 100644
index 0000000..3afb3f4
--- /dev/null
+++ b/ext/tk/README.ActiveTcl
@@ -0,0 +1,49 @@
+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/tk/README.tcltklib b/ext/tk/README.tcltklib
new file mode 100644
index 0000000..4d5cd93
--- /dev/null
+++ b/ext/tk/README.tcltklib
@@ -0,0 +1,55 @@
+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 (Mac OSX only) use Tcl/Tk framework
+
+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/tk/depend b/ext/tk/depend
index fd63e23..95d5527 100644
--- a/ext/tk/depend
+++ b/ext/tk/depend
@@ -1 +1,3 @@
+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
tkutil.o: tkutil.c $(hdrdir)/ruby.h $(topdir)/config.h $(hdrdir)/defines.h
diff --git a/ext/tk/extconf.rb b/ext/tk/extconf.rb
index 8b10353..48c777e 100644
--- a/ext/tk/extconf.rb
+++ b/ext/tk/extconf.rb
@@ -1,4 +1,344 @@
+# 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)
+
+mac_need_framework =
+ is_macosx &&
+ enable_config("mac-tcltk-framework", false) &&
+ FileTest.directory?("/Library/Frameworks/Tcl.framework/") &&
+ FileTest.directory?("/Library/Frameworks/Tk.framework/")
+
+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
+ $CPPFLAGS += ' -DFORCE_TCL_THREAD=1'
+ tcl_enable_thread = true
+ when false
+ $CPPFLAGS += ' -DFORCE_TCL_THREAD=1'
+ 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 Tcl/Tk library on your environment (do coss-compile?). If the
+** consistency is not kept, some memory troubles (e.g. "Hang-up" or
+** "Segmentation Fault") may bother you. We strongly recommend you to
+** check the consistency by your own hand.
+**
+*****************************************************************************
+')
+ 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 libraries
+** seems to be compiled without "pthread support". Although You can
+** create tcltklib library, this combination may cause memory trouble
+** (e.g. "Hang-up" or "Segmentation Fault"). If you have no reason you
+** must have to keep current pthread support status, we recommend you
+** to make both or neither libraries to support pthread.
+**
+** If you want change the status of pthread support, please recompile
+** Ruby without "--enable-pthread" configure option or recompile Tcl/Tk
+** with "--enable-threads" configure option (if your Tcl/Tk is later
+** than or equal to Tcl/Tk8.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 ERRROR:
+**
+** Ruby is not compiled with --enable-pthread, but your Tcl/Tk
+** libararies seems to be compiled with "pthread support". This
+** combination possibly cause "Hang-up" or "Segmentation Fault"
+** frequently when Ruby/Tk is working. We NEVER recommend you to
+** create the library under such combination of pthread support.
+**
+** Please recompile Ruby with "--enable-pthread" configure option
+** or recompile Tcl/Tk with "--disable-threads" configure option.
+**
+*****************************************************************************
+')
+ $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 mac_need_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 mac_need_framework
+ $CPPFLAGS += ' -I/Library/Frameworks/Tcl.framework/headers -I/Library/Frameworks/Tk.framework/Headers'
+ $LDFLAGS += ' -framework Tk -framework Tcl'
+ end
+
+ if stubs or pthread_check
+ # create Makefile
+
+ # backup
+ if $INSTALLFILES
+ installfiles_bup = $INSTALLFILES.dup
+ else
+ installfiles_bup = nil
+ $INSTALLFILES = []
+ end
+
+ cleanings_bup = CLEANINGS.dup
+
+ if $objs
+ objs_bup = $objs.dup
+ else
+ objs_bup = nil
+ $objs = []
+ end
+
+ # for SUPPORT_STATUS
+ $INSTALLFILES << ["lib/tkextlib/SUPPORT_STATUS", "$(RUBYLIBDIR)", "lib"]
+
+ # for tcltklib.so
+ $objs << "stubs.o" << "tcltklib.o"
+
+ # for tkutil.so
+ mk_tkutil = "\n\n"
+ mk_tkutil << "OBJS2 = tkutil.#{$OBJEXT}\n"
+ mk_tkutil << "TARGET2 = tkutil\n"
+ mk_tkutil << "DLLIB2 = $(TARGET2).#{CONFIG['DLEXT']}\n"
+ mk_tkutil << "STATIC_LIB2 = $(TARGET2).#{$LIBEXT}\n"
+ mk_tkutil << "\n"
+ mk_tkutil << 'CLEANLIBS2 = "$(TARGET2).{lib,exp,il?,tds,map}" $(DLLIB2)'
+ mk_tkutil << "\n\n"
+ mk_tkutil << "all: $(DLLIB2)\n"
+ mk_tkutil << "static: $(STATIC_LIB2)\n"
+ mk_tkutil << "\n"
+
+ mk_tkutil << CLEANINGS.sub(/\$\(CLEANLIBS\)/, "$(CLEANLIBS) $(CLEANLIBS2)")
+ mk_tkutil << "\n\n"
+
+ mk_tkutil << "$(DLLIB2): $(OBJS2)\n\t"
+ mk_tkutil << "@-$(RM) $@\n\t"
+ mk_tkutil << "@-$(RM) $(TARGET2).lib\n\t" if $mswin
+
+ LINK_SO2 = if CONFIG["DLEXT"] == $OBJEXT
+ "ld $(DLDFLAGS) -r -o $(DLLIB2) $(OBJS2)\n"
+ else
+ "$(LDSHARED) $(DLDFLAGS) $(LIBPATH) #{OUTFLAG}$(DLLIB2) " \
+ "$(OBJS2) $(LOCAL_LIBS) $(LIBS)"
+ end
+ mk_tkutil << LINK_SO2
+
+ mk_tkutil << "\n\n"
+ mk_tkutil << "$(STATIC_LIB2): $(OBJS2)\n\t"
+ mk_tkutil << "$(AR) #{config_string('ARFLAGS') || 'cru '}$@ $(OBJS2)"
+ if ranlib = config_string('RANLIB')
+ mk_tkutil << "\n\t@-#{ranlib} $(DLLIB2) 2> /dev/null || true"
+ end
+ mk_tkutil << "\n\n\n"
+
+ mk_tkutil << "install: $(RUBYARCHDIR)/$(DLLIB2)\n"
+ mk_tkutil << "$(RUBYARCHDIR)/$(DLLIB2): $(DLLIB2) $(RUBYARCHDIR)\n"
+ mk_tkutil << "\t@$(INSTALL_PROG) $(DLLIB2) $(RUBYARCHDIR)\n"
+
+ CLEANINGS.replace(mk_tkutil)
+
+ # create
+ create_makefile("tcltklib")
+
+ # reset
+ $INSTALLFILES = installfiles_bup
+ CLEANINGS.replace(cleanings_bup)
+ $objs = objs_bup
+ end
+end
diff --git a/ext/tk/lib/tcltk.rb b/ext/tk/lib/tcltk.rb
new file mode 100644
index 0000000..1a6694d
--- /dev/null
+++ b/ext/tk/lib/tcltk.rb
@@ -0,0 +1,367 @@
+# 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/tk/old-README.tcltklib.eucj b/ext/tk/old-README.tcltklib.eucj
new file mode 100644
index 0000000..fd75202
--- /dev/null
+++ b/ext/tk/old-README.tcltklib.eucj
@@ -0,0 +1,159 @@
+(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/tk/sample/tcltklib/batsu.gif b/ext/tk/sample/tcltklib/batsu.gif
new file mode 100644
index 0000000..880cc73
--- /dev/null
+++ b/ext/tk/sample/tcltklib/batsu.gif
Binary files differ
diff --git a/ext/tk/sample/tcltklib/lines0.tcl b/ext/tk/sample/tcltklib/lines0.tcl
new file mode 100644
index 0000000..8ed3c5e
--- /dev/null
+++ b/ext/tk/sample/tcltklib/lines0.tcl
@@ -0,0 +1,42 @@
+#! /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/tk/sample/tcltklib/lines1.rb b/ext/tk/sample/tcltklib/lines1.rb
new file mode 100644
index 0000000..9f21ae6
--- /dev/null
+++ b/ext/tk/sample/tcltklib/lines1.rb
@@ -0,0 +1,50 @@
+#! /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/tk/sample/tcltklib/lines2.rb b/ext/tk/sample/tcltklib/lines2.rb
new file mode 100644
index 0000000..e459589
--- /dev/null
+++ b/ext/tk/sample/tcltklib/lines2.rb
@@ -0,0 +1,54 @@
+#! /usr/local/bin/ruby
+
+require "tk"
+
+def drawlines()
+ print Time.now, "\n"
+
+ for j in 0 .. 99
+ print "*"
+ $stdout.flush
+ if (j & 1) != 0
+ col = "blue"
+ else
+ col = "red"
+ end
+ for i in 0 .. 99
+# 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/tk/sample/tcltklib/lines3.rb b/ext/tk/sample/tcltklib/lines3.rb
new file mode 100644
index 0000000..caa50f9
--- /dev/null
+++ b/ext/tk/sample/tcltklib/lines3.rb
@@ -0,0 +1,54 @@
+#! /usr/local/bin/ruby
+
+require "tk"
+
+def drawlines()
+ print Time.now, "\n"
+
+ for j in 0 .. 99
+ print "*"
+ $stdout.flush
+ if (j & 1) != 0
+ col = "blue"
+ else
+ col = "red"
+ end
+ for i in 0 .. 99
+# $a.create(TkcLine, i, 0, 0, 500 - i, "fill"=>col)
+ end
+ end
+
+ print Time.now, "\n"
+
+ for j in 0 .. 99
+ print "*"
+ $stdout.flush
+ if (j & 1) != 0
+ col = "blue"
+ else
+ col = "red"
+ end
+ for i in 0 .. 99
+ $a.create(TkcLine, i, 0, 0, 500 - i, "fill"=>col)
+ end
+ end
+
+ print Time.now, "\n"
+# Tk.root.destroy
+end
+
+$a = TkCanvas.new{
+ height(500)
+ width(500)
+}
+
+$b = TkButton.new{
+ text("draw")
+ command(proc{drawlines()})
+}
+
+TkPack.configure($a, $b, {"side"=>"left"})
+
+Tk.mainloop
+
+# eof
diff --git a/ext/tk/sample/tcltklib/lines4.rb b/ext/tk/sample/tcltklib/lines4.rb
new file mode 100644
index 0000000..7a1175b
--- /dev/null
+++ b/ext/tk/sample/tcltklib/lines4.rb
@@ -0,0 +1,54 @@
+#! /usr/local/bin/ruby
+
+require "tk"
+
+def drawlines()
+ print Time.now, "\n"
+
+ for j in 0 .. 99
+ print "*"
+ $stdout.flush
+ if (j & 1) != 0
+ col = "blue"
+ else
+ col = "red"
+ end
+ for i in 0 .. 99
+# TkCore::INTERP.__invoke($a.path, "create", "line", i.to_s, '0', '0', (500 - i).to_s, "-fill", col)
+ end
+ end
+
+ print Time.now, "\n"
+
+ for j in 0 .. 99
+ print "*"
+ $stdout.flush
+ if (j & 1) != 0
+ col = "blue"
+ else
+ col = "red"
+ end
+ for i in 0 .. 99
+ TkCore::INTERP.__invoke($a.path, "create", "line", i.to_s, '0', '0', (500 - i).to_s, "-fill", col)
+ end
+ end
+
+ print Time.now, "\n"
+# Tk.root.destroy
+end
+
+$a = TkCanvas.new{
+ height(500)
+ width(500)
+}
+
+$b = TkButton.new{
+ text("draw")
+ command(proc{drawlines()})
+}
+
+TkPack.configure($a, $b, {"side"=>"left"})
+
+Tk.mainloop
+
+# eof
diff --git a/ext/tk/sample/tcltklib/maru.gif b/ext/tk/sample/tcltklib/maru.gif
new file mode 100644
index 0000000..2c02028
--- /dev/null
+++ b/ext/tk/sample/tcltklib/maru.gif
Binary files differ
diff --git a/ext/tk/sample/tcltklib/safeTk.rb b/ext/tk/sample/tcltklib/safeTk.rb
new file mode 100644
index 0000000..5d2c60e
--- /dev/null
+++ b/ext/tk/sample/tcltklib/safeTk.rb
@@ -0,0 +1,22 @@
+#!/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/tk/sample/tcltklib/sample0.rb b/ext/tk/sample/tcltklib/sample0.rb
new file mode 100644
index 0000000..cd4c806
--- /dev/null
+++ b/ext/tk/sample/tcltklib/sample0.rb
@@ -0,0 +1,39 @@
+#! /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/tk/sample/tcltklib/sample1.rb b/ext/tk/sample/tcltklib/sample1.rb
new file mode 100644
index 0000000..13df440
--- /dev/null
+++ b/ext/tk/sample/tcltklib/sample1.rb
@@ -0,0 +1,634 @@
+#! /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/tk/sample/tcltklib/sample2.rb b/ext/tk/sample/tcltklib/sample2.rb
new file mode 100644
index 0000000..444bb1e
--- /dev/null
+++ b/ext/tk/sample/tcltklib/sample2.rb
@@ -0,0 +1,451 @@
+#!/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/tk/stubs.c b/ext/tk/stubs.c
new file mode 100644
index 0000000..3913abb
--- /dev/null
+++ b/ext/tk/stubs.c
@@ -0,0 +1,104 @@
+int ruby_tcltk_stubs();
+
+#if defined USE_TCL_STUBS && defined USE_TK_STUBS
+#include "ruby.h"
+
+#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
+
+#include <tcl.h>
+#include <tk.h>
+
+int
+ruby_tcltk_stubs()
+{
+ DL_HANDLE tcl_dll;
+ DL_HANDLE tk_dll;
+ void (*p_Tcl_FindExecutable)(const char *);
+ Tcl_Interp *(*p_Tcl_CreateInterp)();
+ int (*p_Tk_Init)(Tcl_Interp *);
+ Tcl_Interp *tcl_ip;
+ int n;
+ char *ruby_tcl_dll = 0;
+ char *ruby_tk_dll = 0;
+ char tcl_name[20];
+ char tk_name[20];
+
+ ruby_tcl_dll = getenv("RUBY_TCL_DLL");
+#if defined _WIN32
+ if (ruby_tcl_dll) ruby_tcl_dll = ruby_strdup(ruby_tcl_dll);
+#endif
+ ruby_tk_dll = getenv("RUBY_TK_DLL");
+ if (ruby_tcl_dll && ruby_tk_dll) {
+ tcl_dll = (DL_HANDLE)DL_OPEN(ruby_tcl_dll);
+ tk_dll = (DL_HANDLE)DL_OPEN(ruby_tk_dll);
+ } else {
+ snprintf(tcl_name, sizeof tcl_name, TCL_NAME, DLEXT);
+ snprintf(tk_name, sizeof tk_name, TK_NAME, DLEXT);
+ /* examine from 8.9 to 8.1 */
+ for (n = '9'; n > '0'; n--) {
+ tcl_name[TCL_INDEX] = n;
+ tk_name[TK_INDEX] = n;
+ tcl_dll = (DL_HANDLE)DL_OPEN(tcl_name);
+ tk_dll = (DL_HANDLE)DL_OPEN(tk_name);
+ if (tcl_dll && tk_dll)
+ break;
+ }
+ }
+
+#if defined _WIN32
+ if (ruby_tcl_dll) ruby_xfree(ruby_tcl_dll);
+#endif
+
+ if (!tcl_dll || !tk_dll)
+ return -1;
+
+ p_Tcl_FindExecutable = (void (*)(const char *))DL_SYM(tcl_dll, "Tcl_FindExecutable");
+ if (!p_Tcl_FindExecutable)
+ return -7;
+
+ p_Tcl_FindExecutable("ruby");
+
+ p_Tcl_CreateInterp = (Tcl_Interp *(*)())DL_SYM(tcl_dll, "Tcl_CreateInterp");
+ if (!p_Tcl_CreateInterp)
+ return -2;
+
+ tcl_ip = (*p_Tcl_CreateInterp)();
+ if (!tcl_ip)
+ return -3;
+
+ p_Tk_Init = (int (*)(Tcl_Interp *))DL_SYM(tk_dll, "Tk_Init");
+ if (!p_Tk_Init)
+ return -4;
+ (*p_Tk_Init)(tcl_ip);
+
+ if (!Tcl_InitStubs(tcl_ip, "8.1", 0))
+ return -5;
+ if (!Tk_InitStubs(tcl_ip, "8.1", 0))
+ return -6;
+
+ Tcl_DeleteInterp(tcl_ip);
+
+ return 0;
+}
+#endif
diff --git a/ext/tk/tcltklib.c b/ext/tk/tcltklib.c
new file mode 100644
index 0000000..c9a72ed
--- /dev/null
+++ b/ext/tk/tcltklib.c
@@ -0,0 +1,6541 @@
+/*
+ * tcltklib.c
+ * Aug. 27, 1997 Y. Shigehiro
+ * Oct. 24, 1997 Y. Matsumoto
+ */
+
+#define TCLTKLIB_RELEASE_DATE "2005-01-25"
+
+#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>
+
+#ifdef __MACOS__
+# include <tkMac.h>
+# include <Quickdraw.h>
+#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 DUMP1(ARG1)
+#define DUMP2(ARG1, ARG2)
+*/
+
+/* release date */
+const char tcltklib_release_date[] = TCLTKLIB_RELEASE_DATE;
+
+/* finalize_proc_name */
+static char *finalize_hook_name = "INTERP_FINALIZE_HOOK";
+
+/* to cancel remained after-scripts when deleting IP */
+#define CANCEL_AFTER_SCRIPTS "__ruby_tcltklib_cancel_after_scripts__"
+#define DEF_CANCEL_AFTER_SCRIPTS_PROC "proc __ruby_tcltklib_cancel_after_scripts__ {} {foreach id [after info] {after cancel $id}}"
+
+/* for callback break & continue */
+static VALUE eTkCallbackReturn;
+static VALUE eTkCallbackBreak;
+static VALUE eTkCallbackContinue;
+
+static VALUE eLocalJumpError;
+
+static ID ID_at_enc;
+static ID ID_at_interp;
+
+static ID ID_stop_p;
+static ID ID_kill;
+static ID ID_join;
+
+static ID ID_call;
+static ID ID_backtrace;
+static ID ID_message;
+
+static ID ID_at_reason;
+static ID ID_return;
+static ID ID_break;
+static ID ID_next;
+
+static ID ID_to_s;
+static ID ID_inspect;
+
+static VALUE ip_invoke_real _((int, VALUE*, VALUE));
+static VALUE ip_invoke _((int, VALUE*, VALUE));
+
+/* 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;
+};
+
+void
+invoke_queue_mark(struct invoke_queue *q)
+{
+ rb_gc_mark(q->interp);
+ rb_gc_mark(q->result);
+ rb_gc_mark(q->thread);
+}
+
+void
+eval_queue_mark(struct eval_queue *q)
+{
+ rb_gc_mark(q->interp);
+ rb_gc_mark(q->result);
+ rb_gc_mark(q->thread);
+}
+
+
+static VALUE eventloop_thread;
+static VALUE watchdog_thread;
+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;
+
+#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
+
+static int ip_null_namespace _((Tcl_Interp *));
+#if TCL_MAJOR_VERSION >= 8
+#ifndef Tcl_GetCurrentNamespace
+EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace _((Tcl_Interp *));
+#endif
+#endif
+
+
+/*---- class TclTkIp ----*/
+struct tcltkip {
+ Tcl_Interp *ip; /* the interpreter */
+ 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 ptr;
+}
+
+/* increment/decrement reference count of tcltkip */
+static int
+rbtk_preserve_ip(ptr)
+ struct tcltkip *ptr;
+{
+ ptr->ref_count++;
+ 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 {
+ Tcl_Release((ClientData)ptr->ip);
+ }
+ return(ptr->ref_count);
+}
+
+/* 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[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("called timer_for_tcl");
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ Tk_DeleteTimerHandler(timer_token);
+
+ run_timer_flag = 1;
+
+ if (timer_tick > 0) {
+ timer_token = Tk_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 */
+ Tk_DeleteTimerHandler(timer_token);
+
+ timer_tick = req_timer_tick = ttick;
+ if (timer_tick > 0) {
+ /* start timer callback */
+ timer_token = Tk_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 (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ 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 (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ 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 (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ 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_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 (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ 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;
+{
+ return INT2FIX(Tk_GetNumMainWindows());
+}
+
+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;
+
+
+ if (update_flag) DUMP1("update loop start!!");
+
+ t.tv_sec = (time_t)0;
+ t.tv_usec = (time_t)(no_event_wait*1000.0);
+
+ Tk_DeleteTimerHandler(timer_token);
+ run_timer_flag = 0;
+ if (timer_tick > 0) {
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+ timer_token = Tk_CreateTimerHandler(timer_tick, _timer_for_tcl,
+ (ClientData)0);
+ rb_thread_critical = thr_crit_bup;
+ } else {
+ timer_token = (Tcl_TimerToken)NULL;
+ }
+
+ 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 = Tk_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);
+
+ if (update_flag != 0) {
+ if (found_event) {
+ DUMP1("next update loop");
+ continue;
+ } else {
+ DUMP1("update complete");
+ return 0;
+ }
+ }
+
+ DUMP1("check Root Widget");
+ if (check_root && Tk_GetNumMainWindows() == 0) {
+ run_timer_flag = 0;
+ if (!rb_prohibit_interrupt) {
+ if (rb_trap_pending) rb_trap_exec();
+ }
+ return 1;
+ }
+
+ 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 (Tcl_DoOneEvent(event_flag)) {
+ tick_counter++;
+ } else {
+ if (update_flag != 0) {
+ DUMP1("update complete");
+ return 0;
+ }
+ tick_counter += no_event_tick;
+ rb_thread_wait_for(t);
+ }
+
+ if (watchdog_thread != 0 && eventloop_thread != current) {
+ return 1;
+ }
+
+ DUMP1("check Root Widget");
+ if (check_root && Tk_GetNumMainWindows() == 0) {
+ run_timer_flag = 0;
+ if (!rb_prohibit_interrupt) {
+ if (rb_trap_pending) rb_trap_exec();
+ }
+ return 1;
+ }
+
+ DUMP1("trap check");
+ if (!rb_prohibit_interrupt) {
+ if (rb_trap_pending) rb_trap_exec();
+ }
+
+ if (loop_counter++ > 30000) {
+ /* fprintf(stderr, "loop_counter > 30000\n"); */
+ loop_counter = 0;
+ }
+
+ if (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;
+}
+
+VALUE
+lib_eventloop_main(check_rootwidget)
+ VALUE check_rootwidget;
+{
+ check_rootwidget_flag = RTEST(check_rootwidget);
+
+ if (lib_eventloop_core(check_rootwidget_flag, 0, (int *)NULL)) {
+ return Qtrue;
+ } else {
+ return Qfalse;
+ }
+}
+
+VALUE
+lib_eventloop_ensure(parent_evloop)
+ VALUE parent_evloop;
+{
+ Tk_DeleteTimerHandler(timer_token);
+ timer_token = (Tcl_TimerToken)NULL;
+ DUMP2("eventloop-ensure: current-thread : %lx\n", rb_thread_current());
+ DUMP2("eventloop-ensure: eventloop-thread : %lx\n", eventloop_thread);
+ if (eventloop_thread == rb_thread_current()) {
+ DUMP2("eventloop-thread -> %lx\n", parent_evloop);
+ eventloop_thread = parent_evloop;
+ }
+ return Qnil;
+}
+
+static VALUE
+lib_eventloop_launcher(check_rootwidget)
+ VALUE check_rootwidget;
+{
+ VALUE parent_evloop = eventloop_thread;
+
+ eventloop_thread = rb_thread_current();
+
+ if (ruby_debug) {
+ fprintf(stderr, "tcltklib: eventloop-thread : %lx -> %lx\n",
+ parent_evloop, eventloop_thread);
+ }
+
+ return rb_ensure(lib_eventloop_main, check_rootwidget,
+ lib_eventloop_ensure, parent_evloop);
+}
+
+/* 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(check_rootwidget);
+}
+
+static VALUE
+ip_mainloop(argc, argv, self)
+ int argc;
+ VALUE *argv;
+ VALUE self;
+{
+ struct tcltkip *ptr = get_ip(self);
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ return Qnil;
+ }
+
+ if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
+ /* slave IP */
+ return Qnil;
+ }
+ return lib_mainloop(argc, argv, self);
+}
+
+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 (watchdog_thread != 0) {
+ 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 (eventloop_thread == 0
+ || (loop_counter == prev_val
+ && RTEST(rb_funcall(eventloop_thread, ID_stop_p, 0))
+ && ++chance >= 3 )
+ ) {
+ /* start new eventloop thread */
+ DUMP2("eventloop thread %lx is sleeping or dead",
+ eventloop_thread);
+ evloop = rb_thread_create(lib_eventloop_launcher,
+ (void*)&check_rootwidget);
+ DUMP2("create new eventloop thread %lx", evloop);
+ loop_counter = -1;
+ chance = 0;
+ rb_thread_run(evloop);
+ } else {
+ loop_counter = prev_val;
+ chance = 0;
+ if (event_loop_wait_event) {
+ rb_thread_wait_for(t0);
+ } else {
+ rb_thread_wait_for(t1);
+ }
+ /* rb_thread_schedule(); */
+ }
+ } while(!check || Tk_GetNumMainWindows() != 0);
+
+ return Qnil;
+}
+
+VALUE
+lib_watchdog_ensure(arg)
+ VALUE arg;
+{
+ eventloop_thread = 0; /* 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 (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ return Qnil;
+ }
+
+ if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
+ /* slave IP */
+ return Qnil;
+ }
+ return lib_mainloop_watchdog(argc, argv, self);
+}
+
+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 (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 (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ 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 (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 = Qnil;
+ if (RTEST(rb_ivar_defined(exc, ID_at_enc))) {
+ enc = rb_ivar_get(exc, ID_at_enc);
+ }
+ if (NIL_P(enc) && RTEST(rb_ivar_defined(msg, ID_at_enc))) {
+ enc = rb_ivar_get(msg, ID_at_enc);
+ }
+ if (NIL_P(enc)) {
+ encoding = (Tcl_Encoding)NULL;
+ } else if (TYPE(enc) == T_STRING) {
+ encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr);
+ } else {
+ enc = rb_funcall(enc, ID_to_s, 0, 0);
+ encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr);
+ }
+
+ /* to avoid a garbled error message dialog */
+ buf = ALLOC_N(char, (RSTRING(msg)->len)+1);
+ strncpy(buf, RSTRING(msg)->ptr, RSTRING(msg)->len);
+ buf[RSTRING(msg)->len] = 0;
+
+ Tcl_DStringInit(&dstr);
+ Tcl_DStringFree(&dstr);
+ Tcl_ExternalToUtfDString(encoding, buf, RSTRING(msg)->len, &dstr);
+
+ Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL);
+ DUMP2("error message:%s", Tcl_DStringValue(&dstr));
+ free(buf);
+
+#else /* TCL_VERSION <= 8.0 */
+ Tcl_AppendResult(interp, RSTRING(msg)->ptr, (char*)NULL);
+#endif
+
+ rb_thread_critical = thr_crit_bup;
+}
+
+static VALUE
+TkStringValue(obj)
+ VALUE obj;
+{
+ switch(TYPE(obj)) {
+ case T_STRING:
+ return obj;
+
+ case T_NIL:
+ return rb_str_new2("");
+
+ case T_TRUE:
+ return rb_str_new2("1");
+
+ case T_FALSE:
+ return rb_str_new2("0");
+
+ case T_ARRAY:
+ return rb_funcall(obj, ID_join, 1, rb_str_new2(" "));
+
+ default:
+ if (rb_respond_to(obj, ID_to_s)) {
+ return rb_funcall(obj, ID_to_s, 0, 0);
+ }
+ }
+
+ return rb_funcall(obj, ID_inspect, 0, 0);
+}
+
+/* Tcl command `ruby'|`ruby_eval' */
+static VALUE
+ip_ruby_eval_rescue(failed, einfo)
+ VALUE failed;
+ VALUE einfo;
+{
+ DUMP1("call ip_ruby_eval_rescue");
+ RARRAY(failed)->ptr[0] = einfo;
+ return Qnil;
+}
+
+struct eval_body_arg {
+ char *string;
+ VALUE failed;
+};
+
+static VALUE
+ip_ruby_eval_body(arg)
+ struct eval_body_arg *arg;
+{
+ volatile VALUE ret;
+ int status = 0;
+ int thr_crit_bup;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ DUMP1("call ip_ruby_eval_body");
+ rb_trap_immediate = 0;
+
+#if 0
+ ret = rb_rescue2(rb_eval_string, (VALUE)arg->string,
+ ip_ruby_eval_rescue, arg->failed,
+ rb_eStandardError, rb_eScriptError, rb_eSystemExit,
+ (VALUE)0);
+#else
+
+ rb_thread_critical = Qfalse;
+ ret = rb_eval_string_protect(arg->string, &status);
+ rb_thread_critical = Qtrue;
+ if (status) {
+ char *errtype, *buf;
+ int errtype_len, len;
+ VALUE old_gc;
+
+ old_gc = rb_gc_disable();
+
+ switch(status) {
+ case TAG_RETURN:
+ errtype = "LocalJumpError: ";
+ errtype_len = strlen(errtype);
+ len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len;
+ buf = ALLOC_N(char, len + 1);
+ strncpy(buf, errtype, errtype_len);
+ strncpy(buf + errtype_len,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->ptr,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->len);
+ *(buf + len) = 0;
+
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackReturn, buf);
+ free(buf);
+ break;
+
+ case TAG_BREAK:
+ errtype = "LocalJumpError: ";
+ errtype_len = strlen(errtype);
+ len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len;
+ buf = ALLOC_N(char, len + 1);
+ strncpy(buf, errtype, errtype_len);
+ strncpy(buf + errtype_len,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->ptr,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->len);
+ *(buf + len) = 0;
+
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackBreak, buf);
+ free(buf);
+ break;
+
+ case TAG_NEXT:
+ errtype = "LocalJumpError: ";
+ errtype_len = strlen(errtype);
+ len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len;
+ buf = ALLOC_N(char, len + 1);
+ strncpy(buf, errtype, errtype_len);
+ strncpy(buf + errtype_len,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->ptr,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->len);
+ *(buf + len) = 0;
+
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackContinue,buf);
+ free(buf);
+ break;
+
+ case TAG_RETRY:
+ case TAG_REDO:
+ if (NIL_P(ruby_errinfo)) {
+ rb_jump_tag(status);
+ } else {
+ RARRAY(arg->failed)->ptr[0] = ruby_errinfo;
+ }
+ break;
+
+ case TAG_RAISE:
+ case TAG_FATAL:
+ if (NIL_P(ruby_errinfo)) {
+ RARRAY(arg->failed)->ptr[0]
+ = rb_exc_new2(rb_eException, "unknown exception");
+ } else {
+ RARRAY(arg->failed)->ptr[0] = ruby_errinfo;
+ }
+ break;
+
+ case TAG_THROW:
+ if (NIL_P(ruby_errinfo)) {
+ rb_jump_tag(TAG_THROW);
+ } else {
+ RARRAY(arg->failed)->ptr[0] = ruby_errinfo;
+ }
+ break;
+
+ default:
+ buf = ALLOC_N(char, 256);
+ sprintf(buf, "unknown loncaljmp status %d", status);
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(rb_eException, buf);
+ free(buf);
+ break;
+ }
+
+ if (old_gc == Qfalse) rb_gc_enable();
+
+ ret = Qnil;
+ }
+#endif
+
+ rb_thread_critical = thr_crit_bup;
+
+ return ret;
+}
+
+static VALUE
+ip_ruby_eval_ensure(trapflag)
+ VALUE trapflag;
+{
+ rb_trap_immediate = NUM2INT(trapflag);
+ return Qnil;
+}
+
+
+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
+{
+ volatile VALUE res;
+ volatile VALUE exception = rb_ary_new2(1);
+ int old_trapflag;
+ struct eval_body_arg *arg;
+ int thr_crit_bup;
+
+ /* ruby command has 1 arg. */
+ if (argc != 2) {
+ rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)",
+ argc - 1);
+ }
+
+ /* allocate */
+ arg = ALLOC(struct eval_body_arg);
+
+ /* 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->string = ALLOC_N(char, len + 1);
+ strncpy(arg->string, str, len);
+ arg->string[len] = 0;
+
+ rb_thread_critical = thr_crit_bup;
+
+ }
+#else /* TCL_MAJOR_VERSION < 8 */
+ arg->string = argv[1];
+#endif
+ /* arg.failed = 0; */
+ RARRAY(exception)->ptr[0] = Qnil;
+ RARRAY(exception)->len = 1;
+ arg->failed = exception;
+
+ /* evaluate the argument string by ruby */
+ DUMP2("rb_eval_string(%s)", arg->string);
+ old_trapflag = rb_trap_immediate;
+#ifdef HAVE_NATIVETHREAD
+ if (!is_ruby_native_thread()) {
+ rb_bug("cross-thread violation on ip_ruby_eval()");
+ }
+#endif
+ res = rb_ensure(ip_ruby_eval_body, (VALUE)arg,
+ ip_ruby_eval_ensure, INT2FIX(old_trapflag));
+
+#if TCL_MAJOR_VERSION >= 8
+ free(arg->string);
+#endif
+
+ free(arg);
+
+ /* status check */
+ /* if (arg.failed) { */
+ if (!NIL_P(RARRAY(exception)->ptr[0])) {
+ VALUE eclass;
+ volatile VALUE bt_ary;
+ volatile VALUE backtrace;
+
+ DUMP1("(rb_eval_string result) failed");
+
+ Tcl_ResetResult(interp);
+
+ res = RARRAY(exception)->ptr[0];
+ eclass = rb_obj_class(res);
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ DUMP1("set backtrace");
+ if (!NIL_P(bt_ary = rb_funcall(res, ID_backtrace, 0, 0))) {
+ backtrace = rb_ary_join(bt_ary, rb_str_new2("\n"));
+ StringValue(backtrace);
+ Tcl_AddErrorInfo(interp, RSTRING(backtrace)->ptr);
+ }
+
+ rb_thread_critical = thr_crit_bup;
+
+ if (eclass == eTkCallbackReturn) {
+ ip_set_exc_message(interp, res);
+ return TCL_RETURN;
+
+ } else if (eclass == eTkCallbackBreak) {
+ ip_set_exc_message(interp, res);
+ return TCL_BREAK;
+
+ } else if (eclass == eTkCallbackContinue) {
+ ip_set_exc_message(interp, res);
+ return TCL_CONTINUE;
+
+ } else if (eclass == rb_eSystemExit) {
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ /* Tcl_Eval(interp, "destroy ."); */
+ if (Tk_GetNumMainWindows() > 0) {
+ Tk_Window main_win = Tk_MainWindow(interp);
+ if (main_win != (Tk_Window)NULL) {
+ Tk_DestroyWindow(main_win);
+ }
+ }
+
+ /* StringValue(res); */
+ res = rb_funcall(res, ID_message, 0, 0);
+
+ Tcl_AppendResult(interp, RSTRING(res)->ptr, (char*)NULL);
+
+ rb_thread_critical = thr_crit_bup;
+
+ rb_raise(rb_eSystemExit, RSTRING(res)->ptr);
+
+ } else if (rb_obj_is_kind_of(res, eLocalJumpError)) {
+ VALUE reason = rb_ivar_get(res, ID_at_reason);
+
+ if (TYPE(reason) != T_SYMBOL) {
+ ip_set_exc_message(interp, res);
+ return TCL_ERROR;
+ }
+
+ if (SYM2ID(reason) == ID_return) {
+ ip_set_exc_message(interp, res);
+ return TCL_RETURN;
+
+ } else if (SYM2ID(reason) == ID_break) {
+ ip_set_exc_message(interp, res);
+ return TCL_BREAK;
+
+ } else if (SYM2ID(reason) == ID_next) {
+ ip_set_exc_message(interp, res);
+ return TCL_CONTINUE;
+
+ } else {
+ ip_set_exc_message(interp, res);
+ return TCL_ERROR;
+ }
+ } else {
+ ip_set_exc_message(interp, res);
+ return TCL_ERROR;
+ }
+ }
+
+ /* result must be string or nil */
+ if (NIL_P(res)) {
+ DUMP1("(rb_eval_string result) nil");
+ Tcl_ResetResult(interp);
+ return TCL_OK;
+ }
+
+ /* copy result to the tcl interpreter */
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ res = TkStringValue(res);
+ DUMP2("(rb_eval_string result) %s", RSTRING(res)->ptr);
+ DUMP1("Tcl_AppendResult");
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, RSTRING(res)->ptr, (char *)NULL);
+
+ rb_thread_critical = thr_crit_bup;
+
+ return TCL_OK;
+}
+
+
+/* Tcl command `ruby_cmd' */
+struct cmd_body_arg {
+ VALUE receiver;
+ ID method;
+ VALUE args;
+ VALUE failed;
+};
+
+static VALUE
+ip_ruby_cmd_core(arg)
+ struct cmd_body_arg *arg;
+{
+ 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;
+}
+
+static VALUE
+ip_ruby_cmd_rescue(failed, einfo)
+ VALUE failed;
+ VALUE einfo;
+{
+ DUMP1("call ip_ruby_cmd_rescue");
+ RARRAY(failed)->ptr[0] = einfo;
+ return Qnil;
+}
+
+static VALUE
+ip_ruby_cmd_body(arg)
+ struct cmd_body_arg *arg;
+{
+ volatile VALUE ret;
+ int status = 0;
+ int thr_crit_bup;
+ VALUE old_gc;
+
+ volatile VALUE receiver = arg->receiver;
+ volatile VALUE args = arg->args;
+ volatile VALUE failed = arg->failed;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ DUMP1("call ip_ruby_cmd_body");
+ rb_trap_immediate = 0;
+
+#if 0
+ ret = rb_rescue2(ip_ruby_cmd_core, (VALUE)arg,
+ ip_ruby_cmd_rescue, arg->failed,
+ rb_eStandardError, rb_eScriptError, rb_eSystemExit,
+ (VALUE)0);
+#else
+ ret = rb_protect(ip_ruby_cmd_core, (VALUE)arg, &status);
+
+ if (status) {
+ char *errtype, *buf;
+ int errtype_len, len;
+
+ old_gc = rb_gc_disable();
+
+ switch(status) {
+ case TAG_RETURN:
+ errtype = "LocalJumpError: ";
+ errtype_len = strlen(errtype);
+ len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len;
+ buf = ALLOC_N(char, len + 1);
+ strncpy(buf, errtype, errtype_len);
+ strncpy(buf + errtype_len,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->ptr,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->len);
+ *(buf + len) = 0;
+
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackReturn, buf);
+ free(buf);
+ break;
+
+ case TAG_BREAK:
+ errtype = "LocalJumpError: ";
+ errtype_len = strlen(errtype);
+ len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len;
+ buf = ALLOC_N(char, len + 1);
+ strncpy(buf, errtype, errtype_len);
+ strncpy(buf + errtype_len,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->ptr,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->len);
+ *(buf + len) = 0;
+
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackBreak, buf);
+ free(buf);
+ break;
+
+ case TAG_NEXT:
+ errtype = "LocalJumpError: ";
+ errtype_len = strlen(errtype);
+ len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len;
+ buf = ALLOC_N(char, len + 1);
+ strncpy(buf, errtype, errtype_len);
+ strncpy(buf + errtype_len,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->ptr,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->len);
+ *(buf + len) = 0;
+
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackContinue,buf);
+ free(buf);
+ break;
+
+ case TAG_RETRY:
+ case TAG_REDO:
+ if (NIL_P(ruby_errinfo)) {
+ rb_jump_tag(status);
+ } else {
+ RARRAY(arg->failed)->ptr[0] = ruby_errinfo;
+ }
+ break;
+
+ case TAG_RAISE:
+ case TAG_FATAL:
+ if (NIL_P(ruby_errinfo)) {
+ RARRAY(arg->failed)->ptr[0]
+ = rb_exc_new2(rb_eException, "unknown exception");
+ } else {
+ RARRAY(arg->failed)->ptr[0] = ruby_errinfo;
+ }
+ break;
+
+ case TAG_THROW:
+ if (NIL_P(ruby_errinfo)) {
+ rb_jump_tag(TAG_THROW);
+ } else {
+ RARRAY(arg->failed)->ptr[0] = ruby_errinfo;
+ }
+ break;
+
+ default:
+ buf = ALLOC_N(char, 256);
+ rb_warn(buf, "unknown loncaljmp status %d", status);
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(rb_eException, buf);
+ free(buf);
+ break;
+ }
+
+ if (old_gc == Qfalse) rb_gc_enable();
+
+ ret = Qnil;
+ }
+#endif
+
+ rb_thread_critical = thr_crit_bup;
+ DUMP1("finish ip_ruby_cmd_body");
+
+ return ret;
+}
+
+static VALUE
+ip_ruby_cmd_ensure(trapflag)
+ VALUE trapflag;
+{
+ rb_trap_immediate = NUM2INT(trapflag);
+ return Qnil;
+}
+
+/* ruby_cmd receiver method arg ... */
+static int
+#if TCL_MAJOR_VERSION >= 8
+ip_ruby_cmd(clientData, interp, argc, argv)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int argc;
+ Tcl_Obj *CONST argv[];
+#else /* TCL_MAJOR_VERSION < 8 */
+ip_ruby_cmd(clientData, interp, argc, argv)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int argc;
+ char *argv[];
+#endif
+{
+ volatile VALUE res;
+ volatile VALUE receiver;
+ volatile ID method;
+ volatile VALUE args = rb_ary_new2(argc - 2);
+ volatile VALUE exception = rb_ary_new2(1);
+ char *str;
+ int i;
+ int len;
+ int old_trapflag;
+ struct cmd_body_arg *arg;
+ int thr_crit_bup;
+ VALUE old_gc;
+
+ if (argc < 3) {
+ rb_raise(rb_eArgError, "too few arguments");
+ }
+
+ /* allocate */
+ arg = ALLOC(struct cmd_body_arg);
+
+ /* get arguments from Tcl objects */
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+ old_gc = rb_gc_disable();
+
+ /* get receiver */
+#if TCL_MAJOR_VERSION >= 8
+ str = Tcl_GetStringFromObj(argv[1], &len);
+#else /* TCL_MAJOR_VERSION < 8 */
+ str = argv[1];
+#endif
+ DUMP2("receiver:%s",str);
+ if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) {
+ /* class | module | constant */
+ receiver = rb_const_get(rb_cObject, rb_intern(str));
+ } else if (str[0] == '$') {
+ /* global variable */
+ receiver = rb_gv_get(str);
+ } else {
+ /* global variable omitted '$' */
+ char *buf;
+
+ len = strlen(str);
+ buf = ALLOC_N(char, len + 2);
+ buf[0] = '$';
+ strncpy(buf + 1, str, len);
+ buf[len + 1] = 0;
+ receiver = rb_gv_get(buf);
+ free(buf);
+ }
+ if (NIL_P(receiver)) {
+ rb_raise(rb_eArgError, "unknown class/module/global-variable '%s'",
+ str);
+ }
+
+ /* get metrhod */
+#if TCL_MAJOR_VERSION >= 8
+ str = Tcl_GetStringFromObj(argv[2], &len);
+#else /* TCL_MAJOR_VERSION < 8 */
+ str = argv[2];
+#endif
+ method = rb_intern(str);
+
+ /* get args */
+ RARRAY(args)->len = 0;
+ for(i = 3; i < argc; i++) {
+#if TCL_MAJOR_VERSION >= 8
+ str = Tcl_GetStringFromObj(argv[i], &len);
+ DUMP2("arg:%s",str);
+ RARRAY(args)->ptr[RARRAY(args)->len++] = rb_tainted_str_new(str, len);
+#else /* TCL_MAJOR_VERSION < 8 */
+ DUMP2("arg:%s",argv[i]);
+ RARRAY(args)->ptr[RARRAY(args)->len++] = rb_tainted_str_new2(argv[i]);
+#endif
+ }
+
+ if (old_gc == Qfalse) rb_gc_enable();
+ rb_thread_critical = thr_crit_bup;
+
+ RARRAY(exception)->ptr[0] = Qnil;
+ RARRAY(exception)->len = 1;
+
+ arg->receiver = receiver;
+ arg->method = method;
+ arg->args = args;
+ arg->failed = exception;
+
+ /* evaluate the argument string by ruby */
+ old_trapflag = rb_trap_immediate;
+#ifdef HAVE_NATIVETHREAD
+ if (!is_ruby_native_thread()) {
+ rb_bug("cross-thread violation on ip_ruby_cmd()");
+ }
+#endif
+
+ res = rb_ensure(ip_ruby_cmd_body, (VALUE)arg,
+ ip_ruby_cmd_ensure, INT2FIX(old_trapflag));
+
+ free(arg);
+
+ /* status check */
+ /* if (arg.failed) { */
+ if (!NIL_P(RARRAY(exception)->ptr[0])) {
+ VALUE eclass;
+ volatile VALUE bt_ary;
+ volatile VALUE backtrace;
+
+ DUMP1("(rb_eval_cmd result) failed");
+
+ Tcl_ResetResult(interp);
+
+ res = RARRAY(exception)->ptr[0];
+ eclass = rb_obj_class(res);
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ DUMP1("set backtrace");
+ if (!NIL_P(bt_ary = rb_funcall(res, ID_backtrace, 0, 0))) {
+ backtrace = rb_ary_join(bt_ary, rb_str_new2("\n"));
+ StringValue(backtrace);
+ Tcl_AddErrorInfo(interp, RSTRING(backtrace)->ptr);
+ }
+
+ rb_thread_critical = thr_crit_bup;
+
+ if (eclass == eTkCallbackReturn) {
+ ip_set_exc_message(interp, res);
+ return TCL_RETURN;
+
+ } else if (eclass == eTkCallbackBreak) {
+ ip_set_exc_message(interp, res);
+ return TCL_BREAK;
+
+ } else if (eclass == eTkCallbackContinue) {
+ ip_set_exc_message(interp, res);
+ return TCL_CONTINUE;
+
+ } else if (eclass == rb_eSystemExit) {
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ /* Tcl_Eval(interp, "destroy ."); */
+ if (Tk_GetNumMainWindows() > 0) {
+ Tk_Window main_win = Tk_MainWindow(interp);
+ if (main_win != (Tk_Window)NULL) {
+ Tk_DestroyWindow(main_win);
+ }
+ }
+
+ /* StringValue(res); */
+ res = rb_funcall(res, ID_message, 0, 0);
+
+ Tcl_AppendResult(interp, RSTRING(res)->ptr, (char*)NULL);
+
+ rb_thread_critical = thr_crit_bup;
+
+ rb_raise(rb_eSystemExit, RSTRING(res)->ptr);
+
+ } else if (rb_obj_is_kind_of(res, eLocalJumpError)) {
+ VALUE reason = rb_ivar_get(res, ID_at_reason);
+
+ if (TYPE(reason) != T_SYMBOL) {
+ ip_set_exc_message(interp, res);
+ return TCL_ERROR;
+ }
+
+ if (SYM2ID(reason) == ID_return) {
+ ip_set_exc_message(interp, res);
+ return TCL_RETURN;
+
+ } else if (SYM2ID(reason) == ID_break) {
+ ip_set_exc_message(interp, res);
+ return TCL_BREAK;
+
+ } else if (SYM2ID(reason) == ID_next) {
+ ip_set_exc_message(interp, res);
+ return TCL_CONTINUE;
+
+ } else {
+ ip_set_exc_message(interp, res);
+ return TCL_ERROR;
+ }
+ } else {
+ ip_set_exc_message(interp, res);
+ return TCL_ERROR;
+ }
+ }
+
+ /* result must be string or nil */
+ if (NIL_P(res)) {
+ DUMP1("(rb_eval_cmd result) nil");
+ Tcl_ResetResult(interp);
+ return TCL_OK;
+ }
+
+
+ /* copy result to the tcl interpreter */
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ old_gc = rb_gc_disable();
+
+ res = TkStringValue(res);
+
+ if (old_gc == Qfalse) rb_gc_enable();
+ DUMP2("(rb_eval_cmd result) '%s'", RSTRING(res)->ptr);
+ DUMP1("Tcl_AppendResult");
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, RSTRING(res)->ptr, (char *)NULL);
+
+ rb_thread_critical = thr_crit_bup;
+
+ DUMP1("end of ip_ruby_cmd");
+ return TCL_OK;
+}
+
+
+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
+{
+ if (!Tcl_InterpDeleted(interp) && !ip_null_namespace(interp)) {
+ Tcl_Preserve(interp);
+ Tcl_Eval(interp, "interp eval {} {destroy .}; interp delete {}");
+ 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
+ cmd = Tcl_GetString(argv[0]);
+
+#else /* TCL_MAJOR_VERSION < 8 */
+ char *endptr;
+ cmd = argv[0];
+#endif
+
+ if (rb_safe_level() >= 4) {
+ rb_raise(rb_eSecurityError,
+ "Insecure operation `exit' at level %d",
+ rb_safe_level());
+ } else if (Tcl_IsSafe(interp)) {
+ rb_raise(rb_eSecurityError,
+ "Insecure operation `exit' on a safe interpreter");
+#if 0
+ } else if (Tcl_GetMaster(interp) != (Tcl_Interp *)NULL) {
+ Tcl_Preserve(interp);
+ Tcl_Eval(interp, "interp eval {} {destroy .}");
+ Tcl_Eval(interp, "interp delete {}");
+ Tcl_Release(interp);
+ return TCL_OK;
+#endif
+ }
+
+ Tcl_ResetResult(interp);
+
+ switch(argc) {
+ case 1:
+ rb_exit(0); /* not return if succeed */
+
+ Tcl_AppendResult(interp,
+ "fail to call \"", cmd, "\"", (char *)NULL);
+ return TCL_ERROR;
+
+ case 2:
+#if TCL_MAJOR_VERSION >= 8
+ if (!Tcl_GetIntFromObj(interp, argv[1], &state)) {
+ return TCL_ERROR;
+ }
+ param = Tcl_GetString(argv[1]);
+#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);
+ }
+ param = argv[1];
+#endif
+ rb_exit(state); /* not return if succeed */
+
+ Tcl_AppendResult(interp, "fail to call \"", cmd, " ",
+ param, "\"", (char *)NULL);
+ return TCL_ERROR;
+ default:
+ /* arguemnt error */
+ Tcl_AppendResult(interp,
+ "wrong number of arguments: should be \"",
+ cmd, " ?returnCode?\"", (char *)NULL);
+ return TCL_ERROR;
+ }
+}
+
+
+/**************************/
+/* based on tclEvent.c */
+/**************************/
+
+#if 0 /*
+ Disable the following "update" and "thread_update". Bcause,
+ they don't work in a callback-proc. After calling update in
+ a callback-proc, the callback proc never be worked.
+ If the problem will be fixed in the future, may enable the
+ functions.
+ */
+/*********************/
+/* replace of update */
+/*********************/
+#if TCL_MAJOR_VERSION >= 8
+static int ip_rbUpdateObjCmd _((ClientData, Tcl_Interp *, int,
+ Tcl_Obj *CONST []));
+static int
+ip_rbUpdateObjCmd(clientData, interp, objc, objv)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int objc;
+ Tcl_Obj *CONST objv[];
+#else /* TCL_MAJOR_VERSION < 8 */
+static int ip_rbUpdateCommand _((ClientData, Tcl_Interp *, int, char *[]));
+static int
+ip_rbUpdateCommand(clientData, interp, objc, objv)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int objc;
+ char *objv[];
+#endif
+{
+ int optionIndex;
+ int ret, done;
+ int flags = 0;
+ static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
+ enum updateOptions {REGEXP_IDLETASKS};
+ char *nameString;
+ int dummy;
+
+ DUMP1("Ruby's 'update' is called");
+ if (objc == 1) {
+ flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
+
+ } else if (objc == 2) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
+ "option", 0, &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum updateOptions) optionIndex) {
+ case REGEXP_IDLETASKS: {
+ flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
+ break;
+ }
+ default: {
+ Tcl_Panic("ip_rbUpdateObjCmd: bad option index to UpdateOptions");
+ }
+ }
+ } else {
+#ifdef Tcl_WrongNumArgs
+ Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]");
+#else
+# if TCL_MAJOR_VERSION >= 8
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
+ Tcl_GetStringFromObj(objv[0], &dummy),
+ " [ idletasks ]\"",
+ (char *) NULL);
+# else /* TCL_MAJOR_VERSION < 8 */
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
+ objv[0], " [ idletasks ]\"", (char *) NULL);
+# endif
+#endif
+ return TCL_ERROR;
+ }
+
+ /* call eventloop */
+#if 1
+ ret = lib_eventloop_core(0, flags, (int *)NULL); /* ignore result */
+#else
+ Tcl_UpdateObjCmd(clientData, interp, objc, objv);
+#endif
+
+ /*
+ * Must clear the interpreter's result because event handlers could
+ * have executed commands.
+ */
+
+ DUMP2("last result '%s'", Tcl_GetStringResult(interp));
+ Tcl_ResetResult(interp);
+ DUMP1("finish Ruby's 'update'");
+ return TCL_OK;
+}
+
+
+/**********************/
+/* update with thread */
+/**********************/
+struct th_update_param {
+ VALUE thread;
+ int done;
+};
+
+static void rb_threadUpdateProc _((ClientData));
+static void
+rb_threadUpdateProc(clientData)
+ ClientData clientData; /* Pointer to integer to set to 1. */
+{
+ struct th_update_param *param = (struct th_update_param *) clientData;
+
+ DUMP1("threadUpdateProc is called");
+ param->done = 1;
+ rb_thread_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, done;
+ int flags = 0;
+ int dummy;
+ struct th_update_param *param;
+ static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
+ enum updateOptions {REGEXP_IDLETASKS};
+ volatile VALUE current_thread = rb_thread_current();
+
+ DUMP1("Ruby's 'thread_update' is called");
+
+ if (rb_thread_alone() || eventloop_thread == current_thread) {
+#define USE_TCL_UPDATE 0
+#if TCL_MAJOR_VERSION >= 8
+# if USE_TCL_UPDATE
+ DUMP1("call Tcl_UpdateObjCmd");
+ return Tcl_UpdateObjCmd(clientData, interp, objc, objv);
+# else
+ DUMP1("call ip_rbUpdateObjCmd");
+ return ip_rbUpdateObjCmd(clientData, interp, objc, objv);
+# endif
+#else /* TCL_MAJOR_VERSION < 8 */
+# if USE_TCL_UPDATE
+ DUMP1("call ip_rbUpdateCommand");
+ return Tcl_UpdateCommand(clientData, interp, objc, objv);
+# else
+ DUMP1("call ip_rbUpdateCommand");
+ return ip_rbUpdateCommand(clientData, interp, objc, objv);
+# endif
+#endif
+ }
+
+ DUMP1("start Ruby's 'thread_update' body");
+
+ if (objc == 1) {
+ flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
+
+ } else if (objc == 2) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
+ "option", 0, &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum updateOptions) optionIndex) {
+ case REGEXP_IDLETASKS: {
+ flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
+ break;
+ }
+ default: {
+ Tcl_Panic("ip_rb_threadUpdateObjCmd: bad option index to UpdateOptions");
+ }
+ }
+ } else {
+#ifdef Tcl_WrongNumArgs
+ Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]");
+#else
+# if TCL_MAJOR_VERSION >= 8
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
+ Tcl_GetStringFromObj(objv[0], &dummy),
+ " [ idletasks ]\"",
+ (char *) NULL);
+# else /* TCL_MAJOR_VERSION < 8 */
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
+ objv[0], " [ idletasks ]\"", (char *) NULL);
+# endif
+#endif
+ return TCL_ERROR;
+ }
+
+ DUMP1("pass argument check");
+
+ param = (struct th_update_param *)Tcl_Alloc(sizeof(struct th_update_param));
+ 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;
+}
+#endif /* update and thread_update don't work */
+
+
+/***************************/
+/* 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");
+ 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;
+ }
+
+ 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_core(/* not check root-widget */0, 0, &done);
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ Tcl_UntraceVar(interp, nameString,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, (ClientData) &done);
+
+ rb_thread_critical = thr_crit_bup;
+
+ /*
+ * Clear out the interpreter's result, since it may have been set
+ * by event handlers.
+ */
+
+ 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");
+
+ 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);
+
+ 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;
+
+ break;
+
+ case TKWAIT_VISIBILITY:
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ if (Tk_MainWindow(interp) == (Tk_Window)NULL) {
+ window = NULL;
+ } else {
+ window = Tk_NameToWindow(interp, nameString, tkwin);
+ }
+
+ if (window == 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);
+ 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_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) {
+ 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);
+ /*
+ * 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 (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) {
+#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 (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_MainWindow(interp) == (Tk_Window)NULL) {
+ window = NULL;
+ } else {
+ window = Tk_NameToWindow(interp, nameString, tkwin);
+ }
+
+ if (window == 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_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) {
+ 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);
+}
+
+/* destroy interpreter */
+VALUE del_root(ip)
+ Tcl_Interp *ip;
+{
+ Tk_Window main_win;
+
+ if (!Tcl_InterpDeleted(ip)) {
+ Tcl_Preserve(ip);
+
+ if ( (main_win = Tk_MainWindow(ip)) != (Tk_Window)NULL
+ && !(((Tk_FakeWin*)main_win)->flags & TK_ALREADY_DEAD) ) {
+ DUMP1("wait main_win is destroyed");
+ Tk_DestroyWindow(main_win);
+ }
+
+ Tcl_Release(ip);
+ }
+ return Qnil;
+}
+
+
+static void
+delete_slaves(ip)
+ Tcl_Interp *ip;
+{
+ Tcl_Interp *slave;
+ Tcl_Obj *slave_list, *elem;
+ Tcl_CmdInfo info;
+ char *slave_name;
+ int i, len;
+
+ if (Tcl_InterpDeleted(ip) || ip_null_namespace(ip)) {
+ DUMP2("call delete_slaves() for deleted ip(%lx)", ip);
+ return;
+ }
+
+ DUMP2("delete slaves of ip(%lx)", ip);
+
+ Tcl_Preserve(ip);
+
+ if (Tcl_Eval(ip, "info slaves") == TCL_ERROR) {
+ DUMP2("ip(%lx) cannot get a list of slave IPs", ip);
+ return;
+ }
+
+ slave_list = Tcl_GetObjResult(ip);
+ Tcl_IncrRefCount(slave_list);
+
+ if (Tcl_ListObjLength((Tcl_Interp*)NULL, slave_list, &len) == TCL_ERROR) {
+ DUMP1("slave_list is not a list object");
+ Tcl_DecrRefCount(slave_list);
+ return;
+ }
+
+ 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 = Tcl_GetSlave(ip, slave_name);
+ if (slave == (Tcl_Interp*)NULL) {
+ DUMP2("slave \"%s\" does not exist", slave_name);
+ continue;
+ }
+
+ Tcl_DecrRefCount(elem);
+
+ Tcl_Preserve(slave);
+
+ if (!Tcl_InterpDeleted(slave) && !ip_null_namespace(slave)) {
+ if (Tcl_Eval(slave, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) {
+ if (Tcl_GetCommandInfo(slave, CANCEL_AFTER_SCRIPTS, &info)) {
+ DUMP2("call cancel after scripts proc '%s'",
+ CANCEL_AFTER_SCRIPTS);
+ Tcl_Eval(slave, CANCEL_AFTER_SCRIPTS);
+ }
+ }
+
+ if (Tcl_GetCommandInfo(slave, finalize_hook_name, &info)) {
+ DUMP2("call finalize hook proc '%s'", finalize_hook_name);
+ Tcl_Eval(slave, finalize_hook_name);
+ }
+ }
+
+ /* delete slaves of slave */
+ delete_slaves(slave);
+
+ /* delete slave */
+ del_root(slave);
+ /* while(!rbtk_InterpDeleted(slave)) { */
+ if (!Tcl_InterpDeleted(slave)) {
+ DUMP1("wait ip is deleted");
+ Tcl_DeleteInterp(slave);
+ }
+
+ Tcl_Release(slave);
+
+ /* delete slave_name command */
+ Tcl_DeleteCommand(ip, slave_name);
+ }
+
+ Tcl_DecrRefCount(slave_list);
+
+ Tcl_Release(ip);
+}
+
+static void
+ip_free(ptr)
+ struct tcltkip *ptr;
+{
+ Tcl_CmdInfo info;
+ int thr_crit_bup;
+
+ DUMP2("free Tcl Interp %lx", ptr->ip);
+ if (ptr) {
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ DUMP2("IP ref_count = %d", ptr->ref_count);
+
+ if (!Tcl_InterpDeleted(ptr->ip) && !ip_null_namespace(ptr->ip)) {
+ DUMP2("IP(%lx) is not deleted", ptr->ip);
+ /* Tcl_Preserve(ptr->ip); */
+ rbtk_preserve_ip(ptr);
+
+ delete_slaves(ptr->ip);
+
+ Tcl_ResetResult(ptr->ip);
+
+ if (Tcl_Eval(ptr->ip, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) {
+ if (Tcl_GetCommandInfo(ptr->ip, CANCEL_AFTER_SCRIPTS, &info)) {
+ DUMP2("call cancel after scripts proc '%s'",
+ CANCEL_AFTER_SCRIPTS);
+ Tcl_Eval(ptr->ip, CANCEL_AFTER_SCRIPTS);
+ }
+ }
+
+ if (Tcl_GetCommandInfo(ptr->ip, finalize_hook_name, &info)) {
+ DUMP2("call finalize hook proc '%s'", finalize_hook_name);
+ Tcl_Eval(ptr->ip, finalize_hook_name);
+ }
+
+ /* del_root(ptr->ip); */
+
+ DUMP1("delete interp");
+ /* while(!rbtk_InterpDeleted(ptr->ip)) { */
+ if (!Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("wait ip is deleted");
+ Tcl_DeleteInterp(ptr->ip);
+ }
+
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ }
+
+ rbtk_release_ip(ptr);
+ DUMP2("IP ref_count = %d", ptr->ref_count);
+
+ 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 VALUE
+ip_init(argc, argv, self)
+ int argc;
+ VALUE *argv;
+ VALUE self;
+{
+ struct tcltkip *ptr; /* tcltkip data struct */
+ VALUE argv0, opts;
+ int cnt;
+ int with_tk = 1;
+ Tk_Window mainWin;
+
+ /* 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 = Tcl_CreateInterp();
+ if (ptr->ip == NULL) {
+ rb_raise(rb_eRuntimeError, "fail to create a new Tk interpreter");
+ }
+
+ 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) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
+ }
+
+ /* set variables */
+ 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");
+ if (Tk_Init(ptr->ip) == TCL_ERROR) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
+ }
+ DUMP1("Tcl_StaticPackage(\"Tk\")");
+#if TCL_MAJOR_VERSION >= 8
+ Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, Tk_SafeInit);
+#else /* 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
+
+#if 0 /*
+ Disable the following "update" and "thread_update". Bcause,
+ they don't work in a callback-proc. After calling update in
+ a callback-proc, the callback proc never be worked.
+ If the problem will be fixed in the future, may enable the
+ functions.
+ */
+ /* replace 'update' command */
+# if TCL_MAJOR_VERSION >= 8
+ DUMP1("Tcl_CreateObjCommand(\"update\")");
+ Tcl_CreateObjCommand(ptr->ip, "update", ip_rbUpdateObjCmd,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+# else /* TCL_MAJOR_VERSION < 8 */
+ DUMP1("Tcl_CreateCommand(\"update\")");
+ Tcl_CreateCommand(ptr->ip, "update", ip_rbUpdateCommand,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+# endif
+
+ /* add 'thread_update' command */
+# if TCL_MAJOR_VERSION >= 8
+ DUMP1("Tcl_CreateObjCommand(\"thread_update\")");
+ Tcl_CreateObjCommand(ptr->ip, "thread_update", ip_rb_threadUpdateObjCmd,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+# else /* TCL_MAJOR_VERSION < 8 */
+ DUMP1("Tcl_CreateCommand(\"thread_update\")");
+ Tcl_CreateCommand(ptr->ip, "thread_update", ip_rb_threadUpdateCommand,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+# endif
+#endif
+
+ /* replace 'vwait' command */
+#if TCL_MAJOR_VERSION >= 8
+ DUMP1("Tcl_CreateObjCommand(\"vwait\")");
+ Tcl_CreateObjCommand(ptr->ip, "vwait", ip_rbVwaitObjCmd,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+#else /* TCL_MAJOR_VERSION < 8 */
+ DUMP1("Tcl_CreateCommand(\"vwait\")");
+ Tcl_CreateCommand(ptr->ip, "vwait", ip_rbVwaitCommand,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+#endif
+
+ /* replace 'tkwait' command */
+#if TCL_MAJOR_VERSION >= 8
+ DUMP1("Tcl_CreateObjCommand(\"tkwait\")");
+ Tcl_CreateObjCommand(ptr->ip, "tkwait", ip_rbTkWaitObjCmd,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+#else /* TCL_MAJOR_VERSION < 8 */
+ DUMP1("Tcl_CreateCommand(\"tkwait\")");
+ Tcl_CreateCommand(ptr->ip, "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(ptr->ip, "thread_vwait", ip_rb_threadVwaitObjCmd,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+#else /* TCL_MAJOR_VERSION < 8 */
+ DUMP1("Tcl_CreateCommand(\"thread_vwait\")");
+ Tcl_CreateCommand(ptr->ip, "thread_vwait", ip_rb_threadVwaitCommand,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+#endif
+
+ /* add 'thread_tkwait' command */
+#if TCL_MAJOR_VERSION >= 8
+ DUMP1("Tcl_CreateObjCommand(\"thread_tkwait\")");
+ Tcl_CreateObjCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitObjCmd,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+#else /* TCL_MAJOR_VERSION < 8 */
+ DUMP1("Tcl_CreateCommand(\"thread_tkwait\")");
+ Tcl_CreateCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitCommand,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+#endif
+
+ Tk_Release((ClientData)mainWin);
+
+ return self;
+}
+
+static VALUE
+ip_create_slave(argc, argv, self)
+ int argc;
+ VALUE *argv;
+ VALUE self;
+{
+ struct tcltkip *master = get_ip(self);
+ struct tcltkip *slave = ALLOC(struct tcltkip);
+ VALUE safemode;
+ VALUE name;
+ int safe;
+ int thr_crit_bup;
+ Tk_Window mainWin;
+
+ /* safe-mode check */
+ if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) {
+ safemode = Qfalse;
+ }
+ if (Tcl_IsSafe(master->ip) == 1) {
+ safe = 1;
+ } else if (safemode == Qfalse || NIL_P(safemode)) {
+ safe = 0;
+ rb_secure(4);
+ } else {
+ safe = 1;
+ }
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(master->ip)) {
+ DUMP1("master-ip is deleted");
+ rb_thread_critical = thr_crit_bup;
+ rb_raise(rb_eRuntimeError, "deleted master cannot create a new slave interpreter");
+ }
+
+ /* create slave-ip */
+ slave->ref_count = 0;
+ slave->allow_ruby_exit = 0;
+ slave->return_value = 0;
+
+ slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe);
+ if (slave->ip == NULL) {
+ rb_thread_critical = thr_crit_bup;
+ rb_raise(rb_eRuntimeError, "fail to create the new slave interpreter");
+ }
+ 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_MainWindow(slave->ip);
+#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
+
+ rb_thread_critical = thr_crit_bup;
+
+ return Data_Wrap_Struct(CLASS_OF(self), 0, ip_free, slave);
+}
+
+/* make ip "safe" */
+static VALUE
+ip_make_safe(self)
+ VALUE self;
+{
+ struct tcltkip *ptr = get_ip(self);
+ Tk_Window mainWin;
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ rb_raise(rb_eRuntimeError, "interpreter is deleted");
+ }
+
+ if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
+ }
+
+ ptr->allow_ruby_exit = 0;
+
+ /* replace 'exit' command --> 'interp_exit' command */
+ mainWin = Tk_MainWindow(ptr->ip);
+#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 self;
+}
+
+/* is safe? */
+static VALUE
+ip_is_safe_p(self)
+ VALUE self;
+{
+ struct tcltkip *ptr = get_ip(self);
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ 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 (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ 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 (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ rb_raise(rb_eRuntimeError, "interpreter is deleted");
+ }
+
+ if (Tcl_IsSafe(ptr->ip)) {
+ rb_raise(rb_eSecurityError,
+ "insecure operation on a safe interpreter");
+ }
+
+ mainWin = Tk_MainWindow(ptr->ip);
+
+ 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;
+{
+ Tcl_CmdInfo info;
+ struct tcltkip *ptr = get_ip(self);
+
+ /* Tcl_Preserve(ptr->ip); */
+ rbtk_preserve_ip(ptr);
+
+ DUMP1("delete slaves");
+ delete_slaves(ptr->ip);
+
+ DUMP1("finalize operation");
+ if (Tcl_Eval(ptr->ip, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) {
+ if (Tcl_GetCommandInfo(ptr->ip, CANCEL_AFTER_SCRIPTS, &info)) {
+ DUMP2("call cancel after scripts proc '%s'",
+ CANCEL_AFTER_SCRIPTS);
+ Tcl_Eval(ptr->ip, CANCEL_AFTER_SCRIPTS);
+ }
+ }
+
+ if (Tcl_GetCommandInfo(ptr->ip, finalize_hook_name, &info)) {
+ DUMP2("call finalize hook proc '%s'", finalize_hook_name);
+ Tcl_Eval(ptr->ip, finalize_hook_name);
+ }
+
+ del_root(ptr->ip);
+
+ DUMP1("delete interp");
+ /* while(!rbtk_InterpDeleted(ptr->ip)) { */
+ if (!Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("wait ip is deleted");
+ Tcl_DeleteInterp(ptr->ip);
+ }
+
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+
+ return Qnil;
+}
+
+/* is deleted? */
+static int
+ip_null_namespace(interp)
+ Tcl_Interp *interp;
+{
+#if TCL_MAJOR_VERSION < 8
+ return 0;
+#else /* support Namespace */
+ return ( Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL );
+#endif
+}
+
+static VALUE
+ip_has_null_namespace_p(self)
+ VALUE self;
+{
+ struct tcltkip *ptr = get_ip(self);
+
+ if (ip_null_namespace(ptr->ip)) {
+ return Qtrue;
+ } else {
+ return Qfalse;
+ }
+}
+
+static VALUE
+ip_is_deleted_p(self)
+ VALUE self;
+{
+ struct tcltkip *ptr = get_ip(self);
+
+ if (Tcl_InterpDeleted(ptr->ip)) {
+ return Qtrue;
+ } else {
+ return Qfalse;
+ }
+}
+
+
+static VALUE
+#ifdef HAVE_STDARG_PROTOTYPES
+create_ip_exc(VALUE interp, VALUE exc, const char *fmt, ...)
+#else
+create_ip_exc(interp, exc, fmt, va_alist)
+ VALUE interp:
+ VALUE exc;
+ const char *fmt;
+ va_dcl
+#endif
+{
+ va_list args;
+ char buf[BUFSIZ];
+ VALUE einfo;
+
+ va_init_list(args,fmt);
+ vsnprintf(buf, BUFSIZ, fmt, args);
+ buf[BUFSIZ - 1] = '\0';
+ va_end(args);
+ einfo = rb_exc_new2(exc, buf);
+ rb_ivar_set(einfo, ID_at_interp, interp);
+ Tcl_ResetResult(get_ip(interp)->ip);
+
+ return einfo;
+}
+
+static VALUE
+ip_get_result_string_obj(interp)
+ Tcl_Interp *interp;
+{
+#if TCL_MAJOR_VERSION >= 8
+ int len;
+ char *s;
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ s = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
+ if (s == (char*)NULL) {
+ return rb_tainted_str_new2("");
+ } else {
+ return(rb_tainted_str_new(s, len));
+ }
+
+# else /* TCL_VERSION >= 8.1 */
+ volatile VALUE strval;
+ Tcl_Obj *retobj = Tcl_GetObjResult(interp);
+ int thr_crit_bup;
+
+ Tcl_IncrRefCount(retobj);
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ if (Tcl_GetCharLength(retobj) != Tcl_UniCharLen(Tcl_GetUnicode(retobj))) {
+ /* possibly binary string */
+ s = Tcl_GetByteArrayFromObj(retobj, &len);
+ if (s == (char*)NULL) {
+ strval = rb_tainted_str_new2("");
+ } else {
+ strval = rb_tainted_str_new(s, len);
+ }
+ rb_ivar_set(strval, ID_at_enc, rb_str_new2("binary"));
+ } else {
+ /* possibly text string */
+ s = Tcl_GetStringFromObj(retobj, &len);
+ if (s == (char*)NULL) {
+ strval = rb_tainted_str_new2("");
+ } else {
+ strval = rb_tainted_str_new(s, len);
+ }
+ }
+
+ rb_thread_critical = thr_crit_bup;
+
+ Tcl_DecrRefCount(retobj);
+
+ return(strval);
+
+# endif
+#else /* TCL_MAJOR_VERSION < 8 */
+ return(rb_tainted_str_new2(interp->result));
+#endif
+}
+
+/* eval string in tcl by Tcl_Eval() */
+static VALUE
+ip_eval_real(self, cmd_str, cmd_len)
+ VALUE self;
+ char *cmd_str;
+ int cmd_len;
+{
+ volatile VALUE ret;
+ char *s;
+ int len;
+ struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
+
+#if TCL_MAJOR_VERSION >= 8
+ /* call Tcl_EvalObj() */
+ {
+ Tcl_Obj *cmd;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ cmd = Tcl_NewStringObj(cmd_str, cmd_len);
+ Tcl_IncrRefCount(cmd);
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ Tcl_DecrRefCount(cmd);
+ rb_thread_critical = thr_crit_bup;
+ ptr->return_value = TCL_OK;
+ return rb_tainted_str_new2("");
+ } else {
+ /* Tcl_Preserve(ptr->ip); */
+ rbtk_preserve_ip(ptr);
+
+ ptr->return_value = Tcl_EvalObj(ptr->ip, cmd);
+ /* ptr->return_value = Tcl_GlobalEvalObj(ptr->ip, cmd); */
+ }
+
+ Tcl_DecrRefCount(cmd);
+
+ }
+
+ if (ptr->return_value == TCL_ERROR) {
+ volatile VALUE exc;
+ exc = create_ip_exc(self, rb_eRuntimeError,
+ "%s", Tcl_GetStringResult(ptr->ip));
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+
+ rb_thread_critical = thr_crit_bup;
+ rb_exc_raise(exc);
+ }
+ DUMP2("(TCL_Eval result) %d", ptr->return_value);
+
+ /* pass back the result (as string) */
+ ret = ip_get_result_string_obj(ptr->ip);
+ /* Tcl_Release(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 (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ 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 (ptr->return_value == TCL_ERROR) {
+ volatile VALUE exc;
+ exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result);
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_exc_raise(exc);
+ }
+ DUMP2("(TCL_Eval result) %d", ptr->return_value);
+
+ /* pass back the result (as string) */
+ ret = ip_get_result_string_obj(ptr->ip);
+ /* Tcl_Release(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;
+
+ DUMP2("do_eval_queue_handler : evPtr = %p", evPtr);
+ DUMP2("eval queue_thread : %lx", rb_thread_current());
+ DUMP2("added by thread : %lx", q->thread);
+
+ if (*(q->done)) {
+ 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 {
+ DUMP2("call eval_real (for caller thread:%lx)", q->thread);
+ DUMP2("call eval_real (current thread:%lx)", rb_thread_current());
+ ret = ip_eval_real(q->interp, q->str, q->len);
+ }
+
+ /* set result */
+ RARRAY(q->result)->ptr[0] = ret;
+
+ /* complete */
+ *(q->done) = -1;
+
+ /* back to caller */
+ DUMP2("back to caller (caller thread:%lx)", q->thread);
+ DUMP2(" (current thread:%lx)", rb_thread_current());
+ 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 (eventloop_thread == 0 || current == eventloop_thread) {
+ if (eventloop_thread) {
+ DUMP2("eval from current eventloop %lx", current);
+ } else {
+ DUMP2("eval from thread:%lx but no eventloop", current);
+ }
+ result = ip_eval_real(self, 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);
+ strncpy(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(self)
+ VALUE self;
+{
+ volatile VALUE exc;
+ struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
+
+ rb_secure(4);
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ rb_raise(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);
+
+ /* delete namespace ( tested on tk8.4.5 ) */
+ ptr->return_value = Tcl_Eval(ptr->ip, "namespace delete ::tk::msgcat");
+ /* ignore ERROR */
+ DUMP2("(TCL_Eval result) %d", ptr->return_value);
+ Tcl_ResetResult(ptr->ip);
+
+ /* delete trace proc ( tested on tk8.4.5 ) */
+ ptr->return_value = Tcl_Eval(ptr->ip, "trace vdelete ::tk_strictMotif w ::tk::EventMotifBindings");
+ /* ignore ERROR */
+ DUMP2("(TCL_Eval result) %d", ptr->return_value);
+ Tcl_ResetResult(ptr->ip);
+
+ /* execute Tk_Init of Tk_SafeInit */
+#if TCL_MAJOR_VERSION >= 8
+ if (Tcl_IsSafe(ptr->ip)) {
+ DUMP1("Tk_SafeInit");
+ if (Tk_SafeInit(ptr->ip) == TCL_ERROR) {
+ exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+ rb_exc_raise(exc);
+ }
+ } else {
+ DUMP1("Tk_Init");
+ if (Tk_Init(ptr->ip) == TCL_ERROR) {
+ exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+ rb_exc_raise(exc);
+ }
+ }
+#else /* TCL_MAJOR_VERSION < 8 */
+ DUMP1("Tk_Init");
+ if (Tk_Init(ptr->ip) == TCL_ERROR) {
+ exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_exc_raise(exc);
+ }
+#endif
+
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+
+ rb_thread_critical = thr_crit_bup;
+
+ return Qnil;
+}
+
+
+static VALUE
+ip_restart(self)
+ VALUE self;
+{
+ struct tcltkip *ptr = get_ip(self);
+
+ rb_secure(4);
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ 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;
+
+ if (NIL_P(ip_obj)) {
+ interp = (Tcl_Interp *)NULL;
+ } else {
+ interp = get_ip(ip_obj)->ip;
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(interp)) {
+ DUMP1("ip is deleted");
+ interp = (Tcl_Interp *)NULL;
+ }
+ }
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ if (NIL_P(encodename)) {
+ if (TYPE(str) == T_STRING) {
+ volatile VALUE enc;
+
+ enc = Qnil;
+ if (RTEST(rb_ivar_defined(str, ID_at_enc))) {
+ enc = rb_ivar_get(str, ID_at_enc);
+ }
+ if (NIL_P(enc)) {
+ if (NIL_P(ip_obj)) {
+ encoding = (Tcl_Encoding)NULL;
+ } else {
+ if (RTEST(rb_ivar_defined(ip_obj, ID_at_enc))) {
+ enc = rb_ivar_get(ip_obj, ID_at_enc);
+ }
+ if (NIL_P(enc)) {
+ encoding = (Tcl_Encoding)NULL;
+ } else {
+ StringValue(enc);
+ encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr);
+ if (encoding == (Tcl_Encoding)NULL) {
+ rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING(enc)->ptr);
+ }
+ }
+ }
+ } else {
+ StringValue(enc);
+ if (strcmp(RSTRING(enc)->ptr, "binary") == 0) {
+ rb_thread_critical = thr_crit_bup;
+ return str;
+ }
+ encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr);
+ if (encoding == (Tcl_Encoding)NULL) {
+ rb_warning("string has unknown encoding information (@encoding:'%s')", RSTRING(enc)->ptr);
+ }
+ }
+ } else {
+ encoding = (Tcl_Encoding)NULL;
+ }
+ } else {
+ StringValue(encodename);
+ encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr);
+ if (encoding == (Tcl_Encoding)NULL) {
+ /*
+ rb_warning("unknown encoding name '%s'",
+ RSTRING(encodename)->ptr);
+ */
+ 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);
+ strncpy(buf, RSTRING(str)->ptr, RSTRING(str)->len);
+ buf[RSTRING(str)->len] = 0;
+
+ Tcl_DStringInit(&dstr);
+ Tcl_DStringFree(&dstr);
+ /* Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr); */
+ Tcl_ExternalToUtfDString(encoding, buf, RSTRING(str)->len, &dstr);
+
+ /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */
+ str = rb_str_new2(Tcl_DStringValue(&dstr));
+ rb_ivar_set(str, ID_at_enc, rb_tainted_str_new2("utf-8"));
+ if (taint_flag) OBJ_TAINT(str);
+
+ 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;
+
+ if (NIL_P(ip_obj)) {
+ interp = (Tcl_Interp *)NULL;
+ } else {
+ interp = get_ip(ip_obj)->ip;
+ }
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ if (NIL_P(encodename)) {
+ volatile VALUE enc;
+
+ if (TYPE(str) == T_STRING) {
+ enc = Qnil;
+ if (RTEST(rb_ivar_defined(str, ID_at_enc))) {
+ enc = rb_ivar_get(str, ID_at_enc);
+ }
+ if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) {
+ rb_thread_critical = thr_crit_bup;
+ return str;
+ }
+ }
+
+ if (NIL_P(ip_obj)) {
+ encoding = (Tcl_Encoding)NULL;
+ } else {
+ enc = Qnil;
+ if (RTEST(rb_ivar_defined(ip_obj, ID_at_enc))) {
+ enc = rb_ivar_get(ip_obj, ID_at_enc);
+ }
+ if (NIL_P(enc)) {
+ encoding = (Tcl_Encoding)NULL;
+ } else {
+ StringValue(enc);
+ encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr);
+ if (encoding == (Tcl_Encoding)NULL) {
+ rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING(enc)->ptr);
+ } else {
+ encodename = rb_obj_dup(enc);
+ }
+ }
+ }
+
+ } else {
+ StringValue(encodename);
+
+ if (strcmp(RSTRING(encodename)->ptr, "binary") == 0) {
+ char *s;
+ int len;
+
+ s = Tcl_GetByteArrayFromObj(Tcl_NewStringObj(RSTRING(str)->ptr,
+ RSTRING(str)->len),
+ &len);
+ str = rb_tainted_str_new(s, len);
+ rb_ivar_set(str, ID_at_enc, rb_tainted_str_new2("binary"));
+
+ rb_thread_critical = thr_crit_bup;
+ return str;
+ }
+
+ encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr);
+ if (encoding == (Tcl_Encoding)NULL) {
+ /*
+ rb_warning("unknown encoding name '%s'",
+ RSTRING(encodename)->ptr);
+ encodename = Qnil;
+ */
+ 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);
+ strncpy(buf, RSTRING(str)->ptr, RSTRING(str)->len);
+ buf[RSTRING(str)->len] = 0;
+
+ Tcl_DStringInit(&dstr);
+ Tcl_DStringFree(&dstr);
+ /* Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr); */
+ Tcl_UtfToExternalDString(encoding,buf,RSTRING(str)->len,&dstr);
+
+ /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */
+ str = rb_str_new2(Tcl_DStringValue(&dstr));
+ rb_ivar_set(str, ID_at_enc, encodename);
+
+ if (taint_flag) OBJ_TAINT(str);
+
+ 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;
+
+ StringValue(str);
+ if (!RSTRING(str)->len) {
+ return str;
+ }
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ src_buf = ALLOC_N(char,(RSTRING(str)->len)+1);
+ strncpy(src_buf, RSTRING(str)->ptr, RSTRING(str)->len);
+ src_buf[RSTRING(str)->len] = 0;
+
+ dst_buf = ALLOC_N(char,(RSTRING(str)->len)+1);
+
+ ptr = src_buf;
+ while(RSTRING(str)->len > ptr - src_buf) {
+ if (*ptr == '\\' && (all_bs || *(ptr + 1) == 'u')) {
+ dst_len += Tcl_UtfBackslash(ptr, &read_len, (dst_buf + dst_len));
+ ptr += read_len;
+ } else {
+ *(dst_buf + (dst_len++)) = *(ptr++);
+ }
+ }
+
+ str = rb_str_new(dst_buf, dst_len);
+ if (taint_flag) OBJ_TAINT(str);
+
+ free(src_buf);
+ free(dst_buf);
+
+ rb_thread_critical = thr_crit_bup;
+#endif
+
+ return str;
+}
+
+static VALUE
+lib_UTF_backslash(self, str)
+ VALUE self;
+ VALUE str;
+{
+ return lib_UTF_backslash_core(self, str, 0);
+}
+
+static VALUE
+lib_Tcl_backslash(self, str)
+ VALUE self;
+ VALUE str;
+{
+ return lib_UTF_backslash_core(self, str, 1);
+}
+
+#if TCL_MAJOR_VERSION >= 8
+static VALUE
+ip_invoke_core(interp, objc, objv)
+ VALUE interp;
+ int objc;
+ Tcl_Obj **objv;
+#else
+static VALUE
+ip_invoke_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;
+
+#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 (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ return rb_tainted_str_new2("");
+ }
+
+ /* 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");
+ /* if (event_loop_abort_on_exc || cmd[0] != '.') { */
+ if (event_loop_abort_on_exc > 0) {
+ /*rb_ip_raise(obj,rb_eNameError,"invalid command name `%s'",cmd);*/
+ return create_ip_exc(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);
+ return rb_tainted_str_new2("");
+ }
+ }
+ DUMP1("end Tcl_GetCommandInfo");
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ /* memory allocation for arguments of this command */
+#if TCL_MAJOR_VERSION >= 8
+ if (!info.isNativeObjectProc) {
+ /* 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
+ }
+
+ rb_thread_critical = thr_crit_bup;
+
+ /* exception on mainloop */
+ if (ptr->return_value == TCL_ERROR) {
+ if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
+#if TCL_MAJOR_VERSION >= 8
+ return create_ip_exc(interp, rb_eRuntimeError,
+ "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ return create_ip_exc(interp, rb_eRuntimeError,
+ "%s", ptr->ip->result);
+#endif
+ } else {
+ if (event_loop_abort_on_exc < 0) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_warning("%s (ignore)", ptr->ip->result);
+#endif
+ } else {
+#if TCL_MAJOR_VERSION >= 8
+ rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_warn("%s (ignore)", ptr->ip->result);
+#endif
+ }
+ Tcl_ResetResult(ptr->ip);
+ return rb_tainted_str_new2("");
+ }
+ }
+
+ /* 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;
+ VALUE v;
+ char *s;
+ int thr_crit_bup;
+
+#if TCL_MAJOR_VERSION >= 8
+ Tcl_Obj **av = (Tcl_Obj **)NULL;
+ Tcl_Obj *resultPtr;
+#else /* TCL_MAJOR_VERSION < 8 */
+ char **av = (char **)NULL;
+#endif
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ /* memory allocation */
+#if TCL_MAJOR_VERSION >= 8
+ av = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, argc+1);
+ for (i = 0; i < argc; ++i) {
+ VALUE enc;
+
+ v = argv[i];
+ s = StringValuePtr(v);
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ av[i] = Tcl_NewStringObj(s, RSTRING(v)->len);
+# else /* TCL_VERSION >= 8.1 */
+ enc = Qnil;
+ if (RTEST(rb_ivar_defined(v, ID_at_enc))) {
+ enc = rb_ivar_get(v, ID_at_enc);
+ }
+ if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) {
+ /* binary string */
+ av[i] = Tcl_NewByteArrayObj(s, RSTRING(v)->len);
+ } else if (strlen(s) != RSTRING(v)->len) {
+ /* probably binary string */
+ av[i] = Tcl_NewByteArrayObj(s, RSTRING(v)->len);
+ } else {
+ /* probably text string */
+ av[i] = Tcl_NewStringObj(s, RSTRING(v)->len);
+ }
+# endif
+ Tcl_IncrRefCount(av[i]);
+ }
+ av[argc] = (Tcl_Obj *)NULL;
+
+#else /* TCL_MAJOR_VERSION < 8 */
+ /* string interface */
+ av = (char **)ALLOC_N(char *, argc+1);
+ for (i = 0; i < argc; ++i) {
+ v = argv[i];
+ s = StringValuePtr(v);
+ av[i] = ALLOC_N(char, strlen(s)+1);
+ strcpy(av[i], s);
+ }
+ av[argc] = (char *)NULL;
+#endif
+
+ rb_thread_critical = thr_crit_bup;
+
+ return av;
+}
+
+static void
+free_invoke_arguments(argc, av)
+ int argc;
+#if TCL_MAJOR_VERSION >= 8
+ Tcl_Obj **av;
+#else /* TCL_MAJOR_VERSION < 8 */
+ char **av;
+#endif
+{
+ int i;
+
+ for (i = 0; i < argc; ++i) {
+#if TCL_MAJOR_VERSION >= 8
+ Tcl_DecrRefCount(av[i]);
+#else /* TCL_MAJOR_VERSION < 8 */
+ free(av[i]);
+#endif
+ }
+ free(av);
+}
+
+static VALUE
+ip_invoke_real(argc, argv, interp)
+ int argc;
+ VALUE *argv;
+ VALUE interp;
+{
+ VALUE v;
+ struct tcltkip *ptr; /* tcltkip data struct */
+ int i;
+ Tcl_CmdInfo info;
+ char *s;
+ int len;
+ int thr_crit_bup;
+
+#if TCL_MAJOR_VERSION >= 8
+ Tcl_Obj **av = (Tcl_Obj **)NULL;
+ Tcl_Obj *resultPtr;
+#else /* TCL_MAJOR_VERSION < 8 */
+ char **av = (char **)NULL;
+#endif
+
+ DUMP2("invoke_real called by thread:%lx", rb_thread_current());
+
+ /* allocate memory for arguments */
+ av = alloc_invoke_arguments(argc, argv);
+
+ /* get the data struct */
+ ptr = get_ip(interp);
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ return rb_tainted_str_new2("");
+ }
+
+ /* 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 (eventloop_thread == 0 || current == eventloop_thread) {
+ if (eventloop_thread) {
+ DUMP2("invoke from current eventloop %lx", current);
+ } else {
+ DUMP2("invoke from thread:%lx but no eventloop", 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 (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ 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_variable(self, varname_arg, flag_arg)
+ VALUE self;
+ VALUE varname_arg;
+ VALUE flag_arg;
+{
+ struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
+ volatile VALUE varname, flag;
+
+ varname = varname_arg;
+ flag = flag_arg;
+
+ StringValue(varname);
+
+#if TCL_MAJOR_VERSION >= 8
+ {
+ Tcl_Obj *nameobj, *ret;
+ char *s;
+ int len;
+ volatile VALUE strval;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr,
+ RSTRING(varname)->len);
+ Tcl_IncrRefCount(nameobj);
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ Tcl_DecrRefCount(nameobj);
+ rb_thread_critical = thr_crit_bup;
+ return rb_tainted_str_new2("");
+ } else {
+ /* Tcl_Preserve(ptr->ip); */
+ rbtk_preserve_ip(ptr);
+ ret = Tcl_ObjGetVar2(ptr->ip, nameobj, (Tcl_Obj*)NULL,
+ FIX2INT(flag));
+ }
+
+ Tcl_DecrRefCount(nameobj);
+
+ if (ret == (Tcl_Obj*)NULL) {
+ volatile VALUE exc;
+#if TCL_MAJOR_VERSION >= 8
+ exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
+#endif
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+ rb_exc_raise(exc);
+ }
+
+ Tcl_IncrRefCount(ret);
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ Tcl_DecrRefCount(ret);
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+ return(strval);
+
+# else /* TCL_VERSION >= 8.1 */
+ if (Tcl_GetCharLength(ret)
+ != Tcl_UniCharLen(Tcl_GetUnicode(ret))) {
+ /* possibly binary string */
+ s = Tcl_GetByteArrayFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ rb_ivar_set(strval, ID_at_enc, rb_tainted_str_new2("binary"));
+ } else {
+ /* possibly text string */
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ }
+
+ Tcl_DecrRefCount(ret);
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+
+ return(strval);
+# endif
+ }
+#else /* TCL_MAJOR_VERSION < 8 */
+ {
+ char *ret;
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ return rb_tainted_str_new2("");
+ } else {
+ /* Tcl_Preserve(ptr->ip); */
+ rbtk_preserve_ip(ptr);
+ ret = Tcl_GetVar2(ptr->ip, RSTRING(varname)->ptr,
+ (char*)NULL, FIX2INT(flag));
+ }
+
+ if (ret == (char*)NULL) {
+ volatile VALUE exc;
+#if TCL_MAJOR_VERSION >= 8
+ exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
+#endif
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+ rb_exc_raise(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_arg, index_arg, flag_arg)
+ VALUE self;
+ VALUE varname_arg;
+ VALUE index_arg;
+ VALUE flag_arg;
+{
+ struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
+ volatile VALUE varname, index, flag;
+
+ if (NIL_P(index_arg)) {
+ return ip_get_variable(self, varname_arg, flag_arg);
+ }
+
+ varname = varname_arg;
+ index = index_arg;
+ flag = flag_arg;
+
+ StringValue(varname);
+ StringValue(index);
+
+#if TCL_MAJOR_VERSION >= 8
+ {
+ Tcl_Obj *nameobj, *idxobj, *ret;
+ char *s;
+ int len;
+ volatile VALUE strval;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr,
+ RSTRING(varname)->len);
+ Tcl_IncrRefCount(nameobj);
+ idxobj = Tcl_NewStringObj(RSTRING(index)->ptr, RSTRING(index)->len);
+ Tcl_IncrRefCount(idxobj);
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ Tcl_DecrRefCount(nameobj);
+ Tcl_DecrRefCount(idxobj);
+ rb_thread_critical = thr_crit_bup;
+ return rb_tainted_str_new2("");
+ } else {
+ /* Tcl_Preserve(ptr->ip); */
+ rbtk_preserve_ip(ptr);
+ ret = Tcl_ObjGetVar2(ptr->ip, nameobj, idxobj, FIX2INT(flag));
+ }
+
+ Tcl_DecrRefCount(nameobj);
+ Tcl_DecrRefCount(idxobj);
+
+ if (ret == (Tcl_Obj*)NULL) {
+ volatile VALUE exc;
+#if TCL_MAJOR_VERSION >= 8
+ exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
+#endif
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+ rb_exc_raise(exc);
+ }
+
+ Tcl_IncrRefCount(ret);
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ Tcl_DecrRefCount(ret);
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+ return(strval);
+
+# else /* TCL_VERSION >= 8.1 */
+ if (Tcl_GetCharLength(ret)
+ != Tcl_UniCharLen(Tcl_GetUnicode(ret))) {
+ /* possibly binary string */
+ s = Tcl_GetByteArrayFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ rb_ivar_set(strval, ID_at_enc, rb_tainted_str_new2("binary"));
+ } else {
+ /* possibly text string */
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ }
+
+ Tcl_DecrRefCount(ret);
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+
+ return(strval);
+# endif
+ }
+#else /* TCL_MAJOR_VERSION < 8 */
+ {
+ char *ret;
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ return rb_tainted_str_new2("");
+ } else {
+ /* Tcl_Preserve(ptr->ip); */
+ rbtk_preserve_ip(ptr);
+ ret = Tcl_GetVar2(ptr->ip, RSTRING(varname)->ptr,
+ RSTRING(index)->ptr, FIX2INT(flag));
+ }
+
+ if (ret == (char*)NULL) {
+ volatile VALUE exc;
+#if TCL_MAJOR_VERSION >= 8
+ exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
+#endif
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+ rb_exc_raise(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_set_variable(self, varname_arg, value_arg, flag_arg)
+ VALUE self;
+ VALUE varname_arg;
+ VALUE value_arg;
+ VALUE flag_arg;
+{
+ struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
+ volatile VALUE varname, value, flag;
+
+ varname = varname_arg;
+ value = value_arg;
+ flag = flag_arg;
+
+ StringValue(varname);
+ StringValue(value);
+
+#if TCL_MAJOR_VERSION >= 8
+ {
+ Tcl_Obj *nameobj, *valobj, *ret;
+ char *s;
+ int len;
+ volatile VALUE strval;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr,
+ RSTRING(varname)->len);
+
+ Tcl_IncrRefCount(nameobj);
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ valobj = Tcl_NewStringObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ Tcl_IncrRefCount(valobj);
+# else /* TCL_VERSION >= 8.1 */
+ {
+ volatile VALUE enc = Qnil;
+
+ if (RTEST(rb_ivar_defined(value, ID_at_enc))) {
+ enc = rb_ivar_get(value, ID_at_enc);
+ }
+
+ if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) {
+ /* binary string */
+ valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ } else if (strlen(RSTRING(value)->ptr) != RSTRING(value)->len) {
+ /* probably binary string */
+ valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ } else {
+ /* probably text string */
+ valobj = Tcl_NewStringObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ }
+
+ Tcl_IncrRefCount(valobj);
+ }
+# endif
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ Tcl_DecrRefCount(nameobj);
+ 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_ObjSetVar2(ptr->ip, nameobj, (Tcl_Obj*)NULL, valobj,
+ FIX2INT(flag));
+ }
+
+ Tcl_DecrRefCount(nameobj);
+ Tcl_DecrRefCount(valobj);
+
+ if (ret == (Tcl_Obj*)NULL) {
+ volatile VALUE exc;
+#if TCL_MAJOR_VERSION >= 8
+ exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
+#endif
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+ rb_exc_raise(exc);
+ }
+
+ Tcl_IncrRefCount(ret);
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+# else /* TCL_VERSION >= 8.1 */
+ {
+ VALUE old_gc;
+
+ old_gc = rb_gc_disable();
+
+ if (Tcl_GetCharLength(ret) != Tcl_UniCharLen(Tcl_GetUnicode(ret))) {
+ /* possibly binary string */
+ s = Tcl_GetByteArrayFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ rb_ivar_set(strval, ID_at_enc, rb_str_new2("binary"));
+ } else {
+ /* possibly text string */
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ }
+ if (old_gc == Qfalse) rb_gc_enable();
+ }
+# endif
+
+ 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;
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ return rb_tainted_str_new2("");
+ } else {
+ /* Tcl_Preserve(ptr->ip); */
+ rbtk_preserve_ip(ptr);
+ ret = Tcl_SetVar2(ptr->ip, RSTRING(varname)->ptr, (char*)NULL,
+ RSTRING(value)->ptr, (int)FIX2INT(flag));
+ }
+
+ if (ret == NULL) {
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ }
+
+ 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_arg, index_arg, value_arg, flag_arg)
+ VALUE self;
+ VALUE varname_arg;
+ VALUE index_arg;
+ VALUE value_arg;
+ VALUE flag_arg;
+{
+ struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
+ volatile VALUE varname, index, value, flag;
+
+ if (NIL_P(index_arg)) {
+ return ip_set_variable(self, varname_arg, value_arg, flag_arg);
+ }
+
+ varname = varname_arg;
+ index = index_arg;
+ value = value_arg;
+ flag = flag_arg;
+
+ StringValue(varname);
+ StringValue(index);
+ StringValue(value);
+
+#if TCL_MAJOR_VERSION >= 8
+ {
+ Tcl_Obj *nameobj, *idxobj, *valobj, *ret;
+ char *s;
+ int len;
+ volatile VALUE strval;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr,
+ RSTRING(varname)->len);
+ Tcl_IncrRefCount(nameobj);
+
+ idxobj = Tcl_NewStringObj(RSTRING(index)->ptr,
+ RSTRING(index)->len);
+ Tcl_IncrRefCount(idxobj);
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ valobj = Tcl_NewStringObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+# else /* TCL_VERSION >= 8.1 */
+ {
+ VALUE enc = Qnil;
+
+ if (RTEST(rb_ivar_defined(value, ID_at_enc))) {
+ enc = rb_ivar_get(value, ID_at_enc);
+ }
+
+ if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) {
+ /* binary string */
+ valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ } else if (strlen(RSTRING(value)->ptr) != RSTRING(value)->len) {
+ /* probably binary string */
+ valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ } else {
+ /* probably text string */
+ valobj = Tcl_NewStringObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ }
+ }
+
+# endif
+ Tcl_IncrRefCount(valobj);
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ Tcl_DecrRefCount(nameobj);
+ Tcl_DecrRefCount(idxobj);
+ 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_ObjSetVar2(ptr->ip, nameobj, idxobj, valobj,
+ FIX2INT(flag));
+ }
+
+ Tcl_DecrRefCount(nameobj);
+ Tcl_DecrRefCount(idxobj);
+ Tcl_DecrRefCount(valobj);
+
+ if (ret == (Tcl_Obj*)NULL) {
+ volatile VALUE exc;
+#if TCL_MAJOR_VERSION >= 8
+ exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
+#endif
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+ rb_exc_raise(exc);
+ }
+
+ Tcl_IncrRefCount(ret);
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+# else /* TCL_VERSION >= 8.1 */
+ if (Tcl_GetCharLength(ret) != Tcl_UniCharLen(Tcl_GetUnicode(ret))) {
+ /* possibly binary string */
+ s = Tcl_GetByteArrayFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ rb_ivar_set(strval, ID_at_enc, rb_str_new2("binary"));
+ } else {
+ /* possibly text string */
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ }
+# endif
+
+ 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;
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ return rb_tainted_str_new2("");
+ } else {
+ /* Tcl_Preserve(ptr->ip); */
+ rbtk_preserve_ip(ptr);
+ ret = Tcl_SetVar2(ptr->ip, RSTRING(varname)->ptr,
+ RSTRING(index)->ptr,
+ RSTRING(value)->ptr, FIX2INT(flag));
+ }
+
+ if (ret == (char*)NULL) {
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ }
+
+ Tcl_IncrRefCount(ret);
+
+ strval = rb_tainted_str_new2(ret);
+
+ Tcl_DecrRefCount(ret);
+ /* Tcl_Release(ptr->ip); */
+ rbtk_release_ip(ptr);
+ rb_thread_critical = thr_crit_bup;
+
+ return(strval);
+ }
+#endif
+}
+
+static VALUE
+ip_unset_variable(self, varname_arg, flag_arg)
+ VALUE self;
+ VALUE varname_arg;
+ VALUE flag_arg;
+{
+ struct tcltkip *ptr = get_ip(self);
+ volatile VALUE varname, value, flag;
+
+ varname = varname_arg;
+ flag = flag_arg;
+
+ StringValue(varname);
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ return Qtrue;
+ }
+
+ ptr->return_value = Tcl_UnsetVar(ptr->ip, RSTRING(varname)->ptr,
+ FIX2INT(flag));
+ if (ptr->return_value == TCL_ERROR) {
+ if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
+ }
+ return Qfalse;
+ }
+ return Qtrue;
+}
+
+static VALUE
+ip_unset_variable2(self, varname_arg, index_arg, flag_arg)
+ VALUE self;
+ VALUE varname_arg;
+ VALUE index_arg;
+ VALUE flag_arg;
+{
+ struct tcltkip *ptr = get_ip(self);
+ volatile VALUE varname, index, value, flag;
+
+ if (NIL_P(index_arg)) {
+ return ip_unset_variable(self, varname_arg, flag_arg);
+ }
+
+ varname = varname_arg;
+ index = index_arg;
+ flag = flag_arg;
+
+ StringValue(varname);
+ StringValue(index);
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip) || ip_null_namespace(ptr->ip)) {
+ DUMP1("ip is deleted");
+ return Qtrue;
+ }
+
+ ptr->return_value = Tcl_UnsetVar2(ptr->ip, RSTRING(varname)->ptr,
+ RSTRING(index)->ptr, FIX2INT(flag));
+ if (ptr->return_value == TCL_ERROR) {
+ if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
+ }
+ return Qfalse;
+ }
+ return Qtrue;
+}
+
+static VALUE
+ip_get_global_var(self, varname)
+ VALUE self;
+ VALUE varname;
+{
+ return ip_get_variable(self, varname,
+ INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+}
+
+static VALUE
+ip_get_global_var2(self, varname, index)
+ VALUE self;
+ VALUE varname;
+ VALUE index;
+{
+ return ip_get_variable2(self, varname, index,
+ INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+}
+
+static VALUE
+ip_set_global_var(self, varname, value)
+ VALUE self;
+ VALUE varname;
+ VALUE value;
+{
+ return ip_set_variable(self, varname, value,
+ INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+}
+
+static VALUE
+ip_set_global_var2(self, varname, index, value)
+ VALUE self;
+ VALUE varname;
+ VALUE index;
+ VALUE value;
+{
+ return ip_set_variable2(self, varname, index, value,
+ INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+}
+
+static VALUE
+ip_unset_global_var(self, varname)
+ VALUE self;
+ VALUE varname;
+{
+ return ip_unset_variable(self, varname,
+ INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+}
+
+static VALUE
+ip_unset_global_var2(self, varname, index)
+ VALUE self;
+ VALUE varname;
+ VALUE index;
+{
+ return ip_unset_variable2(self, varname, index,
+ INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+}
+
+
+/* treat Tcl_List */
+static VALUE
+lib_split_tklist_core(ip_obj, list_str)
+ VALUE ip_obj;
+ VALUE list_str;
+{
+ Tcl_Interp *interp;
+ volatile VALUE ary, elem;
+ int idx;
+ int taint_flag = OBJ_TAINTED(list_str);
+ int result;
+ VALUE old_gc;
+
+ if (NIL_P(ip_obj)) {
+ interp = (Tcl_Interp *)NULL;
+ } else {
+ interp = get_ip(ip_obj)->ip;
+ }
+
+ StringValue(list_str);
+
+ {
+#if TCL_MAJOR_VERSION >= 8
+ /* object style interface */
+ Tcl_Obj *listobj;
+ int objc;
+ Tcl_Obj **objv;
+ int thr_crit_bup;
+
+# if 1
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ listobj = Tcl_NewStringObj(RSTRING(list_str)->ptr,
+ RSTRING(list_str)->len);
+# else /* TCL_VERSION >= 8.1 */
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ {
+ VALUE enc = Qnil;
+
+ if (RTEST(rb_ivar_defined(list_str, ID_at_enc))) {
+ enc = rb_ivar_get(list_str, ID_at_enc);
+ }
+
+ if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) {
+ /* binary string */
+ listobj = Tcl_NewByteArrayObj(RSTRING(list_str)->ptr,
+ RSTRING(list_str)->len);
+ } else if (strlen(RSTRING(list_str)->ptr)
+ != RSTRING(list_str)->len) {
+ /* probably binary string */
+ listobj = Tcl_NewByteArrayObj(RSTRING(list_str)->ptr,
+ RSTRING(list_str)->len);
+ } else {
+ /* probably text string */
+ listobj = Tcl_NewStringObj(RSTRING(list_str)->ptr,
+ RSTRING(list_str)->len);
+ }
+ }
+
+ rb_thread_critical = thr_crit_bup;
+# endif
+# else
+ listobj = Tcl_NewStringObj(RSTRING(list_str)->ptr,
+ RSTRING(list_str)->len);
+# endif
+
+ Tcl_IncrRefCount(listobj);
+
+ result = Tcl_ListObjGetElements(interp, listobj, &objc, &objv);
+
+ if (result == TCL_ERROR) {
+ Tcl_DecrRefCount(listobj);
+ if (interp == (Tcl_Interp*)NULL) {
+ rb_raise(rb_eRuntimeError, "cannot get elements from list");
+ } else {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(interp));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", interp->result);
+#endif
+ }
+ }
+
+ for(idx = 0; idx < objc; idx++) {
+ Tcl_IncrRefCount(objv[idx]);
+ }
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ ary = rb_ary_new2(objc);
+ if (taint_flag) OBJ_TAINT(ary);
+
+ old_gc = rb_gc_disable();
+
+ for(idx = 0; idx < objc; idx++) {
+ char *str;
+ int len;
+
+# if 1
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ str = Tcl_GetStringFromObj(objv[idx], &len);
+ elem = rb_str_new(str, len);
+# else /* TCL_VERSION >= 8.1 */
+ if (Tcl_GetCharLength(objv[idx])
+ != Tcl_UniCharLen(Tcl_GetUnicode(objv[idx]))) {
+ /* possibly binary string */
+ str = Tcl_GetByteArrayFromObj(objv[idx], &len);
+ elem = rb_str_new(str, len);
+ rb_ivar_set(elem, ID_at_enc, rb_tainted_str_new2("binary"));
+ } else {
+ /* possibly text string */
+ str = Tcl_GetStringFromObj(objv[idx], &len);
+ elem = rb_str_new(str, len);
+ }
+# endif
+# else
+ str = Tcl_GetStringFromObj(objv[idx], &len);
+ elem = rb_str_new(str, len);
+# endif
+
+ if (taint_flag) OBJ_TAINT(elem);
+ RARRAY(ary)->ptr[idx] = elem;
+ }
+
+ RARRAY(ary)->len = objc;
+
+ if (old_gc == Qfalse) rb_gc_enable();
+
+ rb_thread_critical = thr_crit_bup;
+
+ for(idx = 0; idx < objc; idx++) {
+ Tcl_DecrRefCount(objv[idx]);
+ }
+
+ Tcl_DecrRefCount(listobj);
+
+#else /* TCL_MAJOR_VERSION < 8 */
+ /* string style interface */
+ int argc;
+ char **argv;
+
+ if (Tcl_SplitList(interp, RSTRING(list_str)->ptr,
+ &argc, &argv) == TCL_ERROR) {
+ if (interp == (Tcl_Interp*)NULL) {
+ rb_raise(rb_eRuntimeError, "cannot get elements from list");
+ } else {
+ rb_raise(rb_eRuntimeError, "%s", interp->result);
+ }
+ }
+
+ ary = rb_ary_new2(argc);
+ if (taint_flag) OBJ_TAINT(ary);
+
+ old_gc = rb_gc_disable();
+
+ for(idx = 0; idx < argc; idx++) {
+ if (taint_flag) {
+ elem = rb_tainted_str_new2(argv[idx]);
+ } else {
+ elem = rb_str_new2(argv[idx]);
+ }
+ /* rb_ivar_set(elem, ID_at_enc, rb_str_new2("binary")); */
+ RARRAY(ary)->ptr[idx] = elem;
+ }
+ RARRAY(ary)->len = argc;
+
+ if (old_gc == Qfalse) rb_gc_enable();
+#endif
+ }
+
+ return ary;
+}
+
+static VALUE
+lib_split_tklist(self, list_str)
+ VALUE self;
+ VALUE list_str;
+{
+ return lib_split_tklist_core(Qnil, list_str);
+}
+
+
+static VALUE
+ip_split_tklist(self, list_str)
+ VALUE self;
+ VALUE list_str;
+{
+ return lib_split_tklist_core(self, list_str);
+}
+
+static VALUE
+lib_merge_tklist(argc, argv, obj)
+ int argc;
+ VALUE *argv;
+ VALUE obj;
+{
+ int num, len;
+ int *flagPtr;
+ char *dst, *result;
+ volatile VALUE str;
+ int taint_flag = 0;
+ int thr_crit_bup;
+ VALUE old_gc;
+
+ if (argc == 0) return rb_str_new2("");
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+ old_gc = rb_gc_disable();
+
+ /* based on Tcl/Tk's Tcl_Merge() */
+ flagPtr = ALLOC_N(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;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ StringValue(src);
+
+#if TCL_MAJOR_VERSION >= 8
+ len = Tcl_ScanCountedElement(RSTRING(src)->ptr, RSTRING(src)->len,
+ &scan_flag);
+ dst = rb_str_new(0, len + 1);
+ len = Tcl_ConvertCountedElement(RSTRING(src)->ptr, RSTRING(src)->len,
+ RSTRING(dst)->ptr, scan_flag);
+#else /* TCL_MAJOR_VERSION < 8 */
+ len = Tcl_ScanElement(RSTRING(src)->ptr, &scan_flag);
+ dst = rb_str_new(0, len + 1);
+ len = Tcl_ConvertElement(RSTRING(src)->ptr, RSTRING(dst)->ptr, scan_flag);
+#endif
+
+ RSTRING(dst)->len = len;
+ RSTRING(dst)->ptr[len] = '\0';
+ if (taint_flag) OBJ_TAINT(dst);
+
+ rb_thread_critical = thr_crit_bup;
+
+ return dst;
+}
+
+
+#ifdef __MACOS__
+static void
+_macinit()
+{
+ tcl_macQdPtr = &qd; /* setup QuickDraw globals */
+ Tcl_MacSetEventProc(TkMacConvertEvent); /* setup event handler */
+}
+#endif
+
+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;
+
+ VALUE lib = rb_define_module("TclTkLib");
+ VALUE ip = rb_define_class("TclTkIp", rb_cObject);
+
+ VALUE ev_flag = rb_define_module_under(lib, "EventFlag");
+ VALUE var_flag = rb_define_module_under(lib, "VarAccessFlag");
+
+ /* --------------------------------------------------------------- */
+
+#if defined USE_TCL_STUBS && defined USE_TK_STUBS
+ extern int ruby_tcltk_stubs();
+ int ret = ruby_tcltk_stubs();
+
+ if (ret)
+ rb_raise(rb_eLoadError, "tcltklib: tcltk_stubs init error(%d)", ret);
+#endif
+
+ /* --------------------------------------------------------------- */
+
+ rb_global_variable(&eTkCallbackReturn);
+ rb_global_variable(&eTkCallbackBreak);
+ rb_global_variable(&eTkCallbackContinue);
+
+ rb_global_variable(&eventloop_thread);
+ rb_global_variable(&watchdog_thread);
+
+ /* --------------------------------------------------------------- */
+
+ rb_define_const(lib, "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
+
+ /* --------------------------------------------------------------- */
+
+ eTkCallbackBreak = rb_define_class("TkCallbackReturn", rb_eStandardError);
+ eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError);
+ eTkCallbackContinue = rb_define_class("TkCallbackContinue",
+ rb_eStandardError);
+
+ /* --------------------------------------------------------------- */
+
+ eLocalJumpError = rb_const_get(rb_cObject, rb_intern("LocalJumpError"));
+
+ ID_at_enc = rb_intern("@encoding");
+ ID_at_interp = rb_intern("@interp");
+
+ ID_stop_p = rb_intern("stop?");
+ ID_kill = rb_intern("kill");
+ ID_join = rb_intern("join");
+
+ ID_call = rb_intern("call");
+ ID_backtrace = rb_intern("backtrace");
+ ID_message = rb_intern("message");
+
+ ID_at_reason = rb_intern("@reason");
+ ID_return = rb_intern("return");
+ ID_break = rb_intern("break");
+ ID_next = rb_intern("next");
+
+ ID_to_s = rb_intern("to_s");
+ ID_inspect = rb_intern("inspect");
+
+ /* --------------------------------------------------------------- */
+
+ rb_define_module_function(lib, "mainloop", lib_mainloop, -1);
+ rb_define_module_function(lib, "mainloop_watchdog",
+ lib_mainloop_watchdog, -1);
+ 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_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, "null_namespace?", ip_has_null_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, "_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 = 0;
+ watchdog_thread = 0;
+
+ /* --------------------------------------------------------------- */
+
+#ifdef __MACOS__
+ _macinit();
+#endif
+
+ /* from Tk_Main() */
+ DUMP1("Tcl_FindExecutable");
+ Tcl_FindExecutable(RSTRING(rb_argv0)->ptr);
+
+ /* --------------------------------------------------------------- */
+}
+
+/* eof */