From bf0e2520d7103948427adc520047335f55038907 Mon Sep 17 00:00:00 2001
From: nagai <nagai@b2dd03c8-39d4-4d8f-98ff-823fe69b080e>
Date: Sun, 19 Oct 2014 08:38:35 +0000
Subject: * ext/tk/tcltklib.c: support Tcl/Tk8.6. * ext/tk/lib/tk.rb: ditto. *
 ext/tk/extconf.rb: ditto. * ext/tk/lib/tk_mac.rb: add new features of
 Tcl/Tk8.6. * ext/tk/lib/tkextlib/tile/treeview.rb: ditto. *
 ext/tk/lib/tkextlib/tile/fontchooser.rb: add an alias. *
 ext/tk/lib/tk/autoload.rb: ditto. * ext/tk/lib/tkextlib/tcllib/validator.rb:
 add a new feature of tklib extension. * ext/tk/lib/tkextlib/tkimg/dted.rb: a
 new supported format of Img extension. * ext/tk/lib/tkextlib/tkimg/raw.rb:
 ditto.

git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/trunk@48018 b2dd03c8-39d4-4d8f-98ff-823fe69b080e
---
 ext/tk/extconf.rb                       |   4 +-
 ext/tk/lib/tk.rb                        |  22 ++++-
 ext/tk/lib/tk/autoload.rb               |   2 +
 ext/tk/lib/tk/fontchooser.rb            |   4 +
 ext/tk/lib/tk/tk_mac.rb                 | 158 ++++++++++++++++++++++++++++++++
 ext/tk/lib/tkextlib/tcllib/validator.rb |  65 +++++++++++++
 ext/tk/lib/tkextlib/tile/treeview.rb    |  30 ++++++
 ext/tk/lib/tkextlib/tkimg/dted.rb       |  33 +++++++
 ext/tk/lib/tkextlib/tkimg/raw.rb        |  33 +++++++
 ext/tk/tcltklib.c                       |  40 +++++---
 10 files changed, 374 insertions(+), 17 deletions(-)
 create mode 100644 ext/tk/lib/tk/tk_mac.rb
 create mode 100644 ext/tk/lib/tkextlib/tcllib/validator.rb
 create mode 100644 ext/tk/lib/tkextlib/tkimg/dted.rb
 create mode 100644 ext/tk/lib/tkextlib/tkimg/raw.rb

(limited to 'ext')

diff --git a/ext/tk/extconf.rb b/ext/tk/extconf.rb
index 8e20e42ea1..c6a2dd52ff 100644
--- a/ext/tk/extconf.rb
+++ b/ext/tk/extconf.rb
@@ -9,10 +9,10 @@ TkLib_Config['search_versions'] =
   # %w[8.9 8.8 8.7 8.6 8.5 8.4 8.3 8.2 8.1 8.0 7.6 4.2]
   # %w[8.7 8.6 8.5 8.4 8.3 8.2 8.1 8.0]
   # %w[8.7 8.6 8.5 8.4 8.0] # to shorten search steps
-  %w[8.5 8.4 8.6] # Tcl/Tk8.6 support is experimental.
+  %w[8.6 8.5 8.4]
 
 TkLib_Config['unsupported_versions'] =
-  %w[8.8 8.7] # Tcl/Tk8.6 support is experimental.
+  %w[8.8 8.7]
 
 TkLib_Config['major_nums'] = '87'
 
diff --git a/ext/tk/lib/tk.rb b/ext/tk/lib/tk.rb
index 5bac92e47c..45f86a9253 100644
--- a/ext/tk/lib/tk.rb
+++ b/ext/tk/lib/tk.rb
@@ -1309,8 +1309,12 @@ EOS
           end
 
           unless interp.deleted?
-            #Thread.current[:status].value = TclTkLib.mainloop(false)
-            Thread.current[:status].value = interp.mainloop(false)
+            begin
+              #Thread.current[:status].value = TclTkLib.mainloop(false)
+              Thread.current[:status].value = interp.mainloop(false)
+            rescue Exception=>e
+              puts "ignore exception on interp: #{e.inspect}\n" if $DEBUG
+            end
           end
 
         ensure
