From: Lars Magne Ingebrigtsen <larsi@gnus.org>
Date: Fri, 4 Jan 2002 06:44:21 +0000 (+0000)
Subject: ShengHuo just checked in stuff that worked on the same functions as
X-Git-Url: https://cgit.sxemacs.org/?a=commitdiff_plain;h=d048be25d5e08f2ba33377c19350b647247f6fed;p=gnus

ShengHuo just checked in stuff that worked on the same functions as
this patch.  I've merged, and I hope that I kept all of his
changes...

* 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.
---

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 2ff376eb3..42d35990d 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,35 @@
+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
diff --git a/lisp/compface.el b/lisp/compface.el
index 0204ad38c..185f9494f 100644
--- a/lisp/compface.el
+++ b/lisp/compface.el
@@ -30,19 +30,26 @@
   "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)
diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el
index 8d312e38c..34e7a6f9d 100644
--- a/lisp/gnus-art.el
+++ b/lisp/gnus-art.el
@@ -228,15 +228,13 @@ regexp.  If it matches, the text in question is not a signature."
 (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."
@@ -1806,8 +1804,7 @@ unfolded."
 		  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)))
diff --git a/lisp/gnus-ems.el b/lisp/gnus-ems.el
index a239f1b9d..732fbe54c 100644
--- a/lisp/gnus-ems.el
+++ b/lisp/gnus-ems.el
@@ -209,65 +209,18 @@
 	  (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 " "))
@@ -279,8 +232,8 @@ for XEmacs."
   (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)
 
diff --git a/lisp/gnus-fun.el b/lisp/gnus-fun.el
index caae6ee67..9b033c332 100644
--- a/lisp/gnus-fun.el
+++ b/lisp/gnus-fun.el
@@ -159,6 +159,29 @@
 	  (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
diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el
index 98197d790..24c43278d 100644
--- a/lisp/gnus-xmas.el
+++ b/lisp/gnus-xmas.el
@@ -645,41 +645,6 @@ XEmacs compatibility workaround."
    '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))
@@ -820,23 +785,41 @@ XEmacs compatibility workaround."
 		      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.
@@ -851,7 +834,8 @@ Warning: Don't insert text immediately after the image."
     (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
diff --git a/lisp/gnus.el b/lisp/gnus.el
index 16b042178..c5f362dea 100644
--- a/lisp/gnus.el
+++ b/lisp/gnus.el
@@ -1987,7 +1987,8 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
       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