(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.
See `tool-bar-add-item' and `tool-bar-add-item-from-menu' for
conveniently adding tool bar items."
:init-value nil
:global t
:group 'mouse
:group 'frames
(and (display-images-p)
(let ((lines (if tool-bar-mode 1 0)))
(mapc (lambda (frame)
(modify-frame-parameters frame
(list (cons 'tool-bar-lines lines))))
(frame-list))
(let ((elt (assq 'tool-bar-lines default-frame-alist)))
(if elt
(setcdr elt lines)
(add-to-list 'default-frame-alist (cons 'tool-bar-lines lines)))))
(if (and tool-bar-mode
(display-graphic-p)
(= 1 (length (default-value 'tool-bar-map)))) (tool-bar-setup))))
(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)))
(defun tool-bar-add-item (icon def key &rest props)
"Add an item to the tool bar.
ICON names the image, DEF is the key definition and KEY is a symbol
for the fake function key in the menu keymap. Remaining arguments
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
is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
ICON.xbm, using `find-image'.
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-local-item (icon def key map &rest props)
"Add an item to the tool bar in map MAP.
ICON names the image, DEF is the key definition and KEY is a symbol
for the fake function key in the menu keymap. Remaining arguments
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
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)))))
(defun tool-bar-add-item-from-menu (command icon &optional map &rest props)
"Define tool bar binding for COMMAND in keymap MAP using the given ICON.
This makes a binding for COMMAND in `tool-bar-map', copying its
binding from the menu bar in MAP (which defaults to `global-map'), but
modifies the binding by adding an image specification for ICON. It
finds ICON just like `tool-bar-add-item'. PROPS are additional
properties to add to the binding.
MAP must contain appropriate binding for `[menu-bar]' which holds a keymap.
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-from-menu'."
(apply 'tool-bar-local-item-from-menu command icon
(default-value 'tool-bar-map) map props))
(defun tool-bar-local-item-from-menu (command icon in-map &optional from-map &rest props)
"Define local tool bar binding for COMMAND using the given ICON.
This makes a binding for COMMAND in IN-MAP, copying its binding from
the menu bar in FROM-MAP (which defaults to `global-map'), but
modifies the binding by adding an image specification for ICON. It
finds ICON just like `tool-bar-add-item'. PROPS are additional
properties to add to the binding.
FROM-MAP must contain appropriate binding for `[menu-bar]' which
holds a keymap."
(unless from-map
(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))
submap key)
(when (and (display-images-p) image)
(dolist (k keys)
(if (and (vectorp k)
(> (length k) 1))
(let ((m (lookup-key menu-bar-map (substring k 0 -1)))
(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 (and (consp rest) (consp (car rest)))
(setq rest (cdr rest)))
(append `(menu-item ,(car defn) ,rest)
(list :image image) props))))))))
(defun tool-bar-setup ()
(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 'print-buffer "print")
(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"))
)
(provide 'tool-bar)