@@ -1569,7 +1573,15 @@ EOS
   EOL
 =end
 
-  at_exit{ INTERP.remove_tk_procs(TclTkLib::FINALIZE_PROC_NAME) }
+  if !WITH_RUBY_VM || RUN_EVENTLOOP_ON_MAIN_THREAD ### check Ruby 1.9 !!!!!!!
+    at_exit{ INTERP.remove_tk_procs(TclTkLib::FINALIZE_PROC_NAME) }
+  else
+    at_exit{
+      Tk.root.destroy
+      INTERP.remove_tk_procs(TclTkLib::FINALIZE_PROC_NAME)
+      INTERP_THREAD.kill.join
+    }
+  end
 
   EventFlag = TclTkLib::EventFlag
 
@@ -5197,6 +5209,8 @@ class TkWindow<TkObject
     TkWinfo.exist?(self)
   end
 
+  alias subcommand tk_send
+
   def bind_class
     @db_class || self.class()
   end
@@ -5742,7 +5756,7 @@ TkWidget = TkWindow
 #Tk.freeze
 
 module Tk
-  RELEASE_DATE = '2010-06-03'.freeze
+  RELEASE_DATE = '2014-10-19'.freeze
 
   autoload :AUTO_PATH,        'tk/variable'
   autoload :TCL_PACKAGE_PATH, 'tk/variable'
diff --git a/ext/tk/lib/tk/autoload.rb b/ext/tk/lib/tk/autoload.rb
index f6ca261da9..451922c7d3 100644
--- a/ext/tk/lib/tk/autoload.rb
+++ b/ext/tk/lib/tk/autoload.rb
@@ -94,6 +94,8 @@ module Tk
   autoload :Y_Scrollable,     'tk/scrollable'
   autoload :Scrollable,       'tk/scrollable'
 
+  autoload :Fontchooser,      'tk/fontchooser'
+
   autoload :Wm,               'tk/wm'
   autoload :Wm_for_General,   'tk/wm'
 
diff --git a/ext/tk/lib/tk/fontchooser.rb b/ext/tk/lib/tk/fontchooser.rb
index 694c58a607..22d70f9c0a 100644
--- a/ext/tk/lib/tk/fontchooser.rb
+++ b/ext/tk/lib/tk/fontchooser.rb
@@ -8,6 +8,10 @@ module TkFont::Chooser
   extend TkCore
 end
 
+module Tk
+  Fontchooser = TkFont::Chooser
+end
+
 class << TkFont::Chooser
   def method_missing(id, *args)
     name = id.id2name
