* ext/tk/tcltklib.c (ip_make_menu_embeddable): help to make a menu

  widget embeddable (pack, grid, and so on) like as a general widget.
  However, an embeddable menu may require to be definied some event
  bindings for general use.
* ext/tk/lib/tk/event.rb: [bug fix] Tk.callback_break and
  Tk.callback_continue don't work on MultiTkIp.
* ext/tk/lib/multi-tk.rb: ditto.
* ext/tk/lib/tk.rb: lack of Tk.callback_return.
* ext/tk/lib/tk/menu.rb: improve creating clone menus.


git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/branches/ruby_1_8@10461 b2dd03c8-39d4-4d8f-98ff-823fe69b080e

5 files changed, 301 insertions, 11 deletions

diff --git a/ext/tk/lib/multi-tk.rb b/ext/tk/lib/multi-tk.rb
index 408dd0fc30..42f92c3b55 100644
--- a/ext/tk/lib/multi-tk.rb
+++ b/ext/tk/lib/multi-tk.rb
@@ -158,7 +158,9 @@ class MultiTkIp
         backup_ip = current['callback_ip']
         current['callback_ip'] = @ip
         begin
-          @ip.cb_eval(@cmd, *args)
+          ret = @ip.cb_eval(@cmd, *args)
+          fail ret if ret.kind_of?(Exception)
+          ret
         rescue TkCallbackBreak, TkCallbackContinue => e
           fail e
 	rescue SecurityError => e
@@ -175,6 +177,8 @@ class MultiTkIp
             fail e
           end
         rescue Exception => e
+          fail e if e.message =~ /^TkCallback/
+
           if @ip.safe?
 	    if @ip.respond_to?(:cb_error)
               @ip.cb_error(e)
@@ -662,6 +666,8 @@ class MultiTkIp
     @interp = TclTkIp.new(name, _keys2opts(keys))
     @ip_name = nil
 
+    @callback_status = [].taint
+
     @system = Object.new
 
     @wait_on_mainloop = [true, 0].taint
@@ -1057,6 +1063,8 @@ class MultiTkIp
     @cb_error_proc.taint unless @cb_error_proc.tainted?
     @evloop_thread.taint unless @evloop_thread.tainted?
 
+    @callback_status = []
+
     name, safe, safe_opts, tk_opts = _parse_slaveopts(keys)
 
     safe = 4 if safe && !safe.kind_of?(Fixnum)
@@ -1487,6 +1495,7 @@ class MultiTkIp
     @@CB_ENTRY_CLASS.new(__getip, cmd).freeze
   end
 
+=begin
   def cb_eval(cmd, *args)
     #self.eval_callback{ TkComm._get_eval_string(TkUtil.eval_cmd(cmd, *args)) }
     #ret = self.eval_callback{ TkComm._get_eval_string(TkUtil.eval_cmd(cmd, *args)) }
@@ -1499,8 +1508,62 @@ class MultiTkIp
     end
     ret
   end
-end
+=end
+  def cb_eval(cmd, *args)
+    self.eval_callback(*args){|safe, *params|
+      $SAFE=safe if $SAFE < safe
+      # TkUtil.eval_cmd(cmd, *params)
+      TkComm._get_eval_string(TkUtil.eval_cmd(cmd, *params))
+    }
+  end
+=begin
+  def cb_eval(cmd, *args)
+    @callback_status[0] ||= TkVariable.new
+    @callback_status[1] ||= TkVariable.new
+    st, val = @callback_status
+    th = Thread.new{
+      self.eval_callback(*args){|safe, *params|
+        #p [status, val, safe, *params]
+        $SAFE=safe if $SAFE < safe
+        begin
+          TkComm._get_eval_string(TkUtil.eval_cmd(cmd, *params))
+        rescue TkCallbackContinue
+          st.value = 4
+        rescue TkCallbackBreak
+          st.value = 3
+        rescue TkCallbackReturn
+          st.value = 2
+        rescue Exception => e
+          val.value = e.message
+          st.value = 1
+        else
+          st.value = 0
+        end
+      }
+    }
+    begin
+      st.wait
+      status = st.numeric
+      retval = val.value
+    rescue => e
+      fail e
+    end
+
+    if status == 1
+      fail RuntimeError, retval
+    elsif status == 2
+      fail TkCallbackReturn, "Tk callback returns 'return' status"
+    elsif status == 3
+      fail TkCallbackBreak, "Tk callback returns 'break' status"
+    elsif status == 4
+      fail TkCallbackContinue, "Tk callback returns 'continue' status"
+    else
+      ''
+    end
+  end
+=end
 
