Sync up with XEmacs 21.4.17.

[chise/xemacs-chise.git.1] / lisp / dialog-gtk.el

diff --git a/lisp/dialog-gtk.el b/lisp/dialog-gtk.el
index aaca803..1cfdaf2 100644 (file)
--- a/lisp/dialog-gtk.el
+++ b/lisp/dialog-gtk.el
@@ -32,6 +32,31 @@
 (require 'gtk-password-dialog)
 (require 'gtk-file-dialog)
 
+(defun gtk-popup-convert-underscores (str)
+  ;; Convert the XEmacs button accelerator representation to Gtk mnemonic
+  ;; form.  If no accelerator has been provided, put one at the start of the
+  ;; string (this mirrors the behaviour under X). This algorithm is also found
+  ;; in menubar-gtk.c:convert_underscores().
+  (let ((new-str (string))
+       (i 0)
+       (found-accel nil))
+    (while (< i (length str))
+      (let ((c (aref str i)))
+       (cond ((eq c ?%)
+              (setq i (1+ i))
+              (if (and (not (eq (aref str i) ?_)) (not (eq (aref str i) ?%)))
+                  (setq i (1- i)))
+              (setq found-accel 1)
+              )
+             ((eq c ?_)
+               (setq new-str (concat new-str "_")))
+              ))
+       (setq new-str (concat new-str (string (aref str i))))
+       (setq i (1+ i))
+       )
+    (if found-accel new-str (concat "_" new-str)) 
+    ))
+
 (defun popup-builtin-open-dialog (keys)
   ;; Allowed keywords are:
   ;;
@@ -180,7 +205,13 @@
        (dialog nil)                    ; GtkDialog
        (buttons nil)                   ; List of GtkButton objects
        (activep t)
+       (callback nil)
        (flushrightp nil)
+       (length nil)
+       (label nil)
+       (gui-button nil)
+       (accel-group (gtk-accel-group-new))
+       (accel-key nil)
        (errp t))
     (if (not buttons-descr)
        (error 'syntax-error
@@ -206,28 +237,44 @@
                    (if (not (vectorp button))
                        (error "Button descriptor is not a vector: %S" button))
 
-                   (if (< (length button) 3)
-                       (error "Button descriptor is too small: %S" button))
-
-                   (push (gtk-button-new-with-label (aref button 0)) buttons)
-
-                   ;; Need to detect what flavor of descriptor it is.
-                   (if (not (keywordp (aref button 2)))
-                       ;; Simple style... just [ name callback activep ]
-                       ;; We ignore the 'suffix' entry, because that is what
-                       ;; the X code does.
-                       (setq activep (aref button 2))
-                     (let ((ctr 2)
-                           (len (length button)))
-                       (if (logand len 1)
-                           (error
-                            "Button descriptor has an odd number of keywords and values: %S"
-                            button))
-                       (while (< ctr len)
-                         (if (eq (aref button ctr) :active)
-                             (setq activep (aref button (1+ ctr))
-                                   ctr len))
-                         (setq ctr (+ ctr 2)))))
+                   (setq length (length button))
+
+                   (cond
+                    ((= length 1)      ; [ "name" ]
+                     (setq callback nil
+                           activep nil))
+                    ((= length 2)      ; [ "name" callback ]
+                     (setq callback (aref button 1)
+                           activep t))
+                    ((and (or (= length 3) (= length 4))
+                          (not (keywordp (aref button 2))))
+                     ;; [ "name" callback active-p ] or
+                     ;; [ "name" callback active-p suffix ]
+                     ;; We ignore the 'suffix' entry, because that is
+                     ;; what the X code does.
+                     (setq callback (aref button 1)
+                           activep (aref button 2)))
+                    (t                 ; 100% keyword specification
+                     (let ((plist (cdr (mapcar 'identity button))))
+                       (setq activep (plist-get plist :active)
+                             callback (plist-get plist :callback)))))
+
+                   ;; Create the label and determine what the mnemonic key is.
+                   (setq label (gtk-label-new ""))
+                   (setq accel-key (gtk-label-parse-uline label
+                                                          (gtk-popup-convert-underscores (aref button 0))))
+                   ;; Place the label in the button.
+                   (gtk-misc-set-alignment label 0.5 0.5)
+                   (setq gui-button (gtk-button-new))
+                   (gtk-container-add gui-button label)
+                   ;; Add ALT-mnemonic to the dialog's accelerator group.
+                   (gtk-widget-add-accelerator gui-button "clicked" accel-group
+                                               accel-key
+                                               8 ; GDK_MOD1_MASK
+                                               4 ; GTK_ACCEL_LOCKED
+                                               )
+                   
+                   (push gui-button buttons)
                    (gtk-widget-set-sensitive (car buttons) (eval activep))
                    
                    ;; Apply the callback
@@ -243,7 +290,7 @@
                             unread-command-events)
                       (gtk-main-quit)
                       t)
-                    (cons (aref button 1) dialog))
+                    (cons callback dialog))
 
                    (gtk-widget-show (car buttons))
                    (funcall (if flushrightp 'gtk-box-pack-end 'gtk-box-pack-start)
@@ -256,6 +303,9 @@
          (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
          (put dialog 'type 'dialog)
          (put dialog 'modal t)
+         ;; Make the dialog listen for global mnemonic keys.
+         (gtk-window-add-accel-group dialog accel-group)
+
          (gtk-widget-show-all dialog)
          (gtk-main)
          (gtk-widget-destroy dialog)