1 ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
7 ;; This file is part of GNU Emacs.
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)
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.
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.
27 (defvar gnus-mouse-2 [mouse-2])
28 (defvar gnus-easymenu 'easymenu)
29 (defvar gnus-group-mode-hook ())
30 (defvar gnus-summary-mode-hook ())
31 (defvar gnus-article-mode-hook ())
33 ;; We do not byte-compile this file, because error messages are such a
38 ((string-match "XEmacs\\|Lucid" emacs-version)
39 ;; XEmacs definitions.
41 (defvar gnus-summary-highlight
42 '(((> score default) . bold)
43 ((< score default) . italic))
44 "*Alist of `(FORM . FACE)'.
45 Summary lines are highlighted with the FACE for the first FORM which
46 evaluate to a non-nil value.
48 Point will be at the beginning of the line when FORM is evaluated.
49 The following can be used for convenience:
51 score: (gnus-summary-article-score)
52 default: gnus-summary-default-score
53 below: gnus-summary-mark-below
55 To check for marks, e.g. to underline replied articles, use
56 `gnus-summary-article-mark':
58 ((= (gnus-summary-article-mark) gnus-replied-mark) . underline)")
60 (setq gnus-mouse-2 [button2])
61 (setq gnus-easymenu 'auc-menu)
63 (or (memq 'underline (list-faces))
64 (funcall (intern "make-face") 'underline))
65 ;; Must avoid calling set-face-underline-p directly, because it
66 ;; is a defsubst in emacs19, and will make the .elc files non
68 (or (face-differs-from-default-p 'underline)
69 (funcall 'set-face-underline-p 'underline t))
70 (or (fboundp 'set-text-properties)
71 (defun set-text-properties (start end props &optional buffer)
72 (if (or (null buffer) (bufferp buffer))
76 start end (car props) (nth 1 props) buffer)
77 (setq props (nthcdr 2 props)))
78 (remove-text-properties start end ())))))
80 (or (fboundp 'make-overlay) (fset 'make-overlay 'make-extent))
81 (or (fboundp 'overlay-put) (fset 'overlay-put 'set-extent-property))
82 (or (fboundp 'move-overlay)
83 (defun move-overlay (extent start end &optional buffer)
84 (set-extent-endpoints extent start end)))
85 (or (boundp 'standard-display-table) (setq standard-display-table nil))
86 (or (boundp 'read-event) (fset 'read-event 'next-command-event))
88 (setq gnus-display-type
89 (let ((display-resource
90 (x-get-resource ".displayType" "DisplayType" 'string)))
91 (cond (display-resource (intern (downcase display-resource)))
92 ((x-display-color-p) 'color)
93 ((x-display-grayscale-p) 'grayscale)
96 (setq gnus-background-mode
98 (x-get-resource ".backgroundMode" "BackgroundMode" 'string))
99 (params (frame-parameters)))
100 (cond (bg-resource (intern (downcase bg-resource)))
101 ; ((< (apply '+ (x-color-values
102 ; (cdr (assq 'background-color params))))
103 ; (/ (apply '+ (x-color-values "white")) 3))
107 (if (not gnus-visual)
109 (setq gnus-group-mode-hook
112 (easy-menu-add gnus-group-reading-menu)
113 (easy-menu-add gnus-group-group-menu)
114 (easy-menu-add gnus-group-post-menu)
115 (easy-menu-add gnus-group-misc-menu)
116 (gnus-install-mouse-tracker))
117 gnus-group-mode-hook))
118 (setq gnus-summary-mode-hook
121 (easy-menu-add gnus-summary-mark-menu)
122 (easy-menu-add gnus-summary-move-menu)
123 (easy-menu-add gnus-summary-article-menu)
124 (easy-menu-add gnus-summary-thread-menu)
125 (easy-menu-add gnus-summary-misc-menu)
126 (easy-menu-add gnus-summary-post-menu)
127 (easy-menu-add gnus-summary-kill-menu)
128 (gnus-install-mouse-tracker))
129 gnus-summary-mode-hook))
130 (setq gnus-article-mode-hook
133 (easy-menu-add gnus-article-article-menu)
134 (easy-menu-add gnus-article-treatment-menu))
135 gnus-article-mode-hook)))
137 (defun gnus-install-mouse-tracker ()
138 (require 'mode-motion)
139 (setq mode-motion-hook 'mode-motion-highlight-line)))
141 ((and (not (string-match "28.9" emacs-version))
142 (not (string-match "29" emacs-version)))
143 (setq gnus-hidden-properties '(invisible t))
144 (or (fboundp 'buffer-substring-no-properties)
145 (defun buffer-substring-no-properties (beg end)
146 (format "%s" (buffer-substring beg end)))))
156 (defun gnus-dummy-func (&rest args))
157 (let ((funcs '(mouse-set-point set-face-foreground
158 set-face-background x-popup-menu)))
160 (or (fboundp (car funcs))
161 (fset (car funcs) 'gnus-dummy-func))
162 (setq funcs (cdr funcs))))))
163 (or (fboundp 'file-regular-p)
164 (defun file-regular-p (file)
165 (and (not (file-directory-p file))
166 (not (file-symlink-p file))
167 (file-exists-p file))))
168 (or (fboundp 'face-list)
169 (defun face-list (&rest args)))
172 (defun gnus-ems-redefine ()
174 ((string-match "XEmacs\\|Lucid" emacs-version)
175 ;; XEmacs definitions.
176 (fset 'gnus-set-mouse-face 'identity)
177 (fset 'gnus-summary-make-display-table (lambda () nil))
178 (fset 'gnus-visual-turn-off-edit-menu 'identity)
180 (defun gnus-highlight-selected-summary ()
181 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
182 ;; Highlight selected article in summary buffer
183 (if gnus-summary-selected-face
185 (let* ((beg (progn (beginning-of-line) (point)))
186 (end (progn (end-of-line) (point)))
187 (to (max 1 (1- (or (previous-single-property-change
188 end 'mouse-face nil beg) end))))
189 (from (1+ (or (next-single-property-change
190 beg 'mouse-face nil end) beg))))
195 (if gnus-newsgroup-selected-overlay
196 (delete-extent gnus-newsgroup-selected-overlay))
197 (setq gnus-newsgroup-selected-overlay
198 (make-extent from to))
199 (set-extent-face gnus-newsgroup-selected-overlay
200 gnus-summary-selected-face)))))
203 (defun gnus-summary-recenter ()
204 (let* ((top (cond ((< (window-height) 4) 0)
205 ((< (window-height) 7) 1)
207 (height (- (window-height) 2))
208 (bottom (save-excursion (goto-char (point-max))
209 (forward-line (- height))
211 (window (get-buffer-window (current-buffer))))
213 ;; The user has to want it,
214 gnus-auto-center-summary
215 ;; the article buffer must be displayed,
216 (get-buffer-window gnus-article-buffer)
217 ;; Set the window start to either `bottom', which is the biggest
218 ;; possible valid number, or the second line from the top,
219 ;; whichever is the least.
221 window (min bottom (save-excursion (forward-line (- top))
224 (defun gnus-group-insert-group-line-info (group)
225 (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
230 (setq info (nth 2 entry))
231 (gnus-group-insert-group-line
232 nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
233 (setq active (gnus-gethash group gnus-active-hashtb))
235 (gnus-group-insert-group-line
236 nil group (if (member group gnus-zombie-list) gnus-level-zombie
238 nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
241 (remove-text-properties
242 (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
243 '(gnus-group nil)))))
245 (defun gnus-copy-article-buffer (&optional article-buffer)
246 (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
247 (buffer-disable-undo gnus-article-copy)
248 (or (memq gnus-article-copy gnus-buffer-list)
249 (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
250 (let ((article-buffer (or article-buffer gnus-article-buffer))
252 (if (and (get-buffer article-buffer)
253 (buffer-name (get-buffer article-buffer)))
255 (set-buffer article-buffer)
257 (setq buf (buffer-substring (point-min) (point-max)))
258 (set-buffer gnus-article-copy)
260 (insert (format "%s" buf))))))
262 (defun gnus-summary-refer-article (message-id)
263 "Refer article specified by MESSAGE-ID.
264 NOTE: This command only works with newsgroups that use real or simulated NNTP."
265 (interactive "sMessage-ID: ")
266 (if (or (not (stringp message-id))
267 (zerop (length message-id)))
269 ;; Construct the correct Message-ID if necessary.
270 ;; Suggested by tale@pawl.rpi.edu.
271 (or (string-match "^<" message-id)
272 (setq message-id (concat "<" message-id)))
273 (or (string-match ">$" message-id)
274 (setq message-id (concat message-id ">")))
275 (let ((header (car (gnus-gethash (downcase message-id)
276 gnus-newsgroup-dependencies))))
278 (or (gnus-summary-goto-article (header-number header))
279 ;; The header has been read, but the article had been
280 ;; expunged, so we insert it again.
282 (gnus-summary-insert-line
283 nil header 0 nil gnus-read-mark nil nil
284 (header-subject header))
287 (remove-text-properties
288 (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
289 '(gnus-number nil gnus-mark nil gnus-level nil)))
291 (header-number header)))
292 (let ((gnus-override-method gnus-refer-article-method)
293 (gnus-ancient-mark gnus-read-mark)
294 (tmp-buf (get-buffer-create " *gnus refer"))
295 (tmp-point (window-start
296 (get-buffer-window gnus-article-buffer)))
298 (and gnus-refer-article-method
299 (or (gnus-server-opened gnus-refer-article-method)
300 (gnus-open-server gnus-refer-article-method)))
301 ;; Save the old article buffer.
304 (buffer-disable-undo (current-buffer))
305 (insert-buffer-substring gnus-article-buffer))
307 (if (gnus-article-prepare
308 message-id nil (gnus-read-header message-id))
310 (setq number (header-number gnus-current-headers))
311 (gnus-rebuild-thread message-id)
312 (gnus-summary-goto-subject number)
313 (gnus-summary-recenter)
314 (gnus-article-set-window-start
315 (cdr (assq number gnus-newsgroup-bookmarks)))
317 ;; We restore the old article buffer.
319 (set-buffer gnus-article-buffer)
320 (let ((buffer-read-only nil))
321 (insert-buffer-substring tmp-buf)
323 (set-window-start (get-buffer-window (current-buffer))
326 (kill-buffer tmp-buf)))))))
328 (defun gnus-summary-insert-pseudos (pslist &optional not-view)
329 (let ((buffer-read-only nil)
330 (article (gnus-summary-article-number))
332 (or (gnus-summary-goto-subject article)
333 (error (format "No such article: %d" article)))
334 (or gnus-newsgroup-headers-hashtb-by-number
335 (gnus-make-headers-hashtable-by-number))
336 (gnus-summary-position-cursor)
337 ;; If all commands are to be bunched up on one line, we collect
339 (if gnus-view-pseudos-separately
341 (let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
344 (setq action (cdr (assq 'action (car ps))))
345 (setq files (list (cdr (assq 'name (car ps)))))
346 (while (and ps (cdr ps)
347 (string= (or action "1")
348 (or (cdr (assq 'action (car (cdr ps)))) "2")))
349 (setq files (cons (cdr (assq 'name (car (cdr ps)))) files))
350 (setcdr ps (cdr (cdr ps))))
353 (if (not (string-match "%s" action))
354 (setq files (cons " " files)))
355 (setq files (cons " " files))
356 (and (assq 'execute (car ps))
357 (setcdr (assq 'execute (car ps))
358 (funcall (if (string-match "%s" action)
361 (mapconcat (lambda (f) f) files " ")))))
362 (setq ps (cdr ps)))))
363 (if (and gnus-view-pseudos (not not-view))
365 (and (assq 'execute (car pslist))
366 (gnus-execute-command (cdr (assq 'execute (car pslist)))
367 (eq gnus-view-pseudos 'not-confirm)))
368 (setq pslist (cdr pslist)))
371 (gnus-summary-goto-subject (or (cdr (assq 'article (car pslist)))
372 (gnus-summary-article-number)))
375 (insert " " (file-name-nondirectory
376 (cdr (assq 'name (car pslist))))
377 ": " (or (cdr (assq 'execute (car pslist))) "") "\n")
379 b (1+ b) (list 'gnus-number gnus-reffed-article-number
380 'gnus-mark gnus-unread-mark
382 'gnus-pseudo (car pslist)))
383 (remove-text-properties (b) (gnus-point-at-eol)
384 '(gnus-number nil gnus-mark nil gnus-level nil))
386 (gnus-sethash (int-to-string gnus-reffed-article-number)
387 (car pslist) gnus-newsgroup-headers-hashtb-by-number)
388 (setq gnus-reffed-article-number (1- gnus-reffed-article-number))
389 (setq pslist (cdr pslist)))))))
392 (defun gnus-article-push-button (event)
393 "Check text under the mouse pointer for a callback function.
394 If the text under the mouse pointer has a `gnus-callback' property,
395 call it with the value of the `gnus-data' text property."
397 (set-buffer (window-buffer (event-window event)))
398 (let* ((pos (event-closest-point event))
399 (data (get-text-property pos 'gnus-data))
400 (fun (get-text-property pos 'gnus-callback)))
401 (if fun (funcall fun data))))
407 (if (not (fboundp 'truncate-string))
408 (defun truncate-string (str width)
409 (let ((w (string-width str))
410 (col 0) (idx 0) (p-idx 0) chr)
414 (setq chr (aref str idx)
415 col (+ col (char-width chr))
417 idx (+ idx (char-bytes chr))
419 (substring str 0 (if (= col width)
424 (defalias 'gnus-truncate-string 'truncate-string)
426 (defun gnus-cite-add-face (number prefix face)
427 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
429 (let ((inhibit-point-motion-hooks t)
433 (forward-char (chars-in-string prefix))
434 (forward-char (length prefix)))
435 (skip-chars-forward " \t")
438 (skip-chars-backward " \t")
441 (overlay-put (make-overlay from to) 'face face)))))
444 'gnus-format-max-width
445 (lambda (form length)
446 (let* ((val (eval form))
447 (valstr (if (numberp val) (int-to-string val) val)))
448 (if (> (length valstr) length)
449 (truncate-string valstr length)
452 (fset 'gnus-summary-make-display-table (lambda () nil))
459 ;; byte-compile-warnings: nil
462 ;;; gnus-ems.el ends here