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