+end
 
 # evaluate a procedure on the proper interpreter
 class MultiTkIp
@@ -1969,6 +2032,10 @@ class << MultiTkIp
     __getip._unset_global_var2(var, idx)
   end
 
+  def _make_menu_embeddable(menu_path)
+    __getip._make_menu_embeddable(menu_path)
+  end
+
   def _split_tklist(str)
     __getip._split_tklist(str)
   end
@@ -2410,6 +2477,11 @@ class MultiTkIp
     @interp._unset_global_var2(var, idx)
   end
 
+  def _make_menu_embeddable(menu_path)
+    raise SecurityError, "no permission to manipulate" unless self.manipulable?
+    @interp._make_menu_embeddable(menu_path)
+  end
+
   def _split_tklist(str)
     raise SecurityError, "no permission to manipulate" unless self.manipulable?
     @interp._split_tklist(str)
diff --git a/ext/tk/lib/tk.rb b/ext/tk/lib/tk.rb
index c80dc45ea5..4504d1d2ec 100644
--- a/ext/tk/lib/tk.rb
+++ b/ext/tk/lib/tk.rb
@@ -1295,6 +1295,10 @@ module TkCore
     fail TkCallbackContinue, "Tk callback returns 'continue' status"
   end
 
+  def callback_return
+    fail TkCallbackReturn, "Tk callback returns 'return' status"
+  end
+
   def TkCore.callback(*arg)
     begin
       if TkCore::INTERP.tk_cmd_tbl.kind_of?(Hash)
@@ -4559,7 +4563,7 @@ end
 #Tk.freeze
 
 module Tk
-  RELEASE_DATE = '2006-06-27'.freeze
+  RELEASE_DATE = '2006-07-03'.freeze
 
   autoload :AUTO_PATH,        'tk/variable'
   autoload :TCL_PACKAGE_PATH, 'tk/variable'
diff --git a/ext/tk/lib/tk/event.rb b/ext/tk/lib/tk/event.rb
index af05dc96de..70a1e38bbe 100644
--- a/ext/tk/lib/tk/event.rb
+++ b/ext/tk/lib/tk/event.rb
@@ -416,10 +416,18 @@ module TkEvent
         id = install_cmd(proc{|*arg|
           ex_args = []
           extra_args_tbl.reverse_each{|conv| ex_args << conv.call(arg.pop)}
-          TkUtil.eval_cmd(cmd, *(ex_args.concat(klass.scan_args(keys, arg))))
+          begin
+            TkUtil.eval_cmd(cmd, *(ex_args.concat(klass.scan_args(keys, arg))))
+          rescue Exception=>e
+            if TkCore::INTERP.kind_of?(TclTkIp)
+              fail e
+            else
+              # MultiTkIp
+              fail Exception, "#{e.class}: #{e.message.dup}"
+            end
+          end
         })
       end
-      id + ' ' + args
     else
       keys, args = klass._get_all_subst_keys
 
@@ -431,11 +439,46 @@ module TkEvent
         id = install_cmd(proc{|*arg|
           ex_args = []
           extra_args_tbl.reverse_each{|conv| ex_args << conv.call(arg.pop)}
-          TkUtil.eval_cmd(cmd, 
-                          *(ex_args << klass.new(*klass.scan_args(keys, arg))))
+          begin
+            TkUtil.eval_cmd(cmd, *(ex_args << klass.new(*klass.scan_args(keys, arg))))
+          rescue Exception=>e
+            if TkCore::INTERP.kind_of?(TclTkIp)
+              fail e
+            else
+              # MultiTkIp
+              fail Exception, "#{e.class}: #{e.message.dup}"
+            end
+          end
         })
       end
+    end
+
+    if TkCore::INTERP.kind_of?(TclTkIp)
       id + ' ' + args
+    else
+      # MultiTkIp
+      "if {[set st [catch {#{id} #{args}} ret]] != 0} {
+         if {$st == 4} {
+           return -code continue $ret
+         } elseif {$st == 3} {
+           return -code break $ret
+         } elseif {$st == 2} {
+           return -code return $ret
+         } elseif {[regexp {^Exception: (TkCallbackContinue: .*)$} \
+                                                               $ret m msg]} {
+           return -code continue $msg
+         } elseif {[regexp {^Exception: (TkCallbackBreak: .*)$} $ret m msg]} {
+           return -code break $msg
+         } elseif {[regexp {^Exception: (TkCallbackReturn: .*)$} $ret m msg]} {
+           return -code return $msg
+         } elseif {[regexp {^Exception: (\\S+: .*)$} $ret m msg]} {
+           return -code return $msg
+         } else {
+           return -code error $ret
+         }
+       } else {
+          set ret
+       }"
     end
   end
 
