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