X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/cbee283dd7dd655124e81a6bd555506476180b5d..1650d7102ae8ea943e4197b7d91198640f0e0ff6:/lisp/tool-bar.el

diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el
index a224b4375b..f0dfee25b4 100644
--- a/lisp/tool-bar.el
+++ b/lisp/tool-bar.el
@@ -1,17 +1,17 @@
 ;;; tool-bar.el --- setting up the tool bar
-;;
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
-;;
+
+;; Copyright (C) 2000-2016 Free Software Foundation, Inc.
+
 ;; Author: Dave Love <fx@gnu.org>
 ;; Keywords: mouse frames
+;; Package: emacs
 
 ;; This file is part of GNU Emacs.
 
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -19,9 +19,7 @@
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;; Commentary:
 
@@ -45,21 +43,30 @@
 ;; Deleting it means invoking this command won't work
 ;; when you are on a tty.  I hope that won't cause too much trouble -- rms.
 (define-minor-mode tool-bar-mode
-  "Toggle use of the tool bar.
-With numeric ARG, display the tool bar if and only if ARG is positive.
+  "Toggle the tool bar in all graphical frames (Tool Bar mode).
+With a prefix argument ARG, enable Tool Bar mode if ARG is
+positive, and disable it otherwise.  If called from Lisp, enable
+Tool Bar mode if ARG is omitted or nil.
 
 See `tool-bar-add-item' and `tool-bar-add-item-from-menu' for
 conveniently adding tool bar items."
-  :init-value nil
+  :init-value t
   :global t
-  :group 'mouse
-  :group 'frames
-  (and (display-images-p)
-       (modify-all-frames-parameters (list (cons 'tool-bar-lines
-						 (if tool-bar-mode 1 0))))
-       (if (and tool-bar-mode
-		(display-graphic-p))
-	   (tool-bar-setup))))
+  ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
+  :variable tool-bar-mode
+  (let ((val (if tool-bar-mode 1 0)))
+    (dolist (frame (frame-list))
+      (set-frame-parameter frame 'tool-bar-lines val))
+    ;; If the user has given `default-frame-alist' a `tool-bar-lines'
+    ;; parameter, replace it.
+    (if (assq 'tool-bar-lines default-frame-alist)
+	(setq default-frame-alist
+	      (cons (cons 'tool-bar-lines val)
+		    (assq-delete-all 'tool-bar-lines
+				     default-frame-alist)))))
+  (and tool-bar-mode
+       (= 1 (length (default-value 'tool-bar-map))) ; not yet setup
+       (tool-bar-setup)))
 
 ;;;###autoload
 ;; Used in the Show/Hide menu, to have the toggle reflect the current frame.
@@ -71,24 +78,50 @@ See `tool-bar-mode' for more information."
       (tool-bar-mode (if (> (frame-parameter nil 'tool-bar-lines) 0) 0 1))
     (tool-bar-mode arg)))
 
-;;;###autoload
-;; We want to pretend the toolbar by standard is on, as this will make
-;; customize consider disabling the toolbar a customization, and save
-;; that.  We could do this for real by setting :init-value above, but
-;; that would turn on the toolbar in MS Windows where it is currently
-;; useless, and it would overwrite disabling the tool bar from X
-;; resources.  If anyone want to implement this in a cleaner way,
-;; please do so.
-;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2002-02-21.
-(put 'tool-bar-mode 'standard-value '(t))
-
 (defvar tool-bar-map (make-sparse-keymap)
   "Keymap for the tool bar.
 Define this locally to override the global tool bar.")
 
 (global-set-key [tool-bar]
-		'(menu-item "tool bar" ignore
-			    :filter (lambda (ignore) tool-bar-map)))
+		`(menu-item ,(purecopy "tool bar") ignore
+			    :filter tool-bar-make-keymap))
+
+(declare-function image-mask-p "image.c" (spec &optional frame))
+
+(defconst tool-bar-keymap-cache (make-hash-table :weakness t :test 'equal))
+
+(defun tool-bar-make-keymap (&optional _ignore)
+  "Generate an actual keymap from `tool-bar-map'.
+Its main job is to figure out which images to use based on the display's
+color capability and based on the available image libraries."
+  (let ((key (cons (frame-terminal) tool-bar-map)))
+    (or (gethash key tool-bar-keymap-cache)
+	(puthash key (tool-bar-make-keymap-1) tool-bar-keymap-cache))))
+
+(defun tool-bar-make-keymap-1 ()
+  "Generate an actual keymap from `tool-bar-map', without caching."
+  (mapcar (lambda (bind)
+            (let (image-exp plist)
+              (when (and (eq (car-safe (cdr-safe bind)) 'menu-item)
+			 ;; For the format of menu-items, see node
+			 ;; `Extended Menu Items' in the Elisp manual.
+			 (setq plist (nthcdr (if (consp (nth 4 bind)) 5 4)
+					     bind))
+			 (setq image-exp (plist-get plist :image))
+			 (consp image-exp)
+			 (not (eq (car image-exp) 'image))
+			 (fboundp (car image-exp)))
+		(if (not (display-images-p))
+		    (setq bind nil)
+		  (let ((image (eval image-exp)))
+		    (unless (and image (image-mask-p image))
+		      (setq image (append image '(:mask heuristic))))
+		    (setq bind (copy-sequence bind)
+			  plist (nthcdr (if (consp (nth 4 bind)) 5 4)
+					bind))
+		    (plist-put plist :image image))))
+	      bind))
+	  tool-bar-map))
 
 ;;;###autoload
 (defun tool-bar-add-item (icon def key &rest props)
@@ -99,7 +132,7 @@ PROPS are additional items to add to the menu item specification.  See
 Info node `(elisp)Tool Bar'.  Items are added from left to right.
 
 ICON is the base name of a file containing the image to use.  The
-function will first try to use low-color/ICON.xpm if display-color-cells
+function will first try to use low-color/ICON.xpm if `display-color-cells'
 is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
 ICON.xbm, using `find-image'.
 
@@ -107,6 +140,26 @@ Use this function only to make bindings in the global value of `tool-bar-map'.
 To define items in any other map, use `tool-bar-local-item'."
   (apply 'tool-bar-local-item icon def key tool-bar-map props))
 
+(defun tool-bar--image-expression (icon)
+  "Return an expression that evaluates to an image spec for ICON."
+  (let* ((fg (face-attribute 'tool-bar :foreground))
+	 (bg (face-attribute 'tool-bar :background))
+	 (colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
+			(if (eq bg 'unspecified) nil (list :background bg))))
+	 (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
+	 (xpm-lo-spec (list :type 'xpm :file
+			    (concat "low-color/" icon ".xpm")))
+	 (pbm-spec (append (list :type 'pbm :file
+                                 (concat icon ".pbm")) colors))
+	 (xbm-spec (append (list :type 'xbm :file
+                                 (concat icon ".xbm")) colors)))
+    `(find-image (cond ((not (display-color-p))
+			',(list pbm-spec xbm-spec xpm-lo-spec xpm-spec))
+		       ((< (display-color-cells) 256)
+			',(list xpm-lo-spec xpm-spec pbm-spec xbm-spec))
+		       (t
+			',(list xpm-spec pbm-spec xbm-spec))))))
+
 ;;;###autoload
 (defun tool-bar-local-item (icon def key map &rest props)
   "Add an item to the tool bar in map MAP.
@@ -116,32 +169,13 @@ PROPS are additional items to add to the menu item specification.  See
 Info node `(elisp)Tool Bar'.  Items are added from left to right.
 
 ICON is the base name of a file containing the image to use.  The
-function will first try to use low-color/ICON.xpm if display-color-cells
+function will first try to use low-color/ICON.xpm if `display-color-cells'
 is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
 ICON.xbm, using `find-image'."
-  (let* ((fg (face-attribute 'tool-bar :foreground))
-	 (bg (face-attribute 'tool-bar :background))
-	 (colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
-			(if (eq bg 'unspecified) nil (list :background bg))))
-	 (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
-	 (xpm-lo-spec (if (> (display-color-cells) 256)
-			  nil
-			(list :type 'xpm :file
-                              (concat "low-color/" icon ".xpm"))))
-	 (pbm-spec (append (list :type 'pbm :file
-                                 (concat icon ".pbm")) colors))
-	 (xbm-spec (append (list :type 'xbm :file
-                                 (concat icon ".xbm")) colors))
-	 (image (find-image
-		(if (display-color-p)
-		    (list xpm-lo-spec xpm-spec pbm-spec xbm-spec)
-		  (list pbm-spec xbm-spec xpm-lo-spec xpm-spec)))))
-
-    (when (and (display-images-p) image)
-      (unless (image-mask-p image)
-	(setq image (append image '(:mask heuristic))))
-      (define-key-after map (vector key)
-	`(menu-item ,(symbol-name key) ,def :image ,image ,@props)))))
+  (let* ((image-exp (tool-bar--image-expression icon)))
+    (define-key-after map (vector key)
+      `(menu-item ,(symbol-name key) ,def :image ,image-exp ,@props))
+    (force-mode-line-update)))
 
 ;;;###autoload
 (defun tool-bar-add-item-from-menu (command icon &optional map &rest props)
@@ -174,121 +208,100 @@ holds a keymap."
     (setq from-map global-map))
   (let* ((menu-bar-map (lookup-key from-map [menu-bar]))
 	 (keys (where-is-internal command menu-bar-map))
-	 (fg (face-attribute 'tool-bar :foreground))
-	 (bg (face-attribute 'tool-bar :background))
-	 (colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
-			(if (eq bg 'unspecified) nil (list :background bg))))
-	 (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
-	 (xpm-lo-spec (if (> (display-color-cells) 256)
-			  nil
-			(list :type 'xpm :file
-                              (concat "low-color/" icon ".xpm"))))
-	 (pbm-spec (append (list :type 'pbm :file
-                                 (concat icon ".pbm")) colors))
-	 (xbm-spec (append (list :type 'xbm :file
-                                 (concat icon ".xbm")) colors))
-	 (spec (if (display-color-p)
-		   (list xpm-lo-spec xpm-spec pbm-spec xbm-spec)
-		 (list pbm-spec xbm-spec xpm-lo-spec xpm-spec)))
-	 (image (find-image spec))
+	 (image-exp (tool-bar--image-expression icon))
 	 submap key)
-    (when (and (display-images-p) image)
-      ;; We'll pick up the last valid entry in the list of keys if
-      ;; there's more than one.
-      (dolist (k keys)
-	;; We're looking for a binding of the command in a submap of
-	;; the menu bar map, so the key sequence must be two or more
-	;; long.
-	(if (and (vectorp k)
-		 (> (length k) 1))
-	    (let ((m (lookup-key menu-bar-map (substring k 0 -1)))
-		  ;; Last element in the bound key sequence:
-		  (kk (aref k (1- (length k)))))
-	      (if (and (keymapp m)
-		       (symbolp kk))
-		  (setq submap m
-			key kk)))))
-      (when (and (symbolp submap) (boundp submap))
-	(setq submap (eval submap)))
-      (unless (image-mask-p image)
-	(setq image (append image '(:mask heuristic))))
-      (let ((defn (assq key (cdr submap))))
-	(if (eq (cadr defn) 'menu-item)
-	    (define-key-after in-map (vector key)
-	      (append (cdr defn) (list :image image) props))
-	  (setq defn (cdr defn))
-	  (define-key-after in-map (vector key)
-	    (let ((rest (cdr defn)))
-	      ;; If the rest of the definition starts
-	      ;; with a list of menu cache info, get rid of that.
-	      (if (and (consp rest) (consp (car rest)))
-		  (setq rest (cdr rest)))
-	      (append `(menu-item ,(car defn) ,rest)
-		      (list :image image) props))))))))
+    ;; We'll pick up the last valid entry in the list of keys if
+    ;; there's more than one.
+    ;; FIXME: Aren't they *all* "valid"??  --Stef
+    (dolist (k keys)
+      ;; We're looking for a binding of the command in a submap of
+      ;; the menu bar map, so the key sequence must be two or more
+      ;; long.
+      (if (and (vectorp k)
+               (> (length k) 1))
+          (let ((m (lookup-key menu-bar-map (substring k 0 -1)))
+                ;; Last element in the bound key sequence:
+                (kk (aref k (1- (length k)))))
+            (if (and (keymapp m)
+                     (symbolp kk))
+                (setq submap m
+                      key kk)))))
+    (when (and (symbolp submap) (boundp submap))
+      (setq submap (eval submap)))
+    (let ((defn (assq key (cdr submap))))
+      (if (eq (cadr defn) 'menu-item)
+          (define-key-after in-map (vector key)
+            (append (cdr defn) (list :image image-exp) props))
+        (setq defn (cdr defn))
+        (define-key-after in-map (vector key)
+          (let ((rest (cdr defn)))
+            ;; If the rest of the definition starts
+            ;; with a list of menu cache info, get rid of that.
+            (if (and (consp rest) (consp (car rest)))
+                (setq rest (cdr rest)))
+            (append `(menu-item ,(car defn) ,rest)
+                    (list :image image-exp) props))))
+      (force-mode-line-update))))
 
 ;;; Set up some global items.  Additions/deletions up for grabs.
 
-(defvar tool-bar-setup nil
-  "Set to t if the tool-bar has been set up by `tool-bar-setup'.")
-
-(defun tool-bar-setup (&optional frame)
-  (unless tool-bar-setup
-    (with-selected-frame (or frame (selected-frame))
-      ;; People say it's bad to have EXIT on the tool bar, since users
-      ;; might inadvertently click that button.
-      ;;(tool-bar-add-item-from-menu 'save-buffers-kill-emacs "exit")
-      (tool-bar-add-item-from-menu 'find-file "new")
-      (tool-bar-add-item-from-menu 'menu-find-file-existing "open")
-      (tool-bar-add-item-from-menu 'dired "diropen")
-      (tool-bar-add-item-from-menu 'kill-this-buffer "close")
-      (tool-bar-add-item-from-menu 'save-buffer "save" nil
-				   :visible '(or buffer-file-name
-						 (not (eq 'special
-							  (get major-mode
-							       'mode-class)))))
-      (tool-bar-add-item-from-menu 'write-file "saveas" nil
-				   :visible '(or buffer-file-name
-						 (not (eq 'special
-							  (get major-mode
-							       'mode-class)))))
-      (tool-bar-add-item-from-menu 'undo "undo" nil
-				   :visible '(not (eq 'special (get major-mode
-								    'mode-class))))
-      (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [cut])
-				   "cut" nil
-				   :visible '(not (eq 'special (get major-mode
-								    'mode-class))))
-      (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [copy])
-				   "copy")
-      (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [paste])
-				   "paste" nil
-				   :visible '(not (eq 'special (get major-mode
-								    'mode-class))))
-      (tool-bar-add-item-from-menu 'nonincremental-search-forward "search")
-      ;;(tool-bar-add-item-from-menu 'ispell-buffer "spell")
-
-      ;; There's no icon appropriate for News and we need a command rather
-      ;; than a lambda for Read Mail.
+(defun tool-bar-setup ()
+  (setq tool-bar-separator-image-expression
+	(tool-bar--image-expression "separator"))
+  (tool-bar-add-item-from-menu 'find-file "new" nil :label "New File"
+			       :vert-only t)
+  (tool-bar-add-item-from-menu 'menu-find-file-existing "open" nil
+			       :label "Open" :vert-only t)
+  (tool-bar-add-item-from-menu 'dired "diropen" nil :vert-only t)
+  (tool-bar-add-item-from-menu 'kill-this-buffer "close" nil :vert-only t)
+  (tool-bar-add-item-from-menu 'save-buffer "save" nil
+			       :label "Save")
+  (define-key-after (default-value 'tool-bar-map) [separator-1] menu-bar-separator)
+  (tool-bar-add-item-from-menu 'undo "undo" nil)
+  (define-key-after (default-value 'tool-bar-map) [separator-2] menu-bar-separator)
+  (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [cut])
+			       "cut" nil :vert-only t)
+  (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [copy])
+			       "copy" nil :vert-only t)
+  (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [paste])
+			       "paste" nil :vert-only t)
+  (define-key-after (default-value 'tool-bar-map) [separator-3] menu-bar-separator)
+  (tool-bar-add-item-from-menu 'isearch-forward "search"
+			       nil :label "Search" :vert-only t)
+  ;;(tool-bar-add-item-from-menu 'ispell-buffer "spell")
+
+  ;; There's no icon appropriate for News and we need a command rather
+  ;; than a lambda for Read Mail.
   ;;(tool-bar-add-item-from-menu 'compose-mail "mail/compose")
 
-  (tool-bar-add-item-from-menu 'print-buffer "print")
-
-  ;; tool-bar-add-item-from-menu itself operates on
-  ;; (default-value 'tool-bar-map), but when we don't use that function,
-  ;; we must explicitly operate on the default value.
-
-  (let ((tool-bar-map (default-value 'tool-bar-map)))
-    (tool-bar-add-item "preferences" 'customize 'customize
-		       :help "Edit preferences (customize)")
-
-    (tool-bar-add-item "help" (lambda ()
-				(interactive)
-				(popup-menu menu-bar-help-menu))
-		       'help
-		       :help "Pop up the Help menu"))
-  (setq tool-bar-setup t))))
+  ;; Help button on a tool bar is rather non-standard...
+  ;; (let ((tool-bar-map (default-value 'tool-bar-map)))
+  ;;   (tool-bar-add-item "help" (lambda ()
+  ;; 				(interactive)
+  ;; 				(popup-menu menu-bar-help-menu))
+  ;; 		       'help
+  ;; 		       :help "Pop up the Help menu"))
+)
+
+(if (featurep 'move-toolbar)
+    (defcustom tool-bar-position 'top
+      "Specify on which side the tool bar shall be.
+Possible values are `top' (tool bar on top), `bottom' (tool bar at bottom),
+`left' (tool bar on left) and `right' (tool bar on right).
+Customize `tool-bar-mode' if you want to show or hide the tool bar."
+      :version "24.1"
+      :type '(choice (const top)
+		     (const bottom)
+		     (const left)
+		     (const right))
+      :group 'frames
+      :initialize 'custom-initialize-default
+      :set (lambda (sym val)
+	     (set-default sym val)
+	     (modify-all-frames-parameters
+	      (list (cons 'tool-bar-position val))))))
 
 
 (provide 'tool-bar)
-;; arch-tag: 15f30f0a-d0d7-4d50-bbb7-f48fd0c8582f
+
 ;;; tool-bar.el ends here