projects / gnus / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
(gnus-group-expire-articles-1): Make sure server is open.
[gnus] / lisp / gnus-xmas.el
diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el
index c98fe5a..fd6ea7f 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,99 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.
@@ -28,11 +28,21 @@
 (require 'text-props)
 (defvar menu-bar-mode (featurep 'menubar))
 (require 'messagexmas)
 (require 'text-props)
 (defvar menu-bar-mode (featurep 'menubar))
 (require 'messagexmas)
+(require 'wid-edit)
 
 
-(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)
+
+;;(format "%02x%02x%02x" 114 66 20) "724214"
 
 (defvar gnus-xmas-logo-color-alist
   '((flame "#cc3300" "#ff2200")
 
 (defvar gnus-xmas-logo-color-alist
   '((flame "#cc3300" "#ff2200")
@@ -45,24 +55,33 @@ automatically.")
     (grape "#b264cc" "#cf7df")
     (labia "#cc64c2" "#fd7dff")
     (berry "#cc6485" "#ff7db5")
     (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.")
 
     (neutral "#b4b4b4" "#878787")
     (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 '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.")
 
 
 (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
       '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.
+    "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
+  "*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.
 
@@ -76,7 +95,6 @@ asynchronously.        The compressed face will be piped to this command.")
 (defvar gnus-active-hashtb)
 (defvar gnus-article-buffer)
 (defvar gnus-auto-center-summary)
 (defvar gnus-active-hashtb)
 (defvar gnus-article-buffer)
 (defvar gnus-auto-center-summary)
-(defvar gnus-buffer-list)
 (defvar gnus-current-headers)
 (defvar gnus-level-killed)
 (defvar gnus-level-zombie)
 (defvar gnus-current-headers)
 (defvar gnus-level-killed)
 (defvar gnus-level-zombie)
@@ -120,11 +138,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 +151,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.
@@ -156,7 +181,9 @@ displayed, no centering will be performed."
                     (- (window-height) 2)))
           (top (cond ((< height 4) 0)
                      ((< height 7) 1)
                     (- (window-height) 2)))
           (top (cond ((< height 4) 0)
                      ((< height 7) 1)
-                     (t 2)))
+                     (t (if (numberp gnus-auto-center-summary)
+                            gnus-auto-center-summary
+                          2))))
           (bottom (save-excursion (goto-char (point-max))
                                   (forward-line (- height))
                                   (point)))
           (bottom (save-excursion (goto-char (point-max))
                                   (forward-line (- height))
                                   (point)))
@@ -166,8 +193,10 @@ displayed, no centering will be performed."
        ;; Set the window start to either `bottom', which is the biggest
        ;; possible valid number, or the second line from the top,
        ;; whichever is the least.
        ;; Set the window start to either `bottom', which is the biggest
        ;; possible valid number, or the second line from the top,
        ;; whichever is the least.
+       ;; NOFORCE parameter suggested by Daniel Pittman <daniel@danann.net>.
        (set-window-start
        (set-window-start
-        window (min bottom (save-excursion (forward-line (- top)) (point)))))
+        window (min bottom (save-excursion (forward-line (- top)) (point))) 
+        t))
       ;; Do horizontal recentering while we're at it.
       (when (and (get-buffer-window (current-buffer) t)
                 (not (eq gnus-auto-center-summary 'vertical)))
       ;; Do horizontal recentering while we're at it.
       (when (and (get-buffer-window (current-buffer) t)
                 (not (eq gnus-auto-center-summary 'vertical)))
@@ -177,8 +206,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 +240,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,
@@ -202,26 +250,18 @@ call it with the value of the `gnus-data' text property."
   (let* ((pos (event-closest-point event))
         (data (get-text-property pos 'gnus-data))
         (fun (get-text-property pos 'gnus-callback)))
   (let* ((pos (event-closest-point event))
         (data (get-text-property pos 'gnus-data))
         (fun (get-text-property pos 'gnus-callback)))
+    (goto-char pos)
     (when fun
       (funcall fun data))))
 
 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
     (when fun
       (funcall fun data))))
 
 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
-  (set-extent-endpoints extent start end))
-
-;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
-(defun gnus-xmas-article-add-button (from to fun &optional data)
-  "Create a button between FROM and TO with callback FUN and data DATA."
-  (when gnus-article-button-face
-    (gnus-overlay-put (gnus-make-overlay from to)
-                     'face gnus-article-button-face))
-  (gnus-add-text-properties 
-   from to
-   (nconc
-    (and gnus-article-mouse-face
-        (list 'mouse-face gnus-article-mouse-face))
-    (list 'gnus-callback fun)
-    (and data (list 'gnus-data data))
-    (list 'highlight t))))
+  (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)))
 
 (defun gnus-xmas-window-top-edge (&optional window)
   (nth 1 (window-pixel-edges window)))
 
 (defun gnus-xmas-window-top-edge (&optional window)
   (nth 1 (window-pixel-edges window)))
@@ -252,8 +292,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 +344,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,52 +381,18 @@ 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)))
-                       (timezone-parse-date date)))
-        (ttime (mapcar (lambda (ti) (and ti (string-to-int ti)))
-                       (timezone-parse-time
-                        (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 
-                  (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
-                 (timezone-absolute-from-gregorian 
-                  (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
-    (+ (nth 2 ttime)
-       (* (nth 1 ttime) 60)
-       (* (float (nth 0 ttime)) 60 60)
-       (* (float tday) 60 60 24))))
-
 (defun gnus-xmas-define ()
   (setq gnus-mouse-2 [button2])
 (defun gnus-xmas-define ()
   (setq gnus-mouse-2 [button2])
+  (setq gnus-mouse-3 [button3])
+  (setq gnus-widget-button-keymap widget-button-keymap)
 
   (unless (memq 'underline (face-list))
     (and (fboundp 'make-face)
 
   (unless (memq 'underline (face-list))
     (and (fboundp 'make-face)
@@ -381,17 +403,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))
 
+  (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))
@@ -401,53 +435,41 @@ call it with the value of the `gnus-data' text property."
 
   (defvar gnus-mouse-face-prop 'highlight)
 
 
   (defvar gnus-mouse-face-prop 'highlight)
 
-  (unless (fboundp 'encode-time)
-    (defun encode-time (sec minute hour day month year &optional zone)
-      (let ((seconds
-            (gnus-xmas-seconds-since-epoch
-             (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)))))))
-      
   (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-article-push-button 'gnus-xmas-article-push-button)
   (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-article-push-button 'gnus-xmas-article-push-button)
-  (fset 'gnus-article-add-button 'gnus-xmas-article-add-button)
   (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
   (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-window-top-edge 'gnus-xmas-window-top-edge)
   (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-character-to-event 'character-to-event)
-  (fset 'gnus-article-show-hidden-text 'gnus-xmas-article-show-hidden-text)
   (fset 'gnus-mode-line-buffer-identification
        'gnus-xmas-mode-line-buffer-identification)
   (fset 'gnus-key-press-event-p 'key-press-event-p)
   (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)
+  (fset 'gnus-annotation-in-region-p 'gnus-xmas-annotation-in-region-p)
+  (fset 'gnus-mime-button-menu 'gnus-xmas-mime-button-menu)
 
   (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 +487,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,115 +504,119 @@ 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 nil, do not use a toolbar.
-If it is non-nil, it must be a toolbar.  The five legal values are
+If it is non-nil, it must be a toolbar.  The five valid values are
 `default-toolbar', `top-toolbar', `bottom-toolbar',
 `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-kill-group gnus-group-kill-group t "Kill 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-kill-group gnus-group-kill-group t "Kill group"]
-    [gnus-group-exit gnus-group-exit t "Exit Gnus"]
-    )
+    [gnus-group-exit gnus-group-exit t "Exit Gnus"])
   "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,33 +626,28 @@ 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-catchup t "Catchup"]
     [gnus-summary-catchup-and-exit
      gnus-summary-catchup-and-exit t "Catchup and exit"]
     [gnus-summary-cancel-article
      gnus-summary-cancel-article t "Cancel article"]
     [gnus-summary-catchup
      gnus-summary-catchup t "Catchup"]
     [gnus-summary-catchup-and-exit
      gnus-summary-catchup-and-exit t "Catchup and exit"]
-    [gnus-summary-exit gnus-summary-exit t "Exit this summary"]
-    )
+    [gnus-summary-exit gnus-summary-exit t "Exit this summary"])
   "The summary buffer toolbar.")
 
 (defvar gnus-summary-mail-toolbar
   '(
   "The summary buffer 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-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-mail-originate gnus-summary-post-news t "Originate"]
     [gnus-summary-mail-save gnus-summary-save-article t "Save"]
     [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
     [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
     [gnus-summary-mail-save gnus-summary-save-article t "Save"]
     [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
-;    [gnus-summary-mail-delete gnus-summary-delete-article t "Delete message"]
     [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
     [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
-;    [gnus-summary-mail-spell gnus-mail-spell t "Spell"]
-;    [gnus-summary-mail-help gnus-mail-help  t "Message help"]
     [gnus-summary-caesar-message
      gnus-summary-caesar-message t "Rot 13"]
     [gnus-uu-decode-uu
     [gnus-summary-caesar-message
      gnus-summary-caesar-message t "Rot 13"]
     [gnus-uu-decode-uu
@@ -641,12 +656,11 @@ 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-summary-catchup-and-exit
-     gnus-summary-catchup-and-exit t "Catchup and exit"]
     [gnus-summary-catchup
      gnus-summary-catchup t "Catchup"]
     [gnus-summary-catchup
      gnus-summary-catchup t "Catchup"]
-    [gnus-summary-exit gnus-summary-exit t "Exit this summary"]
-    )
+    [gnus-summary-catchup-and-exit
+     gnus-summary-catchup-and-exit t "Catchup and exit"]
+    [gnus-summary-exit gnus-summary-exit t "Exit this summary"])
   "The summary buffer mail toolbar.")
 
 (defun gnus-xmas-setup-group-toolbar ()
   "The summary buffer mail toolbar.")
 
 (defun gnus-xmas-setup-group-toolbar ()
@@ -675,104 +689,180 @@ 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))))
-
-(defun gnus-xmas-article-show-hidden-text (type &optional hide)
-  "Show all hidden text of type TYPE.
-If HIDE, hide the text instead."
-  (save-excursion
-    (set-buffer gnus-article-buffer)
-    (let ((buffer-read-only nil)
-         (inhibit-point-motion-hooks t)
-         (beg (point-min)))
-      (while (gnus-goto-char (text-property-any
-                             beg (point-max) 'gnus-type type))
-       (setq beg (point))
-       (forward-char)
-       (if hide
-           (article-hide-text beg (point) gnus-hidden-properties)
-         (article-unhide-text beg (point)))
-       (setq beg (point)))
-      (save-window-excursion
-       (select-window (get-buffer-window (current-buffer)))
-       (recenter))
-      t)))
-
-(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")))))
+      (set-extent-begin-glyph ext xface-glyph)
+      (set-extent-property ext 'duplicable t))))
 
 
-(defvar gnus-xmas-modeline-left-extent 
+(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)
     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)
     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)
     (gnus-splash)))
 
 
 (defun gnus-xmas-splash ()
   (when (eq (device-type) 'x)
     (gnus-splash)))
 
+(defun gnus-xmas-annotation-in-region-p (b e)
+  (or (map-extents (lambda (e u) t) nil b e nil nil 'mm t)
+      (if (= b e)
+         (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
+       (text-property-any b e 'gnus-undeletable t))))
+
+(defun gnus-xmas-mime-button-menu (event)
+  "Construct a context-sensitive menu of MIME commands."
+  (interactive "e")
+  (let ((response (get-popup-menu-response
+                  `("MIME Part"
+                    ,@(mapcar (lambda (c) `[,(caddr c) ,(car c) t])
+                              gnus-mime-button-commands)))))
+    (set-buffer (event-buffer event))
+    (goto-char (event-point event))
+    (funcall (event-function response) (event-object response))))
+
+(defun gnus-group-add-icon ()
+  "Add an icon to the current line according to `gnus-group-icon-list'."
+  (let* ((p (point))
+        (end (progn (end-of-line) (point)))
+        ;; now find out where the line starts and leave point there.
+        (beg (progn (beginning-of-line) (point))))
+    (save-restriction
+      (narrow-to-region beg end)
+      (goto-char beg)
+      (when (search-forward "==&&==" nil t)
+       (let* ((group (gnus-group-group-name))
+              (entry (gnus-group-entry group))
+              (unread (if (numberp (car entry)) (car entry) 0))
+              (active (gnus-active group))
+              (total (if active (1+ (- (cdr active) (car active))) 0))
+              (info (nth 2 entry))
+              (method (gnus-server-get-method group (gnus-info-method info)))
+              (marked (gnus-info-marks info))
+              (mailp (memq 'mail (assoc (symbol-name
+                                         (car (or method gnus-select-method)))
+                                        gnus-valid-select-methods)))
+              (level (or (gnus-info-level info) gnus-level-killed))
+              (score (or (gnus-info-score info) 0))
+              (ticked (gnus-range-length (cdr (assq 'tick marked))))
+              (group-age (gnus-group-timestamp-delta group))
+              (inhibit-read-only t)
+              (list gnus-group-icon-list)
+              (mystart (match-beginning 0))
+              (myend (match-end 0)))
+         (goto-char (point-min))
+         (while (and list
+                     (not (eval (caar list))))
+           (setq list (cdr list)))
+         (if list
+             (let* ((file (cdar list))
+                    (glyph (gnus-group-icon-create-glyph
+                            (buffer-substring mystart myend)
+                            file)))
+               (if glyph
+                   (progn
+                     (mapcar 'delete-annotation (annotations-at myend))
+                     (let ((ext (make-extent mystart myend))
+                           (ant (make-annotation glyph myend 'text)))
+                       ;; set text extent params
+                       (set-extent-property ext 'end-open t)
+                       (set-extent-property ext 'start-open t)
+                       (set-extent-property ext 'invisible t)))
+                 (delete-region mystart myend)))
+           (delete-region mystart myend))))
+      (widen))
+    (goto-char p)))
+
+(defun gnus-group-icon-create-glyph (substring pixmap)
+  "Create a glyph for insertion into a group line."
+  (and
+   gnus-group-running-xemacs
+   (or
+    (cdr-safe (assoc pixmap gnus-group-icon-cache))
+    (let* ((glyph (make-glyph
+                  (list
+                   (cons 'x
+                         (expand-file-name pixmap gnus-xmas-glyph-directory))
+                   (cons 'mswindows
+                         (expand-file-name pixmap gnus-xmas-glyph-directory))
+                   (cons 'tty substring)))))
+      (setq gnus-group-icon-cache
+           (cons (cons pixmap glyph) gnus-group-icon-cache))
+      (set-glyph-face glyph 'default)
+      glyph))))
+
 (provide 'gnus-xmas)
 
 ;;; gnus-xmas.el ends here
 (provide 'gnus-xmas)
 
 ;;; gnus-xmas.el ends here
Steve's SXEmacs-friendly Gnus repo