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 (if (string-match "XEmacs\\|Lucid" emacs-version)
40 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
41 (defvar gnus-display-type
43 (let ((display-resource (x-get-resource ".displayType" "DisplayType")))
44 (cond (display-resource (intern (downcase display-resource)))
45 ((x-display-color-p) 'color)
46 ((x-display-grayscale-p) 'grayscale)
49 "A symbol indicating the display Emacs is running under.
50 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
51 guesses this display attribute wrongly, either set this variable in
52 your `~/.emacs' or set the resource `Emacs.displayType' in your
53 `~/.Xdefaults'. See also `gnus-background-mode'.
55 This is a meta-variable that will affect what default values other
56 variables get. You would normally not change this variable, but
57 pounce directly on the real variables themselves.")
59 (defvar gnus-background-mode
61 (let ((bg-resource (x-get-resource ".backgroundMode"
63 (params (frame-parameters)))
64 (cond (bg-resource (intern (downcase bg-resource)))
65 ((and (cdr (assq 'background-color params))
66 (< (apply '+ (x-color-values
67 (cdr (assq 'background-color params))))
68 (/ (apply '+ (x-color-values "white")) 3)))
72 "A symbol indicating the Emacs background brightness.
73 The symbol should be one of `light' or `dark'.
74 If Emacs guesses this frame attribute wrongly, either set this variable in
75 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
77 See also `gnus-display-type'.
79 This is a meta-variable that will affect what default values other
80 variables get. You would normally not change this variable, but
81 pounce directly on the real variables themselves."))
84 ((string-match "XEmacs\\|Lucid" emacs-version)
85 ;; XEmacs definitions.
87 (setq gnus-mouse-2 [button2])
88 (setq gnus-easymenu 'auc-menu)
90 (or (memq 'underline (list-faces))
91 (funcall (intern "make-face") 'underline))
92 ;; Must avoid calling set-face-underline-p directly, because it
93 ;; is a defsubst in emacs19, and will make the .elc files non
95 (or (face-differs-from-default-p 'underline)
96 (funcall 'set-face-underline-p 'underline t))
97 (or (fboundp 'set-text-properties)
98 (defun set-text-properties (start end props &optional buffer)
99 (if (or (null buffer) (bufferp buffer))
103 start end (car props) (nth 1 props) buffer)
104 (setq props (nthcdr 2 props)))
105 (remove-text-properties start end ())))))
107 (or (fboundp 'make-overlay) (fset 'make-overlay 'make-extent))
108 (or (fboundp 'overlay-put) (fset 'overlay-put 'set-extent-property))
109 (or (fboundp 'move-overlay)
110 (defun move-overlay (extent start end &optional buffer)
111 (set-extent-endpoints extent start end)))
112 (or (boundp 'standard-display-table) (setq standard-display-table nil))
113 (or (boundp 'read-event) (fset 'read-event 'next-command-event))
115 ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
116 (defvar gnus-display-type (device-class)
117 "A symbol indicating the display Emacs is running under.
118 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
119 guesses this display attribute wrongly, either set this variable in
120 your `~/.emacs' or set the resource `Emacs.displayType' in your
121 `~/.Xdefaults'. See also `gnus-background-mode'.
123 This is a meta-variable that will affect what default values other
124 variables get. You would normally not change this variable, but
125 pounce directly on the real variables themselves.")
128 (or (fboundp 'x-color-values)
129 (fset 'x-color-values
131 (color-instance-rgb-components
132 (make-color-instance color)))))
134 (defvar gnus-background-mode
136 (x-get-resource ".backgroundMode" "BackgroundMode" 'string))
137 (params (frame-parameters)))
138 (cond (bg-resource (intern (downcase bg-resource)))
139 ((and (assq 'background-color params)
140 (< (apply '+ (x-color-values
141 (cdr (assq 'background-color params))))
142 (/ (apply '+ (x-color-values "white")) 3)))
145 "A symbol indicating the Emacs background brightness.
146 The symbol should be one of `light' or `dark'.
147 If Emacs guesses this frame attribute wrongly, either set this variable in
148 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
150 See also `gnus-display-type'.
152 This is a meta-variable that will affect what default values other
153 variables get. You would normally not change this variable, but
154 pounce directly on the real variables themselves.")
157 (defun gnus-install-mouse-tracker ()
158 (require 'mode-motion)
159 (setq mode-motion-hook 'mode-motion-highlight-line)))
161 ((and (not (string-match "28.9" emacs-version))
162 (not (string-match "29" emacs-version)))
163 (setq gnus-hidden-properties '(invisible t))
164 (or (fboundp 'buffer-substring-no-properties)
165 (defun buffer-substring-no-properties (beg end)
166 (format "%s" (buffer-substring beg end)))))
176 (defun gnus-dummy-func (&rest args))
177 (let ((funcs '(mouse-set-point set-face-foreground
178 set-face-background x-popup-menu)))
180 (or (fboundp (car funcs))
181 (fset (car funcs) 'gnus-dummy-func))
182 (setq funcs (cdr funcs))))))
183 (or (fboundp 'file-regular-p)
184 (defun file-regular-p (file)
185 (and (not (file-directory-p file))
186 (not (file-symlink-p file))
187 (file-exists-p file))))
188 (or (fboundp 'face-list)
189 (defun face-list (&rest args)))
192 (defun gnus-ems-redefine ()
194 ((string-match "XEmacs\\|Lucid" emacs-version)
195 ;; XEmacs definitions.
196 (fset 'gnus-mouse-face-function 'identity)
197 (fset 'gnus-summary-make-display-table (lambda () nil))
198 (fset 'gnus-visual-turn-off-edit-menu 'identity)
200 (defun gnus-highlight-selected-summary ()
201 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
202 ;; Highlight selected article in summary buffer
203 (if gnus-summary-selected-face
205 (let* ((beg (progn (beginning-of-line) (point)))
206 (end (progn (end-of-line) (point)))
207 (to (max 1 (1- (or (previous-single-property-change
208 end 'mouse-face nil beg) end))))
209 (from (1+ (or (next-single-property-change
210 beg 'mouse-face nil end) beg))))
215 (if gnus-newsgroup-selected-overlay
216 (delete-extent gnus-newsgroup-selected-overlay))
217 (setq gnus-newsgroup-selected-overlay
218 (make-extent from to))
219 (set-extent-face gnus-newsgroup-selected-overlay
220 gnus-summary-selected-face)))))
223 (defun gnus-summary-recenter ()
224 (let* ((top (cond ((< (window-height) 4) 0)
225 ((< (window-height) 7) 1)
227 (height (- (window-height) 2))
228 (bottom (save-excursion (goto-char (point-max))
229 (forward-line (- height))
231 (window (get-buffer-window (current-buffer))))
233 ;; The user has to want it,
234 gnus-auto-center-summary
235 ;; the article buffer must be displayed,
236 (get-buffer-window gnus-article-buffer)
237 ;; Set the window start to either `bottom', which is the biggest
238 ;; possible valid number, or the second line from the top,
239 ;; whichever is the least.
241 window (min bottom (save-excursion (forward-line (- top))
244 (defun gnus-group-insert-group-line-info (group)
245 (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
250 (setq info (nth 2 entry))
251 (gnus-group-insert-group-line
252 nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
253 (setq active (gnus-gethash group gnus-active-hashtb))
255 (gnus-group-insert-group-line
256 nil group (if (member group gnus-zombie-list) gnus-level-zombie
258 nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
261 (remove-text-properties
262 (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
263 '(gnus-group nil)))))
265 (defun gnus-copy-article-buffer (&optional article-buffer)
266 (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
267 (buffer-disable-undo gnus-article-copy)
268 (or (memq gnus-article-copy gnus-buffer-list)
269 (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
270 (let ((article-buffer (or article-buffer gnus-article-buffer))
272 (if (and (get-buffer article-buffer)
273 (buffer-name (get-buffer article-buffer)))
275 (set-buffer article-buffer)
277 (setq buf (buffer-substring (point-min) (point-max)))
278 (set-buffer gnus-article-copy)
280 (insert (format "%s" buf))))))
282 (defun gnus-summary-refer-article (message-id)
283 "Refer article specified by MESSAGE-ID.
284 NOTE: This command only works with newsgroups that use real or simulated NNTP."
285 (interactive "sMessage-ID: ")
286 (if (or (not (stringp message-id))
287 (zerop (length message-id)))
289 ;; Construct the correct Message-ID if necessary.
290 ;; Suggested by tale@pawl.rpi.edu.
291 (or (string-match "^<" message-id)
292 (setq message-id (concat "<" message-id)))
293 (or (string-match ">$" message-id)
294 (setq message-id (concat message-id ">")))
295 (let ((header (car (gnus-gethash (downcase message-id)
296 gnus-newsgroup-dependencies))))
298 (or (gnus-summary-goto-article (header-number header))
299 ;; The header has been read, but the article had been
300 ;; expunged, so we insert it again.
302 (gnus-summary-insert-line
303 nil header 0 nil gnus-read-mark nil nil
304 (header-subject header))
307 (remove-text-properties
308 (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
309 '(gnus-number nil gnus-mark nil gnus-level nil)))
311 (header-number header)))
312 (let ((gnus-override-method gnus-refer-article-method)
313 (gnus-ancient-mark gnus-read-mark)
314 (tmp-buf (get-buffer-create " *gnus refer"))
315 (tmp-point (window-start
316 (get-buffer-window gnus-article-buffer)))
318 (and gnus-refer-article-method
319 (or (gnus-server-opened gnus-refer-article-method)
320 (gnus-open-server gnus-refer-article-method)))
321 ;; Save the old article buffer.
324 (buffer-disable-undo (current-buffer))
325 (insert-buffer-substring gnus-article-buffer))
327 (if (gnus-article-prepare
328 message-id nil (gnus-read-header message-id))
330 (setq number (header-number gnus-current-headers))
331 (gnus-rebuild-thread message-id)
332 (gnus-summary-goto-subject number)
333 (gnus-summary-recenter)
334 (gnus-article-set-window-start
335 (cdr (assq number gnus-newsgroup-bookmarks)))
337 ;; We restore the old article buffer.
339 (set-buffer gnus-article-buffer)
340 (let ((buffer-read-only nil))
341 (insert-buffer-substring tmp-buf)
343 (set-window-start (get-buffer-window (current-buffer))
346 (kill-buffer tmp-buf)))))))
348 (defun gnus-summary-insert-pseudos (pslist &optional not-view)
349 (let ((buffer-read-only nil)
350 (article (gnus-summary-article-number))
352 (or (gnus-summary-goto-subject article)
353 (error (format "No such article: %d" article)))
354 (or gnus-newsgroup-headers-hashtb-by-number
355 (gnus-make-headers-hashtable-by-number))
356 (gnus-summary-position-cursor)
357 ;; If all commands are to be bunched up on one line, we collect
359 (if gnus-view-pseudos-separately
361 (let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
364 (setq action (cdr (assq 'action (car ps))))
365 (setq files (list (cdr (assq 'name (car ps)))))
366 (while (and ps (cdr ps)
367 (string= (or action "1")
368 (or (cdr (assq 'action (car (cdr ps)))) "2")))
369 (setq files (cons (cdr (assq 'name (car (cdr ps)))) files))
370 (setcdr ps (cdr (cdr ps))))
373 (if (not (string-match "%s" action))
374 (setq files (cons " " files)))
375 (setq files (cons " " files))
376 (and (assq 'execute (car ps))
377 (setcdr (assq 'execute (car ps))
378 (funcall (if (string-match "%s" action)
381 (mapconcat (lambda (f) f) files " ")))))
382 (setq ps (cdr ps)))))
383 (if (and gnus-view-pseudos (not not-view))
385 (and (assq 'execute (car pslist))
386 (gnus-execute-command (cdr (assq 'execute (car pslist)))
387 (eq gnus-view-pseudos 'not-confirm)))
388 (setq pslist (cdr pslist)))
391 (gnus-summary-goto-subject (or (cdr (assq 'article (car pslist)))
392 (gnus-summary-article-number)))
395 (insert " " (file-name-nondirectory
396 (cdr (assq 'name (car pslist))))
397 ": " (or (cdr (assq 'execute (car pslist))) "") "\n")
399 b (1+ b) (list 'gnus-number gnus-reffed-article-number
400 'gnus-mark gnus-unread-mark
402 'gnus-pseudo (car pslist)))
403 (remove-text-properties
404 b (gnus-point-at-eol)
405 '(gnus-number nil gnus-mark nil gnus-level nil))
407 (gnus-sethash (int-to-string gnus-reffed-article-number)
408 (car pslist) gnus-newsgroup-headers-hashtb-by-number)
409 (setq gnus-reffed-article-number (1- gnus-reffed-article-number))
410 (setq pslist (cdr pslist)))))))
413 (defun gnus-article-push-button (event)
414 "Check text under the mouse pointer for a callback function.
415 If the text under the mouse pointer has a `gnus-callback' property,
416 call it with the value of the `gnus-data' text property."
418 (set-buffer (window-buffer (event-window event)))
419 (let* ((pos (event-closest-point event))
420 (data (get-text-property pos 'gnus-data))
421 (fun (get-text-property pos 'gnus-callback)))
422 (if fun (funcall fun data))))
424 ;; Re-build the thread containing ID.
425 (defun gnus-rebuild-thread (id)
426 (let ((dep gnus-newsgroup-dependencies)
427 (buffer-read-only nil)
428 parent headers refs thread art)
429 (while (and id (setq headers
430 (car (setq art (gnus-gethash (downcase id)
433 (setq id (and (setq refs (header-references headers))
434 (string-match "\\(<[^>]+>\\) *$" refs)
435 (substring refs (match-beginning 1) (match-end 1)))))
436 (setq thread (gnus-make-sub-thread (car parent)))
437 (gnus-rebuild-remove-articles thread)
439 (gnus-summary-prepare-threads (list thread) 0)
441 (while (>= (point) beg)
442 (remove-text-properties
443 (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
444 '(gnus-number nil gnus-mark nil gnus-level nil))
446 (gnus-summary-update-lines beg (point)))))
448 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
449 (defun gnus-article-add-button (from to fun &optional data)
450 "Create a button between FROM and TO with callback FUN and data DATA."
451 (and gnus-article-button-face
452 (overlay-put (make-overlay from to) 'face gnus-article-button-face))
453 (add-text-properties from to
455 (and gnus-article-mouse-face
456 (list 'mouse-face gnus-article-mouse-face))
457 (list 'gnus-callback fun)
458 (and data (list 'gnus-data data))
459 (list 'highlight t))))
461 (if (not gnus-visual)
463 (setq gnus-group-mode-hook
466 (easy-menu-add gnus-group-reading-menu)
467 (easy-menu-add gnus-group-group-menu)
468 (easy-menu-add gnus-group-post-menu)
469 (easy-menu-add gnus-group-misc-menu)
470 (gnus-install-mouse-tracker))
471 gnus-group-mode-hook))
472 (setq gnus-summary-mode-hook
475 (easy-menu-add gnus-summary-mark-menu)
476 (easy-menu-add gnus-summary-move-menu)
477 (easy-menu-add gnus-summary-article-menu)
478 (easy-menu-add gnus-summary-thread-menu)
479 (easy-menu-add gnus-summary-misc-menu)
480 (easy-menu-add gnus-summary-post-menu)
481 (easy-menu-add gnus-summary-kill-menu)
482 (gnus-install-mouse-tracker))
483 gnus-summary-mode-hook))
484 (setq gnus-article-mode-hook
487 (easy-menu-add gnus-article-article-menu)
488 (easy-menu-add gnus-article-treatment-menu))
489 gnus-article-mode-hook)))
496 (if (not (fboundp 'truncate-string))
497 (defun truncate-string (str width)
498 (let ((w (string-width str))
499 (col 0) (idx 0) (p-idx 0) chr)
503 (setq chr (aref str idx)
504 col (+ col (char-width chr))
506 idx (+ idx (char-bytes chr))
508 (substring str 0 (if (= col width)
513 (defalias 'gnus-truncate-string 'truncate-string)
515 (defun gnus-cite-add-face (number prefix face)
516 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
518 (let ((inhibit-point-motion-hooks t)
522 (forward-char (chars-in-string prefix))
523 (forward-char (length prefix)))
524 (skip-chars-forward " \t")
527 (skip-chars-backward " \t")
530 (overlay-put (make-overlay from to) 'face face)))))
532 (defun gnus-max-width-function (el max-width)
533 (` (let* ((val (eval (, el)))
534 (valstr (if (numberp val)
535 (int-to-string val) val)))
536 (if (> (length valstr) (, max-width))
537 (truncate-string valstr (, max-width))
540 (fset 'gnus-summary-make-display-table (lambda () nil))
547 ;; byte-compile-warnings: nil
550 ;;; gnus-ems.el ends here