(C2-3234): Unify HD-KS336910.

[chise/xemacs-chise.git.1] / lisp / menubar.el

diff --git a/lisp/menubar.el b/lisp/menubar.el
index de084e1..b26065c 100644 (file)
--- a/lisp/menubar.el
+++ b/lisp/menubar.el
@@ -20,7 +20,7 @@
 ;; General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
 ;; General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License

-;; along with XEmacs; see the file COPYING.  If not, write to the 
+;; along with XEmacs; see the file COPYING.  If not, write to the

 ;; Free Software Foundation, 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 
 ;; Free Software Foundation, 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 

@@ -96,7 +96,7 @@ See `current-menubar' for a description of the syntax of a menubar."
        ((stringp menuitem)
        (and (string-match "^\\(-+\\|=+\\):\\(.*\\)" menuitem)
             (setq item (match-string 2 menuitem))
        ((stringp menuitem)
        (and (string-match "^\\(-+\\|=+\\):\\(.*\\)" menuitem)
             (setq item (match-string 2 menuitem))

-            (or (member item '(;; Motif-compatible 
+            (or (member item '(;; Motif-compatible

                                "singleLine"
                                "doubleLine"
                                "singleDashedLine"
                                "singleLine"
                                "doubleLine"
                                "singleDashedLine"

@@ -289,14 +289,13 @@ MENU-LEAF is a menubar leaf node.  See the documentation of `current-menubar'.
 BEFORE, if provided, is the name of a menu item before which this item should
  be added, if this item is not on the menu already.  If the item is already
  present, it will not be moved.
 BEFORE, if provided, is the name of a menu item before which this item should
  be added, if this item is not on the menu already.  If the item is already
  present, it will not be moved.

-If IN-MENU is present use that instead of `current-menubar' as the menu to
-change.
-"
+IN-MENU, if provided, means use that instead of `current-menubar' as the
+ menu to change."

   ;; Note easymenu.el uses the fact that menu-leaf can be a submenu.
   (add-menu-item-1 t menu-path menu-leaf before in-menu))
 
 ;; I actually liked the old name better, but the interface has changed too
   ;; Note easymenu.el uses the fact that menu-leaf can be a submenu.
   (add-menu-item-1 t menu-path menu-leaf before in-menu))
 
 ;; I actually liked the old name better, but the interface has changed too

