cgit.sxemacs.org Git - gnus/blob - lisp/gnus-xmas.el

   1 ;;; gnus-xmas.el --- Gnus functions for XEmacs
   2
   3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
   4 ;;   2005, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (eval-when-compile
  31   (autoload 'gnus-active "gnus" nil nil 'macro)
  32   (autoload 'gnus-group-entry "gnus" nil nil 'macro)
  33   (autoload 'gnus-info-level "gnus" nil nil 'macro)
  34   (autoload 'gnus-info-marks "gnus" nil nil 'macro)
  35   (autoload 'gnus-info-method "gnus" nil nil 'macro)
  36   (autoload 'gnus-info-score "gnus" nil nil 'macro))
  37
  38 (require 'text-props)
  39 (defvar menu-bar-mode (featurep 'menubar))
  40 (require 'messagexmas)
  41 (require 'wid-edit)
  42 (require 'gnus-util)
  43
  44 (defgroup gnus-xmas nil
  45   "XEmacsoid support for Gnus"
  46   :group 'gnus)
  47
  48 (defcustom gnus-xmas-glyph-directory nil
  49   "Directory where Gnus logos and icons are located.
  50 If this variable is nil, Gnus will try to locate the directory
  51 automatically."
  52   :type '(choice (const :tag "autodetect" nil)
  53                  directory)
  54   :group 'gnus-xmas)
  55
  56 (unless gnus-xmas-glyph-directory
  57   (unless (setq gnus-xmas-glyph-directory
  58                 (message-xmas-find-glyph-directory "gnus"))
  59     (error "Can't find glyph directory. \
  60 Possibly the `etc' directory has not been installed.")))
  61
  62 ;;; Internal variables.
  63
  64 ;; Don't warn about these undefined variables.
  65
  66 ;;defined in gnus.el
  67 (defvar gnus-active-hashtb)
  68 (defvar gnus-article-buffer)
  69 (defvar gnus-auto-center-summary)
  70 (defvar gnus-current-headers)
  71 (defvar gnus-level-killed)
  72 (defvar gnus-level-zombie)
  73 (defvar gnus-newsgroup-bookmarks)
  74 (defvar gnus-newsgroup-dependencies)
  75 (defvar gnus-newsgroup-selected-overlay)
  76 (defvar gnus-newsrc-hashtb)
  77 (defvar gnus-read-mark)
  78 (defvar gnus-refer-article-method)
  79 (defvar gnus-reffed-article-number)
  80 (defvar gnus-unread-mark)
  81 (defvar gnus-version)
  82 (defvar gnus-view-pseudos)
  83 (defvar gnus-view-pseudos-separately)
  84 (defvar gnus-visual)
  85 (defvar gnus-zombie-list)
  86 ;;defined in gnus-msg.el
  87 (defvar gnus-article-copy)
  88 (defvar gnus-check-before-posting)
  89 ;;defined in gnus-vis.el
  90 (defvar gnus-article-button-face)
  91 (defvar gnus-article-mouse-face)
  92 (defvar gnus-summary-selected-face)
  93 (defvar gnus-group-reading-menu)
  94 (defvar gnus-group-group-menu)
  95 (defvar gnus-group-misc-menu)
  96 (defvar gnus-summary-article-menu)
  97 (defvar gnus-summary-thread-menu)
  98 (defvar gnus-summary-misc-menu)
  99 (defvar gnus-summary-post-menu)
 100 (defvar gnus-summary-kill-menu)
 101 (defvar gnus-article-article-menu)
 102 (defvar gnus-article-treatment-menu)
 103 (defvar gnus-mouse-2)
 104 (defvar standard-display-table)
 105 (defvar gnus-tree-minimize-window)
 106 ;;`gnus-agent-mode' in gnus-agent.el will define it.
 107 (defvar gnus-agent-summary-mode)
 108 (defvar gnus-draft-mode)
 109
 110 (defun gnus-xmas-highlight-selected-summary ()
 111   ;; Highlight selected article in summary buffer
 112   (when gnus-summary-selected-face
 113     (when gnus-newsgroup-selected-overlay
 114       (delete-extent gnus-newsgroup-selected-overlay))
 115     (setq gnus-newsgroup-selected-overlay
 116           (make-extent (point-at-bol) (point-at-eol)))
 117     (set-extent-face gnus-newsgroup-selected-overlay
 118                      gnus-summary-selected-face)))
 119
 120 (defcustom gnus-xmas-force-redisplay nil
 121   "*If non-nil, force a redisplay before recentering the summary buffer.
 122 This is ugly, but it works around a bug in `window-displayed-height'."
 123   :type 'boolean
 124   :group 'gnus-xmas)
 125
 126 (defun gnus-xmas-switch-horizontal-scrollbar-off ()
 127   (when (featurep 'scrollbar)
 128     (set-specifier scrollbar-height (cons (current-buffer) 0))))
 129
 130 (defun gnus-xmas-summary-recenter ()
 131   "\"Center\" point in the summary window.
 132 If `gnus-auto-center-summary' is nil, or the article buffer isn't
 133 displayed, no centering will be performed."
 134   ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
 135   ;; Recenter only when requested.  Suggested by popovich@park.cs.columbia.edu.
 136   ;; Force redisplay to get properly computed window height.
 137   (when gnus-xmas-force-redisplay
 138     (sit-for 0))
 139   (when gnus-auto-center-summary
 140     (let* ((height (if (fboundp 'window-displayed-height)
 141                        (window-displayed-height)
 142                      (- (window-height) 2)))
 143            (top (cond ((< height 4) 0)
 144                       ((< height 7) 1)
 145                       (t (if (numberp gnus-auto-center-summary)
 146                              gnus-auto-center-summary
 147                            2))))
 148            (bottom (save-excursion (goto-char (point-max))
 149                                    (forward-line (- height))
 150                                    (point)))
 151            (window (get-buffer-window (current-buffer))))
 152       (when (get-buffer-window gnus-article-buffer)
 153         ;; Only do recentering when the article buffer is displayed,
 154         ;; Set the window start to either `bottom', which is the biggest
 155         ;; possible valid number, or the second line from the top,
 156         ;; whichever is the least.
 157         ;; NOFORCE parameter suggested by Daniel Pittman <daniel@danann.net>.
 158         (set-window-start
 159          window (min bottom (save-excursion (forward-line (- top)) (point)))
 160          t))
 161       ;; Do horizontal recentering while we're at it.
 162       (when (and (get-buffer-window (current-buffer) t)
 163                  (not (eq gnus-auto-center-summary 'vertical)))
 164         (let ((selected (selected-window)))
 165           (select-window (get-buffer-window (current-buffer) t))
 166           (gnus-summary-position-point)
 167           (gnus-horizontal-recenter)
 168           (select-window selected))))))
 169
 170 (defun gnus-xmas-summary-set-display-table ()
 171   ;; Setup the display table -- like `gnus-summary-setup-display-table',
 172   ;; but done in an XEmacsish way.
 173   (let ((table (make-display-table))
 174         (i 32))
 175     ;; Nix out all the control chars...
 176     (while (>= (setq i (1- i)) 0)
 177       (gnus-put-display-table i [??] table))
 178     ;; ... but not newline and cr, of course.  (cr is necessary for the
 179     ;; selective display).
 180     (gnus-put-display-table ?\n nil table)
 181     (gnus-put-display-table ?\r nil table)
 182     ;; We keep TAB as well.
 183     (gnus-put-display-table ?\t nil table)
 184     ;; We nix out any glyphs over 126 below ctl-arrow.
 185     (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
 186       (while (>= (setq i (1- i)) 127)
 187         (unless (gnus-get-display-table i table)
 188           (gnus-put-display-table i [??] table))))
 189     ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
 190     (add-spec-to-specifier current-display-table table (current-buffer) nil)))
 191
 192 (defun gnus-xmas-add-text-properties (start end props &optional object)
 193   (add-text-properties start end props object)
 194   (put-text-property start end 'start-closed nil object))
 195
 196 (defun gnus-xmas-put-text-property (start end prop value &optional object)
 197   (put-text-property start end prop value object)
 198   (put-text-property start end 'start-closed nil object))
 199
 200 (defun gnus-xmas-extent-start-open (point)
 201   (map-extents (lambda (extent arg)
 202                  (set-extent-property extent 'start-open t))
 203                nil point (min (1+ (point)) (point-max))))
 204
 205 (defun gnus-xmas-article-push-button (event)
 206   "Check text under the mouse pointer for a callback function.
 207 If the text under the mouse pointer has a `gnus-callback' property,
 208 call it with the value of the `gnus-data' text property."
 209   (interactive "e")
 210   (set-buffer (window-buffer (event-window event)))
 211   (let* ((pos (event-closest-point event))
 212          (data (get-text-property pos 'gnus-data))
 213          (fun (get-text-property pos 'gnus-callback)))
 214     (goto-char pos)
 215     (when fun
 216       (funcall fun data))))
 217
 218 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
 219   (set-extent-endpoints extent start end buffer))
 220
 221 (defun gnus-xmas-kill-all-overlays ()
 222   "Delete all extents in the current buffer."
 223   (map-extents (lambda (extent ignore)
 224                  (delete-extent extent)
 225                  nil)))
 226
 227 (defun gnus-xmas-overlays-in (beg end)
 228   "Return a list of the extents that overlap the region BEG ... END."
 229   (mapcar-extents #'identity nil nil beg end))
 230
 231 (defun gnus-xmas-window-top-edge (&optional window)
 232   (nth 1 (window-pixel-edges window)))
 233
 234 (defun gnus-xmas-tree-minimize ()
 235   (when (and gnus-tree-minimize-window
 236              (not (one-window-p)))
 237     (let* ((window-min-height 2)
 238            (height (1+ (count-lines (point-min) (point-max))))
 239            (min (max (1- window-min-height) height))
 240            (tot (if (numberp gnus-tree-minimize-window)
 241                     (min gnus-tree-minimize-window min)
 242                   min))
 243            (win (get-buffer-window (current-buffer)))
 244            (wh (and win (1- (window-height win)))))
 245       (when (and win
 246                  (not (eq tot wh)))
 247         (let ((selected (selected-window)))
 248           (select-window win)
 249           (enlarge-window (- tot wh))
 250           (select-window selected))))))
 251
 252 ;; Select the lowest window on the frame.
 253 (defun gnus-xmas-select-lowest-window ()
 254   (let* ((lowest-window (selected-window))
 255          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 256          (last-window (previous-window))
 257          (window-search t))
 258     (while window-search
 259       (let* ((this-window (next-window))
 260              (next-bottom-edge (car (cdr (cdr (cdr
 261                                                (window-pixel-edges
 262                                                 this-window)))))))
 263         (when (< bottom-edge next-bottom-edge)
 264           (setq bottom-edge next-bottom-edge)
 265           (setq lowest-window this-window))
 266
 267         (select-window this-window)
 268         (when (eq last-window this-window)
 269           (select-window lowest-window)
 270           (setq window-search nil))))))
 271
 272 (defmacro gnus-xmas-menu-add (type &rest menus)
 273   `(gnus-xmas-menu-add-1 ',type ',menus))
 274 (put 'gnus-xmas-menu-add 'lisp-indent-function 1)
 275
 276 (defun gnus-xmas-menu-add-1 (type menus)
 277   (when (and menu-bar-mode
 278              (gnus-visual-p (intern (format "%s-menu" type)) 'menu))
 279     (while menus
 280       (easy-menu-add (symbol-value (pop menus))))))
 281
 282 (defun gnus-xmas-group-menu-add ()
 283   (gnus-xmas-menu-add group
 284     gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu))
 285
 286 (defun gnus-xmas-summary-menu-add ()
 287   (gnus-xmas-menu-add summary
 288     gnus-summary-misc-menu gnus-summary-kill-menu
 289     gnus-summary-article-menu gnus-summary-thread-menu
 290     gnus-summary-post-menu ))
 291
 292 (defun gnus-xmas-article-menu-add ()
 293   (gnus-xmas-menu-add article
 294     gnus-article-article-menu gnus-article-treatment-menu
 295     gnus-article-post-menu gnus-article-commands-menu))
 296
 297 (defun gnus-xmas-score-menu-add ()
 298   (gnus-xmas-menu-add score
 299     gnus-score-menu))
 300
 301 (defun gnus-xmas-pick-menu-add ()
 302   (gnus-xmas-menu-add pick
 303     gnus-pick-menu))
 304
 305 (defun gnus-xmas-topic-menu-add ()
 306   (gnus-xmas-menu-add topic
 307     gnus-topic-menu))
 308
 309 (defun gnus-xmas-binary-menu-add ()
 310   (gnus-xmas-menu-add binary
 311     gnus-binary-menu))
 312
 313 (defun gnus-xmas-agent-summary-menu-add ()
 314   (gnus-xmas-menu-add agent-summary
 315     gnus-agent-summary-menu))
 316
 317 (defun gnus-xmas-agent-group-menu-add ()
 318   (gnus-xmas-menu-add agent-group
 319     gnus-agent-group-menu))
 320
 321 (defun gnus-xmas-agent-server-menu-add ()
 322   (gnus-xmas-menu-add agent-server
 323     gnus-agent-server-menu))
 324
 325 (defun gnus-xmas-tree-menu-add ()
 326   (gnus-xmas-menu-add tree
 327     gnus-tree-menu))
 328
 329 (defun gnus-xmas-draft-menu-add ()
 330   (gnus-xmas-menu-add draft
 331     gnus-draft-menu))
 332
 333 (defun gnus-xmas-server-menu-add ()
 334   (gnus-xmas-menu-add menu
 335     gnus-server-server-menu gnus-server-connections-menu))
 336
 337 (defun gnus-xmas-browse-menu-add ()
 338   (gnus-xmas-menu-add browse
 339     gnus-browse-menu))
 340
 341 (defun gnus-xmas-read-event-char (&optional prompt)
 342   "Get the next event."
 343   (when prompt
 344     (display-message 'no-log (format "%s" prompt)))
 345   (let ((event (next-command-event)))
 346     (sit-for 0)
 347     ;; We junk all non-key events.  Is this naughty?
 348     (while (not (or (key-press-event-p event)
 349                     (button-press-event-p event)))
 350       (dispatch-event event)
 351       (setq event (next-command-event)))
 352     (cons (and (key-press-event-p event)
 353                (event-to-character event))
 354           event)))
 355
 356 (defun gnus-xmas-article-describe-bindings (&optional prefix)
 357   "Show a list of all defined keys, and their definitions.
 358 The optional argument PREFIX, if non-nil, should be a key sequence;
 359 then we display only bindings that start with that prefix."
 360   (interactive)
 361   (gnus-article-check-buffer)
 362   (let ((keymap (copy-keymap gnus-article-mode-map))
 363         (map (copy-keymap gnus-article-send-map))
 364         (sumkeys (where-is-internal 'gnus-article-read-summary-keys))
 365         parent agent draft)
 366     (define-key keymap "S" map)
 367     (set-keymap-default-binding map nil)
 368     (with-current-buffer gnus-article-current-summary
 369       (set-keymap-parent
 370        keymap
 371        (if (setq parent (keymap-parent gnus-article-mode-map))
 372            (prog1
 373                (setq parent (copy-keymap parent))
 374              (set-keymap-parent parent (current-local-map)))
 375          (current-local-map)))
 376       (let ((def (key-binding "S"))
 377             gnus-pick-mode)
 378         (set-keymap-parent map (if (symbolp def)
 379                                    (symbol-value def)
 380                                  def))
 381         (dolist (key sumkeys)
 382           (when (setq def (key-binding key))
 383             (define-key keymap key def))))
 384       (when (boundp 'gnus-agent-summary-mode)
 385         (setq agent gnus-agent-summary-mode))
 386       (when (boundp 'gnus-draft-mode)
 387         (setq draft gnus-draft-mode)))
 388     (with-temp-buffer
 389       (setq major-mode 'gnus-article-mode)
 390       (use-local-map keymap)
 391       (set (make-local-variable 'gnus-agent-summary-mode) agent)
 392       (set (make-local-variable 'gnus-draft-mode) draft)
 393       (describe-bindings prefix))))
 394
 395 (defun gnus-xmas-define ()