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, 2005
   4 ;;        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 2, 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 'timer-funcs)
  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
 107 (defun gnus-xmas-highlight-selected-summary ()
 108   ;; Highlight selected article in summary buffer
 109   (when gnus-summary-selected-face
 110     (when gnus-newsgroup-selected-overlay
 111       (delete-extent gnus-newsgroup-selected-overlay))
 112     (setq gnus-newsgroup-selected-overlay
 113           (make-extent (point-at-bol) (point-at-eol)))
 114     (set-extent-face gnus-newsgroup-selected-overlay
 115                      gnus-summary-selected-face)))
 116
 117 (defcustom gnus-xmas-force-redisplay nil
 118   "*If non-nil, force a redisplay before recentering the summary buffer.
 119 This is ugly, but it works around a bug in `window-displayed-height'."
 120   :type 'boolean
 121   :group 'gnus-xmas)
 122
 123 (defun gnus-xmas-switch-horizontal-scrollbar-off ()
 124   (when (featurep 'scrollbar)
 125     (set-specifier scrollbar-height (cons (current-buffer) 0))))
 126
 127 (defun gnus-xmas-summary-recenter ()
 128   "\"Center\" point in the summary window.
 129 If `gnus-auto-center-summary' is nil, or the article buffer isn't
 130 displayed, no centering will be performed."
 131   ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
 132   ;; Recenter only when requested.  Suggested by popovich@park.cs.columbia.edu.
 133   ;; Force redisplay to get properly computed window height.
 134   (when gnus-xmas-force-redisplay
 135     (sit-for 0))
 136   (when gnus-auto-center-summary
 137     (let* ((height (if (fboundp 'window-displayed-height)
 138                        (window-displayed-height)
 139                      (- (window-height) 2)))
 140            (top (cond ((< height 4) 0)
 141                       ((< height 7) 1)
 142                       (t (if (numberp gnus-auto-center-summary)
 143                              gnus-auto-center-summary
 144                            2))))
 145            (bottom (save-excursion (goto-char (point-max))
 146                                    (forward-line (- height))
 147                                    (point)))
 148            (window (get-buffer-window (current-buffer))))
 149       (when (get-buffer-window gnus-article-buffer)
 150         ;; Only do recentering when the article buffer is displayed,
 151         ;; Set the window start to either `bottom', which is the biggest
 152         ;; possible valid number, or the second line from the top,
 153         ;; whichever is the least.
 154         ;; NOFORCE parameter suggested by Daniel Pittman <daniel@danann.net>.
 155         (set-window-start
 156          window (min bottom (save-excursion (forward-line (- top)) (point)))
 157          t))
 158       ;; Do horizontal recentering while we're at it.
 159       (when (and (get-buffer-window (current-buffer) t)
 160                  (not (eq gnus-auto-center-summary 'vertical)))
 161         (let ((selected (selected-window)))
 162           (select-window (get-buffer-window (current-buffer) t))
 163           (gnus-summary-position-point)
 164           (gnus-horizontal-recenter)
 165           (select-window selected))))))
 166
 167 (defun gnus-xmas-summary-set-display-table ()
 168   ;; Setup the display table -- like `gnus-summary-setup-display-table',
 169   ;; but done in an XEmacsish way.
 170   (let ((table (make-display-table))
 171         (i 32))
 172     ;; Nix out all the control chars...
 173     (while (>= (setq i (1- i)) 0)
 174       (aset table i [??]))
 175     ;; ... but not newline and cr, of course.  (cr is necessary for the
 176     ;; selective display).
 177     (aset table ?\n nil)
 178     (aset table ?\r nil)
 179     ;; We keep TAB as well.
 180     (aset table ?\t nil)
 181     ;; We nix out any glyphs over 126 below ctl-arrow.
 182     (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
 183       (while (>= (setq i (1- i)) 127)
 184         (unless (aref table i)
 185           (aset table i [??]))))
 186     ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
 187     (add-spec-to-specifier current-display-table table (current-buffer) nil)))
 188
 189 (defun gnus-xmas-add-text-properties (start end props &optional object)
 190   (add-text-properties start end props object)
 191   (put-text-property start end 'start-closed nil object))
 192
 193 (defun gnus-xmas-put-text-property (start end prop value &optional object)
 194   (put-text-property start end prop value object)
 195   (put-text-property start end 'start-closed nil object))
 196
 197 (defun gnus-xmas-extent-start-open (point)
 198   (map-extents (lambda (extent arg)
 199                  (set-extent-property extent 'start-open t))
 200                nil point (min (1+ (point)) (point-max))))
 201
 202 (defun gnus-xmas-article-push-button (event)
 203   "Check text under the mouse pointer for a callback function.
 204 If the text under the mouse pointer has a `gnus-callback' property,
 205 call it with the value of the `gnus-data' text property."
 206   (interactive "e")
 207   (set-buffer (window-buffer (event-window event)))
 208   (let* ((pos (event-closest-point event))
 209          (data (get-text-property pos 'gnus-data))
 210          (fun (get-text-property pos 'gnus-callback)))
 211     (goto-char pos)
 212     (when fun
 213       (funcall fun data))))
 214
 215 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
 216   (set-extent-endpoints extent start end buffer))
 217
 218 (defun gnus-xmas-kill-all-overlays ()
 219   "Delete all extents in the current buffer."
 220   (map-extents (lambda (extent ignore)
 221                  (delete-extent extent)
 222                  nil)))
 223
 224 (defun gnus-xmas-window-top-edge (&optional window)
 225   (nth 1 (window-pixel-edges window)))
 226
 227 (defun gnus-xmas-tree-minimize ()
 228   (when (and gnus-tree-minimize-window
 229              (not (one-window-p)))
 230     (let* ((window-min-height 2)
 231            (height (1+ (count-lines (point-min) (point-max))))
 232            (min (max (1- window-min-height) height))
 233            (tot (if (numberp gnus-tree-minimize-window)
 234                     (min gnus-tree-minimize-window min)
 235                   min))
 236            (win (get-buffer-window (current-buffer)))
 237            (wh (and win (1- (window-height win)))))
 238       (when (and win
 239                  (not (eq tot wh)))
 240 &nb