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