diff --git a/ext/tk/lib/tk/menu.rb b/ext/tk/lib/tk/menu.rb
index be8ec2ddee..ddddc8e53e 100644
--- a/ext/tk/lib/tk/menu.rb
+++ b/ext/tk/lib/tk/menu.rb
@@ -43,6 +43,7 @@ module TkMenuEntryConfig
 end
 
 class TkMenu<TkWindow
+  include Wm
   include TkMenuEntryConfig
   extend TkMenuSpec
 
@@ -115,6 +116,36 @@ class TkMenu<TkWindow
   def add_separator(keys=nil)
     add('separator', keys)
   end
+
+  def clone_menu(*args)
+    if args[0].kind_of?(TkWindow)
+      parent = args.shift
+    else
+      parent = self
+    end
+
+    if args[0].kind_of?(String) || args[0].kind_of?(Symbol) # menu type
+      type = args.shift
+    else
+      type = None # 'normal'
+    end
+
+    if args[0].kind_of?(Hash)
+      keys = _symbolkey2str(args.shift)
+    else
+      keys = {}
+    end
+
+    parent = keys.delete('parent') if keys.has_key?('parent')
+    type = keys.delete('type') if keys.has_key?('type')
+
+    if keys.empty?
+      TkMenuClone.new(self, parent, type)
+    else
+      TkMenuClone.new(self, parent, type, keys)
+    end
+  end
+
   def index(idx)
     ret = tk_send_without_enc('index', _get_eval_enc_str(idx))
     (ret == 'none')? nil: number(ret)
@@ -352,6 +383,7 @@ end
 
 
 class TkMenuClone<TkMenu
+=begin
   def initialize(parent, type=None)
     widgetname = nil
     if parent.kind_of? Hash
@@ -367,8 +399,44 @@ class TkMenuClone<TkMenu
     install_win(@parent.path, widgetname)
     tk_call_without_enc(@parent.path, 'clone', @path, type)
   end
-end
+=end
+  def initialize(src_menu, *args)
+    widgetname = nil
+
+    if args[0].kind_of?(TkWindow)  # parent window
+      parent = args.shift
+    else
+      parent = src_menu
+    end
+
+    if args[0].kind_of?(String) || args[0].kind_of?(Symbol)  # menu type
+      type = args.shift
+    else
+      type = None  # 'normal'
+    end
+
+    if args[0].kind_of?(Hash)
+      keys = _symbolkey2str(args.shift)
+      parent = keys.delete('parent') if keys.has_key?('parent')
+      widgetname = keys.delete('widgetname')
+      type = keys.delete('type') if keys.has_key?('type')
+    else
+      keys = nil
+    end
 
+    @src_menu = src_menu
+    @parent = parent
+    @type = type
+    install_win(@parent.path, widgetname)
+    tk_call_without_enc(@src_menu.path, 'clone', @path, @type)
+    configure(keys) if keys && !keys.empty?
+  end
+
+  def source_menu
+    @src_menu
+  end
+end
+TkCloneMenu = TkMenuClone
 
 module TkSystemMenu
   def initialize(parent, keys=nil)
diff --git a/ext/tk/tcltklib.c b/ext/tk/tcltklib.c
index 183486a3a6..5c986f1dcf 100644
--- a/ext/tk/tcltklib.c
+++ b/ext/tk/tcltklib.c
@@ -4,7 +4,7 @@
  *              Oct. 24, 1997   Y. Matsumoto
  */
 
-#define TCLTKLIB_RELEASE_DATE "2006-06-26"
+#define TCLTKLIB_RELEASE_DATE "2006-07-03"
 
 #include "ruby.h"
 #include "rubysig.h"
@@ -129,7 +129,10 @@ tcl_eval(interp, cmd)
     const char *cmd; /* don't have to be writable */
 {
     char *buf = strdup(cmd);
-    const int ret = Tcl_Eval(interp, buf);
+    int ret;
+
+    Tcl_AllowExceptions(interp);
+    ret = Tcl_Eval(interp, buf);
     free(buf);
     return ret;
 }
