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

   1 ;;; gnus-xmas.el --- Gnus functions for XEmacs
   2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5 ;; Keywords: news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'text-props)
  29 (eval-when-compile (require 'cl))
  30 (defvar menu-bar-mode t)
  31 (require 'messagexmas)
  32
  33 (defvar gnus-xmas-glyph-directory nil
  34   "*Directory where Gnus logos and icons are located.
  35 If this variable is nil, Gnus will try to locate the directory
  36 automatically.")
  37
  38 (defvar gnus-xmas-logo-color-alist
  39   '((flame "#cc3300" "#ff2200")
  40     (pine "#c0cc93" "#f8ffb8")
  41     (moss "#a1cc93" "#d2ffb8")
  42     (irish "#04cc90" "#05ff97")
  43     (sky "#049acc" "#05deff")
  44     (tin "#6886cc" "#82b6ff")
  45     (velvet "#7c68cc" "#8c82ff")
  46     (grape "#b264cc" "#cf7df")
  47     (labia "#cc64c2" "#fd7dff")
  48     (berry "#cc6485" "#ff7db5")
  49     (neutral "#b4b4b4" "#878787")
  50     (september "#bf9900" "#ffcc00"))
  51   "Color alist used for the Gnus logo.")
  52
  53 (defvar gnus-xmas-logo-color-style 'september
  54   "Color styles used for the Gnus logo.")
  55
  56 (defvar gnus-xmas-logo-colors
  57   (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist))
  58   "Colors used for the Gnus logo.")
  59
  60 ;;; Internal variables.
  61
  62 ;; Don't warn about these undefined variables.
  63
  64 (defvar gnus-group-mode-hook)
  65 (defvar gnus-summary-mode-hook)
  66 (defvar gnus-article-mode-hook)
  67
  68 ;;defined in gnus.el
  69 (defvar gnus-active-hashtb)
  70 (defvar gnus-article-buffer)
  71 (defvar gnus-auto-center-summary)
  72 (defvar gnus-buffer-list)
  73 (defvar gnus-current-headers)
  74 (defvar gnus-level-killed)
  75 (defvar gnus-level-zombie)
  76 (defvar gnus-newsgroup-bookmarks)
  77 (defvar gnus-newsgroup-dependencies)
  78 (defvar gnus-newsgroup-selected-overlay)
  79 (defvar gnus-newsrc-hashtb)
  80 (defvar gnus-read-mark)
  81 (defvar gnus-refer-article-method)
  82 (defvar gnus-reffed-article-number)
  83 (defvar gnus-unread-mark)
  84 (defvar gnus-version)
  85 (defvar gnus-view-pseudos)
  86 (defvar gnus-view-pseudos-separately)
  87 (defvar gnus-visual)
  88 (defvar gnus-zombie-list)
  89 ;;defined in gnus-msg.el
  90 (defvar gnus-article-copy)
  91 (defvar gnus-check-before-posting)
  92 ;;defined in gnus-vis.el
  93 (defvar gnus-article-button-face)
  94 (defvar gnus-article-mouse-face)
  95 (defvar gnus-summary-selected-face)
  96 (defvar gnus-group-reading-menu)
  97 (defvar gnus-group-group-menu)
  98 (defvar gnus-group-misc-menu)
  99 (defvar gnus-summary-article-menu)
 100 (defvar gnus-summary-thread-menu)
 101 (defvar gnus-summary-misc-menu)
 102 (defvar gnus-summary-post-menu)
 103 (defvar gnus-summary-kill-menu)
 104 (defvar gnus-article-article-menu)
 105 (defvar gnus-article-treatment-menu)
 106 (defvar gnus-mouse-2)
 107 (defvar standard-display-table)
 108
 109 (defun gnus-xmas-set-text-properties (start end props &optional buffer)
 110   "You should NEVER use this function.  It is ideologically blasphemous.
 111 It is provided only to ease porting of broken FSF Emacs programs."
 112   (if (stringp buffer)
 113       nil
 114     (map-extents (lambda (extent ignored)
 115                    (remove-text-properties
 116                     start end
 117                     (list (extent-property extent 'text-prop) nil)
 118                     buffer))
 119                  buffer start end nil nil 'text-prop)
 120     (gnus-add-text-properties start end props buffer)))
 121
 122 (defun gnus-xmas-highlight-selected-summary ()
 123   ;; Highlight selected article in summary buffer
 124   (if gnus-summary-selected-face
 125       (progn
 126         (if gnus-newsgroup-selected-overlay
 127             (delete-extent gnus-newsgroup-selected-overlay))
 128         (setq gnus-newsgroup-selected-overlay
 129               (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
 130         (set-extent-face gnus-newsgroup-selected-overlay
 131                          gnus-summary-selected-face))))
 132
 133 (defun gnus-xmas-summary-recenter ()
 134   "\"Center\" point in the summary window.
 135 If `gnus-auto-center-summary' is nil, or the article buffer isn't
 136 displayed, no centering will be performed."
 137   ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
 138   ;; Recenter only when requested.  Suggested by popovich@park.cs.columbia.edu.
 139   (when gnus-auto-center-summary
 140     (sit-for 0)
 141     (let* ((height (if (fboundp 'window-displayed-height)
 142                        (window-displayed-height)
 143                      (- (window-height) 2)))
 144            (top (cond ((< height 4) 0)
 145                       ((< height 7) 1)
 146                       (t 2)))
 147            (bottom (save-excursion (goto-char (point-max))
 148                                    (forward-line (- height))
 149                                    (point)))
 150            (window (get-buffer-window (current-buffer))))
 151       (when (get-buffer-window gnus-article-buffer)
 152         ;; Only do recentering when the article buffer is displayed,
 153         ;; Set the window start to either `bottom', which is the biggest
 154         ;; possible valid number, or the second line from the top,
 155         ;; whichever is the least.
 156         (set-window-start
 157          window (min bottom (save-excursion
 158                               (forward-line (- top)) (point)))))
 159       ;; Do horizontal recentering while we're at it.
 160       (when (and (get-buffer-window (current-buffer) t)
 161                  (not (eq gnus-auto-center-summary 'vertical)))
 162         (let ((selected (selected-window)))
 163           (select-window (get-buffer-window (current-buffer) t))
 164           (gnus-summary-position-point)
 165           (gnus-horizontal-recenter)
 166           (select-window selected))))))
 167
 168 (defun gnus-xmas-add-hook (hook function &optional append local)
 169   (add-hook hook function))
 170
 171 (defun gnus-xmas-add-text-properties (start end props &optional object)
 172   (add-text-properties start end props object)
 173   (put-text-property start end 'start-closed nil object))
 174
 175 (defun gnus-xmas-put-text-property (start end prop value &optional object)
 176   (put-text-property start end prop value object)
 177   (put-text-property start end 'start-closed nil object))
 178
 179 (defun gnus-xmas-extent-start-open (point)
 180   (map-extents (lambda (extent arg)
 181                  (set-extent-property extent 'start-open t))
 182                nil point (min (1+ (point)) (point-max))))
 183
 184 (defun gnus-xmas-copy-article-buffer (&optional article-buffer)
 185   (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
 186   (buffer-disable-undo gnus-article-copy)
 187   (or (memq gnus-article-copy gnus-buffer-list)
 188       (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
 189   (let ((article-buffer (or article-buffer gnus-article-buffer))
 190         buf)
 191     (if (and (get-buffer article-buffer)
 192              (buffer-name (get-buffer article-buffer)))
 193         (save-excursion
 194           (set-buffer article-buffer)
 195           (widen)
 196           (setq buf (buffer-substring (point-min) (point-max)))
 197           (set-buffer gnus-article-copy)
 198           (erase-buffer)
 199           (insert (format "%s" buf))))
 200     gnus-article-copy))
 201
 202 (defun gnus-xmas-article-push-button (event)
 203   "Check text under the mouse pointer for a callback function.
 204 If the text under the mouse pointer has a `gnus-callback' property,
 205 call it with the value of the `gnus-data' text property."
 206   (interactive "e")
 207   (set-buffer (window-buffer (event-window event)))
 208   (let* ((pos (event-closest-point event))
 209          (data (get-text-property pos 'gnus-data))
 210          (fun (get-text-property pos 'gnus-callback)))
 211     (if fun (funcall fun data))))
 212
 213 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
 214   (set-extent-endpoints extent start end))
 215
 216 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
 217 (defun gnus-xmas-article-add-button (from to fun &optional data)
 218   "Create a button between FROM and TO with callback FUN and data DATA."
 219   (and gnus-article-button-face
 220        (gnus-overlay-put (gnus-make-overlay from to)
 221                          'face gnus-article-button-face))
 222   (gnus-add-text-properties
 223    from to
 224    (nconc
 225     (and gnus-article-mouse-face
 226          (list 'mouse-face gnus-article-mouse-face))
 227     (list 'gnus-callback fun)
 228     (and data (list 'gnus-data data))
 229     (list 'highlight t))))
 230
 231 (defun gnus-xmas-window-top-edge (&optional window)
 232   (nth 1 (window-pixel-edges window)))
 233
 234 (defun gnus-xmas-tree-minimize ()
 235   (when (and gnus-tree-minimize-window
 236              (not (one-window-p)))
 237     (let* ((window-min-height 2)
 238            (height (1+ (count-lines (point-min) (point-max))))
 239            (min (max (1- window-min-height) height))
 240            (tot (if (numberp gnus-tree-minimize-window)
 241                     (min gnus-tree-minimize-window min)
 242                   min))
 243            (win (get-buffer-window (current-buffer)))
 244            (wh (and win (1- (window-height win)))))
 245       (when (and win
 246                  (not (eq tot wh)))
 247         (let ((selected (selected-window)))
 248           (select-window win)
 249           (enlarge-window (- tot wh))
 250           (select-window selected))))))
 251
 252 ;; Select the lowest window on the frame.
 253 (defun gnus-xmas-appt-select-lowest-window ()
 254   (let* ((lowest-window (selected-window))
 255          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 256          (last-window (previous-window))
 257          (window-search t))
 258     (while window-search
 259       (let* ((this-window (next-window))
 260              (next-bottom-edge (car (cdr (cdr (cdr
 261                                                (window-pixel-edges
 262                                                 this-window)))))))
 263         (if (< bottom-edge next-bottom-edge)
 264             (progn
 265               (setq bottom-edge next-bottom-edge)
 266               (setq lowest-window this-window)))
 267
 268         (select-window this-window)
 269         (if (eq last-window this-window)
 270             (progn
 271               (select-window lowest-window)
 272               (setq window-search nil)))))))
 273
 274 (defmacro gnus-xmas-menu-add (type &rest menus)
 275   `(gnus-xmas-menu-add-1 ',type ',menus))
 276 (put 'gnus-xmas-menu-add 'lisp-indent-function 1)
 277 (put 'gnus-xmas-menu-add 'lisp-indent-hook 1)
 278
 279 (defun gnus-xmas-menu-add-1 (type menus)
 280   (when (and menu-bar-mode
 281              (gnus-visual-p (intern (format "%s-menu" type)) 'menu))
 282     (while menus
 283       (easy-menu-add (symbol-value (pop menus))))))
 284
 285 (defun gnus-xmas-group-menu-add ()
 286   (gnus-xmas-menu-add group
 287     gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu))
 288
 289 (defun gnus-xmas-summary-menu-add ()
 290   (gnus-xmas-menu-add summary
 291     gnus-summary-article-menu gnus-summary-thread-menu
 292     gnus-summary-misc-menu gnus-summary-post-menu gnus-summary-kill-menu))
 293
 294 (defun gnus-xmas-article-menu-add ()
 295   (gnus-xmas-menu-add article
 296     gnus-article-article-menu gnus-article-treatment-menu))
 297
 298 (defun gnus-xmas-pick-menu-add ()
 299   (gnus-xmas-menu-add pick
 300     gnus-pick-menu))
 301
 302 (defun gnus-xmas-binary-menu-add ()
 303   (gnus-xmas-menu-add binary
 304     gnus-binary-menu))
 305
 306 (defun gnus-xmas-tree-menu-add ()
 307   (gnus-xmas-menu-add tree
 308     gnus-tree-menu))
 309
 310 (defun gnus-xmas-grouplens-menu-add ()
 311   (gnus-xmas-menu-add grouplens
 312     gnus-grouplens-menu))
 313
 314 (defun gnus-xmas-read-event-char ()
 315   "Get the next event."
 316   (let ((event (next-event)))
 317     ;; We junk all non-key events.  Is this naughty?
 318     (while (not (key-press-event-p event))
 319       (setq event (next-event)))
 320     (cons (and (key-press-event-p event)
 321               ; (numberp (event-key event))
 322                (event-to-character event))
 323           event)))
 324
 325 (defun gnus-xmas-group-remove-excess-properties ()
 326   (let ((end (point))
 327         (beg (progn (forward-line -1) (point))))
 328     (remove-text-properties (1+ beg) end '(gnus-group nil))
 329     (remove-text-properties
 330      beg end
 331      '(gnus-topic nil gnus-topic-level nil gnus-topic-visible nil))
 332     (goto-char end)
 333     (map-extents
 334      (lambda (e ma)
 335        (set-extent-property e 'start-closed t))
 336      (current-buffer) beg end)))
 337
 338 (defun gnus-xmas-topic-remove-excess-properties ()
 339   (let ((end (point))
 340         (beg (progn (forward-line -1) (point))))
 341     (remove-text-properties beg end '(gnus-group nil gnus-unread nil))
 342     (remove-text-properties (1+ beg) end '(gnus-topic nil))
 343     (goto-char end)))
 344
 345 (defun gnus-xmas-seconds-since-epoch (date)
 346   "Return a floating point number that says how many seconds have lapsed between Jan 1 12:00:00 1970 and DATE."
 347   (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti)))
 348                         (timezone-parse-date date)))
 349          (ttime (mapcar (lambda (ti) (and ti (string-to-int ti)))
 350                         (timezone-parse-time
 351                          (aref (timezone-parse-date date) 3))))
 352          (edate (mapcar (lambda (ti) (and ti (string-to-int ti)))
 353                         (timezone-parse-date "Jan 1 12:00:00 1970")))
 354          (tday (- (timezone-absolute-from-gregorian
 355                    (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
 356                   (timezone-absolute-from-gregorian
 357                    (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
 358     (+ (nth 2 ttime)
 359        (* (nth 1 ttime) 60)
 360        (* (float (nth 0 ttime)) 60 60)
 361        (* (float tday) 60 60 24))))
 362
 363 (defun gnus-xmas-define ()
 364   (setq gnus-mouse-2 [button2])
 365
 366   (or (memq 'underline (list-faces))
 367       (and (fboundp 'make-face)
 368            (funcall (intern "make-face") 'underline)))
 369   ;; Must avoid calling set-face-underline-p directly, because it
 370   ;; is a defsubst in emacs19, and will make the .elc files non
 371   ;; portable!
 372   (or (face-differs-from-default-p 'underline)
 373       (funcall (intern "set-face-underline-p") 'underline t))
 374
 375   (fset 'gnus-make-overlay 'make-extent)
 376   (fset 'gnus-overlay-put 'set-extent-property)
 377   (fset 'gnus-move-overlay 'gnus-xmas-move-overlay)
 378   (fset 'gnus-overlay-end 'extent-end-position)
 379   (fset 'gnus-extent-detached-p 'extent-detached-p)
 380   (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
 381   (fset 'gnus-put-text-property 'gnus-xmas-put-text-property)
 382
 383   (require 'text-props)
 384   (if (< emacs-minor-version 14)
 385       (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
 386
 387   (or (boundp 'standard-display-table) (setq standard-display-table nil))
 388
 389   (defvar gnus-mouse-face-prop 'highlight)
 390
 391   (unless (fboundp 'encode-time)
 392     (defun encode-time (sec minute hour day month year &optional zone)
 393       (let ((seconds
 394              (gnus-xmas-seconds-since-epoch
 395               (timezone-make-arpa-date
 396                year month day (timezone-make-time-string hour minute sec)
 397                zone))))
 398         (list (floor (/ seconds (expt 2 16)))
 399               (round (mod seconds (expt 2 16)))))))
 400
 401   (defun gnus-byte-code (func)
 402     "Return a form that can be `eval'ed based on FUNC."
 403     (let ((fval (symbol-function func)))
 404       (if (byte-code-function-p fval)
 405           (list 'funcall fval)
 406         (cons 'progn (cdr (cdr fval))))))
 407
 408   ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
 409   (defvar gnus-display-type (device-class)
 410     "A symbol indicating the display Emacs is running under.
 411 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
 412 guesses this display attribute wrongly, either set this variable in
 413 your `~/.emacs' or set the resource `Emacs.displayType' in your
 414 `~/.Xdefaults'. See also `gnus-background-mode'.
 415
 416 This is a meta-variable that will affect what default values other
 417 variables get.  You would normally not change this variable, but
 418 pounce directly on the real variables themselves.")
 419
 420
 421   (fset 'gnus-x-color-values
 422         (if (fboundp 'x-color-values)
 423             'x-color-values
 424           (lambda (color)
 425             (color-instance-rgb-components
 426              (make-color-instance color)))))
 427
 428   (defvar gnus-background-mode
 429     (let* ((bg-resource
 430             (condition-case ()
 431                 (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
 432               (error nil)))
 433            (params (frame-parameters))
 434            (color (condition-case ()
 435                       (or (assq 'background-color params)
 436                           (color-instance-name
 437                            (specifier-instance
 438                             (face-background 'default))))
 439                     (error nil))))
 440       (cond (bg-resource (intern (downcase bg-resource)))
 441             ((and color
 442                   (< (apply '+ (gnus-x-color-values color))
 443                      (/ (apply '+ (gnus-x-color-values "white")) 3)))
 444              'dark)
 445             (t 'light)))
 446     "A symbol indicating the Emacs background brightness.
 447 The symbol should be one of `light' or `dark'.
 448 If Emacs guesses this frame attribute wrongly, either set this variable in
 449 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
 450 `~/.Xdefaults'.
 451 See also `gnus-display-type'.
 452
 453 This is a meta-variable that will affect what default values other
 454 variables get.  You would normally not change this variable, but
 455 pounce directly on the real variables themselves.")
 456   )
 457
 458
 459
 460 (defun gnus-xmas-redefine ()
 461   "Redefine lots of Gnus functions for XEmacs."
 462   (fset 'gnus-summary-make-display-table 'ignore)
 463   (fset 'gnus-visual-turn-off-edit-menu 'identity)
 464   (fset 'gnus-highlight-selected-summary
 465         'gnus-xmas-highlight-selected-summary)
 466   (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
 467   (fset 'gnus-extent-start-open 'gnus-xmas-extent-start-open)
 468   (fset 'gnus-copy-article-buffer 'gnus-xmas-copy-article-buffer)
 469   (fset 'gnus-article-push-button 'gnus-xmas-article-push-button)
 470   (fset 'gnus-article-add-button 'gnus-xmas-article-add-button)
 471   (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
 472   (fset 'gnus-read-event-char 'gnus-xmas-read-event-char)
 473   (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
 474   (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
 475   (fset 'gnus-appt-select-lowest-window
 476         'gnus-xmas-appt-select-lowest-window)
 477   (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
 478   (fset 'gnus-make-local-hook 'make-local-variable)
 479   (fset 'gnus-add-hook 'gnus-xmas-add-hook)
 480   (fset 'gnus-character-to-event 'character-to-event)
 481
 482   (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
 483   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add)
 484   (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)
 485
 486   (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add)
 487   (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add)
 488   (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
 489   (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
 490
 491   (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
 492   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar)
 493
 494   (when (and (<= emacs-major-version 19)
 495              (<= emacs-minor-version 13))
 496     (fset 'gnus-group-remove-excess-properties
 497           'gnus-xmas-group-remove-excess-properties)
 498     (fset 'gnus-topic-remove-excess-properties
 499           'gnus-xmas-topic-remove-excess-properties)))
 500
 501
 502 ;;; XEmacs logo and toolbar.
 503
 504 (defun gnus-xmas-group-startup-message (&optional x y)
 505   "Insert startup message in current buffer."
 506   ;; Insert the message.
 507   (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
 508   (erase-buffer)
 509   (let ((logo (and gnus-xmas-glyph-directory
 510                    (concat
 511                     (file-name-as-directory gnus-xmas-glyph-directory)
 512                     "gnus.xpm")))
 513         (xpm-color-symbols
 514          (and (featurep 'xpm)
 515               (append `(("thing" ,(car gnus-xmas-logo-colors))
 516                         ("shadow" ,(cadr gnus-xmas-logo-colors)))
 517                       xpm-color-symbols))))
 518     (if (and (featurep 'xpm)
 519              (not (equal (device-type) 'tty))
 520              logo
 521              (file-exists-p logo))
 522         (progn
 523           (setq logo (make-glyph logo))
 524           (insert " ")
 525           (set-extent-begin-glyph (make-extent (point) (point)) logo)
 526           (goto-char (point-min))
 527           (while (not (eobp))
 528             (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
 529                                  ? ))
 530             (forward-line 1))
 531           (goto-char (point-min))
 532           (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
 533                  (wheight (window-height))
 534                  (rest (- wheight pheight)))
 535             (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
 536
 537       (insert
 538        (format "              %s
 539           _    ___ _             _
 540           _ ___ __ ___  __    _ ___
 541           __   _     ___    __  ___
 542               _           ___     _
 543              _  _ __             _
 544              ___   __            _
 545                    __           _
 546                     _      _   _
 547                    _      _    _
 548                       _  _    _
 549                   __  ___
 550                  _   _ _     _
 551                 _   _
 552               _    _
 553              _    _
 554             _
 555           __
 556
 557 "
 558                ""))
 559       ;; And then hack it.
 560       (gnus-indent-rigidly (point-min) (point-max)
 561                            (/ (max (- (window-width) (or x 46)) 0) 2))
 562       (goto-char (point-min))
 563       (forward-line 1)
 564       (let* ((pheight (count-lines (point-min) (point-max)))
 565              (wheight (window-height))
 566              (rest (- wheight pheight)))
 567         (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
 568     ;; Fontify some.
 569     (goto-char (point-min))
 570     (and (search-forward "Praxis" nil t)
 571          (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 572     (goto-char (point-min))
 573     (let* ((mode-string (gnus-group-set-mode-line)))
 574       (setq mode-line-buffer-identification
 575             (list (concat gnus-version (substring (car mode-string) 4))))
 576       (set-buffer-modified-p t))))
 577
 578
 579 ;;; The toolbar.
 580
 581 (defvar gnus-use-toolbar 'default-toolbar
 582   "*If nil, do not use a toolbar.
 583 If it is non-nil, it must be a toolbar.  The five legal values are
 584 `default-toolbar', `top-toolbar', `bottom-toolbar',
 585 `right-toolbar', and `left-toolbar'.")
 586
 587 (defvar gnus-group-toolbar
 588   '(
 589     [gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
 590     [gnus-group-get-new-news-this-group
 591      gnus-group-get-new-news-this-group t "Get new news in this group"]
 592     [gnus-group-catchup-current
 593      gnus-group-catchup-current t "Catchup group"]
 594     [gnus-group-describe-group
 595      gnus-group-describe-group t "Describe group"]
 596     [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
 597     [gnus-group-exit gnus-group-exit t "Exit Gnus"]
 598     )
 599   "The group buffer toolbar.")
 600
 601 (defvar gnus-summary-toolbar
 602   '(
 603     [gnus-summary-post-news
 604      gnus-summary-post-news t "Post an article"]
 605     [gnus-summary-followup-with-original
 606      gnus-summary-followup-with-original t
 607      "Post a followup and yank the original"]
 608     [gnus-summary-followup
 609      gnus-summary-followup t "Post a followup"]
 610     [gnus-summary-reply-with-original
 611      gnus-summary-reply-with-original t "Mail a reply and yank the original"]
 612     [gnus-summary-reply
 613      gnus-summary-reply t "Mail a reply"]
 614     [gnus-summary-caesar-message
 615      gnus-summary-caesar-message t "Rot 13"]
 616     [gnus-uu-decode-uu
 617      gnus-uu-decode-uu t "Decode uuencoded articles"]
 618     [gnus-summary-save-article-file
 619      gnus-summary-save-article-file t "Save article in file"]
 620     [gnus-summary-save-article
 621      gnus-summary-save-article t "Save article"]
 622     [gnus-uu-post-news
 623      gnus-uu-post-news t "Post an uuencoded article"]
 624     [gnus-summary-cancel-article
 625      gnus-summary-cancel-article t "Cancel article"]
 626     )
 627   "The summary buffer toolbar.")
 628
 629 (defvar gnus-summary-mail-toolbar
 630   '([gnus-summary-mail-reply gnus-summary-reply t "Reply"]
 631     [gnus-summary-mail-get gnus-mail-get t "Message get"]
 632     [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
 633     [gnus-summary-mail-save gnus-summary-save-article t "Save"]
 634     [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
 635     [gnus-summary-mail-delete gnus-summary-delete-article t "Delete message"]
 636     [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
 637 ;    [gnus-summary-mail-spell gnus-mail-spell t "Spell"]
 638 ;    [gnus-summary-mail-help gnus-mail-help  t "Message help"]
 639     )
 640   "The summary buffer mail toolbar.")
 641
 642 (defun gnus-xmas-setup-group-toolbar ()
 643   (let (dir)
 644     (and gnus-use-toolbar
 645          (setq dir (message-xmas-setup-toolbar gnus-group-toolbar nil "gnus"))
 646          (file-exists-p (concat dir "gnus-group-catchup-current-up.xpm"))
 647          (set-specifier (symbol-value gnus-use-toolbar)
 648                         (cons (current-buffer) gnus-group-toolbar)))))
 649
 650 (defun gnus-xmas-setup-summary-toolbar ()
 651   (let ((bar (if (gnus-news-group-p gnus-newsgroup-name)
 652                  gnus-summary-toolbar gnus-summary-mail-toolbar))
 653         dir)
 654     (and gnus-use-toolbar
 655          (setq dir (message-xmas-setup-toolbar bar nil "gnus"))
 656          (file-exists-p (concat dir "gnus-group-catchup-current-up.xpm"))
 657          (set-specifier (symbol-value gnus-use-toolbar)
 658                         (cons (current-buffer) bar)))))
 659
 660 (defun gnus-xmas-mail-strip-quoted-names (address)
 661   "Protect mail-strip-quoted-names from NIL input.
 662 XEmacs compatibility workaround."
 663   (if (null address)
 664       nil
 665     (mail-strip-quoted-names address)))
 666
 667 ;;; gnus-xmas.el ends here