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

   1 ;;; gnus-xmas.el --- Gnus functions for XEmacs
   2
   3 ;; Copyright (C) 1995-2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.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 3, 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.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (eval-when-compile
  28   (autoload 'gnus-active "gnus" nil nil 'macro)
  29   (autoload 'gnus-group-entry "gnus" nil nil 'macro)
  30   (autoload 'gnus-info-level "gnus" nil nil 'macro)
  31   (autoload 'gnus-info-marks "gnus" nil nil 'macro)
  32   (autoload 'gnus-info-method "gnus" nil nil 'macro)
  33   (autoload 'gnus-info-score "gnus" nil nil 'macro))
  34
  35 (require 'text-props)
  36 (defvar menu-bar-mode (featurep 'menubar))
  37 (require 'messagexmas)
  38 (require 'wid-edit)
  39 (require 'gnus-util)
  40
  41 (defgroup gnus-xmas nil
  42   "XEmacsoid support for Gnus"
  43   :group 'gnus)
  44
  45 (defcustom gnus-xmas-glyph-directory nil
  46   "Directory where Gnus logos and icons are located.
  47 If this variable is nil, Gnus will try to locate the directory
  48 automatically."
  49   :type '(choice (const :tag "autodetect" nil)
  50                  directory)
  51   :group 'gnus-xmas)
  52
  53 (unless gnus-xmas-glyph-directory
  54   (unless (setq gnus-xmas-glyph-directory
  55                 (message-xmas-find-glyph-directory "gnus"))
  56     (error "Can't find glyph directory. \
  57 Possibly the `etc' directory has not been installed.")))
  58
  59 ;;; Internal variables.
  60
  61 ;; Don't warn about these undefined variables.
  62
  63 ;;defined in gnus.el
  64 (defvar gnus-active-hashtb)
  65 (defvar gnus-article-buffer)
  66 (defvar gnus-auto-center-summary)
  67 (defvar gnus-current-headers)
  68 (defvar gnus-level-killed)
  69 (defvar gnus-level-zombie)
  70 (defvar gnus-newsgroup-bookmarks)
  71 (defvar gnus-newsgroup-dependencies)
  72 (defvar gnus-newsgroup-selected-overlay)
  73 (defvar gnus-newsrc-hashtb)
  74 (defvar gnus-read-mark)
  75 (defvar gnus-refer-article-method)
  76 (defvar gnus-reffed-article-number)
  77 (defvar gnus-unread-mark)
  78 (defvar gnus-version)
  79 (defvar gnus-view-pseudos)
  80 (defvar gnus-view-pseudos-separately)
  81 (defvar gnus-visual)
  82 (defvar gnus-zombie-list)
  83 ;;defined in gnus-msg.el
  84 (defvar gnus-article-copy)
  85 (defvar gnus-check-before-posting)
  86 ;;defined in gnus-vis.el
  87 (defvar gnus-article-button-face)
  88 (defvar gnus-article-mouse-face)
  89 (defvar gnus-summary-selected-face)
  90 (defvar gnus-group-reading-menu)
  91 (defvar gnus-group-group-menu)
  92 (defvar gnus-group-misc-menu)
  93 (defvar gnus-summary-article-menu)
  94 (defvar gnus-summary-thread-menu)
  95 (defvar gnus-summary-misc-menu)
  96 (defvar gnus-summary-post-menu)
  97 (defvar gnus-summary-kill-menu)
  98 (defvar gnus-article-article-menu)
  99 (defvar gnus-article-treatment-menu)
 100 (defvar gnus-mouse-2)
 101 (defvar standard-display-table)
 102 (defvar gnus-tree-minimize-window)
 103 ;;`gnus-agent-mode' in gnus-agent.el will define it.
 104 (defvar gnus-agent-summary-mode)
 105 (defvar gnus-draft-mode)
 106
 107 (defcustom gnus-xmas-force-redisplay nil
 108   "*If non-nil, force a redisplay before recentering the summary buffer.
 109 This is ugly, but it works around a bug in `window-displayed-height'."
 110   :type 'boolean
 111   :group 'gnus-xmas)
 112
 113 (defun gnus-xmas-switch-horizontal-scrollbar-off ()
 114   (when (featurep 'scrollbar)
 115     (set-specifier scrollbar-height (cons (current-buffer) 0))))
 116
 117 (defun gnus-xmas-summary-recenter ()
 118   "\"Center\" point in the summary window.
 119 If `gnus-auto-center-summary' is nil, or the article buffer isn't
 120 displayed, no centering will be performed."
 121   ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
 122   ;; Recenter only when requested.  Suggested by popovich@park.cs.columbia.edu.
 123   ;; Force redisplay to get properly computed window height.
 124   (when gnus-xmas-force-redisplay
 125     (sit-for 0))
 126   (when gnus-auto-center-summary
 127     (let* ((height (if (fboundp 'window-displayed-height)
 128                        (window-displayed-height)
 129                      (- (window-height) 2)))
 130            (top (cond ((< height 4) 0)
 131                       ((< height 7) 1)
 132                       (t (if (numberp gnus-auto-center-summary)
 133                              gnus-auto-center-summary
 134                            2))))
 135            (bottom (save-excursion (goto-char (point-max))
 136                                    (forward-line (- height))
 137                                    (point)))
 138            (window (get-buffer-window (current-buffer))))
 139       (when (get-buffer-window gnus-article-buffer)
 140         ;; Only do recentering when the article buffer is displayed,
 141         ;; Set the window start to either `bottom', which is the biggest
 142         ;; possible valid number, or the second line from the top,
 143         ;; whichever is the least.
 144         ;; NOFORCE parameter suggested by Daniel Pittman <daniel@danann.net>.
 145         (set-window-start
 146          window (min bottom (save-excursion (forward-line (- top)) (point)))
 147          t))
 148       ;; Do horizontal recentering while we're at it.
 149       (when (and (get-buffer-window (current-buffer) t)
 150                  (not (eq gnus-auto-center-summary 'vertical)))
 151         (let ((selected (selected-window)))
 152           (select-window (get-buffer-window (current-buffer) t))
 153           (gnus-summary-position-point)
 154           (gnus-horizontal-recenter)
 155           (select-window selected))))))
 156
 157 (defun gnus-xmas-summary-set-display-table ()
 158   ;; Setup the display table -- like `gnus-summary-setup-display-table',
 159   ;; but done in an XEmacsish way.
 160   (let ((table (make-display-table))
 161         (i 32))
 162     ;; Nix out all the control chars...
 163     (while (>= (setq i (1- i)) 0)
 164       (gnus-put-display-table i [??] table))
 165     ;; ... but not newline and cr, of course.  (cr is necessary for the
 166     ;; selective display).
 167     (gnus-put-display-table ?\n nil table)
 168     (gnus-put-display-table ?\r nil table)
 169     ;; We keep TAB as well.
 170     (gnus-put-display-table ?\t nil table)
 171     ;; We nix out any glyphs over 126 below ctl-arrow.
 172     (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
 173       (while (>= (setq i (1- i)) 127)
 174         (unless (gnus-get-display-table i table)
 175           (gnus-put-display-table i [??] table))))
 176     ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
 177     (add-spec-to-specifier current-display-table table (current-buffer) nil)))
 178
 179 (defun gnus-xmas-add-text-properties (start end props &optional object)
 180   (add-text-properties start end props object)
 181   (put-text-property start end 'start-closed nil object))
 182
 183 (defun gnus-xmas-put-text-property (start end prop value &optional object)
 184   (put-text-property start end prop value object)
 185   (put-text-property start end 'start-closed nil object))
 186
 187 (defun gnus-xmas-extent-start-open (point)
 188   (map-extents (lambda (extent arg)
 189                  (set-extent-property extent 'start-open t))
 190                nil point (min (1+ (point)) (point-max))))
 191
 192 (defun gnus-xmas-article-push-button (event)
 193   "Check text under the mouse pointer for a callback function.
 194 If the text under the mouse pointer has a `gnus-callback' property,
 195 call it with the value of the `gnus-data' text property."
 196   (interactive "e")
 197   (set-buffer (window-buffer (event-window event)))
 198   (let* ((pos (event-closest-point event))
 199          (data (get-text-property pos 'gnus-data))
 200          (fun (get-text-property pos 'gnus-callback)))
 201     (goto-char pos)
 202     (when fun
 203       (funcall fun data))))
 204
 205 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
 206   (set-extent-endpoints extent start end buffer))
 207
 208 (defun gnus-xmas-kill-all-overlays ()
 209   "Delete all extents in the current buffer."
 210   (map-extents (lambda (extent ignore)
 211                  (delete-extent extent)
 212                  nil)))
 213
 214 (defun gnus-xmas-overlays-in (beg end)
 215   "Return a list of the extents that overlap the region BEG ... END."
 216   (mapcar-extents #'identity nil nil beg end))
 217
 218 (defun gnus-xmas-window-top-edge (&optional window)
 219   (nth 1 (window-pixel-edges window)))
 220
 221 (defun gnus-xmas-tree-minimize ()
 222   (when (and gnus-tree-minimize-window
 223              (not (one-window-p)))
 224     (let* ((window-min-height 2)
 225            (height (1+ (count-lines (point-min) (point-max))))
 226            (min (max (1- window-min-height) height))
 227            (tot (if (numberp gnus-tree-minimize-window)
 228                     (min gnus-tree-minimize-window min)
 229                   min))
 230            (win (get-buffer-window (current-buffer)))
 231            (wh (and win (1- (window-height win)))))
 232       (when (and win
 233                  (not (eq tot wh)))
 234         (let ((selected (selected-window)))
 235           (select-window win)
 236           (enlarge-window (- tot wh))
 237           (select-window selected))))))
 238
 239 ;; Select the lowest window on the frame.
 240 (defun gnus-xmas-select-lowest-window ()