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, 2002, 2003,
   4 ;;   2005, 2006 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 3, 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., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (eval-when-compile
  31   (autoload 'gnus-active "gnus" nil nil 'macro)
  32   (autoload 'gnus-group-entry "gnus" nil nil 'macro)
  33   (autoload 'gnus-info-level "gnus" nil nil 'macro)
  34   (autoload 'gnus-info-marks "gnus" nil nil 'macro)
  35   (autoload 'gnus-info-method "gnus" nil nil 'macro)
  36   (autoload 'gnus-info-score "gnus" nil nil 'macro))
  37
  38 (require 'text-props)
  39 (defvar menu-bar-mode (featurep 'menubar))
  40 (require 'messagexmas)
  41 (require 'wid-edit)
  42
  43 (defgroup gnus-xmas nil
  44   "XEmacsoid support for Gnus"
  45   :group 'gnus)
  46
  47 (defcustom gnus-xmas-glyph-directory nil
  48   "Directory where Gnus logos and icons are located.
  49 If this variable is nil, Gnus will try to locate the directory
  50 automatically."
  51   :type '(choice (const :tag "autodetect" nil)
  52                  directory)
  53   :group 'gnus-xmas)
  54
  55 (unless gnus-xmas-glyph-directory
  56   (unless (setq gnus-xmas-glyph-directory
  57                 (message-xmas-find-glyph-directory "gnus"))
  58     (error "Can't find glyph directory. \
  59 Possibly the `etc' directory has not been installed.")))
  60
  61 ;;; Internal variables.
  62
  63 ;; Don't warn about these undefined variables.
  64
  65 ;;defined in gnus.el
  66 (defvar gnus-active-hashtb)
  67 (defvar gnus-article-buffer)
  68 (defvar gnus-auto-center-summary)
  69 (defvar gnus-current-headers)
  70 (defvar gnus-level-killed)
  71 (defvar gnus-level-zombie)
  72 (defvar gnus-newsgroup-bookmarks)
  73 (defvar gnus-newsgroup-dependencies)
  74 (defvar gnus-newsgroup-selected-overlay)
  75 (defvar gnus-newsrc-hashtb)
  76 (defvar gnus-read-mark)
  77 (defvar gnus-refer-article-method)
  78 (defvar gnus-reffed-article-number)
  79 (defvar gnus-unread-mark)
  80 (defvar gnus-version)
  81 (defvar gnus-view-pseudos)
  82 (defvar gnus-view-pseudos-separately)
  83 (defvar gnus-visual)
  84 (defvar gnus-zombie-list)
  85 ;;defined in gnus-msg.el
  86 (defvar gnus-article-copy)
  87 (defvar gnus-check-before-posting)
  88 ;;defined in gnus-vis.el
  89 (defvar gnus-article-button-face)
  90 (defvar gnus-article-mouse-face)
  91 (defvar gnus-summary-selected-face)
  92 (defvar gnus-group-reading-menu)
  93 (defvar gnus-group-group-menu)
  94 (defvar gnus-group-misc-menu)
  95 (defvar gnus-summary-article-menu)
  96 (defvar gnus-summary-thread-menu)
  97 (defvar gnus-summary-misc-menu)
  98 (defvar gnus-summary-post-menu)
  99 (defvar gnus-summary-kill-menu)
 100 (defvar gnus-article-article-menu)
 101 (defvar gnus-article-treatment-menu)
 102 (defvar gnus-mouse-2)
 103 (defvar standard-display-table)
 104 (defvar gnus-tree-minimize-window)
 105 ;;`gnus-agent-mode' in gnus-agent.el will define it.
 106 (defvar gnus-agent-summary-mode)
 107
 108 (defun gnus-xmas-highlight-selected-summary ()
 109   ;; Highlight selected article in summary buffer
 110   (when gnus-summary-selected-face
 111     (when gnus-newsgroup-selected-overlay
 112       (delete-extent gnus-newsgroup-selected-overlay))
 113     (setq gnus-newsgroup-selected-overlay
 114           (make-extent (point-at-bol) (point-at-eol)))
 115     (set-extent-face gnus-newsgroup-selected-overlay
 116                      gnus-summary-selected-face)))
 117
 118 (defcustom gnus-xmas-force-redisplay nil
 119   "*If non-nil, force a redisplay before recentering the summary buffer.
 120 This is ugly, but it works around a bug in `window-displayed-height'."
 121   :type 'boolean
 122   :group 'gnus-xmas)
 123
 124 (defun gnus-xmas-switch-horizontal-scrollbar-off ()
 125   (when (featurep 'scrollbar)
 126     (set-specifier scrollbar-height (cons (current-buffer) 0))))
 127
 128 (defun gnus-xmas-summary-recenter ()
 129   "\"Center\" point in the summary window.
 130 If `gnus-auto-center-summary' is nil, or the article buffer isn't
 131 displayed, no centering will be performed."
 132   ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
 133   ;; Recenter only when requested.  Suggested by popovich@park.cs.columbia.edu.
 134   ;; Force redisplay to get properly computed window height.
 135   (when gnus-xmas-force-redisplay
 136     (sit-for 0))
 137   (when gnus-auto-center-summary
 138     (let* ((height (if (fboundp 'window-displayed-height)
 139                        (window-displayed-height)
 140                      (- (window-height) 2)))
 141            (top (cond ((< height 4) 0)
 142                       ((< height 7) 1)
 143                       (t (if (numberp gnus-auto-center-summary)
 144                              gnus-auto-center-summary
 145                            2))))
 146            (bottom (save-excursion (goto-char (point-max))
 147                                    (forward-line (- height))
 148                                    (point)))
 149            (window (get-buffer-window (current-buffer))))
 150       (when (get-buffer-window gnus-article-buffer)
 151         ;; Only do recentering when the article buffer is displayed,
 152         ;; Set the window start to either `bottom', which is the biggest
 153         ;; possible valid number, or the second line from the top,
 154         ;; whichever is the least.
 155         ;; NOFORCE parameter suggested by Daniel Pittman <daniel@danann.net>.
 156         (set-window-start
 157          window (min bottom (save-excursion (forward-line (- top)) (point)))
 158          t))
 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-summary-set-display-table ()
 169   ;; Setup the display table -- like `gnus-summary-setup-display-table',
 170   ;; but done in an XEmacsish way.
 171   (let ((table (make-display-table))
 172         (i 32))
 173     ;; Nix out all the control chars...
 174     (while (>= (setq i (1- i)) 0)
 175       (aset table i [??]))
 176     ;; ... but not newline and cr, of course.  (cr is necessary for the
 177     ;; selective display).
 178     (aset table ?\n nil)
 179     (aset table ?\r nil)
 180     ;; We keep TAB as well.
 181     (aset table ?\t nil)
 182     ;; We nix out any glyphs over 126 below ctl-arrow.
 183     (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
 184       (while (>= (setq i (1- i)) 127)
 185         (unless (aref table i)
 186           (aset table i [??]))))
 187     ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
 188     (add-spec-to-specifier current-display-table table (current-buffer) nil)))
 189
 190 (defun gnus-xmas-add-text-properties (start end props &optional object)
 191   (add-text-properties start end props object)
 192   (put-text-property start end 'start-closed nil object))
 193
 194 (defun gnus-xmas-put-text-property (start end prop value &optional object)
 195   (put-text-property start end prop value object)
 196   (put-text-property start end 'start-closed nil object))
 197
 198 (defun gnus-xmas-extent-start-open (point)
 199   (map-extents (lambda (extent arg)
 200                  (set-extent-property extent 'start-open t))
 201                nil point (min (1+ (point)) (point-max))))
 202
 203 (defun gnus-xmas-article-push-button (event)
 204   "Check text under the mouse pointer for a callback function.
 205 If the text under the mouse pointer has a `gnus-callback' property,
 206 call it with the value of the `gnus-data' text property."
 207   (interactive "e")
 208   (set-buffer (window-buffer (event-window event)))
 209   (let* ((pos (event-closest-point event))
 210          (data (get-text-property pos 'gnus-data))
 211          (fun (get-text-property pos 'gnus-callback)))
 212     (goto-char pos)
 213     (when fun
 214       (funcall fun data))))
 215
 216 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
 217   (set-extent-endpoints extent start end buffer))
 218
 219 (defun gnus-xmas-kill-all-overlays ()
 220   "Delete all extents in the current buffer."
 221   (map-extents (lambda (extent ignore)
 222                  (delete-extent extent)
 223                  nil)))
 224
 225 (defun gnus-xmas-window-top-edge (&optional window)
 226   (nth 1 (window-pixel-edges window)))
 227
 228 (defun gnus-xmas-tree-minimize ()
 229   (when (and gnus-tree-minimize-window
 230              (not (one-window-p)))
 231     (let* ((window-min-height 2)
 232            (height (1+ (count-lines (point-min) (point-max))))
 233            (min (max (1- window-min-height) height))
 234            (tot (if (numberp gnus-tree-minimize-window)
 235                     (min gnus-tree-minimize-window min)
 236                   min))
 237            (win (get-buffer-window (current-buffer)))
 238            (wh (and win (1- (window-height win)))))
 239       (when (and win
 240                  (not (eq tot wh)))
 241         (let ((selected (selected-window)))
 242           (select-window win)
 243           (enlarge-window (- tot wh))
 244           (select-window selected))))))
 245
 246 ;; Select the lowest window on the frame.
 247 (defun gnus-xmas-select-lowest-window ()
 248   (let* ((lowest-window (selected-window))
 249          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 250          (last-window (previous-window))
 251          (window-search t))
 252     (while window-search
 253       (let* ((this-window (next-window))
 254              (next-bottom-edge (car (cdr (cdr (cdr
 255                                                (window-pixel-edges
 256                                                 this-window)))))))
 257         (when (< bottom-edge next-bottom-edge)
 258           (setq bottom-edge next-bottom-edge)
 259           (setq lowest-window this-window))
 260
 261         (select-window this-window)
 262         (when (eq last-window this-window)
 263           (select-window lowest-window)
 264           (setq window-search nil))))))
 265
 266 (defmacro gnus-xmas-menu-add (type &rest menus)
 267   `(gnus-xmas-menu-add-1 ',type ',menus))
 268 (put 'gnus-xmas-menu-add 'lisp-indent-function 1)
 269
 270 (defun gnus-xmas-menu-add-1 (type menus)
 271   (when (and menu-bar-mode
 272              (gnus-visual-p (intern (format "%s-menu" type)) 'menu))
 273     (while menus
 274       (easy-menu-add (symbol-value (pop menus))))))
 275
 276 (defun gnus-xmas-group-menu-add ()
 277   (gnus-xmas-menu-add group
 278     gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu))
 279
 280 (defun gnus-xmas-summary-menu-add ()
 281   (gnus-xmas-menu-add summary
 282     gnus-summary-misc-menu gnus-summary-kill-menu
 283     gnus-summary-article-menu gnus-summary-thread-menu
 284     gnus-summary-post-menu ))
 285
 286 (defun gnus-xmas-article-menu-add ()
 287   (gnus-xmas-menu-add article
 288     gnus-article-article-menu gnus-article-treatment-menu
 289     gnus-article-post-menu gnus-article-commands-menu))
 290
 291 (defun gnus-xmas-score-menu-add ()
 292   (gnus-xmas-menu-add score
 293     gnus-score-menu))
 294
 295 (defun gnus-xmas-pick-menu-add ()
 296   (gnus-xmas-menu-add pick
 297     gnus-pick-menu))
 298
 299 (defun gnus-xmas-topic-menu-add ()
 300   (gnus-xmas-menu-add topic
 301     gnus-topic-menu))
 302
 303 (defun gnus-xmas-binary-menu-add ()
 304   (gnus-xmas-menu-add binary
 305     gnus-binary-menu))
 306
 307 (defun gnus-xmas-agent-summary-menu-add ()
 308   (gnus-xmas-menu-add agent-summary
 309     gnus-agent-summary-menu))
 310
 311 (defun gnus-xmas-agent-group-menu-add ()
 312   (gnus-xmas-menu-add agent-group
 313     gnus-agent-group-menu))
 314
 315 (defun gnus-xmas-agent-server-menu-add ()
 316   (gnus-xmas-menu-add agent-server
 317     gnus-agent-server-menu))
 318
 319 (defun gnus-xmas-tree-menu-add ()
 320   (gnus-xmas-menu-add tree
 321     gnus-tree-menu))
 322
 323 (defun gnus-xmas-draft-menu-add ()
 324   (gnus-xmas-menu-add draft
 325     gnus-draft-menu))
 326
 327 (defun gnus-xmas-server-menu-add ()
 328   (gnus-xmas-menu-add menu
 329     gnus-server-server-menu gnus-server-connections-menu))
 330
 331 (defun gnus-xmas-browse-menu-add ()
 332   (gnus-xmas-menu-add browse
 333     gnus-browse-menu))
 334
 335 (defun gnus-xmas-read-event-char (&optional prompt)
 336   "Get the next event."
 337   (when prompt
 338     (message "%s" prompt))
 339   (let ((event (next-command-event)))
 340     (sit-for 0)
 341     ;; We junk all non-key events.  Is this naughty?
 342     (while (not (or (key-press-event-p event)
 343                     (button-press-event-p event)))
 344       (dispatch-event event)
 345       (setq event (next-command-event)))
 346     (cons (and (key-press-event-p event)
 347                (event-to-character event))
 348           event)))
 349
 350 (defun gnus-xmas-article-describe-bindings (&optional prefix)
 351   "Show a list of all defined keys, and their definitions.
 352 The optional argument PREFIX, if non-nil, should be a key sequence;
 353 then we display only bindings that start with that prefix."
 354   (interactive)
 355   (gnus-article-check-buffer)
 356   (let ((keymap (copy-keymap gnus-article-mode-map))
 357         (map (copy-keymap gnus-article-send-map))
 358         (sumkeys (where-is-internal 'gnus-article-read-summary-keys))
 359         agent)
 360     (define-key keymap "S" map)
 361     (set-keymap-default-binding map nil)
 362     (with-current-buffer gnus-article-current-summary
 363       (let ((def (key-binding "S"))
 364             gnus-pick-mode)
 365         (set-keymap-parent map (if (symbolp def)
 366                                    (symbol-value def)
 367                                  def))
 368         (dolist (key sumkeys)
 369           (when (setq def (key-binding key))
 370             (define-key keymap key def))))
 371       (when (boundp 'gnus-agent-summary-mode)
 372         (setq agent gnus-agent-summary-mode)))
 373     (with-temp-buffer
 374       (setq major-mode 'gnus-article-mode)
 375       (use-local-map keymap)
 376       (set (make-local-variable 'gnus-agent-summary-mode) agent)
 377       (describe-bindings prefix))))
 378
 379 (defun gnus-xmas-define ()
 380   (setq gnus-mouse-2 [button2])
 381   (setq gnus-mouse-3 [button3])
 382   (setq gnus-widget-button-keymap widget-button-keymap)
 383
 384   (unless (memq 'underline (face-list))
 385     (and (fboundp 'make-face)
 386          (funcall (intern "make-face") 'underline)))
 387   ;; Must avoid calling set-face-underline-p directly, because it
 388   ;; is a defsubst in emacs19, and will make the .elc files non
 389   ;; portable!
 390   (unless (face-differs-from-default-p 'underline)
 391     (funcall (intern "set-face-underline-p") 'underline t))
 392
 393   (cond
 394    ((fboundp 'char-or-char-int-p)
 395     ;; Handle both types of marks for XEmacs-20.x.
 396     (defalias 'gnus-characterp 'char-or-char-int-p))
 397    ;; V19 of XEmacs, probably.
 398    (t
 399     (defalias 'gnus-characterp 'characterp)))
 400
 401   (defalias 'gnus-make-overlay
 402     (lambda (beg end &optional buffer front-advance rear-advance)
 403       "Create a new overlay with range BEG to END in BUFFER.
 404 FRONT-ADVANCE and REAR-ADVANCE are ignored."
 405       (make-extent beg end buffer)))
 406
 407   (defalias 'gnus-delete-overlay 'delete-extent)
 408   (defalias 'gnus-overlay-put 'set-extent-property)
 409   (defalias 'gnus-move-overlay 'gnus-xmas-move-overlay)
 410   (defalias 'gnus-overlay-buffer 'extent-object)
 411   (defalias 'gnus-overlay-start 'extent-start-position)
 412   (defalias 'gnus-overlay-end 'extent-end-position)
 413   (defalias 'gnus-kill-all-overlays 'gnus-xmas-kill-all-overlays)
 414   (defalias 'gnus-extent-detached-p 'extent-detached-p)
 415   (defalias 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
 416   (defalias 'gnus-put-text-property 'gnus-xmas-put-text-property)
 417   (defalias 'gnus-deactivate-mark 'ignore)
 418   (defalias 'gnus-window-edges 'window-pixel-edges)
 419   (defalias 'gnus-assq-delete-all 'gnus-xmas-assq-delete-all)
 420
 421   (unless (boundp 'standard-display-table)
 422     (setq standard-display-table nil))
 423
 424   (defvar gnus-mouse-face-prop 'highlight)
 425
 426   (defun gnus-byte-code (func)
 427     "Return a form that can be `eval'ed based on FUNC."
 428     (let ((fval (indirect-function func)))
 429       (if (compiled-function-p fval)
 430           (list 'funcall fval)
 431         (cons 'progn (cdr (cdr fval))))))
 432
 433   (unless (fboundp 'match-string-no-properties)
 434     (defalias 'match-string-no-properties 'match-string))
 435
 436   (defalias 'gnus-x-color-values
 437         (if (fboundp 'x-color-values)
 438             'x-color-values
 439           (lambda (color)
 440             (color-instance-rgb-components
 441              (make-color-instance color)))))
 442
 443   (unless (fboundp 'char-width)
 444     (defalias 'char-width (lambda (ch) 1))))
 445
 446 (defun gnus-xmas-redefine ()
 447   "Redefine lots of Gnus functions for XEmacs."
 448   (defalias 'gnus-summary-set-display-table 'gnus-xmas-summary-set-display-table)
 449   (defalias 'gnus-visual-turn-off-edit-menu 'identity)
 450   (defalias 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
 451   (defalias 'gnus-extent-start-open 'gnus-xmas-extent-start-open)
 452   (defalias 'gnus-article-push-button 'gnus-xmas-article-push-button)
 453   (defalias 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
 454   (defalias 'gnus-read-event-char 'gnus-xmas-read-event-char)
 455   (defalias 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
 456   (defalias 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
 457   (defalias 'gnus-select-lowest-window
 458     'gnus-xmas-select-lowest-window)
 459   (defalias 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
 460   (defalias 'gnus-character-to-event 'character-to-event)
 461   (defalias 'gnus-mode-line-buffer-identification
 462     'gnus-xmas-mode-line-buffer-identification)
 463   (defalias 'gnus-key-press-event-p 'key-press-event-p)
 464   (defalias 'gnus-region-active-p 'region-active-p)
 465   (defalias 'gnus-mark-active-p 'region-exists-p)
 466   (defalias 'gnus-annotation-in-region-p 'gnus-xmas-annotation-in-region-p)
 467   (defalias 'gnus-mime-button-menu 'gnus-xmas-mime-button-menu)
 468   (defalias 'gnus-mime-security-button-menu
 469     'gnus-xmas-mime-security-button-menu)
 470   (defalias 'gnus-image-type-available-p 'gnus-xmas-image-type-available-p)
 471   (defalias 'gnus-put-image 'gnus-xmas-put-image)
 472   (defalias 'gnus-create-image 'gnus-xmas-create-image)
 473   (defalias 'gnus-remove-image 'gnus-xmas-remove-image)
 474   (defalias 'gnus-article-describe-bindings
 475     'gnus-xmas-article-describe-bindings)
 476
 477   ;; These ones are not defcutom'ed, sometimes not even defvar'ed. They
 478   ;; probably should. If that is done, the code below should then be moved
 479   ;; where each variable is defined, in order not to mess with user settings.
 480   ;; -- didier
 481   (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add)
 482   (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
 483   (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add)
 484   (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add)
 485   (add-hook 'gnus-draft-mode-hook 'gnus-xmas-draft-menu-add)
 486   (add-hook 'gnus-mailing-list-mode-hook 'gnus-xmas-mailing-list-menu-add))
 487
 488
 489 ;;; XEmacs logo and toolbar.
 490
 491 (defun gnus-xmas-group-startup-message (&optional x y)
 492   "Insert startup message in current buffer."
 493   ;; Insert the message.
 494   (erase-buffer)
 495   (cond
 496    ((and (console-on-window-system-p)
 497          (or (featurep 'xpm)
 498              (featurep 'xbm)))
 499     (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory))
 500            (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory))
 501            (glyph (make-glyph
 502                    (cond ((featurep 'xpm)
 503                           `[xpm
 504                             :file ,logo-xpm
 505                             :color-symbols
 506                             (("thing" . ,(car gnus-logo-colors))
 507                              ("shadow" . ,(cadr gnus-logo-colors))
 508                              ("oort" . "#eeeeee")
 509                              ("background" . ,(face-background 'default)))])
 510                          ((featurep 'xbm)
 511                           `[xbm :file ,logo-xbm])
 512                          (t [nothing])))))
 513       (insert " ")
 514       (set-extent-begin-glyph (make-extent (point) (point)) glyph)
 515       (goto-char (point-min))
 516       (while (not (eobp))
 517         (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
 518                              ?\ ))
 519         (forward-line 1))
 520       (setq gnus-simple-splash nil))
 521     (goto-char (point-min))
 522     (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
 523            (wheight (window-height))
 524            (rest (- wheight pheight)))
 525       (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
 526    (t
 527     (insert
 528      (format "              %s
 529           _    ___ _             _
 530           _ ___ __ ___  __    _ ___
 531           __   _     ___    __  ___
 532               _           ___     _
 533              _  _ __             _
 534              ___   __            _
 535                    __           _
 536                     _      _   _
 537                    _      _    _
 538                       _  _    _
 539                   __  ___
 540                  _   _ _     _
 541                 _   _
 542               _    _
 543              _    _
 544             _
 545           __
 546
 547 "
 548              ""))
 549     ;; And then hack it.
 550     (gnus-indent-rigidly (point-min) (point-max)
 551                          (/ (max (- (window-width) (or x 46)) 0) 2))
 552     (goto-char (point-min))
 553     (forward-line 1)
 554     (let* ((pheight (count-lines (point-min) (point-max)))
 555            (wheight (window-height))
 556            (rest (- wheight pheight)))
 557       (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
 558     ;; Paint it.
 559     (put-text-property (point-min) (point-max) 'face 'gnus-splash)))
 560   (setq modeline-buffer-identification
 561         (list (concat gnus-version ": *Group*")))
 562   (set-buffer-modified-p t))
 563
 564
 565 ;;; The toolbar.
 566
 567 (defun gnus-xmas-update-toolbars ()
 568   "Update the toolbars' appearance."
 569   (when (and (not noninteractive)
 570              (featurep 'gnus-xmas))
 571     (save-excursion
 572       (dolist (buffer (buffer-list))
 573         (set-buffer buffer)
 574         (cond ((eq major-mode 'gnus-group-mode)
 575                (gnus-xmas-setup-group-toolbar))
 576               ((eq major-mode 'gnus-summary-mode)
 577                (gnus-xmas-setup-summary-toolbar)))))))
 578
 579 (defcustom gnus-use-toolbar (if (featurep 'toolbar) 'default)
 580   "*Position to display the toolbar.  Nil means do not use a toolbar.
 581 If it is non-nil, it should be one of the symbols `default', `top',
 582 `bottom', `right', and `left'.  `default' means to use the default
 583 toolbar, the rest mean to display the toolbar on the place which those
 584 names show."
 585   :type '(choice (const default)
 586                  (const top) (const bottom) (const left) (const right)
 587                  (const :tag "no toolbar" nil))
 588   :set (lambda (symbol value)
 589          (set-default
 590           symbol
 591           (if (or (not value)
 592                   (memq value (list 'default 'top 'bottom 'right 'left)))
 593               value
 594             'default))
 595          (gnus-xmas-update-toolbars))
 596   :group 'gnus-xmas)
 597
 598 (defcustom gnus-toolbar-thickness
 599   (if (featurep 'toolbar)
 600       (cons (specifier-instance default-toolbar-height)
 601             (specifier-instance default-toolbar-width)))
 602   "*Cons of the height and the width specifying the thickness of a toolbar.
 603 The height is used for the toolbar displayed on the top or the bottom,
 604 the width is used for the toolbar displayed on the right or the left."
 605   :type '(cons :tag "height & width"
 606                (integer :tag "height") (integer :tag "width"))
 607   :set (lambda (symbol value)
 608          (set-default
 609           symbol
 610           (if (and (consp value) (natnump (car value)) (natnump (cdr value)))
 611               value
 612             '(37 . 40)))
 613          (gnus-xmas-update-toolbars))
 614   :group 'gnus-xmas)
 615
 616 (defvar gnus-group-toolbar
 617   '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
 618     [gnus-group-get-new-news-this-group
 619      gnus-group-get-new-news-this-group t "Get new news in this group"]
 620     [gnus-group-catchup-current
 621      gnus-group-catchup-current t "Catchup group"]
 622     [gnus-group-describe-group
 623      gnus-group-describe-group t "Describe group"]
 624     [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
 625     [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]
 626     [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
 627     [gnus-summary-mail-save
 628      gnus-group-save-newsrc t "Save .newsrc files"] ; borrowed icon.
 629     [gnus-group-exit gnus-group-exit t "Exit Gnus"])
 630   "The group buffer toolbar.")
 631
 632 (defvar gnus-summary-toolbar
 633   '([gnus-summary-prev-unread
 634      gnus-summary-prev-page-or-article t "Page up"]
 635     [gnus-summary-next-unread
 636      gnus-summary-next-page t "Page down"]
 637     [gnus-summary-post-news
 638      gnus-summary-post-news t "Post an article"]
 639     [gnus-summary-followup-with-original
 640      gnus-summary-followup-with-original t
 641      "Post a followup and yank the original"]
 642     [gnus-summary-followup
 643      gnus-summary-followup t "Post a followup"]
 644     [gnus-summary-reply-with-original
 645      gnus-summary-reply-with-original t "Mail a reply and yank the original"]
 646     [gnus-summary-reply
 647      gnus-summary-reply t "Mail a reply"]
 648     [gnus-summary-caesar-message
 649      gnus-summary-caesar-message t "Rot 13"]
 650     [gnus-uu-decode-uu
 651      gnus-uu-decode-uu t "Decode uuencoded articles"]
 652     [gnus-summary-save-article-file
 653      gnus-summary-save-article-file t "Save article in file"]
 654     [gnus-summary-save-article
 655      gnus-summary-save-article t "Save article"]
 656     [gnus-uu-post-news
 657      gnus-uu-post-news t "Post a uuencoded article"]
 658     [gnus-summary-cancel-article
 659      gnus-summary-cancel-article t "Cancel article"]
 660     [gnus-summary-catchup
 661      gnus-summary-catchup t "Catchup"]
 662     [gnus-summary-catchup-and-exit
 663      gnus-summary-catchup-and-exit t "Catchup and exit"]
 664     [gnus-summary-exit gnus-summary-exit t "Exit this summary"])
 665   "The summary buffer toolbar.")
 666
 667 (defvar gnus-summary-mail-toolbar
 668   '(
 669     [gnus-summary-prev-unread
 670      gnus-summary-prev-unread-article t "Prev unread article"]
 671     [gnus-summary-next-unread
 672      gnus-summary-next-unread-article t "Next unread article"]
 673     [gnus-summary-mail-reply gnus-summary-reply t "Reply"]
 674     [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
 675     [gnus-summary-mail-save gnus-summary-save-article t "Save"]
 676     [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
 677     [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
 678     [gnus-summary-caesar-message
 679      gnus-summary-caesar-message t "Rot 13"]
 680     [gnus-uu-decode-uu
 681      gnus-uu-decode-uu t "Decode uuencoded articles"]
 682     [gnus-summary-save-article-file
 683      gnus-summary-save-article-file t "Save article in file"]
 684     [gnus-summary-save-article
 685      gnus-summary-save-article t "Save article"]
 686     [gnus-summary-cancel-article ; usenet : cancellation :: mail : deletion.
 687      gnus-summary-delete-article t "Delete message"]
 688     [gnus-summary-catchup
 689      gnus-summary-catchup t "Catchup"]
 690     [gnus-summary-catchup-and-exit
 691      gnus-summary-catchup-and-exit t "Catchup and exit"]
 692     [gnus-summary-exit gnus-summary-exit t "Exit this summary"])
 693   "The summary buffer mail toolbar.")
 694
 695 (defun gnus-xmas-setup-toolbar (toolbar)
 696   (when (featurep 'toolbar)
 697     (if (and gnus-use-toolbar
 698              (message-xmas-setup-toolbar toolbar nil "gnus"))
 699         (let ((bar (or (intern-soft (format "%s-toolbar" gnus-use-toolbar))
 700                        'default-toolbar))
 701               (height (car gnus-toolbar-thickness))
 702               (width (cdr gnus-toolbar-thickness))
 703               (cur (current-buffer))
 704               bars)
 705           (set-specifier (symbol-value bar) toolbar cur)
 706           (set-specifier default-toolbar-height height cur)
 707           (set-specifier default-toolbar-width width cur)
 708           (set-specifier top-toolbar-height height cur)
 709           (set-specifier bottom-toolbar-height height cur)
 710           (set-specifier right-toolbar-width width cur)
 711           (set-specifier left-toolbar-width width cur)
 712           (if (eq bar 'default-toolbar)
 713               (progn
 714                 (remove-specifier default-toolbar-visible-p cur)
 715                 (remove-specifier top-toolbar cur)
 716                 (remove-specifier top-toolbar-visible-p cur)
 717                 (remove-specifier bottom-toolbar cur)
 718                 (remove-specifier bottom-toolbar-visible-p cur)
 719                 (remove-specifier right-toolbar cur)
 720                 (remove-specifier right-toolbar-visible-p cur)
 721                 (remove-specifier left-toolbar cur)
 722                 (remove-specifier left-toolbar-visible-p cur))
 723             (set-specifier (symbol-value (intern (format "%s-visible-p" bar)))
 724                            t cur)
 725             (setq bars (delq bar (list 'default-toolbar
 726                                        'bottom-toolbar 'top-toolbar
 727                                        'right-toolbar 'left-toolbar)))
 728             (while bars
 729               (set-specifier (symbol-value (intern (format "%s-visible-p"
 730                                                            (pop bars))))
 731                              nil cur))))
 732       (let ((cur (current-buffer)))
 733         (set-specifier default-toolbar-visible-p nil cur)
 734         (set-specifier top-toolbar-visible-p nil cur)
 735         (set-specifier bottom-toolbar-visible-p nil cur)
 736         (set-specifier right-toolbar-visible-p nil cur)
 737         (set-specifier left-toolbar-visible-p nil cur)))))
 738
 739 (defun gnus-xmas-setup-group-toolbar ()
 740   (gnus-xmas-setup-toolbar gnus-group-toolbar))
 741
 742 (defun gnus-xmas-setup-summary-toolbar ()
 743   (gnus-xmas-setup-toolbar (if (gnus-news-group-p gnus-newsgroup-name)
 744                                gnus-summary-toolbar
 745                              gnus-summary-mail-toolbar)))
 746
 747 (defun gnus-xmas-mail-strip-quoted-names (address)
 748   "Protect mail-strip-quoted-names from nil input.
 749 XEmacs compatibility workaround."
 750   (if (null address)
 751       nil
 752     (mail-strip-quoted-names address)))
 753
 754 (defun gnus-xmas-call-region (command &rest args)
 755   (apply
 756    'call-process-region (point-min) (point-max) command t '(t nil) nil
 757    args))
 758
 759 (defvar gnus-xmas-modeline-left-extent
 760   (let ((ext (copy-extent modeline-buffer-id-left-extent)))
 761     ext))
 762
 763 (defvar gnus-xmas-modeline-right-extent
 764   (let ((ext (copy-extent modeline-buffer-id-right-extent)))
 765     ext))
 766
 767 (defvar gnus-xmas-modeline-glyph
 768   (progn
 769     (let* ((file-xpm (expand-file-name "gnus-pointer.xpm"
 770                                        gnus-xmas-glyph-directory))
 771            (file-xbm (expand-file-name "gnus-pointer.xbm"
 772                                        gnus-xmas-glyph-directory))
 773            (glyph (make-glyph
 774                    ;; Gag gag gag.
 775                    (cond ((featurep 'xpm)
 776                           ;; Let's try a nifty XPM
 777                           `[xpm :file ,file-xpm])
 778                          ((featurep 'xbm)
 779                           ;; Then a not-so-nifty XBM
 780                           `[xbm :file ,file-xbm])
 781                          ;; Then the simple string
 782                          (t [string :data "Gnus:"])))))
 783       (set-glyph-face glyph 'modeline-buffer-id)
 784       glyph)))
 785
 786 (defun gnus-xmas-mode-line-buffer-identification (line)
 787   (let ((line (car line))
 788         chop)
 789     (cond
 790      ;; This is some weird type of id.
 791      ((not (stringp line))
 792       (list line))
 793      ;; This is non-standard, so we just pass it through.
 794      ((not (string-match "^Gnus:" line))
 795       (list line))
 796      ;; We have a standard line, so we colorize and glyphize it a bit.
 797      (t
 798       (setq chop (match-end 0))
 799       (list
 800        (if gnus-xmas-modeline-glyph
 801            (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
 802          (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
 803        (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
 804
 805 (defun gnus-xmas-splash ()
 806   (when (eq (device-type) 'x)
 807     (gnus-splash)))
 808
 809 (defun gnus-xmas-annotation-in-region-p (b e)
 810   (or (map-extents (lambda (e u) t) nil b e nil nil 'mm t)
 811       (if (= b e)
 812           (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
 813         (text-property-any b e 'gnus-undeletable t))))
 814
 815 (defun gnus-xmas-mime-button-menu (event prefix)
 816   "Construct a context-sensitive menu of MIME commands."
 817   (interactive "e\nP")
 818   (let ((response (get-popup-menu-response
 819                    `("MIME Part"
 820                      ,@(mapcar (lambda (c) `[,(caddr c) ,(car c) t])
 821                                gnus-mime-button-commands)))))
 822     (set-buffer (event-buffer event))
 823     (goto-char (event-point event))
 824     (funcall (event-function response) (event-object response))))
 825
 826 (defun gnus-xmas-mime-security-button-menu (event prefix)
 827   "Construct a context-sensitive menu of security commands."
 828   (interactive "e\nP")
 829   (let ((response
 830          (get-popup-menu-response
 831           `("Security Part"
 832             ,@(delq nil
 833                     (mapcar (lambda (c)
 834                               (unless (eq (car c) 'undefined)
 835                                 `[,(caddr c) ,(car c) t]))
 836                             gnus-mime-security-button-commands))))))
 837     (set-buffer (event-buffer event))
 838     (goto-char (event-point event))
 839     (funcall (event-function response) (event-object response))))
 840
 841 (defun gnus-group-add-icon ()
 842   "Add an icon to the current line according to `gnus-group-icon-list'."
 843   (let* ((p (point))
 844          (end (point-at-eol))
 845          ;; now find out where the line starts and leave point there.
 846          (beg (progn (beginning-of-line) (point))))
 847     (save-restriction
 848       (narrow-to-region beg end)
 849       (goto-char beg)
 850       (when (search-forward "==&&==" nil t)
 851         (let* ((group (gnus-group-group-name))
 852                (entry (gnus-group-entry group))
 853                (unread (if (numberp (car entry)) (car entry) 0))
 854                (active (gnus-active group))
 855                (total (if active (1+ (- (cdr active) (car active))) 0))
 856                (info (nth 2 entry))
 857                (method (gnus-server-get-method group (gnus-info-method info)))
 858                (marked (gnus-info-marks info))
 859                (mailp (memq 'mail (assoc (symbol-name
 860                                           (car (or method gnus-select-method)))
 861                                          gnus-valid-select-methods)))
 862                (level (or (gnus-info-level info) gnus-level-killed))
 863                (score (or (gnus-info-score info) 0))
 864                (ticked (gnus-range-length (cdr (assq 'tick marked))))
 865                (group-age (gnus-group-timestamp-delta group))
 866                (inhibit-read-only t)
 867                (list gnus-group-icon-list)
 868                (mystart (match-beginning 0))
 869                (myend (match-end 0)))
 870           (goto-char (point-min))
 871           (while (and list
 872                       (not (eval (caar list))))
 873             (setq list (cdr list)))
 874           (if list
 875               (let* ((file (cdar list))
 876                      (glyph (gnus-group-icon-create-glyph
 877                              (buffer-substring mystart myend)
 878                              file)))
 879                 (if glyph
 880                     (progn
 881                       (mapc 'delete-annotation (annotations-at myend))
 882                       (let ((ext (make-extent mystart myend))
 883                             (ant (make-annotation glyph myend 'text)))
 884                         ;; set text extent params
 885                         (set-extent-property ext 'end-open t)
 886                         (set-extent-property ext 'start-open t)
 887                         (set-extent-property ext 'invisible t)))
 888                   (delete-region mystart myend)))
 889             (delete-region mystart myend))))
 890       (widen))
 891     (goto-char p)))
 892
 893 (defun gnus-group-icon-create-glyph (substring pixmap)
 894   "Create a glyph for insertion into a group line."
 895   (or
 896    (cdr-safe (assoc pixmap gnus-group-icon-cache))
 897    (let* ((glyph (make-glyph
 898                   (list
 899                    (cons 'x
 900                          (expand-file-name pixmap gnus-xmas-glyph-directory))
 901                    (cons 'mswindows
 902                          (expand-file-name pixmap gnus-xmas-glyph-directory))
 903                    (cons 'tty substring)))))
 904      (setq gnus-group-icon-cache
 905            (cons (cons pixmap glyph) gnus-group-icon-cache))
 906      (set-glyph-face glyph 'default)
 907      glyph)))
 908
 909 (defun gnus-xmas-mailing-list-menu-add ()
 910   (gnus-xmas-menu-add mailing-list
 911                       gnus-mailing-list-menu))
 912
 913 (defun gnus-xmas-image-type-available-p (type)
 914   (and (if (fboundp 'display-images-p)
 915            (display-images-p)
 916          window-system)
 917        (featurep (if (eq type 'pbm) 'xbm type))))
 918
 919 (defun gnus-xmas-create-image (file &optional type data-p &rest props)
 920   (let ((type (if type
 921                   (symbol-name type)
 922                 (car (last (split-string file "[.]")))))
 923         (face (plist-get props :face))
 924         glyph)
 925     (when (equal type "pbm")
 926       (with-temp-buffer
 927         (if data-p
 928             (insert file)
 929           (insert-file-contents-literally file))
 930         (shell-command-on-region (point-min) (point-max)
 931                                  "ppmtoxpm 2>/dev/null" t)
 932         (setq file (buffer-string)
 933               type "xpm"
 934               data-p t)))
 935     (setq glyph
 936           (if (equal type "xbm")
 937               (make-glyph (list (cons 'x file)))
 938             (with-temp-buffer
 939               (if data-p
 940                   (insert file)
 941                 (insert-file-contents-literally file))
 942               (make-glyph
 943                (vector
 944                 (or (intern type)
 945                     (mm-image-type-from-buffer))
 946                 :data (buffer-string))))))
 947     (when face
 948       (set-glyph-face glyph face))
 949     glyph))
 950
 951 (defun gnus-xmas-put-image (glyph &optional string category)
 952   "Insert STRING, but display GLYPH.
 953 Warning: Don't insert text immediately after the image."
 954   (let ((begin (point))
 955         extent)
 956     (if (and (bobp) (not string))
 957         (setq string " "))
 958     (if string
 959         (insert string)
 960       (setq begin (1- begin)))
 961     (setq extent (make-extent begin (point)))
 962     (set-extent-property extent 'gnus-image category)
 963     (set-extent-property extent 'duplicable t)
 964     (if string
 965         (set-extent-property extent 'invisible t))
 966     (set-extent-property extent 'end-glyph glyph))
 967   glyph)
 968
 969 (defun gnus-xmas-remove-image (image &optional category)
 970   "Remove the image matching IMAGE and CATEGORY found first."
 971   (map-extents
 972    (lambda (ext unused)
 973      (when (equal (extent-end-glyph ext) image)
 974        (set-extent-property ext 'invisible nil)
 975        (set-extent-property ext 'end-glyph nil)
 976        t))
 977    nil nil nil nil nil 'gnus-image category))
 978
 979 (defun gnus-xmas-assq-delete-all (key alist)
 980   (let ((elem nil))
 981     (while (setq elem (assq key alist))
 982       (setq alist (delq elem alist)))
 983     alist))
 984
 985 (provide 'gnus-xmas)
 986
 987 ;;; arch-tag: 4e84de3f-ea0a-4ee3-bfeb-e03d46fcacef
 988 ;;; gnus-xmas.el ends here