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   (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
 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-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
 481   (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add)
 482   (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add)
 483   (add-hook 'gnus-draft-mode-hook 'gnus-xmas-draft-menu-add)
 484   (add-hook 'gnus-mailing-list-mode-hook 'gnus-xmas-mailing-list-menu-add))
 485
 486
 487 ;;; XEmacs logo and toolbar.
 488
 489 (defun gnus-xmas-group-startup-message (&optional x y)
 490   "Insert startup message in current buffer."
 491   ;; Insert the message.
 492   (erase-buffer)
 493   (cond
 494    ((and (console-on-window-system-p)
 495          (or (featurep 'xpm)
 496              (featurep 'xbm)))
 497     (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory))
 498            (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory))
 499            (glyph (make-glyph
 500                    (cond ((featurep 'xpm)
 501                           `[xpm
 502                             :file ,logo-xpm
 503                             :color-symbols
 504                             (("thing" . ,(car gnus-xmas-logo-colors))
 505                              ("shadow" . ,(cadr gnus-xmas-logo-colors))
 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       (setq gnus-simple-splash nil))
 518     (goto-char (point-min))
 519     (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
 520            (wheight (window-height))
 521            (rest (- wheight pheight)))
 522       (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
 523    (t
 524     (insert
 525      (format "              %s
 526           _    ___ _             _
 527           _ ___ __ ___  __    _ ___
 528           __   _     ___    __  ___
 529               _           ___     _
 530              _  _ __             _
 531              ___   __            _
 532                    __           _
 533                     _      _   _
 534                    _      _    _
 535                       _  _    _
 536                   __  ___
 537                  _   _ _     _
 538                 _   _
 539               _    _
 540              _    _
 541             _
 542           __
 543
 544 "
 545              ""))
 546     ;; And then hack it.
 547     (gnus-indent-rigidly (point-min) (point-max)
 548                          (/ (max (- (window-width) (or x 46)) 0) 2))
 549     (goto-char (point-min))
 550     (forward-line 1)
 551     (let* ((pheight (count-lines (point-min) (point-max)))
 552            (wheight (window-height))
 553            (rest (- wheight pheight)))
 554       (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
 555     ;; Paint it.
 556     (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)))
 557   (setq modeline-buffer-identification
 558         (list (concat gnus-version ": *Group*")))
 559   (set-buffer-modified-p t))
 560
 561
 562 ;;; The toolbar.
 563
 564 (defcustom gnus-use-toolbar (if (featurep 'toolbar)
 565                                 'default-toolbar
 566                               nil)
 567   "*If nil, do not use a toolbar.
 568 If it is non-nil, it must be a toolbar.  The five valid values are
 569 `default-toolbar', `top-toolbar', `bottom-toolbar',
 570 `right-toolbar', and `left-toolbar'."
 571   :type '(choice (const default-toolbar)
 572                  (const top-toolbar) (const bottom-toolbar)
 573                  (const left-toolbar) (const right-toolbar)
 574                  (const :tag "no toolbar" nil))
 575   :group 'gnus-xmas)
 576
 577 (defvar gnus-group-toolbar
 578   '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
 579     [gnus-group-get-new-news-this-group
 580      gnus-group-get-new-news-this-group t "Get new news in this group"]
 581     [gnus-group-catchup-current
 582      gnus-group-catchup-current t "Catchup group"]
 583     [gnus-group-describe-group
 584      gnus-group-describe-group t "Describe group"]
 585     [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
 586     [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]
 587     [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
 588     [gnus-group-exit gnus-group-exit t "Exit Gnus"])
 589   "The group buffer toolbar.")
 590
 591 (defvar gnus-summary-toolbar
 592   '([gnus-summary-prev-unread
 593      gnus-summary-prev-page-or-article t "Page up"]
 594     [gnus-summary-next-unread
 595      gnus-summary-next-page t "Page down"]
 596     [gnus-summary-post-news
 597      gnus-summary-post-news t "Post an article"]
 598     [gnus-summary-followup-with-original
 599      gnus-summary-followup-with-original t
 600      "Post a followup and yank the original"]
 601     [gnus-summary-followup
 602      gnus-summary-followup t "Post a followup"]
 603     [gnus-summary-reply-with-original
 604      gnus-summary-reply-with-original t "Mail a reply and yank the original"]
 605     [gnus-summary-reply
 606      gnus-summary-reply t "Mail a reply"]
 607     [gnus-summary-caesar-message
 608      gnus-summary-caesar-message t "Rot 13"]
 609     [gnus-uu-decode-uu
 610      gnus-uu-decode-uu t "Decode uuencoded articles"]
 611     [gnus-summary-save-article-file
 612      gnus-summary-save-article-file t "Save article in file"]
 613     [gnus-summary-save-article
 614      gnus-summary-save-article t "Save article"]
 615     [gnus-uu-post-news
 616      gnus-uu-post-news t "Post a uuencoded article"]
 617     [gnus-summary-cancel-article
 618      gnus-summary-cancel-article t "Cancel article"]
 619     [gnus-summary-catchup
 620      gnus-summary-catchup t "Catchup"]
 621     [gnus-summary-catchup-and-exit
 622      gnus-summary-catchup-and-exit t "Catchup and exit"]
 623     [gnus-summary-exit gnus-summary-exit t "Exit this summary"])
 624   "The summary buffer toolbar.")
 625
 626 (defvar gnus-summary-mail-toolbar
 627   '(
 628     [gnus-summary-prev-unread
 629      gnus-summary-prev-unread-article t "Prev unread article"]
 630     [gnus-summary-next-unread
 631      gnus-summary-next-unread-article t "Next unread article"]
 632     [gnus-summary-mail-reply gnus-summary-reply t "Reply"]
 633     [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
 634     [gnus-summary-mail-save gnus-summary-save-article t "Save"]
 635     [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
 636     [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
 637     [gnus-summary-caesar-message
 638      gnus-summary-caesar-message t "Rot 13"]
 639     [gnus-uu-decode-uu
 640      gnus-uu-decode-uu t "Decode uuencoded articles"]
 641     [gnus-summary-save-article-file
 642      gnus-summary-save-article-file t "Save article in file"]
 643     [gnus-summary-save-article
 644      gnus-summary-save-article t "Save article"]
 645     [gnus-summary-catchup
 646      gnus-summary-catchup t "Catchup"]
 647     [gnus-summary-catchup-and-exit
 648      gnus-summary-catchup-and-exit t "Catchup and exit"]
 649     [gnus-summary-exit gnus-summary-exit t "Exit this summary"])
 650   "The summary buffer mail toolbar.")
 651
 652 (defun gnus-xmas-setup-group-toolbar ()
 653   (and gnus-use-toolbar
 654        (message-xmas-setup-toolbar gnus-group-toolbar nil "gnus")
 655        (set-specifier (symbol-value gnus-use-toolbar)
 656                       (cons (current-buffer) gnus-group-toolbar))))
 657
 658 (defun gnus-xmas-setup-summary-toolbar ()
 659   (let ((bar (if (gnus-news-group-p gnus-newsgroup-name)
 660                  gnus-summary-toolbar gnus-summary-mail-toolbar)))
 661     (and gnus-use-toolbar
 662          (message-xmas-setup-toolbar bar nil "gnus")
 663          (set-specifier (symbol-value gnus-use-toolbar)
 664                         (cons (current-buffer) bar)))))
 665
 666 (defun gnus-xmas-mail-strip-quoted-names (address)
 667   "Protect mail-strip-quoted-names from nil input.
 668 XEmacs compatibility workaround."
 669   (if (null address)
 670       nil
 671     (mail-strip-quoted-names address)))
 672
 673 (defun gnus-xmas-call-region (command &rest args)
 674   (apply
 675    'call-process-region (point-min) (point-max) command t '(t nil) nil
 676    args))
 677
 678 (defface gnus-x-face '((t (:foreground "black" :background "white")))
 679   "Face to show X face"
 680   :group 'gnus-xmas)
 681
 682 (defun gnus-xmas-article-display-xface (beg end &optional buffer)
 683   "Display any XFace headers in BUFFER."
 684   (save-excursion
 685     (let ((xface-glyph
 686            (cond
 687             ((featurep 'xface)
 688              (make-glyph (vector 'xface :data
 689                                  (concat "X-Face: "
 690                                          (if buffer
 691                                              (with-current-buffer buffer
 692                                                (buffer-substring beg end))
 693                                            (buffer-substring beg end))))))
 694             ((featurep 'xpm)
 695              (let ((cur (or buffer (current-buffer))))
 696                (save-excursion
 697                  (gnus-set-work-buffer)
 698                  (insert-buffer-substring cur beg end)
 699                  (let ((coding-system-for-read 'binary)
 700                        (coding-system-for-write 'binary))
 701                    (gnus-xmas-call-region "uncompface")
 702                    (goto-char (point-min))
 703                    (insert "/* Width=48, Height=48 */\n")
 704                    (gnus-xmas-call-region "icontopbm")
 705                    (gnus-xmas-call-region "ppmtoxpm")
 706                    (make-glyph
 707                     (vector 'xpm :data (buffer-string)))))))
 708             (t
 709              (make-glyph [nothing]))))
 710           (ext (make-extent (progn
 711                               (goto-char (point-min))
 712                               (re-search-forward "^From:" nil t)
 713                               (point))
 714                             (1+ (point)))))
 715       (set-glyph-face xface-glyph 'gnus-x-face)
 716       (set-extent-begin-glyph ext xface-glyph)
 717       (set-extent-property ext 'duplicable t))))
 718
 719 (defvar gnus-xmas-modeline-left-extent
 720   (let ((ext (copy-extent modeline-buffer-id-left-extent)))
 721     ext))
 722
 723 (defvar gnus-xmas-modeline-right-extent
 724   (let ((ext (copy-extent modeline-buffer-id-right-extent)))
 725     ext))
 726
 727 (defvar gnus-xmas-modeline-glyph
 728   (progn
 729     (let* ((file-xpm (expand-file-name "gnus-pointer.xpm"
 730                                        gnus-xmas-glyph-directory))
 731            (file-xbm (expand-file-name "gnus-pointer.xbm"
 732                                        gnus-xmas-glyph-directory))
 733            (glyph (make-glyph
 734                    ;; Gag gag gag.
 735                    (cond ((featurep 'xpm)
 736                           ;; Let's try a nifty XPM
 737                           `[xpm :file ,file-xpm])
 738                          ((featurep 'xbm)
 739                           ;; Then a not-so-nifty XBM
 740                           `[xbm :file ,file-xbm])
 741                          ;; Then the simple string
 742                          (t [string :data "Gnus:"])))))
 743       (set-glyph-face glyph 'modeline-buffer-id)
 744       glyph)))
 745
 746 (defun gnus-xmas-mode-line-buffer-identification (line)
 747   (let ((line (car line))
 748         chop)
 749     (cond
 750      ;; This is some weird type of id.
 751      ((not (stringp line))
 752       (list line))
 753      ;; This is non-standard, so we just pass it through.
 754      ((not (string-match "^Gnus:" line))
 755       (list line))
 756      ;; We have a standard line, so we colorize and glyphize it a bit.
 757      (t
 758       (setq chop (match-end 0))
 759       (list
 760        (if gnus-xmas-modeline-glyph
 761            (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
 762          (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
 763        (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
 764
 765 (defun gnus-xmas-splash ()
 766   (when (eq (device-type) 'x)
 767     (gnus-splash)))
 768
 769 (defun gnus-xmas-annotation-in-region-p (b e)
 770   (or (map-extents (lambda (e u) t) nil b e nil nil 'mm t)
 771       (if (= b e)
 772           (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
 773         (text-property-any b e 'gnus-undeletable t))))
 774
 775 (defun gnus-xmas-mime-button-menu (event)
 776   "Construct a context-sensitive menu of MIME commands."
 777   (interactive "e")
 778   (let ((response (get-popup-menu-response
 779                    `("MIME Part"
 780                      ,@(mapcar (lambda (c) `[,(caddr c) ,(car c) t])
 781                                gnus-mime-button-commands)))))
 782     (set-buffer (event-buffer event))
 783     (goto-char (event-point event))
 784     (funcall (event-function response) (event-object response))))
 785
 786 (defun gnus-group-add-icon ()
 787   "Add an icon to the current line according to `gnus-group-icon-list'."
 788   (let* ((p (point))
 789          (end (progn (end-of-line) (point)))
 790          ;; now find out where the line starts and leave point there.
 791          (beg (progn (beginning-of-line) (point))))
 792     (save-restriction
 793       (narrow-to-region beg end)
 794       (goto-char beg)
 795       (when (search-forward "==&&==" nil t)
 796         (let* ((group (gnus-group-group-name))
 797                (entry (gnus-group-entry group))
 798                (unread (if (numberp (car entry)) (car entry) 0))
 799                (active (gnus-active group))
 800                (total (if active (1+ (- (cdr active) (car active))) 0))
 801                (info (nth 2 entry))
 802                (method (gnus-server-get-method group (gnus-info-method info)))
 803                (marked (gnus-info-marks info))
 804                (mailp (memq 'mail (assoc (symbol-name
 805                                           (car (or method gnus-select-method)))
 806                                          gnus-valid-select-methods)))
 807                (level (or (gnus-info-level info) gnus-level-killed))
 808                (score (or (gnus-info-score info) 0))
 809                (ticked (gnus-range-length (cdr (assq 'tick marked))))
 810                (group-age (gnus-group-timestamp-delta group))
 811                (inhibit-read-only t)
 812                (list gnus-group-icon-list)
 813                (mystart (match-beginning 0))
 814                (myend (match-end 0)))
 815           (goto-char (point-min))
 816           (while (and list
 817                       (not (eval (caar list))))
 818             (setq list (cdr list)))
 819           (if list
 820               (let* ((file (cdar list))
 821                      (glyph (gnus-group-icon-create-glyph
 822                              (buffer-substring mystart myend)
 823                              file)))
 824                 (if glyph
 825                     (progn
 826                       (mapcar 'delete-annotation (annotations-at myend))
 827                       (let ((ext (make-extent mystart myend))
 828                             (ant (make-annotation glyph myend 'text)))
 829                         ;; set text extent params
 830                         (set-extent-property ext 'end-open t)
 831                         (set-extent-property ext 'start-open t)
 832                         (set-extent-property ext 'invisible t)))
 833                   (delete-region mystart myend)))
 834             (delete-region mystart myend))))
 835       (widen))
 836     (goto-char p)))
 837
 838 (defun gnus-group-icon-create-glyph (substring pixmap)
 839   "Create a glyph for insertion into a group line."
 840   (or
 841    (cdr-safe (assoc pixmap gnus-group-icon-cache))
 842    (let* ((glyph (make-glyph
 843                   (list
 844                    (cons 'x
 845                          (expand-file-name pixmap gnus-xmas-glyph-directory))
 846                    (cons 'mswindows
 847                          (expand-file-name pixmap gnus-xmas-glyph-directory))
 848                    (cons 'tty substring)))))
 849      (setq gnus-group-icon-cache
 850            (cons (cons pixmap glyph) gnus-group-icon-cache))
 851      (set-glyph-face glyph 'default)
 852      glyph)))
 853
 854 (defun gnus-xmas-mailing-list-menu-add ()
 855   (gnus-xmas-menu-add mailing-list
 856                       gnus-mailing-list-menu))
 857
 858 (defun gnus-xmas-image-type-available-p (type)
 859   (featurep type))
 860
 861 (defun gnus-xmas-create-image (file)
 862   (with-temp-buffer
 863     (insert-file-contents file)
 864     (mm-create-image-xemacs (car (last (split-string file "[.]"))))))
 865
 866 (defun gnus-xmas-put-image (glyph)
 867   (let ((annot (make-annotation glyph nil 'text)))
 868     (set-extent-property annot 'mm t)
 869     (set-extent-property annot 'duplicable t)))
 870
 871 (provide 'gnus-xmas)
 872
 873 ;;; gnus-xmas.el ends here