[bpt/emacs.git] / lisp / toolbar / tool-bar.el

;;; tool-bar.el --- setting up the tool bar
;;
;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
;;
;; Author: Dave Love <fx@gnu.org>
;; Keywords: mouse frames

;; This file is part of GNU Emacs.

;; 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 2, 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
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Provides `tool-bar-mode' to control display of the tool -bar and
;; bindings for the global tool bar with convenience functions
;; `tool-bar-add-item' and `tool-bar-add-item-from-menu'.

;; The normal global binding for [tool-bar] (below) uses the value of
;; `tool-bar-map' as the actual keymap to define the tool bar.  Modes
;; may either bind items under the [tool-bar] prefix key of the local
;; map to add to the global bar or may set `tool-bar-map'
;; buffer-locally to override it.  (Some items are removed from the
;; global bar in modes which have `special' as their `mode-class'
;; properlty.)

;; Todo: Somehow make tool bars easily customizable by the naive?

;;; Code:

;;;###autoload
(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."
  :global t
  :group 'mouse
  :group 'frames
  (and (display-images-p)
       (let ((lines (if tool-bar-mode 1 0)))
	 ;; Alter existing frames...
	 (mapc (lambda (frame)
		 (modify-frame-parameters frame
					  (list (cons 'tool-bar-lines lines))))
	       (frame-list))
	 ;; ...and future ones.
	 (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)))) ; not yet setup
	   (tool-bar-setup))))

(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)))