diff --git a/ext/tk/lib/tk/tk_mac.rb b/ext/tk/lib/tk/tk_mac.rb
new file mode 100644
index 0000000000..77bb2349cc
--- /dev/null
+++ b/ext/tk/lib/tk/tk_mac.rb
@@ -0,0 +1,158 @@
+#
+# tk/tk_mac.rb : Access Mac-Specific functionality on OS X from Tk
+#                (supported by Tk8.6 or later)
+#
+#     ATTENTION !!
+#         This is NOT TESTED. Because I have no test-environment.
+#
+require 'tk'
+
+module Tk
+  module Mac
+  end
+end
+
+module Tk::Mac
+  extend TkCore
+
+  # event handler callbacks
+  def self.def_ShowPreferences(cmd=Proc.new)
+    ip_eval("proc ::tk::mac::ShowPreferences {} { #{install_cmd(cmd)} }")
+    nil
+  end
+
+  def self.def_OpenApplication(cmd=Proc.new)
+    ip_eval("proc ::tk::mac::OpenApplication {} { #{install_cmd(cmd)} }")
+    nil
+  end
+
+  def self.def_ReopenApplication(cmd=Proc.new)
+    ip_eval("proc ::tk::mac::ReopenApplication {} { #{install_cmd(cmd)} }")
+    nil
+  end
+
+  def self.def_OpenDocument(cmd=Proc.new)
+    ip_eval("proc ::tk::mac::OpenDocument {args} { eval #{install_cmd(cmd)} $args }")
+    nil
+  end
+
+  def self.def_PrintDocument(cmd=Proc.new)
+    ip_eval("proc ::tk::mac::PrintDocument {args} { eval #{install_cmd(cmd)} $args }")
+    nil
+  end
+
+  def self.def_Quit(cmd=Proc.new)
+    ip_eval("proc ::tk::mac::Quit {} { #{install_cmd(cmd)} }")
+    nil
+  end
+
+  def self.def_OnHide(cmd=Proc.new)
+    ip_eval("proc ::tk::mac::OnHide {} { #{install_cmd(cmd)} }")
+    nil
+  end
+
+  def self.def_OnShow(cmd=Proc.new)
+    ip_eval("proc ::tk::mac::OnShow {} { #{install_cmd(cmd)} }")
+    nil
+  end
+
+  def self.def_ShowHelp(cmd=Proc.new)
+    ip_eval("proc ::tk::mac::ShowHelp {} { #{install_cmd(cmd)} }")
+    nil
+  end
+
+
+  # additional dialogs
+  def self.standardAboutPanel
+    tk_call('::tk::mac::standardAboutPanel')
+    nil
+  end
+
+
+  # system configuration
+  def self.useCompatibilityMetrics(mode)
+    tk_call('::tk::mac::useCompatibilityMetrics', mode)
+    nil
+  end
+
+  def self.CGAntialiasLimit(limit)
+    tk_call('::tk::mac::CGAntialiasLimit', limit)
+    nil
+  end
+
+  def self.antialiasedtext(num)
+    tk_call('::tk::mac::antialiasedtext', num)
+    nil
+  end
+
+  def self.useThemedToplevel(mode)
+    tk_call('::tk::mac::useThemedToplevel', mode)
+    nil
+  end
+
+end
+
+class Tk::Mac::IconBitmap < TkImage
+  TkCommandNames = ['::tk::mac::iconBitmap'].freeze
+
+  def self.new(width, height, keys)
+    if keys.kind_of?(Hash)
+      name = nil
+      if keys.key?(:imagename)
+        name = keys[:imagename]
+      elsif keys.key?('imagename')
+        name = keys['imagename']
+      end
+      if name
+        if name.kind_of?(TkImage)
+          obj = name
+        else
+          name = _get_eval_string(name)
+          obj = nil
+          Tk_IMGTBL.mutex.synchronize{
+            obj = Tk_IMGTBL[name]
+          }
+        end
+        if obj
+          if !(keys[:without_creating] || keys['without_creating'])
+            keys = _symbolkey2str(keys)
+            keys.delete('imagename')
+            keys.delete('without_creating')
+            obj.instance_eval{
+              tk_call_without_enc('::tk::mac::iconBitmap',
+                                  @path, width, height, *hash_kv(keys, true))
+            }
+          end
+          return obj
+        end
+      end
+    end
+    (obj = self.allocate).instance_eval{
+      Tk_IMGTBL.mutex.synchronize{
+        initialize(width, height, keys)
+        Tk_IMGTBL[@path] = self
+      }
+    }
+    obj
+  end
+
+  def initialize(width, height, keys)
+    @path = nil
+    without_creating = false
+    if keys.kind_of?(Hash)
+      keys = _symbolkey2str(keys)
+      @path = keys.delete('imagename')
+      without_creating = keys.delete('without_creating')
+    end
+    unless @path
+      Tk_Image_ID.mutex.synchronize{
+        @path = Tk_Image_ID.join(TkCore::INTERP._ip_id_)
+        Tk_Image_ID[1].succ!
+      }
+    end
+    unless without_creating
+      tk_call_without_enc('::tk::mac::iconBitmap',
+                          @path, width, height, *hash_kv(keys, true))
+    end
+  end
+end
diff --git a/ext/tk/lib/tkextlib/tcllib/validator.rb b/ext/tk/lib/tkextlib/tcllib/validator.rb
new file mode 100644
index 0000000000..3a71960afa
--- /dev/null
+++ b/ext/tk/lib/tkextlib/tcllib/validator.rb
@@ -0,0 +1,65 @@
+#
+#  tkextlib/tcllib/validator.rb
+#                               by Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp)
+#
+#   * Part of tcllib extension
+#   * Provides a unified validation API
+#
+
+require 'tk'
+require 'tkextlib/tcllib.rb'
+
+# TkPackage.require('widget::validator', '0.1')
+TkPackage.require('widget::validator')
+
+module Tk::Tcllib
+  module Validator
+    PACKAGE_NAME = 'widget::validator'.freeze
+    def self.package_name
+      PACKAGE_NAME
+    end
+
+    def self.package_version
+      begin
+        TkPackage.require('widget::validator')
+      rescue
+        ''
+      end
+    end
+  end
+end
+
+module Tk::Tcllib::Validator
+  extend TkCore
+
+  def self.attach(widget, color, cmd=Proc.new)
+    tk_call_without_enc('::widget::validator', 'attach', widget, color, cmd)
+    nil
+  end
+
+  def self.detach(widget)
+    tk_call_without_enc('::widget::validator', 'detach', widget)
+    nil
+  end
+
+  def self.validate(widget)
+    tk_call_without_enc('::widget::validator', 'validate', widget)
+    nil
+  end
+
+  def attach_validator(color, cmd=Proc.new)
+    tk_call_without_enc('::widget::validator', 'attach', @path, color, cmd)
+    self
+  end
+
+  def detach_validator(color, cmd=Proc.new)
+    tk_call_without_enc('::widget::validator', 'detach', @path)
+    self
+  end
+
+  def invoke_validator(color, cmd=Proc.new)
+    tk_call_without_enc('::widget::validator', 'validate', @path)
+    self
+  end
+  alias validate_validator invoke_validator
+end
diff --git a/ext/tk/lib/tkextlib/tile/treeview.rb b/ext/tk/lib/tkextlib/tile/treeview.rb
index 70db3d6d78..ed8e875d96 100644
--- a/ext/tk/lib/tkextlib/tile/treeview.rb
+++ b/ext/tk/lib/tkextlib/tile/treeview.rb
@@ -986,6 +986,18 @@ class Tk::Tile::Treeview::Tag < TkObject
   end
   alias added? tag_has?
 
