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