2002-01-01 Steve Youngs <youngs@xemacs.org>

[gnus] / lisp / gnus-xmas.el

diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el
index f060c03..15a300c 100644 (file)
--- a/lisp/gnus-xmas.el
+++ b/lisp/gnus-xmas.el
@@ -1,6 +1,6 @@
 ;;; gnus-xmas.el --- Gnus functions for XEmacs
 
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
 ;;        Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -50,37 +50,6 @@ automatically."
     (error "Can't find glyph directory. \
 Possibly the `etc' directory has not been installed.")))
 
-;;(format "%02x%02x%02x" 114 66 20) "724214"
-
-(defvar gnus-xmas-logo-color-alist
-  '((flame "#cc3300" "#ff2200")
-    (pine "#c0cc93" "#f8ffb8")
-    (moss "#a1cc93" "#d2ffb8")
-    (irish "#04cc90" "#05ff97")
-    (sky "#049acc" "#05deff")
-    (tin "#6886cc" "#82b6ff")
-    (velvet "#7c68cc" "#8c82ff")
-    (grape "#b264cc" "#cf7df")
-    (labia "#cc64c2" "#fd7dff")
-    (berry "#cc6485" "#ff7db5")
-    (dino "#724214" "#1e3f03")
-    (neutral "#b4b4b4" "#878787")
-    (september "#bf9900" "#ffcc00"))
-  "Color alist used for the Gnus logo.")
-
-(defcustom gnus-xmas-logo-color-style 'dino
-  "*Color styles used for the Gnus logo."
-  :type '(choice (const flame) (const pine) (const moss)
-                (const irish) (const sky) (const tin)
-                (const velvet) (const grape) (const labia)
-                (const berry) (const neutral) (const september)
-                (const dino))
-  :group 'gnus-xmas)
-
-(defvar gnus-xmas-logo-colors
-  (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist))
-  "Colors used for the Gnus logo.")
-
 ;;; Internal variables.
 
 ;; Don't warn about these undefined variables.
@@ -470,6 +439,7 @@ call it with the value of the `gnus-data' text property."
   (defalias 'gnus-image-type-available-p 'gnus-xmas-image-type-available-p)
   (defalias 'gnus-put-image 'gnus-xmas-put-image)
   (defalias 'gnus-create-image 'gnus-xmas-create-image)
+  (defalias 'gnus-remove-image 'gnus-xmas-remove-image)
 
   ;; These ones are not defcutom'ed, sometimes not even defvar'ed. They
   ;; probably should. If that is done, the code below should then be moved
@@ -501,8 +471,8 @@ call it with the value of the `gnus-data' text property."
                          `[xpm
                            :file ,logo-xpm
                            :color-symbols
-                           (("thing" . ,(car gnus-xmas-logo-colors))
-                            ("shadow" . ,(cadr gnus-xmas-logo-colors))
+                           (("thing" . ,(car gnus-logo-colors))
+                            ("shadow" . ,(cadr gnus-logo-colors))
                             ("background" . ,(face-background 'default)))])
                         ((featurep 'xbm)
                          `[xbm :file ,logo-xbm])
@@ -679,23 +649,19 @@ XEmacs compatibility workaround."
   "Face to show X face"
   :group 'gnus-xmas)
 
-(defun gnus-xmas-article-display-xface (beg end &optional buffer)
-  "Display any XFace headers in BUFFER."
+(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: "
-                                        (if buffer
-                                            (with-current-buffer buffer
-                                              (buffer-substring beg end))
-                                          (buffer-substring beg end))))))
+                                (concat "X-Face: " data))))
            ((featurep 'xpm)
-            (let ((cur (or buffer (current-buffer))))
+            (let ((cur (current-buffer)))
               (save-excursion
                 (gnus-set-work-buffer)
-                (insert-buffer-substring cur beg end)
+                (insert data)
                 (let ((coding-system-for-read 'binary)
                       (coding-system-for-write 'binary))
                   (gnus-xmas-call-region "uncompface")
@@ -706,15 +672,13 @@ XEmacs compatibility workaround."
                   (make-glyph
                    (vector 'xpm :data (buffer-string)))))))
            (t
-            (make-glyph [nothing]))))
-         (ext (make-extent (progn
-                             (goto-char (point-min))
-                             (re-search-forward "^From:" nil t)
-                             (point))
-                           (1+ (point)))))
+            (make-glyph [nothing])))))
       (set-glyph-face xface-glyph 'gnus-x-face)
-      (set-extent-begin-glyph ext xface-glyph)
-      (set-extent-property ext 'duplicable t))))
+
+      (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)))
@@ -863,10 +827,22 @@ XEmacs compatibility workaround."
     (insert-file-contents file)
     (mm-create-image-xemacs (car (last (split-string file "[.]"))))))
 
-(defun gnus-xmas-put-image (glyph)
-  (let ((annot (make-annotation glyph nil 'text)))
-    (set-extent-property annot 'mm t)
-    (set-extent-property annot 'duplicable t)))
+(defun gnus-xmas-put-image (glyph &optional string)
+  (let ((begin (point))
+       extent)
+    (insert string)
+    (setq extent (make-extent begin (point)))
+    (set-extent-property extent 'gnus-image t)
+    (set-extent-property extent 'duplicable t)
+    (set-extent-property extent 'begin-glyph glyph)))
+
+(defun gnus-xmas-remove-image (image)
+  (map-extents
+   (lambda (ext unused)
+     (when (equal (extent-begin-glyph ext) image)
+       (set-extent-property ext 'begin-glyph nil))
+     nil)
+   nil nil nil nil nil 'gnus-image))
 
 (provide 'gnus-xmas)