cgit.sxemacs.org Git - gnus/blob - lisp/gnus-xmas.el

   1 ;;; gnus-xmas.el --- Gnus functions for XEmacs
   2
   3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
   4 ;;      Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (require 'text-props)
  31 (defvar menu-bar-mode (featurep 'menubar))
  32 (require 'messagexmas)
  33 (require 'wid-edit)
  34
  35 (defgroup gnus-xmas nil
  36   "XEmacsoid support for Gnus"
  37   :group 'gnus)
  38
  39 (defcustom gnus-xmas-glyph-directory nil
  40   "Directory where Gnus logos and icons are located.
  41 If this variable is nil, Gnus will try to locate the directory
  42 automatically."
  43   :type '(choice (const :tag "autodetect" nil)
  44                  directory)
  45   :group 'gnus-xmas)
  46
  47 (unless gnus-xmas-glyph-directory
  48   (unless (setq gnus-xmas-glyph-directory
  49                 (message-xmas-find-glyph-directory "gnus"))
  50     (gnus-error 1 "Can't find glyph directory. Possibly the `etc' directory is not installed.")))
  51
  52 ;;(format "%02x%02x%02x" 114 66 20) "724214"
  53
  54 (defvar gnus-xmas-logo-color-alist
  55   '((flame "#cc3300" "#ff2200")
  56     (pine "#c0cc93" "#f8ffb8")
  57     (moss "#a1cc93" "#d2ffb8")
  58     (irish "#04cc90" "#05ff97")
  59     (sky "#049acc" "#05deff")
  60     (tin "#6886cc" "#82b6ff")
  61     (velvet "#7c68cc" "#8c82ff")
  62     (grape "#b264cc" "#cf7df")
  63     (labia "#cc64c2" "#fd7dff")
  64     (berry "#cc6485" "#ff7db5")
  65     (dino "#724214" "#1e3f03")
  66     (neutral "#b4b4b4" "#878787")
  67     (september "#bf9900" "#ffcc00"))
  68   "Color alist used for the Gnus logo.")
  69
  70 (defcustom gnus-xmas-logo-color-style 'dino
  71   "*Color styles used for the Gnus logo."
  72   :type '(choice (const flame) (const pine) (const moss)
  73                  (const irish) (const sky) (const tin)
  74                  (const velvet) (const grape) (const labia)
  75                  (const berry) (const neutral) (const september)
  76                  (const dino))
  77   :group 'gnus-xmas)
  78
  79 (defvar gnus-xmas-logo-colors
  80   (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist))
  81   "Colors used for the Gnus logo.")
  82
  83 (defcustom gnus-article-x-face-command
  84   (if (or (featurep 'xface)
  85           (featurep 'xpm))
  86       'gnus-xmas-article-display-xface
  87     "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
  88   "*String or function to be executed to display an X-Face header.
  89 If it is a string, the command will be executed in a sub-shell
  90 asynchronously.  The compressed face will be piped to this command."
  91   :type '(choice string function))
  92
  93 ;;; Internal variables.
  94
  95 ;; Don't warn about these undefined variables.
  96
  97 (defvar gnus-group-mode-hook)
  98 (defvar gnus-summary-mode-hook)
  99 (defvar gnus-article-mode-hook)
 100
 101 ;;defined in gnus.el
 102 (defvar gnus-active-hashtb)
 103 (defvar gnus-article-buffer)
 104 (defvar gnus-auto-center-summary)
 105 (defvar gnus-current-headers)
 106 (defvar gnus-level-killed)
 107 (defvar gnus-level-zombie)
 108 (defvar gnus-newsgroup-bookmarks)
 109 (defvar gnus-newsgroup-dependencies)
 110 (defvar gnus-newsgroup-selected-overlay)
 111 (defvar gnus-newsrc-hashtb)
 112 (defvar gnus-read-mark)
 113 (defvar gnus-refer-article-method)
 114 (defvar gnus-reffed-article-number)
 115 (defvar gnus-unread-mark)
 116 (defvar gnus-version)
 117 (defvar gnus-view-pseudos)
 118 (defvar gnus-view-pseudos-separately)
 119 (defvar gnus-visual)
 120 (defvar gnus-zombie-list)
 121 ;;defined in gnus-msg.el
 122 (defvar gnus-article-copy)
 123 (defvar gnus-check-before-posting)
 124 ;;defined in gnus-vis.el
 125 (defvar gnus-article-button-face)
 126 (defvar gnus-article-mouse-face)
 127 (defvar gnus-summary-selected-face)
 128 (defvar gnus-group-reading-menu)
 129 (defvar gnus-group-group-menu)
 130 (defvar gnus-group-misc-menu)
 131 (defvar gnus-summary-article-menu)
 132 (defvar gnus-summary-thread-menu)
 133 (defvar gnus-summary-misc-menu)
 134 (defvar gnus-summary-post-menu)
 135 (defvar gnus-summary-kill-menu)
 136 (defvar gnus-article-article-menu)
 137 (defvar gnus-article-treatment-menu)
 138 (defvar gnus-mouse-2)
 139 (defvar standard-display-table)
 140 (defvar gnus-tree-minimize-window)
 141
 142 (defun gnus-xmas-set-text-properties (start end props &optional buffer)
 143   "You should NEVER use this function.  It is ideologically blasphemous.
 144 It is provided only to ease porting of broken FSF Emacs programs."
 145   (if (stringp buffer)
 146       nil
 147     (map-extents (lambda (extent ignored)
 148                    (remove-text-properties
 149                     start end
 150                     (list (extent-property extent 'text-prop) nil)
 151                     buffer)
 152                    nil)
 153                  buffer start end nil nil 'text-prop)
 154     (gnus-add-text-properties start end props buffer)))
 155
 156 (defun gnus-xmas-highlight-selected-summary ()
 157   ;; Highlight selected article in summary buffer
 158   (when gnus-summary-selected-face
 159     (when gnus-newsgroup-selected-overlay
 160       (delete-extent gnus-newsgroup-selected-overlay))
 161     (setq gnus-newsgroup-selected-overlay
 162           (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
 163     (set-extent-face gnus-newsgroup-selected-overlay
 164                      gnus-summary-selected-face)))
 165
 166 (defcustom gnus-xmas-force-redisplay nil
 167   "*If non-nil, force a redisplay before recentering the summary buffer.
 168 This is ugly, but it works around a bug in `window-displayed-height'."
 169   :type 'boolean
 170   :group 'gnus-xmas)
 171
 172 (defun gnus-xmas-switch-horizontal-scrollbar-off ()
 173   (when (featurep 'scrollbar)
 174     (set-specifier scrollbar-height (cons (current-buffer) 0))))
 175
 176 (defun gnus-xmas-summary-recenter ()
 177   "\"Center\" point in the summary window.
 178 If `gnus-auto-center-summary' is nil, or the article buffer isn't
 179 displayed, no centering will be performed."
 180   ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
 181   ;; Recenter only when requested.  Suggested by popovich@park.cs.columbia.edu.
 182   ;; Force redisplay to get properly computed window height.
 183   (when gnus-xmas-force-redisplay
 184     (sit-for 0))
 185   (when gnus-auto-center-summary
 186     (let* ((height (if (fboundp 'window-displayed-height)
 187                        (window-displayed-height)
 188                      (- (window-height) 2)))
 189            (top (cond ((< height 4) 0)
 190                       ((< height 7) 1)
 191                       (t (if (numberp gnus-auto-center-summary)
 192                              gnus-auto-center-summary
 193                            2))))
 194            (bottom (save-excursion (goto-char (point-max))
 195                                    (forward-line (- height))
 196                                    (point)))
 197            (window (get-buffer-window (current-buffer))))
 198       (when (get-buffer-window gnus-article-buffer)
 199         ;; Only do recentering when the article buffer is displayed,
 200         ;; Set the window start to either `bottom', which is the biggest
 201         ;; possible valid number, or the second line from the top,
 202         ;; whichever is the least.
 203         ;; NOFORCE parameter suggested by Daniel Pittman <daniel@danann.net>.
 204         (set-window-start
 205          window (min bottom (save-excursion (forward-line (- top)) (point)))
 206          t))
 207       ;; Do horizontal recentering while we're at it.
 208       (when (and (get-buffer-window (current-buffer) t)
 209                  (not (eq gnus-auto-center-summary 'vertical)))
 210         (let ((selected (selected-window)))
 211           (select-window (get-buffer-window (current-buffer) t))
 212           (gnus-summary-position-point)
 213           (gnus-horizontal-recenter)
 214           (select-window selected))))))
 215
 216 (defun gnus-xmas-summary-set-display-table ()
 217   ;; Setup the display table -- like `gnus-summary-setup-display-table',
 218   ;; but done in an XEmacsish way.
 219   (let ((table (make-display-table))
 220         (i 32))
 221     ;; Nix out all the control chars...
 222     (while (>= (setq i (1- i)) 0)
 223       (aset table i [??]))
 224     ;; ... but not newline and cr, of course.  (cr is necessary for the
 225     ;; selective display).
 226     (aset table ?\n nil)
 227     (aset table ?\r nil)
 228     ;; We keep TAB as well.
 229     (aset table ?\t nil)
 230     ;; We nix out any glyphs over 126 below ctl-arrow.
 231     (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
 232       (while (>= (setq i (1- i)) 127)
 233         (unless (aref table i)
 234           (aset table i [??]))))
 235     ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
 236     (add-spec-to-specifier current-display-table table (current-buffer) nil)))
 237
 238 (defun gnus-xmas-add-text-properties (start end props &optional object)
 239   (add-text-properties start end props object)
 240   (put-text-property start end 'start-closed nil object))
 241
 242 (defun gnus-xmas-put-text-property (start end prop value &optional object)
 243   (put-text-property start end prop value object)
 244   (put-text-property start end 'start-closed nil object))
 245
 246 (defun gnus-xmas-extent-start-open (point)
 247   (map-extents (lambda (extent arg)
 248                  (set-extent-property extent 'start-open t))
 249                nil point (min (1+ (point)) (point-max))))
 250
 251 (defun gnus-xmas-article-push-button (event)
 252   "Check text under the mouse pointer for a callback function.
 253 If the text under the mouse pointer has a `gnus-callback' property,
 254 call it with the value of the `gnus-data' text property."
 255   (interactive "e")
 256   (set-buffer (window-buffer (event-window event)))
 257   (let* ((pos (event-closest-point event))
 258          (data (get-text-property pos 'gnus-data))
 259          (fun (get-text-property pos 'gnus-callback)))
 260     (goto-char pos)
 261     (when fun
 262       (funcall fun data))))
 263
 264 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
 265   (set-extent-endpoints extent start end buffer))
 266
 267 (defun gnus-xmas-kill-all-overlays ()
 268   "Delete all extents in the current buffer."
 269   (map-extents (lambda (extent ignore)
 270                  (delete-extent extent)
 271                  nil)))
 272
 273 (defun gnus-xmas-window-top-edge (&optional window)
 274   (nth 1 (window-pixel-edges window)))
 275
 276 (defun gnus-xmas-tree-minimize ()
 277   (when (and gnus-tree-minimize-window
 278              (not (one-window-p)))
 279     (let* ((window-min-height 2)
 280            (height (1+ (count-lines (point-min) (point-max))))
 281            (min (max (1- window-min-height) height))
 282            (tot (if (numberp gnus-tree-minimize-window)
 283                     (min gnus-tree-minimize-window min)
 284                   min))
 285            (win (get-buffer-window (current-buffer)))
 286            (wh (and win (1- (window-height win)))))
 287       (when (and win
 288                  (not (eq tot wh)))
 289         (let ((selected (selected-window)))
 290           (select-window win)
 291           (enlarge-window (- tot wh))
 292           (select-window selected))))))
 293
 294 ;; Select the lowest window on the frame.
 295 (defun gnus-xmas-appt-select-lowest-window ()
 296   (let* ((lowest-window (selected-window))
 297          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 298          (last-window (previous-window))
 299          (window-search t))
 300     (while window-search
 301       (let* ((this-window (next-window))
 302              (next-bottom-edge (car (cdr (cdr (cdr
 303                                                (window-pixel-edges
 304                                                 this-window)))))))
 305         (when (< bottom-edge next-bottom-edge)
 306           (setq bottom-edge next-bottom-edge)
 307           (setq lowest-window this-window))
 308
 309         (select-window this-window)
 310         (when (eq last-window this-window)
 311           (select-window lowest-window)
 312           (setq window-search nil))))))
 313
 314 (defmacro gnus-xmas-menu-add (type &rest menus)
 315   `(gnus-xmas-menu-add-1 ',type ',menus))
 316 (put 'gnus-xmas-menu-add 'lisp-indent-function 1)
 317
 318 (defun gnus-xmas-menu-add-1 (type menus)
 319   (when (and menu-bar-mode
 320              (gnus-visual-p (intern (format "%s-menu" type)) 'menu))
 321     (while menus
 322       (easy-menu-add (symbol-value (pop menus))))))
 323
 324 (defun gnus-xmas-group-menu-add ()
 325   (gnus-xmas-menu-add group
 326     gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu))
 327
 328 (defun gnus-xmas-summary-menu-add ()
 329   (gnus-xmas-menu-add summary
 330     gnus-summary-misc-menu gnus-summary-kill-menu
 331     gnus-summary-article-menu gnus-summary-thread-menu
 332     gnus-summary-post-menu ))
 333
 334 (defun gnus-xmas-article-menu-add ()
 335   (gnus-xmas-menu-add article
 336     gnus-article-article-menu gnus-article-treatment-menu))
 337
 338 (defun gnus-xmas-score-menu-add ()
 339   (gnus-xmas-menu-add score
 340     gnus-score-menu))
 341
 342 (defun gnus-xmas-pick-menu-add ()
 343   (gnus-xmas-menu-add pick
 344     gnus-pick-menu))
 345
 346 (defun gnus-xmas-topic-menu-add ()
 347   (gnus-xmas-menu-add topic
 348     gnus-topic-menu))
 349
 350 (defun gnus-xmas-binary-menu-add ()
 351   (gnus-xmas-menu-add binary
 352     gnus-binary-menu))
 353
 354 (defun gnus-xmas-agent-summary-menu-add ()
 355   (gnus-xmas-menu-add agent-summary
 356     gnus-agent-summary-menu))
 357
 358 (defun gnus-xmas-agent-group-menu-add ()
 359   (gnus-xmas-menu-add agent-group
 360     gnus-agent-group-menu))
 361
 362 (defun gnus-xmas-agent-server-menu-add ()
 363   (gnus-xmas-menu-add agent-server
 364     gnus-agent-server-menu))
 365
 366 (defun gnus-xmas-tree-menu-add ()
 367   (gnus-xmas-menu-add tree
 368     gnus-tree-menu))
 369
 370 (defun gnus-xmas-draft-menu-add ()
 371   (gnus-xmas-menu-add draft
 372     gnus-draft-menu))
 373
 374 (defun gnus-xmas-server-menu-add ()
 375   (gnus-xmas-menu-add menu
 376     gnus-server-server-menu gnus-server-connections-menu))
 377
 378 (defun gnus-xmas-browse-menu-add ()
 379   (gnus-xmas-menu-add browse
 380     gnus-browse-menu))
 381
 382 (defun gnus-xmas-grouplens-menu-add ()
 383   (gnus-xmas-menu-add grouplens
 384     gnus-grouplens-menu))
 385
 386 (defun gnus-xmas-read-event-char ()
 387   "Get the next event."
 388   (let ((event (next-command-event)))
 389     (sit-for 0)
 390     ;; We junk all non-key events.  Is this naughty?
 391     (while (not (or (key-press-event-p event)
 392                     (button-press-event-p event)))
 393       (dispatch-event event)
 394       (setq event (next-command-event)))
 395     (cons (and (key-press-event-p event)
 396                (event-to-character event))
 397           event)))
 398
 399 (defun gnus-xmas-define ()
 400   (setq gnus-mouse-2 [button2])
 401   (setq gnus-mouse-3 [button3])
 402   (setq gnus-widget-button-keymap widget-button-keymap)
 403
 404   (unless (memq 'underline (face-list))
 405     (and (fboundp 'make-face)
 406          (funcall (intern "make-face") 'underline)))
 407   ;; Must avoid calling set-face-underline-p directly, because it
 408   ;; is a defsubst in emacs19, and will make the .elc files non
 409   ;; portable!
 410   (unless (face-differs-from-default-p 'underline)
 411     (funcall (intern "set-face-underline-p") 'underline t))
 412
 413   (cond
 414    ((fboundp 'char-or-char-int-p)
 415     ;; Handle both types of marks for XEmacs-20.x.
 416     (defalias 'gnus-characterp 'char-or-char-int-p))
 417    ;; V19 of XEmacs, probably.
 418    (t
 419     (defalias 'gnus-characterp 'characterp)))
 420
 421   (defalias 'gnus-make-overlay 'make-extent)
 422   (defalias 'gnus-delete-overlay 'delete-extent)
 423   (defalias 'gnus-overlay-put 'set-extent-property)
 424   (defalias 'gnus-move-overlay 'gnus-xmas-move-overlay)
 425   (defalias 'gnus-overlay-buffer 'extent-object)
 426   (defalias 'gnus-overlay-start 'extent-start-position)
 427   (defalias 'gnus-overlay-end 'extent-end-position)
 428   (defalias 'gnus-kill-all-overlays 'gnus-xmas-kill-all-overlays)
 429   (defalias 'gnus-extent-detached-p 'extent-detached-p)
 430   (defalias 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
 431   (defalias 'gnus-put-text-property 'gnus-xmas-put-text-property)
 432   (defalias 'gnus-deactivate-mark 'ignore)
 433   (defalias 'gnus-window-edges 'window-pixel-edges)
 434
 435   (if (and (<= emacs-major-version 19)
 436            (< emacs-minor-version 14))
 437       (defalias 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
 438
 439   (when (fboundp 'turn-off-scroll-in-place)
 440     (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
 441
 442   (unless (boundp 'standard-display-table)
 443     (setq standard-display-table nil))
 444
 445   (defvar gnus-mouse-face-prop 'highlight)
 446
 447   (defun gnus-byte-code (func)
 448     "Return a form that can be `eval'ed based on FUNC."
 449     (let ((fval (indirect-function func)))
 450       (if (compiled-function-p fval)
 451           (list 'funcall fval)
 452         (cons 'progn (cdr (cdr fval))))))
 453
 454   (unless (fboundp 'match-string-no-properties)
 455     (defalias 'match-string-no-properties 'match-string))
 456
 457   (defalias 'gnus-x-color-values
 458         (if (fboundp 'x-color-values)
 459             'x-color-values
 460           (lambda (color)
 461             (color-instance-rgb-components
 462              (make-color-instance color))))))
 463
 464 (defun gnus-xmas-redefine ()
 465   "Redefine lots of Gnus functions for XEmacs."
 466   (defalias 'gnus-summary-set-display-table 'gnus-xmas-summary-set-display-table)
 467   (defalias 'gnus-visual-turn-off-edit-menu 'identity)
 468   (defalias 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
 469   (defalias 'gnus-extent-start-open 'gnus-xmas-extent-start-open)
 470   (defalias 'gnus-article-push-button 'gnus-xmas-article-push-button)
 471   (defalias 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
 472   (defalias 'gnus-read-event-char 'gnus-xmas-read-event-char)
 473   (defalias 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
 474   (defalias 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
 475   (defalias 'gnus-appt-select-lowest-window
 476         'gnus-xmas-appt-select-lowest-window)
 477   (defalias 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
 478   (defalias 'gnus-character-to-event 'character-to-event)
 479   (defalias 'gnus-mode-line-buffer-identification
 480         'gnus-xmas-mode-line-buffer-identification)
 481   (defalias 'gnus-key-press-event-p 'key-press-event-p)
 482   (defalias 'gnus-region-active-p 'region-active-p)
 483   (defalias 'gnus-annotation-in-region-p 'gnus-xmas-annotation-in-region-p)
 484   (defalias 'gnus-mime-button-menu 'gnus-xmas-mime-button-menu)
 485
 486   (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
 487   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add)
 488   (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)
 489   (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add)
 490
 491   (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add)
 492   (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add)
 493   (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add)
 494   (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
 495   (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
 496   (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add)
 497   (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add)
 498
 499   (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
 500   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar)
 501
 502   (add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add)
 503   (add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add)
 504   (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add)
 505
 506   (add-hook 'gnus-draft-mode-hook 'gnus-xmas-draft-menu-add)
 507   (add-hook 'gnus-summary-mode-hook
 508             'gnus-xmas-switch-horizontal-scrollbar-off)
 509   (add-hook 'gnus-tree-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off))
 510
 511
 512 ;;; XEmacs logo and toolbar.
 513
 514 (defun gnus-xmas-group-startup-message (&optional x y)
 515   "Insert startup message in current buffer."
 516   ;; Insert the message.
 517   (erase-buffer)
 518   (cond
 519    ((and (console-on-window-system-p)
 520          (or (featurep 'xpm)
 521              (featurep 'xbm)))
 522     (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory))
 523            (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory))
 524            (glyph (make-glyph
 525                    (cond ((featurep 'xpm)
 526                           `[xpm
 527                             :file ,logo-xpm
 528                             :color-symbols
 529                             (("thing" . ,(car gnus-xmas-logo-colors))
 530                              ("shadow" . ,(cadr gnus-xmas-logo-colors))
 531                              ("background" . ,(face-background 'default)))])
 532                          ((featurep 'xbm)
 533                           `[xbm :file ,logo-xbm])
 534                          (t [nothing])))))
 535       (insert " ")
 536       (set-extent-begin-glyph (make-extent (point) (point)) glyph)
 537       (goto-char (point-min))
 538       (while (not (eobp))
 539         (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
 540                              ?\ ))
 541         (forward-line 1))
 542       (setq gnus-simple-splash nil))
 543     (goto-char (point-min))
 544     (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
 545            (wheight (window-height))
 546            (rest (- wheight pheight)))
 547       (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
 548    (t
 549     (insert
 550      (format "              %s
 551           _    ___ _             _
 552           _ ___ __ ___  __    _ ___
 553           __   _     ___    __  ___
 554               _           ___     _
 555              _  _ __             _
 556              ___   __            _
 557                    __           _
 558                     _      _   _
 559                    _      _    _
 560                       _  _    _
 561                   __  ___
 562                  _   _ _     _
 563                 _   _
 564               _    _
 565              _    _
 566             _
 567           __
 568
 569 "
 570              ""))
 571     ;; And then hack it.
 572     (gnus-indent-rigidly (point-min) (point-max)
 573                          (/ (max (- (window-width) (or x 46)) 0) 2))
 574     (goto-char (point-min))
 575     (forward-line 1)
 576     (let* ((pheight (count-lines (point-min) (point-max)))
 577            (wheight (window-height))
 578            (rest (- wheight pheight)))
 579       (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
 580     ;; Paint it.
 581     (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)))
 582   (setq modeline-buffer-identification
 583         (list (concat gnus-version ": *Group*")))
 584   (set-buffer-modified-p t))
 585
 586
 587 ;;; The toolbar.
 588
 589 (defcustom gnus-use-toolbar (if (featurep 'toolbar)
 590                                 'default-toolbar
 591                               nil)
 592   "*If nil, do not use a toolbar.
 593 If it is non-nil, it must be a toolbar.  The five valid values are
 594 `default-toolbar', `top-toolbar', `bottom-toolbar',
 595 `right-toolbar', and `left-toolbar'."
 596   :type '(choice (const default-toolbar)
 597                  (const top-toolbar) (const bottom-toolbar)
 598                  (const left-toolbar) (const right-toolbar)
 599                  (const :tag "no toolbar" nil))
 600   :group 'gnus-xmas)
 601
 602 (defvar gnus-group-toolbar
 603   '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
 604     [gnus-group-get-new-news-this-group
 605      gnus-group-get-new-news-this-group t "Get new news in this group"]
 606     [gnus-group-catchup-current
 607      gnus-group-catchup-current t "Catchup group"]
 608     [gnus-group-describe-group
 609      gnus-group-describe-group t "Describe group"]
 610     [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
 611     [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]
 612     [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
 613     [gnus-group-exit gnus-group-exit t "Exit Gnus"])
 614   "The group buffer toolbar.")
 615
 616 (defvar gnus-summary-toolbar
 617   '([gnus-summary-prev-unread
 618      gnus-summary-prev-page-or-article t "Page up"]
 619     [gnus-summary-next-unread
 620      gnus-summary-next-page t "Page down"]
 621     [gnus-summary-post-news
 622      gnus-summary-post-news t "Post an article"]
 623     [gnus-summary-followup-with-original
 624      gnus-summary-followup-with-original t
 625      "Post a followup and yank the original"]
 626     [gnus-summary-followup
 627      gnus-summary-followup t "Post a followup"]
 628     [gnus-summary-reply-with-original
 629      gnus-summary-reply-with-original t "Mail a reply and yank the original"]
 630     [gnus-summary-reply
 631      gnus-summary-reply t "Mail a reply"]
 632     [gnus-summary-caesar-message
 633      gnus-summary-caesar-message t "Rot 13"]
 634     [gnus-uu-decode-uu
 635      gnus-uu-decode-uu t "Decode uuencoded articles"]
 636     [gnus-summary-save-article-file
 637      gnus-summary-save-article-file t "Save article in file"]
 638     [gnus-summary-save-article
 639      gnus-summary-save-article t "Save article"]
 640     [gnus-uu-post-news
 641      gnus-uu-post-news t "Post a uuencoded article"]
 642     [gnus-summary-cancel-article
 643      gnus-summary-cancel-article t "Cancel article"]
 644     [gnus-summary-catchup
 645      gnus-summary-catchup t "Catchup"]
 646     [gnus-summary-catchup-and-exit
 647      gnus-summary-catchup-and-exit t "Catchup and exit"]
 648     [gnus-summary-exit gnus-summary-exit t "Exit this summary"])
 649   "The summary buffer toolbar.")
 650
 651 (defvar gnus-summary-mail-toolbar
 652   '(
 653     [gnus-summary-prev-unread
 654      gnus-summary-prev-unread-article t "Prev unread article"]
 655     [gnus-summary-next-unread
 656      gnus-summary-next-unread-article t "Next unread article"]
 657     [gnus-summary-mail-reply gnus-summary-reply t "Reply"]
 658     [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
 659     [gnus-summary-mail-save gnus-summary-save-article t "Save"]
 660     [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
 661     [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
 662     [gnus-summary-caesar-message
 663      gnus-summary-caesar-message t "Rot 13"]
 664     [gnus-uu-decode-uu
 665      gnus-uu-decode-uu t "Decode uuencoded articles"]
 666     [gnus-summary-save-article-file
 667      gnus-summary-save-article-file t "Save article in file"]
 668     [gnus-summary-save-article
 669      gnus-summary-save-article t "Save article"]
 670     [gnus-summary-catchup
 671      gnus-summary-catchup t "Catchup"]
 672     [gnus-summary-catchup-and-exit
 673      gnus-summary-catchup-and-exit t "Catchup and exit"]
 674     [gnus-summary-exit gnus-summary-exit t "Exit this summary"])
 675   "The summary buffer mail toolbar.")
 676
 677 (defun gnus-xmas-setup-group-toolbar ()
 678   (and gnus-use-toolbar
 679        (message-xmas-setup-toolbar gnus-group-toolbar nil "gnus")
 680        (set-specifier (symbol-value gnus-use-toolbar)
 681                       (cons (current-buffer) gnus-group-toolbar))))
 682
 683 (defun gnus-xmas-setup-summary-toolbar ()
 684   (let ((bar (if (gnus-news-group-p gnus-newsgroup-name)
 685                  gnus-summary-toolbar gnus-summary-mail-toolbar)))
 686     (and gnus-use-toolbar
 687          (message-xmas-setup-toolbar bar nil "gnus")
 688          (set-specifier (symbol-value gnus-use-toolbar)
 689                         (cons (current-buffer) bar)))))
 690
 691 (defun gnus-xmas-mail-strip-quoted-names (address)
 692   "Protect mail-strip-quoted-names from NIL input.
 693 XEmacs compatibility workaround."
 694   (if (null address)
 695       nil
 696     (mail-strip-quoted-names address)))
 697
 698 (defun gnus-xmas-call-region (command &rest args)
 699   (apply
 700    'call-process-region (point-min) (point-max) command t '(t nil) nil
 701    args))
 702
 703 (defface gnus-x-face '((t (:foreground "black" :background "white")))
 704   "Face to show X face"
 705   :group 'gnus-xmas)
 706
 707 (defun gnus-xmas-article-display-xface (beg end)
 708   "Display any XFace headers in the current article."
 709   (save-excursion
 710     (let ((xface-glyph
 711            (cond
 712             ((featurep 'xface)
 713              (make-glyph (vector 'xface :data
 714                                  (concat "X-Face: "
 715                                          (buffer-substring beg end)))))
 716             ((featurep 'xpm)
 717              (let ((cur (current-buffer)))
 718                (save-excursion
 719                  (gnus-set-work-buffer)
 720                  (insert-buffer-substring cur beg end)
 721                  (gnus-xmas-call-region "uncompface")
 722                  (goto-char (point-min))
 723                  (insert "/* Width=48, Height=48 */\n")
 724                  (gnus-xmas-call-region "icontopbm")
 725                  (gnus-xmas-call-region "ppmtoxpm")
 726                  (make-glyph
 727                   (vector 'xpm :data (buffer-string))))))
 728             (t
 729              (make-glyph [nothing]))))
 730           (ext (make-extent (progn
 731                               (goto-char (point-min))
 732                               (re-search-forward "^From:" nil t)
 733                               (point))
 734                             (1+ (point)))))
 735       (set-glyph-face xface-glyph 'gnus-x-face)
 736       (set-extent-begin-glyph ext xface-glyph)
 737       (set-extent-property ext 'duplicable t))))
 738
 739 (defvar gnus-xmas-modeline-left-extent
 740   (let ((ext (copy-extent modeline-buffer-id-left-extent)))
 741     ext))
 742
 743 (defvar gnus-xmas-modeline-right-extent
 744   (let ((ext (copy-extent modeline-buffer-id-right-extent)))
 745     ext))
 746
 747 (defvar gnus-xmas-modeline-glyph
 748   (progn
 749     (let* ((file-xpm (expand-file-name "gnus-pointer.xpm"
 750                                        gnus-xmas-glyph-directory))
 751            (file-xbm (expand-file-name "gnus-pointer.xbm"
 752                                        gnus-xmas-glyph-directory))
 753            (glyph (make-glyph
 754                    ;; Gag gag gag.
 755                    (cond ((featurep 'xpm)
 756                           ;; Let's try a nifty XPM
 757                           `[xpm :file ,file-xpm])
 758                          ((featurep 'xbm)
 759                           ;; Then a not-so-nifty XBM
 760                           `[xbm :file ,file-xbm])
 761                          ;; Then the simple string
 762                          (t [string :data "Gnus:"])))))
 763       (set-glyph-face glyph 'modeline-buffer-id)
 764       glyph)))
 765
 766 (defun gnus-xmas-mode-line-buffer-identification (line)
 767   (let ((line (car line))
 768         chop)
 769     (cond
 770      ;; This is some weird type of id.
 771      ((not (stringp line))
 772       (list line))
 773      ;; This is non-standard, so we just pass it through.
 774      ((not (string-match "^Gnus:" line))
 775       (list line))
 776      ;; We have a standard line, so we colorize and glyphize it a bit.
 777      (t
 778       (setq chop (match-end 0))
 779       (list
 780        (if gnus-xmas-modeline-glyph
 781            (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
 782          (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
 783        (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
 784
 785 (defun gnus-xmas-splash ()
 786   (when (eq (device-type) 'x)
 787     (gnus-splash)))
 788
 789 (defun gnus-xmas-annotation-in-region-p (b e)
 790   (or (map-extents (lambda (e u) t) nil b e nil nil 'mm t)
 791       (if (= b e)
 792           (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
 793         (text-property-any b e 'gnus-undeletable t))))
 794
 795 (defun gnus-xmas-mime-button-menu (event)
 796   "Construct a context-sensitive menu of MIME commands."
 797   (interactive "e")
 798   (let ((response (get-popup-menu-response
 799                    `("MIME Part"
 800                      ,@(mapcar (lambda (c) `[,(caddr c) ,(car c) t])
 801                                gnus-mime-button-commands)))))
 802     (set-buffer (event-buffer event))
 803     (goto-char (event-point event))
 804     (funcall (event-function response) (event-object response))))
 805
 806 (defun gnus-group-add-icon ()
 807   "Add an icon to the current line according to `gnus-group-icon-list'."
 808   (let* ((p (point))
 809          (end (progn (end-of-line) (point)))
 810          ;; now find out where the line starts and leave point there.
 811          (beg (progn (beginning-of-line) (point))))
 812     (save-restriction
 813       (narrow-to-region beg end)
 814       (goto-char beg)
 815       (when (search-forward "==&&==" nil t)
 816         (let* ((group (gnus-group-group-name))
 817                (entry (gnus-group-entry group))
 818                (unread (if (numberp (car entry)) (car entry) 0))
 819                (active (gnus-active group))
 820                (total (if active (1+ (- (cdr active) (car active))) 0))
 821                (info (nth 2 entry))
 822                (method (gnus-server-get-method group (gnus-info-method info)))
 823                (marked (gnus-info-marks info))
 824                (mailp (memq 'mail (assoc (symbol-name
 825                                           (car (or method gnus-select-method)))
 826                                          gnus-valid-select-methods)))
 827                (level (or (gnus-info-level info) gnus-level-killed))
 828                (score (or (gnus-info-score info) 0))
 829                (ticked (gnus-range-length (cdr (assq 'tick marked))))
 830                (group-age (gnus-group-timestamp-delta group))
 831                (inhibit-read-only t)
 832                (list gnus-group-icon-list)
 833                (mystart (match-beginning 0))
 834                (myend (match-end 0)))
 835           (goto-char (point-min))
 836           (while (and list
 837                       (not (eval (caar list))))
 838             (setq list (cdr list)))
 839           (if list
 840               (let* ((file (cdar list))
 841                      (glyph (gnus-group-icon-create-glyph
 842                              (buffer-substring mystart myend)
 843                              file)))
 844                 (if glyph
 845                     (progn
 846                       (mapcar 'delete-annotation (annotations-at myend))
 847                       (let ((ext (make-extent mystart myend))
 848                             (ant (make-annotation glyph myend 'text)))
 849                         ;; set text extent params
 850                         (set-extent-property ext 'end-open t)
 851                         (set-extent-property ext 'start-open t)
 852                         (set-extent-property ext 'invisible t)))
 853                   (delete-region mystart myend)))
 854             (delete-region mystart myend))))
 855       (widen))
 856     (goto-char p)))
 857
 858 (defun gnus-group-icon-create-glyph (substring pixmap)
 859   "Create a glyph for insertion into a group line."
 860   (or
 861    (cdr-safe (assoc pixmap gnus-group-icon-cache))
 862    (let* ((glyph (make-glyph
 863                   (list
 864                    (cons 'x
 865                          (expand-file-name pixmap gnus-xmas-glyph-directory))
 866                    (cons 'mswindows
 867                          (expand-file-name pixmap gnus-xmas-glyph-directory))
 868                    (cons 'tty substring)))))
 869      (setq gnus-group-icon-cache
 870            (cons (cons pixmap glyph) gnus-group-icon-cache))
 871      (set-glyph-face glyph 'default)
 872      glyph)))
 873
 874 (defun gnus-xmas-mailing-list-menu-add ()
 875   (gnus-xmas-menu-add mailing-list
 876                       gnus-mailing-list-menu))
 877
 878 (add-hook 'gnus-mailing-list-mode-hook 'gnus-xmas-mailing-list-menu-add)
 879
 880 (provide 'gnus-xmas)
 881
 882 ;;; gnus-xmas.el ends here