1 ;;; gnus-xmas.el --- Gnus functions for XEmacs
3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
4 ;; Free Software Foundation, Inc.
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
9 ;; This file is part of GNU Emacs.
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)
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.
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., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
31 (defvar menu-bar-mode (featurep 'menubar))
32 (require 'messagexmas)
35 (defgroup gnus-xmas nil
36 "XEmacsoid support for Gnus"
39 (defcustom gnus-xmas-glyph-directory nil
40 "Directory where Gnus logos and icons are located.
41 If this variable is nil, Gnus will try to locate the directory
43 :type '(choice (const :tag "autodetect" nil)
47 (unless gnus-xmas-glyph-directory
48 (unless (setq gnus-xmas-glyph-directory
49 (message-xmas-find-glyph-directory "gnus"))
50 (error "Can't find glyph directory. \
51 Possibly the `etc' directory has not been installed.")))
53 ;;; Internal variables.
55 ;; Don't warn about these undefined variables.
58 (defvar gnus-active-hashtb)
59 (defvar gnus-article-buffer)
60 (defvar gnus-auto-center-summary)
61 (defvar gnus-current-headers)
62 (defvar gnus-level-killed)
63 (defvar gnus-level-zombie)
64 (defvar gnus-newsgroup-bookmarks)
65 (defvar gnus-newsgroup-dependencies)
66 (defvar gnus-newsgroup-selected-overlay)
67 (defvar gnus-newsrc-hashtb)
68 (defvar gnus-read-mark)
69 (defvar gnus-refer-article-method)
70 (defvar gnus-reffed-article-number)
71 (defvar gnus-unread-mark)
73 (defvar gnus-view-pseudos)
74 (defvar gnus-view-pseudos-separately)
76 (defvar gnus-zombie-list)
77 ;;defined in gnus-msg.el
78 (defvar gnus-article-copy)
79 (defvar gnus-check-before-posting)
80 ;;defined in gnus-vis.el
81 (defvar gnus-article-button-face)
82 (defvar gnus-article-mouse-face)
83 (defvar gnus-summary-selected-face)
84 (defvar gnus-group-reading-menu)
85 (defvar gnus-group-group-menu)
86 (defvar gnus-group-misc-menu)
87 (defvar gnus-summary-article-menu)
88 (defvar gnus-summary-thread-menu)
89 (defvar gnus-summary-misc-menu)
90 (defvar gnus-summary-post-menu)
91 (defvar gnus-summary-kill-menu)
92 (defvar gnus-article-article-menu)
93 (defvar gnus-article-treatment-menu)
95 (defvar standard-display-table)
96 (defvar gnus-tree-minimize-window)
98 (defun gnus-xmas-set-text-properties (start end props &optional buffer)
99 "You should NEVER use this function. It is ideologically blasphemous.
100 It is provided only to ease porting of broken FSF Emacs programs."
103 (map-extents (lambda (extent ignored)
104 (remove-text-properties
106 (list (extent-property extent 'text-prop) nil)
109 buffer start end nil nil 'text-prop)
110 (gnus-add-text-properties start end props buffer)))
112 (defun gnus-xmas-highlight-selected-summary ()
113 ;; Highlight selected article in summary buffer
114 (when gnus-summary-selected-face
115 (when gnus-newsgroup-selected-overlay
116 (delete-extent gnus-newsgroup-selected-overlay))
117 (setq gnus-newsgroup-selected-overlay
118 (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
119 (set-extent-face gnus-newsgroup-selected-overlay
120 gnus-summary-selected-face)))
122 (defcustom gnus-xmas-force-redisplay nil
123 "*If non-nil, force a redisplay before recentering the summary buffer.
124 This is ugly, but it works around a bug in `window-displayed-height'."
128 (defun gnus-xmas-switch-horizontal-scrollbar-off ()
129 (when (featurep 'scrollbar)
130 (set-specifier scrollbar-height (cons (current-buffer) 0))))
132 (defun gnus-xmas-summary-recenter ()
133 "\"Center\" point in the summary window.
134 If `gnus-auto-center-summary' is nil, or the article buffer isn't
135 displayed, no centering will be performed."
136 ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
137 ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu.
138 ;; Force redisplay to get properly computed window height.
139 (when gnus-xmas-force-redisplay
141 (when gnus-auto-center-summary
142 (let* ((height (if (fboundp 'window-displayed-height)
143 (window-displayed-height)
144 (- (window-height) 2)))
145 (top (cond ((< height 4) 0)
147 (t (if (numberp gnus-auto-center-summary)
148 gnus-auto-center-summary
150 (bottom (save-excursion (goto-char (point-max))
151 (forward-line (- height))
153 (window (get-buffer-window (current-buffer))))
154 (when (get-buffer-window gnus-article-buffer)
155 ;; Only do recentering when the article buffer is displayed,
156 ;; Set the window start to either `bottom', which is the biggest
157 ;; possible valid number, or the second line from the top,
158 ;; whichever is the least.
159 ;; NOFORCE parameter suggested by Daniel Pittman <daniel@danann.net>.
161 window (min bottom (save-excursion (forward-line (- top)) (point)))
163 ;; Do horizontal recentering while we're at it.
164 (when (and (get-buffer-window (current-buffer) t)
165 (not (eq gnus-auto-center-summary 'vertical)))
166 (let ((selected (selected-window)))
167 (select-window (get-buffer-window (current-buffer) t))
168 (gnus-summary-position-point)
169 (gnus-horizontal-recenter)
170 (select-window selected))))))
172 (defun gnus-xmas-summary-set-display-table ()
173 ;; Setup the display table -- like `gnus-summary-setup-display-table',
174 ;; but done in an XEmacsish way.
175 (let ((table (make-display-table))
177 ;; Nix out all the control chars...
178 (while (>= (setq i (1- i)) 0)
180 ;; ... but not newline and cr, of course. (cr is necessary for the
181 ;; selective display).
184 ;; We keep TAB as well.
186 ;; We nix out any glyphs over 126 below ctl-arrow.
187 (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
188 (while (>= (setq i (1- i)) 127)
189 (unless (aref table i)
190 (aset table i [??]))))
191 ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
192 (add-spec-to-specifier current-display-table table (current-buffer) nil)))
194 (defun gnus-xmas-add-text-properties (start end props &optional object)
195 (add-text-properties start end props object)
196 (put-text-property start end 'start-closed nil object))
198 (defun gnus-xmas-put-text-property (start end prop value &optional object)
199 (put-text-property start end prop value object)
200 (put-text-property start end 'start-closed nil object))
202 (defun gnus-xmas-extent-start-open (point)
203 (map-extents (lambda (extent arg)
204 (set-extent-property extent 'start-open t))
205 nil point (min (1+ (point)) (point-max))))
207 (defun gnus-xmas-article-push-button (event)
208 "Check text under the mouse pointer for a callback function.
209 If the text under the mouse pointer has a `gnus-callback' property,
210 call it with the value of the `gnus-data' text property."
212 (set-buffer (window-buffer (event-window event)))
213 (let* ((pos (event-closest-point event))
214 (data (get-text-property pos 'gnus-data))
215 (fun (get-text-property pos 'gnus-callback)))
218 (funcall fun data))))
220 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
221 (set-extent-endpoints extent start end buffer))
223 (defun gnus-xmas-kill-all-overlays ()
224 "Delete all extents in the current buffer."
225 (map-extents (lambda (extent ignore)
226 (delete-extent extent)
229 (defun gnus-xmas-window-top-edge (&optional window)
230 (nth 1 (window-pixel-edges window)))
232 (defun gnus-xmas-tree-minimize ()
233 (when (and gnus-tree-minimize-window
234 (not (one-window-p)))
235 (let* ((window-min-height 2)
236 (height (1+ (count-lines (point-min) (point-max))))
237 (min (max (1- window-min-height) height))
238 (tot (if (numberp gnus-tree-minimize-window)