1 ;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
3 ;; Copyright (C) 1996-1999, 2001-2017 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 (eval-when-compile (require 'cl
))
37 (defcustom gnus-pick-display-summary nil
38 "Display summary while reading."
40 :group
'gnus-summary-pick
)
42 (defcustom gnus-pick-mode-hook nil
43 "Hook run in summary pick mode buffers."
45 :group
'gnus-summary-pick
)
47 (defcustom gnus-mark-unpicked-articles-as-read nil
48 "If non-nil, mark all unpicked articles as read."
50 :group
'gnus-summary-pick
)
52 (defcustom gnus-pick-elegant-flow t
53 "If non-nil, `gnus-pick-start-reading' runs
54 `gnus-summary-next-group' when no articles have been picked."
56 :group
'gnus-summary-pick
)
58 (defcustom gnus-summary-pick-line-format
59 "%-5P %U\ %R\ %z\ %I\ %(%[%4L: %-23,23n%]%) %s\n"
60 "The format specification of the lines in pick buffers.
61 It accepts the same format specs that `gnus-summary-line-format' does."
63 :group
'gnus-summary-pick
)
65 ;;; Internal variables.
67 (defvar gnus-pick-mode-map
68 (let ((map (make-sparse-keymap)))
70 " " gnus-pick-next-page
71 "u" gnus-pick-unmark-article-or-thread
72 "." gnus-pick-article-or-thread
73 [down-mouse-2
] gnus-pick-mouse-pick-region
74 "\r" gnus-pick-start-reading
)
77 (defun gnus-pick-make-menu-bar ()
78 (unless (boundp 'gnus-pick-menu
)
80 gnus-pick-menu gnus-pick-mode-map
""
83 ["Article" gnus-summary-mark-as-processable t
]
84 ["Thread" gnus-uu-mark-thread t
]
85 ["Region" gnus-uu-mark-region t
]
86 ["Regexp" gnus-uu-mark-by-regexp t
]
87 ["Buffer" gnus-uu-mark-buffer t
])
89 ["Article" gnus-summary-unmark-as-processable t
]
90 ["Thread" gnus-uu-unmark-thread t
]
91 ["Region" gnus-uu-unmark-region t
]
92 ["Regexp" gnus-uu-unmark-by-regexp t
]
93 ["Buffer" gnus-summary-unmark-all-processable t
])
94 ["Start reading" gnus-pick-start-reading t
]
95 ["Switch pick mode off" gnus-pick-mode gnus-pick-mode
]))))
97 (define-minor-mode gnus-pick-mode
98 "Minor mode for providing a pick-and-read interface in Gnus summary buffers.
100 \\{gnus-pick-mode-map}"
101 :lighter
" Pick" :keymap gnus-pick-mode-map
103 ((not (derived-mode-p 'gnus-summary-mode
)) (setq gnus-pick-mode nil
))
104 ((not gnus-pick-mode
)
105 ;; FIXME: a buffer-local minor mode removing globally from a hook??
106 (remove-hook 'gnus-message-setup-hook
'gnus-pick-setup-message
))
108 ;; Make sure that we don't select any articles upon group entry.
109 (set (make-local-variable 'gnus-auto-select-first
) nil
)
110 ;; Change line format.
111 (setq gnus-summary-line-format gnus-summary-pick-line-format
)
112 (setq gnus-summary-line-format-spec nil
)
113 (gnus-update-format-specifications nil
'summary
)
114 (gnus-update-summary-mark-positions)
115 ;; FIXME: a buffer-local minor mode adding globally to a hook??
116 (add-hook 'gnus-message-setup-hook
'gnus-pick-setup-message
)
117 (set (make-local-variable 'gnus-summary-goto-unread
) 'never
)
119 (when (gnus-visual-p 'pick-menu
'menu
)
120 (gnus-pick-make-menu-bar)))))
122 (defun gnus-pick-setup-message ()
123 "Make Message do the right thing on exit."
124 (when (and (gnus-buffer-live-p gnus-summary-buffer
)
125 (with-current-buffer gnus-summary-buffer
128 `(gnus-configure-windows ,gnus-current-window-configuration t
)
129 'send
'exit
'postpone
'kill
)))
131 (defvar gnus-pick-line-number
1)
132 (defun gnus-pick-line-number ()
133 "Return the current line number."
134 (incf gnus-pick-line-number
))
136 (defun gnus-pick-start-reading (&optional catch-up
)
137 "Start reading the picked articles.
138 If given a prefix, mark all unpicked articles as read."
140 (if gnus-newsgroup-processable
142 (gnus-summary-limit-to-articles nil
)
143 (when (or catch-up gnus-mark-unpicked-articles-as-read
)
144 (gnus-summary-limit-mark-excluded-as-read))
145 (gnus-summary-first-article)
146 (gnus-configure-windows
147 (if gnus-pick-display-summary
'article
'pick
) t
))
148 (if gnus-pick-elegant-flow
150 (when (or catch-up gnus-mark-unpicked-articles-as-read
)
151 (gnus-summary-catchup nil t
))
152 (if (gnus-group-quit-config gnus-newsgroup-name
)
154 (gnus-summary-next-group)))
155 (error "No articles have been picked"))))
157 (defun gnus-pick-goto-article (arg)
158 "Go to the article number indicated by ARG.
159 If ARG is an invalid article number, then stay on current line."
162 (goto-char (point-min))
163 (when (zerop (forward-line (1- (prefix-numeric-value arg
))))
166 (gnus-error 2 "No such line: %s" arg
)
169 (defun gnus-pick-article (&optional arg
)
170 "Pick the article on the current line.
171 If ARG, pick the article on that line instead."
174 (gnus-pick-goto-article arg
))
175 (gnus-summary-mark-as-processable 1))
177 (defun gnus-pick-article-or-thread (&optional arg
)
178 "If `gnus-thread-hide-subtree' is t, then pick the thread on the current line.
179 Otherwise pick the article on the current line.
180 If ARG, pick the article/thread on that line instead."
183 (gnus-pick-goto-article arg
))
184 (if gnus-thread-hide-subtree
187 (gnus-uu-mark-thread))
189 (gnus-summary-mark-as-processable 1)))
191 (defun gnus-pick-unmark-article-or-thread (&optional arg
)
192 "If `gnus-thread-hide-subtree' is t, then unmark the thread on current line.
193 Otherwise unmark the article on current line.
194 If ARG, unmark thread/article on that line instead."
197 (gnus-pick-goto-article arg
))
198 (if gnus-thread-hide-subtree
200 (gnus-uu-unmark-thread))
201 (gnus-summary-unmark-as-processable 1)))
203 (defun gnus-pick-mouse-pick (e)
207 (gnus-summary-mark-as-processable 1)))
209 (defun gnus-pick-mouse-pick-region (start-event)
210 "Pick articles that the mouse is dragged over.
211 This must be bound to a button-down mouse event."
213 (mouse-minibuffer-check start-event
)
214 (let* ((echo-keystrokes 0)
215 (start-posn (event-start start-event
))
216 (start-point (posn-point start-posn
))
217 (start-line (1+ (count-lines (point-min) start-point
)))
218 (start-window (posn-window start-posn
))
219 (bounds (window-edges start-window
))
221 (bottom (if (window-minibuffer-p start-window
)
223 ;; Don't count the mode line.
224 (1- (nth 3 bounds
))))
225 (click-count (1- (event-click-count start-event
))))
226 (setq mouse-selection-click-count click-count
)
227 (setq mouse-selection-click-count-buffer
(current-buffer))
228 (mouse-set-point start-event
)
229 ;; In case the down click is in the middle of some intangible text,
230 ;; use the end of that text, and put it in START-POINT.
231 (when (< (point) start-point
)
232 (goto-char start-point
))
234 (setq start-point
(point))
235 ;; end-of-range is used only in the single-click case.
236 ;; It is the place where the drag has reached so far
237 ;; (but not outside the window where the drag started).
238 (let (event end end-point
(end-of-range (point)))
241 (setq event
(cdr (gnus-read-event-char)))
242 (or (mouse-movement-p event
)
243 (eq (car-safe event
) 'switch-frame
)))
244 (if (eq (car-safe event
) 'switch-frame
)
246 (setq end
(event-end event
)
247 end-point
(posn-point end
))
250 ;; Are we moving within the original window?
251 ((and (eq (posn-window end
) start-window
)
252 (integer-or-marker-p end-point
))
253 ;; Go to START-POINT first, so that when we move to END-POINT,
254 ;; if it's in the middle of intangible text,
255 ;; point jumps in the direction away from START-POINT.
256 (goto-char start-point
)
257 (goto-char end-point
)
259 ;; In case the user moved his mouse really fast, pick
260 ;; articles on the line between this one and the last one.
261 (let* ((this-line (1+ (count-lines (point-min) end-point
)))
262 (min-line (min this-line start-line
))
263 (max-line (max this-line start-line
)))
264 (while (< min-line max-line
)
265 (goto-char (point-min))
266 (forward-line (1- min-line
))
268 (setq min-line
(1+ min-line
)))
269 (setq start-line this-line
))
270 (when (zerop (% click-count
3))
271 (setq end-of-range
(point))))
273 (let ((mouse-row (cdr (cdr (mouse-position)))))
277 (mouse-scroll-subr start-window
(- mouse-row top
)))
278 ((>= mouse-row bottom
)
279 (mouse-scroll-subr start-window
280 (1+ (- mouse-row bottom
)))))))))))
282 (let (;; (fun (key-binding (vector (car event))))
284 ;; Run the binding of the terminating up-event, if possible.
285 ;; In the case of a multiple click, it gives the wrong results,
286 ;; because it would fail to set up a region.
288 ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun))
289 ;; In this case, we can just let the up-event execute normally.
290 (let ((end (event-end event
)))
291 ;; Set the position in the event before we replay it,
292 ;; because otherwise it may have a position in the wrong
294 (setcar (cdr end
) end-of-range
)
295 ;; Delete the overlay before calling the function,
296 ;; because delete-overlay increases buffer-modified-tick.
297 (push event unread-command-events
))))))))
299 (defvar scroll-in-place
)
301 (defun gnus-pick-next-page ()
302 "Go to the next page. If at the end of the buffer, start reading articles."
304 (let ((scroll-in-place nil
))
307 (end-of-buffer (gnus-pick-start-reading)))))
313 (defvar gnus-binary-mode-hook nil
314 "Hook run in summary binary mode buffers.")
316 (defvar gnus-binary-mode-map
317 (let ((map (make-sparse-keymap)))
318 (gnus-define-keys map
319 "g" gnus-binary-show-article
)
322 (defun gnus-binary-make-menu-bar ()
323 (unless (boundp 'gnus-binary-menu
)
325 gnus-binary-menu gnus-binary-mode-map
""
327 ["Switch binary mode off" gnus-binary-mode t
]))))
329 (define-minor-mode gnus-binary-mode
330 "Minor mode for providing a binary group interface in Gnus summary buffers."
331 :lighter
" Binary" :keymap gnus-binary-mode-map
333 ((not (derived-mode-p 'gnus-summary-mode
)) (setq gnus-binary-mode nil
))
335 ;; Make sure that we don't select any articles upon group entry.
336 (make-local-variable 'gnus-auto-select-first
)
337 (setq gnus-auto-select-first nil
)
338 (make-local-variable 'gnus-summary-display-article-function
)
339 (setq gnus-summary-display-article-function
'gnus-binary-display-article
)
341 (when (gnus-visual-p 'binary-menu
'menu
)
342 (gnus-binary-make-menu-bar)))))
344 (defun gnus-binary-display-article (article &optional _all-header
)
345 "Run ARTICLE through the binary decode functions."
346 (when (gnus-summary-goto-subject article
)
347 (let ((gnus-view-pseudos (or gnus-view-pseudos
'automatic
)))
348 (gnus-uu-decode-uu))))
350 (defun gnus-binary-show-article (&optional arg
)
351 "Bypass the binary functions and show the article."
353 (let (gnus-summary-display-article-function)
354 (gnus-summary-show-article arg
)))
360 (defcustom gnus-tree-line-format
"%(%[%3,3n%]%)"
361 "Format of tree elements."
363 :group
'gnus-summary-tree
)
365 (defcustom gnus-tree-minimize-window t
366 "If non-nil, minimize the tree buffer window.
367 If a number, never let the tree buffer grow taller than that number of
369 :type
'(choice boolean
371 :group
'gnus-summary-tree
)
373 (defcustom gnus-selected-tree-face
'mode-line
374 "Face used for highlighting selected articles in the thread tree."
376 :group
'gnus-summary-tree
)
378 (defvar gnus-tree-brackets
'((?\
[ . ?\
]) (?\
( . ?\
))
379 (?\
{ . ?\
}) (?
< . ?
>))
380 "Brackets used in tree nodes.")
382 (defvar gnus-tree-parent-child-edges
'(?- ?
\\ ?|
)
383 "Characters used to connect parents with children.")
385 (defcustom gnus-tree-mode-line-format
"Gnus: %%b %S %Z"
386 "The format specification for the tree mode line."
388 :group
'gnus-summary-tree
)
390 (defcustom gnus-generate-tree-function
'gnus-generate-vertical-tree
391 "Function for generating a thread tree.
392 Two predefined functions are available:
393 `gnus-generate-horizontal-tree' and `gnus-generate-vertical-tree'."
394 :type
'(radio (function-item gnus-generate-vertical-tree
)
395 (function-item gnus-generate-horizontal-tree
)
396 (function :tag
"Other" nil
))
397 :group
'gnus-summary-tree
)
399 (defcustom gnus-tree-mode-hook nil
400 "Hook run in tree mode buffers."
402 :group
'gnus-summary-tree
)
404 ;;; Internal variables.
406 (defvar gnus-tmp-name
)
407 (defvar gnus-tmp-from
)
408 (defvar gnus-tmp-number
)
409 (defvar gnus-tmp-open-bracket
)
410 (defvar gnus-tmp-close-bracket
)
411 (defvar gnus-tmp-subject
)
413 (defvar gnus-tree-line-format-alist
414 `((?n gnus-tmp-name ?s
)
415 (?f gnus-tmp-from ?s
)
416 (?N gnus-tmp-number ?d
)
417 (?\
[ gnus-tmp-open-bracket ?c
)
418 (?\
] gnus-tmp-close-bracket ?c
)
419 (?s gnus-tmp-subject ?s
)))
421 (defvar gnus-tree-mode-line-format-alist gnus-summary-mode-line-format-alist
)
423 (defvar gnus-tree-mode-line-format-spec nil
)
424 (defvar gnus-tree-line-format-spec nil
)
426 (defvar gnus-tree-node-length nil
)
427 (defvar gnus-selected-tree-overlay nil
)
429 (defvar gnus-tree-displayed-thread nil
)
430 (defvar gnus-tree-inhibit nil
)
432 (defvar gnus-tree-mode-map
433 (let ((map (make-keymap)))
434 (suppress-keymap map
)
437 "\r" gnus-tree-select-article
438 [mouse-2
] gnus-tree-pick-article
439 "\C-?" gnus-tree-read-summary-keys
440 "h" gnus-tree-show-summary
442 "\C-c\C-i" gnus-info-find-node
)
444 (substitute-key-definition
445 'undefined
'gnus-tree-read-summary-keys map
)
448 (put 'gnus-tree-mode
'mode-class
'special
)
450 (defun gnus-tree-make-menu-bar ()
451 (unless (boundp 'gnus-tree-menu
)
453 gnus-tree-menu gnus-tree-mode-map
""
455 ["Select article" gnus-tree-select-article t
]))))
457 (define-derived-mode gnus-tree-mode fundamental-mode
"Tree"
458 "Major mode for displaying thread trees."
459 (gnus-set-format 'tree-mode
)
460 (gnus-set-format 'tree t
)
461 (when (gnus-visual-p 'tree-menu
'menu
)
462 (gnus-tree-make-menu-bar))
463 (gnus-simplify-mode-line)
464 (buffer-disable-undo)
465 (setq buffer-read-only t
)
466 (setq truncate-lines t
)
468 (gnus-set-work-buffer)
469 (gnus-tree-node-insert (make-mail-header "") nil
)
470 (setq gnus-tree-node-length
(1- (point)))))
472 (defun gnus-tree-read-summary-keys (&optional arg
)
473 "Read a summary buffer key sequence and execute it."
475 (unless gnus-tree-inhibit
476 (let ((buf (current-buffer))
477 (gnus-tree-inhibit t
)
479 (set-buffer gnus-article-buffer
)
480 (gnus-article-read-summary-keys arg nil t
)
481 (when (setq win
(get-buffer-window buf
))
483 (when gnus-selected-tree-overlay
484 (goto-char (or (overlay-end gnus-selected-tree-overlay
) 1)))
485 (gnus-tree-minimize)))))
487 (defun gnus-tree-show-summary ()
488 "Reconfigure windows to show summary buffer."
490 (if (not (gnus-buffer-live-p gnus-summary-buffer
))
491 (error "There is no summary buffer for this tree buffer")
492 (gnus-configure-windows 'article
)
493 (gnus-summary-goto-subject gnus-current-article
)))
495 (defun gnus-tree-select-article (article)
496 "Select the article under point, if any."
497 (interactive (list (gnus-tree-article-number)))
498 (let ((buf (current-buffer)))
500 (with-current-buffer gnus-summary-buffer
501 (gnus-summary-goto-article article
))
502 (select-window (get-buffer-window buf
)))))
504 (defun gnus-tree-pick-article (e)
505 "Select the article under the mouse pointer."
508 (gnus-tree-select-article (gnus-tree-article-number)))
510 (defun gnus-tree-article-number ()
511 (get-text-property (point) 'gnus-number
))
513 (defun gnus-tree-article-region (article)
514 "Return a cons with BEG and END of the article region."
515 (let ((pos (text-property-any
516 (point-min) (point-max) 'gnus-number article
)))
518 (cons pos
(next-single-property-change pos
'gnus-number
)))))
520 (defun gnus-tree-recenter ()
521 "Center point in the tree window."
522 (let ((selected (selected-window))
523 (tree-window (gnus-get-buffer-window gnus-tree-buffer t
)))
525 (select-window tree-window
)
526 (when gnus-selected-tree-overlay
527 (goto-char (or (overlay-end gnus-selected-tree-overlay
) 1)))
528 (let* ((top (cond ((< (window-height) 4) 0)
529 ((< (window-height) 7) 1)
531 (height (1- (window-height)))
532 (bottom (save-excursion (goto-char (point-max))
533 (forward-line (- height
))
535 ;; Set the window start to either `bottom', which is the biggest
536 ;; possible valid number, or the second line from the top,
537 ;; whichever is the least.
539 tree-window
(min bottom
(save-excursion
540 (forward-line (- top
)) (point)))))
541 (select-window selected
))))
543 (defun gnus-get-tree-buffer ()
544 "Return the tree buffer properly initialized."
545 (with-current-buffer (gnus-get-buffer-create gnus-tree-buffer
)
546 (unless (derived-mode-p 'gnus-tree-mode
)
550 (defun gnus-tree-minimize ()
551 (when (and gnus-tree-minimize-window
552 (not (one-window-p)))
555 (walk-windows (lambda (_window) (incf windows
)))
558 (* window-min-height
(1- windows
))
560 (let* ((window-min-height 2)
561 (height (count-lines (point-min) (point-max)))
562 (min (max (1- window-min-height
) height
))
563 (tot (if (numberp gnus-tree-minimize-window
)
564 (min gnus-tree-minimize-window min
)
566 (win (get-buffer-window (current-buffer)))
567 (wh (and win
(1- (window-height win
)))))
568 (setq tot
(min tot tot-win-height
))
571 (let ((selected (selected-window)))
572 (when (ignore-errors (select-window win
))
573 (enlarge-window (- tot wh
))
574 (select-window selected
))))))))
576 ;;; Generating the tree.
578 (defun gnus-tree-node-insert (header sparse
&optional adopted
)
579 (let* ((dummy (stringp header
))
580 (header (if (vectorp header
) header
582 (setq header
(make-mail-header "*****"))
583 (mail-header-set-number header
0)
584 (mail-header-set-lines header
0)
585 (mail-header-set-chars header
0)
587 (gnus-tmp-from (mail-header-from header
))
588 (gnus-tmp-subject (mail-header-subject header
))
589 (gnus-tmp-number (mail-header-number header
))
592 ((string-match "(.+)" gnus-tmp-from
)
593 (substring gnus-tmp-from
594 (1+ (match-beginning 0)) (1- (match-end 0))))
595 ((string-match "<[^>]+> *$" gnus-tmp-from
)
596 (let ((beg (match-beginning 0)))
597 (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from
)
598 (substring gnus-tmp-from
(1+ (match-beginning 0))
600 (substring gnus-tmp-from
0 beg
))))
601 ((memq gnus-tmp-number sparse
)
604 (gnus-tmp-open-bracket
605 (cond ((memq gnus-tmp-number sparse
)
606 (caadr gnus-tree-brackets
))
607 (dummy (caaddr gnus-tree-brackets
))
608 (adopted (car (nth 3 gnus-tree-brackets
)))
609 (t (caar gnus-tree-brackets
))))
610 (gnus-tmp-close-bracket
611 (cond ((memq gnus-tmp-number sparse
)
612 (cdadr gnus-tree-brackets
))
613 (adopted (cdr (nth 3 gnus-tree-brackets
)))
615 (cdaddr gnus-tree-brackets
))
616 (t (cdar gnus-tree-brackets
))))
617 (buffer-read-only nil
)
621 (setq end
(progn (eval gnus-tree-line-format-spec
) (point)))
622 (list 'gnus-number gnus-tmp-number
))
623 (when (or t
(gnus-visual-p 'tree-highlight
'highlight
))
624 (gnus-tree-highlight-node gnus-tmp-number beg end
))))
626 (defmacro gnus--let-eval
(bindings evalsym
&rest body
)
627 "Build an environment in which to evaluate expressions.
628 BINDINGS is a `let'-style list of bindings to use for the environment.
629 EVALSYM is then bound in BODY to a function that takes a sexp and evaluates
630 it in the environment specified by BINDINGS."
631 (declare (indent 2) (debug ((&rest
(sym form
)) sym body
)))
632 (if (ignore-errors (let ((x 3)) (eq (eval '(- x
1) '((x .
4))) x
)))
633 ;; Use lexical vars if possible.
634 `(let* ((env (list ,@(mapcar (lambda (binding)
635 `(cons ',(car binding
) ,(cadr binding
)))
637 (,evalsym
(lambda (exp) (eval exp env
))))
639 `(let (,@bindings
(,evalsym
#'eval
)) ,@body
)))
641 (defun gnus-tree-highlight-node (article beg end
)
642 "Highlight current line according to `gnus-summary-highlight'."
643 (let ((list gnus-summary-highlight
)
645 (with-current-buffer gnus-summary-buffer
646 (let ((uncached (memq article gnus-newsgroup-undownloaded
)))
648 ((score (or (cdr (assq article gnus-newsgroup-scored
))
649 gnus-summary-default-score
0))
650 (default gnus-summary-default-score
)
651 (default-high gnus-summary-default-high-score
)
652 (default-low gnus-summary-default-low-score
)
654 (downloaded (not uncached
))
655 (mark (or (gnus-summary-article-mark article
) gnus-unread-mark
)))
657 ;; Eval the cars of the lists until we find a match.
659 (not (funcall evalfun
(caar list
))))
660 (setq list
(cdr list
))))))
661 (unless (eq (setq face
(cdar list
)) (gnus-get-text-property-excluding-characters-with-faces beg
'face
))
662 (gnus-put-text-property-excluding-characters-with-faces
664 (if (boundp face
) (symbol-value face
) face
)))))
666 (defun gnus-tree-indent (level)
667 (insert (make-string (1- (* (1+ gnus-tree-node-length
) level
)) ?
)))
669 (defvar gnus-tmp-limit
)
670 (defvar gnus-tmp-sparse
)
671 (defvar gnus-tmp-indent
)
673 (defun gnus-generate-tree (thread)
674 "Generate a thread tree for THREAD."
675 (with-current-buffer (gnus-get-tree-buffer)
676 (let ((buffer-read-only nil
)
679 (funcall gnus-generate-tree-function thread
0)
680 (gnus-set-mode-line 'tree
)
681 (goto-char (point-min))
684 (let ((selected (selected-window)))
685 (when (gnus-get-buffer-window (set-buffer gnus-tree-buffer
) t
)
686 (select-window (gnus-get-buffer-window (set-buffer gnus-tree-buffer
) t
))
687 (gnus-horizontal-recenter)
688 (select-window selected
))))))
690 (defun gnus-generate-horizontal-tree (thread level
&optional dummyp adopted
)
691 "Generate a horizontal tree."
692 (let* ((dummy (stringp (car thread
)))
695 (memq (mail-header-number (car thread
))
699 ;; We don't want this article.
700 (setq thread
(cdr thread
))
702 ;; Not the first article on the line, so we insert a "-".
703 (insert (car gnus-tree-parent-child-edges
))
704 ;; If the level isn't zero, then we insert some indentation.
705 (unless (zerop level
)
706 (gnus-tree-indent level
)
707 (insert (cadr gnus-tree-parent-child-edges
))
708 (setq col
(- (setq beg
(point)) (point-at-bol) 1))
709 ;; Draw "|" lines upwards.
713 (eq (char-after) ?
))
715 (insert (caddr gnus-tree-parent-child-edges
)))
718 ;; Insert the article node.
719 (gnus-tree-node-insert (pop thread
) gnus-tmp-sparse adopted
))
721 ;; End of the thread, so we go to the next line.
724 ;; Recurse downwards in all children of this article.
726 (gnus-generate-horizontal-tree
727 (pop thread
) (if do
(1+ level
) level
)
728 (or dummyp dummy
) dummy
)))))
730 (defsubst gnus-tree-indent-vertical
()
731 (let ((len (- (* (1+ gnus-tree-node-length
) gnus-tmp-indent
)
732 (- (point) (point-at-bol)))))
734 (insert (make-string len ?
)))))
736 (defsubst gnus-tree-forward-line
(n)
737 (while (>= (decf n
) 0)
738 (unless (zerop (forward-line 1))
743 (defun gnus-generate-vertical-tree (thread level
&optional dummyp adopted
)
744 "Generate a vertical tree."
745 (let* ((dummy (stringp (car thread
)))
748 (memq (mail-header-number (car thread
))
752 ;; We don't want this article.
753 (setq thread
(cdr thread
))
754 (if (not (save-excursion (beginning-of-line) (bobp)))
755 ;; Not the first article on the line, so we insert a "-".
757 (gnus-tree-indent-vertical)
758 (insert (make-string (/ gnus-tree-node-length
2) ?
))
759 (insert (caddr gnus-tree-parent-child-edges
))
760 (gnus-tree-forward-line 1))
761 ;; If the level isn't zero, then we insert some indentation.
762 (unless (zerop gnus-tmp-indent
)
763 (gnus-tree-forward-line (1- (* 2 level
)))
764 (gnus-tree-indent-vertical)
766 (insert (cadr gnus-tree-parent-child-edges
))
769 ;; Draw "-" lines leftwards.
770 (while (and (not (bobp))
771 (eq (char-after (1- (point))) ?
))
773 (insert (car gnus-tree-parent-child-edges
))
776 (gnus-tree-forward-line 1)))
778 ;; Insert the article node.
779 (gnus-tree-indent-vertical)
780 (gnus-tree-node-insert (pop thread
) gnus-tmp-sparse adopted
)
781 (gnus-tree-forward-line 1))
783 ;; End of the thread, so we go to the next line.
785 (goto-char (point-min))
787 (incf gnus-tmp-indent
))
788 ;; Recurse downwards in all children of this article.
790 (gnus-generate-vertical-tree
791 (pop thread
) (if do
(1+ level
) level
)
792 (or dummyp dummy
) dummy
)))))
794 ;;; Interface functions.
796 (defun gnus-possibly-generate-tree (article &optional force
)
797 "Generate the thread tree for ARTICLE if it isn't displayed already."
798 (when (with-current-buffer gnus-summary-buffer
801 (vectorp (gnus-summary-article-header article
))))
803 (let ((top (with-current-buffer gnus-summary-buffer
807 (gnus-summary-article-header article
))
809 (gnus-tmp-limit gnus-newsgroup-limit
)
810 (gnus-tmp-sparse gnus-newsgroup-sparse
))
812 (not (eq top gnus-tree-displayed-thread
)))
813 (gnus-generate-tree top
)
814 (setq gnus-tree-displayed-thread top
))))))
816 (defun gnus-tree-open ()
817 (gnus-get-tree-buffer))
819 (defun gnus-tree-close ()
820 (gnus-kill-buffer gnus-tree-buffer
))
822 (defun gnus-tree-perhaps-minimize ()
823 (when (and gnus-tree-minimize-window
824 (get-buffer gnus-tree-buffer
))
825 (with-current-buffer gnus-tree-buffer
826 (gnus-tree-minimize))))
828 (defun gnus-highlight-selected-tree (article)
829 "Highlight the selected article in the tree."
830 (when (buffer-live-p gnus-tree-buffer
)
831 (let ((buf (current-buffer))
833 (set-buffer gnus-tree-buffer
)
834 (when (setq region
(gnus-tree-article-region article
))
835 (when (not gnus-selected-tree-overlay
)
836 ;; Create a new overlay.
838 (setq gnus-selected-tree-overlay
839 (make-overlay (point-min) (1+ (point-min))))
840 'face gnus-selected-tree-face
))
841 ;; Move the overlay to the article.
843 gnus-selected-tree-overlay
(goto-char (car region
)) (cdr region
))
846 (let ((selected (selected-window)))
847 (when (gnus-get-buffer-window (set-buffer gnus-tree-buffer
) t
)
849 (gnus-get-buffer-window (set-buffer gnus-tree-buffer
) t
))
850 (gnus-horizontal-recenter)
851 (select-window selected
))))
852 ;; If we remove this save-excursion, it updates the wrong mode lines?!?
853 (with-current-buffer gnus-tree-buffer
854 (gnus-set-mode-line 'tree
))
857 (defun gnus-tree-highlight-article (article face
)
858 ;; The save-excursion here is apparently necessary because
859 ;; `set-window-point' somehow manages to alter the buffer position.
861 (with-current-buffer (gnus-get-tree-buffer)
863 (when (setq region
(gnus-tree-article-region article
))
864 (put-text-property (car region
) (cdr region
) 'face face
)
866 (gnus-get-buffer-window (current-buffer) t
) (cdr region
)))))))
870 ;;; gnus-salt.el ends here