;;;###autoload
(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 ICON.xpm, then ICON.pbm, and finally
ICON.xbm, using `find-image'.

Keybindings are made in the map `tool-bar-map'.  To define items in
some local map, bind `tool-bar-map' with `let' around calls of this
function."
  (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))))
	 (image (find-image
		(if (display-color-p)
		    (list (list :type 'xpm :file (concat icon ".xpm"))
			  (append (list :type 'pbm :file (concat icon ".pbm"))
				  colors)
			  (append (list :type 'xbm :file (concat icon ".xbm"))
				  colors))
		  (list (append (list :type 'pbm :file (concat icon ".pbm"))
				colors)
			(append (list :type 'xbm :file (concat icon ".xbm"))
				colors)
			(list :type 'xpm :file (concat icon ".xpm")))))))
    (when (and (display-images-p) image)
      (unless (image-mask-p image)
	(setq image (append image '(:mask heuristic))))
      (define-key-after tool-bar-map (vector key)
	`(menu-item ,(symbol-name key) ,def :image ,image ,@props)))))

;;;###autoload
(defun tool-bar-add-item-from-menu (command icon &optional map &rest props)
  "Define tool bar binding for COMMAND using the given ICON in keymap MAP.
The binding of COMMAND is looked up in the menu bar in MAP (default
`global-map') and modified to add an image specification for ICON, which
is looked for as by `tool-bar-add-item'.
MAP must contain an appropriate keymap bound to `[menu-bar]'.
PROPS is a list of additional properties to add to the binding.

Keybindings are made in the map `tool-bar-map'.  To define items in
some local map, bind `tool-bar-map' with `let' around calls of this
function."
  (unless map
    (setq map global-map))
  (let* ((menu-bar-map (lookup-key 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))))
	 (spec (if (display-color-p)
		   (list (list :type 'xpm :file (concat icon ".xpm"))
			 (append (list :type 'pbm :file (concat icon ".pbm"))
				       colors)
			 (append (list :type 'xbm :file (concat icon ".xbm"))
				       colors))
		 (list (append (list :type 'pbm :file (concat icon ".pbm"))
				     colors)
		       (append (list :type 'xbm :file (concat icon ".xbm"))
				     colors)
		       (list :type 'xpm :file (concat icon ".xpm")))))
	 (image (find-image spec))
	 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 tool-bar-map (vector key)
	      (append (cdr defn) (list :image image) props))
	  (setq defn (cdr defn))
	  (define-key-after tool-bar-map (vector key)
	    (append `(menu-item ,(car defn) ,(cddr defn))
		    (list :image image) props)))))))

;;; Set up some global items.  Additions/deletions up for grabs.

(defun tool-bar-setup ()
  ;; 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 'dired "open")
  (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 'kill-region "cut" nil
			       :visible '(not (eq 'special (get major-mode
								'mode-class))))
  (tool-bar-add-item-from-menu 'menu-bar-kill-ring-save "copy")
  (tool-bar-add-item-from-menu 'yank "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.
  ;;(tool-bar-add-item-from-menu 'compose-mail "mail_compose")

  (tool-bar-add-item-from-menu 'print-buffer "print")
  (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)

;;; tool-bar.el ends here
Commit	Line	Data
e8af40ee	1	;;; tool-bar.el --- setting up the tool bar
ec7f4585	2	;;
98a8938c	3	;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
ec7f4585 DL	4	;;
	5	;; Author: Dave Love <fx@gnu.org>
	6	;; Keywords: mouse frames
	7
	8	;; This file is part of GNU Emacs.
	9
	10	;; GNU Emacs is free software; you can redistribute it and/or modify
	11	;; it under the terms of the GNU General Public License as published by
	12	;; the Free Software Foundation; either version 2, or (at your option)
	13	;; any later version.
	14
	15	;; GNU Emacs is distributed in the hope that it will be useful,
	16	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	17	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	;; GNU General Public License for more details.
	19
	20	;; You should have received a copy of the GNU General Public License
	21	;; along with GNU Emacs; see the file COPYING. If not, write to the
	22	;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
	23	;; Boston, MA 02111-1307, USA.
	24
	25	;;; Commentary:
	26
	27	;; Provides `tool-bar-mode' to control display of the tool -bar and
	28	;; bindings for the global tool bar with convenience functions
	29	;; `tool-bar-add-item' and `tool-bar-add-item-from-menu'.
	30
9a4b8870	31	;; The normal global binding for [tool-bar] (below) uses the value of
c129b5ef DL	32	;; `tool-bar-map' as the actual keymap to define the tool bar. Modes
	33	;; may either bind items under the [tool-bar] prefix key of the local
	34	;; map to add to the global bar or may set `tool-bar-map'
b28e72df	35	;; buffer-locally to override it. (Some items are removed from the
9a4b8870 DL	36	;; global bar in modes which have `special' as their `mode-class'
	37	;; properlty.)
	38
adf7d3a8 DL	39	;; Todo: Somehow make tool bars easily customizable by the naive?
adf7d3a8 DL	40
ec7f4585 DL	41	;;; Code:
	42
	43	;;;###autoload
	44	(define-minor-mode tool-bar-mode
	45	"Toggle use of the tool bar.
a81fc510	46	With numeric ARG, display the tool bar if and only if ARG is positive.
ec7f4585 DL	47
	48	See `tool-bar-add-item' and `tool-bar-add-item-from-menu' for
	49	conveniently adding tool bar items."
ec7f4585 DL	50	:global t
	51	:group 'mouse
	52	:group 'frames
ef32aa02 EZ	53	(and (display-images-p)
	54	(let ((lines (if tool-bar-mode 1 0)))
	55	;; Alter existing frames...
	56	(mapc (lambda (frame)
	57	(modify-frame-parameters frame
	58	(list (cons 'tool-bar-lines lines))))
	59	(frame-list))
	60	;; ...and future ones.
	61	(let ((elt (assq 'tool-bar-lines default-frame-alist)))
	62	(if elt
	63	(setcdr elt lines)
	64	(add-to-list 'default-frame-alist (cons 'tool-bar-lines lines)))))
	65	(if (and tool-bar-mode
	66	(display-graphic-p)
	67	(= 1 (length (default-value 'tool-bar-map)))) ; not yet setup
	68	(tool-bar-setup))))
ec7f4585	69
9a4b8870 DL	70	(defvar tool-bar-map (make-sparse-keymap)
	71	"Keymap for the tool bar.
	72	Define this locally to override the global tool bar.")
	73
	74	(global-set-key [tool-bar]
	75	'(menu-item "tool bar" ignore
	76	:filter (lambda (ignore) tool-bar-map)))
ec7f4585 DL	77
ec7f4585 DL	78	;;;###autoload
9a4b8870	79	(defun tool-bar-add-item (icon def key &rest props)
ec7f4585 DL	80	"Add an item to the tool bar.
ec7f4585 DL	81	ICON names the image, DEF is the key definition and KEY is a symbol
9a4b8870 DL	82	for the fake function key in the menu keymap. Remaining arguments
	83	PROPS are additional items to add to the menu item specification. See
	84	Info node `(elisp)Tool Bar'. Items are added from left to right.
ec7f4585	85
cb4aae04 EZ	86	ICON is the base name of a file containing the image to use. The
	87	function will first try to use ICON.xpm, then ICON.pbm, and finally
	88	ICON.xbm, using `find-image'.
9a4b8870 DL	89
	90	Keybindings are made in the map `tool-bar-map'. To define items in
	91	some local map, bind `tool-bar-map' with `let' around calls of this
	92	function."
3fae165c GM	93	(let* ((fg (face-attribute 'tool-bar :foreground))
	94	(bg (face-attribute 'tool-bar :background))
	95	(colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
	96	(if (eq bg 'unspecified) nil (list :background bg))))
3b6d80f1	97	(image (find-image
34e86ea3	98	(if (display-color-p)
3fae165c GM	99	(list (list :type 'xpm :file (concat icon ".xpm"))
	100	(append (list :type 'pbm :file (concat icon ".pbm"))
	101	colors)
	102	(append (list :type 'xbm :file (concat icon ".xbm"))
	103	colors))
	104	(list (append (list :type 'pbm :file (concat icon ".pbm"))
	105	colors)
	106	(append (list :type 'xbm :file (concat icon ".xbm"))
	107	colors)
	108	(list :type 'xpm :file (concat icon ".xpm")))))))
196de866	109	(when (and (display-images-p) image)
ec7f4585 DL	110	(unless (image-mask-p image)
ec7f4585 DL	111	(setq image (append image '(:mask heuristic))))
9a4b8870	112	(define-key-after tool-bar-map (vector key)
ec7f4585 DL	113	`(menu-item ,(symbol-name key) ,def :image ,image ,@props)))))
ec7f4585 DL	114
c2156508	115	;;;###autoload
ec7f4585 DL	116	(defun tool-bar-add-item-from-menu (command icon &optional map &rest props)
	117	"Define tool bar binding for COMMAND using the given ICON in keymap MAP.
	118	The binding of COMMAND is looked up in the menu bar in MAP (default
	119	`global-map') and modified to add an image specification for ICON, which
	120	is looked for as by `tool-bar-add-item'.
9a4b8870 DL	121	MAP must contain an appropriate keymap bound to `[menu-bar]'.
	122	PROPS is a list of additional properties to add to the binding.
	123
	124	Keybindings are made in the map `tool-bar-map'. To define items in
	125	some local map, bind `tool-bar-map' with `let' around calls of this
	126	function."
ec7f4585 DL	127	(unless map
	128	(setq map global-map))
	129	(let* ((menu-bar-map (lookup-key map [menu-bar]))
	130	(keys (where-is-internal command menu-bar-map))
3fae165c GM	131	(fg (face-attribute 'tool-bar :foreground))
	132	(bg (face-attribute 'tool-bar :background))
	133	(colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
	134	(if (eq bg 'unspecified) nil (list :background bg))))
7e636904 GM	135	(spec (if (display-color-p)
	136	(list (list :type 'xpm :file (concat icon ".xpm"))
	137	(append (list :type 'pbm :file (concat icon ".pbm"))
	138	colors)
	139	(append (list :type 'xbm :file (concat icon ".xbm"))
	140	colors))
	141	(list (append (list :type 'pbm :file (concat icon ".pbm"))
	142	colors)
	143	(append (list :type 'xbm :file (concat icon ".xbm"))
	144	colors)
	145	(list :type 'xpm :file (concat icon ".xpm")))))
	146	(image (find-image spec))
ec7f4585	147	submap key)
196de866	148	(when (and (display-images-p) image)
ec7f4585 DL	149	;; We'll pick up the last valid entry in the list of keys if
	150	;; there's more than one.
	151	(dolist (k keys)
	152	;; We're looking for a binding of the command in a submap of
	153	;; the menu bar map, so the key sequence must be two or more
	154	;; long.
	155	(if (and (vectorp k)
	156	(> (length k) 1))
	157	(let ((m (lookup-key menu-bar-map (substring k 0 -1)))
	158	;; Last element in the bound key sequence:
	159	(kk (aref k (1- (length k)))))
	160	(if (and (keymapp m)
	161	(symbolp kk))
	162	(setq submap m
	163	key kk)))))
	164	(when (and (symbolp submap) (boundp submap))
	165	(setq submap (eval submap)))
ddba99ad MB	166	(unless (image-mask-p image)
ddba99ad MB	167	(setq image (append image '(:mask heuristic))))
98a8938c GM	168	(let ((defn (assq key (cdr submap))))
	169	(if (eq (cadr defn) 'menu-item)
	170	(define-key-after tool-bar-map (vector key)
	171	(append (cdr defn) (list :image image) props))
	172	(setq defn (cdr defn))
	173	(define-key-after tool-bar-map (vector key)
	174	(append `(menu-item ,(car defn) ,(cddr defn))
	175	(list :image image) props)))))))
ec7f4585 DL	176
	177	;;; Set up some global items. Additions/deletions up for grabs.
	178
ebd4825d	179	(defun tool-bar-setup ()
7a03d9cd EZ	180	;; People say it's bad to have EXIT on the tool bar, since users
	181	;; might inadvertently click that button.
	182	;;(tool-bar-add-item-from-menu 'save-buffers-kill-emacs "exit")
ebd4825d DL	183	(tool-bar-add-item-from-menu 'find-file "new")
	184	(tool-bar-add-item-from-menu 'dired "open")
	185	(tool-bar-add-item-from-menu 'kill-this-buffer "close")
	186	(tool-bar-add-item-from-menu 'save-buffer "save" nil
5ec17636 DL	187	:visible '(or buffer-file-name
	188	(not (eq 'special
	189	(get major-mode
	190	'mode-class)))))
ebd4825d	191	(tool-bar-add-item-from-menu 'write-file "saveas" nil
5ec17636 DL	192	:visible '(or buffer-file-name
	193	(not (eq 'special
	194	(get major-mode
	195	'mode-class)))))
ebd4825d DL	196	(tool-bar-add-item-from-menu 'undo "undo" nil
	197	:visible '(not (eq 'special (get major-mode
	198	'mode-class))))
	199	(tool-bar-add-item-from-menu 'kill-region "cut" nil
	200	:visible '(not (eq 'special (get major-mode
	201	'mode-class))))
	202	(tool-bar-add-item-from-menu 'menu-bar-kill-ring-save "copy")
	203	(tool-bar-add-item-from-menu 'yank "paste" nil
	204	:visible '(not (eq 'special (get major-mode
	205	'mode-class))))
	206	(tool-bar-add-item-from-menu 'nonincremental-search-forward "search")
	207	;;(tool-bar-add-item-from-menu 'ispell-buffer "spell")
	208
	209	;; There's no icon appropriate for News and we need a command rather
	210	;; than a lambda for Read Mail.
	211	;;(tool-bar-add-item-from-menu 'compose-mail "mail_compose")
	212
	213	(tool-bar-add-item-from-menu 'print-buffer "print")
9a4b8870	214	(tool-bar-add-item "preferences" 'customize 'customize
ebd4825d DL	215	:help "Edit preferences (customize)")
ebd4825d DL	216
9a4b8870 DL	217	(tool-bar-add-item "help" (lambda ()
	218	(interactive)
	219	(popup-menu menu-bar-help-menu))
	220	'help
	221	:help "Pop up the Help menu")
ebd4825d	222	)
ec7f4585 DL	223
	224	(provide 'tool-bar)
	225
	226	;;; tool-bar.el ends here