Choose images dynamically.
(tool-bar-make-keymap, tool-bar-find-image): New function. (tool-bar-find-image-cache): New var. (tool-bar-local-item, tool-bar-local-item-from-menu): Don't select the image yet, do it later in tool-bar-make-keymap.
This commit is contained in:
Stefan Monnier
parent
42a83f4b6c
commit
c8fcd943a9
2 changed files with 97 additions and 69 deletions
|
|
@ -1,3 +1,11 @@
|
|||
2008-05-07 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* tool-bar.el: Choose images dynamically.
|
||||
(tool-bar-make-keymap, tool-bar-find-image): New function.
|
||||
(tool-bar-find-image-cache): New var.
|
||||
(tool-bar-local-item, tool-bar-local-item-from-menu):
|
||||
Don't select the image yet, do it later in tool-bar-make-keymap.
|
||||
|
||||
2008-05-07 Andreas Schwab <schwab@suse.de>
|
||||
|
||||
* window.el: Require 'cl when compiling.
|
||||
|
|
@ -60,8 +68,7 @@
|
|||
2008-05-06 Chong Yidong <cyd@stupidchicken.com>
|
||||
|
||||
* progmodes/compile.el (compilation-error-regexp-alist-alist):
|
||||
Tweak Open Watcom regexp to distinguish between errors and
|
||||
warnings.
|
||||
Tweak Open Watcom regexp to distinguish between errors and warnings.
|
||||
|
||||
2008-05-06 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
|
|
@ -103,7 +110,7 @@
|
|||
|
||||
* vc-dispatcher.el (vc-dir-mark-buffer-changed): Fix typo
|
||||
client-mode -> vc-client-object, and guess `funcall' was meant.
|
||||
(vc-dir-mode): Rename client-mode -> vc-client.mode.
|
||||
(vc-dir-mode): Rename client-mode -> vc-client-mode.
|
||||
|
||||
2008-05-05 Dan Nicolaescu <dann@ics.uci.edu>
|
||||
|
||||
|
|
@ -152,10 +159,9 @@
|
|||
The separation is not yet completely clean, but it's a good start.
|
||||
* vc.el: This file is about 1700 lines shorter now.
|
||||
Remove obsolete logentry-check from the backend API.
|
||||
* vc-sccs.el (vc-sccs-logentry-check): Remove . This was
|
||||
was the only implementation of the logentry-check method, and
|
||||
it guarded against a log length limit that has probably been
|
||||
obsolete for 15 years (!).
|
||||
* vc-sccs.el (vc-sccs-logentry-check): Remove . This was the only
|
||||
implementation of the logentry-check method, and it guarded against
|
||||
a log length limit that has probably been obsolete for 15 years (!).
|
||||
|
||||
2008-05-02 Sam Steingold <sds@gnu.org>
|
||||
|
||||
|
|
|
|||
146
lisp/tool-bar.el
146
lisp/tool-bar.el
|
|
@ -86,7 +86,35 @@ 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)))
|
||||
:filter tool-bar-make-keymap))
|
||||
|
||||
(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."
|
||||
(mapcar (lambda (bind)
|
||||
(let (image-exp)
|
||||
(when (and (eq (car-safe (cdr-safe bind)) 'menu-item)
|
||||
(setq image-exp (plist-get bind :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 (image-mask-p image)
|
||||
(setq image (append image '(:mask heuristic))))
|
||||
(setq bind (copy-sequence bind))
|
||||
(plist-put bind :image image))))
|
||||
bind))
|
||||
tool-bar-map))
|
||||
|
||||
(defconst tool-bar-find-image-cache (make-hash-table :weakness t :test 'equal))
|
||||
|
||||
(defun tool-bar-find-image (specs)
|
||||
"Like `find-image' but with caching."
|
||||
(or (gethash specs tool-bar-find-image-cache)
|
||||
(puthash specs (find-image specs) tool-bar-find-image-cache)))
|
||||
|
||||
;;;###autoload
|
||||
(defun tool-bar-add-item (icon def key &rest props)
|
||||
|
|
@ -114,7 +142,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'."
|
||||
(let* ((fg (face-attribute 'tool-bar :foreground))
|
||||
|
|
@ -130,16 +158,13 @@ ICON.xbm, using `find-image'."
|
|||
(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)))))
|
||||
(image-exp `(tool-bar-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)))))
|
||||
(define-key-after map (vector key)
|
||||
`(menu-item ,(symbol-name key) ,def :image ,image-exp ,@props))))
|
||||
|
||||
;;;###autoload
|
||||
(defun tool-bar-add-item-from-menu (command icon &optional map &rest props)
|
||||
|
|
@ -185,44 +210,41 @@ holds a keymap."
|
|||
(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-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))))
|
||||
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.
|
||||
(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)))))))
|
||||
|
||||
;;; Set up some global items. Additions/deletions up for grabs.
|
||||
|
||||
|
|
@ -267,24 +289,24 @@ holds a keymap."
|
|||
|
||||
;; 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 'compose-mail "mail/compose")
|
||||
|
||||
(tool-bar-add-item-from-menu 'print-buffer "print")
|
||||
(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.
|
||||
;; 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)")
|
||||
(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))))
|
||||
(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))))
|
||||
|
||||
|
||||
(provide 'tool-bar)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue