|
13401
|
1 ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
|
|
|
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
|
|
|
3
|
|
|
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
|
|
|
5 ;; Keywords: news
|
|
|
6
|
|
|
7 ;; This file is part of GNU Emacs.
|
|
|
8
|
|
|
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
10 ;; it under the terms of the GNU General Public License as published by
|
|
|
11 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
12 ;; any later version.
|
|
|
13
|
|
|
14 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
17 ;; GNU General Public License for more details.
|
|
|
18
|
|
|
19 ;; You should have received a copy of the GNU General Public License
|
|
|
20 ;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
|
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
22
|
|
|
23 ;;; Commentary:
|
|
|
24
|
|
|
25 ;;; Code:
|
|
|
26
|
|
|
27 (defvar gnus-mouse-2 [mouse-2])
|
|
|
28 (defvar gnus-group-mode-hook ())
|
|
|
29 (defvar gnus-summary-mode-hook ())
|
|
|
30 (defvar gnus-article-mode-hook ())
|
|
|
31
|
|
|
32 (defalias 'gnus-make-overlay 'make-overlay)
|
|
|
33 (defalias 'gnus-overlay-put 'overlay-put)
|
|
|
34 (defalias 'gnus-move-overlay 'move-overlay)
|
|
|
35
|
|
|
36 (or (fboundp 'mail-file-babyl-p)
|
|
|
37 (fset 'mail-file-babyl-p 'rmail-file-p))
|
|
|
38
|
|
|
39 ;; Don't warn about these undefined variables.
|
|
|
40 ;defined in gnus.el
|
|
|
41 (defvar gnus-active-hashtb)
|
|
|
42 (defvar gnus-article-buffer)
|
|
|
43 (defvar gnus-auto-center-summary)
|
|
|
44 (defvar gnus-buffer-list)
|
|
|
45 (defvar gnus-current-headers)
|
|
|
46 (defvar gnus-level-killed)
|
|
|
47 (defvar gnus-level-zombie)
|
|
|
48 (defvar gnus-newsgroup-bookmarks)
|
|
|
49 (defvar gnus-newsgroup-dependencies)
|
|
|
50 (defvar gnus-newsgroup-headers-hashtb-by-number)
|
|
|
51 (defvar gnus-newsgroup-selected-overlay)
|
|
|
52 (defvar gnus-newsrc-hashtb)
|
|
|
53 (defvar gnus-read-mark)
|
|
|
54 (defvar gnus-refer-article-method)
|
|
|
55 (defvar gnus-reffed-article-number)
|
|
|
56 (defvar gnus-unread-mark)
|
|
|
57 (defvar gnus-version)
|
|
|
58 (defvar gnus-view-pseudos)
|
|
|
59 (defvar gnus-view-pseudos-separately)
|
|
|
60 (defvar gnus-visual)
|
|
|
61 (defvar gnus-zombie-list)
|
|
|
62 ;defined in gnus-msg.el
|
|
|
63 (defvar gnus-article-copy)
|
|
|
64 (defvar gnus-check-before-posting)
|
|
|
65 ;defined in gnus-vis.el
|
|
|
66 (defvar gnus-article-button-face)
|
|
|
67 (defvar gnus-article-mouse-face)
|
|
|
68 (defvar gnus-summary-selected-face)
|
|
|
69
|
|
|
70
|
|
|
71 ;; We do not byte-compile this file, because error messages are such a
|
|
|
72 ;; bore.
|
|
|
73
|
|
|
74 (defun gnus-set-text-properties-xemacs (start end props &optional buffer)
|
|
|
75 "You should NEVER use this function. It is ideologically blasphemous.
|
|
|
76 It is provided only to ease porting of broken FSF Emacs programs."
|
|
|
77 (if (and (stringp buffer) (not (setq buffer (get-buffer buffer))))
|
|
|
78 nil
|
|
|
79 (map-extents (lambda (extent ignored)
|
|
|
80 (remove-text-properties
|
|
|
81 start end
|
|
|
82 (list (extent-property extent 'text-prop) nil)
|
|
|
83 buffer))
|
|
|
84 buffer start end nil nil 'text-prop)
|
|
|
85 (add-text-properties start end props buffer)))
|
|
|
86
|
|
|
87 (eval
|
|
|
88 '(progn
|
|
|
89 (if (string-match "XEmacs\\|Lucid" emacs-version)
|
|
|
90 ()
|
|
|
91 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
|
|
|
92 (defvar gnus-display-type
|
|
|
93 (condition-case nil
|
|
|
94 (let ((display-resource (x-get-resource ".displayType" "DisplayType")))
|
|
|
95 (cond (display-resource (intern (downcase display-resource)))
|
|
|
96 ((x-display-color-p) 'color)
|
|
|
97 ((x-display-grayscale-p) 'grayscale)
|
|
|
98 (t 'mono)))
|
|
|
99 (error 'mono))
|
|
|
100 "A symbol indicating the display Emacs is running under.
|
|
|
101 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
|
|
|
102 guesses this display attribute wrongly, either set this variable in
|
|
|
103 your `~/.emacs' or set the resource `Emacs.displayType' in your
|
|
|
104 `~/.Xdefaults'. See also `gnus-background-mode'.
|
|
|
105
|
|
|
106 This is a meta-variable that will affect what default values other
|
|
|
107 variables get. You would normally not change this variable, but
|
|
|
108 pounce directly on the real variables themselves.")
|
|
|
109
|
|
|
110 (defvar gnus-background-mode
|
|
|
111 (condition-case nil
|
|
|
112 (let ((bg-resource (x-get-resource ".backgroundMode"
|
|
|
113 "BackgroundMode"))
|
|
|
114 (params (frame-parameters)))
|
|
|
115 (cond (bg-resource (intern (downcase bg-resource)))
|
|
|
116 ((and (cdr (assq 'background-color params))
|
|
|
117 (< (apply '+ (x-color-values
|
|
|
118 (cdr (assq 'background-color params))))
|
|
|
119 (/ (apply '+ (x-color-values "white")) 3)))
|
|
|
120 'dark)
|
|
|
121 (t 'light)))
|
|
|
122 (error 'light))
|
|
|
123 "A symbol indicating the Emacs background brightness.
|
|
|
124 The symbol should be one of `light' or `dark'.
|
|
|
125 If Emacs guesses this frame attribute wrongly, either set this variable in
|
|
|
126 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
|
|
|
127 `~/.Xdefaults'.
|
|
|
128 See also `gnus-display-type'.
|
|
|
129
|
|
|
130 This is a meta-variable that will affect what default values other
|
|
|
131 variables get. You would normally not change this variable, but
|
|
|
132 pounce directly on the real variables themselves."))
|
|
|
133
|
|
|
134 (cond
|
|
|
135 ((string-match "XEmacs\\|Lucid" emacs-version)
|
|
|
136 ;; XEmacs definitions.
|
|
|
137
|
|
|
138 (setq gnus-mouse-2 [button2])
|
|
|
139
|
|
|
140 (or (memq 'underline (list-faces))
|
|
|
141 (and (fboundp 'make-face)
|
|
|
142 (funcall (intern "make-face") 'underline)))
|
|
|
143 ;; Must avoid calling set-face-underline-p directly, because it
|
|
|
144 ;; is a defsubst in emacs19, and will make the .elc files non
|
|
|
145 ;; portable!
|
|
|
146 (or (face-differs-from-default-p 'underline)
|
|
|
147 (funcall 'set-face-underline-p 'underline t))
|
|
|
148
|
|
|
149 (defalias 'gnus-make-overlay 'make-extent)
|
|
|
150 (defalias 'gnus-overlay-put 'set-extent-property)
|
|
|
151 (defun gnus-move-overlay (extent start end &optional buffer)
|
|
|
152 (set-extent-endpoints extent start end))
|
|
|
153
|
|
|
154 (require 'text-props)
|
|
|
155 (fset 'set-text-properties 'gnus-set-text-properties-xemacs)
|
|
|
156
|
|
|
157 (or (boundp 'standard-display-table) (setq standard-display-table nil))
|
|
|
158 (or (boundp 'read-event) (fset 'read-event 'next-command-event))
|
|
|
159
|
|
|
160 ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
|
|
|
161 (defvar gnus-display-type (device-class)
|
|
|
162 "A symbol indicating the display Emacs is running under.
|
|
|
163 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
|
|
|
164 guesses this display attribute wrongly, either set this variable in
|
|
|
165 your `~/.emacs' or set the resource `Emacs.displayType' in your
|
|
|
166 `~/.Xdefaults'. See also `gnus-background-mode'.
|
|
|
167
|
|
|
168 This is a meta-variable that will affect what default values other
|
|
|
169 variables get. You would normally not change this variable, but
|
|
|
170 pounce directly on the real variables themselves.")
|
|
|
171
|
|
|
172
|
|
|
173 (or (fboundp 'x-color-values)
|
|
|
174 (fset 'x-color-values
|
|
|
175 (lambda (color)
|
|
|
176 (color-instance-rgb-components
|
|
|
177 (make-color-instance color)))))
|
|
|
178
|
|
|
179 (defvar gnus-background-mode
|
|
|
180 (let ((bg-resource
|
|
|
181 (condition-case ()
|
|
|
182 (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
|
|
|
183 (error nil)))
|
|
|
184 (params (frame-parameters)))
|
|
|
185 (cond (bg-resource (intern (downcase bg-resource)))
|
|
|
186 ((and (assq 'background-color params)
|
|
|
187 (< (apply '+ (x-color-values
|
|
|
188 (cdr (assq 'background-color params))))
|
|
|
189 (/ (apply '+ (x-color-values "white")) 3)))
|
|
|
190 'dark)
|
|
|
191 (t 'light)))
|
|
|
192 "A symbol indicating the Emacs background brightness.
|
|
|
193 The symbol should be one of `light' or `dark'.
|
|
|
194 If Emacs guesses this frame attribute wrongly, either set this variable in
|
|
|
195 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
|
|
|
196 `~/.Xdefaults'.
|
|
|
197 See also `gnus-display-type'.
|
|
|
198
|
|
|
199 This is a meta-variable that will affect what default values other
|
|
|
200 variables get. You would normally not change this variable, but
|
|
|
201 pounce directly on the real variables themselves.")
|
|
|
202
|
|
|
203
|
|
|
204 (defun gnus-install-mouse-tracker ()
|
|
|
205 (require 'mode-motion)
|
|
|
206 (setq mode-motion-hook 'mode-motion-highlight-line)))
|
|
|
207
|
|
|
208 ((and (not (string-match "28.9" emacs-version))
|
|
|
209 (not (string-match "29" emacs-version)))
|
|
|
210 ;; Remove the `intangible' prop.
|
|
|
211 (let ((props (and (boundp 'gnus-hidden-properties)
|
|
|
212 gnus-hidden-properties)))
|
|
|
213 (while (and props (not (eq (car (cdr props)) 'intangible)))
|
|
|
214 (setq props (cdr props)))
|
|
|
215 (and props (setcdr props (cdr (cdr (cdr props))))))
|
|
|
216 (or (fboundp 'buffer-substring-no-properties)
|
|
|
217 (defun buffer-substring-no-properties (beg end)
|
|
|
218 (format "%s" (buffer-substring beg end)))))
|
|
|
219
|
|
|
220 ((boundp 'MULE)
|
|
|
221 (provide 'gnusutil))
|
|
|
222
|
|
|
223 )))
|
|
|
224
|
|
|
225 (eval-and-compile
|
|
|
226 (cond
|
|
|
227 ((not window-system)
|
|
|
228 (defun gnus-dummy-func (&rest args))
|
|
|
229 (let ((funcs '(mouse-set-point set-face-foreground
|
|
|
230 set-face-background x-popup-menu)))
|
|
|
231 (while funcs
|
|
|
232 (or (fboundp (car funcs))
|
|
|
233 (fset (car funcs) 'gnus-dummy-func))
|
|
|
234 (setq funcs (cdr funcs))))))
|
|
|
235 (or (fboundp 'file-regular-p)
|
|
|
236 (defun file-regular-p (file)
|
|
|
237 (and (not (file-directory-p file))
|
|
|
238 (not (file-symlink-p file))
|
|
|
239 (file-exists-p file))))
|
|
|
240 (or (fboundp 'face-list)
|
|
|
241 (defun face-list (&rest args)))
|
|
|
242 )
|
|
|
243
|
|
|
244 (defun gnus-highlight-selected-summary-xemacs ()
|
|
|
245 ;; Highlight selected article in summary buffer
|
|
|
246 (if gnus-summary-selected-face
|
|
|
247 (progn
|
|
|
248 (if gnus-newsgroup-selected-overlay
|
|
|
249 (delete-extent gnus-newsgroup-selected-overlay))
|
|
|
250 (setq gnus-newsgroup-selected-overlay
|
|
|
251 (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
|
|
|
252 (set-extent-face gnus-newsgroup-selected-overlay
|
|
|
253 gnus-summary-selected-face))))
|
|
|
254
|
|
|
255 (defun gnus-summary-recenter-xemacs ()
|
|
|
256 (let* ((top (cond ((< (window-height) 4) 0)
|
|
|
257 ((< (window-height) 7) 1)
|
|
|
258 (t 2)))
|
|
|
259 (height (- (window-height) 2))
|
|
|
260 (bottom (save-excursion (goto-char (point-max))
|
|
|
261 (forward-line (- height))
|
|
|
262 (point)))
|
|
|
263 (window (get-buffer-window (current-buffer))))
|
|
|
264 (and
|
|
|
265 ;; The user has to want it,
|
|
|
266 gnus-auto-center-summary
|
|
|
267 ;; the article buffer must be displayed,
|
|
|
268 (get-buffer-window gnus-article-buffer)
|
|
|
269 ;; Set the window start to either `bottom', which is the biggest
|
|
|
270 ;; possible valid number, or the second line from the top,
|
|
|
271 ;; whichever is the least.
|
|
|
272 (set-window-start
|
|
|
273 window (min bottom (save-excursion (forward-line (- top))
|
|
|
274 (point)))))))
|
|
|
275
|
|
|
276 (defun gnus-group-insert-group-line-info-xemacs (group)
|
|
|
277 (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
|
|
|
278 (beg (point))
|
|
|
279 active info)
|
|
|
280 (if entry
|
|
|
281 (progn
|
|
|
282 (setq info (nth 2 entry))
|
|
|
283 (gnus-group-insert-group-line
|
|
|
284 nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
|
|
|
285 (setq active (gnus-gethash group gnus-active-hashtb))
|
|
|
286
|
|
|
287 (gnus-group-insert-group-line
|
|
|
288 nil group (if (member group gnus-zombie-list) gnus-level-zombie
|
|
|
289 gnus-level-killed)
|
|
|
290 nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
|
|
|
291 (save-excursion
|
|
|
292 (goto-char beg)
|
|
|
293 (remove-text-properties
|
|
|
294 (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
|
|
|
295 '(gnus-group nil)))))
|
|
|
296
|
|
|
297 (defun gnus-summary-refer-article-xemacs (message-id)
|
|
|
298 "Refer article specified by MESSAGE-ID.
|
|
|
299 NOTE: This command only works with newsgroups that use real or simulated NNTP."
|
|
|
300 (interactive "sMessage-ID: ")
|
|
|
301 (if (or (not (stringp message-id))
|
|
|
302 (zerop (length message-id)))
|
|
|
303 ()
|
|
|
304 ;; Construct the correct Message-ID if necessary.
|
|
|
305 ;; Suggested by tale@pawl.rpi.edu.
|
|
|
306 (or (string-match "^<" message-id)
|
|
|
307 (setq message-id (concat "<" message-id)))
|
|
|
308 (or (string-match ">$" message-id)
|
|
|
309 (setq message-id (concat message-id ">")))
|
|
|
310 (let ((header (car (gnus-gethash (downcase message-id)
|
|
|
311 gnus-newsgroup-dependencies))))
|
|
|
312 (if header
|
|
|
313 (or (gnus-summary-goto-article (mail-header-number header))
|
|
|
314 ;; The header has been read, but the article had been
|
|
|
315 ;; expunged, so we insert it again.
|
|
|
316 (let ((beg (point)))
|
|
|
317 (gnus-summary-insert-line
|
|
|
318 nil header 0 nil gnus-read-mark nil nil
|
|
|
319 (mail-header-subject header))
|
|
|
320 (save-excursion
|
|
|
321 (goto-char beg)
|
|
|
322 (remove-text-properties
|
|
|
323 (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
|
|
|
324 '(gnus-number nil gnus-mark nil gnus-level nil)))
|
|
|
325 (forward-line -1)
|
|
|
326 (mail-header-number header)))
|
|
|
327 (let ((gnus-override-method gnus-refer-article-method)
|
|
|
328 (gnus-ancient-mark gnus-read-mark)
|
|
|
329 (tmp-point (window-start
|
|
|
330 (get-buffer-window gnus-article-buffer)))
|
|
|
331 number tmp-buf)
|
|
|
332 (and gnus-refer-article-method
|
|
|
333 (gnus-check-server gnus-refer-article-method))
|
|
|
334 ;; Save the old article buffer.
|
|
|
335 (save-excursion
|
|
|
336 (set-buffer gnus-article-buffer)
|
|
|
337 (gnus-kill-buffer " *temp Article*")
|
|
|
338 (setq tmp-buf (rename-buffer " *temp Article*")))
|
|
|
339 (prog1
|
|
|
340 (if (gnus-article-prepare
|
|
|
341 message-id nil (gnus-read-header message-id))
|
|
|
342 (progn
|
|
|
343 (setq number (mail-header-number gnus-current-headers))
|
|
|
344 (gnus-rebuild-thread message-id)
|
|
|
345 (gnus-summary-goto-subject number)
|
|
|
346 (gnus-summary-recenter)
|
|
|
347 (gnus-article-set-window-start
|
|
|
348 (cdr (assq number gnus-newsgroup-bookmarks)))
|
|
|
349 message-id)
|
|
|
350 ;; We restore the old article buffer.
|
|
|
351 (save-excursion
|
|
|
352 (kill-buffer gnus-article-buffer)
|
|
|
353 (set-buffer tmp-buf)
|
|
|
354 (rename-buffer gnus-article-buffer)
|
|
|
355 (let ((buffer-read-only nil))
|
|
|
356 (and tmp-point
|
|
|
357 (set-window-start (get-buffer-window (current-buffer))
|
|
|
358 tmp-point)))))))))))
|
|
|
359
|
|
|
360 (defun gnus-summary-insert-pseudos-xemacs (pslist &optional not-view)
|
|
|
361 (let ((buffer-read-only nil)
|
|
|
362 (article (gnus-summary-article-number))
|
|
|
363 b)
|
|
|
364 (or (gnus-summary-goto-subject article)
|
|
|
365 (error (format "No such article: %d" article)))
|
|
|
366 (or gnus-newsgroup-headers-hashtb-by-number
|
|
|
367 (gnus-make-headers-hashtable-by-number))
|
|
|
368 (gnus-summary-position-cursor)
|
|
|
369 ;; If all commands are to be bunched up on one line, we collect
|
|
|
370 ;; them here.
|
|
|
371 (if gnus-view-pseudos-separately
|
|
|
372 ()
|
|
|
373 (let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
|
|
|
374 files action)
|
|
|
375 (while ps
|
|
|
376 (setq action (cdr (assq 'action (car ps))))
|
|
|
377 (setq files (list (cdr (assq 'name (car ps)))))
|
|
|
378 (while (and ps (cdr ps)
|
|
|
379 (string= (or action "1")
|
|
|
380 (or (cdr (assq 'action (car (cdr ps)))) "2")))
|
|
|
381 (setq files (cons (cdr (assq 'name (car (cdr ps)))) files))
|
|
|
382 (setcdr ps (cdr (cdr ps))))
|
|
|
383 (if (not files)
|
|
|
384 ()
|
|
|
385 (if (not (string-match "%s" action))
|
|
|
386 (setq files (cons " " files)))
|
|
|
387 (setq files (cons " " files))
|
|
|
388 (and (assq 'execute (car ps))
|
|
|
389 (setcdr (assq 'execute (car ps))
|
|
|
390 (funcall (if (string-match "%s" action)
|
|
|
391 'format 'concat)
|
|
|
392 action
|
|
|
393 (mapconcat (lambda (f) f) files " ")))))
|
|
|
394 (setq ps (cdr ps)))))
|
|
|
395 (if (and gnus-view-pseudos (not not-view))
|
|
|
396 (while pslist
|
|
|
397 (and (assq 'execute (car pslist))
|
|
|
398 (gnus-execute-command (cdr (assq 'execute (car pslist)))
|
|
|
399 (eq gnus-view-pseudos 'not-confirm)))
|
|
|
400 (setq pslist (cdr pslist)))
|
|
|
401 (save-excursion
|
|
|
402 (while pslist
|
|
|
403 (gnus-summary-goto-subject (or (cdr (assq 'article (car pslist)))
|
|
|
404 (gnus-summary-article-number)))
|
|
|
405 (forward-line 1)
|
|
|
406 (setq b (point))
|
|
|
407 (insert " "
|
|
|
408 (file-name-nondirectory (cdr (assq 'name (car pslist))))
|
|
|
409 ": " (or (cdr (assq 'execute (car pslist))) "") "\n")
|
|
|
410 (add-text-properties
|
|
|
411 b (1+ b) (list 'gnus-number gnus-reffed-article-number
|
|
|
412 'gnus-mark gnus-unread-mark
|
|
|
413 'gnus-level 0
|
|
|
414 'gnus-pseudo (car pslist)))
|
|
|
415 ;; Fucking XEmacs redisplay bug with truncated lines.
|
|
|
416 (goto-char b)
|
|
|
417 (sit-for 0)
|
|
|
418 ;; Grumble.. Fucking XEmacs stickyness of text properties.
|
|
|
419 (remove-text-properties
|
|
|
420 (1+ b) (1+ (gnus-point-at-eol))
|
|
|
421 '(gnus-number nil gnus-mark nil gnus-level nil))
|
|
|
422 (forward-line -1)
|
|
|
423 (gnus-sethash (int-to-string gnus-reffed-article-number)
|
|
|
424 (car pslist) gnus-newsgroup-headers-hashtb-by-number)
|
|
|
425 (setq gnus-reffed-article-number (1- gnus-reffed-article-number))
|
|
|
426 (setq pslist (cdr pslist)))))))
|
|
|
427
|
|
|
428
|
|
|
429 (defun gnus-copy-article-buffer-xemacs (&optional article-buffer)
|
|
|
430 (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
|
|
|
431 (buffer-disable-undo gnus-article-copy)
|
|
|
432 (or (memq gnus-article-copy gnus-buffer-list)
|
|
|
433 (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
|
|
|
434 (let ((article-buffer (or article-buffer gnus-article-buffer))
|
|
|
435 buf)
|
|
|
436 (if (and (get-buffer article-buffer)
|
|
|
437 (buffer-name (get-buffer article-buffer)))
|
|
|
438 (save-excursion
|
|
|
439 (set-buffer article-buffer)
|
|
|
440 (widen)
|
|
|
441 (setq buf (buffer-substring (point-min) (point-max)))
|
|
|
442 (set-buffer gnus-article-copy)
|
|
|
443 (erase-buffer)
|
|
|
444 (insert (format "%s" buf))))))
|
|
|
445
|
|
|
446 (defun gnus-article-push-button-xemacs (event)
|
|
|
447 "Check text under the mouse pointer for a callback function.
|
|
|
448 If the text under the mouse pointer has a `gnus-callback' property,
|
|
|
449 call it with the value of the `gnus-data' text property."
|
|
|
450 (interactive "e")
|
|
|
451 (set-buffer (window-buffer (event-window event)))
|
|
|
452 (let* ((pos (event-closest-point event))
|
|
|
453 (data (get-text-property pos 'gnus-data))
|
|
|
454 (fun (get-text-property pos 'gnus-callback)))
|
|
|
455 (if fun (funcall fun data))))
|
|
|
456
|
|
|
457 ;; Re-build the thread containing ID.
|
|
|
458 (defun gnus-rebuild-thread-xemacs (id)
|
|
|
459 (let ((dep gnus-newsgroup-dependencies)
|
|
|
460 (buffer-read-only nil)
|
|
|
461 parent headers refs thread art)
|
|
|
462 (while (and id (setq headers
|
|
|
463 (car (setq art (gnus-gethash (downcase id)
|
|
|
464 dep)))))
|
|
|
465 (setq parent art)
|
|
|
466 (setq id (and (setq refs (mail-header-references headers))
|
|
|
467 (string-match "\\(<[^>]+>\\) *$" refs)
|
|
|
468 (substring refs (match-beginning 1) (match-end 1)))))
|
|
|
469 (setq thread (gnus-make-sub-thread (car parent)))
|
|
|
470 (gnus-rebuild-remove-articles thread)
|
|
|
471 (let ((beg (point)))
|
|
|
472 (gnus-summary-prepare-threads (list thread) 0)
|
|
|
473 (save-excursion
|
|
|
474 (while (and (>= (point) beg)
|
|
|
475 (not (bobp)))
|
|
|
476 (or (eobp)
|
|
|
477 (remove-text-properties
|
|
|
478 (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
|
|
|
479 '(gnus-number nil gnus-mark nil gnus-level nil)))
|
|
|
480 (forward-line -1)))
|
|
|
481 (gnus-summary-update-lines beg (point)))))
|
|
|
482
|
|
|
483
|
|
|
484 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
|
|
|
485 (defun gnus-article-add-button-xemacs (from to fun &optional data)
|
|
|
486 "Create a button between FROM and TO with callback FUN and data DATA."
|
|
|
487 (and gnus-article-button-face
|
|
|
488 (gnus-overlay-put (gnus-make-overlay from to) 'face gnus-article-button-face))
|
|
|
489 (add-text-properties from to
|
|
|
490 (append
|
|
|
491 (and gnus-article-mouse-face
|
|
|
492 (list 'mouse-face gnus-article-mouse-face))
|
|
|
493 (list 'gnus-callback fun)
|
|
|
494 (and data (list 'gnus-data data))
|
|
|
495 (list 'highlight t))))
|
|
|
496
|
|
|
497 (defun gnus-window-top-edge-xemacs (&optional window)
|
|
|
498 (nth 1 (window-pixel-edges window)))
|
|
|
499
|
|
|
500 ;; Select the lowest window on the frame.
|
|
|
501 (defun gnus-appt-select-lowest-window-xemacs ()
|
|
|
502 (let* ((lowest-window (selected-window))
|
|
|
503 (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
|
|
|
504 (last-window (previous-window))
|
|
|
505 (window-search t))
|
|
|
506 (while window-search
|
|
|
507 (let* ((this-window (next-window))
|
|
|
508 (next-bottom-edge (car (cdr (cdr (cdr
|
|
|
509 (window-pixel-edges
|
|
|
510 this-window)))))))
|
|
|
511 (if (< bottom-edge next-bottom-edge)
|
|
|
512 (progn
|
|
|
513 (setq bottom-edge next-bottom-edge)
|
|
|
514 (setq lowest-window this-window)))
|
|
|
515
|
|
|
516 (select-window this-window)
|
|
|
517 (if (eq last-window this-window)
|
|
|
518 (progn
|
|
|
519 (select-window lowest-window)
|
|
|
520 (setq window-search nil)))))))
|
|
|
521
|
|
|
522 (defun gnus-ems-redefine ()
|
|
|
523 (cond
|
|
|
524 ((string-match "XEmacs\\|Lucid" emacs-version)
|
|
|
525 ;; XEmacs definitions.
|
|
|
526 (fset 'gnus-mouse-face-function 'identity)
|
|
|
527 (fset 'gnus-summary-make-display-table (lambda () nil))
|
|
|
528 (fset 'gnus-visual-turn-off-edit-menu 'identity)
|
|
|
529 (fset 'gnus-highlight-selected-summary
|
|
|
530 'gnus-highlight-selected-summary-xemacs)
|
|
|
531 (fset 'gnus-summary-recenter 'gnus-summary-recenter-xemacs)
|
|
|
532 (fset 'gnus-group-insert-group-line-info
|
|
|
533 'gnus-group-insert-group-line-info-xemacs)
|
|
|
534 (fset 'gnus-copy-article-buffer 'gnus-copy-article-buffer-xemacs)
|
|
|
535 (fset 'gnus-summary-refer-article 'gnus-summary-refer-article-xemacs)
|
|
|
536 (fset 'gnus-summary-insert-pseudos 'gnus-summary-insert-pseudos-xemacs)
|
|
|
537 (fset 'gnus-article-push-button 'gnus-article-push-button-xemacs)
|
|
|
538 (fset 'gnus-rebuild-thread 'gnus-rebuild-thread-xemacs)
|
|
|
539 (fset 'gnus-article-add-button 'gnus-article-add-button-xemacs)
|
|
|
540 (fset 'gnus-window-top-edge 'gnus-window-top-edge-xemacs)
|
|
|
541 (fset 'set-text-properties 'gnus-set-text-properties-xemacs)
|
|
|
542
|
|
|
543 (or (fboundp 'appt-select-lowest-window)
|
|
|
544 (fset 'appt-select-lowest-window
|
|
|
545 'gnus-appt-select-lowest-window-xemacs))
|
|
|
546
|
|
|
547 (if (not gnus-visual)
|
|
|
548 ()
|
|
|
549 (setq gnus-group-mode-hook
|
|
|
550 (cons
|
|
|
551 '(lambda ()
|
|
|
552 (easy-menu-add gnus-group-reading-menu)
|
|
|
553 (easy-menu-add gnus-group-group-menu)
|
|
|
554 (easy-menu-add gnus-group-misc-menu)
|
|
|
555 (gnus-install-mouse-tracker))
|
|
|
556 gnus-group-mode-hook))
|
|
|
557 (setq gnus-summary-mode-hook
|
|
|
558 (cons
|
|
|
559 '(lambda ()
|
|
|
560 (easy-menu-add gnus-summary-article-menu)
|
|
|
561 (easy-menu-add gnus-summary-thread-menu)
|
|
|
562 (easy-menu-add gnus-summary-misc-menu)
|
|
|
563 (easy-menu-add gnus-summary-post-menu)
|
|
|
564 (easy-menu-add gnus-summary-kill-menu)
|
|
|
565 (gnus-install-mouse-tracker))
|
|
|
566 gnus-summary-mode-hook))
|
|
|
567 (setq gnus-article-mode-hook
|
|
|
568 (cons
|
|
|
569 '(lambda ()
|
|
|
570 (easy-menu-add gnus-article-article-menu)
|
|
|
571 (easy-menu-add gnus-article-treatment-menu))
|
|
|
572 gnus-article-mode-hook)))
|
|
|
573
|
|
|
574 (defvar gnus-logo (make-glyph (make-specifier 'image)))
|
|
|
575
|
|
|
576 (defun gnus-group-startup-xmessage (&optional x y)
|
|
|
577 "Insert startup message in current buffer."
|
|
|
578 ;; Insert the message.
|
|
|
579 (erase-buffer)
|
|
|
580 (if (featurep 'xpm)
|
|
|
581 (progn
|
|
|
582 (set-glyph-property gnus-logo 'image "~/tmp/gnus.xpm")
|
|
|
583 (set-glyph-image gnus-logo "~/tmp/gnus.xpm" 'global 'x)
|
|
|
584
|
|
|
585 (insert " ")
|
|
|
586 (set-extent-begin-glyph (make-extent (point) (point)) gnus-logo)
|
|
|
587 (insert "
|
|
|
588 Gnus * A newsreader for Emacsen
|
|
|
589 A Praxis Release * larsi@ifi.uio.no")
|
|
|
590 (goto-char (point-min))
|
|
|
591 (while (not (eobp))
|
|
|
592 (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
|
|
|
593 ? ))
|
|
|
594 (forward-line 1))
|
|
|
595 (goto-char (point-min))
|
|
|
596 ;; +4 is fuzzy factor.
|
|
|
597 (insert-char ?\n (/ (max (- (window-height) (or y 24)) 0) 2)))
|
|
|
598
|
|
|
599 (insert
|
|
|
600 (format "
|
|
|
601 %s
|
|
|
602 A newsreader
|
|
|
603 for GNU Emacs
|
|
|
604
|
|
|
605 Based on GNUS
|
|
|
606 written by
|
|
|
607 Masanobu UMEDA
|
|
|
608
|
|
|
609 A Praxis Release
|
|
|
610 larsi@ifi.uio.no
|
|
|
611 "
|
|
|
612 gnus-version))
|
|
|
613 ;; And then hack it.
|
|
|
614 ;; 18 is the longest line.
|
|
|
615 (indent-rigidly (point-min) (point-max)
|
|
|
616 (/ (max (- (window-width) (or x 28)) 0) 2))
|
|
|
617 (goto-char (point-min))
|
|
|
618 ;; +4 is fuzzy factor.
|
|
|
619 (insert-char ?\n (/ (max (- (window-height) (or y 12)) 0) 2)))
|
|
|
620
|
|
|
621 ;; Fontify some.
|
|
|
622 (goto-char (point-min))
|
|
|
623 (search-forward "Praxis")
|
|
|
624 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)
|
|
|
625 (goto-char (point-min)))
|
|
|
626
|
|
|
627
|
|
|
628
|
|
|
629 )
|
|
|
630
|
|
|
631 ((boundp 'MULE)
|
|
|
632 ;; Mule definitions
|
|
|
633 (if (not (fboundp 'truncate-string))
|
|
|
634 (defun truncate-string (str width)
|
|
|
635 (let ((w (string-width str))
|
|
|
636 (col 0) (idx 0) (p-idx 0) chr)
|
|
|
637 (if (<= w width)
|
|
|
638 str
|
|
|
639 (while (< col width)
|
|
|
640 (setq chr (aref str idx)
|
|
|
641 col (+ col (char-width chr))
|
|
|
642 p-idx idx
|
|
|
643 idx (+ idx (char-bytes chr))
|
|
|
644 ))
|
|
|
645 (substring str 0 (if (= col width)
|
|
|
646 idx
|
|
|
647 p-idx))
|
|
|
648 )))
|
|
|
649 )
|
|
|
650 (defalias 'gnus-truncate-string 'truncate-string)
|
|
|
651
|
|
|
652 (defun gnus-cite-add-face (number prefix face)
|
|
|
653 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
|
|
|
654 (if face
|
|
|
655 (let ((inhibit-point-motion-hooks t)
|
|
|
656 from to)
|
|
|
657 (goto-line number)
|
|
|
658 (if (boundp 'MULE)
|
|
|
659 (forward-char (chars-in-string prefix))
|
|
|
660 (forward-char (length prefix)))
|
|
|
661 (skip-chars-forward " \t")
|
|
|
662 (setq from (point))
|
|
|
663 (end-of-line 1)
|
|
|
664 (skip-chars-backward " \t")
|
|
|
665 (setq to (point))
|
|
|
666 (if (< from to)
|
|
|
667 (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
|
|
|
668
|
|
|
669 (defun gnus-max-width-function (el max-width)
|
|
|
670 (` (let* ((val (eval (, el)))
|
|
|
671 (valstr (if (numberp val)
|
|
|
672 (int-to-string val) val)))
|
|
|
673 (if (> (length valstr) (, max-width))
|
|
|
674 (truncate-string valstr (, max-width))
|
|
|
675 valstr))))
|
|
|
676
|
|
|
677 (fset 'gnus-summary-make-display-table (lambda () nil))
|
|
|
678
|
|
|
679 (if (boundp 'gnus-check-before-posting)
|
|
|
680 (setq gnus-check-before-posting
|
|
|
681 (delq 'long-lines
|
|
|
682 (delq 'control-chars gnus-check-before-posting)))
|
|
|
683 )
|
|
|
684 )
|
|
|
685 ))
|
|
|
686
|
|
|
687 (provide 'gnus-ems)
|
|
|
688
|
|
|
689 ;; Local Variables:
|
|
|
690 ;; byte-compile-warnings: '(redefine callargs)
|
|
|
691 ;; End:
|
|
|
692
|
|
|
693 ;;; gnus-ems.el ends here
|