+  def tag_has
+    @t.tag_has(@id)
+  end
+
+  def add(*items)
+    @t.tag_add(@id, *items))
+  end
+
+  def remove(*items)
+    @t.tag_remove(@id, *items))
+  end
+
   def bind(seq, *args)
     if TkComm._callback_entry?(args[0]) || !block_given?
       cmd = args.shift
@@ -1299,6 +1311,24 @@ class Tk::Tile::Treeview < TkWindow
     _bindinfo([@path, 'tag', 'bind', tag], context)
   end
   alias tagbindinfo tag_bindinfo
+
+  def tag_names
+    tk_split_simplelist(tk_send('tag', 'names')).collect{|id|
+      Tk::Tile::Treeview::Tag.id2obj(self, id)
+    }
+  end
+
+  def tag_add(tag, *items)
+    fail ArgumentError, "no target items" if items.empty?
+    tk_send('tag', 'add', tagid(tag), *(items.collect{|item| tagid(item)}))
+    self
+  end
+
+  def tag_remove(tag, *items)
+    tk_send('tag', 'remove', tagid(tag), *(items.collect{|item| tagid(item)}))
+    self
+  end
+
 end
 
 #Tk.__set_toplevel_aliases__(:Ttk, Tk::Tile::Treeview, :TkTreeview)
