From cc66b1fae449cd360ab33fbbe8b598510e3fec26 Mon Sep 17 00:00:00 2001 From: nagai Date: Fri, 25 Jul 2003 16:43:03 +0000 Subject: tcltklib.c : add TclTkIp#create_slave , TclTkIp#_make_safe and TclTkIp#safe? MANUAL.euc : modify descriptions tk.rb : bug fix [ruby-talk:76980] and modify to support multi Tk IPs tkafter.rb : modify to support multi Tk IPs git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/trunk@4163 b2dd03c8-39d4-4d8f-98ff-823fe69b080e --- ext/tcltklib/MANUAL.euc | 39 +++++++++++++++++++++-- ext/tcltklib/tcltklib.c | 83 +++++++++++++++++++++++++++++++++++++++++++------ ext/tk/lib/tk.rb | 69 ++++++++++++++++++++++++++-------------- ext/tk/lib/tkafter.rb | 31 +++++++++++++++++- 4 files changed, 186 insertions(+), 36 deletions(-) (limited to 'ext') diff --git a/ext/tcltklib/MANUAL.euc b/ext/tcltklib/MANUAL.euc index 757cd40a4d..f44e491e46 100644 --- a/ext/tcltklib/MANUAL.euc +++ b/ext/tcltklib/MANUAL.euc @@ -1,5 +1,5 @@ (tof) - 2003/06/19 Hidetoshi NAGAI + 2003/07/25 Hidetoshi NAGAI 本ドキュメントには古い tcltk ライブラリ，tcltklib ライブラリの説明 が含まれていますが，その記述内容は古いものとなっています． @@ -245,7 +245,35 @@ require "tcltklib" : ( see set_eventloop_wait ) クラス 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') ) + インスタンスメソッド + create_slave(name, safe=false) + : レシーバを親とする name という名前のスレーブインタープリタを + : 生成する． + : safe には生成するインタープリタを safe インタープリタとする + : かを指定する．デフォルトは false ということになっているが， + : たとえ明確に false を指定していたとしても，親となるインター + : プリタが safe インタープリタであれば，その設定を引き継いで + : safe インタープリタとして生成される． + + make_safe + : Tcl/Tk インタープリタを safe インタープリタに変更する． + : 戻り値はレシーバであるインタープリタ自身である． + : 失敗した場合は RuntimeError の例外を発生する． + + safe? + : Tcl/Tk インタープリタを safe インタープリタであるかを調べる． + : safe インタープリタであれば true を返す． + restart : Tcl/Tk インタープリタの Tk 部分の初期化，再起動を行う． : 一旦 root widget を破壊した後に再度 Tk の機能が必要と @@ -258,8 +286,13 @@ require "tcltklib" : _invoke は評価スクリプトの token ごとに一つの引数とな : るように与える． : _invoke の方は Tcl/Tk インタープリタの字句解析器を用い - : ないため，評価の負荷がより少なくてすむ． - + : ないため，評価の負荷がより少なくてすむ．ただし，その代 + : わりに auto_load のような機構は働かず，load 等によって + : Tcl/Tk インタープリタ上に既に登録済みのコマンドしか呼 + : び出すことができない． + : _eval では auto_load 機構が働くため，一度 _eval を実行 + : して登録に成功しさえすれば，以降は _invoke でも利用で + : きるようになる． _toUTF8(str, encoding) _fromUTF8(str, encoding) diff --git a/ext/tcltklib/tcltklib.c b/ext/tcltklib/tcltklib.c index 5331e1fd03..9df98742b7 100644 --- a/ext/tcltklib/tcltklib.c +++ b/ext/tcltklib/tcltklib.c @@ -614,22 +614,22 @@ ip_init(argc, argv, self) cnt = rb_scan_args(argc, argv, "02", &argv0, &opts); switch(cnt) { case 2: - /* options */ - Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), 0); + /* options */ + Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), 0); case 1: - /* argv0 */ - if (argv0 != Qnil) { - Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0); - } + /* argv0 */ + if (argv0 != Qnil) { + Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0); + } case 0: - /* no args */ - ; + /* no args */ + ; } /* from Tcl_AppInit() */ DUMP1("Tk_Init"); if (Tk_Init(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); } DUMP1("Tcl_StaticPackage(\"Tk\")"); #if TCL_MAJOR_VERSION >= 8 @@ -653,6 +653,68 @@ ip_init(argc, argv, self) 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; + } 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"); + } + 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; + } +} + /* eval string in tcl by Tcl_Eval() */ static VALUE ip_eval(self, str) @@ -1012,6 +1074,9 @@ Init_tcltklib() 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, "_eval", ip_eval, 1); rb_define_method(ip, "_toUTF8",ip_toUTF8,2); rb_define_method(ip, "_fromUTF8",ip_fromUTF8,2); diff --git a/ext/tk/lib/tk.rb b/ext/tk/lib/tk.rb index e0c11c1c0d..b84b0a7c48 100644 --- a/ext/tk/lib/tk.rb +++ b/ext/tk/lib/tk.rb @@ -1,4 +1,4 @@ -# + # tk.rb - Tk interface module using tcltklib # $Date$ # by Yukihiro Matsumoto @@ -251,7 +251,8 @@ module TkComm def procedure(val) if val =~ /^rb_out (c\d+)/ #Tk_CMDTBL[$1] - TkCore::INTERP.tk_cmd_tbl[$1] + #TkCore::INTERP.tk_cmd_tbl[$1] + TkCore::INTERP.tk_cmd_tbl[$1].cmd else #nil val @@ -291,6 +292,7 @@ module TkComm return str end private :_get_eval_string + module_function :_get_eval_string def ruby2tcl(v) if v.kind_of?(Hash) @@ -319,7 +321,7 @@ module TkComm return '' if cmd == '' id = _next_cmd_id #Tk_CMDTBL[id] = cmd - TkCore::INTERP.tk_cmd_tbl[id] = cmd + TkCore::INTERP.tk_cmd_tbl[id] = TkCore::INTERP.get_cb_entry(cmd) @cmdtbl = [] unless defined? @cmdtbl @cmdtbl.push id return format("rb_out %s", id); @@ -656,8 +658,8 @@ module TkCore INTERP = TclTkIp.new(name, opts) - def INTERP.__ip_id - nil + def INTERP.__getip + self end INTERP.instance_eval{ @@ -667,8 +669,20 @@ module TkCore @tk_table_list = [] @init_ip_env = [] # table of Procs - @add_tk_procs = [] # table of [name, body] + @add_tk_procs = [] # table of [name, args, body] + + @cb_entry_class = Class.new{|c| + def initialize(ip, cmd) + @ip = ip + @cmd = cmd + end + attr_reader :ip, :cmd + def call(*args) + @ip.cb_eval(@cmd, *args) + end + } } + def INTERP.tk_cmd_tbl @tk_cmd_tbl end @@ -691,13 +705,20 @@ module TkCore return obj end + def INTERP.get_cb_entry(cmd) + @cb_entry_class.new(__getip, cmd).freeze + end + def INTERP.cb_eval(cmd, *args) + TkComm._get_eval_string(TkUtil.eval_cmd(cmd, *args)) + end + def INTERP.init_ip_env(script = Proc.new) @init_ip_env << script script.call(self) end - def INTERP.add_tk_procs(name, args, body) + def INTERP.add_tk_procs(name, args = nil, body = nil) @add_tk_procs << [name, args, body] - self._invoke('proc', name, args, body) + self._invoke('proc', name, args, body) if args && body end def INTERP.init_ip_internal ip = self @@ -726,6 +747,20 @@ module TkCore fail TkCallbackContinue, "Tk callback returns 'continue' status" end + def TkCore.callback(arg) + # arg = tk_split_list(arg) + arg = tk_split_simplelist(arg) + #_get_eval_string(TkUtil.eval_cmd(Tk_CMDTBL[arg.shift], *arg)) + #_get_eval_string(TkUtil.eval_cmd(TkCore::INTERP.tk_cmd_tbl[arg.shift], + # *arg)) + cb_obj = TkCore::INTERP.tk_cmd_tbl[arg.shift] + cb_obj.call(*arg) + end + + def load_cmd_on_ip(tk_cmd) + bool(tk_call('auto_load', tk_cmd)) + end + def after(ms, cmd=Proc.new) myid = _curr_cmd_id cmdid = install_cmd(cmd) @@ -794,14 +829,6 @@ module TkCore tk_call('clock','seconds').to_i end - def TkCore.callback(arg) - # arg = tk_split_list(arg) - arg = tk_split_simplelist(arg) - #_get_eval_string(TkUtil.eval_cmd(Tk_CMDTBL[arg.shift], *arg)) - _get_eval_string(TkUtil.eval_cmd(TkCore::INTERP.tk_cmd_tbl[arg.shift], - *arg)) - end - def windowingsystem tk_call('tk', 'windowingsystem') end @@ -898,7 +925,7 @@ module TkCore TkCore::INTERP.init_ip_internal tk_call('set', 'argv0', app_name) if app_name - if keys.kind_of?(Hash) && keys.size > 0 + if keys.kind_of?(Hash) # tk_call('set', 'argc', keys.size * 2) tk_call('set', 'argv', hash_kv(keys).join(' ')) end @@ -937,10 +964,6 @@ module TkCore tk_call 'tk_chooseColor', *hash_kv(keys) end - def chooseDirectory(keys = nil) - tk_call 'tk_chooseDirectory', *hash_kv(keys) - end - def ip_eval(cmd_string) res = INTERP._eval(cmd_string) if INTERP._return_value() != 0 @@ -1484,11 +1507,11 @@ if /^8\.[1-9]/ =~ Tk::TCL_VERSION && !Tk::JAPANIZED_TK TkCommandNames = ['encoding'.freeze].freeze def encoding=(name) - INTERP.encoding = name + TkCore::INTERP.encoding = name end def encoding - INTERP.encoding + TkCore::INTERP.encoding end def encoding_names diff --git a/ext/tk/lib/tkafter.rb b/ext/tk/lib/tkafter.rb index 4401bce719..2ff60fe1e9 100644 --- a/ext/tk/lib/tkafter.rb +++ b/ext/tk/lib/tkafter.rb @@ -25,7 +25,8 @@ class TkTimer @after_id = nil ex_obj = Tk_CBTBL[obj_id] return nil if ex_obj == nil; # canceled - _get_eval_string(ex_obj.do_callback) + #_get_eval_string(ex_obj.do_callback) + ex_obj.cb_call end def self.info @@ -103,6 +104,8 @@ class TkTimer @id = Tk_CBID.join Tk_CBID[1].succ! + @cb_cmd = TkCore::INTERP.get_cb_entry(self.method(:do_callback)) + @set_next = true @init_sleep = 0 @@ -142,6 +145,10 @@ class TkTimer attr_accessor :loop_exec + def cb_call + @cb_cmd.call + end + def get_procs [@init_sleep, @init_proc, @init_args, @sleep_time, @loop_exec, @loop_proc] end @@ -220,6 +227,28 @@ class TkTimer self end + def delete_procs(*procs) + procs.each{|e| + if e.kind_of? Proc + @loop_proc.delete([e]) + else + @loop_proc.delete(e) + end + } + @proc_max = @loop_proc.size + + cancel if @proc_max == 0 + + self + end + + def delete_at(n) + @loop_proc.delete_at(n) + @proc_max = @loop_proc.size + cancel if @proc_max == 0 + self + end + def set_start_proc(sleep, init_proc, *init_args) if !sleep == 'idle' && !sleep.kind_of?(Integer) fail format("%s need to be Integer", sleep.inspect) -- cgit v1.2.3