-;; drastically to keep it. --Stig 
+;; drastically to keep it. --Stig

 (defun add-submenu (menu-path submenu &optional before in-menu)
   "Add a menu to the menubar or one of its submenus.
 If the named menu exists already, it is changed.
 (defun add-submenu (menu-path submenu &optional before in-menu)
   "Add a menu to the menubar or one of its submenus.
 If the named menu exists already, it is changed.

@@ -308,33 +307,38 @@ SUBMENU is the new menu to add.
  See the documentation of `current-menubar' for the syntax.
 BEFORE, if provided, is the name of a menu before which this menu should
  be added, if this menu is not on its parent already.  If the menu is already
  See the documentation of `current-menubar' for the syntax.
 BEFORE, if provided, is the name of a menu before which this menu should
  be added, if this menu is not on its parent already.  If the menu is already

- present, it will not be moved."
+ present, it will not be moved.
+IN-MENU, if provided, means use that instead of `current-menubar' as the
+ menu to change."

   (check-menu-syntax submenu nil)
   (add-menu-item-1 nil menu-path submenu before in-menu))
   (check-menu-syntax submenu nil)
   (add-menu-item-1 nil menu-path submenu before in-menu))

-
-(defun purecopy-menubar (x)
-  ;; this calls purecopy on the strings, and the contents of the vectors,
-  ;; but not on the vectors themselves, or the conses - those must be
-  ;; writable.
-  (cond ((vectorp x)
-        (let ((i (length x)))
-          (while (> i 0)
-            (aset x (1- i) (purecopy (aref x (1- i))))
-            (setq i (1- i))))
-        x)
-       ((consp x)
-        (let ((rest x))
-          (while rest
-            (setcar rest (purecopy-menubar (car rest)))
-            (setq rest (cdr rest))))
-        x)
-       (t
-        (purecopy x))))
+;; purespace is no more, so this function is unnecessary
+;(defun purecopy-menubar (x)
+;  ;; this calls purecopy on the strings, and the contents of the vectors,
+;  ;; but not on the vectors themselves, or the conses - those must be
+;  ;; writable.
+;  (cond ((vectorp x)
+;       (let ((i (length x)))
+;         (while (> i 0)
+;           (aset x (1- i) (purecopy (aref x (1- i))))
+;           (setq i (1- i))))
+;       x)
+;      ((consp x)
+;       (let ((rest x))
+;         (while rest
+;           (setcar rest (purecopy-menubar (car rest)))
+;           (setq rest (cdr rest))))
+;       x)
+;      (t
+;       (purecopy x))))

 
 (defun delete-menu-item (path &optional from-menu)
   "Remove the named menu item from the menu hierarchy.
 
 (defun delete-menu-item (path &optional from-menu)
   "Remove the named menu item from the menu hierarchy.

-PATH is a list of strings which identify the position of the menu item in 
-the menu hierarchy.  The documentation of `add-submenu' describes menu-paths."
+PATH is a list of strings which identify the position of the menu item
+in the menu hierarchy.  The documentation of `add-submenu' describes
+menu paths.
+FROM-MENU, if provided, means use that instead of `current-menubar'
+as the menu to change."

   (let* ((pair (condition-case nil (find-menu-item (or from-menu
                                                       current-menubar) path)
                 (error nil)))
   (let* ((pair (condition-case nil (find-menu-item (or from-menu
                                                       current-menubar) path)
                 (error nil)))

@@ -352,13 +356,12 @@ the menu hierarchy.  The documentation of `add-submenu' describes menu-paths."
 
 (defun relabel-menu-item (path new-name)
   "Change the string of the specified menu item.
 
 (defun relabel-menu-item (path new-name)
   "Change the string of the specified menu item.

-PATH is a list of strings which identify the position of the menu item in 
+PATH is a list of strings which identify the position of the menu item in

 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"

-under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the 
+under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the

 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\".
 NEW-NAME is the string that the menu item will be printed as from now on."
 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\".
 NEW-NAME is the string that the menu item will be printed as from now on."

-  (or (stringp new-name)
-      (setq new-name (signal 'wrong-type-argument (list 'stringp new-name))))
+  (check-type new-name string)

   (let* ((menubar current-menubar)
          (pair (find-menu-item menubar path))
          (item (car pair))
   (let* ((menubar current-menubar)
          (pair (find-menu-item menubar path))
          (item (car pair))

@@ -380,7 +383,7 @@ NEW-NAME is the string that the menu item will be printed as from now on."
 ;; into the menubar if we didn't want people to use 'em?
 ;; x-font-menu.el is the only known offender right now and that ought to be
 ;; rehashed a bit.
 ;; into the menubar if we didn't want people to use 'em?
 ;; x-font-menu.el is the only known offender right now and that ought to be
 ;; rehashed a bit.

-;; 
+;;

 
 (defun enable-menu-item-1 (path toggle-p on-p)
   (let (menu item)
 
 (defun enable-menu-item-1 (path toggle-p on-p)
   (let (menu item)

@@ -430,33 +433,33 @@ NEW-NAME is the string that the menu item will be printed as from now on."
 
 (defun enable-menu-item (path)
   "Make the named menu item be selectable.
 
 (defun enable-menu-item (path)
   "Make the named menu item be selectable.

-PATH is a list of strings which identify the position of the menu item in 
+PATH is a list of strings which identify the position of the menu item in

 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"

-under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the 
+under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the

 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
   (enable-menu-item-1 path nil t))
 
 (defun disable-menu-item (path)
   "Make the named menu item be unselectable.
 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
   (enable-menu-item-1 path nil t))
 
 (defun disable-menu-item (path)
   "Make the named menu item be unselectable.

-PATH is a list of strings which identify the position of the menu item in 
+PATH is a list of strings which identify the position of the menu item in

 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"

-under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the 
+under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the

 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
   (enable-menu-item-1 path nil nil))
 
 (defun select-toggle-menu-item (path)
   "Make the named toggle- or radio-style menu item be in the `selected' state.
 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
   (enable-menu-item-1 path nil nil))
 
 (defun select-toggle-menu-item (path)
   "Make the named toggle- or radio-style menu item be in the `selected' state.

-PATH is a list of strings which identify the position of the menu item in 
+PATH is a list of strings which identify the position of the menu item in

 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"

-under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the 
+under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the

 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
   (enable-menu-item-1 path t t))
 
 (defun deselect-toggle-menu-item (path)
  "Make the named toggle- or radio-style menu item be in the `unselected' state.
 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
   (enable-menu-item-1 path t t))
 
 (defun deselect-toggle-menu-item (path)
  "Make the named toggle- or radio-style menu item be in the `unselected' state.

-PATH is a list of strings which identify the position of the menu item in 
+PATH is a list of strings which identify the position of the menu item in

 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"

-under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the 
+under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the

 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
   (enable-menu-item-1 path t nil))
 
 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
   (enable-menu-item-1 path t nil))
 

@@ -520,41 +523,46 @@ button was clicked."
                                     (extent-property extent 'context-menu))
                                 context-extents))))
     (popup-menu
                                     (extent-property extent 'context-menu))
                                 context-extents))))
     (popup-menu

-     (cond ((and global-popup-menu mode-popup-menu)
+     (progn

            ;; Merge global-popup-menu and mode-popup-menu
            ;; Merge global-popup-menu and mode-popup-menu

-           (check-menu-syntax mode-popup-menu)
-           (let* ((title (car mode-popup-menu))
-                  (items (cdr mode-popup-menu))
+           (and mode-popup-menu (check-menu-syntax mode-popup-menu))
+           (let* ((mode-title (and (stringp (car mode-popup-menu))
+                                   (car mode-popup-menu)))
+                  (mode-items (if mode-title (cdr mode-popup-menu)
+                                mode-popup-menu))
+                  (global-title (and (stringp (car global-popup-menu))
+                                     (car global-popup-menu)))
+                  (global-items (if global-title (cdr global-popup-menu)
+                                  global-popup-menu))

                   mode-filters)
              ;; Strip keywords from local menu for attaching them at the top
                   mode-filters)
              ;; Strip keywords from local menu for attaching them at the top

-             (while (and items
-                         (keywordp (car items)))
+             (while (and mode-items
+                         (keywordp (car mode-items)))

                ;; Push both keyword and its argument.
                ;; Push both keyword and its argument.

-               (push (pop items) mode-filters)
-               (push (pop items) mode-filters))
+               (push (pop mode-items) mode-filters)
+               (push (pop mode-items) mode-filters))

              (setq mode-filters (nreverse mode-filters))
              ;; If mode-filters contains a keyword already present in
              ;; `global-popup-menu', you will probably lose.
              (setq mode-filters (nreverse mode-filters))
              ;; If mode-filters contains a keyword already present in
              ;; `global-popup-menu', you will probably lose.

-             (append (list (car global-popup-menu))
+             (append (cond ((not popup-menu-titles) (list ""))
+                           (mode-title (list mode-title))
+                           (global-title (list global-title))
+                           (t (list "")))

                      mode-filters
                      mode-filters

-                     (cdr global-popup-menu)
-                     '("---" "---")
-                     (if popup-menu-titles (list title))
-                     (if popup-menu-titles '("---" "---"))
-                     items
-                     context-menu-items)))
-          (t
-           (append
-            (or mode-popup-menu
-                global-popup-menu
-                (error "No menu defined in this buffer"))
-            context-menu-items))))
+                     context-menu-items
+                     (and context-menu-items mode-items '("---"))
+                     mode-items
+                     (and (or context-menu-items mode-items)
+                          global-items '("---" "---"))
+                     (and global-title (list global-title))
+                     global-items
+                     ))))

 
     (while (popup-up-p)
       (dispatch-event (next-event)))
 
     ))
 
     (while (popup-up-p)
       (dispatch-event (next-event)))
 
     ))