diff --git a/ext/tk/lib/tkextlib/tkimg/dted.rb b/ext/tk/lib/tkextlib/tkimg/dted.rb
new file mode 100644
index 0000000000..cae833664c
--- /dev/null
+++ b/ext/tk/lib/tkextlib/tkimg/dted.rb
@@ -0,0 +1,33 @@
+#
+#  TkImg - format 'DTED'
+#                               by Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp)
+#
+require 'tk'
+
+# call setup script for general 'tkextlib' libraries
+require 'tkextlib/setup.rb'
+
+# call setup script
+require 'tkextlib/tkimg/setup.rb'
+
+# TkPackage.require('img::dted', '1.4')
+TkPackage.require('img::dted')
+
+module Tk
+  module Img
+    module DTED
+      PACKAGE_NAME = 'img::dted'.freeze
+      def self.package_name
+        PACKAGE_NAME
+      end
+
+      def self.package_version
+        begin
+          TkPackage.require('img::dted')
+        rescue
+          ''
+        end
+      end
+    end
+  end
+end
diff --git a/ext/tk/lib/tkextlib/tkimg/raw.rb b/ext/tk/lib/tkextlib/tkimg/raw.rb
new file mode 100644
index 0000000000..5f1cdcaac0
--- /dev/null
+++ b/ext/tk/lib/tkextlib/tkimg/raw.rb
@@ -0,0 +1,33 @@
+#
+#  TkImg - format 'Raw Data'
+#                               by Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp)
+#
+require 'tk'
+
+# call setup script for general 'tkextlib' libraries
+require 'tkextlib/setup.rb'
+
+# call setup script
+require 'tkextlib/tkimg/setup.rb'
+
+# TkPackage.require('img::raw', '1.4')
+TkPackage.require('img::raw')
+
+module Tk
+  module Img
+    module Raw
+      PACKAGE_NAME = 'img::raw'.freeze
+      def self.package_name
+        PACKAGE_NAME
+      end
+
+      def self.package_version
+        begin
+          TkPackage.require('img::raw')
+        rescue
+          ''
+        end
+      end
+    end
+  end
+end
diff --git a/ext/tk/tcltklib.c b/ext/tk/tcltklib.c
index 1ec4cec52e..2d45f7511b 100644
--- a/ext/tk/tcltklib.c
+++ b/ext/tk/tcltklib.c
@@ -6008,6 +6008,9 @@ ip_rb_replaceSlaveTkCmdsCommand(clientData, interp, objc, objv)
     return TCL_OK;
 }
 
