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

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