@@ -143,7 +146,10 @@ tcl_global_eval(interp, cmd)
     const char *cmd; /* don't have to be writable */
 {
     char *buf = strdup(cmd);
-    const int ret = Tcl_GlobalEval(interp, buf);
+    int ret;
+
+    Tcl_AllowExceptions(interp);
+    ret = Tcl_GlobalEval(interp, buf);
     free(buf);
     return ret;
 }
@@ -5591,6 +5597,7 @@ call_tcl_eval(arg)
 {
     struct call_eval_info *inf = (struct call_eval_info *)arg;
 
+    Tcl_AllowExceptions(inf->ptr->ip);
     inf->ptr->return_value = Tcl_EvalObj(inf->ptr->ip, inf->cmd);
 
     return Qnil;
@@ -7721,6 +7728,98 @@ tcltklib_compile_info()
     return ret;
 }
 
+/*###############################################*/
+
+/*
+ *   The following is based on tkMenu.[ch] 
+ *   of Tcl/Tk (>=8.0) source code.
+ */
+#if TCL_MAJOR_VERSION >= 8
+
+#define MASTER_MENU             0
+#define TEAROFF_MENU            1
+#define MENUBAR                 2
+
+struct dummy_TkMenuEntry {
+    int type;
+    struct dummy_TkMenu *menuPtr;
+    /* , and etc.   */
+};
+
+struct dummy_TkMenu {
+    Tk_Window tkwin;
+    Display *display;
+    Tcl_Interp *interp;
+    Tcl_Command widgetCmd;
+    struct dummy_TkMenuEntry **entries;
+    int numEntries;
+    int active;
+    int menuType;     /* MASTER_MENU, TEAROFF_MENU, or MENUBAR */
+    Tcl_Obj *menuTypePtr;
+    /* , and etc.   */
+};
+
+struct dummy_TkMenuRef {
+    struct dummy_TkMenu *menuPtr;
+    char *dummy1;
+    char *dummy2;
+    char *dummy3;
+};
+
+EXTERN struct dummy_TkMenuRef *TkFindMenuReferences(Tcl_Interp*, char*);
+
+#endif
+
+static VALUE
+ip_make_menu_embeddable(interp, menu_path)
+    VALUE interp;
+    VALUE menu_path;
+{
+#if TCL_MAJOR_VERSION >= 8
+    struct tcltkip *ptr = get_ip(interp);
+    struct dummy_TkMenuRef *menuRefPtr;
+
+    StringValue(menu_path);
+
+    menuRefPtr = TkFindMenuReferences(ptr->ip, RSTRING(menu_path)->ptr);
+    if (menuRefPtr == (struct dummy_TkMenuRef *) NULL) {
+        rb_raise(rb_eArgError, "not a menu widget, or invalid widget path");
+    }
+
+    if (menuRefPtr->menuPtr == (struct dummy_TkMenu *) NULL) {
+        rb_raise(rb_eRuntimeError, 
+		 "invalid menu widget (maybe already destroyed)");
+    }
+
+    if ((menuRefPtr->menuPtr)->menuType != MENUBAR) {
+        rb_raise(rb_eRuntimeError, 
+		 "target menu widget must be a MENUBAR type");
+    }
+
+    (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU;
+#if 0  /* cause SEGV */
+    {
+       /* char *s = "tearoff"; */
+       char *s = "normal";
+       /* Tcl_SetStringObj((menuRefPtr->menuPtr)->menuTypePtr, s, strlen(s));*/
+       (menuRefPtr->menuPtr)->menuTypePtr = Tcl_NewStringObj(s, strlen(s));
+       /* (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU; */
+       (menuRefPtr->menuPtr)->menuType = MASTER_MENU;
+    }
+#endif
+
+    TkEventuallyRecomputeMenu(menuRefPtr->menuPtr);
+    TkEventuallyRedrawMenu(menuRefPtr->menuPtr, 
+			   (struct dummy_TkMenuEntry *)NULL);
+
+#else /* TCL_MAJOR_VERSION <= 7 */
+    rb_notimplement();
+#endif
+
+    return interp;
+}
+
+/*###############################################*/
 
 /*---- initialization ----*/
 void
@@ -7918,6 +8017,10 @@ Init_tcltklib()
 
     /* --------------------------------------------------------------- */
 
+    rb_define_method(ip, "_make_menu_embeddable", ip_make_menu_embeddable, 1);
+
+    /* --------------------------------------------------------------- */
+
     rb_define_method(ip, "_split_tklist", ip_split_tklist, 1);
     rb_define_method(ip, "_merge_tklist", lib_merge_tklist, -1);
     rb_define_method(ip, "_conv_listelement", lib_conv_listelement, 1);