+2002-01-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * compface.el (uncompface): XEmacs and Emacs have differing
+ capabilities.
+
+ * gnus-fun.el (gnus-display-x-face-in-from): Use face.
+
+ * gnus-ems.el (gnus-article-xface-ring-internal): Removed.
+ (gnus-article-xface-ring-size): Removed.
+ (gnus-article-display-xface): Removed.
+ (gnus-remove-image): Cleaned up.
+
+ * gnus-xmas.el (gnus-xmas-create-image): Convert pbm to xbm.
+ (gnus-xmas-create-image): Take pbm files.
+ (gnus-x-face): Removed.
+ (gnus-xmas-article-display-xface): Removed.
+
+ * gnus-fun.el (gnus-display-x-face-in-from): Bind
+ default-enable-multibyte-characters.
+
+ * compface.el (uncompface): Doc fix.
+
+ * gnus-art.el (gnus-article-x-face-command): Use
+ gnus-display-x-face-in-from.
+
+ * gnus-xmas.el (gnus-xmas-put-image): Return the image.
+
+ * gnus-ems.el (gnus-put-image): Return the image.
+
+ * gnus-fun.el (gnus-display-x-face-in-from): New function.
+ (gnus-x-face): Moved here.
+
2002-01-04 ShengHuo ZHU <zsh@cs.rochester.edu>
* gnus-xmas.el (gnus-xmas-put-image): Don't insert SPC or make
"Convert FACE to pbm.
Requires the external programs `uncompface', and `icontopbm'. On a
GNU/Linux system these might be in packages with names like `compface'
-or `faces-xface' and `netpbm' or `libgr-progs', for instance. See
-also `compface-xbm-p'."
+or `faces-xface' and `netpbm' or `libgr-progs', for instance."
(with-temp-buffer
(insert face)
- (and (eq 0 (apply #'call-process-region (point-min) (point-max)
+ (and (eq 0 (apply 'call-process-region (point-min) (point-max)
"uncompface"
'delete '(t nil) nil))
(progn
(goto-char (point-min))
- (progn (insert "/* Width=48, Height=48 */\n") t)
- (eq 0 (call-process-region (point-min) (point-max)
- "icontopbm"
- 'delete '(t nil))))
+ (insert "/* Width=48, Height=48 */\n")
+ ;; I just can't get "icontopbm" to work correctly on its
+ ;; own in XEmacs. And Emacs doesn't understand un-raw pbm
+ ;; files.
+ (if (not (featurep 'xemacs))
+ (eq 0 (call-process-region (point-min) (point-max)
+ "icontopbm"
+ 'delete '(t nil)))
+ (shell-command-on-region (point-min) (point-max)
+ "icontopbm | pnmnoraw"
+ (current-buffer) t)
+ t))
(buffer-string))))
(provide 'compface)
(defcustom gnus-article-x-face-command
(if (featurep 'xemacs)
(if (or (gnus-image-type-available-p 'xface)
- (gnus-image-type-available-p 'xpm))
- 'gnus-xmas-article-display-xface
+ (gnus-image-type-available-p 'pbm))
+ 'gnus-display-x-face-in-from
"{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
- (if (gnus-image-type-available-p 'xbm)
- 'gnus-article-display-xface
- (if gnus-article-compface-xbm
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -"
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
-display -")))
+ (if (gnus-image-type-available-p 'pbm)
+ 'gnus-display-x-face-in-from
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
+display -"))
"*String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
image)
(when xpm
(setq image (gnus-create-image xpm 'xpm t))
- (goto-char (point-min))
- (re-search-forward "^From:" nil 'move)
+ (gnus-article-goto-header "from")
(gnus-add-wash-type 'xface)
(gnus-add-image 'xface image)
(gnus-put-image image)))
(goto-char (point-min))
(sit-for 0))))))
-(defvar gnus-article-xface-ring-internal nil
- "Cache for face data.")
-
-;; Worth customizing?
-(defvar gnus-article-xface-ring-size 6
- "Length of the ring used for `gnus-article-xface-ring-internal'.")
-
-(defun gnus-article-display-xface (data)
- "Display the XFace header FACE in the current buffer.
-Requires support for images in your Emacs and the external programs
-`uncompface', and `icontopbm'. On a GNU/Linux system these
-might be in packages with names like `compface' or `faces-xface' and
-`netpbm' or `libgr-progs', for instance. See also
-`gnus-article-compface-xbm'.
-
-This function is for Emacs 21+. See `gnus-xmas-article-display-xface'
-for XEmacs."
- ;; It might be worth converting uncompface's output in Lisp.
-
- (when (if (fboundp 'display-graphic-p)
- (display-graphic-p))
- (unless gnus-article-xface-ring-internal ; Only load ring when needed.
- (setq gnus-article-xface-ring-internal
- (make-ring gnus-article-xface-ring-size)))
- (save-excursion
- (let* ((cur (current-buffer))
- (image (cdr-safe (assoc data (ring-elements
- gnus-article-xface-ring-internal))))
- default-enable-multibyte-characters
- face)
- (unless image
- (when (setq face (uncompface data))
- ;; Miles Bader says that faces don't look right as
- ;; light on dark.
- (if (eq 'dark (cdr-safe (assq 'background-mode
- (frame-parameters))))
- (setq image (create-image face 'pbm
- t
- :ascent 'center
- :foreground "black"
- :background "white"))
- (setq image (create-image face 'pbm
- t :ascent 'center))))
- (ring-insert gnus-article-xface-ring-internal (cons data image)))
- (when image
- (goto-char (point-min))
- (re-search-forward "^From:" nil 'move)
- (gnus-add-wash-type 'xface)
- (gnus-add-image 'xface image)
- (gnus-put-image image))))))
-
;;; Image functions.
(defun gnus-image-type-available-p (type)
(and (fboundp 'image-type-available-p)
(image-type-available-p type)))
-(defun gnus-create-image (file &optional type data-p)
- (create-image file type data-p))
+(defun gnus-create-image (file &optional type data-p &rest props)
+ (let ((face (plist-get props :face)))
+ (when face
+ (setq props (plist-put props :foreground (face-foreground face)))
+ (setq props (plist-put props :background (face-background face))))
+ (apply 'create-image file type data-p props)))
(defun gnus-put-image (glyph &optional string)
(insert-image glyph (or string " "))
(dolist (position (message-text-with-property 'display))
(when (equal (get-text-property position 'display) image)
(put-text-property position (1+ position) 'display nil)
- (if (get-text-property position 'gnus-image-text-deletable)
- (delete-region position (1+ position))))))
+ (when (get-text-property position 'gnus-image-text-deletable)
+ (delete-region position (1+ position))))))
(provide 'gnus-ems)
(goto-char (point-max)))))
(gnus-convert-gray-x-face-to-xpm faces)))
+(defface gnus-x-face '((t (:foreground "black" :background "white")))
+ "Face to show X-Face.
+The colors from this face are used as the foreground and background
+colors of the displayed X-Faces."
+ :group 'gnus-article-headers)
+
+(defun gnus-display-x-face-in-from (data)
+ "Display the X-Face DATA in the From header."
+ (let ((default-enable-multibyte-characters nil)
+ pbm)
+ (when (and (gnus-image-type-available-p 'pbm)
+ (setq pbm (uncompface data)))
+ (save-excursion
+ (save-restriction
+ (article-narrow-to-head)
+ (gnus-article-goto-header "from")
+ (gnus-add-image 'xface (gnus-put-image
+ (gnus-create-image
+ pbm 'pbm t
+ :ascent 'center
+ :face 'gnus-x-face)))
+ (gnus-add-wash-type 'xface))))))
+
(provide 'gnus-fun)
;;; gnus-fun.el ends here
'call-process-region (point-min) (point-max) command t '(t nil) nil
args))
-(defface gnus-x-face '((t (:foreground "black" :background "white")))
- "Face to show X face"
- :group 'gnus-xmas)
-
-(defun gnus-xmas-article-display-xface (data)
- "Display the XFace in DATA."
- (save-excursion
- (let ((xface-glyph
- (cond
- ((featurep 'xface)
- (make-glyph (vector 'xface :data
- (concat "X-Face: " data))))
- ((featurep 'xpm)
- (let ((cur (current-buffer)))
- (save-excursion
- (gnus-set-work-buffer)
- (insert data)
- (let ((coding-system-for-read 'binary)
- (coding-system-for-write 'binary))
- (gnus-xmas-call-region "uncompface")
- (goto-char (point-min))
- (insert "/* Width=48, Height=48 */\n")
- (gnus-xmas-call-region "icontopbm")
- (gnus-xmas-call-region "ppmtoxpm")
- (make-glyph
- (vector 'xpm :data (buffer-string)))))))
- (t
- (make-glyph [nothing])))))
- (set-glyph-face xface-glyph 'gnus-x-face)
-
- (gnus-article-goto-header "from")
- (gnus-put-image xface-glyph)
- (gnus-add-wash-type 'xface)
- (gnus-add-image 'xface xface-glyph))))
-
(defvar gnus-xmas-modeline-left-extent
(let ((ext (copy-extent modeline-buffer-id-left-extent)))
ext))
gnus-mailing-list-menu))
(defun gnus-xmas-image-type-available-p (type)
+ (when (eq type 'pbm)
+ (setq type 'xbm))
(featurep type))
-(defun gnus-xmas-create-image (file &optional type data-p)
+(defun gnus-xmas-create-image (file &optional type data-p &rest props)
(let ((type (if type
(symbol-name type)
- (car (last (split-string file "[.]"))))))
- (if (equal type "xbm")
- (make-glyph (list (cons 'x file)))
+ (car (last (split-string file "[.]")))))
+ (face (plist-get props :face))
+ glyph)
+ (when (equal type "pbm")
(with-temp-buffer
- (if data-p
- (insert file)
- (insert-file-contents file))
- (make-glyph
- (vector
- (or (mm-image-type-from-buffer)
- (intern type))
- :data (buffer-string)))))))
+ (if data-p
+ (insert file)
+ (insert-file-contents file))
+ (shell-command-on-region (point-min) (point-max)
+ "ppmtoxpm 2>/dev/null" t)
+ (setq file (buffer-string)
+ type "xpm"
+ data-p t)))
+ (setq glyph
+ (if (equal type "xbm")
+ (make-glyph (list (cons 'x file)))
+ (with-temp-buffer
+ (if data-p
+ (insert file)
+ (insert-file-contents file))
+ (make-glyph
+ (vector
+ (or (intern type)
+ (mm-image-type-from-buffer))
+ :data (buffer-string))))))
+ (when face
+ (set-glyph-face glyph face))
+ glyph))
(defun gnus-xmas-put-image (glyph &optional string)
"Insert STRING, but display GLYPH.
(set-extent-property extent 'duplicable t)
(if string
(set-extent-property extent 'invisible t))
- (set-extent-property extent 'end-glyph glyph)))
+ (set-extent-property extent 'end-glyph glyph))
+ glyph)
(defun gnus-xmas-remove-image (image)
(map-extents
gnus-demon-remove-handler)
("gnus-demon" :interactive t
gnus-demon-init gnus-demon-cancel)
- ("gnus-fun" gnus-convert-gray-x-face-to-xpm)
+ ("gnus-fun" gnus-convert-gray-x-face-to-xpm gnus-display-x-face-in-from
+ gnus-convert-image-to-gray-x-face)
("gnus-salt" gnus-highlight-selected-tree gnus-possibly-generate-tree
gnus-tree-open gnus-tree-close gnus-carpal-setup-buffer)
("gnus-nocem" gnus-nocem-scan-groups gnus-nocem-close
projects / gnus / commitdiff