-  
+

 (defun popup-buffer-menu (event)
   "Pop up a copy of the Buffers menu (from the menubar) where the mouse is clicked."
   (interactive "e")
 (defun popup-buffer-menu (event)
   "Pop up a copy of the Buffers menu (from the menubar) where the mouse is clicked."
   (interactive "e")

@@ -663,6 +671,10 @@ If no response was received, nil is returned.
 
 MENU-DESC and EVENT are as in the call to `popup-menu'."
   ;; partially stolen from w3
 
 MENU-DESC and EVENT are as in the call to `popup-menu'."
   ;; partially stolen from w3

+
+  ;; This function is way gross and assumes to much about menu
+  ;; processing that is X specific. Under mswindows popup menus behave
+  ;; in reasonable ways that you can't obstruct.

   (let ((echo-keystrokes 0)
        new-event)
     (popup-menu menu-desc event)
   (let ((echo-keystrokes 0)
        new-event)
     (popup-menu menu-desc event)

@@ -671,14 +683,22 @@ MENU-DESC and EVENT are as in the call to `popup-menu'."
        (setq new-event (next-command-event new-event))
        (cond ((misc-user-event-p new-event)
               (throw 'popup-done new-event))
        (setq new-event (next-command-event new-event))
        (cond ((misc-user-event-p new-event)
               (throw 'popup-done new-event))

-             ((not (popup-up-p))
-              (setq unread-command-events (cons new-event
-                                                unread-command-events))
-              (throw 'popup-done nil))

              ((button-release-event-p new-event);; don't beep twice
               nil)
              ((button-release-event-p new-event);; don't beep twice
               nil)

-             ((event-matches-key-specifier-p (quit-char))
+             ;; It shows how bogus this function is that the event
+             ;; arg could be missing and no-one noticed ...
+             ((event-matches-key-specifier-p new-event (quit-char))

               (signal 'quit nil))
               (signal 'quit nil))

+             ;; mswindows has no pop-down processing (selection is
+             ;; atomic) so doing anything more makes no sense. Since
+             ;; popup-up-p is always false under mswindows, this
+             ;; function has been ordered to do essentially X-specifc
+             ;; processing after this check.
+             ((not (popup-up-p))       
+              (setq unread-command-events (cons new-event
+                                                unread-command-events))
+              (throw 'popup-done nil))
+             ;; mswindows never gets here

              (t
               (beep)
               (message "please make a choice from the menu.")))))))
              (t
               (beep)
               (message "please make a choice from the menu.")))))))