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