* Reiner Steib <[EMAIL PROTECTED]> writes: > On Thu, Sep 01 2005, Steve Youngs wrote: >> - ((string-match "^21\\." emacs-version) ;; XXX how far back can I go? >> + ((emacs-version>= 21) ;; XXX how far back can I go?
> Wouldn't if make more sense to test for features rather than
> version?
Yes, it probably would. How about this patch instead (which also adds
support for displaying those colour Face images).
The patch also removes the code for displaying X-Face's in ancient
versions of XEmacs. To keep the XEmacs folks happy you only need to
support back to 21.4. This patch, however, will be fine for any
version back to 21.1 (possibly 21.0).
2005-09-04 Steve Youngs <[EMAIL PROTECTED]>
* lisp/bbdb-gui.el (bbdb-hack-x-face): Rewrite, omitting version
checks and remove all the old stuff for ancient versions of
XEmacs.
(bbdb-convert-face-to-png): New.
(bbdb-hack-c-face): New. Display colour Face header images.
(bbdb-fontify-buffer): Use it.
Index: lisp/bbdb-gui.el
===================================================================
RCS file: /cvsroot/bbdb/bbdb/lisp/bbdb-gui.el,v
retrieving revision 1.33
diff -u -p -r1.33 bbdb-gui.el
--- lisp/bbdb-gui.el 25 Jun 2003 15:58:06 -0000 1.33
+++ lisp/bbdb-gui.el 3 Sep 2005 14:41:57 -0000
@@ -182,7 +182,7 @@
(bbdb-set-specifier scrollbar-height (cons (current-buffer) 0)))
(let ((rest (or records bbdb-records))
- record face
+ record face cface
start end s e
multi-line-p
property
@@ -193,6 +193,7 @@
multi-line-p (string-match "multi-line"
(symbol-name (nth 1 (car rest))))
face (and multi-line-p (bbdb-record-getprop record 'face))
+ cface (and multi-line-p (bbdb-record-getprop record 'cface))
start (marker-position (nth 2 (car rest)))
end (1- (or (nth 2 (car (cdr rest))) (point-max))))
@@ -215,6 +216,7 @@
;; bogus, like most GNU Emacs GUI stuff.
(bbdb-set-extent-property extent 'priority 3)
(if face (bbdb-hack-x-face face extent))
+ (if cface (bbdb-hack-c-face cface extent))
(goto-char start)
(setq s start)
(setq property (cadr (member 'bbdb-field (text-properties-at s))))
@@ -261,57 +263,17 @@
"Process a face property of a record and honour it.
Not done for GNU Emacs just yet, since it doesn't have image support
as of GNU Emacs 20.7"
- (if (not (or (and (fboundp 'highlight-headers-hack-x-face-p)
- (symbol-value (intern ;; compiler
- "highlight-headers-hack-x-face-p"))) ;; ick.
- (and (featurep 'xemacs)
- (string-match "^21\\." emacs-version)))) ;; XXX
- () ;; nothing doing
+ (when (and (featurep 'xemacs)
+ (featurep 'xface))
(setq face (bbdb-split face "\n"))
(while face
- (cond
-
- ;; ripped pretty much verbatim from VM; X Faces for recent XEmacsen.
- ((string-match "^21\\." emacs-version) ;; XXX how far back can I go?
- (condition-case nil
- (let* ((h (concat "X-Face: " (car face))) ;; from vm-display-xface
- (g (intern h vm-xface-cache)))
- (if (bbdb-find-face 'vm-xface) ;; use the same face as VM
- nil
- (make-face 'vm-xface)
- (set-face-background 'vm-xface "white")
- (set-face-foreground 'vm-xface "black"))
- (if (boundp g)
- (setq g (symbol-value g))
- (set g (bbdb-make-glyph
- (list
- (vector 'xface ':data h)))) ;; XXX use API
- (setq g (symbol-value g))
- (bbdb-set-glyph-face g 'vm-xface))
- (bbdb-set-extent-property extent 'vm-xface t)
- (bbdb-set-extent-begin-glyph extent g))
- (error nil))) ;; looks like you don't have xface support, d00d
-
- ;; requires lemacs 19.10 version of highlight-headers.el
- ((fboundp 'highlight-headers-x-face) ; the 19.10 way
- (bbdb-highlight-headers-x-face (car face) extent)
- (let ((b (bbdb-extent-property extent 'begin-glyph)))
- (cond (b ; I'd like this to be an end-glyph instead
- (bbdb-set-extent-property extent 'begin-glyph nil)
- (bbdb-set-extent-property extent 'end-glyph b)))))
-
- ((fboundp 'highlight-headers-x-face-to-pixmap) ; the 19.13 way
- (save-excursion
- (set-buffer (get-buffer-create " *tmp*"))
- (buffer-disable-undo (current-buffer))
- (erase-buffer)
- (insert (car face))
- (bbdb-set-extent-begin-glyph extent nil)
- (bbdb-set-extent-end-glyph extent
- (bbdb-highlight-headers-x-face-to-pixmap
- (point-min) (point-max)))
- (erase-buffer))))
-
+ (let ((glyph (concat "X-Face: " (car face))))
+ (bbdb-set-extent-begin-glyph
+ extent
+ (bbdb-make-glyph (list (vector 'xface
+ :data glyph
+ :foreground "black"
+ :background "white")))))
;; more faces?
(setq face (cdr face))
(cond (face ; there are more, so clone the extent
@@ -320,6 +282,35 @@ as of GNU Emacs 20.7"
(bbdb-extent-end-position extent)))
(bbdb-set-extent-property extent 'data 'bbdb))))))
+;; shamelessly stolen from Gnus
+(defun bbdb-convert-face-to-png (face)
+ "Convert FACE (which is base64-encoded) to a PNG.
+The PNG is returned as a string."
+ (with-temp-buffer
+ (insert face)
+ (ignore-errors
+ (base64-decode-region (point-min) (point-max)))
+ (buffer-string)))
+
+(defun bbdb-hack-c-face (cface extent)
+ "Process a cface property of a record and honour it.
+Not done for GNU/Emacs."
+ (when (and (featurep 'xemacs)
+ (featurep 'png))
+ (let ((ext (bbdb-make-extent (bbdb-extent-start-position extent)
+ (bbdb-extent-start-position extent))))
+ (setq cface (bbdb-split cface "\n"))
+ (while cface
+ (bbdb-set-extent-begin-glyph
+ ext
+ (bbdb-make-glyph
+ (list (vector 'png :data (bbdb-convert-face-to-png (car cface))))))
+ (setq cface (cdr cface))
+ (cond (cface ; there are more, so clone the extent
+ (setq ext (bbdb-make-extent
+ (bbdb-extent-start-position ext)
+ (bbdb-extent-end-position ext)))
+ (bbdb-set-extent-property ext 'data 'bbdb)))))))
(defcustom bbdb-user-menu-commands nil
"User defined menu entries which should be appended to the BBDB menu.
--
|---<Steve Youngs>---------------<GnuPG KeyID: A94B3003>---|
| Te audire no possum. |
| Musa sapientum fixa est in aure. |
|----------------------------------<[EMAIL PROTECTED]>---|
pgp39vjxvRjGi.pgp
Description: PGP signature
