summaryrefslogtreecommitdiff
path: root/ext/tcltklib
diff options
context:
space:
mode:
Diffstat (limited to 'ext/tcltklib')
-rw-r--r--ext/tcltklib/.cvsignore3
-rw-r--r--ext/tcltklib/MANIFEST19
-rw-r--r--ext/tcltklib/MANUAL.eng264
-rw-r--r--ext/tcltklib/MANUAL.euc408
-rw-r--r--ext/tcltklib/README.1st41
-rw-r--r--ext/tcltklib/README.euc159
-rw-r--r--ext/tcltklib/demo/lines0.tcl42
-rw-r--r--ext/tcltklib/demo/lines1.rb54
-rw-r--r--ext/tcltklib/demo/lines2.rb50
-rw-r--r--ext/tcltklib/demo/safeTk.rb22
-rw-r--r--ext/tcltklib/depend2
-rw-r--r--ext/tcltklib/extconf.rb58
-rw-r--r--ext/tcltklib/lib/tcltk.rb367
-rw-r--r--ext/tcltklib/sample/batsu.gifbin538 -> 0 bytes
-rw-r--r--ext/tcltklib/sample/maru.gifbin481 -> 0 bytes
-rw-r--r--ext/tcltklib/sample/sample0.rb39
-rw-r--r--ext/tcltklib/sample/sample1.rb634
-rw-r--r--ext/tcltklib/sample/sample2.rb449
-rw-r--r--ext/tcltklib/stubs.c97
-rw-r--r--ext/tcltklib/tcltklib.c2396
20 files changed, 0 insertions, 5104 deletions
diff --git a/ext/tcltklib/.cvsignore b/ext/tcltklib/.cvsignore
deleted file mode 100644
index 90c83ed9b1..0000000000
--- a/ext/tcltklib/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-Makefile
-*.log
-*.def
diff --git a/ext/tcltklib/MANIFEST b/ext/tcltklib/MANIFEST
deleted file mode 100644
index e06547a6aa..0000000000
--- a/ext/tcltklib/MANIFEST
+++ /dev/null
@@ -1,19 +0,0 @@
-MANIFEST
-README.1st
-README.euc
-MANUAL.euc
-MANUAL.eng
-tcltklib.c
-stubs.c
-depend
-extconf.rb
-lib/tcltk.rb
-demo/lines0.tcl
-demo/lines1.rb
-demo/lines2.rb
-demo/safeTk.rb
-sample/sample0.rb
-sample/sample1.rb
-sample/sample2.rb
-sample/maru.gif
-sample/batsu.gif
diff --git a/ext/tcltklib/MANUAL.eng b/ext/tcltklib/MANUAL.eng
deleted file mode 100644
index a037d18d41..0000000000
--- a/ext/tcltklib/MANUAL.eng
+++ /dev/null
@@ -1,264 +0,0 @@
-(tof)
- 2003/10/17 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 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.
-
-
-class TclTkIp
- [class methods]
- new(ip_name=nil, options='')
- : Generate an instance of TclTkIp class.
- : If 'ip_name' argument is given as a string, it is the name
- : of the Tk interpreter which is shown by 'winfo interps'
- : command.
- : 'options' argument accepts a string which is the command
- : line options of wish; such as '-geometry' or '-use'.
- : The information is used to generate the root widget of the
- : interpreter.
- : ( e.g. TclTkIp.new('FOO', '-geometry 500x200 -use 0x2200009') )
- : If is given nil or falsr for the 'option' argument, generates
- : the Tcl interpreter without Tk library. Then the interpreter
- : doesn't need GUI environment. Therefore, even if a window
- : system doesn't exist or cannot be used, Ruby can control the
- : Tcl interpreter and the extention libraries loaded on the
- : interpreter.
-
- [instance methods]
- create_slave(name, safe=false)
- : Create a slave interpreter.
- : The parent of the interpreter is the receiver of this method.
- : The name of the slave interpreter is given by 'name' argument.
- : The 'safe' argument decides whether the slave interpreter is
- : created as a safe interpreter or not. If true, create a safe
- : interpreter. Default is false. However, if the parent
- : interpreter is a safe interpreter, the created interpreter is
- : a safe interpreter (ignore 'safe' argument value).
- : If $SAFE >= 4, can create a safe interpreter only.
-
- make_safe
- : Make the interpreter to the safe interpreter, and returns
- : self. If fail, raise RuntimeError.
-
- safe?
- : Check whether the interpreter is the safe interpreter.
- : If is the safe interpreter, returns true.
-
- delete
- : Delete the interpreter.
- : The deleted interpreter doesn't accept command and then
- : raise an exception.
-
- deleted?
- : Check whether the interpreter is already deleted.
- : If deleted, returns true.
-
- restart
- : Restart Tk part of the interpreter.
- : Use this when you need Tk functions after destroying the
- : root widget.
- : On $SAFE >= 4, cannot call this method.
-
- _eval(str)
- _invoke(*args)
- : Estimates the arguments as a command on the Tk interpreter.
- : The argument of _eval is a script of Tcl/Tk.
- : Each argument of _invoke is a token of one command line of
- : Tcl/Tk.
- : Because the operation of _invoke doesn't through the
- : command line parser of Tk interpreter, the cost of
- : estimation is smaller than _eval. However, auto_load
- : mechanism of the Tk interpreter doesn't work on _invoke.
- : So _invoke can call only the command which already
- : registered on the interpreter by 'load' command and so on.
- : On _eval command, auto_load mechanism words. So if succeed
- : to _eval and regist the command once, after that, the
- : command can be called by _invoke.
-
- _toUTF8(str, encoding)
- _fromUTF8(str, encoding)
- : Call the function (which is internal function of Tcl/Tk) to
- : convert to/from a UTF8 string.
-
- _thread_vwait(var_name)
- _thread_tkwait(mode, target)
- : 'vwait' or 'tkwait' with thread support.
- : The difference from normal 'vwait' or 'tkwait' command is
- : doing independent wait from the vwait stack when they are
- : called on the other thread than the eventloop thread.
- : In the case of Tcl/Tk's vwait / tkwait, if 2nd vwait /
- : tkwait is called on waiting for 1st vwait / tkwait,
- : returns the order of [2nd]->[1st] regardless of the order
- : of when the wait condition was fulfilled.
- : If _thread_vwait / _thread_tkwait is called on the
- : eventloop thread, there is no difference from vwait /
- : tkwait. But if called on the other thread than the
- : eventloop, stops the thread. And when the wait condition
- : is fulfilled, the thread restarts. The meaning of
- : "independent from the vwait stack" is that the timing of
- : restarting is independent from the waiting status of the
- : other threads. That is, even if the eventloop thread is
- : waiting by vwait and is not fulfilled the condition,
- : _thread_vwait completes the waiting when its waiting
- : condition is fulfilled and the thread which stopped by
- : _thread_vwait can continue the operation.
-
- _return_value
- : Get the last result value on the interpreter.
-
- mainloop
- mainloop_watchdog
- : If on the slave interpreter, never start an eventloop and
- : returns nil.
- : With the exception that, same to the TclTkLib module method
- : with the same name.
-
- do_one_event
- : With the exception that the argument is forced to set
- : DONT_WAIT flag on the slave interpreter, same to
- : TclTkLib#do_one_event.
-
- set_eventloop_tick
- get_eventloop_tick
- set_no_event_wait
- get_no_event_wait
- set_eventloop_weight
- get_eventloop_weight
- mainloop_abort_on_exception
- mainloop_abort_on_exception=
- : With the exception that it is ignored to set value on the
- : slave interpreter, same to the TclTkLib module method with
- : the same name.
-
-class TkCallbackBreak < StandardError
-class TkCallbackContinue < StandardError
- : They are exception classes to break or continue the Tk callback
- : operation.
- : If raise TkCallbackBreak on the callback procedure, Ruby returns
- : 'break' code to Tk interpreter (Then the Tk interpreter will
- : break the operation for the current event).
- : If raise TkCallbackContinue, returns 'continue' code (Then the Tk
- : interpreter will break the operateion for the current bindtag and
- : starts the operation for the next buindtag for the current event).
-
-(eof)
diff --git a/ext/tcltklib/MANUAL.euc b/ext/tcltklib/MANUAL.euc
deleted file mode 100644
index 9f9c77da02..0000000000
--- a/ext/tcltklib/MANUAL.euc
+++ /dev/null
@@ -1,408 +0,0 @@
-(tof)
- 2003/10/17 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 を返す ) する
-
- モジュールメソッド
- 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 に設定されている．
- : １個のインタープリタだけを使っている場合にはエラー時にその
- : まま停止しても通常は問題ないが，複数のインタープリタが同時
- : に動作している場合には，それらを管理するイベントループは１
- : 個だけであるため，いずれかのインタープリタのエラーが原因で，
- : 他のインタープリタの処理継続が不可能になることがある．その
- : ような場合でもエラーを無視してイベントループが稼働を続ける
- : ことで，他のインタープリタが正常に動作し続けることができる．
- : $SAFE >= 4 では実行が禁止される．
-
- mainloop_abort_on_exception
- : Tk インタープリタ上で例外を発生した際に，イベントループをエ
- : ラー停止させるかどうかの設定状態を true/false で得る．
-
- num_of_mainwindows
- : 現在のメインウィンドウ (ルートウィジェット) の数を返す．
- : メインウィンドウは一つのインタープリタに付き最大一つである
- : ので，この値は現在 Tk の機能が有効であるインタープリタの総
- : 数に等しい．
-
-
-クラス 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 を返す．
-
- 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 上での評価の実行結果としての戻り値を返す．
-
- mainloop
- mainloop_watchdog
- : スレーブ IP の場合にはイベントループを起動せずに nil を返す．
- : それ以外の点では引数を含めて TclTkLib の同名メソッドに同じ．
-
- do_one_event
- : スレーブ IP の場合には引数のイベントフラグに DONT_WAIT が
- : 強制的に追加される (イベント待ちでスリープすることは禁止)．
- : それ以外の点では引数を含めて TclTkLib の同名メソッドに同じ．
-
- set_eventloop_tick
- get_eventloop_tick
- set_no_event_wait
- get_no_event_wait
- set_eventloop_weight
- get_eventloop_weight
- mainloop_abort_on_exception
- mainloop_abort_on_exception=
- : スレーブ IP の場合には値の設定が許されない (無視される)．
- : それ以外の点では引数を含めて TclTkLib の同名メソッドに同じ．
-
-クラス TkCallbackBreak < StandardError
-クラス TkCallbackContinue < StandardError
- : これらはイベントコールバックにおいて，コールバック処理を適切に中
- : 断したり，次のバインドタグのバインディング処理に進めたりすること
- : を可能にするための例外クラスである．
- : コールバックで break や continue を実現するためには，コールバック
- : である Ruby 手続きが Tcl/Tk インタープリタ側に適切なリターンコー
- : ドを返す必要がある．Ruby の手続きが普通に値を返すのでは，それが普
- : 通の戻り値であるのか否かを区別ができないため，例外発生を利用した
- : 実装を行っている．
-
-(eof)
diff --git a/ext/tcltklib/README.1st b/ext/tcltklib/README.1st
deleted file mode 100644
index 510dd1c2cd..0000000000
--- a/ext/tcltklib/README.1st
+++ /dev/null
@@ -1,41 +0,0 @@
-To compile 'tcltklib', you must have Tcl/Tk libraries on your environment.
-Although 'extconf.rb' script searches Tcl/Tk libraries and header files,
-sometimes fails to find them. And then, 'tcltklib' cannot be compiled. If
-Tcl/Tk libraries or header files are installed but are not found, you can
-give the information by arguments of the 'configure' script. Please give
-some or all of the following options.
-
- --with-tcllib=<libname> (e.g. libtcl8.3.so ==> --with-tcllib=tcl8.3)
- --with-tklib=<libname> (e.g. libtk8.3.so ==> --with-tklib=tk8.3)
-
- --enable_tcltk_stubs (if you force to enable stubs)
-
- --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'
-
-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.3/ --with-tcllib=tcl8.3 --with-tklib=tk8.3 --enable-tcltk_stubs' 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.
-
-==========================================================
- Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp)
diff --git a/ext/tcltklib/README.euc b/ext/tcltklib/README.euc
deleted file mode 100644
index fd75202c18..0000000000
--- a/ext/tcltklib/README.euc
+++ /dev/null
@@ -1,159 +0,0 @@
-(tof)
- 2003/06/19 Hidetoshi NAGAI
-
-本ドキュメントには古い tcltk ライブラリ，tcltklib ライブラリの説明
-が含まれていますが，その記述内容は古いものとなっています．
-
-まず，現在の Ruby/Tk の中心である tk.rb は wish を呼び出したりはせ
-ず，tcltklib ライブラリを wrap して動作するものとなっています．その
-ため，古い説明記述で述べられているようなプロセス間通信によるオーバ
-ヘッドは存在しません．
-
-現在の tcltklib ライブラリでも，Tcl/Tk の C ライブラリをリンクして
-直接に動かすことで，オーバヘッドを押さえつつ Tcl/Tk インタープリタ
-のほぼ全機能（拡張ライブラリを含む）を使える点は同じです．しかし，
-その役割はほぼ「tk.rb 以下のライブラリを効果的に働かせるためのもの」
-と見なされており，その目的でメンテナンスされています．
-
-tk.rb の高機能化に伴って，中水準のライブラリである tcltk ライブラリ
-（tcltk.rb）はその存在意義を減じており，現在ではメンテナンスは行わ
-れていません．
-
-なお，古い説明ではバインディングにおけるスクリプトの追加はできないこ
-ととなっていますが，現在の tk.rb ではこれも可能であることを補足して
-おきます．
-
-以下がライブラリの古い説明文書です．
-==============================================================
- tcltk ライブラリ
- tcltklib ライブラリ
- Sep. 19, 1997 Y. Shigehiro
-
-以下, 「tcl/tk」という表記は, tclsh や wish を実現している, 一般でいう
-ところの tcl/tk を指します. 「tcltk ライブラリ」, 「tcltklib ライブラ
-リ」という表記は, 本パッケージに含まれる ruby 用のライブラリを指します.
-
-[ファイルについて]
-
-README.euc : このファイル(注意, 特徴, インストールの方法).
-MANUAL.euc : マニュアル.
-
-lib/, ext/ : ライブラリの実体.
-
-sample/ : マニュアル代わりのサンプルプログラム.
-sample/sample0.rb : tcltklib ライブラリのテスト.
-sample/sample1.rb : tcltk ライブラリのテスト.
- tcl/tk (wish) でできそうなことを一通り書いてみました.
-sample/sample2.rb : tcltk ライブラリのサンプル.
- maeda shugo (shugo@po.aianet.ne.jp) 氏による
- (`rb.tk' で書かれていた) ruby のサンプルプログラム
- http://www.aianet.or.jp/~shugo/ruby/othello.rb.gz
- を tcltk ライブラリを使うように, 機械的に変更してみました.
-
-demo/ : 100 本の線を 100 回描くデモプログラム.
- 最初に空ループの時間を測定し, 続いて実際に線を引く時間を測定します.
- tcl/tk は(再)描画のときに backing store を使わずに律義に 10000 本(?)
- 線を引くので, (再)描画を始めると, マシンがかなり重くなります.
-demo/lines0.tcl : wish 用のスクリプト.
-demo/lines1.rb : `tk.rb' 用のスクリプト.
-demo/lines2.rb : tcltk ライブラリ用のスクリプト.
-
-[注意]
-
-コンパイル/実行には, tcl/tk の C ライブラリが必要です.
-
-このライブラリは,
-
- ruby-1.0-970701, ruby-1.0-970911, ruby-1.0-970919
- FreeBSD 2.2.2-RELEASE
- およびそのパッケージ jp-tcl-7.6.tgz, jp-tk-4.2.tgz
-
-で作成/動作確認しました. 他の環境では動作するかどうかわかりません.
-
-TclTkLib.mainloop を実行中に Control-C が効かないのは不便なので, ruby
-のソースを参考に, #include "sig.h" して trap_immediate を操作していま
-すが, ruby の README.EXT にも書いてないのに, こんなことをして良いのか
-どうかわかりません.
-
--d オプションでデバッグ情報を表示させるために, ruby のソースを参考に,
-debug という大域変数を参照していますが, ruby の README.EXT にも書いて
-ないのに, こんなことをして良いのかどうかわかりません.
-
-extconf.rb は書きましたが, (いろいろな意味で)これで良いのか良く分かり
-ません.
-
-[特徴]
-
-ruby から tcl/tk ライブラリを利用できます.
-
-tcl/tk インタプリタのスクリプトは, 機械的に tcltk ライブラリ用の ruby
-スクリプトに変換できます.
-
-(`tk.rb' との違い)
-
-1. tcl/tk インタプリタのスクリプトが, どのように, tcltk ライブラリ用の
- ruby スクリプトに変換されるかが理解できれば, マニュアル類が無いに等
- しい `tk.rb' とは異なり
-
- tcl/tk のマニュアルやオンラインドキュメントを用いて
-
- 効率良くプログラミングを行うことができます.
- 記述方法がわからない, コマンドに与えるパラメータがわからない...
- - Canvas.new { ... } と, なぜイテレータブロックを書けるの??
- - Canvas の bbox は数値のリストを返すのに, xview は文字列を返すの??
- と, いちいち, ライブラリのソースを追いかける必要はありません.
-
-2. 個々の機能(オプション)を個別処理によりサポートしており, そのためサ
- ポートしていない機能は使うことができない(本当は使えないこともないの
- ですが) `tk.rb' とは異なり, tcl/tk インタプリタで可能なことは
-
- ほとんど
-
- ruby からも実行できます. 現在, ruby から実行できないことが確認され
- ているのは,
-
- bind コマンドでスクリプトを追加する構文
- 「bind tag sequence +script」
- ^
-
- のみです.
- - `. configure -width' をしようとして, `Tk.root.height()' と書い
- たのに, `undefined method `height'' と怒られてしまった. tk.rb を
- 読んでみて, ガーン. できないのか...
- ということはありません.
-
-3. wish プロセスを起動しプロセス間通信で wish を利用する `tk.rb' とは
- 異なり, tcl/tk の C ライブラリをリンクし
-
- より高速に (といっても, 思った程は速くないですが)
-
- 処理を行います.
-
-4. `tk.rb' ほど, 高水準なインターフェースを備えていないため, tcl/tk イ
- ンタプリタの生成等
-
- 何から何まで自分で記述
-
- しなければなりません(その代わり, tcl/tk ライブラリの仕様通り,
- tcl/tk インタプリタを複数生成することもできますが).
- インターフェースは(おそらく) ruby の思想に沿ったものではありません.
- また, スクリプトの記述は
-
- ダサダサ
-
- です. スクリプトは, 一見, 読みづらいものとなります. が, 書く人にとっ
- ては, それほど煩わしいものではないと思います.
-
-[インストールの方法]
-
-0. ruby のソースファイル(ruby-1.0-なんたら.tgz)を展開しておきます.
-
-1. ruby-1.0-なんたら/ext に ext/tcltklib をコピーします.
- cp -r ext/tcltklib ???/ruby-1.0-なんたら/ext/
-
-2. ruby のインストール法に従い make 等をします.
-
-3. ruby のライブラリ置場に lib/* をコピーします.
- cp lib/* /usr/local/lib/ruby/
-
-(eof)
diff --git a/ext/tcltklib/demo/lines0.tcl b/ext/tcltklib/demo/lines0.tcl
deleted file mode 100644
index 8ed3c5e1c1..0000000000
--- a/ext/tcltklib/demo/lines0.tcl
+++ /dev/null
@@ -1,42 +0,0 @@
-#! /usr/local/bin/wish
-
-proc drawlines {} {
- puts [clock format [clock seconds]]
-
- for {set j 0} {$j < 100} {incr j} {
- puts -nonewline "*"
- flush stdout
- if {$j & 1} {
- set c "blue"
- } {
- set c "red"
- }
- for {set i 0} {$i < 100} {incr i} {
-# .a create line $i 0 0 [expr 500 - $i] -fill $c
- }
- }
-
- puts [clock format [clock seconds]]
-
- for {set j 0} {$j < 100} {incr j} {
- puts -nonewline "*"
- flush stdout
- if {$j & 1} {
- set c "blue"
- } {
- set c "red"
- }
- for {set i 0} {$i < 100} {incr i} {
- .a create line $i 0 0 [expr 500 - $i] -fill $c
- }
- }
-
- puts [clock format [clock seconds]]
-# destroy .
-}
-
-canvas .a -height 500 -width 500
-button .b -text draw -command drawlines
-pack .a .b -side left
-
-# eof
diff --git a/ext/tcltklib/demo/lines1.rb b/ext/tcltklib/demo/lines1.rb
deleted file mode 100644
index e459589f50..0000000000
--- a/ext/tcltklib/demo/lines1.rb
+++ /dev/null
@@ -1,54 +0,0 @@
-#! /usr/local/bin/ruby
-
-require "tk"
-
-def drawlines()
- print Time.now, "\n"
-
- for j in 0 .. 99
- print "*"
- $stdout.flush
- if (j & 1) != 0
- col = "blue"
- else
- col = "red"
- end
- for i in 0 .. 99
-# TkcLine.new($a, i, 0, 0, 500 - i, "-fill", col)
- end
- end
-
- print Time.now, "\n"
-
- for j in 0 .. 99
- print "*"
- $stdout.flush
- if (j & 1) != 0
- col = "blue"
- else
- col = "red"
- end
- for i in 0 .. 99
- TkcLine.new($a, i, 0, 0, 500 - i, "-fill", col)
- end
- end
-
- print Time.now, "\n"
-# Tk.root.destroy
-end
-
-$a = TkCanvas.new{
- height(500)
- width(500)
-}
-
-$b = TkButton.new{
- text("draw")
- command(proc{drawlines()})
-}
-
-TkPack.configure($a, $b, {"side"=>"left"})
-
-Tk.mainloop
-
-# eof
diff --git a/ext/tcltklib/demo/lines2.rb b/ext/tcltklib/demo/lines2.rb
deleted file mode 100644
index 9f21ae6377..0000000000
--- a/ext/tcltklib/demo/lines2.rb
+++ /dev/null
@@ -1,50 +0,0 @@
-#! /usr/local/bin/ruby
-
-require "tcltk"
-
-def drawlines()
- print Time.now, "\n"
-
- for j in 0 .. 99
- print "*"
- $stdout.flush
- if (j & 1) != 0
- col = "blue"
- else
- col = "red"
- end
- for i in 0 .. 99
-# $a.e("create line", i, 0, 0, 500 - i, "-fill", col)
- end
- end
-
- print Time.now, "\n"
-
- for j in 0 .. 99
- print "*"
- $stdout.flush
- if (j & 1) != 0
- col = "blue"
- else
- col = "red"
- end
- for i in 0 .. 99
- $a.e("create line", i, 0, 0, 500 - i, "-fill", col)
- end
- end
-
- print Time.now, "\n"
-# $ip.commands()["destroy"].e($root)
-end
-
-$ip = TclTkInterpreter.new()
-$root = $ip.rootwidget()
-$a = TclTkWidget.new($ip, $root, "canvas", "-height 500 -width 500")
-$c = TclTkCallback.new($ip, proc{drawlines()})
-$b = TclTkWidget.new($ip, $root, "button", "-text draw -command", $c)
-
-$ip.commands()["pack"].e($a, $b, "-side left")
-
-TclTk.mainloop
-
-# eof
diff --git a/ext/tcltklib/demo/safeTk.rb b/ext/tcltklib/demo/safeTk.rb
deleted file mode 100644
index 5d2c60e700..0000000000
--- a/ext/tcltklib/demo/safeTk.rb
+++ /dev/null
@@ -1,22 +0,0 @@
-#!/usr/bin/env ruby
-require 'tcltklib'
-
-master = TclTkIp.new
-slave_name = 'slave0'
-slave = master.create_slave(slave_name, true)
-master._eval("::safe::interpInit #{slave_name}")
-master._eval("::safe::loadTk #{slave_name}")
-
-master._invoke('label', '.l1', '-text', 'master')
-master._invoke('pack', '.l1', '-padx', '30', '-pady', '50')
-master._eval('label .l2 -text {root widget of master-ip}')
-master._eval('pack .l2 -padx 30 -pady 50')
-
-slave._invoke('label', '.l1', '-text', 'slave')
-slave._invoke('pack', '.l1', '-padx', '30', '-pady', '50')
-slave._eval('label .l2 -text {root widget of slave-ip}')
-slave._eval('pack .l2 -padx 30 -pady 20')
-slave._eval('label .l3 -text {( container frame widget of master-ip )}')
-slave._eval('pack .l3 -padx 30 -pady 20')
-
-TclTkLib.mainloop
diff --git a/ext/tcltklib/depend b/ext/tcltklib/depend
deleted file mode 100644
index 2cd9c400f7..0000000000
--- a/ext/tcltklib/depend
+++ /dev/null
@@ -1,2 +0,0 @@
-tcltklib.o: tcltklib.c $(hdrdir)/ruby.h $(topdir)/config.h $(hdrdir)/defines.h
-stubs.o: stubs.c $(hdrdir)/ruby.h $(topdir)/config.h $(hdrdir)/defines.h
diff --git a/ext/tcltklib/extconf.rb b/ext/tcltklib/extconf.rb
deleted file mode 100644
index 575bf78034..0000000000
--- a/ext/tcltklib/extconf.rb
+++ /dev/null
@@ -1,58 +0,0 @@
-# extconf.rb for tcltklib
-
-require 'mkmf'
-
-if RUBY_PLATFORM !~ /mswin32|mingw|cygwin|bccwin32/
- 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"]
- func = stubs ? "Tcl_InitStubs" : "Tcl_FindExecutable"
- if tcllib
- find_library(tcllib, func, *paths)
- elsif find_library("tcl", func, *paths)
- true
- else
- %w[8.4 8.3 8.2 8.0 7.6].find { |ver|
- 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"]
- func = stubs ? "Tk_InitStubs" : "Tk_Init"
- if tklib
- find_library(tklib, func, *paths)
- elsif find_library("tk", func, *paths)
- true
- else
- %w[8.4 8.3 8.2 8.0 4.2].find { |ver|
- find_library("tk#{ver}", func, *paths) or
- find_library("tk#{ver.delete('.')}", func, *paths)
- }
- end
-end
-
-if have_header("tcl.h") && have_header("tk.h") &&
- (/mswin32|mingw|cygwin|bccwin32/ =~ RUBY_PLATFORM || find_library("X11", "XOpenDisplay",
- "/usr/X11/lib", "/usr/lib/X11", "/usr/X11R6/lib", "/usr/openwin/lib")) &&
- find_tcl(tcllib, stubs) &&
- find_tk(tklib, stubs)
- $CPPFLAGS += ' -DUSE_TCL_STUBS -DUSE_TK_STUBS' if stubs
- $CPPFLAGS += ' -D_WIN32' if /cygwin/ =~ RUBY_PLATFORM
- create_makefile("tcltklib")
-end
diff --git a/ext/tcltklib/lib/tcltk.rb b/ext/tcltklib/lib/tcltk.rb
deleted file mode 100644
index a6bc773b96..0000000000
--- a/ext/tcltklib/lib/tcltk.rb
+++ /dev/null
@@ -1,367 +0,0 @@
-# tof
-
-#### tcltk library, more direct manipulation of tcl/tk
-#### Sep. 5, 1997 Y. Shigehiro
-
-require "tcltklib"
-
-################
-
-# module TclTk: collection of tcl/tk utilities (supplies namespace.)
-module TclTk
-
- # initialize Hash to hold unique symbols and such
- @namecnt = {}
-
- # initialize Hash to hold callbacks
- @callback = {}
-end
-
-# TclTk.mainloop(): call TclTkLib.mainloop()
-def TclTk.mainloop()
- print("mainloop: start\n") if $DEBUG
- TclTkLib.mainloop()
- print("mainloop: end\n") if $DEBUG
-end
-
-# TclTk.deletecallbackkey(ca): remove callback from TclTk module
-# this does not remove callbacks from tcl/tk interpreter
-# without calling this method, TclTkInterpreter will not be GCed
-# ca: callback(TclTkCallback)
-def TclTk.deletecallbackkey(ca)
- print("deletecallbackkey: ", ca.to_s(), "\n") if $DEBUG
- @callback.delete(ca.to_s)
-end
-
-# TclTk.dcb(ca, wid, W): call TclTk.deletecallbackkey() for each callbacks
-# in an array.
-# this is for callback for top-level <Destroy>
-# ca: array of callbacks(TclTkCallback)
-# wid: top-level widget(TclTkWidget)
-# w: information about window given by %W(String)
-def TclTk.dcb(ca, wid, w)
- if wid.to_s() == w
- ca.each{|i|
- TclTk.deletecallbackkey(i)
- }
- end
-end
-
-# TclTk._addcallback(ca): register callback
-# ca: callback(TclTkCallback)
-def TclTk._addcallback(ca)
- print("_addcallback: ", ca.to_s(), "\n") if $DEBUG
- @callback[ca.to_s()] = ca
-end
-
-# TclTk._callcallback(key, arg): invoke registered callback
-# key: key to select callback (to_s value of the TclTkCallback)
-# arg: parameter from tcl/tk interpreter
-def TclTk._callcallback(key, arg)
- print("_callcallback: ", @callback[key].inspect, "\n") if $DEBUG
- @callback[key]._call(arg)
- # throw out callback value
- # should return String to satisfy rb_eval_string()
- return ""
-end
-
-# TclTk._newname(prefix): generate unique name(String)
-# prefix: prefix of the unique name
-def TclTk._newname(prefix)
- # generated name counter is stored in @namecnt
- if !@namecnt.key?(prefix)
- # first appearing prefix, initialize
- @namecnt[prefix] = 1
- else
- # already appeared prefix, generate next name
- @namecnt[prefix] += 1
- end
- return "#{prefix}#{@namecnt[prefix]}"
-end
-
-################
-
-# class TclTkInterpreter: tcl/tk interpreter
-class TclTkInterpreter
-
- # initialize():
- def initialize()
- # generate interpreter object
- @ip = TclTkIp.new()
-
- # add ruby_fmt command to tcl interpreter
- # ruby_fmt command format arguments by `format' and call `ruby' command
- # (notice ruby command receives only one argument)
- if $DEBUG
- @ip._eval("proc ruby_fmt {fmt args} { puts \"ruby_fmt: $fmt $args\" ; set cmd [list ruby [format $fmt $args]] ; uplevel $cmd }")
- else
- @ip._eval("proc ruby_fmt {fmt args} { set cmd [list ruby [format $fmt $args]] ; uplevel $cmd }")
- end
-
- # @ip._get_eval_string(*args): generate string to evaluate in tcl interpreter
- # *args: script which is going to be evaluated under tcl/tk
- def @ip._get_eval_string(*args)
- argstr = ""
- args.each{|arg|
- argstr += " " if argstr != ""
- # call to_eval if it is defined
- if (arg.respond_to?(:to_eval))
- argstr += arg.to_eval()
- else
- # call to_s unless defined
- argstr += arg.to_s()
- end
- }
- return argstr
- end
-
- # @ip._eval_args(*args): evaluate string under tcl/tk interpreter
- # returns result string.
- # *args: script which is going to be evaluated under tcl/tk
- def @ip._eval_args(*args)
- # calculate the string to eval in the interpreter
- argstr = _get_eval_string(*args)
-
- # evaluate under the interpreter
- print("_eval: \"", argstr, "\"") if $DEBUG
- res = _eval(argstr)
- if $DEBUG
- print(" -> \"", res, "\"\n")
- elsif _return_value() != 0
- print(res, "\n")
- end
- fail(%Q/can't eval "#{argstr}"/) if _return_value() != 0 #'
- return res
- end
-
- # generate tcl/tk command object and register in the hash
- @commands = {}
- # for all commands registered in tcl/tk interpreter:
- @ip._eval("info command").split(/ /).each{|comname|
- if comname =~ /^[.]/
- # if command is a widget (path), generate TclTkWidget,
- # and register it in the hash
- @commands[comname] = TclTkWidget.new(@ip, comname)
- else
- # otherwise, generate TclTkCommand
- @commands[comname] = TclTkCommand.new(@ip, comname)
- end
- }
- end
-
- # commands(): returns hash of the tcl/tk commands
- def commands()
- return @commands
- end
-
- # rootwidget(): returns root widget(TclTkWidget)
- def rootwidget()
- return @commands["."]
- end
-
- # _tcltkip(): returns @ip(TclTkIp)
- def _tcltkip()
- return @ip
- end
-
- # method_missing(id, *args): execute undefined method as tcl/tk command
- # id: method symbol
- # *args: method arguments
- def method_missing(id, *args)
- # if command named by id registered, then execute it
- if @commands.key?(id.id2name)
- return @commands[id.id2name].e(*args)
- else
- # otherwise, exception
- super
- end
- end
-end
-
-# class TclTkObject: base class of the tcl/tk objects
-class TclTkObject
-
- # initialize(ip, exp):
- # ip: interpreter(TclTkIp)
- # exp: tcl/tk representation
- def initialize(ip, exp)
- fail("type is not TclTkIp") if !ip.kind_of?(TclTkIp)
- @ip = ip
- @exp = exp
- end
-
- # to_s(): returns tcl/tk representation
- def to_s()
- return @exp
- end
-end
-
-# class TclTkCommand: tcl/tk commands
-# you should not call TclTkCommand.new()
-# commands are created by TclTkInterpreter:initialize()
-class TclTkCommand < TclTkObject
-
- # e(*args): execute command. returns String (e is for exec or eval)
- # *args: command arguments
- def e(*args)
- return @ip._eval_args(to_s(), *args)
- end
-end
-
-# class TclTkLibCommand: tcl/tk commands in the library
-class TclTkLibCommand < TclTkCommand
-
- # initialize(ip, name):
- # ip: interpreter(TclTkInterpreter)
- # name: command name (String)
- def initialize(ip, name)
- super(ip._tcltkip, name)
- end
-end
-
-# class TclTkVariable: tcl/tk variable
-class TclTkVariable < TclTkObject
-
- # initialize(interp, dat):
- # interp: interpreter(TclTkInterpreter)
- # dat: the value to set(String)
- # if nil, not initialize variable
- def initialize(interp, dat)
- # auto-generate tcl/tk representation (variable name)
- exp = TclTk._newname("v_")
- # initialize TclTkObject
- super(interp._tcltkip(), exp)
- # safe this for `set' command
- @set = interp.commands()["set"]
- # set value
- set(dat) if dat
- end
-
- # although you can set/refer variable by using set in tcl/tk,
- # we provide the method for accessing variables
-
- # set(data): set tcl/tk variable using `set'
- # data: new value
- def set(data)
- @set.e(to_s(), data.to_s())
- end
-
- # get(): read tcl/tk variable(String) using `set'
- def get()
- return @set.e(to_s())
- end
-end
-
-# class TclTkWidget: tcl/tk widget
-class TclTkWidget < TclTkCommand
-
- # initialize(*args):
- # *args: parameters
- def initialize(*args)
- if args[0].kind_of?(TclTkIp)
- # in case the 1st argument is TclTkIp:
-
- # Wrap tcl/tk widget by TclTkWidget
- # (used in TclTkInterpreter#initialize())
-
- # need two arguments
- fail("illegal # of parameter") if args.size != 2
-
- # ip: interpreter(TclTkIp)
- # exp: tcl/tk representation
- ip, exp = args
-
- # initialize TclTkObject
- super(ip, exp)
- elsif args[0].kind_of?(TclTkInterpreter)
- # in case 1st parameter is TclTkInterpreter:
-
- # generate new widget from parent widget
-
- # interp: interpreter(TclTkInterpreter)
- # parent: parent widget
- # command: widget generating tk command(label 等)
- # *args: argument to the command
- interp, parent, command, *args = args
-
- # generate widget name
- exp = parent.to_s()
- exp += "." if exp !~ /[.]$/
- exp += TclTk._newname("w_")
- # initialize TclTkObject
- super(interp._tcltkip(), exp)
- # generate widget
- res = @ip._eval_args(command, exp, *args)
-# fail("can't create Widget") if res != exp
- # for tk_optionMenu, it is legal res != exp
- else
- fail("first parameter is not TclTkInterpreter")
- end
- end
-end
-
-# class TclTkCallback: tcl/tk callbacks
-class TclTkCallback < TclTkObject
-
- # initialize(interp, pr, arg):
- # interp: interpreter(TclTkInterpreter)
- # pr: callback procedure(Proc)
- # arg: string to pass as block parameters of pr
- # bind command of tcl/tk uses % replacement for parameters
- # pr can receive replaced data using block parameter
- # its format is specified by arg string
- # You should not specify arg for the command like
- # scrollbar with -command option, which receives parameters
- # without specifying any replacement
- def initialize(interp, pr, arg = nil)
- # auto-generate tcl/tk representation (variable name)
- exp = TclTk._newname("c_")
- # initialize TclTkObject
- super(interp._tcltkip(), exp)
- # save parameters
- @pr = pr
- @arg = arg
- # register in the module
- TclTk._addcallback(self)
- end
-
- # to_eval(): retuens string representation for @ip._eval_args
- def to_eval()
- if @arg
- # bind replaces %s before calling ruby_fmt, so %%s is used
- s = %Q/{ruby_fmt {TclTk._callcallback("#{to_s()}", "%%s")} #{@arg}}/
- else
- s = %Q/{ruby_fmt {TclTk._callcallback("#{to_s()}", "%s")}}/
- end
-
- return s
- end
-
- # _call(arg): invoke callback
- # arg: callback parameter
- def _call(arg)
- @pr.call(arg)
- end
-end
-
-# class TclTkImage: tcl/tk images
-class TclTkImage < TclTkCommand
-
- # initialize(interp, t, *args):
- # generating image is done by TclTkImage.new()
- # destrying is done by image delete (inconsistent, sigh)
- # interp: interpreter(TclTkInterpreter)
- # t: image type (photo, bitmap, etc.)
- # *args: command argument
- def initialize(interp, t, *args)
- # auto-generate tcl/tk representation
- exp = TclTk._newname("i_")
- # initialize TclTkObject
- super(interp._tcltkip(), exp)
- # generate image
- res = @ip._eval_args("image create", t, exp, *args)
- fail("can't create Image") if res != exp
- end
-end
-
-# eof
diff --git a/ext/tcltklib/sample/batsu.gif b/ext/tcltklib/sample/batsu.gif
deleted file mode 100644
index 880cc73e09..0000000000
--- a/ext/tcltklib/sample/batsu.gif
+++ /dev/null
Binary files differ
diff --git a/ext/tcltklib/sample/maru.gif b/ext/tcltklib/sample/maru.gif
deleted file mode 100644
index 2c0202892e..0000000000
--- a/ext/tcltklib/sample/maru.gif
+++ /dev/null
Binary files differ
diff --git a/ext/tcltklib/sample/sample0.rb b/ext/tcltklib/sample/sample0.rb
deleted file mode 100644
index cd4c8069b4..0000000000
--- a/ext/tcltklib/sample/sample0.rb
+++ /dev/null
@@ -1,39 +0,0 @@
-#! /usr/local/bin/ruby -vd
-
-# tcltklib ライブラリのテスト
-
-require "tcltklib"
-
-def test
- # インタプリタを生成する
- ip1 = TclTkIp.new()
-
- # 評価してみる
- print ip1._return_value().inspect, "\n"
- print ip1._eval("puts {abc}").inspect, "\n"
-
- # ボタンを作ってみる
- print ip1._return_value().inspect, "\n"
- print ip1._eval("button .lab -text exit -command \"destroy .\"").inspect,
- "\n"
- print ip1._return_value().inspect, "\n"
- print ip1._eval("pack .lab").inspect, "\n"
- print ip1._return_value().inspect, "\n"
-
- # インタプリタから ruby コマンドを評価してみる
-# print ip1._eval(%q/ruby {print "print by ruby\n"}/).inspect, "\n"
- print ip1._eval(%q+puts [ruby {print "print by ruby\n"; "puts by tcl/tk"}]+).inspect, "\n"
- print ip1._return_value().inspect, "\n"
-
- # もう一つインタプリタを生成してみる
- ip2 = TclTkIp.new()
- ip2._eval("button .lab -text test -command \"puts test ; destroy .\"")
- ip2._eval("pack .lab")
-
- TclTkLib.mainloop
-end
-
-test
-GC.start
-
-print "exit\n"
diff --git a/ext/tcltklib/sample/sample1.rb b/ext/tcltklib/sample/sample1.rb
deleted file mode 100644
index 21ee0f29d5..0000000000
--- a/ext/tcltklib/sample/sample1.rb
+++ /dev/null
@@ -1,634 +0,0 @@
-#! /usr/local/bin/ruby -d
-#! /usr/local/bin/ruby
-# -d オプションを付けると, デバッグ情報を表示する.
-
-# tcltk ライブラリのサンプル
-
-# まず, ライブラリを require する.
-require "tcltk"
-
-# 以下は, Test1 のインスタンスの initialize() で,
-# tcl/tk に関する処理を行う例である.
-# 必ずしもそのようにする必要は無く,
-# (もし, そうしたければ) class の外で tcl/tk に関する処理を行っても良い.
-
-class Test1
- # 初期化(インタプリタを生成してウィジェットを生成する).
- def initialize()
-
- #### 使う前のおまじない
-
- # インタプリタの生成.
- ip = TclTkInterpreter.new()
- # コマンドに対応するオブジェクトを c に設定しておく.
- c = ip.commands()
- # 使用するコマンドに対応するオブジェクトは変数に入れておく.
- append, bind, button, destroy, incr, info, label, place, set, wm =
- c.indexes(
- "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().indexes(
- "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().indexes(
- "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().indexes(
- "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().indexes("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().indexes(
- "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().indexes(
- "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().indexes(
- "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().indexes(
- "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().indexes(
- "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().indexes(
- "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().indexes(
- "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().indexes(
- "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().indexes(
- "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().indexes("canvas", "lower", "pack")
- t1, b1, cb = inittoplevel(ip, parent, "canvas")
-
- ## canvas
-
- ca1 = TclTkWidget.new(ip, t1, canvas, "-width 400 -height 300")
- lower.e(ca1, b1)
- # rectangle を作る.
- idr = ca1.e("create rectangle 10 10 20 20")
- # oval を作る.
- ca1.e("create oval 60 10 100 50")
- # polygon を作る.
- ca1.e("create polygon 110 10 110 30 140 10")
- # line を作る.
- ca1.e("create line 150 10 150 30 190 10")
- # arc を作る.
- ca1.e("create arc 200 10 250 50 -start 0 -extent 90 -style pieslice")
- # i1 は本当は, どこかで破壊しなければならないが, 面倒なので放ってある.
- i1 = TclTkImage.new(ip, "photo", "-file maru.gif")
- # image を作る.
- ca1.e("create image 100 100 -image", i1)
- # bitmap を作る.
- ca1.e("create bitmap 260 50 -bitmap questhead")
- # text を作る.
- ca1.e("create text 320 50 -text {drag rectangle}")
- # window を作る(クローズボタン).
- ca1.e("create window 200 200 -window", b1)
-
- # bind により rectangle を drag できるようにする.
- cb.push(c = TclTkCallback.new(ip, proc{|i|
- # i に x と y を受け取るので, 取り出す.
- x, y = i.split(/ /); x = x.to_f; y = y.to_f
- # 座標を変更する.
- ca1.e("coords current #{x - 5} #{y - 5} #{x + 5} #{y + 5}")},
- # x, y 座標を空白で区切ったものをイテレータ変数へ渡すように指定.
- "%x %y"))
- # rectangle に bind する.
- ca1.e("bind", idr, "<B1-Motion>", c)
-
- pack.e(ca1)
- end
-end
-
-# test driver
-
-if ARGV.size == 0
- print "#{$0} n で, n 個のインタプリタを起動します.\n"
- n = 1
-else
- n = ARGV[0].to_i
-end
-
-print "start\n"
-ip = []
-
-# インタプリタ, ウィジェット等の生成.
-for i in 1 .. n
- ip.push(Test1.new())
-end
-
-# 用意ができたらイベントループに入る.
-TclTk.mainloop()
-print "exit from mainloop\n"
-
-# インタプリタが GC されるかのテスト.
-ip = []
-print "GC.start\n" if $DEBUG
-GC.start() if $DEBUG
-print "end\n"
-
-exit
-
-# end
diff --git a/ext/tcltklib/sample/sample2.rb b/ext/tcltklib/sample/sample2.rb
deleted file mode 100644
index 969d8de09a..0000000000
--- a/ext/tcltklib/sample/sample2.rb
+++ /dev/null
@@ -1,449 +0,0 @@
-#!/usr/local/bin/ruby
-#----------------------> pretty simple othello game <-----------------------
-# othello.rb
-#
-# version 0.3
-# maeda shugo (shuto@po.aianet.ne.jp)
-#---------------------------------------------------------------------------
-
-# Sep. 17, 1997 modified by Y. Shigehiro for tcltk library
-# maeda shugo (shugo@po.aianet.ne.jp) 氏による
-# (ruby/tk で書かれていた) ruby のサンプルプログラム
-# http://www.aianet.or.jp/~shugo/ruby/othello.rb.gz
-# を tcltk ライブラリを使うように, 機械的に変更してみました.
-#
-# なるべくオリジナルと同じになるようにしてあります.
-
-require "observer"
-require "tcltk"
-$ip = TclTkInterpreter.new()
-$root = $ip.rootwidget()
-$button, $canvas, $checkbutton, $frame, $label, $pack, $update, $wm =
- $ip.commands().indexes(
- "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))
- @row = row
- @col = col
- @view.e("itemconfigure", @id,
- "-width 0.5m -outline #{BORDER_COLOR}")
- @view.e("bind", @id, "<Any-Enter>", TclTkCallback.new($ip, proc{
- if @oval == nil
- view.e("itemconfigure", @id, "-fill #{HILIT_BG_COLOR}")
- end
- }))
- @view.e("bind", @id, "<Any-Leave>", TclTkCallback.new($ip, proc{
- view.e("itemconfigure", @id, "-fill #{BACK_GROUND_COLOR}")
- }))
- @view.e("bind", @id, "<ButtonRelease-1>", TclTkCallback.new($ip,
- proc{
- view.click_square(self)
- }))
- end
-
- def blink(color)
- @view.e("itemconfigure", @id, "-fill #{color}")
- $update.e()
- sleep(0.1)
- @view.e("itemconfigure", @id, "-fill #{BACK_GROUND_COLOR}")
- end
- end #-----------------------> class Square ends here
-
- def initialize(othello, board)
- super($ip, $root, $canvas)
- @othello = othello
- @board = board
- @board.add_observer(self)
-
- @squares = Array.new(8)
- for i in 0 .. 7
- @squares[i] = Array.new(8)
- end
- @left = 1
- @top = 0.5
- @right = @left + 8
- @bottom = @top + 8
-
- i = self.e("create rectangle", *tk_rect(@left, @top, @right, @bottom))
- self.e("itemconfigure", i,
- "-width 1m -outline #{BORDER_COLOR} -fill #{BACK_GROUND_COLOR}")
-
- for row in 0 .. 7
- for col in 0 .. 7
- @squares[row][col] = Square.new(self, row, col)
- end
- end
-
- update
- end
-
- def tk_rect(left, top, right, bottom)
- return left.to_s + "c", top.to_s + "c",
- right.to_s + "c", bottom.to_s + "c"
- end
-
- def clear
- each_square do |square|
- if square.oval != nil
- self.e("delete", square.oval)
- square.oval = nil
- end
- end
- end
-
- def draw_disk(row, col, disk)
- if disk == EMPTY
- if @squares[row][col].oval != nil
- self.e("delete", @squares[row][col].oval)
- @squares[row][col].oval = nil
- end
- return
- end
-
- $update.e()
- sleep(0.05)
- oval = @squares[row][col].oval
- if oval == nil
- oval = self.e("create oval", *tk_rect(@left + col + 0.2,
- @top + row + 0.2,
- @left + col + 0.8,
- @top + row + 0.8))
- @squares[row][col].oval = oval
- end
- case disk
- when BLACK
- color = BLACK_COLOR
- when WHITE
- color = WHITE_COLOR
- else
- fail format("Unknown disk type: %d", disk)
- end
- self.e("itemconfigure", oval, "-outline #{color} -fill #{color}")
- end
-
- def update(row = nil, col = nil)
- if row && col
- draw_disk(row, col, @board.get_disk(row, col))
- else
- each_square do |square|
- draw_disk(square.row, square.col,
- @board.get_disk(square.row, square.col))
- end
- end
- @othello.show_point
- end
-
- def each_square
- @squares.each do |rows|
- rows.each do |square|
- yield(square)
- end
- end
- end
-
- def click_square(square)
- if @othello.in_com_turn || @othello.game_over ||
- @board.count_point(square.row,
- square.col,
- @board.man_disk) == 0
- square.blink(STOP_COLOR)
- return
- end
- @board.put_disk(square.row, square.col, @board.man_disk)
- @othello.com_turn
- end
-
- private :draw_disk
- public :update
- end #----------------------> class BoardView ends here
-
- def initialize
- @msg_label = TclTkWidget.new($ip, $root, $label)
- $pack.e(@msg_label)
-
- @board = Board.new(self)
- @board_view = BoardView.new(self, @board)
- #### added by Y. Shigehiro
- ## board_view の大きさを設定する.
- x1, y1, x2, y2 = @board_view.e("bbox all").split(/ /).collect{|i| i.to_f}
- @board_view.e("configure -width", x2 - x1)
- @board_view.e("configure -height", y2 - y1)
- ## scrollregion を設定する.
- @board_view.e("configure -scrollregion {", @board_view.e("bbox all"),
- "}")
- #### ここまで
- $pack.e(@board_view, "-fill both -expand true")
-
- panel = TclTkWidget.new($ip, $root, $frame)
-
- @play_black = TclTkWidget.new($ip, panel, $checkbutton,
- "-text {com is black} -command", TclTkCallback.new($ip, proc{
- switch_side
- }))
- $pack.e(@play_black, "-side left")
-
- quit = TclTkWidget.new($ip, panel, $button, "-text Quit -command",
- TclTkCallback.new($ip, proc{
- exit
- }))
- $pack.e(quit, "-side right -fill x")
-
- reset = TclTkWidget.new($ip, panel, $button, "-text Reset -command",
- TclTkCallback.new($ip, proc{
- reset_game
- }))
- $pack.e(reset, "-side right -fill x")
-
- $pack.e(panel, "-side bottom -fill x")
-
-# root = Tk.root
- $wm.e("title", $root, "Othello")
- $wm.e("iconname", $root, "Othello")
-
- @board.com_disk = WHITE
- @game_over = FALSE
-
- TclTk.mainloop
- end
-
- def switch_side
- if @in_com_turn
- @play_black.e("toggle")
- else
- @board.com_disk = @board.man_disk
- com_turn unless @game_over
- end
- end
-
- def reset_game
- if @board.com_disk == BLACK
- @board.com_disk = WHITE
- @play_black.e("toggle")
- end
- @board_view.clear
- @board.reset
- $wm.e("title", $root, "Othello")
- @game_over = FALSE
- end
-
- def com_turn
- @in_com_turn = TRUE
- $update.e()
- sleep(0.5)
- begin
- com_disk = @board.count_disk(@board.com_disk)
- man_disk = @board.count_disk(@board.man_disk)
- if @board.count_disk(EMPTY) == 0
- if man_disk == com_disk
- $wm.e("title", $root, "{Othello - Draw!}")
- elsif man_disk > com_disk
- $wm.e("title", $root, "{Othello - You Win!}")
- else
- $wm.e("title", $root, "{Othello - You Loose!}")
- end
- @game_over = TRUE
- break
- elsif com_disk == 0
- $wm.e("title", $root, "{Othello - You Win!}")
- @game_over = TRUE
- break
- elsif man_disk == 0
- $wm.e("title", $root, "{Othello - You Loose!}")
- @game_over = TRUE
- break
- end
- row, col = @board.search(@board.com_disk)
- break if row == nil || col == nil
- @board.put_disk(row, col, @board.com_disk)
- end while @board.search(@board.man_disk) == [nil, nil]
- @in_com_turn = FALSE
- end
-
- def show_point
- black = @board.count_disk(BLACK)
- white = @board.count_disk(WHITE)
- @msg_label.e("configure -text",
- %Q/{#{format("BLACK: %.2d WHITE: %.2d", black, white)}}/)
- end
-end #----------------------> class Othello ends here
-
-Othello.new
-
-#----------------------------------------------> othello.rb ends here
diff --git a/ext/tcltklib/stubs.c b/ext/tcltklib/stubs.c
deleted file mode 100644
index 56cc8ca921..0000000000
--- a/ext/tcltklib/stubs.c
+++ /dev/null
@@ -1,97 +0,0 @@
-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;
- 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_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/tcltklib/tcltklib.c b/ext/tcltklib/tcltklib.c
deleted file mode 100644
index 50c654d814..0000000000
--- a/ext/tcltklib/tcltklib.c
+++ /dev/null
@@ -1,2396 +0,0 @@
-/*
- * tcltklib.c
- * Aug. 27, 1997 Y. Shigehiro
- * Oct. 24, 1997 Y. Matsumoto
- */
-
-#include "ruby.h"
-#include "rubysig.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
-#endif
-
-/* for ruby_debug */
-
-#define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);}
-#define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\
-fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); }
-/*
-#define DUMP1(ARG1)
-#define DUMP2(ARG1, ARG2)
-*/
-
-/* for callback break & continue */
-static VALUE eTkCallbackBreak;
-static VALUE eTkCallbackContinue;
-
-static VALUE ip_invoke_real _((int, VALUE*, VALUE));
-static VALUE ip_invoke _((int, VALUE*, VALUE));
-
-/* from tkAppInit.c */
-
-#if !defined __MINGW32__
-/*
- * 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
-
-/*---- module TclTkLib ----*/
-
-struct invoke_queue {
- Tcl_Event ev;
- int argc;
- VALUE *argv;
- VALUE obj;
- int done;
- int safe_level;
- VALUE *result;
- VALUE thread;
-};
-
-struct eval_queue {
- Tcl_Event ev;
- VALUE str;
- VALUE obj;
- int done;
- int safe_level;
- VALUE *result;
- VALUE 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 _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
-#else
-static int ip_ruby _((ClientData, Tcl_Interp *, int, char **));
-#endif
-
-/*---- class TclTkIp ----*/
-struct tcltkip {
- Tcl_Interp *ip; /* the interpreter */
- 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;
-}
-
-/* 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;
-{
- /* struct invoke_queue *q, *tmp; */
- /* VALUE thread; */
-
- DUMP1("called timer_for_tcl");
- 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_schedule(); */
- /* tick_counter += event_loop_max; */
-}
-
-static VALUE
-set_eventloop_tick(self, tick)
- VALUE self;
- VALUE tick;
-{
- int ttick = NUM2INT(tick);
-
- rb_secure(4);
-
- if (ttick < 0) {
- rb_raise(rb_eArgError,
- "timer-tick parameter must be 0 or positive number");
- }
-
- /* 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;
- }
-
- 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);
-
- 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);
-
- 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);
-
- 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
-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 (val == Qnil) {
- 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);
- 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, check_var)
- int check_root;
- int *check_var;
-{
- VALUE current = eventloop_thread;
- int found_event = 1;
- struct timeval t;
-
- 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) {
- timer_token = Tk_CreateTimerHandler(timer_tick, _timer_for_tcl,
- (ClientData)0);
- } else {
- timer_token = (Tcl_TimerToken)NULL;
- }
-
- for(;;) {
- if (rb_thread_alone()) {
- DUMP1("no other thread");
- event_loop_wait_event = 0;
-
- if (timer_tick == 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(TCL_ALL_EVENTS);
-
- if (loop_counter++ > 30000) {
- loop_counter = 0;
- }
-
- if (run_timer_flag) {
- /*
- DUMP1("timer interrupt");
- run_timer_flag = 0;
- DUMP1("call rb_trap_exec()");
- rb_trap_exec();
- */
- DUMP1("check Root Widget");
- if (check_root && Tk_GetNumMainWindows() == 0) {
- run_timer_flag = 0;
- rb_trap_exec();
- return 1;
- }
- }
-
- } else {
- int tick_counter;
-
- DUMP1("there are other threads");
- event_loop_wait_event = 1;
-
- found_event = 1;
-
- 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(TCL_ALL_EVENTS | TCL_DONT_WAIT)) {
- tick_counter++;
- } else {
- tick_counter += no_event_tick;
-
- DUMP1("check Root Widget");
- if (check_root && Tk_GetNumMainWindows() == 0) {
- return 1;
- }
-
- rb_thread_wait_for(t);
- }
-
- if (loop_counter++ > 30000) {
- loop_counter = 0;
- }
-
- if (watchdog_thread != 0 && eventloop_thread != current) {
- return 1;
- }
-
- if (run_timer_flag) {
- /*
- DUMP1("timer interrupt");
- run_timer_flag = 0;
- */
- break; /* switch to other thread */
- }
- }
-
- DUMP1("check Root Widget");
- if (check_root && Tk_GetNumMainWindows() == 0) {
- return 1;
- }
- }
-
- /* rb_thread_schedule(); */
- if (run_timer_flag) {
- run_timer_flag = 0;
- rb_trap_exec();
- } else {
- DUMP1("thread scheduling");
- if (is_ruby_native_thread()) {
- rb_thread_schedule();
- }
- }
- }
- return 1;
-}
-
-VALUE
-lib_eventloop_main(check_rootwidget)
- VALUE check_rootwidget;
-{
- check_rootwidget_flag = RTEST(check_rootwidget);
-
- if (lib_eventloop_core(check_rootwidget_flag, (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);
-
- 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, rb_intern("stop?"), 0))) {
- rb_funcall(watchdog_thread, rb_intern("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, rb_intern("stop?"), 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);
-
- 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;
-{
- 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);
- if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
- /* slave IP */
- flags |= TCL_DONT_WAIT;
- }
- }
-
- found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT);
-
- 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);
-}
-
-
-/* Tcl command `ruby' */
-static VALUE
-ip_ruby_eval_rescue(failed, einfo)
- VALUE *failed;
- VALUE einfo;
-{
- *failed = einfo;
- return Qnil;
-}
-
-struct eval_body_arg {
- char *string;
- VALUE failed;
-};
-
-static VALUE
-ip_ruby_eval_body(arg)
- struct eval_body_arg *arg;
-{
- rb_trap_immediate = 0;
- return rb_rescue2(rb_eval_string, (VALUE)arg->string,
- ip_ruby_eval_rescue, (VALUE)&(arg->failed),
- rb_eStandardError, rb_eScriptError, rb_eSystemExit,
- (VALUE)0);
-}
-
-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(clientData, interp, argc, argv)
- ClientData clientData;
- Tcl_Interp *interp;
- int argc;
- Tcl_Obj *CONST argv[];
-#else
-ip_ruby(clientData, interp, argc, argv)
- ClientData clientData;
- Tcl_Interp *interp;
- int argc;
- char *argv[];
-#endif
-{
- VALUE res;
- int old_trapflag;
- struct eval_body_arg arg;
- int dummy;
-
- /* ruby command has 1 arg. */
- if (argc != 2) {
- rb_raise(rb_eArgError, "wrong # of arguments (%d for 1)", argc);
- }
-
- /* get C string from Tcl object */
-#if TCL_MAJOR_VERSION >= 8
- arg.string = Tcl_GetStringFromObj(argv[1], &dummy);
-#else
- arg.string = argv[1];
-#endif
- arg.failed = 0;
-
- /* evaluate the argument string by ruby */
- DUMP2("rb_eval_string(%s)", arg);
- old_trapflag = rb_trap_immediate;
- res = rb_ensure(ip_ruby_eval_body, (VALUE)&arg,
- ip_ruby_eval_ensure, INT2FIX(old_trapflag));
-
- /* status check */
- if (arg.failed) {
- VALUE eclass = CLASS_OF(arg.failed);
- DUMP1("(rb_eval_string result) failed");
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, StringValuePtr(arg.failed), (char*)NULL);
- if (eclass == eTkCallbackBreak) {
- return TCL_BREAK;
- } else if (eclass == eTkCallbackContinue) {
- return TCL_CONTINUE;
- } else if (eclass == rb_eSystemExit) {
- Tcl_Eval(interp, "destroy .");
- rb_raise(rb_eSystemExit, StringValuePtr(arg.failed));
- } else {
- 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 */
- DUMP2("(rb_eval_string result) %s", StringValuePtr(res));
- DUMP1("Tcl_AppendResult");
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, StringValuePtr(res), (char *)NULL);
-
- return TCL_OK;
-}
-
-
-/**************************/
-/* based on tclEvent.c */
-/**************************/
-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. */
-{
- 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
-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 done, foundEvent;
- char *nameString;
- int dummy;
-
- DUMP1("Ruby's 'vwait' is called");
- if (objc != 2) {
-#ifdef Tcl_WrongNumArgs
- Tcl_WrongNumArgs(interp, 1, objv, "name");
-#else
-#if TCL_MAJOR_VERSION >= 8
- /* nameString = Tcl_GetString(objv[0]); */
- nameString = Tcl_GetStringFromObj(objv[0], &dummy);
-#else
- nameString = objv[0];
-#endif
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- nameString, " name\"", (char *) NULL);
-#endif
- return TCL_ERROR;
- }
-#if TCL_MAJOR_VERSION >= 8
- /* nameString = Tcl_GetString(objv[1]); */
- nameString = Tcl_GetStringFromObj(objv[1], &dummy);
-#else
- 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;
- };
- done = 0;
- foundEvent = lib_eventloop_core(/* not check root-widget */0, &done);
- Tcl_UntraceVar(interp, nameString,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, (ClientData) &done);
-
- /*
- * Clear out the interpreter's result, since it may have been set
- * by event handlers.
- */
-
- Tcl_ResetResult(interp);
- if (!foundEvent) {
- Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
- "\": would wait forever", (char *) NULL);
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-
-/**************************/
-/* based on tkCmd.c */
-/**************************/
-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. */
-{
- 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
-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;
- int done, index;
- static CONST char *optionStrings[] = { "variable", "visibility", "window",
- (char *) NULL };
- enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW };
- char *nameString;
- int dummy;
-
- DUMP1("Ruby's 'tkwait' is called");
-
- if (objc != 3) {
-#ifdef Tcl_WrongNumArgs
- Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name");
-#else
-#if TCL_MAJOR_VERSION >= 8
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- Tcl_GetStringFromObj(objv[0], &dummy),
- " variable|visibility|window name\"",
- (char *) NULL);
-#else
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- objv[0], " variable|visibility|window name\"",
- (char *) NULL);
-#endif
-#endif
- return TCL_ERROR;
- }
-
-#if TCL_MAJOR_VERSION >= 8
- if (Tcl_GetIndexFromObj(interp, objv[1],
- (CONST84 char **)optionStrings,
- "option", 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
-#else
- {
- 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);
- return TCL_ERROR;
- }
- }
-#endif
-
-#if TCL_MAJOR_VERSION >= 8
- /* nameString = Tcl_GetString(objv[2]); */
- nameString = Tcl_GetStringFromObj(objv[2], &dummy);
-#else
- nameString = objv[2];
-#endif
-
- switch ((enum options) index) {
- case TKWAIT_VARIABLE: {
- if (Tcl_TraceVar(interp, nameString,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- WaitVariableProc, (ClientData) &done) != TCL_OK) {
- return TCL_ERROR;
- }
- done = 0;
- lib_eventloop_core(check_rootwidget_flag, &done);
- Tcl_UntraceVar(interp, nameString,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- WaitVariableProc, (ClientData) &done);
- break;
- }
-
- case TKWAIT_VISIBILITY: {
- Tk_Window window;
-
- window = Tk_NameToWindow(interp, nameString, tkwin);
- if (window == NULL) {
- return TCL_ERROR;
- }
- Tk_CreateEventHandler(window,
- VisibilityChangeMask|StructureNotifyMask,
- WaitVisibilityProc, (ClientData) &done);
- done = 0;
- lib_eventloop_core(check_rootwidget_flag, &done);
- if (done != 1) {
- /*
- * Note that we do not delete the event handler because it
- * was deleted automatically when the window was destroyed.
- */
-
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "window \"", nameString,
- "\" was deleted before its visibility changed",
- (char *) NULL);
- return TCL_ERROR;
- }
- Tk_DeleteEventHandler(window,
- VisibilityChangeMask|StructureNotifyMask,
- WaitVisibilityProc, (ClientData) &done);
- break;
- }
-
- case TKWAIT_WINDOW: {
- Tk_Window window;
-
- window = Tk_NameToWindow(interp, nameString, tkwin);
- if (window == NULL) {
- return TCL_ERROR;
- }
- Tk_CreateEventHandler(window, StructureNotifyMask,
- WaitWindowProc, (ClientData) &done);
- done = 0;
- lib_eventloop_core(check_rootwidget_flag, &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);
- return TCL_OK;
-}
-
-/****************************/
-/* vwait/tkwait with thread */
-/****************************/
-struct th_vwait_param {
- VALUE thread;
- int done;
-};
-
-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. */
-{
- struct th_vwait_param *param = (struct th_vwait_param *) clientData;
-
- param->done = 1;
- rb_thread_run(param->thread);
-
- return (char *)NULL;
-}
-
-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 = 1;
- }
- if (eventPtr->type == DestroyNotify) {
- param->done = 2;
- }
-}
-
-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 = 1;
- }
-}
-
-#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
-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 dummy;
-
- DUMP1("Ruby's 'thread_vwait' is called");
-
- if (eventloop_thread == rb_thread_current()) {
-#if TCL_MAJOR_VERSION >= 8
- DUMP1("call ip_rbVwaitObjCmd");
- return ip_rbVwaitObjCmd(clientData, interp, objc, objv);
-#else
- DUMP1("call ip_rbVwaitCommand");
- return ip_rbVwaitCommand(clientData, interp, objc, objv);
-#endif
- }
-
- if (objc != 2) {
-#ifdef Tcl_WrongNumArgs
- Tcl_WrongNumArgs(interp, 1, objv, "name");
-#else
-#if TCL_MAJOR_VERSION >= 8
- /* nameString = Tcl_GetString(objv[0]); */
- nameString = Tcl_GetStringFromObj(objv[0], &dummy);
-#else
- nameString = objv[0];
-#endif
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- nameString, " name\"", (char *) NULL);
-#endif
- return TCL_ERROR;
- }
-#if TCL_MAJOR_VERSION >= 8
- /* nameString = Tcl_GetString(objv[1]); */
- nameString = Tcl_GetStringFromObj(objv[1], &dummy);
-#else
- nameString = objv[1];
-#endif
-
- param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param));
- param->thread = rb_thread_current();
- 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;
- };
-
- if (!param->done) {
- rb_thread_stop();
- }
-
- Tcl_UntraceVar(interp, nameString,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- rb_threadVwaitProc, (ClientData) param);
-
- Tcl_Free((char *)param);
-
- 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
-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;
- int index;
- static CONST char *optionStrings[] = { "variable", "visibility", "window",
- (char *) NULL };
- enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW };
- char *nameString;
- int dummy;
-
- DUMP1("Ruby's 'thread_tkwait' is called");
-
- if (eventloop_thread == rb_thread_current()) {
-#if TCL_MAJOR_VERSION >= 8
- DUMP1("call ip_rbTkWaitObjCmd");
- return ip_rbTkWaitObjCmd(clientData, interp, objc, objv);
-#else
- DUMP1("call rb_VwaitCommand");
- return ip_rbTkWaitCommand(clientData, interp, objc, objv);
-#endif
- }
-
- if (objc != 3) {
-#ifdef Tcl_WrongNumArgs
- Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name");
-#else
-#if TCL_MAJOR_VERSION >= 8
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- Tcl_GetStringFromObj(objv[0], &dummy),
- " variable|visibility|window name\"",
- (char *) NULL);
-#else
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- objv[0], " variable|visibility|window name\"",
- (char *) NULL);
-#endif
-#endif
- return TCL_ERROR;
- }
-
-#if TCL_MAJOR_VERSION >= 8
- if (Tcl_GetIndexFromObj(interp, objv[1],
- (CONST84 char **)optionStrings,
- "option", 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
-#else
- {
- 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);
- return TCL_ERROR;
- }
- }
-#endif
-
-#if TCL_MAJOR_VERSION >= 8
- /* nameString = Tcl_GetString(objv[2]); */
- nameString = Tcl_GetStringFromObj(objv[2], &dummy);
-#else
- nameString = objv[2];
-#endif
-
- param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param));
- param->thread = rb_thread_current();
- param->done = 0;
-
- switch ((enum options) index) {
- case TKWAIT_VARIABLE: {
- if (Tcl_TraceVar(interp, nameString,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- rb_threadVwaitProc, (ClientData) param) != TCL_OK) {
- return TCL_ERROR;
- };
-
- if (!param->done) {
- rb_thread_stop();
- }
-
- Tcl_UntraceVar(interp, nameString,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- rb_threadVwaitProc, (ClientData) param);
- break;
- }
-
- case TKWAIT_VISIBILITY: {
- Tk_Window window;
-
- window = Tk_NameToWindow(interp, nameString, tkwin);
- if (window == NULL) {
- return TCL_ERROR;
- }
- Tk_CreateEventHandler(window,
- VisibilityChangeMask|StructureNotifyMask,
- rb_threadWaitVisibilityProc, (ClientData) param);
- if (!param->done) {
- rb_thread_stop();
- }
- if (param->done != 1) {
- /*
- * Note that we do not delete the event handler because it
- * was deleted automatically when the window was destroyed.
- */
-
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "window \"", nameString,
- "\" was deleted before its visibility changed",
- (char *) NULL);
- return TCL_ERROR;
- }
- Tk_DeleteEventHandler(window,
- VisibilityChangeMask|StructureNotifyMask,
- rb_threadWaitVisibilityProc, (ClientData) param);
- break;
- }
-
- case TKWAIT_WINDOW: {
- Tk_Window window;
-
- window = Tk_NameToWindow(interp, nameString, tkwin);
- if (window == NULL) {
- return TCL_ERROR;
- }
- Tk_CreateEventHandler(window, StructureNotifyMask,
- rb_threadWaitWindowProc, (ClientData) param);
- if (!param->done) {
- rb_thread_stop();
- }
- /*
- * Note: there's no need to delete the event handler. It was
- * deleted automatically when the window was destroyed.
- */
- break;
- }
- }
-
- Tcl_Free((char *)param);
-
- /*
- * Clear out the interpreter's result, since it may have been set
- * by event handlers.
- */
-
- Tcl_ResetResult(interp);
- return TCL_OK;
-}
-
-static VALUE
-ip_thread_vwait(self, var)
- VALUE self;
- VALUE var;
-{
- VALUE argv[2];
-
- argv[0] = rb_str_new2("thread_vwait");
- 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];
-
- argv[0] = rb_str_new2("thread_tkwait");
- argv[1] = mode;
- argv[2] = target;
- return ip_invoke_real(3, argv, self);
-}
-
-
-/* destroy interpreter */
-static void
-ip_free(ptr)
- struct tcltkip *ptr;
-{
- DUMP1("Tcl_DeleteInterp");
- if (ptr) {
- Tcl_Release((ClientData)ptr->ip);
- Tcl_DeleteInterp(ptr->ip);
- free(ptr);
- }
-}
-
-/* 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;
-
- /* create object */
- Data_Get_Struct(self, struct tcltkip, ptr);
- ptr = ALLOC(struct tcltkip);
- DATA_PTR(self) = ptr;
- ptr->return_value = 0;
-
- /* from Tk_Main() */
- DUMP1("Tcl_CreateInterp");
- ptr->ip = Tcl_CreateInterp();
- Tcl_Preserve((ClientData)ptr->ip);
- current_interp = ptr->ip;
-
- /* from Tcl_AppInit() */
- DUMP1("Tcl_Init");
- if (Tcl_Init(ptr->ip) == TCL_ERROR) {
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
- }
-
- /* set variables */
- cnt = rb_scan_args(argc, argv, "02", &argv0, &opts);
- switch(cnt) {
- case 2:
- /* options */
- if (opts == Qnil || opts == Qfalse) {
- /* without Tk */
- with_tk = 0;
- } else {
- Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), 0);
- }
- case 1:
- /* argv0 */
- if (argv0 != Qnil) {
- Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0);
- }
- case 0:
- /* no args */
- ;
- }
-
- /* from Tcl_AppInit() */
- if (with_tk) {
- DUMP1("Tk_Init");
- if (Tk_Init(ptr->ip) == TCL_ERROR) {
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
- }
- DUMP1("Tcl_StaticPackage(\"Tk\")");
-#if TCL_MAJOR_VERSION >= 8
- Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, Tk_SafeInit);
-#else
- Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init,
- (Tcl_PackageInitProc *) NULL);
-#endif
- }
-
- /* add ruby command to the interpreter */
-#if TCL_MAJOR_VERSION >= 8
- DUMP1("Tcl_CreateObjCommand(\"ruby\")");
- Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby, (ClientData)NULL,
- (Tcl_CmdDeleteProc *)NULL);
-#else
- DUMP1("Tcl_CreateCommand(\"ruby\")");
- Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby, (ClientData)NULL,
- (Tcl_CmdDeleteProc *)NULL);
-#endif
-
- /* replace 'vwait' command */
-#if TCL_MAJOR_VERSION >= 8
- DUMP1("Tcl_CreateObjCommand(\"vwait\")");
- Tcl_CreateObjCommand(ptr->ip, "vwait", ip_rbVwaitObjCmd,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-#else
- DUMP1("Tcl_CreateCommand(\"vwait\")");
- Tcl_CreateCommand(ptr->ip, "vwait", ip_rbVwaitCommand,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-#endif
-
- /* replace 'tkwait' command */
-#if TCL_MAJOR_VERSION >= 8
- DUMP1("Tcl_CreateObjCommand(\"tkwait\")");
- Tcl_CreateObjCommand(ptr->ip, "tkwait", ip_rbTkWaitObjCmd,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-#else
- DUMP1("Tcl_CreateCommand(\"tkwait\")");
- Tcl_CreateCommand(ptr->ip, "tkwait", ip_rbTkWaitCommand,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-#endif
-
- /* add 'thread_vwait' command */
-#if TCL_MAJOR_VERSION >= 8
- DUMP1("Tcl_CreateObjCommand(\"thread_vwait\")");
- Tcl_CreateObjCommand(ptr->ip, "thread_vwait", ip_rb_threadVwaitObjCmd,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-#else
- DUMP1("Tcl_CreateCommand(\"thread_vwait\")");
- Tcl_CreateCommand(ptr->ip, "thread_vwait", ip_rb_threadVwaitCommand,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-#endif
-
- /* add 'thread_tkwait' command */
-#if TCL_MAJOR_VERSION >= 8
- DUMP1("Tcl_CreateObjCommand(\"thread_tkwait\")");
- Tcl_CreateObjCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitObjCmd,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-#else
- DUMP1("Tcl_CreateCommand(\"thread_tkwait\")");
- Tcl_CreateCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitCommand,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-#endif
-
- 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 name;
- VALUE safemode;
- int safe;
-
- /* 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 || safemode == Qnil) {
- safe = 0;
- rb_secure(4);
- } else {
- safe = 1;
- }
-
- /* create slave-ip */
- if ((slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe))
- == NULL) {
- rb_raise(rb_eRuntimeError, "fail to create the new slave interpreter");
- }
- Tcl_Preserve((ClientData)slave->ip);
- slave->return_value = 0;
-
- 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);
-
- if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) {
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
- }
-
- return self;
-}
-
-/* is safe? */
-static VALUE
-ip_is_safe_p(self)
- VALUE self;
-{
- struct tcltkip *ptr = get_ip(self);
-
- if (Tcl_IsSafe(ptr->ip)) {
- return Qtrue;
- } else {
- return Qfalse;
- }
-}
-
-/* delete interpreter */
-static VALUE
-ip_delete(self)
- VALUE self;
-{
- struct tcltkip *ptr = get_ip(self);
-
- Tcl_DeleteInterp(ptr->ip);
-
- return Qnil;
-}
-
-/* is deleted? */
-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;
- }
-}
-
-
-/* eval string in tcl by Tcl_Eval() */
-static VALUE
-ip_eval_real(self, str)
- VALUE self;
- VALUE str;
-{
- char *s;
- char *buf; /* Tcl_Eval requires re-writable string region */
- struct tcltkip *ptr = get_ip(self);
-
- /* call Tcl_Eval() */
- s = StringValuePtr(str);
- buf = ALLOCA_N(char, strlen(s)+1);
- strcpy(buf, s);
- DUMP2("Tcl_Eval(%s)", buf);
- ptr->return_value = Tcl_Eval(ptr->ip, buf);
- if (ptr->return_value == TCL_ERROR) {
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
- }
- DUMP2("(TCL_Eval result) %d", ptr->return_value);
-
- /* pass back the result (as string) */
- /* return(rb_str_new2(ptr->ip->result)); */
- return(rb_tainted_str_new2(ptr->ip->result));
-}
-
-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->obj, q->str);
-}
-
-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;
-
- DUMP2("do_eval_queue_handler : evPtr = %lx", 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) {
- *(q->result)
- = rb_funcall(rb_proc_new(evq_safelevel_handler,
- Data_Wrap_Struct(rb_cData,0,0,q)),
- rb_intern("call"), 0);
- } else {
- DUMP2("call eval_real (for caller thread:%lx)", q->thread);
- DUMP2("call eval_real (current thread:%lx)", rb_thread_current());
- *(q->result) = ip_eval_real(q->obj, q->str);
- }
-
- /* 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 *tmp;
- VALUE current = rb_thread_current();
- VALUE result;
- VALUE *alloc_result;
- Tcl_QueuePosition position;
-
- if (eventloop_thread == 0 || current == eventloop_thread) {
- if (eventloop_thread) {
- DUMP2("eval from current eventloop %lx", current);
- } else {
- DUMP2("eval from thread:%lx but no eventloop", current);
- }
- result = ip_eval_real(self, str);
- if (rb_obj_is_kind_of(result, rb_eException)) {
- rb_exc_raise(result);
- }
- return result;
- }
-
- DUMP2("eval from thread %lx (NOT current eventloop)", current);
-
- /* allocate memory (protected from Tcl_ServiceEvent) */
- alloc_result = ALLOC(VALUE);
-
- /* allocate memory (freed by Tcl_ServiceEvent) */
- tmp = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue));
-
- /* construct event data */
- tmp->done = 0;
- tmp->obj = self;
- tmp->str = str;
- tmp->result = alloc_result;
- tmp->thread = current;
- tmp->safe_level = rb_safe_level();
- tmp->ev.proc = eval_queue_handler;
- position = TCL_QUEUE_TAIL;
-
- /* add the handler to Tcl event queue */
- DUMP1("add handler");
- Tcl_QueueEvent(&(tmp->ev), position);
-
- /* wait for the handler to be processed */
- DUMP2("wait for handler (current thread:%lx)", current);
- rb_thread_stop();
- DUMP2("back from handler (current thread:%lx)", current);
-
- /* get result & free allocated memory */
- result = *alloc_result;
- free(alloc_result);
- if (rb_obj_is_kind_of(result, rb_eException)) {
- rb_exc_raise(result);
- }
-
- return result;
-}
-
-
-/* restart Tk */
-static VALUE
-lib_restart(self)
- VALUE self;
-{
- struct tcltkip *ptr = get_ip(self);
-
- rb_secure(4);
-
- /* destroy the root wdiget */
- /* ptr->return_value = Tcl_Eval(ptr->ip, "destroy ."); */
- ptr->return_value = FIX2INT(ip_eval(self, "destroy ."));
- /* 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) {
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
- }
- } else {
- DUMP1("Tk_Init");
- if (Tk_Init(ptr->ip) == TCL_ERROR) {
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
- }
- }
-#else
- DUMP1("Tk_Init");
- if (Tk_Init(ptr->ip) == TCL_ERROR) {
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
- }
-#endif
-
- return Qnil;
-}
-
-
-static VALUE
-ip_restart(self)
- VALUE self;
-{
- struct tcltkip *ptr = get_ip(self);
-
- rb_secure(4);
- if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
- /* slave IP */
- return Qnil;
- }
- return lib_restart(self);
-}
-
-static VALUE
-ip_toUTF8(self, str, encodename)
- VALUE self;
- VALUE str;
- VALUE encodename;
-{
-#ifdef TCL_UTF_MAX
- Tcl_Interp *interp;
- Tcl_Encoding encoding;
- Tcl_DString dstr;
- struct tcltkip *ptr;
- char *buf;
-
- ptr = get_ip(self);
- interp = ptr->ip;
-
- StringValue(encodename);
- StringValue(str);
- encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr);
- if (!RSTRING(str)->len) return str;
- buf = ALLOCA_N(char,strlen(RSTRING(str)->ptr)+1);
- strcpy(buf, RSTRING(str)->ptr);
-
- Tcl_DStringInit(&dstr);
- Tcl_DStringFree(&dstr);
- Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr);
- /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */
- str = rb_tainted_str_new2(Tcl_DStringValue(&dstr));
-
- Tcl_FreeEncoding(encoding);
- Tcl_DStringFree(&dstr);
-#endif
- return str;
-}
-
-static VALUE
-ip_fromUTF8(self, str, encodename)
- VALUE self;
- VALUE str;
- VALUE encodename;
-{
-#ifdef TCL_UTF_MAX
- Tcl_Interp *interp;
- Tcl_Encoding encoding;
- Tcl_DString dstr;
- struct tcltkip *ptr;
- char *buf;
-
- ptr = get_ip(self);
- interp = ptr->ip;
-
- StringValue(encodename);
- StringValue(str);
- encoding = Tcl_GetEncoding(interp,RSTRING(encodename)->ptr);
- if (!RSTRING(str)->len) return str;
- buf = ALLOCA_N(char,strlen(RSTRING(str)->ptr)+1);
- strcpy(buf,RSTRING(str)->ptr);
-
- Tcl_DStringInit(&dstr);
- Tcl_DStringFree(&dstr);
- Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr);
- /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */
- str = rb_tainted_str_new2(Tcl_DStringValue(&dstr));
-
- Tcl_FreeEncoding(encoding);
- Tcl_DStringFree(&dstr);
-
-#endif
- return str;
-}
-
-
-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_iv_set(einfo, "interp", interp);
- Tcl_ResetResult(get_ip(interp)->ip);
- return einfo;
-}
-
-
-static VALUE
-ip_invoke_real(argc, argv, obj)
- int argc;
- VALUE *argv;
- VALUE obj;
-{
- VALUE v;
- struct tcltkip *ptr; /* tcltkip data struct */
- int i;
- Tcl_CmdInfo info;
- char *cmd, *s;
- char **av = (char **)NULL;
-#if TCL_MAJOR_VERSION >= 8
- Tcl_Obj **ov = (Tcl_Obj **)NULL;
- Tcl_Obj *resultPtr;
-#endif
-
- DUMP2("invoke_real called by thread:%lx", rb_thread_current());
- /* get the command name string */
- v = argv[0];
- cmd = StringValuePtr(v);
-
- /* get the data struct */
- ptr = get_ip(obj);
-
- /* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
- 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(obj, 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");
-
- /* memory allocation for arguments of this command */
-#if TCL_MAJOR_VERSION >= 8
- if (info.isNativeObjectProc) {
- /* object interface */
- ov = (Tcl_Obj **)ALLOCA_N(Tcl_Obj *, argc+1);
- for (i = 0; i < argc; ++i) {
- v = argv[i];
- s = StringValuePtr(v);
- ov[i] = Tcl_NewStringObj(s, RSTRING(v)->len);
- Tcl_IncrRefCount(ov[i]);
- }
- ov[argc] = (Tcl_Obj *)NULL;
- }
- else
-#endif
- {
- /* string interface */
- av = (char **)ALLOCA_N(char *, argc+1);
- for (i = 0; i < argc; ++i) {
- v = argv[i];
- s = StringValuePtr(v);
- av[i] = ALLOCA_N(char, strlen(s)+1);
- strcpy(av[i], s);
- }
- av[argc] = (char *)NULL;
- }
-
- Tcl_ResetResult(ptr->ip);
-
- /* Invoke the C procedure */
-#if TCL_MAJOR_VERSION >= 8
- if (info.isNativeObjectProc) {
- int dummy;
- ptr->return_value = (*info.objProc)(info.objClientData,
- ptr->ip, argc, ov);
-
- /* get the string value from the result object */
- resultPtr = Tcl_GetObjResult(ptr->ip);
- Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &dummy),
- TCL_VOLATILE);
-
- for (i=0; i<argc; i++) {
- Tcl_DecrRefCount(ov[i]);
- }
- }
- else
-#endif
- {
- TRAP_BEG;
-#if TCL_MAJOR_VERSION >= 8
- ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
- argc, (CONST84 char **)av);
-#else /* TCL_MAJOR_VERSION < 8 */
- ptr->return_value = (*info.proc)(info.clientData, ptr->ip, argc, av);
-#endif
- TRAP_END;
- }
-
- /* exception on mainloop */
- if (ptr->return_value == TCL_ERROR) {
- if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
- /*rb_ip_raise(obj, rb_eRuntimeError, "%s", ptr->ip->result);*/
- return create_ip_exc(obj, rb_eRuntimeError, "%s", ptr->ip->result);
- } else {
- if (event_loop_abort_on_exc < 0) {
- rb_warning("%s (ignore)", ptr->ip->result);
- } else {
- rb_warn("%s (ignore)", ptr->ip->result);
- }
- Tcl_ResetResult(ptr->ip);
- return rb_tainted_str_new2("");
- }
- }
-
- /* pass back the result (as string) */
- /* return rb_str_new2(ptr->ip->result); */
- return rb_tainted_str_new2(ptr->ip->result);
-}
-
-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_real(q->argc, q->argv, q->obj);
-}
-
-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;
-
- DUMP2("do_invoke_queue_handler : evPtr = %lx", 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->result)
- = rb_funcall(rb_proc_new(ivq_safelevel_handler,
- Data_Wrap_Struct(rb_cData,0,0,q)),
- rb_intern("call"), 0);
- } else {
- DUMP2("call invoke_real (for caller thread:%lx)", q->thread);
- DUMP2("call invoke_real (current thread:%lx)", rb_thread_current());
- *(q->result) = ip_invoke_real(q->argc, q->argv, q->obj);
- }
-
- /* 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(argc, argv, obj)
- int argc;
- VALUE *argv;
- VALUE obj;
-{
- struct invoke_queue *tmp;
- VALUE current = rb_thread_current();
- VALUE result;
- VALUE *alloc_argv, *alloc_result;
- Tcl_QueuePosition position;
-
- 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, 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);
-
- /* allocate memory (protected from Tcl_ServiceEvent) */
- alloc_argv = ALLOC_N(VALUE,argc);
- MEMCPY(alloc_argv, argv, VALUE, argc);
- alloc_result = ALLOC(VALUE);
-
- /* allocate memory (freed by Tcl_ServiceEvent) */
- tmp = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue));
-
- /* construct event data */
- tmp->done = 0;
- tmp->obj = obj;
- tmp->argc = argc;
- tmp->argv = alloc_argv;
- tmp->result = alloc_result;
- tmp->thread = current;
- tmp->safe_level = rb_safe_level();
- tmp->ev.proc = invoke_queue_handler;
- position = TCL_QUEUE_TAIL;
-
- /* add the handler to Tcl event queue */
- DUMP1("add handler");
- Tcl_QueueEvent(&(tmp->ev), position);
-
- /* wait for the handler to be processed */
- DUMP2("wait for handler (current thread:%lx)", current);
- rb_thread_stop();
- DUMP2("back from handler (current thread:%lx)", current);
-
- /* get result & free allocated memory */
- result = *alloc_result;
- free(alloc_argv);
- free(alloc_result);
- if (rb_obj_is_kind_of(result, rb_eException)) {
- rb_exc_raise(result);
- }
-
- return result;
-}
-
-/* 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);
-
- return (INT2FIX(ptr->return_value));
-}
-
-#ifdef __MACOS__
-static void
-_macinit()
-{
- tcl_macQdPtr = &qd; /* setup QuickDraw globals */
- Tcl_MacSetEventProc(TkMacConvertEvent); /* setup event handler */
-}
-#endif
-
-/*---- initialization ----*/
-void
-Init_tcltklib()
-{
- VALUE lib = rb_define_module("TclTkLib");
- VALUE ip = rb_define_class("TclTkIp", rb_cObject);
-
- VALUE ev_flag = rb_define_module_under(lib, "EventFlag");
-
-#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_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));
-
- eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError);
- eTkCallbackContinue = rb_define_class("TkCallbackContinue",
- rb_eStandardError);
-
- 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, "get_eventloop_weight",
- get_eventloop_weight, 0);
- rb_define_module_function(lib, "num_of_mainwindows",
- lib_num_of_mainwindows, 0);
-
- 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, "delete", ip_delete, 0);
- rb_define_method(ip, "deleted?", ip_is_deleted_p, 0);
- rb_define_method(ip, "_eval", ip_eval, 1);
- rb_define_method(ip, "_toUTF8",ip_toUTF8, 2);
- rb_define_method(ip, "_fromUTF8",ip_fromUTF8, 2);
- rb_define_method(ip, "_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, "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, "restart", ip_restart, 0);
-
- eventloop_thread = 0;
- watchdog_thread = 0;
-
-#ifdef __MACOS__
- _macinit();
-#endif
-
- /*---- initialize tcl/tk libraries ----*/
- /* from Tk_Main() */
- DUMP1("Tcl_FindExecutable");
- Tcl_FindExecutable(RSTRING(rb_argv0)->ptr);
-}
-
-/* eof */
generated by cgit v1.2.3 (git 2.25.1) at 2026-06-03 16:31:17 +0000