summaryrefslogtreecommitdiff
path: root/ext/tcltklib
diff options
context:
space:
mode:
authormatz <matz@b2dd03c8-39d4-4d8f-98ff-823fe69b080e>1999-01-20 04:59:39 +0000
committermatz <matz@b2dd03c8-39d4-4d8f-98ff-823fe69b080e>1999-01-20 04:59:39 +0000
commit62e648e148b3cb9f96dcce808c55c02b7ccb4486 (patch)
tree9708892ece92e860d81559ab55e6b1f9400d7ffc /ext/tcltklib
parentaeb049c573be4dc24dd20650f40e4777e0f698cf (diff)
ruby 1.3 cycle
git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/branches/RUBY@372 b2dd03c8-39d4-4d8f-98ff-823fe69b080e
Diffstat (limited to 'ext/tcltklib')
-rw-r--r--ext/tcltklib/extconf.rb114
-rw-r--r--ext/tcltklib/lib/tcltk.rb287
-rw-r--r--ext/tcltklib/tcltklib.c293
3 files changed, 452 insertions, 242 deletions
diff --git a/ext/tcltklib/extconf.rb b/ext/tcltklib/extconf.rb
index 26e7fe7b092..e34e549ca0c 100644
--- a/ext/tcltklib/extconf.rb
+++ b/ext/tcltklib/extconf.rb
@@ -1,19 +1,27 @@
# extconf.rb for tcltklib
+require 'mkmf'
+
+have_library("nsl", "t_open")
have_library("socket", "socket")
-have_library("nsl", "gethostbyname")
+have_library("dl", "dlopen")
+have_library("m", "log")
-def search_file(var, include, *path)
+$includes = []
+def search_header(include, *path)
pwd = Dir.getwd
begin
- for i in path.reverse!
+ for i in path.sort!.reverse!
dir = Dir[i]
- for path in dir
+ for path in dir.sort!.reverse!
+ next unless File.directory? path
Dir.chdir path
files = Dir[include]
if files.size > 0
- var << path
- return files.pop
+ unless $includes.include? path
+ $includes << path
+ end
+ return
end
end
end
@@ -22,58 +30,56 @@ def search_file(var, include, *path)
end
end
-$includes = []
-search_file($includes,
- "tcl.h",
- "/usr/include/tcl*",
- "/usr/include",
- "/usr/local/include/tcl*",
- "/usr/local/include")
-search_file($includes,
- "tk.h",
- "/usr/include/tk*",
- "/usr/include",
- "/usr/local/include/tk*",
- "/usr/local/include")
-search_file($includes,
- "X11/Xlib.h",
- "/usr/include",
- "/usr/X11*/include",
- "/usr/include",
- "/usr/X11*/include")
+search_header("tcl.h",
+ "/usr/include/tcl{,8*,7*}",
+ "/usr/include",
+ "/usr/local/include/tcl{,8*,7*}",
+ "/usr/local/include")
+search_header("tk.h",
+ "/usr/include/tk{,8*,4*}",
+ "/usr/include",
+ "/usr/local/include/tk{,8*,4*}",
+ "/usr/local/include")
+search_header("X11/Xlib.h",
+ "/usr/include/X11*",
+ "/usr/include",
+ "/usr/openwin/include",
+ "/usr/X11*/include")
-$CFLAGS = "-Wall " + $includes.collect{|path| "-I" + path}.join(" ")
+$CFLAGS = $includes.collect{|path| "-I" + path}.join(" ")
$libraries = []
-tcllibfile = search_file($libraries,
- "libtcl{,7*,8*}.{a,so}",
- "/usr/lib",
- "/usr/local/lib")
-if tcllibfile
- tcllibfile.sub!(/^lib/, '')
- tcllibfile.sub!(/\.(a|so)$/, '')
-end
-tklibfile = search_file($libraries,
- "libtk{,4*,8*}.{a,so}",
- "/usr/lib",
- "/usr/local/lib")
-if tklibfile
- tklibfile.sub!(/^lib/, '')
- tklibfile.sub!(/\.(a|so)$/, '')
+def search_lib(file, func, *path)
+ for i in path.reverse!
+ dir = Dir[i]
+ for path in dir.sort!.reverse!
+ $LDFLAGS = $libraries.collect{|p| "-L" + p}.join(" ") + " -L" + path
+ files = Dir[path+"/"+file]
+ if files.size > 0
+ for lib in files.sort!.reverse!
+ lib = File::basename(lib)
+ lib.sub!(/^lib/, '')
+ lib.sub!(/\.(a|so)$/, '')
+ if have_library(lib, func)
+ unless $libraries.include? path
+ $libraries << path
+ end
+ return true
+ end
+ end
+ end
+ end
+ end
+ return false;
end
-search_file($libraries,
- "libX11.{a,so}",
- "/usr/lib",
- "/usr/X11*/lib")
-$LDFLAGS = $libraries.collect{|path| "-L" + path}.join(" ")
-
-have_library("dl", "dlopen")
-if have_header("tcl.h") &&
- have_header("tk.h") &&
- have_library("X11", "XOpenDisplay") &&
- have_library("m", "log") &&
- have_library(tcllibfile, "Tcl_FindExecutable") &&
- have_library(tklibfile, "Tk_Init")
+if have_header("tcl.h") && have_header("tk.h") &&
+ search_lib("libX11.{so,a}", "XOpenDisplay",
+ "/usr/lib", "/usr/openwin/lib", "/usr/X11*/lib") &&
+ search_lib("libtcl{8*,7*,}.{so,a}", "Tcl_FindExecutable",
+ "/usr/lib", "/usr/local/lib") &&
+ search_lib("libtk{8*,4*,}.{so,a}", "Tk_Init",
+ "/usr/lib", "/usr/local/lib")
+ $LDFLAGS = $libraries.collect{|path| "-L" + path}.join(" ")
create_makefile("tcltklib")
end
diff --git a/ext/tcltklib/lib/tcltk.rb b/ext/tcltklib/lib/tcltk.rb
index 81d01f930df..54a00e8f3c3 100644
--- a/ext/tcltklib/lib/tcltk.rb
+++ b/ext/tcltklib/lib/tcltk.rb
@@ -1,48 +1,44 @@
# tof
-#### tcltk ライブラリ
+#### tcltk library, more direct manipulation of tcl/tk
#### Sep. 5, 1997 Y. Shigehiro
require "tcltklib"
################
-# module TclTk: tcl/tk のライブラリ全体で必要になるものを集めたもの
-# (主に, 名前空間の点から module にする使う.)
+# module TclTk: collection of tcl/tk utilities (supplies namespace.)
module TclTk
- # 単にここに書けば最初に 1 度実行されるのか??
-
- # 生成した一意な名前を保持しておく連想配列を初期化する.
+ # initialize Hash to hold unique symbols and such
@namecnt = {}
- # コールバックを保持しておく連想配列を初期化する.
+ # initialize Hash to hold callbacks
@callback = {}
end
-# TclTk.mainloop(): TclTkLib.mainloop() を呼ぶ.
+# 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): コールバックを TclTk module から取り除く.
-# tcl/tk インタプリタにおいてコールバックが取り消されるわけではない.
-# これをしないと, 最後に TclTkInterpreter が GC できない.
-# (GC したくなければ, 別に, これをしなくても良い.)
-# ca: コールバック(TclTkCallback)
+# 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): 配列に入っている複数のコールバックに対して
-# TclTk.deletecallbackkey() を呼ぶ.
-# トップレベルの <Destroy> イベントのコールバックとして呼ぶためのもの.
-# ca: コールバック(TclTkCallback) の Array
-# wid: トップレベルのウィジェット(TclTkWidget)
-# w: コールバックに %W で与えられる, ウインドウに関するパラメータ(String)
+# 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|
@@ -51,33 +47,33 @@ def TclTk.dcb(ca, wid, w)
end
end
-# TclTk._addcallback(ca): コールバックを登録する.
-# ca: コールバック(TclTkCallback)
+# 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): 登録したコールバックを呼び出す.
-# key: コールバックを選択するキー (TclTkCallback が to_s() で返す値)
-# arg: tcl/tk インタプリタからのパラメータ
+# 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)
- # コールバックからの返り値はどうせ捨てられる.
- # String を返さないと, rb_eval_string() がエラーになる.
+ # throw out callback value
+ # should return String to satisfy rb_eval_string()
return ""
end
-# TclTk._newname(prefix): 一意な名前(String)を生成して返す.
-# prefix: 名前の接頭語
+# TclTk._newname(prefix): generate unique name(String)
+# prefix: prefix of the unique name
def TclTk._newname(prefix)
- # 生成した名前のカウンタは @namecnt に入っているので, 調べる.
+ # 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]}"
@@ -85,51 +81,48 @@ end
################
-# class TclTkInterpreter: tcl/tk のインタプリタ
+# class TclTkInterpreter: tcl/tk interpreter
class TclTkInterpreter
- # initialize(): 初期化.
+ # initialize():
def initialize()
- # インタプリタを生成する.
+ # generate interpreter object
@ip = TclTkIp.new()
- # インタプリタに ruby_fmt コマンドを追加する.
- # ruby_fmt コマンドとは, 後ろの引数を format コマンドで処理して
- # ruby コマンドに渡すものである.
- # (なお, ruby コマンドは, 引数を 1 つしかとれない.)
+ # 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\" ; ruby [format $fmt $args] }")
else
@ip._eval("proc ruby_fmt {fmt args} { ruby [format $fmt $args] }")
end
- # @ip._get_eval_string(*args): tcl/tk インタプリタで評価する
- # 文字列(String)を生成して返す.
- # *args: tcl/tk で評価するスクリプト(に対応するオブジェクト列)
+ # @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 != ""
- # もし to_eval() メソッドが
+ # call to_eval if it is defined
if (arg.respond_to?(:to_eval))
- # 定義されていればそれを呼ぶ.
argstr += arg.to_eval()
else
- # 定義されていなければ to_s() を呼ぶ.
+ # call to_s unless defined
argstr += arg.to_s()
end
}
return argstr
end
- # @ip._eval_args(*args): tcl/tk インタプリタで評価し,
- # その結果(String)を返す.
- # *args: tcl/tk で評価するスクリプト(に対応するオブジェクト列)
+ # @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
@@ -137,219 +130,205 @@ class TclTkInterpreter
elsif _return_value() != 0
print(res, "\n")
end
- fail(%Q/can't eval "#{argstr}"/) if _return_value() != 0
+ fail(%Q/can't eval "#{argstr}"/) if _return_value() != 0 #'
return res
end
- # tcl/tk のコマンドに対応するオブジェクトを生成し, 連想配列に入れておく.
+ # generate tcl/tk command object and register in the hash
@commands = {}
- # tcl/tk インタプリタに登録されているすべてのコマンドに対して,
+ # for all commands registered in tcl/tk interpreter:
@ip._eval("info command").split(/ /).each{|comname|
if comname =~ /^[.]/
- # コマンドがウィジェット(のパス名)の場合は
- # TclTkWidget のインスタンスを作って連想配列に入れる.
+ # if command is a widget (path), generate TclTkWidget,
+ # and register it in the hash
@commands[comname] = TclTkWidget.new(@ip, comname)
else
- # そうでない場合は
- # TclTkCommand のインスタンスを作って連想配列に入れる.
+ # otherwise, generate TclTkCommand
@commands[comname] = TclTkCommand.new(@ip, comname)
end
}
end
- # commands(): tcl/tk のコマンドに対応するオブジェクトを Hash に
- # 入れたものを返す.
+ # commands(): returns hash of the tcl/tk commands
def commands()
return @commands
end
- # rootwidget(): ルートウィジェット(TclTkWidget)を返す.
+ # rootwidget(): returns root widget(TclTkWidget)
def rootwidget()
return @commands["."]
end
- # _tcltkip(): @ip(TclTkIp) を返す.
+ # _tcltkip(): returns @ip(TclTkIp)
def _tcltkip()
return @ip
end
- # method_missing(id, *args): 未定義のメソッドは tcl/tk のコマンドとみなして
- # 実行し, その結果(String)を返す.
- # id: メソッドのシンボル
- # *args: コマンドの引数
+ # method_missing(id, *args): execute undefined method as tcl/tk command
+ # id: method symbol
+ # *args: method arguments
def method_missing(id, *args)
- # もし, メソッドの tcl/tk コマンドが
+ # 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: tcl/tk のオブジェクト
-# (基底クラスとして使う.
-# tcltk ライブラリを使う人が TclTkObject.new() することはないはず.)
+# class TclTkObject: base class of the tcl/tk objects
class TclTkObject
- # initialize(ip, exp): 初期化.
- # ip: インタプリタ(TclTkIp)
- # exp: tcl/tk での表現形
+ # 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(): tcl/tk での表現形(String)を返す.
+ # to_s(): returns tcl/tk representation
def to_s()
return @exp
end
end
-# class TclTkCommand: tcl/tk のコマンド
-# (tcltk ライブラリを使う人が TclTkCommand.new() することはないはず.
-# TclTkInterpreter:initialize() から new() される.)
+# class TclTkCommand: tcl/tk commands
+# you should not call TclTkCommand.new()
+# commands are created by TclTkInterpreter:initialize()
class TclTkCommand < TclTkObject
- # e(*args): コマンドを実行し, その結果(String)を返す.
- # (e は exec または eval の e.)
- # *args: コマンドの引数
+ # 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 のコマンド
-# (ライブラリにより実現されるコマンドで, tcl/tk インタプリタに最初から
-# 存在しないものは, インタプリタの commands() では生成できない.
-# そのようなものに対し, コマンドの名前から TclTkCommand オブジェクトを
-# 生成する.
+# class TclTkLibCommand: tcl/tk commands in the library
class TclTkLibCommand < TclTkCommand
- # initialize(ip, name): 初期化
- # ip: インタプリタ(TclTkInterpreter)
- # name: コマンド名 (String)
+ # initialize(ip, name):
+ # ip: interpreter(TclTkInterpreter)
+ # name: command name (String)
def initialize(ip, name)
super(ip._tcltkip, name)
end
end
-# class TclTkVariable: tcl/tk の変数
+# class TclTkVariable: tcl/tk variable
class TclTkVariable < TclTkObject
- # initialize(interp, dat): 初期化.
- # interp: インタプリタ(TclTkInterpreter)
- # dat: 設定する値(String)
- # nil なら, 設定しない.
+ # initialize(interp, dat):
+ # interp: interpreter(TclTkInterpreter)
+ # dat: the value to set(String)
+ # if nil, not initialize variable
def initialize(interp, dat)
- # tcl/tk での表現形(変数名)を自動生成する.
+ # auto-generate tcl/tk representation (variable name)
exp = TclTk._newname("v_")
- # TclTkObject を初期化する.
+ # initialize TclTkObject
super(interp._tcltkip(), exp)
- # set コマンドを使うのでとっておく.
+ # safe this for `set' command
@set = interp.commands()["set"]
- # 値を設定する.
+ # set value
set(dat) if dat
end
- # tcl/tk の set を使えば, 値の設定/参照はできるが,
- # それだけではなんなので, 一応, メソッドをかぶせたものも用意しておく.
+ # although you can set/refer variable by using set in tcl/tk,
+ # we provide the method for accessing variables
- # set(data): tcl/tk の変数に set を用いて値を設定する.
- # data: 設定する値
+ # set(data): set tcl/tk variable using `set'
+ # data: new value
def set(data)
@set.e(to_s(), data.to_s())
end
- # get(): tcl/tk の変数の値(String)を set を用いて読みだし返す.
+ # get(): read tcl/tk variable(String) using `set'
def get()
return @set.e(to_s())
end
end
-# class TclTkWidget: tcl/tk のウィジェット
+# class TclTkWidget: tcl/tk widget
class TclTkWidget < TclTkCommand
- # initialize(*args): 初期化.
- # *args: パラメータ
+ # initialize(*args):
+ # *args: parameters
def initialize(*args)
if args[0].kind_of?(TclTkIp)
- # 最初の引数が TclTkIp の場合:
+ # in case the 1st argument is TclTkIp:
- # 既に tcl/tk に定義されているウィジェットに TclTkWidget の構造を
- # かぶせる. (TclTkInterpreter:initialize() から使われる.)
+ # Wrap tcl/tk widget by TclTkWidget
+ # (used in TclTkInterpreter#initialize())
- # パラメータ数が 2 でなければエラー.
+ # need two arguments
fail("illegal # of parameter") if args.size != 2
- # ip: インタプリタ(TclTkIp)
- # exp: tcl/tk での表現形
+ # ip: interpreter(TclTkIp)
+ # exp: tcl/tk representation
ip, exp = args
- # TclTkObject を初期化する.
+ # initialize TclTkObject
super(ip, exp)
elsif args[0].kind_of?(TclTkInterpreter)
- # 最初の引数が TclTkInterpreter の場合:
+ # in case 1st parameter is TclTkInterpreter:
- # 親ウィジェットから新たなウィジェトを生成する.
+ # generate new widget from parent widget
- # interp: インタプリタ(TclTkInterpreter)
- # parent: 親ウィジェット
- # command: ウィジェットを生成するコマンド(label 等)
- # *args: command に渡す引数
+ # 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_")
- # TclTkObject を初期化する.
+ # initialize TclTkObject
super(interp._tcltkip(), exp)
- # ウィジェットを生成する.
+ # generate widget
res = @ip._eval_args(command, exp, *args)
# fail("can't create Widget") if res != exp
- # tk_optionMenu では, ボタン名を exp で指定すると
- # res にメニュー名を返すので res != exp となる.
+ # for tk_optionMenu, it is legal res != exp
else
fail("first parameter is not TclTkInterpreter")
end
end
end
-# class TclTkCallback: tcl/tk のコールバック
+# class TclTkCallback: tcl/tk callbacks
class TclTkCallback < TclTkObject
- # initialize(interp, pr, arg): 初期化.
- # interp: インタプリタ(TclTkInterpreter)
- # pr: コールバック手続き(Proc)
- # arg: pr のイテレータ変数に渡す文字列
- # tcl/tk の bind コマンドではパラメータを受け取るために % 置換を
- # 用いるが, pr の内部で % を書いてもうまくいかない.
- # arg に文字列を書いておくと, その置換結果を, pr で
- # イテレータ変数を通して受け取ることができる.
- # scrollbar コマンドの -command オプションのように
- # 何も指定しなくてもパラメータが付くコマンドに対しては,
- # arg を指定してはならない.
+ # 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)
- # tcl/tk での表現形(変数名)を自動生成する.
+ # auto-generate tcl/tk representation (variable name)
exp = TclTk._newname("c_")
- # TclTkObject を初期化する.
+ # initialize TclTkObject
super(interp._tcltkip(), exp)
- # パラメータをとっておく.
+ # save parameters
@pr = pr
@arg = arg
- # モジュールに登録しておく.
+ # register in the module
TclTk._addcallback(self)
end
- # to_eval(): @ip._eval_args で評価するときの表現形(String)を返す.
+ # to_eval(): retuens string representation for @ip._eval_args
def to_eval()
if @arg
- # %s は ruby_fmt より前に bind により置換されてしまうので
- # %%s としてある. したがって, これは bind 専用.
+ # 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")}}/
@@ -358,28 +337,28 @@ class TclTkCallback < TclTkObject
return s
end
- # _call(arg): コールバックを呼び出す.
- # arg: コールバックに渡されるパラメータ
+ # _call(arg): invoke callback
+ # arg: callback parameter
def _call(arg)
@pr.call(arg)
end
end
-# class TclTkImage: tcl/tk のイメージ
+# class TclTkImage: tcl/tk images
class TclTkImage < TclTkCommand
- # initialize(interp, t, *args): 初期化.
- # イメージの生成は TclTkImage.new() で行うが,
- # 破壊は image delete で行う. (いまいちだけど仕方が無い.)
- # interp: インタプリタ(TclTkInterpreter)
- # t: イメージのタイプ (photo, bitmap, etc.)
- # *args: コマンドの引数
+ # 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)
- # tcl/tk での表現形(変数名)を自動生成する.
+ # auto-generate tcl/tk representation
exp = TclTk._newname("i_")
- # TclTkObject を初期化する.
+ # 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
diff --git a/ext/tcltklib/tcltklib.c b/ext/tcltklib/tcltklib.c
index e7fe77d2b77..625fe61ccc6 100644
--- a/ext/tcltklib/tcltklib.c
+++ b/ext/tcltklib/tcltklib.c
@@ -5,22 +5,31 @@
*/
#include "ruby.h"
-#include "sig.h"
+#include "rubysig.h"
#include <stdio.h>
#include <string.h>
#include <tcl.h>
#include <tk.h>
-/* for debug */
+#ifdef __MACOS__
+# include <tkMac.h>
+# include <Quickdraw.h>
+#endif
-#define DUMP1(ARG1) if (debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);}
-#define DUMP2(ARG1, ARG2) if (debug) { fprintf(stderr, "tcltklib: ");\
+/* for rb_debug */
+
+#define DUMP1(ARG1) if (rb_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);}
+#define DUMP2(ARG1, ARG2) if (rb_debug) { fprintf(stderr, "tcltklib: ");\
fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); }
/*
#define DUMP1(ARG1)
#define DUMP2(ARG1, ARG2)
*/
+/* for callback break & continue */
+VALUE eTkCallbackBreak;
+VALUE eTkCallbackContinue;
+
/* from tkAppInit.c */
/*
@@ -33,26 +42,52 @@ int *tclDummyMathPtr = (int *) matherr;
/*---- module TclTkLib ----*/
-static VALUE thread_safe = Qnil;
+/* Tk_ThreadTimer */
+typedef struct {
+ Tcl_TimerToken token;
+ int flag;
+} Tk_TimerData;
+
+/* timer callback */
+void _timer_for_tcl (ClientData clientData)
+{
+ Tk_TimerData *timer = (Tk_TimerData*)clientData;
+
+ timer->flag = 0;
+ CHECK_INTS;
+#ifdef USE_THREAD
+ if (!rb_thread_critical) rb_thread_schedule();
+#endif
+
+ timer->token = Tk_CreateTimerHandler(200, _timer_for_tcl,
+ (ClientData)timer);
+ timer->flag = 1;
+}
/* execute Tk_MainLoop */
static VALUE
lib_mainloop(VALUE self)
{
- int old_trapflg;
- int flags = RTEST(thread_safe)?TCL_DONT_WAIT:0;
+ Tk_TimerData *timer;
+
+ timer = (Tk_TimerData *) ckalloc(sizeof(Tk_TimerData));
+ timer->flag = 0;
+ timer->token = Tk_CreateTimerHandler(200, _timer_for_tcl,
+ (ClientData)timer);
+ timer->flag = 1;
DUMP1("start Tk_Mainloop");
while (Tk_GetNumMainWindows() > 0) {
- old_trapflg = trap_immediate;
- trap_immediate = 1;
- Tcl_DoOneEvent(flags);
- trap_immediate = old_trapflg;
- CHECK_INTS;
- flags = (thread_safe == 0 || thread_safe == Qnil)?0:TCL_DONT_WAIT;
+ Tcl_DoOneEvent(0);
}
DUMP1("stop Tk_Mainloop");
+#ifdef USE_THREAD
+ if (timer->flag) {
+ Tk_DeleteTimerHandler(timer->token);
+ }
+#endif
+
return Qnil;
}
@@ -71,27 +106,49 @@ ip_eval_rescue(VALUE *failed, VALUE einfo)
}
static int
+#if TCL_MAJOR_VERSION >= 8
+ip_ruby(ClientData clientData, Tcl_Interp *interp,
+ int argc, Tcl_Obj *CONST argv[])
+#else
ip_ruby(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])
+#endif
{
VALUE res;
int old_trapflg;
VALUE failed = 0;
+ char *arg;
+ int dummy;
/* ruby command has 1 arg. */
if (argc != 2) {
- ArgError("wrong # of arguments (%d for 1)", argc);
+ rb_raise(rb_eArgError, "wrong # of arguments (%d for 1)", argc);
}
+ /* get C string from Tcl object */
+#if TCL_MAJOR_VERSION >= 8
+ arg = Tcl_GetStringFromObj(argv[1], &dummy);
+#else
+ arg = argv[1];
+#endif
+
/* evaluate the argument string by ruby */
- DUMP2("rb_eval_string(%s)", argv[1]);
- old_trapflg = trap_immediate;
- trap_immediate = 0;
- res = rb_rescue(rb_eval_string, argv[1], ip_eval_rescue, &failed);
- trap_immediate = old_trapflg;
+ DUMP2("rb_eval_string(%s)", arg);
+ old_trapflg = rb_trap_immediate;
+ rb_trap_immediate = 0;
+ res = rb_rescue(rb_eval_string, (VALUE)arg, ip_eval_rescue, (VALUE)&failed);
+ rb_trap_immediate = old_trapflg;
+ Tcl_ResetResult(interp);
if (failed) {
- Tcl_AppendResult(interp, RSTRING(failed)->ptr, (char*)NULL);
- return TCL_ERROR;
+ VALUE eclass = CLASS_OF(failed);
+ Tcl_AppendResult(interp, STR2CSTR(failed), (char*)NULL);
+ if (eclass == eTkCallbackBreak) {
+ return TCL_BREAK;
+ } else if (eclass == eTkCallbackContinue) {
+ return TCL_CONTINUE;
+ } else {
+ return TCL_ERROR;
+ }
}
/* result must be string or nil */
@@ -99,12 +156,11 @@ ip_ruby(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])
DUMP1("(rb_eval_string result) nil");
return TCL_OK;
}
- Check_Type(res, T_STRING);
/* copy result to the tcl interpreter */
- DUMP2("(rb_eval_string result) %s", RSTRING(res)->ptr);
+ DUMP2("(rb_eval_string result) %s", STR2CSTR(res));
DUMP1("Tcl_AppendResult");
- Tcl_AppendResult(interp, RSTRING(res)->ptr, (char *)NULL);
+ Tcl_AppendResult(interp, STR2CSTR(res), (char *)NULL);
return TCL_OK;
}
@@ -115,6 +171,7 @@ ip_free(struct tcltkip *ptr)
{
DUMP1("Tcl_DeleteInterp");
Tcl_DeleteInterp(ptr->ip);
+ free(ptr);
}
/* create and initialize interpreter */
@@ -135,20 +192,26 @@ ip_new(VALUE self)
/* from Tcl_AppInit() */
DUMP1("Tcl_Init");
if (Tcl_Init(ptr->ip) == TCL_ERROR) {
- Fail("Tcl_Init");
+ rb_raise(rb_eRuntimeError, "Tcl_Init");
}
DUMP1("Tk_Init");
if (Tk_Init(ptr->ip) == TCL_ERROR) {
- Fail("Tk_Init");
+ rb_raise(rb_eRuntimeError, "Tk_Init");
}
DUMP1("Tcl_StaticPackage(\"Tk\")");
Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init,
(Tcl_PackageInitProc *) NULL);
/* 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
return obj;
}
@@ -157,6 +220,7 @@ ip_new(VALUE self)
static VALUE
ip_eval(VALUE self, VALUE str)
{
+ char *s;
char *buf; /* Tcl_Eval requires re-writable string region */
struct tcltkip *ptr; /* tcltkip data struct */
@@ -164,18 +228,162 @@ ip_eval(VALUE self, VALUE str)
Data_Get_Struct(self, struct tcltkip, ptr);
/* call Tcl_Eval() */
- Check_Type(str, T_STRING);
- buf = ALLOCA_N(char,RSTRING(str)->len+1);
- strcpy(buf, RSTRING(str)->ptr);
+ s = STR2CSTR(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) {
- Fail(ptr->ip->result);
+ rb_raise(rb_eRuntimeError, ptr->ip->result);
}
DUMP2("(TCL_Eval result) %d", ptr->return_value);
/* pass back the result (as string) */
- return(str_new2(ptr->ip->result));
+ return(rb_str_new2(ptr->ip->result));
+}
+
+
+static VALUE
+ip_toUTF8(VALUE self, VALUE str, VALUE encodename)
+{
+#ifndef TCL_UTF_MAX
+ return str;
+#else
+ Tcl_Interp *interp;
+ Tcl_Encoding encoding;
+ Tcl_DString dstr;
+ struct tcltkip *ptr;
+ char *buff1,*buff2;
+
+ Data_Get_Struct(self,struct tcltkip, ptr);
+ interp = ptr->ip;
+
+ encoding = Tcl_GetEncoding(interp,STR2CSTR(encodename));
+ buff1 = ALLOCA_N(char,strlen(STR2CSTR(str))+1);
+ strcpy(buff1,STR2CSTR(str));
+
+ Tcl_DStringInit(&dstr);
+ Tcl_DStringFree(&dstr);
+ Tcl_ExternalToUtfDString(encoding,buff1,strlen(buff1),&dstr);
+ buff2 = ALLOCA_N(char,Tcl_DStringLength(&dstr)+1);
+ strcpy(buff2,Tcl_DStringValue(&dstr));
+
+ Tcl_FreeEncoding(encoding);
+ Tcl_DStringFree(&dstr);
+
+ return rb_str_new2(buff2);
+#endif
+}
+
+static VALUE
+ip_fromUTF8(VALUE self, VALUE str, VALUE encodename)
+{
+#ifndef TCL_UTF_MAX
+ return str;
+#else
+ Tcl_Interp *interp;
+ Tcl_Encoding encoding;
+ Tcl_DString dstr;
+ struct tcltkip *ptr;
+ char *buff1,*buff2;
+
+ Data_Get_Struct(self,struct tcltkip, ptr);
+ interp = ptr->ip;
+
+ encoding = Tcl_GetEncoding(interp,STR2CSTR(encodename));
+ buff1 = ALLOCA_N(char,strlen(STR2CSTR(str))+1);
+ strcpy(buff1,STR2CSTR(str));
+
+ Tcl_DStringInit(&dstr);
+ Tcl_DStringFree(&dstr);
+ Tcl_UtfToExternalDString(encoding,buff1,strlen(buff1),&dstr);
+ buff2 = ALLOCA_N(char,Tcl_DStringLength(&dstr)+1);
+ strcpy(buff2,Tcl_DStringValue(&dstr));
+
+ Tcl_FreeEncoding(encoding);
+ Tcl_DStringFree(&dstr);
+
+ return rb_str_new2(buff2);
+#endif
+}
+
+
+static VALUE
+ip_invoke(int argc, VALUE *argv, VALUE obj)
+{
+ struct tcltkip *ptr; /* tcltkip data struct */
+ int i;
+ int object = 0;
+ Tcl_CmdInfo info;
+ char *cmd;
+ char **av = (char **)NULL;
+#if TCL_MAJOR_VERSION >= 8
+ Tcl_Obj **ov = (Tcl_Obj **)NULL;
+ Tcl_Obj *resultPtr;
+#endif
+
+ /* get the data struct */
+ Data_Get_Struct(obj, struct tcltkip, ptr);
+
+ /* get the command name string */
+ cmd = STR2CSTR(argv[0]);
+
+ /* map from the command name to a C procedure */
+ if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) {
+ rb_raise(rb_eNameError, "invalid command name `%s'", cmd);
+ }
+#if TCL_MAJOR_VERSION >= 8
+ object = info.isNativeObjectProc;
+#endif
+
+ /* memory allocation for arguments of this command */
+ if (object) {
+#if TCL_MAJOR_VERSION >= 8
+ /* object interface */
+ ov = (Tcl_Obj **)ALLOCA_N(Tcl_Obj *, argc+1);
+ for (i = 0; i < argc; ++i) {
+ char *s = STR2CSTR(argv[i]);
+ ov[i] = Tcl_NewStringObj(s, strlen(s));
+ }
+ ov[argc] = (Tcl_Obj *)NULL;
+#endif
+ } else {
+ /* string interface */
+ av = (char **)ALLOCA_N(char *, argc+1);
+ for (i = 0; i < argc; ++i) {
+ char *s = STR2CSTR(argv[i]);
+
+ 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 (object) {
+#if TCL_MAJOR_VERSION >= 8
+ 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);
+#endif
+ } else {
+ ptr->return_value = (*info.proc)(info.clientData,
+ ptr->ip, argc, av);
+ }
+
+ if (ptr->return_value == TCL_ERROR) {
+ rb_raise(rb_eRuntimeError, ptr->ip->result);
+ }
+
+ /* pass back the result (as string) */
+ return(rb_str_new2(ptr->ip->result));
}
/* get return code from Tcl_Eval() */
@@ -190,27 +398,44 @@ ip_retval(VALUE 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()
{
extern VALUE rb_argv0; /* the argv[0] */
VALUE lib = rb_define_module("TclTkLib");
- VALUE ip = rb_define_class("TclTkIp", cObject);
+ VALUE ip = rb_define_class("TclTkIp", rb_cObject);
+
+ eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError);
+ eTkCallbackContinue = rb_define_class("TkCallbackContinue",rb_eStandardError);
rb_define_module_function(lib, "mainloop", lib_mainloop, 0);
rb_define_singleton_method(ip, "new", ip_new, 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, "_invoke", ip_invoke, -1);
rb_define_method(ip, "_return_value", ip_retval, 0);
rb_define_method(ip, "mainloop", lib_mainloop, 0);
+#ifdef __MACOS__
+ _macinit();
+#endif
+
/*---- initialize tcl/tk libraries ----*/
/* from Tk_Main() */
DUMP1("Tcl_FindExecutable");
Tcl_FindExecutable(RSTRING(rb_argv0)->ptr);
-
- rb_define_variable("$tk_thread_safe", &thread_safe);
}
/* eof */