LCOV - code coverage report
Current view: top level - lisp - tool-bar.el (source / functions) Hit Total Coverage
Test: tramp-tests.info Lines: 0 110 0.0 %
Date: 2017-08-27 09:44:50 Functions: 0 11 0.0 %

          Line data    Source code
       1             : ;;; tool-bar.el --- setting up the tool bar
       2             : 
       3             : ;; Copyright (C) 2000-2017 Free Software Foundation, Inc.
       4             : 
       5             : ;; Author: Dave Love <fx@gnu.org>
       6             : ;; Keywords: mouse frames
       7             : ;; Package: emacs
       8             : 
       9             : ;; This file is part of GNU Emacs.
      10             : 
      11             : ;; GNU Emacs is free software: you can redistribute it and/or modify
      12             : ;; it under the terms of the GNU General Public License as published by
      13             : ;; the Free Software Foundation, either version 3 of the License, or
      14             : ;; (at your option) any later version.
      15             : 
      16             : ;; GNU Emacs is distributed in the hope that it will be useful,
      17             : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
      18             : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      19             : ;; GNU General Public License for more details.
      20             : 
      21             : ;; You should have received a copy of the GNU General Public License
      22             : ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
      23             : 
      24             : ;;; Commentary:
      25             : 
      26             : ;; Provides `tool-bar-mode' to control display of the tool-bar and
      27             : ;; bindings for the global tool bar with convenience functions
      28             : ;; `tool-bar-add-item' and `tool-bar-add-item-from-menu'.
      29             : 
      30             : ;; The normal global binding for [tool-bar] (below) uses the value of
      31             : ;; `tool-bar-map' as the actual keymap to define the tool bar.  Modes
      32             : ;; may either bind items under the [tool-bar] prefix key of the local
      33             : ;; map to add to the global bar or may set `tool-bar-map'
      34             : ;; buffer-locally to override it.  (Some items are removed from the
      35             : ;; global bar in modes which have `special' as their `mode-class'
      36             : ;; property.)
      37             : 
      38             : ;; Todo: Somehow make tool bars easily customizable by the naive?
      39             : 
      40             : ;;; Code:
      41             : 
      42             : ;; The autoload cookie doesn't work when preloading.
      43             : ;; Deleting it means invoking this command won't work
      44             : ;; when you are on a tty.  I hope that won't cause too much trouble -- rms.
      45             : (define-minor-mode tool-bar-mode
      46             :   "Toggle the tool bar in all graphical frames (Tool Bar mode).
      47             : With a prefix argument ARG, enable Tool Bar mode if ARG is
      48             : positive, and disable it otherwise.  If called from Lisp, enable
      49             : Tool Bar mode if ARG is omitted or nil.
      50             : 
      51             : See `tool-bar-add-item' and `tool-bar-add-item-from-menu' for
      52             : conveniently adding tool bar items."
      53             :   :init-value t
      54             :   :global t
      55             :   ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
      56             :   :variable tool-bar-mode
      57           0 :   (let ((val (if tool-bar-mode 1 0)))
      58           0 :     (dolist (frame (frame-list))
      59           0 :       (set-frame-parameter frame 'tool-bar-lines val))
      60             :     ;; If the user has given `default-frame-alist' a `tool-bar-lines'
      61             :     ;; parameter, replace it.
      62           0 :     (if (assq 'tool-bar-lines default-frame-alist)
      63           0 :         (setq default-frame-alist
      64           0 :               (cons (cons 'tool-bar-lines val)
      65           0 :                     (assq-delete-all 'tool-bar-lines
      66           0 :                                      default-frame-alist)))))
      67           0 :   (and tool-bar-mode
      68           0 :        (= 1 (length (default-value 'tool-bar-map))) ; not yet setup
      69           0 :        (tool-bar-setup)))
      70             : 
      71             : ;;;###autoload
      72             : ;; Used in the Show/Hide menu, to have the toggle reflect the current frame.
      73             : (defun toggle-tool-bar-mode-from-frame (&optional arg)
      74             :   "Toggle tool bar on or off, based on the status of the current frame.
      75             : See `tool-bar-mode' for more information."
      76           0 :   (interactive (list (or current-prefix-arg 'toggle)))
      77           0 :   (if (eq arg 'toggle)
      78           0 :       (tool-bar-mode (if (> (frame-parameter nil 'tool-bar-lines) 0) 0 1))
      79           0 :     (tool-bar-mode arg)))
      80             : 
      81             : (defvar tool-bar-map (make-sparse-keymap)
      82             :   "Keymap for the tool bar.
      83             : Define this locally to override the global tool bar.")
      84             : 
      85             : (global-set-key [tool-bar]
      86             :                 `(menu-item ,(purecopy "tool bar") ignore
      87             :                             :filter tool-bar-make-keymap))
      88             : 
      89             : (declare-function image-mask-p "image.c" (spec &optional frame))
      90             : 
      91             : (defconst tool-bar-keymap-cache (make-hash-table :weakness t :test 'equal))
      92             : 
      93             : (defun tool-bar-make-keymap (&optional _ignore)
      94             :   "Generate an actual keymap from `tool-bar-map'.
      95             : Its main job is to figure out which images to use based on the display's
      96             : color capability and based on the available image libraries."
      97           0 :   (let ((key (cons (frame-terminal) tool-bar-map)))
      98           0 :     (or (gethash key tool-bar-keymap-cache)
      99           0 :         (puthash key (tool-bar-make-keymap-1) tool-bar-keymap-cache))))
     100             : 
     101             : (defun tool-bar-make-keymap-1 ()
     102             :   "Generate an actual keymap from `tool-bar-map', without caching."
     103           0 :   (mapcar (lambda (bind)
     104           0 :             (let (image-exp plist)
     105           0 :               (when (and (eq (car-safe (cdr-safe bind)) 'menu-item)
     106             :                          ;; For the format of menu-items, see node
     107             :                          ;; `Extended Menu Items' in the Elisp manual.
     108           0 :                          (setq plist (nthcdr (if (consp (nth 4 bind)) 5 4)
     109           0 :                                              bind))
     110           0 :                          (setq image-exp (plist-get plist :image))
     111           0 :                          (consp image-exp)
     112           0 :                          (not (eq (car image-exp) 'image))
     113           0 :                          (fboundp (car image-exp)))
     114           0 :                 (if (not (display-images-p))
     115           0 :                     (setq bind nil)
     116           0 :                   (let ((image (eval image-exp)))
     117           0 :                     (unless (and image (image-mask-p image))
     118           0 :                       (setq image (append image '(:mask heuristic))))
     119           0 :                     (setq bind (copy-sequence bind)
     120           0 :                           plist (nthcdr (if (consp (nth 4 bind)) 5 4)
     121           0 :                                         bind))
     122           0 :                     (plist-put plist :image image))))
     123           0 :               bind))
     124           0 :           tool-bar-map))
     125             : 
     126             : ;;;###autoload
     127             : (defun tool-bar-add-item (icon def key &rest props)
     128             :   "Add an item to the tool bar.
     129             : ICON names the image, DEF is the key definition and KEY is a symbol
     130             : for the fake function key in the menu keymap.  Remaining arguments
     131             : PROPS are additional items to add to the menu item specification.  See
     132             : Info node `(elisp)Tool Bar'.  Items are added from left to right.
     133             : 
     134             : ICON is the base name of a file containing the image to use.  The
     135             : function will first try to use low-color/ICON.xpm if `display-color-cells'
     136             : is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
     137             : ICON.xbm, using `find-image'.
     138             : 
     139             : Use this function only to make bindings in the global value of `tool-bar-map'.
     140             : To define items in any other map, use `tool-bar-local-item'."
     141           0 :   (apply 'tool-bar-local-item icon def key tool-bar-map props))
     142             : 
     143             : (defun tool-bar--image-expression (icon)
     144             :   "Return an expression that evaluates to an image spec for ICON."
     145           0 :   (let* ((fg (face-attribute 'tool-bar :foreground))
     146           0 :          (bg (face-attribute 'tool-bar :background))
     147           0 :          (colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
     148           0 :                         (if (eq bg 'unspecified) nil (list :background bg))))
     149           0 :          (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
     150           0 :          (xpm-lo-spec (list :type 'xpm :file
     151           0 :                             (concat "low-color/" icon ".xpm")))
     152           0 :          (pbm-spec (append (list :type 'pbm :file
     153           0 :                                  (concat icon ".pbm")) colors))
     154           0 :          (xbm-spec (append (list :type 'xbm :file
     155           0 :                                  (concat icon ".xbm")) colors)))
     156           0 :     `(find-image (cond ((not (display-color-p))
     157           0 :                         ',(list pbm-spec xbm-spec xpm-lo-spec xpm-spec))
     158             :                        ((< (display-color-cells) 256)
     159           0 :                         ',(list xpm-lo-spec xpm-spec pbm-spec xbm-spec))
     160             :                        (t
     161           0 :                         ',(list xpm-spec pbm-spec xbm-spec))))))
     162             : 
     163             : ;;;###autoload
     164             : (defun tool-bar-local-item (icon def key map &rest props)
     165             :   "Add an item to the tool bar in map MAP.
     166             : ICON names the image, DEF is the key definition and KEY is a symbol
     167             : for the fake function key in the menu keymap.  Remaining arguments
     168             : PROPS are additional items to add to the menu item specification.  See
     169             : Info node `(elisp)Tool Bar'.  Items are added from left to right.
     170             : 
     171             : ICON is the base name of a file containing the image to use.  The
     172             : function will first try to use low-color/ICON.xpm if `display-color-cells'
     173             : is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
     174             : ICON.xbm, using `find-image'."
     175           0 :   (let* ((image-exp (tool-bar--image-expression icon)))
     176           0 :     (define-key-after map (vector key)
     177           0 :       `(menu-item ,(symbol-name key) ,def :image ,image-exp ,@props))
     178           0 :     (force-mode-line-update)))
     179             : 
     180             : ;;;###autoload
     181             : (defun tool-bar-add-item-from-menu (command icon &optional map &rest props)
     182             :   "Define tool bar binding for COMMAND in keymap MAP using the given ICON.
     183             : This makes a binding for COMMAND in `tool-bar-map', copying its
     184             : binding from the menu bar in MAP (which defaults to `global-map'), but
     185             : modifies the binding by adding an image specification for ICON.  It
     186             : finds ICON just like `tool-bar-add-item'.  PROPS are additional
     187             : properties to add to the binding.
     188             : 
     189             : MAP must contain appropriate binding for `[menu-bar]' which holds a keymap.
     190             : 
     191             : Use this function only to make bindings in the global value of `tool-bar-map'.
     192             : To define items in any other map, use `tool-bar-local-item-from-menu'."
     193           0 :   (apply 'tool-bar-local-item-from-menu command icon
     194           0 :          (default-value 'tool-bar-map) map props))
     195             : 
     196             : ;;;###autoload
     197             : (defun tool-bar-local-item-from-menu (command icon in-map &optional from-map &rest props)
     198             :   "Define local tool bar binding for COMMAND using the given ICON.
     199             : This makes a binding for COMMAND in IN-MAP, copying its binding from
     200             : the menu bar in FROM-MAP (which defaults to `global-map'), but
     201             : modifies the binding by adding an image specification for ICON.  It
     202             : finds ICON just like `tool-bar-add-item'.  PROPS are additional
     203             : properties to add to the binding.
     204             : 
     205             : FROM-MAP must contain appropriate binding for `[menu-bar]' which
     206             : holds a keymap."
     207           0 :   (unless from-map
     208           0 :     (setq from-map global-map))
     209           0 :   (let* ((menu-bar-map (lookup-key from-map [menu-bar]))
     210           0 :          (keys (where-is-internal command menu-bar-map))
     211           0 :          (image-exp (tool-bar--image-expression icon))
     212             :          submap key)
     213             :     ;; We'll pick up the last valid entry in the list of keys if
     214             :     ;; there's more than one.
     215             :     ;; FIXME: Aren't they *all* "valid"??  --Stef
     216           0 :     (dolist (k keys)
     217             :       ;; We're looking for a binding of the command in a submap of
     218             :       ;; the menu bar map, so the key sequence must be two or more
     219             :       ;; long.
     220           0 :       (if (and (vectorp k)
     221           0 :                (> (length k) 1))
     222           0 :           (let ((m (lookup-key menu-bar-map (substring k 0 -1)))
     223             :                 ;; Last element in the bound key sequence:
     224           0 :                 (kk (aref k (1- (length k)))))
     225           0 :             (if (and (keymapp m)
     226           0 :                      (symbolp kk))
     227           0 :                 (setq submap m
     228           0 :                       key kk)))))
     229           0 :     (when (and (symbolp submap) (boundp submap))
     230           0 :       (setq submap (eval submap)))
     231           0 :     (let ((defn (assq key (cdr submap))))
     232           0 :       (if (eq (cadr defn) 'menu-item)
     233           0 :           (define-key-after in-map (vector key)
     234           0 :             (append (cdr defn) (list :image image-exp) props))
     235           0 :         (setq defn (cdr defn))
     236           0 :         (define-key-after in-map (vector key)
     237           0 :           (let ((rest (cdr defn)))
     238             :             ;; If the rest of the definition starts
     239             :             ;; with a list of menu cache info, get rid of that.
     240           0 :             (if (and (consp rest) (consp (car rest)))
     241           0 :                 (setq rest (cdr rest)))
     242           0 :             (append `(menu-item ,(car defn) ,rest)
     243           0 :                     (list :image image-exp) props))))
     244           0 :       (force-mode-line-update))))
     245             : 
     246             : ;;; Set up some global items.  Additions/deletions up for grabs.
     247             : 
     248             : (defun tool-bar-setup ()
     249           0 :   (setq tool-bar-separator-image-expression
     250           0 :         (tool-bar--image-expression "separator"))
     251           0 :   (tool-bar-add-item-from-menu 'find-file "new" nil :label "New File"
     252           0 :                                :vert-only t)
     253           0 :   (tool-bar-add-item-from-menu 'menu-find-file-existing "open" nil
     254           0 :                                :label "Open" :vert-only t)
     255           0 :   (tool-bar-add-item-from-menu 'dired "diropen" nil :vert-only t)
     256           0 :   (tool-bar-add-item-from-menu 'kill-this-buffer "close" nil :vert-only t)
     257           0 :   (tool-bar-add-item-from-menu 'save-buffer "save" nil
     258           0 :                                :label "Save")
     259           0 :   (define-key-after (default-value 'tool-bar-map) [separator-1] menu-bar-separator)
     260           0 :   (tool-bar-add-item-from-menu 'undo "undo" nil)
     261           0 :   (define-key-after (default-value 'tool-bar-map) [separator-2] menu-bar-separator)
     262           0 :   (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [cut])
     263           0 :                                "cut" nil :vert-only t)
     264           0 :   (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [copy])
     265           0 :                                "copy" nil :vert-only t)
     266           0 :   (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [paste])
     267           0 :                                "paste" nil :vert-only t)
     268           0 :   (define-key-after (default-value 'tool-bar-map) [separator-3] menu-bar-separator)
     269           0 :   (tool-bar-add-item-from-menu 'isearch-forward "search"
     270           0 :                                nil :label "Search" :vert-only t)
     271             :   ;;(tool-bar-add-item-from-menu 'ispell-buffer "spell")
     272             : 
     273             :   ;; There's no icon appropriate for News and we need a command rather
     274             :   ;; than a lambda for Read Mail.
     275             :   ;;(tool-bar-add-item-from-menu 'compose-mail "mail/compose")
     276             : 
     277             :   ;; Help button on a tool bar is rather non-standard...
     278             :   ;; (let ((tool-bar-map (default-value 'tool-bar-map)))
     279             :   ;;   (tool-bar-add-item "help" (lambda ()
     280             :   ;;                            (interactive)
     281             :   ;;                            (popup-menu menu-bar-help-menu))
     282             :   ;;                   'help
     283             :   ;;                   :help "Pop up the Help menu"))
     284             : )
     285             : 
     286             : (if (featurep 'move-toolbar)
     287             :     (defcustom tool-bar-position 'top
     288             :       "Specify on which side the tool bar shall be.
     289             : Possible values are `top' (tool bar on top), `bottom' (tool bar at bottom),
     290             : `left' (tool bar on left) and `right' (tool bar on right).
     291             : Customize `tool-bar-mode' if you want to show or hide the tool bar."
     292             :       :version "24.1"
     293             :       :type '(choice (const top)
     294             :                      (const bottom)
     295             :                      (const left)
     296             :                      (const right))
     297             :       :group 'frames
     298             :       :initialize 'custom-initialize-default
     299             :       :set (lambda (sym val)
     300             :              (set-default sym val)
     301             :              (modify-all-frames-parameters
     302             :               (list (cons 'tool-bar-position val))))))
     303             : 
     304             : 
     305             : (provide 'tool-bar)
     306             : 
     307             : ;;; tool-bar.el ends here

Generated by: LCOV version 1.12