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