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

4 files changed, 186 insertions, 36 deletions

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 <matz@netlab.jp>
@@ -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)