[Emacs-diffs] Changes to emacs/lisp/tool-bar.el,v

[Stefan Monnier]

CVSROOT:        /sources/emacs
Module name:    emacs
Changes by:     Stefan Monnier <monnier>        08/05/07 18:16:29

Index: tool-bar.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/tool-bar.el,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -b -r1.13 -r1.14
--- tool-bar.el 6 May 2008 07:57:55 -0000       1.13
+++ tool-bar.el 7 May 2008 18:16:28 -0000       1.14
@@ -86,7 +86,35 @@
 
 (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 @@
 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 @@
                                  (concat icon ".pbm")) colors))
         (xbm-spec (append (list :type 'xbm :file
                                  (concat icon ".xbm")) colors))
-        (image (find-image
+        (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)))))
+                          ',(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)))))
+      `(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,12 +210,11 @@
                                  (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)
@@ -208,12 +232,10 @@
                        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))
+            (append (cdr defn) (list :image image-exp) props))
          (setq defn (cdr defn))
          (define-key-after in-map (vector key)
            (let ((rest (cdr defn)))
@@ -222,7 +244,7 @@
              (if (and (consp rest) (consp (car rest)))
                  (setq rest (cdr rest)))
              (append `(menu-item ,(car defn) ,rest)
-                     (list :image image) props))))))))
+                    (list :image image-exp) props)))))))
 
 ;;; Set up some global items.  Additions/deletions up for grabs.