+#ifndef ORIG_NAMESPACE_CMD
+#define ORIG_NAMESPACE_CMD "__orig_namespace_command__"
+#endif
 
 #if TCL_MAJOR_VERSION >= 8
 static int ip_rbNamespaceObjCmd _((ClientData, Tcl_Interp *, int,
@@ -6026,8 +6029,8 @@ ip_rbNamespaceObjCmd(clientData, interp, objc, objv)
     DUMP2("objc = %d", objc);
     DUMP2("objv[0] = '%s'", Tcl_GetString(objv[0]));
     DUMP2("objv[1] = '%s'", Tcl_GetString(objv[1]));
-    if (!Tcl_GetCommandInfo(interp, "__orig_namespace_command__", &(info))) {
-      DUMP1("fail to get __orig_namespace_command__");
+    if (!Tcl_GetCommandInfo(interp, ORIG_NAMESPACE_CMD, &(info))) {
+      DUMP1("fail to get "ORIG_NAMESPACE_CMD);
         Tcl_ResetResult(interp);
         Tcl_AppendResult(interp,
                          "invalid command name \"namespace\"", (char*)NULL);
@@ -6045,7 +6048,7 @@ ip_rbNamespaceObjCmd(clientData, interp, objc, objv)
         /* Tcl8.6 or later */
         int i;
         Tcl_Obj **cp_objv;
-        char org_ns_cmd_name[] = "__orig_namespace_command__";
+        char org_ns_cmd_name[] = ORIG_NAMESPACE_CMD;
 
         DUMP1("call a native-object-proc for tcl8.6 or later");
         cp_objv = RbTk_ALLOC_N(Tcl_Obj *, (objc + 1));
@@ -6056,7 +6059,8 @@ ip_rbNamespaceObjCmd(clientData, interp, objc, objv)
         }
         cp_objv[objc] = (Tcl_Obj *)NULL;
 
-        ret = Tcl_EvalObjv(interp, objc, cp_objv, TCL_EVAL_DIRECT);
+        /* ret = Tcl_EvalObjv(interp, objc, cp_objv, TCL_EVAL_DIRECT); */
+        ret = Tcl_EvalObjv(interp, objc, cp_objv, 0);
 
         ckfree((char*)cp_objv);
 #endif
@@ -6115,17 +6119,17 @@ ip_wrap_namespace_command(interp)
     }
 
     if (orig_info.isNativeObjectProc) {
-        Tcl_CreateObjCommand(interp, "__orig_namespace_command__",
+        Tcl_CreateObjCommand(interp, ORIG_NAMESPACE_CMD,
                              orig_info.objProc, orig_info.objClientData,
                              orig_info.deleteProc);
     } else {
-        Tcl_CreateCommand(interp, "__orig_namespace_command__",
+        Tcl_CreateCommand(interp, ORIG_NAMESPACE_CMD,
                           orig_info.proc, orig_info.clientData,
                           orig_info.deleteProc);
     }
 
 #else /* tcl8.6 or later */
-    Tcl_Eval(interp, "rename namespace __orig_namespace_command__");
+    Tcl_Eval(interp, "rename namespace "ORIG_NAMESPACE_CMD);
 
 #endif
 
@@ -8493,16 +8497,26 @@ invoke_tcl_proc(arg)
 #endif
 {
     struct invoke_info *inf = (struct invoke_info *)arg;
+#if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION < 6
     int i, len;
-#if TCL_MAJOR_VERSION >= 8
     int argc = inf->objc;
     char **argv = (char **)NULL;
 #endif
 
     DUMP1("call invoke_tcl_proc");
 
+#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 6)
+    /* Tcl/Tk 8.6 or later */
+
+    /* eval */
+    inf->ptr->return_value = Tcl_EvalObjv(inf->ptr->ip, inf->objc, inf->objv, TCL_EVAL_DIRECT);
+    /* inf->ptr->return_value = Tcl_EvalObjv(inf->ptr->ip, inf->objc, inf->objv, 0); */
+
+#else /* Tcl/Tk 7.x, 8.0 -- 8.5 */
+
     /* memory allocation for arguments of this command */
-#if TCL_MAJOR_VERSION >= 8
+#if TCL_MAJOR_VERSION == 8
+     /* Tcl/Tk 8.0 -- 8.5 */
     if (!inf->cmdinfo.isNativeObjectProc) {
         DUMP1("called proc is not a native-obj-proc");
         /* string interface */
@@ -8522,7 +8536,8 @@ invoke_tcl_proc(arg)
     Tcl_ResetResult(inf->ptr->ip);
 
     /* Invoke the C procedure */
-#if TCL_MAJOR_VERSION >= 8
+#if TCL_MAJOR_VERSION == 8
+    /* Tcl/Tk 8.0 -- 8.5 */
     if (inf->cmdinfo.isNativeObjectProc) {
         DUMP1("call tcl_proc as a native-obj-proc");
         inf->ptr->return_value
@@ -8532,7 +8547,8 @@ invoke_tcl_proc(arg)
     else
 #endif
     {
-#if TCL_MAJOR_VERSION >= 8
+#if TCL_MAJOR_VERSION == 8
+        /* Tcl/Tk 8.0 -- 8.5 */
         DUMP1("call tcl_proc as not a native-obj-proc");
         inf->ptr->return_value
             = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip,
@@ -8556,6 +8572,8 @@ invoke_tcl_proc(arg)
 #endif
     }
 
+#endif /* Tcl/Tk 8.6 or later || Tcl 7.x, 8.0 -- 8.5 */
+
     DUMP1("end of invoke_tcl_proc");
     return Qnil;
 }
-- 
cgit v1.2.3