git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-xmas.el

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