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