Importing gnus-5.6.5
[elisp/gnus.git-] / lisp / gnus-salt.el
1 ;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
2 ;; Copyright (C) 1996,97,98 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 the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
23
24 ;;; Commentary:
25
26 ;;; Code:
27
28 (eval-when-compile (require 'cl))
29
30 (require 'gnus)
31 (require 'gnus-sum)
32
33 ;;;
34 ;;; gnus-pick-mode
35 ;;;
36
37 (defvar gnus-pick-mode nil
38   "Minor mode for providing a pick-and-read interface in Gnus summary buffers.")
39
40 (defcustom gnus-pick-display-summary nil
41   "*Display summary while reading."
42   :type 'boolean
43   :group 'gnus-summary-pick)
44
45 (defcustom gnus-pick-mode-hook nil
46   "Hook run in summary pick mode buffers."
47   :type 'hook
48   :group 'gnus-summary-pick)
49
50 (defcustom gnus-mark-unpicked-articles-as-read nil
51   "*If non-nil, mark all unpicked articles as read."
52   :type 'boolean
53   :group 'gnus-summary-pick)
54
55 (defcustom gnus-pick-elegant-flow t
56   "If non-nil, gnus-pick-start-reading will run gnus-summary-next-group when no articles have been picked."
57   :type 'boolean
58   :group 'gnus-summary-pick)
59
60 (defcustom gnus-summary-pick-line-format
61   "-5P %U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"
62   "*The format specification of the lines in pick buffers.
63 It accepts the same format specs that `gnus-summary-line-format' does."
64   :type 'string
65   :group 'gnus-summary-pick)
66
67 ;;; Internal variables.
68
69 (defvar gnus-pick-mode-map nil)
70
71 (unless gnus-pick-mode-map
72   (setq gnus-pick-mode-map (make-sparse-keymap))
73
74   (gnus-define-keys gnus-pick-mode-map
75     "t" gnus-uu-mark-thread
76     "T" gnus-uu-unmark-thread
77     " " gnus-pick-next-page
78     "u" gnus-summary-unmark-as-processable
79     "U" gnus-summary-unmark-all-processable
80     "v" gnus-uu-mark-over
81     "r" gnus-uu-mark-region
82     "R" gnus-uu-unmark-region
83     "e" gnus-uu-mark-by-regexp
84     "E" gnus-uu-mark-by-regexp
85     "b" gnus-uu-mark-buffer
86     "B" gnus-uu-unmark-buffer
87     "." gnus-pick-article
88     gnus-down-mouse-2 gnus-pick-mouse-pick-region
89     ;;gnus-mouse-2 gnus-pick-mouse-pick
90     "X" gnus-pick-start-reading
91     "\r" gnus-pick-start-reading))
92
93 (defun gnus-pick-make-menu-bar ()
94   (unless (boundp 'gnus-pick-menu)
95     (easy-menu-define
96      gnus-pick-menu gnus-pick-mode-map ""
97      '("Pick"
98        ("Pick"
99         ["Article" gnus-summary-mark-as-processable t]
100         ["Thread" gnus-uu-mark-thread t]
101         ["Region" gnus-uu-mark-region t]
102         ["Regexp" gnus-uu-mark-regexp t]
103         ["Buffer" gnus-uu-mark-buffer t])
104        ("Unpick"
105         ["Article" gnus-summary-unmark-as-processable t]
106         ["Thread" gnus-uu-unmark-thread t]
107         ["Region" gnus-uu-unmark-region t]
108         ["Regexp" gnus-uu-unmark-regexp t]
109         ["Buffer" gnus-uu-unmark-buffer t])
110        ["Start reading" gnus-pick-start-reading t]
111        ["Switch pick mode off" gnus-pick-mode gnus-pick-mode]))))
112
113 (defun gnus-pick-mode (&optional arg)
114   "Minor mode for providing a pick-and-read interface in Gnus summary buffers.
115
116 \\{gnus-pick-mode-map}"
117   (interactive "P")
118   (when (eq major-mode 'gnus-summary-mode)
119     (if (not (set (make-local-variable 'gnus-pick-mode)
120                   (if (null arg) (not gnus-pick-mode)
121                     (> (prefix-numeric-value arg) 0))))
122         (remove-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
123       ;; Make sure that we don't select any articles upon group entry.
124       (set (make-local-variable 'gnus-auto-select-first) nil)
125       ;; Change line format.
126       (setq gnus-summary-line-format gnus-summary-pick-line-format)
127       (setq gnus-summary-line-format-spec nil)
128       (gnus-update-format-specifications nil 'summary)
129       (gnus-update-summary-mark-positions)
130       (add-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
131       (set (make-local-variable 'gnus-summary-goto-unread) 'never)
132       ;; Set up the menu.
133       (when (gnus-visual-p 'pick-menu 'menu)
134         (gnus-pick-make-menu-bar))
135       (gnus-add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map)
136       (gnus-run-hooks 'gnus-pick-mode-hook))))
137
138 (defun gnus-pick-setup-message ()
139   "Make Message do the right thing on exit."
140   (when (and (gnus-buffer-live-p gnus-summary-buffer)
141              (save-excursion
142                (set-buffer gnus-summary-buffer)
143                gnus-pick-mode))
144     (message-add-action
145      '(gnus-configure-windows 'pick t) 'send 'exit 'postpone 'kill)))
146
147 (defvar gnus-pick-line-number 1)
148 (defun gnus-pick-line-number ()
149   "Return the current line number."
150   (if (bobp)
151       (setq gnus-pick-line-number 1)
152     (incf gnus-pick-line-number)))
153
154 (defun gnus-pick-start-reading (&optional catch-up)
155   "Start reading the picked articles.
156 If given a prefix, mark all unpicked articles as read."
157   (interactive "P")
158   (if gnus-newsgroup-processable
159       (progn
160         (gnus-summary-limit-to-articles nil)
161         (when (or catch-up gnus-mark-unpicked-articles-as-read)
162           (gnus-summary-limit-mark-excluded-as-read))
163         (gnus-summary-first-article)
164         (gnus-configure-windows
165          (if gnus-pick-display-summary 'article 'pick) t))
166     (if gnus-pick-elegant-flow
167         (progn
168           (when (or catch-up gnus-mark-unpicked-articles-as-read)
169             (gnus-summary-catchup nil t))
170           (if (gnus-group-quit-config gnus-newsgroup-name)
171               (gnus-summary-exit)
172             (gnus-summary-next-group)))
173       (error "No articles have been picked"))))
174
175 (defun gnus-pick-article (&optional arg)
176   "Pick the article on the current line.
177 If ARG, pick the article on that line instead."
178   (interactive "P")
179   (when arg
180     (let (pos)
181       (save-excursion
182         (goto-char (point-min))
183         (when (zerop (forward-line (1- (prefix-numeric-value arg))))
184           (setq pos (point))))
185       (if (not pos)
186           (gnus-error 2 "No such line: %s" arg)
187         (goto-char pos))))
188   (gnus-summary-mark-as-processable 1))
189
190 (defun gnus-pick-mouse-pick (e)
191   (interactive "e")
192   (mouse-set-point e)
193   (save-excursion
194     (gnus-summary-mark-as-processable 1)))
195
196 (defun gnus-pick-mouse-pick-region (start-event)
197   "Pick articles that the mouse is dragged over.
198 This must be bound to a button-down mouse event."
199   (interactive "e")
200   (mouse-minibuffer-check start-event)
201   (let* ((echo-keystrokes 0)
202          (start-posn (event-start start-event))
203          (start-point (posn-point start-posn))
204          (start-line (1+ (count-lines 1 start-point)))
205          (start-window (posn-window start-posn))
206          (start-frame (window-frame start-window))
207          (bounds (gnus-window-edges start-window))
208          (top (nth 1 bounds))
209          (bottom (if (window-minibuffer-p start-window)
210                      (nth 3 bounds)
211                    ;; Don't count the mode line.
212                    (1- (nth 3 bounds))))
213          (click-count (1- (event-click-count start-event))))
214     (setq mouse-selection-click-count click-count)
215     (setq mouse-selection-click-count-buffer (current-buffer))
216     (mouse-set-point start-event)
217     ;; In case the down click is in the middle of some intangible text,
218     ;; use the end of that text, and put it in START-POINT.
219     (when (< (point) start-point)
220       (goto-char start-point))
221     (gnus-pick-article)
222     (setq start-point (point))
223     ;; end-of-range is used only in the single-click case.
224     ;; It is the place where the drag has reached so far
225     ;; (but not outside the window where the drag started).
226     (let (event end end-point last-end-point (end-of-range (point)))
227       (track-mouse
228        (while (progn
229                 (setq event (read-event))
230                 (or (mouse-movement-p event)
231                     (eq (car-safe event) 'switch-frame)))
232          (if (eq (car-safe event) 'switch-frame)
233              nil
234            (setq end (event-end event)
235                  end-point (posn-point end))
236            (when end-point
237              (setq last-end-point end-point))
238
239            (cond
240             ;; Are we moving within the original window?
241             ((and (eq (posn-window end) start-window)
242                   (integer-or-marker-p end-point))
243              ;; Go to START-POINT first, so that when we move to END-POINT,
244              ;; if it's in the middle of intangible text,
245              ;; point jumps in the direction away from START-POINT.
246              (goto-char start-point)
247              (goto-char end-point)
248              (gnus-pick-article)
249              ;; In case the user moved his mouse really fast, pick
250              ;; articles on the line between this one and the last one.
251              (let* ((this-line (1+ (count-lines 1 end-point)))
252                     (min-line (min this-line start-line))
253                     (max-line (max this-line start-line)))
254                (while (< min-line max-line)
255                  (goto-line min-line)
256                  (gnus-pick-article)
257                  (setq min-line (1+ min-line)))
258                (setq start-line this-line))
259              (when (zerop (% click-count 3))
260                (setq end-of-range (point))))
261             (t
262              (let ((mouse-row (cdr (cdr (mouse-position)))))
263                (cond
264                 ((null mouse-row))
265                 ((< mouse-row top)
266                  (mouse-scroll-subr start-window (- mouse-row top)))
267                 ((>= mouse-row bottom)
268                  (mouse-scroll-subr start-window
269                                     (1+ (- mouse-row bottom)))))))))))
270       (when (consp event)
271         (let ((fun (key-binding (vector (car event)))))
272           ;; Run the binding of the terminating up-event, if possible.
273           ;; In the case of a multiple click, it gives the wrong results,
274           ;; because it would fail to set up a region.
275           (when nil
276             ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun))
277             ;; In this case, we can just let the up-event execute normally.
278             (let ((end (event-end event)))
279               ;; Set the position in the event before we replay it,
280               ;; because otherwise it may have a position in the wrong
281               ;; buffer.
282               (setcar (cdr end) end-of-range)
283               ;; Delete the overlay before calling the function,
284               ;; because delete-overlay increases buffer-modified-tick.
285               (push event unread-command-events))))))))
286
287 (defun gnus-pick-next-page ()
288   "Go to the next page.  If at the end of the buffer, start reading articles."
289   (interactive)
290   (let ((scroll-in-place nil))
291     (condition-case nil
292         (scroll-up)
293       (end-of-buffer (gnus-pick-start-reading)))))
294
295 ;;;
296 ;;; gnus-binary-mode
297 ;;;
298
299 (defvar gnus-binary-mode nil
300   "Minor mode for providing a binary group interface in Gnus summary buffers.")
301
302 (defvar gnus-binary-mode-hook nil
303   "Hook run in summary binary mode buffers.")
304
305 (defvar gnus-binary-mode-map nil)
306
307 (unless gnus-binary-mode-map
308   (setq gnus-binary-mode-map (make-sparse-keymap))
309
310   (gnus-define-keys
311    gnus-binary-mode-map
312    "g" gnus-binary-show-article))
313
314 (defun gnus-binary-make-menu-bar ()
315   (unless (boundp 'gnus-binary-menu)
316     (easy-menu-define
317      gnus-binary-menu gnus-binary-mode-map ""
318      '("Pick"
319        ["Switch binary mode off" gnus-binary-mode t]))))
320
321 (defun gnus-binary-mode (&optional arg)
322   "Minor mode for providing a binary group interface in Gnus summary buffers."
323   (interactive "P")
324   (when (eq major-mode 'gnus-summary-mode)
325     (make-local-variable 'gnus-binary-mode)
326     (setq gnus-binary-mode
327           (if (null arg) (not gnus-binary-mode)
328             (> (prefix-numeric-value arg) 0)))
329     (when gnus-binary-mode
330       ;; Make sure that we don't select any articles upon group entry.
331       (make-local-variable 'gnus-auto-select-first)
332       (setq gnus-auto-select-first nil)
333       (make-local-variable 'gnus-summary-display-article-function)
334       (setq gnus-summary-display-article-function 'gnus-binary-display-article)
335       ;; Set up the menu.
336       (when (gnus-visual-p 'binary-menu 'menu)
337         (gnus-binary-make-menu-bar))
338       (gnus-add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map)
339       (gnus-run-hooks 'gnus-binary-mode-hook))))
340
341 (defun gnus-binary-display-article (article &optional all-header)
342   "Run ARTICLE through the binary decode functions."
343   (when (gnus-summary-goto-subject article)
344     (let ((gnus-view-pseudos 'automatic))
345       (gnus-uu-decode-uu))))
346
347 (defun gnus-binary-show-article (&optional arg)
348   "Bypass the binary functions and show the article."
349   (interactive "P")
350   (let (gnus-summary-display-article-function)
351     (gnus-summary-show-article arg)))
352
353 ;;;
354 ;;; gnus-tree-mode
355 ;;;
356
357 (defcustom gnus-tree-line-format "%(%[%3,3n%]%)"
358   "Format of tree elements."
359   :type 'string
360   :group 'gnus-summary-tree)
361
362 (defcustom gnus-tree-minimize-window t
363   "If non-nil, minimize the tree buffer window.
364 If a number, never let the tree buffer grow taller than that number of
365 lines."
366   :type 'boolean
367   :group 'gnus-summary-tree)
368
369 (defcustom gnus-selected-tree-face 'modeline
370   "*Face used for highlighting selected articles in the thread tree."
371   :type 'face
372   :group 'gnus-summary-tree)
373
374 (defvar gnus-tree-brackets '((?\[ . ?\]) (?\( . ?\))
375                              (?\{ . ?\}) (?< . ?>))
376   "Brackets used in tree nodes.")
377
378 (defvar gnus-tree-parent-child-edges '(?- ?\\ ?|)
379   "Characters used to connect parents with children.")
380
381 (defcustom gnus-tree-mode-line-format "Gnus: %%b %S %Z"
382   "*The format specification for the tree mode line."
383   :type 'string
384   :group 'gnus-summary-tree)
385
386 (defcustom gnus-generate-tree-function 'gnus-generate-vertical-tree
387   "*Function for generating a thread tree.
388 Two predefined functions are available:
389 `gnus-generate-horizontal-tree' and `gnus-generate-vertical-tree'."
390   :type '(radio (function-item gnus-generate-vertical-tree)
391                 (function-item gnus-generate-horizontal-tree)
392                 (function :tag "Other" nil))
393   :group 'gnus-summary-tree)
394
395 (defcustom gnus-tree-mode-hook nil
396   "*Hook run in tree mode buffers."
397   :type 'hook
398   :group 'gnus-summary-tree)
399
400 ;;; Internal variables.
401
402 (defvar gnus-tree-line-format-alist
403   `((?n gnus-tmp-name ?s)
404     (?f gnus-tmp-from ?s)
405     (?N gnus-tmp-number ?d)
406     (?\[ gnus-tmp-open-bracket ?c)
407     (?\] gnus-tmp-close-bracket ?c)
408     (?s gnus-tmp-subject ?s)))
409
410 (defvar gnus-tree-mode-line-format-alist gnus-summary-mode-line-format-alist)
411
412 (defvar gnus-tree-mode-line-format-spec nil)
413 (defvar gnus-tree-line-format-spec nil)
414
415 (defvar gnus-tree-node-length nil)
416 (defvar gnus-selected-tree-overlay nil)
417
418 (defvar gnus-tree-displayed-thread nil)
419
420 (defvar gnus-tree-mode-map nil)
421 (put 'gnus-tree-mode 'mode-class 'special)
422
423 (unless gnus-tree-mode-map
424   (setq gnus-tree-mode-map (make-keymap))
425   (suppress-keymap gnus-tree-mode-map)
426   (gnus-define-keys
427    gnus-tree-mode-map
428    "\r" gnus-tree-select-article
429    gnus-mouse-2 gnus-tree-pick-article
430    "\C-?" gnus-tree-read-summary-keys
431    "h" gnus-tree-show-summary
432
433    "\C-c\C-i" gnus-info-find-node)
434
435   (substitute-key-definition
436    'undefined 'gnus-tree-read-summary-keys gnus-tree-mode-map))
437
438 (defun gnus-tree-make-menu-bar ()
439   (unless (boundp 'gnus-tree-menu)
440     (easy-menu-define
441      gnus-tree-menu gnus-tree-mode-map ""
442      '("Tree"
443        ["Select article" gnus-tree-select-article t]))))
444
445 (defun gnus-tree-mode ()
446   "Major mode for displaying thread trees."
447   (interactive)
448   (gnus-set-format 'tree-mode)
449   (gnus-set-format 'tree t)
450   (when (gnus-visual-p 'tree-menu 'menu)
451     (gnus-tree-make-menu-bar))
452   (kill-all-local-variables)
453   (gnus-simplify-mode-line)
454   (setq mode-name "Tree")
455   (setq major-mode 'gnus-tree-mode)
456   (use-local-map gnus-tree-mode-map)
457   (buffer-disable-undo (current-buffer))
458   (setq buffer-read-only t)
459   (setq truncate-lines t)
460   (save-excursion
461     (gnus-set-work-buffer)
462     (gnus-tree-node-insert (make-mail-header "") nil)
463     (setq gnus-tree-node-length (1- (point))))
464   (gnus-run-hooks 'gnus-tree-mode-hook))
465
466 (defun gnus-tree-read-summary-keys (&optional arg)
467   "Read a summary buffer key sequence and execute it."
468   (interactive "P")
469   (let ((buf (current-buffer))
470         win)
471     (gnus-article-read-summary-keys arg nil t)
472     (when (setq win (get-buffer-window buf))
473       (select-window win)
474       (when gnus-selected-tree-overlay
475         (goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
476       (gnus-tree-minimize))))
477
478 (defun gnus-tree-show-summary ()
479   "Reconfigure windows to show summary buffer."
480   (interactive)
481   (if (not (gnus-buffer-live-p gnus-summary-buffer))
482       (error "There is no summary buffer for this tree buffer")
483     (gnus-configure-windows 'article)
484     (gnus-summary-goto-subject gnus-current-article)))
485
486 (defun gnus-tree-select-article (article)
487   "Select the article under point, if any."
488   (interactive (list (gnus-tree-article-number)))
489   (let ((buf (current-buffer)))
490     (when article
491       (save-excursion
492         (set-buffer gnus-summary-buffer)
493         (gnus-summary-goto-article article))
494       (select-window (get-buffer-window buf)))))
495
496 (defun gnus-tree-pick-article (e)
497   "Select the article under the mouse pointer."
498   (interactive "e")
499   (mouse-set-point e)
500   (gnus-tree-select-article (gnus-tree-article-number)))
501
502 (defun gnus-tree-article-number ()
503   (get-text-property (point) 'gnus-number))
504
505 (defun gnus-tree-article-region (article)
506   "Return a cons with BEG and END of the article region."
507   (let ((pos (text-property-any (point-min) (point-max) 'gnus-number article)))
508     (when pos
509       (cons pos (next-single-property-change pos 'gnus-number)))))
510
511 (defun gnus-tree-goto-article (article)
512   (let ((pos (text-property-any (point-min) (point-max) 'gnus-number article)))
513     (when pos
514       (goto-char pos))))
515
516 (defun gnus-tree-recenter ()
517   "Center point in the tree window."
518   (let ((selected (selected-window))
519         (tree-window (get-buffer-window gnus-tree-buffer t)))
520     (when tree-window
521       (select-window tree-window)
522       (when gnus-selected-tree-overlay
523         (goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
524       (let* ((top (cond ((< (window-height) 4) 0)
525                         ((< (window-height) 7) 1)
526                         (t 2)))
527              (height (1- (window-height)))
528              (bottom (save-excursion (goto-char (point-max))
529                                      (forward-line (- height))
530                                      (point))))
531         ;; Set the window start to either `bottom', which is the biggest
532         ;; possible valid number, or the second line from the top,
533         ;; whichever is the least.
534         (set-window-start
535          tree-window (min bottom (save-excursion
536                                    (forward-line (- top)) (point)))))
537       (select-window selected))))
538
539 (defun gnus-get-tree-buffer ()
540   "Return the tree buffer properly initialized."
541   (save-excursion
542     (set-buffer (get-buffer-create gnus-tree-buffer))
543     (unless (eq major-mode 'gnus-tree-mode)
544       (gnus-add-current-to-buffer-list)
545       (gnus-tree-mode))
546     (current-buffer)))
547
548 (defun gnus-tree-minimize ()
549   (when (and gnus-tree-minimize-window
550              (not (one-window-p)))
551     (let ((windows 0)
552           tot-win-height)
553       (walk-windows (lambda (window) (incf windows)))
554       (setq tot-win-height
555             (- (frame-height)
556                (* window-min-height (1- windows))
557                2))
558       (let* ((window-min-height 2)
559              (height (count-lines (point-min) (point-max)))
560              (min (max (1- window-min-height) height))
561              (tot (if (numberp gnus-tree-minimize-window)
562                       (min gnus-tree-minimize-window min)
563                     min))
564              (win (get-buffer-window (current-buffer)))
565              (wh (and win (1- (window-height win)))))
566         (setq tot (min tot tot-win-height))
567         (when (and win
568                    (not (eq tot wh)))
569           (let ((selected (selected-window)))
570             (when (ignore-errors (select-window win))
571               (enlarge-window (- tot wh))
572               (select-window selected))))))))
573
574 ;;; Generating the tree.
575
576 (defun gnus-tree-node-insert (header sparse &optional adopted)
577   (let* ((dummy (stringp header))
578          (header (if (vectorp header) header
579                    (progn
580                      (setq header (make-mail-header "*****"))
581                      (mail-header-set-number header 0)
582                      (mail-header-set-lines header 0)
583                      (mail-header-set-chars header 0)
584                      header)))
585          (gnus-tmp-from (mail-header-from header))
586          (gnus-tmp-subject (mail-header-subject header))
587          (gnus-tmp-number (mail-header-number header))
588          (gnus-tmp-name
589           (cond
590            ((string-match "(.+)" gnus-tmp-from)
591             (substring gnus-tmp-from
592                        (1+ (match-beginning 0)) (1- (match-end 0))))
593            ((string-match "<[^>]+> *$" gnus-tmp-from)
594             (let ((beg (match-beginning 0)))
595               (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from)
596                        (substring gnus-tmp-from (1+ (match-beginning 0))
597                                   (1- (match-end 0))))
598                   (substring gnus-tmp-from 0 beg))))
599            ((memq gnus-tmp-number sparse)
600             "***")
601            (t gnus-tmp-from)))
602          (gnus-tmp-open-bracket
603           (cond ((memq gnus-tmp-number sparse)
604                  (caadr gnus-tree-brackets))
605                 (dummy (caaddr gnus-tree-brackets))
606                 (adopted (car (nth 3 gnus-tree-brackets)))
607                 (t (caar gnus-tree-brackets))))
608          (gnus-tmp-close-bracket
609           (cond ((memq gnus-tmp-number sparse)
610                  (cdadr gnus-tree-brackets))
611                 (adopted (cdr (nth 3 gnus-tree-brackets)))
612                 (dummy
613                  (cdaddr gnus-tree-brackets))
614                 (t (cdar gnus-tree-brackets))))
615          (buffer-read-only nil)
616          beg end)
617     (gnus-add-text-properties
618      (setq beg (point))
619      (setq end (progn (eval gnus-tree-line-format-spec) (point)))
620      (list 'gnus-number gnus-tmp-number))
621     (when (or t (gnus-visual-p 'tree-highlight 'highlight))
622       (gnus-tree-highlight-node gnus-tmp-number beg end))))
623
624 (defun gnus-tree-highlight-node (article beg end)
625   "Highlight current line according to `gnus-summary-highlight'."
626   (let ((list gnus-summary-highlight)
627         face)
628     (save-excursion
629       (set-buffer gnus-summary-buffer)
630       (let* ((score (or (cdr (assq article gnus-newsgroup-scored))
631                         gnus-summary-default-score 0))
632              (default gnus-summary-default-score)
633              (mark (or (gnus-summary-article-mark article) gnus-unread-mark)))
634         ;; Eval the cars of the lists until we find a match.
635         (while (and list
636                     (not (eval (caar list))))
637           (setq list (cdr list)))))
638     (unless (eq (setq face (cdar list)) (get-text-property beg 'face))
639       (gnus-put-text-property
640        beg end 'face
641        (if (boundp face) (symbol-value face) face)))))
642
643 (defun gnus-tree-indent (level)
644   (insert (make-string (1- (* (1+ gnus-tree-node-length) level)) ? )))
645
646 (defvar gnus-tmp-limit)
647 (defvar gnus-tmp-sparse)
648 (defvar gnus-tmp-indent)
649
650 (defun gnus-generate-tree (thread)
651   "Generate a thread tree for THREAD."
652   (save-excursion
653     (set-buffer (gnus-get-tree-buffer))
654     (let ((buffer-read-only nil)
655           (gnus-tmp-indent 0))
656       (erase-buffer)
657       (funcall gnus-generate-tree-function thread 0)
658       (gnus-set-mode-line 'tree)
659       (goto-char (point-min))
660       (gnus-tree-minimize)
661       (gnus-tree-recenter)
662       (let ((selected (selected-window)))
663         (when (get-buffer-window (set-buffer gnus-tree-buffer) t)
664           (select-window (get-buffer-window (set-buffer gnus-tree-buffer) t))
665           (gnus-horizontal-recenter)
666           (select-window selected))))))
667
668 (defun gnus-generate-horizontal-tree (thread level &optional dummyp adopted)
669   "Generate a horizontal tree."
670   (let* ((dummy (stringp (car thread)))
671          (do (or dummy
672                  (and (car thread)
673                       (memq (mail-header-number (car thread))
674                             gnus-tmp-limit))))
675          col beg)
676     (if (not do)
677         ;; We don't want this article.
678         (setq thread (cdr thread))
679       (if (not (bolp))
680           ;; Not the first article on the line, so we insert a "-".
681           (insert (car gnus-tree-parent-child-edges))
682         ;; If the level isn't zero, then we insert some indentation.
683         (unless (zerop level)
684           (gnus-tree-indent level)
685           (insert (cadr gnus-tree-parent-child-edges))
686           (setq col (- (setq beg (point)) (gnus-point-at-bol) 1))
687           ;; Draw "|" lines upwards.
688           (while (progn
689                    (forward-line -1)
690                    (forward-char col)
691                    (= (following-char) ? ))
692             (delete-char 1)
693             (insert (caddr gnus-tree-parent-child-edges)))
694           (goto-char beg)))
695       (setq dummyp nil)
696       ;; Insert the article node.
697       (gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted))
698     (if (null thread)
699         ;; End of the thread, so we go to the next line.
700         (unless (bolp)
701           (insert "\n"))
702       ;; Recurse downwards in all children of this article.
703       (while thread
704         (gnus-generate-horizontal-tree
705          (pop thread) (if do (1+ level) level)
706          (or dummyp dummy) dummy)))))
707
708 (defsubst gnus-tree-indent-vertical ()
709   (let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent)
710                 (- (point) (gnus-point-at-bol)))))
711     (when (> len 0)
712       (insert (make-string len ? )))))
713
714 (defsubst gnus-tree-forward-line (n)
715   (while (>= (decf n) 0)
716     (unless (zerop (forward-line 1))
717       (end-of-line)
718       (insert "\n")))
719   (end-of-line))
720
721 (defun gnus-generate-vertical-tree (thread level &optional dummyp adopted)
722   "Generate a vertical tree."
723   (let* ((dummy (stringp (car thread)))
724          (do (or dummy
725                  (and (car thread)
726                       (memq (mail-header-number (car thread))
727                             gnus-tmp-limit))))
728          beg)
729     (if (not do)
730         ;; We don't want this article.
731         (setq thread (cdr thread))
732       (if (not (save-excursion (beginning-of-line) (bobp)))
733           ;; Not the first article on the line, so we insert a "-".
734           (progn
735             (gnus-tree-indent-vertical)
736             (insert (make-string (/ gnus-tree-node-length 2) ? ))
737             (insert (caddr gnus-tree-parent-child-edges))
738             (gnus-tree-forward-line 1))
739         ;; If the level isn't zero, then we insert some indentation.
740         (unless (zerop gnus-tmp-indent)
741           (gnus-tree-forward-line (1- (* 2 level)))
742           (gnus-tree-indent-vertical)
743           (delete-char -1)
744           (insert (cadr gnus-tree-parent-child-edges))
745           (setq beg (point))
746           (forward-char -1)
747           ;; Draw "-" lines leftwards.
748           (while (= (char-after (1- (point))) ? )
749             (delete-char -1)
750             (insert (car gnus-tree-parent-child-edges))
751             (forward-char -1))
752           (goto-char beg)
753           (gnus-tree-forward-line 1)))
754       (setq dummyp nil)
755       ;; Insert the article node.
756       (gnus-tree-indent-vertical)
757       (gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted)
758       (gnus-tree-forward-line 1))
759     (if (null thread)
760         ;; End of the thread, so we go to the next line.
761         (progn
762           (goto-char (point-min))
763           (end-of-line)
764           (incf gnus-tmp-indent))
765       ;; Recurse downwards in all children of this article.
766       (while thread
767         (gnus-generate-vertical-tree
768          (pop thread) (if do (1+ level) level)
769          (or dummyp dummy) dummy)))))
770
771 ;;; Interface functions.
772
773 (defun gnus-possibly-generate-tree (article &optional force)
774   "Generate the thread tree for ARTICLE if it isn't displayed already."
775   (when (save-excursion
776           (set-buffer gnus-summary-buffer)
777           (and gnus-use-trees
778                gnus-show-threads
779                (vectorp (gnus-summary-article-header article))))
780     (save-excursion
781       (let ((top (save-excursion
782                    (set-buffer gnus-summary-buffer)
783                    (gnus-cut-thread
784                     (gnus-remove-thread
785                      (mail-header-id
786                       (gnus-summary-article-header article))
787                      t))))
788             (gnus-tmp-limit gnus-newsgroup-limit)
789             (gnus-tmp-sparse gnus-newsgroup-sparse))
790         (when (or force
791                   (not (eq top gnus-tree-displayed-thread)))
792           (gnus-generate-tree top)
793           (setq gnus-tree-displayed-thread top))))))
794
795 (defun gnus-tree-open (group)
796   (gnus-get-tree-buffer))
797
798 (defun gnus-tree-close (group)
799   (gnus-kill-buffer gnus-tree-buffer))
800
801 (defun gnus-highlight-selected-tree (article)
802   "Highlight the selected article in the tree."
803   (let ((buf (current-buffer))
804         region)
805     (set-buffer gnus-tree-buffer)
806     (when (setq region (gnus-tree-article-region article))
807       (when (or (not gnus-selected-tree-overlay)
808                 (gnus-extent-detached-p gnus-selected-tree-overlay))
809         ;; Create a new overlay.
810         (gnus-overlay-put
811          (setq gnus-selected-tree-overlay (gnus-make-overlay 1 2))
812          'face gnus-selected-tree-face))
813       ;; Move the overlay to the article.
814       (gnus-move-overlay
815        gnus-selected-tree-overlay (goto-char (car region)) (cdr region))
816       (gnus-tree-minimize)
817       (gnus-tree-recenter)
818       (let ((selected (selected-window)))
819         (when (get-buffer-window (set-buffer gnus-tree-buffer) t)
820           (select-window (get-buffer-window (set-buffer gnus-tree-buffer) t))
821           (gnus-horizontal-recenter)
822           (select-window selected))))
823     ;; If we remove this save-excursion, it updates the wrong mode lines?!?
824     (save-excursion
825       (set-buffer gnus-tree-buffer)
826       (gnus-set-mode-line 'tree))
827     (set-buffer buf)))
828
829 (defun gnus-tree-highlight-article (article face)
830   (save-excursion
831     (set-buffer (gnus-get-tree-buffer))
832     (let (region)
833       (when (setq region (gnus-tree-article-region article))
834         (gnus-put-text-property (car region) (cdr region) 'face face)
835         (set-window-point
836          (get-buffer-window (current-buffer) t) (cdr region))))))
837
838 ;;;
839 ;;; gnus-carpal
840 ;;;
841
842 (defvar gnus-carpal-group-buffer-buttons
843   '(("next" . gnus-group-next-unread-group)
844     ("prev" . gnus-group-prev-unread-group)
845     ("read" . gnus-group-read-group)
846     ("select" . gnus-group-select-group)
847     ("catch-up" . gnus-group-catchup-current)
848     ("new-news" . gnus-group-get-new-news-this-group)
849     ("toggle-sub" . gnus-group-unsubscribe-current-group)
850     ("subscribe" . gnus-group-unsubscribe-group)
851     ("kill" . gnus-group-kill-group)
852     ("yank" . gnus-group-yank-group)
853     ("describe" . gnus-group-describe-group)
854     "list"
855     ("subscribed" . gnus-group-list-groups)
856     ("all" . gnus-group-list-all-groups)
857     ("killed" . gnus-group-list-killed)
858     ("zombies" . gnus-group-list-zombies)
859     ("matching" . gnus-group-list-matching)
860     ("post" . gnus-group-post-news)
861     ("mail" . gnus-group-mail)
862     ("rescan" . gnus-group-get-new-news)
863     ("browse-foreign" . gnus-group-browse-foreign)
864     ("exit" . gnus-group-exit)))
865
866 (defvar gnus-carpal-summary-buffer-buttons
867   '("mark"
868     ("read" . gnus-summary-mark-as-read-forward)
869     ("tick" . gnus-summary-tick-article-forward)
870     ("clear" . gnus-summary-clear-mark-forward)
871     ("expirable" . gnus-summary-mark-as-expirable)
872     "move"
873     ("scroll" . gnus-summary-next-page)
874     ("next-unread" . gnus-summary-next-unread-article)
875     ("prev-unread" . gnus-summary-prev-unread-article)
876     ("first" . gnus-summary-first-unread-article)
877     ("best" . gnus-summary-best-unread-article)
878     "article"
879     ("headers" . gnus-summary-toggle-header)
880     ("uudecode" . gnus-uu-decode-uu)
881     ("enter-digest" . gnus-summary-enter-digest-group)
882     ("fetch-parent" . gnus-summary-refer-parent-article)
883     "mail"
884     ("move" . gnus-summary-move-article)
885     ("copy" . gnus-summary-copy-article)
886     ("respool" . gnus-summary-respool-article)
887     "threads"
888     ("lower" . gnus-summary-lower-thread)
889     ("kill" . gnus-summary-kill-thread)
890     "post"
891     ("post" . gnus-summary-post-news)
892     ("mail" . gnus-summary-mail)
893     ("followup" . gnus-summary-followup-with-original)
894     ("reply" . gnus-summary-reply-with-original)
895     ("cancel" . gnus-summary-cancel-article)
896     "misc"
897     ("exit" . gnus-summary-exit)
898     ("fed-up" . gnus-summary-catchup-and-goto-next-group)))
899
900 (defvar gnus-carpal-server-buffer-buttons
901   '(("add" . gnus-server-add-server)
902     ("browse" . gnus-server-browse-server)
903     ("list" . gnus-server-list-servers)
904     ("kill" . gnus-server-kill-server)
905     ("yank" . gnus-server-yank-server)
906     ("copy" . gnus-server-copy-server)
907     ("exit" . gnus-server-exit)))
908
909 (defvar gnus-carpal-browse-buffer-buttons
910   '(("subscribe" . gnus-browse-unsubscribe-current-group)
911     ("exit" . gnus-browse-exit)))
912
913 (defvar gnus-carpal-group-buffer "*Carpal Group*")
914 (defvar gnus-carpal-summary-buffer "*Carpal Summary*")
915 (defvar gnus-carpal-server-buffer "*Carpal Server*")
916 (defvar gnus-carpal-browse-buffer "*Carpal Browse*")
917
918 (defvar gnus-carpal-attached-buffer nil)
919
920 (defvar gnus-carpal-mode-hook nil
921   "*Hook run in carpal mode buffers.")
922
923 (defvar gnus-carpal-button-face 'bold
924   "*Face used on carpal buttons.")
925
926 (defvar gnus-carpal-header-face 'bold-italic
927   "*Face used on carpal buffer headers.")
928
929 (defvar gnus-carpal-mode-map nil)
930 (put 'gnus-carpal-mode 'mode-class 'special)
931
932 (if gnus-carpal-mode-map
933     nil
934   (setq gnus-carpal-mode-map (make-keymap))
935   (suppress-keymap gnus-carpal-mode-map)
936   (define-key gnus-carpal-mode-map " " 'gnus-carpal-select)
937   (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select)
938   (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select))
939
940 (defun gnus-carpal-mode ()
941   "Major mode for clicking buttons.
942
943 All normal editing commands are switched off.
944 \\<gnus-carpal-mode-map>
945 The following commands are available:
946
947 \\{gnus-carpal-mode-map}"
948   (interactive)
949   (kill-all-local-variables)
950   (setq mode-line-modified (cdr gnus-mode-line-modified))
951   (setq major-mode 'gnus-carpal-mode)
952   (setq mode-name "Gnus Carpal")
953   (setq mode-line-process nil)
954   (use-local-map gnus-carpal-mode-map)
955   (buffer-disable-undo (current-buffer))
956   (setq buffer-read-only t)
957   (make-local-variable 'gnus-carpal-attached-buffer)
958   (gnus-run-hooks 'gnus-carpal-mode-hook))
959
960 (defun gnus-carpal-setup-buffer (type)
961   (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type)))))
962     (if (get-buffer buffer)
963         ()
964       (save-excursion
965         (set-buffer (get-buffer-create buffer))
966         (gnus-carpal-mode)
967         (setq gnus-carpal-attached-buffer
968               (intern (format "gnus-%s-buffer" type)))
969         (gnus-add-current-to-buffer-list)
970         (let ((buttons (symbol-value
971                         (intern (format "gnus-carpal-%s-buffer-buttons"
972                                         type))))
973               (buffer-read-only nil)
974               button)
975           (while buttons
976             (setq button (car buttons)
977                   buttons (cdr buttons))
978             (if (stringp button)
979                 (gnus-set-text-properties
980                  (point)
981                  (prog2 (insert button) (point) (insert " "))
982                  (list 'face gnus-carpal-header-face))
983               (gnus-set-text-properties
984                (point)
985                (prog2 (insert (car button)) (point) (insert " "))
986                (list 'gnus-callback (cdr button)
987                      'face gnus-carpal-button-face
988                      gnus-mouse-face-prop 'highlight))))
989           (let ((fill-column (- (window-width) 2)))
990             (fill-region (point-min) (point-max)))
991           (set-window-point (get-buffer-window (current-buffer))
992                             (point-min)))))))
993
994 (defun gnus-carpal-select ()
995   "Select the button under point."
996   (interactive)
997   (let ((func (get-text-property (point) 'gnus-callback)))
998     (if (null func)
999         ()
1000       (pop-to-buffer (symbol-value gnus-carpal-attached-buffer))
1001       (call-interactively func))))
1002
1003 (defun gnus-carpal-mouse-select (event)
1004   "Select the button under the mouse pointer."
1005   (interactive "e")
1006   (mouse-set-point event)
1007   (gnus-carpal-select))
1008
1009 ;;; Allow redefinition of functions.
1010 (gnus-ems-redefine)
1011
1012 (provide 'gnus-salt)
1013
1014 ;;; gnus-salt.el ends here