From 210367ec889f5910e270d6ea2c7ddb8a8d939e61 Mon Sep 17 00:00:00 2001 From: matz Date: Wed, 20 Jan 1999 04:59:39 +0000 Subject: This commit was generated by cvs2svn to compensate for changes in r372, which included commits to RCS files with non-trunk default branches. git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/trunk@373 b2dd03c8-39d4-4d8f-98ff-823fe69b080e --- ext/tcltklib/extconf.rb | 114 +++++++++--------- ext/tcltklib/lib/tcltk.rb | 287 +++++++++++++++++++++------------------------ ext/tcltklib/tcltklib.c | 293 ++++++++++++++++++++++++++++++++++++++++------ 3 files changed, 452 insertions(+), 242 deletions(-) (limited to 'ext/tcltklib') diff --git a/ext/tcltklib/extconf.rb b/ext/tcltklib/extconf.rb index 26e7fe7b09..e34e549ca0 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 81d01f930d..54a00e8f3c 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() を呼ぶ. -# トップレベルの イベントのコールバックとして呼ぶためのもの. -# 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 +# 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 e7fe77d2b7..625fe61ccc 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 #include #include #include -/* for debug */ +#ifdef __MACOS__ +# include +# include +#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 */ -- cgit v1.2.3