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