*** empty log message ***

[gnus] / lisp / gnus-xmas.el

diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el
index 5e3dc56..9d3d239 100644 (file)
--- a/lisp/gnus-xmas.el
+++ b/lisp/gnus-xmas.el
@@ -1,7 +1,7 @@
 ;;; gnus-xmas.el --- Gnus functions for XEmacs
 ;;; gnus-xmas.el --- Gnus functions for XEmacs

-;; Copyright (C) 1995,96 Free Software Foundation, Inc.
+;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.

 
 

-;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>

 ;; Keywords: news
 
 ;; This file is part of GNU Emacs.
 ;; Keywords: news
 
 ;; This file is part of GNU Emacs.


@@ -29,10 +29,17 @@
 (defvar menu-bar-mode (featurep 'menubar))
 (require 'messagexmas)
 
 (defvar menu-bar-mode (featurep 'menubar))
 (require 'messagexmas)
 

-(defvar gnus-xmas-glyph-directory nil
-  "*Directory where Gnus logos and icons are located.
+(defgroup gnus-xmas nil
+  "XEmacsoid support for Gnus"
+  :group 'gnus)
+
+(defcustom gnus-xmas-glyph-directory nil
+  "Directory where Gnus logos and icons are located.

 If this variable is nil, Gnus will try to locate the directory
 If this variable is nil, Gnus will try to locate the directory

-automatically.")
+automatically."
+  :type '(choice (const :tag "autodetect" nil)
+                directory)
+  :group 'gnus-xmas)

 
 (defvar gnus-xmas-logo-color-alist
   '((flame "#cc3300" "#ff2200")
 
 (defvar gnus-xmas-logo-color-alist
   '((flame "#cc3300" "#ff2200")


@@ -49,20 +56,27 @@ automatically.")
     (september "#bf9900" "#ffcc00"))
   "Color alist used for the Gnus logo.")
 
     (september "#bf9900" "#ffcc00"))
   "Color alist used for the Gnus logo.")
 

-(defvar gnus-xmas-logo-color-style 'flame
-  "Color styles used for the Gnus logo.")
+(defcustom gnus-xmas-logo-color-style 'moss
+  "*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))
+  :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.")
 
 
 (defvar gnus-xmas-logo-colors
   (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist))
   "Colors used for the Gnus logo.")
 

-(defvar gnus-article-x-face-command
-  (if (featurep 'xface)
+(defcustom gnus-article-x-face-command
+  (if (or (featurep 'xface)
+         (featurep 'xpm))

       'gnus-xmas-article-display-xface
     "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -")
       'gnus-xmas-article-display-xface
     "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -")

-  "String or function to be executed to display an X-Face header.
+  "*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
 If it is a string, the command will be executed in a sub-shell

-asynchronously.         The compressed face will be piped to this command.")
+asynchronously.         The compressed face will be piped to this command."
+  :type '(choice string function))

 
 ;;; Internal variables.
 
 
 ;;; Internal variables.
 


@@ -120,11 +134,12 @@ It is provided only to ease porting of broken FSF Emacs programs."
   (if (stringp buffer)
       nil
     (map-extents (lambda (extent ignored)
   (if (stringp buffer)
       nil
     (map-extents (lambda (extent ignored)

-                  (remove-text-properties 
-                   start end
-                   (list (extent-property extent 'text-prop) nil)
-                   buffer))
-                buffer start end nil nil 'text-prop)
+                   (remove-text-properties
+                    start end
+                    (list (extent-property extent 'text-prop) nil)
+                    buffer)
+                  nil)
+                 buffer start end nil nil 'text-prop)

     (gnus-add-text-properties start end props buffer)))
 
 (defun gnus-xmas-highlight-selected-summary ()
     (gnus-add-text-properties start end props buffer)))
 
 (defun gnus-xmas-highlight-selected-summary ()


@@ -132,14 +147,20 @@ It is provided only to ease porting of broken FSF Emacs programs."
   (when gnus-summary-selected-face
     (when gnus-newsgroup-selected-overlay
       (delete-extent gnus-newsgroup-selected-overlay))
   (when gnus-summary-selected-face
     (when gnus-newsgroup-selected-overlay
       (delete-extent gnus-newsgroup-selected-overlay))

-    (setq gnus-newsgroup-selected-overlay 
+    (setq gnus-newsgroup-selected-overlay

          (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
     (set-extent-face gnus-newsgroup-selected-overlay
                     gnus-summary-selected-face)))
 
          (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
     (set-extent-face gnus-newsgroup-selected-overlay
                     gnus-summary-selected-face)))
 

-(defvar gnus-xmas-force-redisplay t
-  "If non-nil, force a redisplay before recentering the summary buffer.
-This is ugly, but it works around a bug in `window-displayed-height'.")
+(defcustom gnus-xmas-force-redisplay nil
+  "*If non-nil, force a redisplay before recentering the summary buffer.
+This is ugly, but it works around a bug in `window-displayed-height'."
+  :type 'boolean
+  :group 'gnus-xmas)
+
+(defun gnus-xmas-switch-horizontal-scrollbar-off ()
+  (when (featurep 'scrollbar)
+    (set-specifier scrollbar-height (cons (current-buffer) 0))))

 
 (defun gnus-xmas-summary-recenter ()
   "\"Center\" point in the summary window.
 
 (defun gnus-xmas-summary-recenter ()
   "\"Center\" point in the summary window.


@@ -177,8 +198,27 @@ displayed, no centering will be performed."
          (gnus-horizontal-recenter)
          (select-window selected))))))
 
          (gnus-horizontal-recenter)
          (select-window selected))))))
 

-(defun gnus-xmas-add-hook (hook function &optional append local)
-  (add-hook hook function))
+(defun gnus-xmas-summary-set-display-table ()
+  ;; Setup the display table -- like `gnus-summary-setup-display-table',
+  ;; but done in an XEmacsish way.
+  (let ((table (make-display-table))
+       (i 32))
+    ;; Nix out all the control chars...
+    (while (>= (setq i (1- i)) 0)
+      (aset table i [??]))
+    ;; ... but not newline and cr, of course.  (cr is necessary for the
+    ;; selective display).
+    (aset table ?\n nil)
+    (aset table ?\r nil)
+    ;; We keep TAB as well.
+    (aset table ?\t nil)
+    ;; We nix out any glyphs over 126 below ctl-arrow.
+    (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
+      (while (>= (setq i (1- i)) 127)
+       (unless (aref table i)
+         (aset table i [??]))))
+    ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
+    (add-spec-to-specifier current-display-table table (current-buffer) nil)))

 
 (defun gnus-xmas-add-text-properties (start end props &optional object)
   (add-text-properties start end props object)
 
 (defun gnus-xmas-add-text-properties (start end props &optional object)
   (add-text-properties start end props object)


@@ -192,7 +232,7 @@ displayed, no centering will be performed."
   (map-extents (lambda (extent arg)
                 (set-extent-property extent 'start-open t))
               nil point (min (1+ (point)) (point-max))))
   (map-extents (lambda (extent arg)
                 (set-extent-property extent 'start-open t))
               nil point (min (1+ (point)) (point-max))))

-                 
+

 (defun gnus-xmas-article-push-button (event)
   "Check text under the mouse pointer for a callback function.
 If the text under the mouse pointer has a `gnus-callback' property,
 (defun gnus-xmas-article-push-button (event)
   "Check text under the mouse pointer for a callback function.
 If the text under the mouse pointer has a `gnus-callback' property,


@@ -206,7 +246,13 @@ call it with the value of the `gnus-data' text property."
       (funcall fun data))))
 
 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
       (funcall fun data))))
 
 (defun gnus-xmas-move-overlay (extent start end &optional buffer)

-  (set-extent-endpoints extent start end))
+  (set-extent-endpoints extent start end buffer))
+
+(defun gnus-xmas-kill-all-overlays ()
+  "Delete all extents in the current buffer."
+  (map-extents (lambda (extent ignore)
+                (delete-extent extent)
+                nil)))

 
 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
 (defun gnus-xmas-article-add-button (from to fun &optional data)
 
 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
 (defun gnus-xmas-article-add-button (from to fun &optional data)


@@ -214,7 +260,7 @@ call it with the value of the `gnus-data' text property."
   (when gnus-article-button-face
     (gnus-overlay-put (gnus-make-overlay from to)
                      'face gnus-article-button-face))
   (when gnus-article-button-face
     (gnus-overlay-put (gnus-make-overlay from to)
                      'face gnus-article-button-face))

-  (gnus-add-text-properties 
+  (gnus-add-text-properties

    from to
    (nconc
     (and gnus-article-mouse-face
    from to
    (nconc
     (and gnus-article-mouse-face


@@ -252,8 +298,8 @@ call it with the value of the `gnus-data' text property."
          (window-search t))
     (while window-search
       (let* ((this-window (next-window))
          (window-search t))
     (while window-search
       (let* ((this-window (next-window))

-             (next-bottom-edge (car (cdr (cdr (cdr 
-                                               (window-pixel-edges 
+             (next-bottom-edge (car (cdr (cdr (cdr
+                                               (window-pixel-edges

                                                this-window)))))))
         (when (< bottom-edge next-bottom-edge)
          (setq bottom-edge next-bottom-edge)
                                                this-window)))))))
         (when (< bottom-edge next-bottom-edge)
          (setq bottom-edge next-bottom-edge)


@@ -304,10 +350,26 @@ call it with the value of the `gnus-data' text property."
   (gnus-xmas-menu-add binary
     gnus-binary-menu))
 
   (gnus-xmas-menu-add binary
     gnus-binary-menu))
 

+(defun gnus-xmas-agent-summary-menu-add ()
+  (gnus-xmas-menu-add agent-summary
+    gnus-agent-summary-menu))
+
+(defun gnus-xmas-agent-group-menu-add ()
+  (gnus-xmas-menu-add agent-group
+    gnus-agent-group-menu))
+
+(defun gnus-xmas-agent-server-menu-add ()
+  (gnus-xmas-menu-add agent-server
+    gnus-agent-server-menu))
+

 (defun gnus-xmas-tree-menu-add ()
   (gnus-xmas-menu-add tree
     gnus-tree-menu))
 
 (defun gnus-xmas-tree-menu-add ()
   (gnus-xmas-menu-add tree
     gnus-tree-menu))
 

+(defun gnus-xmas-draft-menu-add ()
+  (gnus-xmas-menu-add draft
+    gnus-draft-menu))
+

 (defun gnus-xmas-server-menu-add ()
   (gnus-xmas-menu-add menu
     gnus-server-server-menu gnus-server-connections-menu))
 (defun gnus-xmas-server-menu-add ()
   (gnus-xmas-menu-add menu
     gnus-server-server-menu gnus-server-connections-menu))


@@ -325,32 +387,14 @@ call it with the value of the `gnus-data' text property."
   (let ((event (next-command-event)))
     (sit-for 0)
     ;; We junk all non-key events.  Is this naughty?
   (let ((event (next-command-event)))
     (sit-for 0)
     ;; We junk all non-key events.  Is this naughty?

-    (while (not (key-press-event-p event))
+    (while (not (or (key-press-event-p event)
+                   (button-press-event-p event)))
+      (dispatch-event event)

       (setq event (next-command-event)))
       (setq event (next-command-event)))

-    (cons (and (key-press-event-p event) 
-              (event-to-character event)) 
+    (cons (and (key-press-event-p event)
+              (event-to-character event))

          event)))
 
          event)))
 

-(defun gnus-xmas-group-remove-excess-properties ()
-  (let ((end (point))
-       (beg (progn (forward-line -1) (point))))
-    (remove-text-properties (1+ beg) end '(gnus-group nil))
-    (remove-text-properties 
-     beg end 
-     '(gnus-topic nil gnus-topic-level nil gnus-topic-visible nil))
-    (goto-char end)
-    (map-extents 
-     (lambda (e ma)
-       (set-extent-property e 'start-closed t))
-     (current-buffer) beg end)))
-                 
-(defun gnus-xmas-topic-remove-excess-properties ()
-  (let ((end (point))
-       (beg (progn (forward-line -1) (point))))
-    (remove-text-properties beg end '(gnus-group nil gnus-unread nil))
-    (remove-text-properties (1+ beg) end '(gnus-topic nil))
-    (goto-char end)))
-

 (defun gnus-xmas-seconds-since-epoch (date)
   "Return a floating point number that says how many seconds have lapsed between Jan 1 12:00:00 1970 and DATE."
   (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti)))
 (defun gnus-xmas-seconds-since-epoch (date)
   "Return a floating point number that says how many seconds have lapsed between Jan 1 12:00:00 1970 and DATE."
   (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti)))


@@ -360,9 +404,9 @@ call it with the value of the `gnus-data' text property."
                         (aref (timezone-parse-date date) 3))))
         (edate (mapcar (lambda (ti) (and ti (string-to-int ti)))
                        (timezone-parse-date "Jan 1 12:00:00 1970")))
                         (aref (timezone-parse-date date) 3))))
         (edate (mapcar (lambda (ti) (and ti (string-to-int ti)))
                        (timezone-parse-date "Jan 1 12:00:00 1970")))

-        (tday (- (timezone-absolute-from-gregorian 
+        (tday (- (timezone-absolute-from-gregorian

                   (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
                   (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))

-                 (timezone-absolute-from-gregorian 
+                 (timezone-absolute-from-gregorian

                   (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
     (+ (nth 2 ttime)
        (* (nth 1 ttime) 60)
                   (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
     (+ (nth 2 ttime)
        (* (nth 1 ttime) 60)


@@ -381,18 +425,29 @@ call it with the value of the `gnus-data' text property."
   (unless (face-differs-from-default-p 'underline)
     (funcall (intern "set-face-underline-p") 'underline t))
 
   (unless (face-differs-from-default-p 'underline)
     (funcall (intern "set-face-underline-p") 'underline t))
 

-  (fset 'gnus-characterp 'characterp)
+  (cond
+   ((fboundp 'char-or-char-int-p)
+    ;; Handle both types of marks for XEmacs-20.x.
+    (fset 'gnus-characterp 'char-or-char-int-p))
+   ;; V19 of XEmacs, probably.
+   (t
+    (fset 'gnus-characterp 'characterp)))
+

   (fset 'gnus-make-overlay 'make-extent)
   (fset 'gnus-make-overlay 'make-extent)

+  (fset 'gnus-delete-overlay 'delete-extent)

   (fset 'gnus-overlay-put 'set-extent-property)
   (fset 'gnus-move-overlay 'gnus-xmas-move-overlay)
   (fset 'gnus-overlay-end 'extent-end-position)
   (fset 'gnus-overlay-put 'set-extent-property)
   (fset 'gnus-move-overlay 'gnus-xmas-move-overlay)
   (fset 'gnus-overlay-end 'extent-end-position)

+  (fset 'gnus-kill-all-overlays 'gnus-xmas-kill-all-overlays)

   (fset 'gnus-extent-detached-p 'extent-detached-p)
   (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
   (fset 'gnus-put-text-property 'gnus-xmas-put-text-property)
   (fset 'gnus-extent-detached-p 'extent-detached-p)
   (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
   (fset 'gnus-put-text-property 'gnus-xmas-put-text-property)

-      
-  (require 'text-props)
-  (when (< emacs-minor-version 14)
-    (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
+  (fset 'gnus-deactivate-mark 'ignore)
+  (fset 'gnus-window-edges 'window-pixel-edges)
+
+  (if (and (<= emacs-major-version 19)
+          (< emacs-minor-version 14))
+      (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties))

 
   (when (fboundp 'turn-off-scroll-in-place)
     (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
 
   (when (fboundp 'turn-off-scroll-in-place)
     (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))


@@ -406,30 +461,29 @@ call it with the value of the `gnus-data' text property."
     (defun encode-time (sec minute hour day month year &optional zone)
       (let ((seconds
             (gnus-xmas-seconds-since-epoch
     (defun encode-time (sec minute hour day month year &optional zone)
       (let ((seconds
             (gnus-xmas-seconds-since-epoch

-             (timezone-make-arpa-date 
+             (timezone-make-arpa-date

               year month day (timezone-make-time-string hour minute sec)
               zone))))
        (list (floor (/ seconds (expt 2 16)))
              (round (mod seconds (expt 2 16)))))))
               year month day (timezone-make-time-string hour minute sec)
               zone))))
        (list (floor (/ seconds (expt 2 16)))
              (round (mod seconds (expt 2 16)))))))

-      
+

   (defun gnus-byte-code (func)
     "Return a form that can be `eval'ed based on FUNC."
   (defun gnus-byte-code (func)
     "Return a form that can be `eval'ed based on FUNC."

-    (let ((fval (symbol-function func)))
+    (let ((fval (indirect-function func)))

       (if (compiled-function-p fval)
          (list 'funcall fval)
        (cons 'progn (cdr (cdr fval))))))
 
       (if (compiled-function-p fval)
          (list 'funcall fval)
        (cons 'progn (cdr (cdr fval))))))
 

-  (fset 'gnus-x-color-values 
+  (fset 'gnus-x-color-values

        (if (fboundp 'x-color-values)
            'x-color-values
          (lambda (color)
            (color-instance-rgb-components
             (make-color-instance color))))))
 
        (if (fboundp 'x-color-values)
            'x-color-values
          (lambda (color)
            (color-instance-rgb-components
             (make-color-instance color))))))
 

-

 (defun gnus-xmas-redefine ()
   "Redefine lots of Gnus functions for XEmacs."
 (defun gnus-xmas-redefine ()
   "Redefine lots of Gnus functions for XEmacs."

-  (fset 'gnus-summary-make-display-table 'ignore)
+  (fset 'gnus-summary-set-display-table 'gnus-xmas-summary-set-display-table)

   (fset 'gnus-visual-turn-off-edit-menu 'identity)
   (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
   (fset 'gnus-extent-start-open 'gnus-xmas-extent-start-open)
   (fset 'gnus-visual-turn-off-edit-menu 'identity)
   (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
   (fset 'gnus-extent-start-open 'gnus-xmas-extent-start-open)


@@ -439,15 +493,14 @@ call it with the value of the `gnus-data' text property."
   (fset 'gnus-read-event-char 'gnus-xmas-read-event-char)
   (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
   (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
   (fset 'gnus-read-event-char 'gnus-xmas-read-event-char)
   (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
   (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize)

-  (fset 'gnus-appt-select-lowest-window 
+  (fset 'gnus-appt-select-lowest-window

        'gnus-xmas-appt-select-lowest-window)
   (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
        'gnus-xmas-appt-select-lowest-window)
   (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)

-  (fset 'gnus-make-local-hook 'make-local-variable)
-  (fset 'gnus-add-hook 'gnus-xmas-add-hook)

   (fset 'gnus-character-to-event 'character-to-event)
   (fset 'gnus-mode-line-buffer-identification
        'gnus-xmas-mode-line-buffer-identification)
   (fset 'gnus-key-press-event-p 'key-press-event-p)
   (fset 'gnus-character-to-event 'character-to-event)
   (fset 'gnus-mode-line-buffer-identification
        'gnus-xmas-mode-line-buffer-identification)
   (fset 'gnus-key-press-event-p 'key-press-event-p)

+  (fset 'gnus-region-active-p 'region-active-p)

 
   (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add)
 
   (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add)


@@ -465,20 +518,14 @@ call it with the value of the `gnus-data' text property."
   (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar)
 
   (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar)
 

-  (when (and (<= emacs-major-version 19)
-            (<= emacs-minor-version 13))
-    (setq gnus-article-x-face-too-ugly (when (eq (device-type) 'tty)
-                                        "."))
-    (fset 'gnus-highlight-selected-summary
-         'gnus-xmas-highlight-selected-summary)
-    (fset 'gnus-group-remove-excess-properties
-         'gnus-xmas-group-remove-excess-properties)
-    (fset 'gnus-topic-remove-excess-properties
-         'gnus-xmas-topic-remove-excess-properties)
-    (fset 'gnus-mode-line-buffer-identification 'identity)
-    (unless (boundp 'shell-command-switch)
-      (setq shell-command-switch "-c"))
-    ))
+  (add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add)
+  (add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add)
+  (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add)
+
+  (add-hook 'gnus-draft-mode-hook 'gnus-xmas-draft-menu-add)
+  (add-hook 'gnus-summary-mode-hook
+           'gnus-xmas-switch-horizontal-scrollbar-off)
+  (add-hook 'gnus-tree-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off))

 
 
 ;;; XEmacs logo and toolbar.
 
 
 ;;; XEmacs logo and toolbar.


@@ -488,92 +535,97 @@ call it with the value of the `gnus-data' text property."
   ;; Insert the message.
   (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
   (erase-buffer)
   ;; Insert the message.
   (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
   (erase-buffer)

-  (let ((logo (and gnus-xmas-glyph-directory
-                  (concat 
-                   (file-name-as-directory gnus-xmas-glyph-directory)
-                   "gnus."
-                   (if (featurep 'xpm) "xpm" "xbm"))))
-       (xpm-color-symbols 
-        (and (featurep 'xpm)
-             (append `(("thing" ,(car gnus-xmas-logo-colors))
-                       ("shadow" ,(cadr gnus-xmas-logo-colors)))
-                     xpm-color-symbols))))
-    (if (and (featurep 'xpm)
-            (not (equal (device-type) 'tty))
-            logo
-            (file-exists-p logo))
-       (progn
-         (setq logo (make-glyph logo))
-         (insert " ")
-         (set-extent-begin-glyph (make-extent (point) (point)) logo)
-         (goto-char (point-min))
-         (while (not (eobp))
-           (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
-                                ? ))
-           (forward-line 1))
-         (goto-char (point-min))
-         (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
-                (wheight (window-height))
-                (rest (- wheight pheight)))
-           (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
-
-      (insert
-       (format "              %s
-          _    ___ _             _      
-          _ ___ __ ___  __    _ ___     
-          __   _     ___    __  ___     
-              _           ___     _     
-             _  _ __             _      
-             ___   __            _      
-                   __           _       
-                    _      _   _        
-                   _      _    _        
-                      _  _    _         
-                  __  ___               
-                 _   _ _     _          
-                _   _                   
-              _    _                    
-             _    _                     
-            _                         
-          __                             
-
-" 
-              ""))
-      ;; And then hack it.
-      (gnus-indent-rigidly (point-min) (point-max)
-                          (/ (max (- (window-width) (or x 46)) 0) 2))
+  (cond
+   ((and (console-on-window-system-p)
+        (or (featurep 'xpm)
+            (featurep 'xbm)))
+    (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory))
+          (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory))
+          (glyph (make-glyph
+                  (cond ((featurep 'xpm)
+                         `[xpm
+                           :file ,logo-xpm
+                           :color-symbols
+                           (("thing" . ,(car gnus-xmas-logo-colors))
+                            ("shadow" . ,(cadr gnus-xmas-logo-colors))
+                            ("background" . ,(face-background 'default)))])
+                        ((featurep 'xbm)
+                         `[xbm :file ,logo-xbm])
+                        (t [nothing])))))
+      (insert " ")
+      (set-extent-begin-glyph (make-extent (point) (point)) glyph)

       (goto-char (point-min))
       (goto-char (point-min))

-      (forward-line 1)
-      (let* ((pheight (count-lines (point-min) (point-max)))
-            (wheight (window-height))
-            (rest (- wheight pheight)))
-       (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
-    ;; Fontify some.
+      (while (not (eobp))
+       (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
+                            ?\ ))
+       (forward-line 1))
+      (setq gnus-simple-splash nil))

     (goto-char (point-min))
     (goto-char (point-min))

-    (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)
+    (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
+          (wheight (window-height))
+          (rest (- wheight pheight)))
+      (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
+   (t
+    (insert
+     (format "              %s
+          _    ___ _             _
+          _ ___ __ ___  __    _ ___
+          __   _     ___    __  ___
+              _           ___     _
+             _  _ __             _
+             ___   __            _
+                   __           _
+                    _      _   _
+                   _      _    _
+                      _  _    _
+                  __  ___
+                 _   _ _     _
+                _   _
+              _    _
+             _    _
+            _
+          __
+
+"
+            ""))
+    ;; And then hack it.
+    (gnus-indent-rigidly (point-min) (point-max)
+                        (/ (max (- (window-width) (or x 46)) 0) 2))

     (goto-char (point-min))
     (goto-char (point-min))

-    (setq modeline-buffer-identification 
-         (list (concat gnus-version ": *Group*")))
-    (set-buffer-modified-p t)))
+    (forward-line 1)
+    (let* ((pheight (count-lines (point-min) (point-max)))
+          (wheight (window-height))
+          (rest (- wheight pheight)))
+      (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
+    ;; Paint it.
+    (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)))
+  (setq modeline-buffer-identification
+       (list (concat gnus-version ": *Group*")))
+  (set-buffer-modified-p t))

 
 
 ;;; The toolbar.
 
 
 
 ;;; The toolbar.
 

-(defvar gnus-use-toolbar (if (featurep 'toolbar)
-                            'default-toolbar
-                          nil)
+(defcustom gnus-use-toolbar (if (featurep 'toolbar)
+                               'default-toolbar
+                             nil)

   "*If nil, do not use a toolbar.
 If it is non-nil, it must be a toolbar.  The five legal values are
 `default-toolbar', `top-toolbar', `bottom-toolbar',
   "*If nil, do not use a toolbar.
 If it is non-nil, it must be a toolbar.  The five legal values are
 `default-toolbar', `top-toolbar', `bottom-toolbar',

-`right-toolbar', and `left-toolbar'.")
-
-(defvar gnus-group-toolbar 
+`right-toolbar', and `left-toolbar'."
+  :type '(choice (const default-toolbar)
+                (const top-toolbar) (const bottom-toolbar)
+                (const left-toolbar) (const right-toolbar)
+                (const :tag "no toolbar" nil))
+  :group 'gnus-xmas)
+
+(defvar gnus-group-toolbar

   '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
   '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]

-    [gnus-group-get-new-news-this-group 
+    [gnus-group-get-new-news-this-group

      gnus-group-get-new-news-this-group t "Get new news in this group"]
      gnus-group-get-new-news-this-group t "Get new news in this group"]

-    [gnus-group-catchup-current 
+    [gnus-group-catchup-current

      gnus-group-catchup-current t "Catchup group"]
      gnus-group-catchup-current t "Catchup group"]

-    [gnus-group-describe-group 
+    [gnus-group-describe-group

      gnus-group-describe-group t "Describe group"]
     [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
     [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]
      gnus-group-describe-group t "Describe group"]
     [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
     [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]


@@ -582,21 +634,21 @@ If it is non-nil, it must be a toolbar.  The five legal values are
     )
   "The group buffer toolbar.")
 
     )
   "The group buffer toolbar.")
 

-(defvar gnus-summary-toolbar 
-  '([gnus-summary-prev-unread 
-     gnus-summary-prev-unread-article t "Prev unread article"]
-    [gnus-summary-next-unread 
-     gnus-summary-next-unread-article t "Next unread article"]
-    [gnus-summary-post-news 
+(defvar gnus-summary-toolbar
+  '([gnus-summary-prev-unread
+     gnus-summary-prev-page-or-article t "Page up"]
+    [gnus-summary-next-unread
+     gnus-summary-next-page t "Page down"]
+    [gnus-summary-post-news

      gnus-summary-post-news t "Post an article"]
     [gnus-summary-followup-with-original
      gnus-summary-post-news t "Post an article"]
     [gnus-summary-followup-with-original

-     gnus-summary-followup-with-original t 
+     gnus-summary-followup-with-original t

      "Post a followup and yank the original"]
      "Post a followup and yank the original"]

-    [gnus-summary-followup 
+    [gnus-summary-followup

      gnus-summary-followup t "Post a followup"]
     [gnus-summary-reply-with-original
      gnus-summary-reply-with-original t "Mail a reply and yank the original"]
      gnus-summary-followup t "Post a followup"]
     [gnus-summary-reply-with-original
      gnus-summary-reply-with-original t "Mail a reply and yank the original"]

-    [gnus-summary-reply 
+    [gnus-summary-reply

      gnus-summary-reply t "Mail a reply"]
     [gnus-summary-caesar-message
      gnus-summary-caesar-message t "Rot 13"]
      gnus-summary-reply t "Mail a reply"]
     [gnus-summary-caesar-message
      gnus-summary-caesar-message t "Rot 13"]


@@ -606,8 +658,8 @@ If it is non-nil, it must be a toolbar.  The five legal values are
      gnus-summary-save-article-file t "Save article in file"]
     [gnus-summary-save-article
      gnus-summary-save-article t "Save article"]
      gnus-summary-save-article-file t "Save article in file"]
     [gnus-summary-save-article
      gnus-summary-save-article t "Save article"]

-    [gnus-uu-post-news 
-     gnus-uu-post-news t "Post an uuencoded article"]
+    [gnus-uu-post-news
+     gnus-uu-post-news t "Post a uuencoded article"]

     [gnus-summary-cancel-article
      gnus-summary-cancel-article t "Cancel article"]
     [gnus-summary-catchup
     [gnus-summary-cancel-article
      gnus-summary-cancel-article t "Cancel article"]
     [gnus-summary-catchup


@@ -620,9 +672,9 @@ If it is non-nil, it must be a toolbar.  The five legal values are
 
 (defvar gnus-summary-mail-toolbar
   '(
 
 (defvar gnus-summary-mail-toolbar
   '(

-    [gnus-summary-prev-unread 
+    [gnus-summary-prev-unread

      gnus-summary-prev-unread-article t "Prev unread article"]
      gnus-summary-prev-unread-article t "Prev unread article"]

-    [gnus-summary-next-unread 
+    [gnus-summary-next-unread

      gnus-summary-next-unread-article t "Next unread article"]
     [gnus-summary-mail-reply gnus-summary-reply t "Reply"]
 ;    [gnus-summary-mail-get gnus-mail-get t "Message get"]
      gnus-summary-next-unread-article t "Next unread article"]
     [gnus-summary-mail-reply gnus-summary-reply t "Reply"]
 ;    [gnus-summary-mail-get gnus-mail-get t "Message get"]


@@ -675,78 +727,101 @@ XEmacs compatibility workaround."
    'call-process-region (point-min) (point-max) command t '(t nil) nil
    args))
 
    'call-process-region (point-min) (point-max) command t '(t nil) nil
    args))
 

-(unless (find-face 'gnus-x-face)
-  (copy-face 'default 'gnus-x-face)
-  (set-face-foreground 'gnus-x-face "black")
-  (set-face-background 'gnus-x-face "white"))
+(defface gnus-x-face '((t (:foreground "black" :background "white")))
+  "Face to show X face"
+  :group 'gnus-xmas)

 
 (defun gnus-xmas-article-display-xface (beg end)
   "Display any XFace headers in the current article."
   (save-excursion
 
 (defun gnus-xmas-article-display-xface (beg end)
   "Display any XFace headers in the current article."
   (save-excursion

-    (let (xface-glyph)
-      (if (featurep 'xface)
-         (setq xface-glyph
-               (make-glyph (vector 'xface :data 
-                                   (concat "X-Face: "
-                                           (buffer-substring beg end)))))
-       (let ((cur (current-buffer)))
-         (save-excursion
-           (gnus-set-work-buffer)
-           (insert (format "%s" (buffer-substring beg end cur)))
-           (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")
-           (setq xface-glyph
-                 (make-glyph
-                  (vector 'xpm :data (buffer-string )))))))
+    (let ((xface-glyph
+          (cond ((featurep 'xface)
+                 (make-glyph (vector 'xface :data
+                                     (concat "X-Face: "
+                                             (buffer-substring beg end)))))
+                ((featurep 'xpm)
+                 (let ((cur (current-buffer)))
+                   (save-excursion
+                     (gnus-set-work-buffer)
+                     (insert (format "%s" (buffer-substring beg end cur)))
+                     (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]))))
+         (ext (make-extent (progn
+                             (goto-char (point-min))
+                             (re-search-forward "^From:" nil t)
+                             (point))
+                           (1+ (point)))))

       (set-glyph-face xface-glyph 'gnus-x-face)
       (set-glyph-face xface-glyph 'gnus-x-face)

-      (goto-char (point-min))
-      (re-search-forward "^From:" nil t)
-      (set-extent-begin-glyph 
-       (make-extent (point) (1+ (point))) xface-glyph))))
-
-(defvar gnus-xmas-pointer-glyph 
-  (progn
-    (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
-    (make-pointer-glyph (concat gnus-xmas-glyph-directory "gnus-pointer."
-                               (if (featurep 'xpm) "xpm" "xbm")))))
-
-(defvar gnus-xmas-modeline-left-extent 
+      (set-extent-begin-glyph ext xface-glyph)
+      (set-extent-property ext 'duplicable t))))
+
+;;(defvar gnus-xmas-pointer-glyph
+;;  (progn
+;;    (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory
+;;                                     "gnus"))
+;;    (let ((file-xpm (expand-file-name "gnus-pointer.xpm"
+;;                                   gnus-xmas-glyph-directory))
+;;       (file-xbm (expand-file-name "gnus-pointer.xbm"
+;;                                   gnus-xmas-glyph-directory)))
+;;      (make-pointer-glyph
+;;       (list (vector 'xpm ':file file-xpm)
+;;          (vector 'xbm ':file file-xbm))))))
+
+(defvar gnus-xmas-modeline-left-extent

   (let ((ext (copy-extent modeline-buffer-id-left-extent)))
   (let ((ext (copy-extent modeline-buffer-id-left-extent)))

-    ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
+;    (set-extent-property ext 'pointer gnus-xmas-pointer-glyph)

     ext))
     ext))

-      
-(defvar gnus-xmas-modeline-right-extent 
+
+(defvar gnus-xmas-modeline-right-extent

   (let ((ext (copy-extent modeline-buffer-id-right-extent)))
   (let ((ext (copy-extent modeline-buffer-id-right-extent)))

-    ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
+;    (set-extent-property ext 'pointer gnus-xmas-pointer-glyph)

     ext))
 
 (defvar gnus-xmas-modeline-glyph
   (progn
     (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
     ext))
 
 (defvar gnus-xmas-modeline-glyph
   (progn
     (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))

-    (let* ((file (concat gnus-xmas-glyph-directory "gnus-pointer."
-                        (if (featurep 'xpm) "xpm" "xbm")))
-          (glyph (make-glyph file)))
-      (when (and (featurep 'x)
-                (file-exists-p file))
-       (set-glyph-face glyph 'modeline-buffer-id))
-      (set-glyph-property glyph 'image (cons 'tty "Gnus:"))
+    (let* ((file-xpm (expand-file-name "gnus-pointer.xpm"
+                                      gnus-xmas-glyph-directory))
+          (file-xbm (expand-file-name "gnus-pointer.xbm"
+                                      gnus-xmas-glyph-directory))
+          (glyph (make-glyph
+                  ;; Gag gag gag.
+                  (cond ((featurep 'xpm)
+                         ;; Let's try a nifty XPM
+                         `[xpm :file ,file-xpm])
+                        ((featurep 'xbm)
+                         ;; Then a not-so-nifty XBM
+                         [xbm :file ,file-xbm])
+                        ;; Then the simple string
+                        (t [string :data "Gnus:"])))))
+      (set-glyph-face glyph 'modeline-buffer-id)

       glyph)))
 
 (defun gnus-xmas-mode-line-buffer-identification (line)
   (let ((line (car line))
        chop)
       glyph)))
 
 (defun gnus-xmas-mode-line-buffer-identification (line)
   (let ((line (car line))
        chop)

-    (if (not (stringp line))
-       (list line)
-      (when (string-match "^Gnus:" line)
-       (setq chop (match-end 0))
-       (list 
-        (if gnus-xmas-modeline-glyph
-            (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
-          (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
-        (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
+    (cond
+     ;; This is some weird type of id.
+     ((not (stringp line))
+      (list line))
+     ;; This is non-standard, so we just pass it through.
+     ((not (string-match "^Gnus:" line))
+      (list line))
+     ;; We have a standard line, so we colorize and glyphize it a bit.
+     (t
+      (setq chop (match-end 0))
+      (list
+       (if gnus-xmas-modeline-glyph
+          (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
+        (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
+       (cons gnus-xmas-modeline-right-extent (substring line chop)))))))

 
 (defun gnus-xmas-splash ()
   (when (eq (device-type) 'x)
 
 (defun gnus-xmas-splash ()
   (when (eq (device-type) 'x)