Fix my last change.

[gnus] / lisp / gnus-xmas.el

diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el
index 7c8ceb9..6bea994 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,97 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 ()


@@ -137,9 +156,11 @@ It is provided only to ease porting of broken FSF Emacs programs."
     (set-extent-face gnus-newsgroup-selected-overlay
                     gnus-summary-selected-face)))
 
     (set-extent-face gnus-newsgroup-selected-overlay
                     gnus-summary-selected-face)))
 

-(defvar 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'.")
+(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)
 
 (defun gnus-xmas-switch-horizontal-scrollbar-off ()
   (when (featurep 'scrollbar)


@@ -160,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)))


@@ -170,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)))


@@ -181,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)


@@ -206,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)))


@@ -308,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))


@@ -337,46 +389,10 @@ call it with the value of the `gnus-data' text property."
               (event-to-character event))
          event)))
 
               (event-to-character 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)


@@ -390,23 +406,28 @@ call it with the value of the `gnus-data' text property."
   (cond
    ((fboundp 'char-or-char-int-p)
     ;; Handle both types of marks for XEmacs-20.x.
   (cond
    ((fboundp 'char-or-char-int-p)
     ;; Handle both types of marks for XEmacs-20.x.

-    (fset 'gnus-characterp 'char-or-char-int-p))
+    (defalias 'gnus-characterp 'char-or-char-int-p))

    ;; V19 of XEmacs, probably.
    (t
    ;; V19 of XEmacs, probably.
    (t

-    (fset 'gnus-characterp 'characterp)))
-
-  (fset 'gnus-make-overlay 'make-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-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)
+    (defalias 'gnus-characterp 'characterp)))
+
+  (defalias 'gnus-make-overlay 'make-extent)
+  (defalias 'gnus-delete-overlay 'delete-extent)
+  (defalias 'gnus-overlay-put 'set-extent-property)
+  (defalias 'gnus-move-overlay 'gnus-xmas-move-overlay)
+  (defalias 'gnus-overlay-buffer 'extent-object)
+  (defalias 'gnus-overlay-start 'extent-start-position)
+  (defalias 'gnus-overlay-end 'extent-end-position)
+  (defalias 'gnus-kill-all-overlays 'gnus-xmas-kill-all-overlays)
+  (defalias 'gnus-extent-detached-p 'extent-detached-p)
+  (defalias 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
+  (defalias 'gnus-put-text-property 'gnus-xmas-put-text-property)
+  (defalias 'gnus-deactivate-mark 'ignore)
+  (defalias 'gnus-window-edges 'window-pixel-edges)

 
 

-  (require 'text-props)

   (if (and (<= emacs-major-version 19)
           (< emacs-minor-version 14))
   (if (and (<= emacs-major-version 19)
           (< emacs-minor-version 14))

-      (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
+      (defalias '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))


@@ -416,24 +437,17 @@ 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
+  (unless (fboundp 'match-string-no-properties)
+    (defalias 'match-string-no-properties 'match-string))
+
+  (defalias 'gnus-x-color-values

        (if (fboundp 'x-color-values)
            'x-color-values
          (lambda (color)
        (if (fboundp 'x-color-values)
            'x-color-values
          (lambda (color)


@@ -442,25 +456,25 @@ call it with the value of the `gnus-data' text property."
 
 (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-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-appt-select-lowest-window
+  (defalias 'gnus-summary-set-display-table 'gnus-xmas-summary-set-display-table)
+  (defalias 'gnus-visual-turn-off-edit-menu 'identity)
+  (defalias 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
+  (defalias 'gnus-extent-start-open 'gnus-xmas-extent-start-open)
+  (defalias 'gnus-article-push-button 'gnus-xmas-article-push-button)
+  (defalias 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
+  (defalias 'gnus-read-event-char 'gnus-xmas-read-event-char)
+  (defalias 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
+  (defalias 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
+  (defalias 'gnus-appt-select-lowest-window

        'gnus-xmas-appt-select-lowest-window)
        'gnus-xmas-appt-select-lowest-window)

-  (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
-  (fset 'gnus-add-hook 'gnus-xmas-add-hook)
-  (fset 'gnus-character-to-event 'character-to-event)
-  (fset 'gnus-mode-line-buffer-identification
+  (defalias 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
+  (defalias 'gnus-character-to-event 'character-to-event)
+  (defalias 'gnus-mode-line-buffer-identification

        'gnus-xmas-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)
+  (defalias 'gnus-key-press-event-p 'key-press-event-p)
+  (defalias 'gnus-region-active-p 'region-active-p)
+  (defalias 'gnus-annotation-in-region-p 'gnus-xmas-annotation-in-region-p)
+  (defalias '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)


@@ -478,21 +492,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)
 

-  (add-hook 'gnus-summary-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off)
+  (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)

 
 

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


@@ -502,37 +509,39 @@ 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
+  (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))
+      (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))
+    (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

           _    ___ _             _
           _ ___ __ ___  __    _ ___
           __   _     ___    __  ___
           _    ___ _             _
           _ ___ __ ___  __    _ ___
           __   _     ___    __  ___


@@ -552,34 +561,37 @@ call it with the value of the `gnus-data' text property."
           __
 
 "
           __
 
 "

-              ""))
-      ;; And then hack it.
-      (gnus-indent-rigidly (point-min) (point-max)
-                          (/ (max (- (window-width) (or x 46)) 0) 2))
-      (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.
-    (goto-char (point-min))
-    (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)
+            ""))
+    ;; 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'.")
+`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"]
 
 (defvar gnus-group-toolbar
   '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]


@@ -592,8 +604,7 @@ If it is non-nil, it must be a toolbar.  The five legal values are
     [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-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.")
 
 (defvar gnus-summary-toolbar
   "The group buffer toolbar.")
 
 (defvar gnus-summary-toolbar


@@ -621,15 +632,14 @@ If it is non-nil, it must be a toolbar.  The five legal values are
     [gnus-summary-save-article
      gnus-summary-save-article t "Save article"]
     [gnus-uu-post-news
     [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 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


@@ -639,14 +649,10 @@ If it is non-nil, it must be a toolbar.  The five legal values are
     [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
      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


@@ -659,8 +665,7 @@ If it is non-nil, it must be a toolbar.  The five legal values are
      gnus-summary-catchup t "Catchup"]
     [gnus-summary-catchup-and-exit
      gnus-summary-catchup-and-exit t "Catchup and exit"]
      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 mail toolbar.")
 
 (defun gnus-xmas-setup-group-toolbar ()
   "The summary buffer mail toolbar.")
 
 (defun gnus-xmas-setup-group-toolbar ()


@@ -689,65 +694,69 @@ 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")))))
+      (set-extent-begin-glyph ext xface-glyph)
+      (set-extent-property ext 'duplicable t))))

 
 (defvar gnus-xmas-modeline-left-extent
   (let ((ext (copy-extent modeline-buffer-id-left-extent)))
 
 (defvar gnus-xmas-modeline-left-extent
   (let ((ext (copy-extent modeline-buffer-id-left-extent)))

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

     ext))
 
 (defvar gnus-xmas-modeline-right-extent
   (let ((ext (copy-extent modeline-buffer-id-right-extent)))
     ext))
 
 (defvar gnus-xmas-modeline-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:"))
-       glyph))))
+    (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))
 
 (defun gnus-xmas-mode-line-buffer-identification (line)
   (let ((line (car line))


@@ -772,6 +781,97 @@ XEmacs compatibility workaround."
   (when (eq (device-type) 'x)
     (gnus-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."
+  (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)))
+
+(defun gnus-xmas-mailing-list-menu-add ()
+  (gnus-xmas-menu-add mailing-list
+                     gnus-mailing-list-menu))
+
+(add-hook 'gnus-mailing-list-mode-hook 'gnus-xmas-mailing-list-menu-add)
+

 (provide 'gnus-xmas)
 
 ;;; gnus-xmas.el ends here
 (provide 'gnus-xmas)
 
 ;;; gnus-xmas.el ends here