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
 336 (defun gnus-xmas-score-menu-add ()
 337   (gnus-xmas-menu-add score
 338     gnus-score-menu))
 339
 340 (defun gnus-xmas-pick-menu-add ()
 341   (gnus-xmas-menu-add pick
 342     gnus-pick-menu))
 343
 344 (defun gnus-xmas-topic-menu-add ()
 345   (gnus-xmas-menu-add topic
 346     gnus-topic-menu))
 347
 348 (defun gnus-xmas-binary-menu-add ()
 349   (gnus-xmas-menu-add binary
 350     gnus-binary-menu))
 351
 352 (defun gnus-xmas-agent-summary-menu-add ()
 353   (gnus-xmas-menu-add agent-summary
 354     gnus-agent-summary-menu))
 355
 356 (defun gnus-xmas-agent-group-menu-add ()
 357   (gnus-xmas-menu-add agent-group
 358     gnus-agent-group-menu))
 359
 360 (defun gnus-xmas-agent-server-menu-add ()
 361   (gnus-xmas-menu-add agent-server
 362     gnus-agent-server-menu))
 363
 364 (defun gnus-xmas-tree-menu-add ()
 365   (gnus-xmas-menu-add tree
 366     gnus-tree-menu))
 367
 368 (defun gnus-xmas-draft-menu-add ()
 369   (gnus-xmas-menu-add draft
 370     gnus-draft-menu))
 371
 372 (defun gnus-xmas-server-menu-add ()
 373   (gnus-xmas-menu-add menu
 374     gnus-server-server-menu gnus-server-connections-menu))
 375
 376 (defun gnus-xmas-browse-menu-add ()
 377   (gnus-xmas-menu-add browse
 378     gnus-browse-menu))
 379
 380 (defun gnus-xmas-grouplens-menu-add ()
 381   (gnus-xmas-menu-add grouplens
 382     gnus-grouplens-menu))
 383
 384 (defun gnus-xmas-read-event-char ()
 385   "Get the next event."
 386   (let ((event (next-command-event)))
 387     (sit-for 0)
 388     ;; We junk all non-key events.  Is this naughty?
 389     (while (not (or (key-press-event-p event)
 390                     (button-press-event-p event)))
 391       (dispatch-event event)
 392       (setq event (next-command-event)))
 393     (cons (and (key-press-event-p event)
 394                (event-to-character event))
 395           event)))
 396
 397 (defun gnus-xmas-define ()
 398   (setq gnus-mouse-2 [button2])
 399   (setq gnus-mouse-3 [button3])
 400   (setq gnus-widget-button-keymap widget-button-keymap)
 401
 402   (unless (memq 'underline (face-list))
 403     (and (fboundp 'make-face)
 404          (funcall (intern "make-face") 'underline)))
 405   ;; Must avoid calling set-face-underline-p directly, because it
 406   ;; is a defsubst in emacs19, and will make the .elc files non
 407   ;; portable!
 408   (unless (face-differs-from-default-p 'underline)
 409     (funcall (intern "set-face-underline-p") 'underline t))
 410
 411   (cond
 412    ((fboundp 'char-or-char-int-p)
 413     ;; Handle both types of marks for XEmacs-20.x.
 414     (defalias 'gnus-characterp 'char-or-char-int-p))
 415    ;; V19 of XEmacs, probably.
 416    (t
 417     (defalias 'gnus-characterp 'characterp)))
 418
 419   (defalias 'gnus-make-overlay 'make-extent)
 420   (defalias 'gnus-delete-overlay 'delete-extent)
 421   (defalias 'gnus-overlay-put 'set-extent-property)
 422   (defalias 'gnus-move-overlay 'gnus-xmas-move-overlay)
 423   (defalias 'gnus-overlay-buffer 'extent-object)
 424   (defalias 'gnus-overlay-start 'extent-start-position)
 425   (defalias 'gnus-overlay-end 'extent-end-position)
 426   (defalias 'gnus-kill-all-overlays 'gnus-xmas-kill-all-overlays)
 427   (defalias 'gnus-extent-detached-p 'extent-detached-p)
 428   (defalias 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
 429   (defalias 'gnus-put-text-property 'gnus-xmas-put-text-property)
 430   (defalias 'gnus-deactivate-mark 'ignore)
 431   (defalias 'gnus-window-edges 'window-pixel-edges)
 432
 433   (if (and (<= emacs-major-version 19)
 434            (< emacs-minor-version 14))
 435       (defalias 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
 436
 437   (unless (boundp 'standard-display-table)
 438     (setq standard-display-table nil))
 439
 440   (defvar gnus-mouse-face-prop 'highlight)
 441
 442   (defun gnus-byte-code (func)
 443     "Return a form that can be `eval'ed based on FUNC."
 444     (let ((fval (indirect-function func)))
 445       (if (compiled-function-p fval)
 446           (list 'funcall fval)
 447         (cons 'progn (cdr (cdr fval))))))
 448
 449   (defalias 'gnus-x-color-values
 450     (if (fboundp 'x-color-values)
 451         'x-color-values
 452       (lambda (color)
 453         (color-instance-rgb-components
 454          (make-color-instance color))))))
 455
 456 (defun gnus-xmas-redefine ()
 457   "Redefine lots of Gnus functions for XEmacs."
 458   (defalias 'gnus-summary-set-display-table 'gnus-xmas-summary-set-display-table)
 459   (defalias 'gnus-visual-turn-off-edit-menu 'identity)
 460   (defalias 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
 461   (defalias 'gnus-extent-start-open 'gnus-xmas-extent-start-open)
 462   (defalias 'gnus-article-push-button 'gnus-xmas-article-push-button)
 463   (defalias 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
 464   (defalias 'gnus-read-event-char 'gnus-xmas-read-event-char)
 465   (defalias 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
 466   (defalias 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
 467   (defalias 'gnus-appt-select-lowest-window
 468         'gnus-xmas-appt-select-lowest-window)
 469   (defalias 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
 470   (defalias 'gnus-character-to-event 'character-to-event)
 471   (defalias 'gnus-mode-line-buffer-identification
 472         'gnus-xmas-mode-line-buffer-identification)
 473   (defalias 'gnus-key-press-event-p 'key-press-event-p)
 474   (defalias 'gnus-region-active-p 'region-active-p)
 475   (defalias 'gnus-annotation-in-region-p 'gnus-xmas-annotation-in-region-p)
 476   (defalias 'gnus-mime-button-menu 'gnus-xmas-mime-button-menu)
 477
 478   ;; These ones are not defcutom'ed, sometimes not even defvar'ed. They
 479   ;; probably should. If that is done, the code below should then be moved
 480   ;; where each variable is defined, in order not to mess with user settings.
 481   ;; -- didier
 482   (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add)
 483   (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
 484   (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
 485   (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add)
 486   (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add)
 487   (add-hook 'gnus-draft-mode-hook 'gnus-xmas-draft-menu-add)
 488   (add-hook 'gnus-mailing-list-mode-hook 'gnus-xmas-mailing-list-menu-add)
 489
 490   (when (featurep 'mule)
 491     (defun gnus-truncate-string (str end-column &optional start-column padding)
 492       "Truncate string STR to end at column END-COLUMN.
 493 The optional 2nd arg START-COLUMN, if non-nil, specifies
 494 the starting column; that means to return the characters occupying
 495 columns START-COLUMN ... END-COLUMN of STR.
 496
 497 The optional 3rd arg PADDING, if non-nil, specifies a padding character
 498 to add at the end of the result if STR doesn't reach column END-COLUMN,
 499 or if END-COLUMN comes in the middle of a character in STR.
 500 PADDING is also added at the beginning of the result
 501 if column START-COLUMN appears in the middle of a character in STR.
 502
 503 If PADDING is nil, no padding is added in these cases, so
 504 the resulting string may be narrower than END-COLUMN.
 505 \[Emacs 20.3 emulating function]"
 506       (or start-column
 507           (setq start-column 0))
 508       (let ((len (length str))
 509             (idx 0)
 510             (column 0)
 511             (head-padding "") (tail-padding "")
 512             ch last-column last-idx from-idx)
 513         (condition-case nil
 514             (while (< column start-column)
 515               (setq ch (aref str idx)
 516                     column (+ column (char-width ch))
 517                     idx (1+ idx)))
 518           (args-out-of-range (setq idx len)))
 519         (if (< column start-column)
 520             (if padding (make-string end-column padding) "")
 521           (if (and padding (> column start-column))
 522               (setq head-padding
 523                     (make-string (- column start-column) padding)))
 524           (setq from-idx idx)
 525           (if (< end-column column)
 526               (setq idx from-idx)
 527             (condition-case nil
 528                 (while (< column end-column)
 529                   (setq last-column column
 530                         last-idx idx
 531                         ch (aref str idx)
 532                         column (+ column (char-width ch))
 533                         idx (1+ idx)))
 534               (args-out-of-range (setq idx len)))
 535             (if (> column end-column)
 536                 (setq column last-column idx last-idx))
 537             (if (and padding (< column end-column))
 538                 (setq tail-padding
 539                       (make-string (- end-column column) padding))))
 540           (setq str (substring str from-idx idx))
 541           (if padding
 542               (concat head-padding str tail-padding)
 543             str))))
 544
 545     (defun gnus-tilde-pad-form (el pad-width)
 546       "Return a form that pads EL to PAD-WIDTH."
 547       (let ((pad (abs pad-width)))
 548         (if (symbolp el)
 549             (if (< pad-width 0)
 550                 `(let ((val (format "%s" ,el)))
 551                    (concat val (make-string
 552                                 (max 0 (- ,pad (string-width val))) ?\ )))
 553               `(let ((val (format "%s" ,el)))
 554                  (concat (make-string
 555                           (max 0 (- ,pad (string-width val))) ?\ )
 556                          val)))
 557           (if (< pad-width 0)
 558               `(let ((val (eval ,el)))
 559                  (concat val (make-string
 560                               (max 0 (- ,pad (string-width val))) ?\ )))
 561             `(let ((val (eval ,el)))
 562                (concat (make-string
 563                         (max 0 (- ,pad (string-width val))) ?\ )
 564                        val))))))
 565     ))
 566
 567 ;;; XEmacs logo and toolbar.
 568
 569 (defun gnus-xmas-group-startup-message (&optional x y)
 570   "Insert startup message in current buffer."
 571   ;; Insert the message.
 572   (erase-buffer)
 573   (cond
 574    ((and (console-on-window-system-p)
 575          (or (featurep 'xpm)
 576              (featurep 'xbm)))
 577     (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory))
 578            (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory))
 579            (glyph (make-glyph
 580                    (cond ((featurep 'xpm)
 581                           `[xpm
 582                             :file ,logo-xpm
 583                             :color-symbols
 584                             (("thing" . ,(car gnus-xmas-logo-colors))
 585                              ("shadow" . ,(cadr gnus-xmas-logo-colors))
 586                              ("background" . ,(face-background 'default)))])
 587                          ((featurep 'xbm)
 588                           `[xbm :file ,logo-xbm])
 589                          (t [nothing]))))
 590            (wpheight (window-pixel-height))
 591            (rest (max 0 (1- (/ (* (- wpheight (glyph-height glyph))
 592                                   (window-height))
 593                                wpheight 2)))))
 594       (insert " ")
 595       (set-extent-begin-glyph (make-extent (point) (point)) glyph)
 596       (goto-char (point-min))
 597       (while (not (eobp))
 598         (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
 599                              ?\ ))
 600         (forward-line 1))
 601       (setq gnus-simple-splash nil)
 602       (goto-char (point-min))
 603       (insert gnus-product-name " " gnus-version-number
 604               (if (zerop (string-to-number gnus-revision-number))
 605                   ""
 606                 (concat " (r" gnus-revision-number ")"))
 607               " based on " gnus-original-product-name " v"
 608               gnus-original-version-number "\n")
 609       (end-of-line 0)
 610       (put-text-property (point-min) (point) 'face 'gnus-splash-face)
 611       (insert-char ?\  (prog1
 612                            (max 0 (/ (- (window-width) (point)) 2))
 613                          (goto-char (point-min))))
 614       (forward-line 1)
 615       (insert-char ?\n rest)
 616       (set-window-start (selected-window) (point-min))))
 617    (t
 618     (insert "
 619           _    ___ _             _
 620           _ ___ __ ___  __    _ ___
 621           __   _     ___    __  ___
 622               _           ___     _
 623              _  _ __             _
 624              ___   __            _
 625                    __           _
 626                     _      _   _
 627                    _      _    _
 628                       _  _    _
 629                   __  ___
 630                  _   _ _     _
 631                 _   _
 632               _    _
 633              _    _
 634             _
 635           __
 636
 637 "
 638             )
 639     (goto-char (point-min))
 640     (insert gnus-product-name " " gnus-version-number
 641             (if (zerop (string-to-number gnus-revision-number))
 642                 ""
 643               (concat " (r" gnus-revision-number ")"))
 644             " based on " gnus-original-product-name " v"
 645             gnus-original-version-number)
 646     (insert-char ?\  (prog1
 647                          (max 0 (/ (- (window-width) (point)) 2))
 648                        (goto-char (point-min))))
 649     (forward-line 1)
 650     ;; And then hack it.
 651     (gnus-indent-rigidly (point) (point-max)
 652                          (/ (max (- (window-width) (or x 46)) 0) 2))
 653     (goto-char (point-min))
 654     (forward-line 1)
 655     (let* ((pheight (count-lines (point-min) (point-max)))
 656            (wheight (window-height))
 657            (rest (- wheight pheight)))
 658       (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
 659     ;; Paint it.
 660     (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)))
 661   (setq modeline-buffer-identification
 662         (list (concat gnus-version ": *Group*")))
 663   (set-buffer-modified-p t))
 664
 665
 666 ;;; The toolbar.
 667
 668 (defcustom gnus-use-toolbar (if (featurep 'toolbar)
 669                                 'default-toolbar
 670                               nil)
 671   "*If nil, do not use a toolbar.
 672 If it is non-nil, it must be a toolbar.  The five valid values are
 673 `default-toolbar', `top-toolbar', `bottom-toolbar',
 674 `right-toolbar', and `left-toolbar'."
 675   :type '(choice (const default-toolbar)
 676                  (const top-toolbar) (const bottom-toolbar)
 677                  (const left-toolbar) (const right-toolbar)
 678                  (const :tag "no toolbar" nil))
 679   :group 'gnus-xmas)
 680
 681 (defvar gnus-group-toolbar
 682   '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
 683     [gnus-group-get-new-news-this-group
 684      gnus-group-get-new-news-this-group t "Get new news in this group"]
 685     [gnus-group-catchup-current
 686      gnus-group-catchup-current t "Catchup group"]
 687     [gnus-group-describe-group
 688      gnus-group-describe-group t "Describe group"]
 689     [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
 690     [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]
 691     [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
 692     [gnus-group-exit gnus-group-exit t "Exit Gnus"])
 693   "The group buffer toolbar.")
 694
 695 (defvar gnus-summary-toolbar
 696   '([gnus-summary-prev-unread
 697      gnus-summary-prev-page-or-article t "Page up"]
 698     [gnus-summary-next-unread
 699      gnus-summary-next-page t "Page down"]
 700     [gnus-summary-post-news
 701      gnus-summary-post-news t "Post an article"]
 702     [gnus-summary-followup-with-original
 703      gnus-summary-followup-with-original t
 704      "Post a followup and yank the original"]
 705     [gnus-summary-followup
 706      gnus-summary-followup t "Post a followup"]
 707     [gnus-summary-reply-with-original
 708      gnus-summary-reply-with-original t "Mail a reply and yank the original"]
 709     [gnus-summary-reply
 710      gnus-summary-reply t "Mail a reply"]
 711     [gnus-summary-caesar-message
 712      gnus-summary-caesar-message t "Rot 13"]
 713     [gnus-uu-decode-uu
 714      gnus-uu-decode-uu t "Decode uuencoded articles"]
 715     [gnus-summary-save-article-file
 716      gnus-summary-save-article-file t "Save article in file"]
 717     [gnus-summary-save-article
 718      gnus-summary-save-article t "Save article"]
 719     [gnus-uu-post-news
 720      gnus-uu-post-news t "Post a uuencoded article"]
 721     [gnus-summary-cancel-article
 722      gnus-summary-cancel-article t "Cancel article"]
 723     [gnus-summary-catchup
 724      gnus-summary-catchup t "Catchup"]
 725     [gnus-summary-catchup-and-exit
 726      gnus-summary-catchup-and-exit t "Catchup and exit"]
 727     [gnus-summary-exit gnus-summary-exit t "Exit this summary"])
 728   "The summary buffer toolbar.")
 729
 730 (defvar gnus-summary-mail-toolbar
 731   '(
 732     [gnus-summary-prev-unread
 733      gnus-summary-prev-unread-article t "Prev unread article"]
 734     [gnus-summary-next-unread
 735      gnus-summary-next-unread-article t "Next unread article"]
 736     [gnus-summary-mail-reply gnus-summary-reply t "Reply"]
 737     [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
 738     [gnus-summary-mail-save gnus-summary-save-article t "Save"]
 739     [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
 740     [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
 741     [gnus-summary-caesar-message
 742      gnus-summary-caesar-message t "Rot 13"]
 743     [gnus-uu-decode-uu
 744      gnus-uu-decode-uu t "Decode uuencoded articles"]
 745     [gnus-summary-save-article-file
 746      gnus-summary-save-article-file t "Save article in file"]
 747     [gnus-summary-save-article
 748      gnus-summary-save-article t "Save article"]
 749     [gnus-summary-catchup
 750      gnus-summary-catchup t "Catchup"]
 751     [gnus-summary-catchup-and-exit
 752      gnus-summary-catchup-and-exit t "Catchup and exit"]
 753     [gnus-summary-exit gnus-summary-exit t "Exit this summary"])
 754   "The summary buffer mail toolbar.")
 755
 756 (defun gnus-xmas-setup-group-toolbar ()
 757   (and gnus-use-toolbar
 758        (message-xmas-setup-toolbar gnus-group-toolbar nil "gnus")
 759        (set-specifier (symbol-value gnus-use-toolbar)
 760                       (cons (current-buffer) gnus-group-toolbar))))
 761
 762 (defun gnus-xmas-setup-summary-toolbar ()
 763   (let ((bar (if (gnus-news-group-p gnus-newsgroup-name)
 764                  gnus-summary-toolbar gnus-summary-mail-toolbar)))
 765     (and gnus-use-toolbar
 766          (message-xmas-setup-toolbar bar nil "gnus")
 767          (set-specifier (symbol-value gnus-use-toolbar)
 768                         (cons (current-buffer) bar)))))
 769
 770 (defun gnus-xmas-mail-strip-quoted-names (address)
 771   "Protect mail-strip-quoted-names from NIL input.
 772 XEmacs compatibility workaround."
 773   (if (null address)
 774       nil
 775     (mail-strip-quoted-names address)))
 776
 777 (defun gnus-xmas-call-region (command &rest args)
 778   (apply
 779    'call-process-region (point-min) (point-max) command t '(t nil) nil
 780    args))
 781
 782 (defface gnus-x-face '((t (:foreground "black" :background "white")))
 783   "Face to show X face"
 784   :group 'gnus-xmas)
 785
 786 (defun gnus-xmas-article-display-xface (beg end &optional buffer)
 787   "Display any XFace headers in BUFFER."
 788   (save-excursion
 789     (let ((xface-glyph
 790            (cond
 791             ((featurep 'xface)
 792              (make-glyph (vector 'xface :data
 793                                  (concat "X-Face: "
 794                                          (if buffer
 795                                              (with-current-buffer buffer
 796                                                (buffer-substring beg end))
 797                                            (buffer-substring beg end))))))
 798             ((featurep 'xpm)
 799              (let ((cur (or buffer (current-buffer))))
 800                (save-excursion
 801                  (gnus-set-work-buffer)
 802                  (insert-buffer-substring cur beg end)
 803                  (gnus-xmas-call-region "uncompface")
 804                  (goto-char (point-min))
 805                  (insert "/* Width=48, Height=48 */\n")
 806                  (gnus-xmas-call-region "icontopbm")
 807                  (gnus-xmas-call-region "ppmtoxpm")
 808                  (make-glyph
 809                   (vector 'xpm :data (buffer-string))))))
 810             (t
 811              (make-glyph [nothing]))))
 812           (ext (make-extent (progn
 813                               (goto-char (point-min))
 814                               (re-search-forward "^From:" nil t)
 815                               (point))
 816                             (1+ (point)))))
 817       (set-glyph-face xface-glyph 'gnus-x-face)
 818       (set-extent-begin-glyph ext xface-glyph)
 819       (set-extent-property ext 'duplicable t))))
 820
 821 (defvar gnus-xmas-modeline-left-extent
 822   (let ((ext (copy-extent modeline-buffer-id-left-extent)))
 823     ext))
 824
 825 (defvar gnus-xmas-modeline-right-extent
 826   (let ((ext (copy-extent modeline-buffer-id-right-extent)))
 827     ext))
 828
 829 (defvar gnus-xmas-modeline-glyph
 830   (progn
 831     (let* ((file-xpm (expand-file-name "gnus-pointer.xpm"
 832                                        gnus-xmas-glyph-directory))
 833            (file-xbm (expand-file-name "gnus-pointer.xbm"
 834                                        gnus-xmas-glyph-directory))
 835            (glyph (make-glyph
 836                    ;; Gag gag gag.
 837                    (cond ((featurep 'xpm)
 838                           ;; Let's try a nifty XPM
 839                           `[xpm :file ,file-xpm])
 840                          ((featurep 'xbm)
 841                           ;; Then a not-so-nifty XBM
 842                           `[xbm :file ,file-xbm])
 843                          ;; Then the simple string
 844                          (t [string :data "Gnus:"])))))
 845       (set-glyph-face glyph 'modeline-buffer-id)
 846       glyph)))
 847
 848 (defun gnus-xmas-mode-line-buffer-identification (line)
 849   (let ((line (car line))
 850         chop)
 851     (cond
 852      ;; This is some weird type of id.
 853      ((not (stringp line))
 854       (list line))
 855      ;; This is non-standard, so we just pass it through.
 856      ((not (string-match "^Gnus:" line))
 857       (list line))
 858      ;; We have a standard line, so we colorize and glyphize it a bit.
 859      (t
 860       (setq chop (match-end 0))
 861       (list
 862        (if gnus-xmas-modeline-glyph
 863            (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
 864          (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
 865        (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
 866
 867 (defun gnus-xmas-splash ()
 868   (when (eq (device-type) 'x)
 869     (gnus-splash)))
 870
 871 (defun gnus-xmas-annotation-in-region-p (b e)
 872   (or (map-extents (lambda (e u) t) nil b e nil nil 'mm t)
 873       (if (= b e)
 874           (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
 875         (text-property-any b e 'gnus-undeletable t))))
 876
 877 (defun gnus-xmas-mime-button-menu (event)
 878   "Construct a context-sensitive menu of MIME commands."
 879   (interactive "e")
 880   (let ((response (get-popup-menu-response
 881                    `("MIME Part"
 882                      ,@(mapcar (lambda (c) `[,(caddr c) ,(car c) t])
 883                                gnus-mime-button-commands)))))
 884     (set-buffer (event-buffer event))
 885     (goto-char (event-point event))
 886     (funcall (event-function response) (event-object response))))
 887
 888 (defun gnus-group-add-icon ()
 889   "Add an icon to the current line according to `gnus-group-icon-list'."
 890   (let* ((p (point))
 891          (end (progn (end-of-line) (point)))
 892          ;; now find out where the line starts and leave point there.
 893          (beg (progn (beginning-of-line) (point))))
 894     (save-restriction
 895       (narrow-to-region beg end)
 896       (goto-char beg)
 897       (when (search-forward "==&&==" nil t)
 898         (let* ((group (gnus-group-group-name))
 899                (entry (gnus-group-entry group))
 900                (unread (if (numberp (car entry)) (car entry) 0))
 901                (active (gnus-active group))
 902                (total (if active (1+ (- (cdr active) (car active))) 0))
 903                (info (nth 2 entry))
 904                (method (gnus-server-get-method group (gnus-info-method info)))
 905                (marked (gnus-info-marks info))
 906                (mailp (memq 'mail (assoc (symbol-name
 907                                           (car (or method gnus-select-method)))
 908                                          gnus-valid-select-methods)))
 909                (level (or (gnus-info-level info) gnus-level-killed))
 910                (score (or (gnus-info-score info) 0))
 911                (ticked (gnus-range-length (cdr (assq 'tick marked))))
 912                (group-age (gnus-group-timestamp-delta group))
 913                (inhibit-read-only t)
 914                (list gnus-group-icon-list)
 915                (mystart (match-beginning 0))
 916                (myend (match-end 0)))
 917           (goto-char (point-min))
 918           (while (and list
 919                       (not (eval (caar list))))
 920             (setq list (cdr list)))
 921           (if list
 922               (let* ((file (cdar list))
 923                      (glyph (gnus-group-icon-create-glyph
 924                              (buffer-substring mystart myend)
 925                              file)))
 926                 (if glyph
 927                     (progn
 928                       (mapcar 'delete-annotation (annotations-at myend))
 929                       (let ((ext (make-extent mystart myend))
 930                             (ant (make-annotation glyph myend 'text)))
 931                         ;; set text extent params
 932                         (set-extent-property ext 'end-open t)
 933                         (set-extent-property ext 'start-open t)
 934                         (set-extent-property ext 'invisible t)))
 935                   (delete-region mystart myend)))
 936             (delete-region mystart myend))))
 937       (widen))
 938     (goto-char p)))
 939
 940 (defun gnus-group-icon-create-glyph (substring pixmap)
 941   "Create a glyph for insertion into a group line."
 942   (or
 943    (cdr-safe (assoc pixmap gnus-group-icon-cache))
 944    (let* ((glyph (make-glyph
 945                   (list
 946                    (cons 'x
 947                          (expand-file-name pixmap gnus-xmas-glyph-directory))
 948                    (cons 'mswindows
 949                          (expand-file-name pixmap gnus-xmas-glyph-directory))
 950                    (cons 'tty substring)))))
 951      (setq gnus-group-icon-cache
 952            (cons (cons pixmap glyph) gnus-group-icon-cache))
 953      (set-glyph-face glyph 'default)
 954      glyph)))
 955
 956 (defun gnus-xmas-mailing-list-menu-add ()
 957   (gnus-xmas-menu-add mailing-list
 958                       gnus-mailing-list-menu))
 959
 960 (provide 'gnus-xmas)
 961
 962 ;;; gnus-xmas.el ends here