17493
|
1 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
|
64754
|
2
|
64307
|
3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
|
79708
|
4 ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
|
17493
|
5
|
|
6 ;; Author: Ilja Weis <kult@uni-paderborn.de>
|
24357
|
7 ;; Lars Magne Ingebrigtsen <larsi@gnus.org>
|
17493
|
8 ;; Keywords: news
|
|
9
|
|
10 ;; This file is part of GNU Emacs.
|
|
11
|
94662
|
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
|
17493
|
13 ;; it under the terms of the GNU General Public License as published by
|
94662
|
14 ;; the Free Software Foundation, either version 3 of the License, or
|
|
15 ;; (at your option) any later version.
|
17493
|
16
|
|
17 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
20 ;; GNU General Public License for more details.
|
|
21
|
|
22 ;; You should have received a copy of the GNU General Public License
|
94662
|
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
17493
|
24
|
|
25 ;;; Commentary:
|
|
26
|
|
27 ;;; Code:
|
|
28
|
19521
|
29 (eval-when-compile (require 'cl))
|
|
30
|
17493
|
31 (require 'gnus)
|
|
32 (require 'gnus-group)
|
|
33 (require 'gnus-start)
|
24357
|
34 (require 'gnus-util)
|
17493
|
35
|
|
36 (defgroup gnus-topic nil
|
|
37 "Group topics."
|
|
38 :group 'gnus-group)
|
|
39
|
|
40 (defvar gnus-topic-mode nil
|
|
41 "Minor mode for Gnus group buffers.")
|
|
42
|
|
43 (defcustom gnus-topic-mode-hook nil
|
|
44 "Hook run in topic mode buffers."
|
|
45 :type 'hook
|
|
46 :group 'gnus-topic)
|
|
47
|
56927
|
48 (when (featurep 'xemacs)
|
|
49 (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add))
|
|
50
|
17493
|
51 (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n"
|
|
52 "Format of topic lines.
|
|
53 It works along the same lines as a normal formatting string,
|
|
54 with some simple extensions.
|
|
55
|
|
56 %i Indentation based on topic level.
|
|
57 %n Topic name.
|
|
58 %v Nothing if the topic is visible, \"...\" otherwise.
|
|
59 %g Number of groups in the topic.
|
|
60 %a Number of unread articles in the groups in the topic.
|
|
61 %A Number of unread articles in the groups in the topic and its subtopics.
|
56927
|
62
|
|
63 General format specifiers can also be used.
|
|
64 See Info node `(gnus)Formatting Variables'."
|
|
65 :link '(custom-manual "(gnus)Formatting Variables")
|
17493
|
66 :type 'string
|
|
67 :group 'gnus-topic)
|
|
68
|
|
69 (defcustom gnus-topic-indent-level 2
|
|
70 "*How much each subtopic should be indented."
|
|
71 :type 'integer
|
|
72 :group 'gnus-topic)
|
|
73
|
|
74 (defcustom gnus-topic-display-empty-topics t
|
|
75 "*If non-nil, display the topic lines even of topics that have no unread articles."
|
|
76 :type 'boolean
|
|
77 :group 'gnus-topic)
|
|
78
|
|
79 ;; Internal variables.
|
|
80
|
|
81 (defvar gnus-topic-active-topology nil)
|
|
82 (defvar gnus-topic-active-alist nil)
|
24357
|
83 (defvar gnus-topic-unreads nil)
|
17493
|
84
|
|
85 (defvar gnus-topology-checked-p nil
|
|
86 "Whether the topology has been checked in this session.")
|
|
87
|
|
88 (defvar gnus-topic-killed-topics nil)
|
|
89 (defvar gnus-topic-inhibit-change-level nil)
|
|
90
|
|
91 (defconst gnus-topic-line-format-alist
|
|
92 `((?n name ?s)
|
|
93 (?v visible ?s)
|
|
94 (?i indentation ?s)
|
|
95 (?g number-of-groups ?d)
|
|
96 (?a (gnus-topic-articles-in-topic entries) ?d)
|
|
97 (?A total-number-of-articles ?d)
|
|
98 (?l level ?d)))
|
|
99
|
|
100 (defvar gnus-topic-line-format-spec nil)
|
|
101
|
|
102 ;;; Utility functions
|
|
103
|
|
104 (defun gnus-group-topic-name ()
|
|
105 "The name of the topic on the current line."
|
85712
|
106 (let ((topic (get-text-property (point-at-bol) 'gnus-topic)))
|
17493
|
107 (and topic (symbol-name topic))))
|
|
108
|
|
109 (defun gnus-group-topic-level ()
|
|
110 "The level of the topic on the current line."
|
85712
|
111 (get-text-property (point-at-bol) 'gnus-topic-level))
|
17493
|
112
|
|
113 (defun gnus-group-topic-unread ()
|
|
114 "The number of unread articles in topic on the current line."
|
85712
|
115 (get-text-property (point-at-bol) 'gnus-topic-unread))
|
17493
|
116
|
|
117 (defun gnus-topic-unread (topic)
|
|
118 "Return the number of unread articles in TOPIC."
|
24357
|
119 (or (cdr (assoc topic gnus-topic-unreads))
|
17493
|
120 0))
|
|
121
|
|
122 (defun gnus-group-topic-p ()
|
|
123 "Return non-nil if the current line is a topic."
|
|
124 (gnus-group-topic-name))
|
|
125
|
|
126 (defun gnus-topic-visible-p ()
|
|
127 "Return non-nil if the current topic is visible."
|
85712
|
128 (get-text-property (point-at-bol) 'gnus-topic-visible))
|
17493
|
129
|
|
130 (defun gnus-topic-articles-in-topic (entries)
|
|
131 (let ((total 0)
|
|
132 number)
|
|
133 (while entries
|
|
134 (when (numberp (setq number (car (pop entries))))
|
|
135 (incf total number)))
|
|
136 total))
|
|
137
|
|
138 (defun gnus-group-topic (group)
|
|
139 "Return the topic GROUP is a member of."
|
|
140 (let ((alist gnus-topic-alist)
|
|
141 out)
|
|
142 (while alist
|
|
143 (when (member group (cdar alist))
|
|
144 (setq out (caar alist)
|
|
145 alist nil))
|
|
146 (setq alist (cdr alist)))
|
|
147 out))
|
|
148
|
|
149 (defun gnus-group-parent-topic (group)
|
|
150 "Return the topic GROUP is member of by looking at the group buffer."
|
|
151 (save-excursion
|
|
152 (set-buffer gnus-group-buffer)
|
|
153 (if (gnus-group-goto-group group)
|
|
154 (gnus-current-topic)
|
|
155 (gnus-group-topic group))))
|
|
156
|
|
157 (defun gnus-topic-goto-topic (topic)
|
|
158 (when topic
|
|
159 (gnus-goto-char (text-property-any (point-min) (point-max)
|
|
160 'gnus-topic (intern topic)))))
|
|
161
|
31716
|
162 (defun gnus-topic-jump-to-topic (topic)
|
|
163 "Go to TOPIC."
|
|
164 (interactive
|
|
165 (list (completing-read "Go to topic: "
|
|
166 (mapcar 'list (gnus-topic-list))
|
|
167 nil t)))
|
85712
|
168 (let ((buffer-read-only nil))
|
|
169 (dolist (topic (gnus-current-topics topic))
|
|
170 (unless (gnus-topic-goto-topic topic)
|
|
171 (gnus-topic-goto-missing-topic topic)
|
|
172 (gnus-topic-display-missing-topic topic))))
|
31716
|
173 (gnus-topic-goto-topic topic))
|
49598
|
174
|
17493
|
175 (defun gnus-current-topic ()
|
|
176 "Return the name of the current topic."
|
|
177 (let ((result
|
|
178 (or (get-text-property (point) 'gnus-topic)
|
|
179 (save-excursion
|
|
180 (and (gnus-goto-char (previous-single-property-change
|
|
181 (point) 'gnus-topic))
|
|
182 (get-text-property (max (1- (point)) (point-min))
|
|
183 'gnus-topic))))))
|
|
184 (when result
|
|
185 (symbol-name result))))
|
|
186
|
24357
|
187 (defun gnus-current-topics (&optional topic)
|
|
188 "Return a list of all current topics, lowest in hierarchy first.
|
|
189 If TOPIC, start with that topic."
|
|
190 (let ((topic (or topic (gnus-current-topic)))
|
17493
|
191 topics)
|
|
192 (while topic
|
|
193 (push topic topics)
|
|
194 (setq topic (gnus-topic-parent-topic topic)))
|
|
195 (nreverse topics)))
|
|
196
|
|
197 (defun gnus-group-active-topic-p ()
|
|
198 "Say whether the current topic comes from the active topics."
|
85712
|
199 (get-text-property (point-at-bol) 'gnus-active))
|
17493
|
200
|
31785
|
201 (defun gnus-topic-find-groups (topic &optional level all lowest recursive)
|
|
202 "Return entries for all visible groups in TOPIC.
|
|
203 If RECURSIVE is t, return groups in its subtopics too."
|
17493
|
204 (let ((groups (cdr (assoc topic gnus-topic-alist)))
|
56927
|
205 info clevel unread group params visible-groups entry active)
|
17493
|
206 (setq lowest (or lowest 1))
|
24357
|
207 (setq level (or level gnus-level-unsubscribed))
|
17493
|
208 ;; We go through the newsrc to look for matches.
|
|
209 (while groups
|
|
210 (when (setq group (pop groups))
|
85712
|
211 (setq entry (gnus-group-entry group)
|
17493
|
212 info (nth 2 entry)
|
|
213 params (gnus-info-params info)
|
|
214 active (gnus-active group)
|
|
215 unread (or (car entry)
|
|
216 (and (not (equal group "dummy.group"))
|
|
217 active
|
|
218 (- (1+ (cdr active)) (car active))))
|
|
219 clevel (or (gnus-info-level info)
|
24357
|
220 (if (member group gnus-zombie-list)
|
|
221 gnus-level-zombie gnus-level-killed))))
|
17493
|
222 (and
|
31716
|
223 info ; nil means that the group is dead.
|
17493
|
224 (<= clevel level)
|
|
225 (>= clevel lowest) ; Is inside the level we want.
|
|
226 (or all
|
31716
|
227 (if (or (eq unread t)
|
|
228 (eq unread nil))
|
17493
|
229 gnus-group-list-inactive-groups
|
|
230 (> unread 0))
|
|
231 (and gnus-list-groups-with-ticked-articles
|
|
232 (cdr (assq 'tick (gnus-info-marks info))))
|
31716
|
233 ;; Has right readedness.
|
17493
|
234 ;; Check for permanent visibility.
|
|
235 (and gnus-permanently-visible-groups
|
|
236 (string-match gnus-permanently-visible-groups group))
|
|
237 (memq 'visible params)
|
|
238 (cdr (assq 'visible params)))
|
|
239 ;; Add this group to the list of visible groups.
|
|
240 (push (or entry group) visible-groups)))
|
31785
|
241 (setq visible-groups (nreverse visible-groups))
|
49598
|
242 (when recursive
|
31785
|
243 (if (eq recursive t)
|
|
244 (setq recursive (cdr (gnus-topic-find-topology topic))))
|
85712
|
245 (dolist (topic-topology (cdr recursive))
|
|
246 (setq visible-groups
|
|
247 (nconc visible-groups
|
|
248 (gnus-topic-find-groups
|
|
249 (caar topic-topology)
|
|
250 level all lowest topic-topology)))))
|
31785
|
251 visible-groups))
|
17493
|
252
|
56927
|
253 (defun gnus-topic-goto-previous-topic (n)
|
|
254 "Go to the N'th previous topic."
|
|
255 (interactive "p")
|
|
256 (gnus-topic-goto-next-topic (- n)))
|
|
257
|
|
258 (defun gnus-topic-goto-next-topic (n)
|
|
259 "Go to the N'th next topic."
|
|
260 (interactive "p")
|
|
261 (let ((backward (< n 0))
|
|
262 (n (abs n))
|
|
263 (topic (gnus-current-topic)))
|
|
264 (while (and (> n 0)
|
|
265 (setq topic
|
|
266 (if backward
|
|
267 (gnus-topic-previous-topic topic)
|
|
268 (gnus-topic-next-topic topic))))
|
|
269 (gnus-topic-goto-topic topic)
|
|
270 (setq n (1- n)))
|
|
271 (when (/= 0 n)
|
|
272 (gnus-message 7 "No more topics"))
|
|
273 n))
|
|
274
|
17493
|
275 (defun gnus-topic-previous-topic (topic)
|
|
276 "Return the previous topic on the same level as TOPIC."
|
|
277 (let ((top (cddr (gnus-topic-find-topology
|
|
278 (gnus-topic-parent-topic topic)))))
|
|
279 (unless (equal topic (caaar top))
|
|
280 (while (and top (not (equal (caaadr top) topic)))
|
|
281 (setq top (cdr top)))
|
|
282 (caaar top))))
|
|
283
|
|
284 (defun gnus-topic-parent-topic (topic &optional topology)
|
|
285 "Return the parent of TOPIC."
|
|
286 (unless topology
|
|
287 (setq topology gnus-topic-topology))
|
|
288 (let ((parent (car (pop topology)))
|
|
289 result found)
|
|
290 (while (and topology
|
|
291 (not (setq found (equal (caaar topology) topic)))
|
|
292 (not (setq result (gnus-topic-parent-topic
|
|
293 topic (car topology)))))
|
|
294 (setq topology (cdr topology)))
|
|
295 (or result (and found parent))))
|
|
296
|
|
297 (defun gnus-topic-next-topic (topic &optional previous)
|
|
298 "Return the next sibling of TOPIC."
|
|
299 (let ((parentt (cddr (gnus-topic-find-topology
|
|
300 (gnus-topic-parent-topic topic))))
|
|
301 prev)
|
|
302 (while (and parentt
|
|
303 (not (equal (caaar parentt) topic)))
|
|
304 (setq prev (caaar parentt)
|
|
305 parentt (cdr parentt)))
|
|
306 (if previous
|
|
307 prev
|
|
308 (caaadr parentt))))
|
|
309
|
|
310 (defun gnus-topic-forward-topic (num)
|
|
311 "Go to the next topic on the same level as the current one."
|
|
312 (let* ((topic (gnus-current-topic))
|
|
313 (way (if (< num 0) 'gnus-topic-previous-topic
|
|
314 'gnus-topic-next-topic))
|
|
315 (num (abs num)))
|
|
316 (while (and (not (zerop num))
|
|
317 (setq topic (funcall way topic)))
|
|
318 (when (gnus-topic-goto-topic topic)
|
|
319 (decf num)))
|
|
320 (unless (zerop num)
|
|
321 (goto-char (point-max)))
|
|
322 num))
|
|
323
|
|
324 (defun gnus-topic-find-topology (topic &optional topology level remove)
|
|
325 "Return the topology of TOPIC."
|
|
326 (unless topology
|
|
327 (setq topology gnus-topic-topology)
|
|
328 (setq level 0))
|
|
329 (let ((top topology)
|
|
330 result)
|
|
331 (if (equal (caar topology) topic)
|
|
332 (progn
|
|
333 (when remove
|
|
334 (delq topology remove))
|
|
335 (cons level topology))
|
|
336 (setq topology (cdr topology))
|
|
337 (while (and topology
|
|
338 (not (setq result (gnus-topic-find-topology
|
|
339 topic (car topology) (1+ level)
|
|
340 (and remove top)))))
|
|
341 (setq topology (cdr topology)))
|
|
342 result)))
|
|
343
|
|
344 (defvar gnus-tmp-topics nil)
|
|
345 (defun gnus-topic-list (&optional topology)
|
|
346 "Return a list of all topics in the topology."
|
|
347 (unless topology
|
|
348 (setq topology gnus-topic-topology
|
|
349 gnus-tmp-topics nil))
|
|
350 (push (caar topology) gnus-tmp-topics)
|
85712
|
351 (mapc 'gnus-topic-list (cdr topology))
|
17493
|
352 gnus-tmp-topics)
|
|
353
|
|
354 ;;; Topic parameter jazz
|
|
355
|
|
356 (defun gnus-topic-parameters (topic)
|
|
357 "Return the parameters for TOPIC."
|
|
358 (let ((top (gnus-topic-find-topology topic)))
|
|
359 (when top
|
|
360 (nth 3 (cadr top)))))
|
|
361
|
|
362 (defun gnus-topic-set-parameters (topic parameters)
|
|
363 "Set the topic parameters of TOPIC to PARAMETERS."
|
|
364 (let ((top (gnus-topic-find-topology topic)))
|
|
365 (unless top
|
|
366 (error "No such topic: %s" topic))
|
|
367 ;; We may have to extend if there is no parameters here
|
|
368 ;; to begin with.
|
|
369 (unless (nthcdr 2 (cadr top))
|
|
370 (nconc (cadr top) (list nil)))
|
|
371 (unless (nthcdr 3 (cadr top))
|
|
372 (nconc (cadr top) (list nil)))
|
|
373 (setcar (nthcdr 3 (cadr top)) parameters)
|
|
374 (gnus-dribble-enter
|
|
375 (format "(gnus-topic-set-parameters %S '%S)" topic parameters))))
|
|
376
|
|
377 (defun gnus-group-topic-parameters (group)
|
85712
|
378 "Compute the group parameters for GROUP in topic mode.
|
|
379 Possibly inherit parameters from topics above GROUP."
|
24357
|
380 (let ((params-list (copy-sequence (gnus-group-get-parameter group))))
|
17493
|
381 (save-excursion
|
85712
|
382 (gnus-topic-hierarchical-parameters
|
|
383 ;; First we try to go to the group within the group buffer and find the
|
|
384 ;; topic for the group that way. This hopefully copes well with groups
|
|
385 ;; that are in more than one topic. Failing that (i.e. when the group
|
|
386 ;; isn't visible in the group buffer) we find a topic for the group via
|
|
387 ;; gnus-group-topic.
|
|
388 (or (and (gnus-group-goto-group group)
|
|
389 (gnus-current-topic))
|
|
390 (gnus-group-topic group))
|
|
391 params-list))))
|
24357
|
392
|
85712
|
393 (defun gnus-topic-hierarchical-parameters (topic &optional group-params-list)
|
|
394 "Compute the topic parameters for TOPIC.
|
|
395 Possibly inherit parameters from topics above TOPIC.
|
|
396 If optional argument GROUP-PARAMS-LIST is non-nil, use it as the basis for
|
|
397 inheritance."
|
|
398 (let ((params-list
|
|
399 ;; We probably have lots of nil elements here, so we remove them.
|
|
400 ;; Probably faster than doing this "properly".
|
|
401 (delq nil (cons group-params-list
|
|
402 (mapcar 'gnus-topic-parameters
|
|
403 (gnus-current-topics topic)))))
|
|
404 param out params)
|
24357
|
405 ;; Now we have all the parameters, so we go through them
|
|
406 ;; and do inheritance in the obvious way.
|
85712
|
407 (let (posting-style)
|
|
408 (while (setq params (pop params-list))
|
|
409 (while (setq param (pop params))
|
|
410 (when (atom param)
|
|
411 (setq param (cons param t)))
|
|
412 (cond ((eq (car param) 'posting-style)
|
|
413 (let ((param (cdr param))
|
|
414 elt)
|
|
415 (while (setq elt (pop param))
|
|
416 (unless (assoc (car elt) posting-style)
|
|
417 (push elt posting-style)))))
|
|
418 (t
|
|
419 (unless (assq (car param) out)
|
|
420 (push param out))))))
|
|
421 (and posting-style (push (cons 'posting-style posting-style) out)))
|
24357
|
422 ;; Return the resulting parameter list.
|
|
423 out))
|
17493
|
424
|
|
425 ;;; General utility functions
|
|
426
|
|
427 (defun gnus-topic-enter-dribble ()
|
|
428 (gnus-dribble-enter
|
|
429 (format "(setq gnus-topic-topology '%S)" gnus-topic-topology)))
|
|
430
|
|
431 ;;; Generating group buffers
|
|
432
|
56927
|
433 (defun gnus-group-prepare-topics (level &optional predicate lowest
|
31716
|
434 regexp list-topic topic-level)
|
24357
|
435 "List all newsgroups with unread articles of level LEVEL or lower.
|
|
436 Use the `gnus-group-topics' to sort the groups.
|
56927
|
437 If PREDICTE is a function, list groups that the function returns non-nil;
|
|
438 if it is t, list groups that have no unread articles.
|
17493
|
439 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
|
|
440 (set-buffer gnus-group-buffer)
|
|
441 (let ((buffer-read-only nil)
|
56927
|
442 (lowest (or lowest 1))
|
|
443 (not-in-list
|
|
444 (and gnus-group-listed-groups
|
|
445 (copy-sequence gnus-group-listed-groups))))
|
17493
|
446
|
56927
|
447 (gnus-update-format-specifications nil 'topic)
|
64754
|
448
|
17493
|
449 (when (or (not gnus-topic-alist)
|
|
450 (not gnus-topology-checked-p))
|
|
451 (gnus-topic-check-topology))
|
|
452
|
|
453 (unless list-topic
|
|
454 (erase-buffer))
|
|
455
|
|
456 ;; List dead groups?
|
56927
|
457 (when (or gnus-group-listed-groups
|
|
458 (and (>= level gnus-level-zombie)
|
|
459 (<= lowest gnus-level-zombie)))
|
17493
|
460 (gnus-group-prepare-flat-list-dead
|
|
461 (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
|
|
462 gnus-level-zombie ?Z
|
|
463 regexp))
|
|
464
|
56927
|
465 (when (or gnus-group-listed-groups
|
|
466 (and (>= level gnus-level-killed)
|
|
467 (<= lowest gnus-level-killed)))
|
17493
|
468 (gnus-group-prepare-flat-list-dead
|
|
469 (setq gnus-killed-list (sort gnus-killed-list 'string<))
|
56927
|
470 gnus-level-killed ?K regexp)
|
|
471 (when not-in-list
|
|
472 (unless gnus-killed-hashtb
|
|
473 (gnus-make-hashtable-from-killed))
|
|
474 (gnus-group-prepare-flat-list-dead
|
|
475 (gnus-remove-if (lambda (group)
|
85712
|
476 (or (gnus-group-entry group)
|
56927
|
477 (gnus-gethash group gnus-killed-hashtb)))
|
|
478 not-in-list)
|
|
479 gnus-level-killed ?K regexp)))
|
17493
|
480
|
|
481 ;; Use topics.
|
|
482 (prog1
|
56927
|
483 (when (or (< lowest gnus-level-zombie)
|
|
484 gnus-group-listed-groups)
|
17493
|
485 (if list-topic
|
|
486 (let ((top (gnus-topic-find-topology list-topic)))
|
|
487 (gnus-topic-prepare-topic (cdr top) (car top)
|
56927
|
488 (or topic-level level) predicate
|
|
489 nil lowest regexp))
|
17493
|
490 (gnus-topic-prepare-topic gnus-topic-topology 0
|
56927
|
491 (or topic-level level) predicate
|
|
492 nil lowest regexp)))
|
17493
|
493 (gnus-group-set-mode-line)
|
56927
|
494 (setq gnus-group-list-mode (cons level predicate))
|
24357
|
495 (gnus-run-hooks 'gnus-group-prepare-hook))))
|
17493
|
496
|
56927
|
497 (defun gnus-topic-prepare-topic (topicl level &optional list-level
|
|
498 predicate silent
|
|
499 lowest regexp)
|
17493
|
500 "Insert TOPIC into the group buffer.
|
|
501 If SILENT, don't insert anything. Return the number of unread
|
|
502 articles in the topic and its subtopics."
|
|
503 (let* ((type (pop topicl))
|
24357
|
504 (entries (gnus-topic-find-groups
|
56927
|
505 (car type)
|
|
506 (if gnus-group-listed-groups
|
|
507 gnus-level-killed
|
|
508 list-level)
|
|
509 (or predicate gnus-group-listed-groups
|
31716
|
510 (cdr (assq 'visible
|
24357
|
511 (gnus-topic-hierarchical-parameters
|
|
512 (car type)))))
|
56927
|
513 (if gnus-group-listed-groups 0 lowest)))
|
17493
|
514 (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
|
|
515 (gnus-group-indentation
|
|
516 (make-string (* gnus-topic-indent-level level) ? ))
|
|
517 (beg (progn (beginning-of-line) (point)))
|
|
518 (topicl (reverse topicl))
|
|
519 (all-entries entries)
|
|
520 (point-max (point-max))
|
|
521 (unread 0)
|
|
522 (topic (car type))
|
|
523 info entry end active tick)
|
|
524 ;; Insert any sub-topics.
|
|
525 (while topicl
|
|
526 (incf unread
|
|
527 (gnus-topic-prepare-topic
|
56927
|
528 (pop topicl) (1+ level) list-level predicate
|
|
529 (not visiblep) lowest regexp)))
|
17493
|
530 (setq end (point))
|
|
531 (goto-char beg)
|
|
532 ;; Insert all the groups that belong in this topic.
|
|
533 (while (setq entry (pop entries))
|
56927
|
534 (when (if (stringp entry)
|
|
535 (gnus-group-prepare-logic
|
|
536 entry
|
|
537 (and
|
|
538 (or (not gnus-group-listed-groups)
|
|
539 (if (< list-level gnus-level-zombie) nil
|
|
540 (let ((entry-level
|
|
541 (if (member entry gnus-zombie-list)
|
|
542 gnus-level-zombie gnus-level-killed)))
|
|
543 (and (<= entry-level list-level)
|
|
544 (>= entry-level lowest)))))
|
|
545 (cond
|
|
546 ((stringp regexp)
|
|
547 (string-match regexp entry))
|
|
548 ((functionp regexp)
|
|
549 (funcall regexp entry))
|
|
550 ((null regexp) t)
|
|
551 (t nil))))
|
|
552 (setq info (nth 2 entry))
|
|
553 (gnus-group-prepare-logic
|
|
554 (gnus-info-group info)
|
|
555 (and (or (not gnus-group-listed-groups)
|
|
556 (let ((entry-level (gnus-info-level info)))
|
|
557 (and (<= entry-level list-level)
|
|
558 (>= entry-level lowest))))
|
|
559 (or (not (functionp predicate))
|
|
560 (funcall predicate info))
|
|
561 (or (not (stringp regexp))
|
|
562 (string-match regexp (gnus-info-group info))))))
|
|
563 (when visiblep
|
|
564 (if (stringp entry)
|
|
565 ;; Dead groups.
|
|
566 (gnus-group-insert-group-line
|
|
567 entry (if (member entry gnus-zombie-list)
|
|
568 gnus-level-zombie gnus-level-killed)
|
|
569 nil (- (1+ (cdr (setq active (gnus-active entry))))
|
|
570 (car active))
|
|
571 nil)
|
|
572 ;; Living groups.
|
|
573 (when (setq info (nth 2 entry))
|
|
574 (gnus-group-insert-group-line
|
|
575 (gnus-info-group info)
|
|
576 (gnus-info-level info) (gnus-info-marks info)
|
|
577 (car entry) (gnus-info-method info)))))
|
|
578 (when (and (listp entry)
|
|
579 (numberp (car entry)))
|
|
580 (incf unread (car entry)))
|
|
581 (when (listp entry)
|
|
582 (setq tick t))))
|
17493
|
583 (goto-char beg)
|
|
584 ;; Insert the topic line.
|
|
585 (when (and (not silent)
|
|
586 (or gnus-topic-display-empty-topics ;We want empty topics
|
|
587 (not (zerop unread)) ;Non-empty
|
|
588 tick ;Ticked articles
|
|
589 (/= point-max (point-max)))) ;Unactivated groups
|
|
590 (gnus-extent-start-open (point))
|
|
591 (gnus-topic-insert-topic-line
|
|
592 (car type) visiblep
|
|
593 (not (eq (nth 2 type) 'hidden))
|
|
594 level all-entries unread))
|
24357
|
595 (gnus-topic-update-unreads (car type) unread)
|
69337
|
596 (when gnus-group-update-tool-bar
|
|
597 (gnus-put-text-property beg end 'point-entered
|
|
598 'gnus-tool-bar-update)
|
|
599 (gnus-put-text-property beg end 'point-left
|
|
600 'gnus-tool-bar-update))
|
17493
|
601 (goto-char end)
|
|
602 unread))
|
|
603
|
|
604 (defun gnus-topic-remove-topic (&optional insert total-remove hide in-level)
|
|
605 "Remove the current topic."
|
|
606 (let ((topic (gnus-group-topic-name))
|
|
607 (level (gnus-group-topic-level))
|
|
608 (beg (progn (beginning-of-line) (point)))
|
|
609 buffer-read-only)
|
|
610 (when topic
|
|
611 (while (and (zerop (forward-line 1))
|
|
612 (> (or (gnus-group-topic-level) (1+ level)) level)))
|
|
613 (delete-region beg (point))
|
|
614 ;; Do the change in this rather odd manner because it has been
|
|
615 ;; reported that some topics share parts of some lists, for some
|
|
616 ;; reason. I have been unable to determine why this is the
|
|
617 ;; case, but this hack seems to take care of things.
|
|
618 (let ((data (cadr (gnus-topic-find-topology topic))))
|
|
619 (setcdr data
|
|
620 (list (if insert 'visible 'invisible)
|
31716
|
621 (caddr data)
|
17493
|
622 (cadddr data))))
|
|
623 (if total-remove
|
|
624 (setq gnus-topic-alist
|
|
625 (delq (assoc topic gnus-topic-alist) gnus-topic-alist))
|
|
626 (gnus-topic-insert-topic topic in-level)))))
|
|
627
|
|
628 (defun gnus-topic-insert-topic (topic &optional level)
|
|
629 "Insert TOPIC."
|
|
630 (gnus-group-prepare-topics
|
|
631 (car gnus-group-list-mode) (cdr gnus-group-list-mode)
|
|
632 nil nil topic level))
|
|
633
|
31716
|
634 (defun gnus-topic-fold (&optional insert topic)
|
17493
|
635 "Remove/insert the current topic."
|
31716
|
636 (let ((topic (or topic (gnus-group-topic-name))))
|
17493
|
637 (when topic
|
|
638 (save-excursion
|
|
639 (if (not (gnus-group-active-topic-p))
|
|
640 (gnus-topic-remove-topic
|
|
641 (or insert (not (gnus-topic-visible-p))))
|
|
642 (let ((gnus-topic-topology gnus-topic-active-topology)
|
|
643 (gnus-topic-alist gnus-topic-active-alist)
|
|
644 (gnus-group-list-mode (cons 5 t)))
|
|
645 (gnus-topic-remove-topic
|
|
646 (or insert (not (gnus-topic-visible-p))) nil nil 9)
|
|
647 (gnus-topic-enter-dribble)))))))
|
|
648
|
|
649 (defun gnus-topic-insert-topic-line (name visiblep shownp level entries
|
|
650 &optional unread)
|
|
651 (let* ((visible (if visiblep "" "..."))
|
|
652 (indentation (make-string (* gnus-topic-indent-level level) ? ))
|
|
653 (total-number-of-articles unread)
|
|
654 (number-of-groups (length entries))
|
24357
|
655 (active-topic (eq gnus-topic-alist gnus-topic-active-alist))
|
|
656 gnus-tmp-header)
|
|
657 (gnus-topic-update-unreads name unread)
|
17493
|
658 (beginning-of-line)
|
|
659 ;; Insert the text.
|
31716
|
660 (if shownp
|
|
661 (gnus-add-text-properties
|
|
662 (point)
|
|
663 (prog1 (1+ (point))
|
|
664 (eval gnus-topic-line-format-spec))
|
|
665 (list 'gnus-topic (intern name)
|
|
666 'gnus-topic-level level
|
|
667 'gnus-topic-unread unread
|
|
668 'gnus-active active-topic
|
|
669 'gnus-topic-visible visiblep)))))
|
17493
|
670
|
24357
|
671 (defun gnus-topic-update-unreads (topic unreads)
|
|
672 (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads)
|
|
673 gnus-topic-unreads))
|
|
674 (push (cons topic unreads) gnus-topic-unreads))
|
|
675
|
17493
|
676 (defun gnus-topic-update-topics-containing-group (group)
|
|
677 "Update all topics that have GROUP as a member."
|
|
678 (when (and (eq major-mode 'gnus-group-mode)
|
|
679 gnus-topic-mode)
|
|
680 (save-excursion
|
|
681 (let ((alist gnus-topic-alist))
|
|
682 ;; This is probably not entirely correct. If a topic
|
|
683 ;; isn't shown, then it's not updated. But the updating
|
|
684 ;; should be performed in any case, since the topic's
|
|
685 ;; parent should be updated. Pfft.
|
|
686 (while alist
|
|
687 (when (and (member group (cdar alist))
|
|
688 (gnus-topic-goto-topic (caar alist)))
|
|
689 (gnus-topic-update-topic-line (caar alist)))
|
|
690 (pop alist))))))
|
|
691
|
|
692 (defun gnus-topic-update-topic ()
|
|
693 "Update all parent topics to the current group."
|
|
694 (when (and (eq major-mode 'gnus-group-mode)
|
|
695 gnus-topic-mode)
|
|
696 (let ((group (gnus-group-group-name))
|
56927
|
697 (m (point-marker))
|
17493
|
698 (buffer-read-only nil))
|
|
699 (when (and group
|
|
700 (gnus-get-info group)
|
|
701 (gnus-topic-goto-topic (gnus-current-topic)))
|
|
702 (gnus-topic-update-topic-line (gnus-group-topic-name))
|
19969
|
703 (goto-char m)
|
|
704 (set-marker m nil)
|
17493
|
705 (gnus-group-position-point)))))
|
|
706
|
|
707 (defun gnus-topic-goto-missing-group (group)
|
|
708 "Place point where GROUP is supposed to be inserted."
|
|
709 (let* ((topic (gnus-group-topic group))
|
|
710 (groups (cdr (assoc topic gnus-topic-alist)))
|
|
711 (g (cdr (member group groups)))
|
31716
|
712 (unfound t)
|
|
713 entry)
|
17493
|
714 ;; Try to jump to a visible group.
|
56927
|
715 (while (and g
|
|
716 (not (gnus-group-goto-group (car g) t)))
|
17493
|
717 (pop g))
|
|
718 ;; It wasn't visible, so we try to see where to insert it.
|
|
719 (when (not g)
|
|
720 (setq g (cdr (member group (reverse groups))))
|
|
721 (while (and g unfound)
|
|
722 (when (gnus-group-goto-group (pop g) t)
|
|
723 (forward-line 1)
|
|
724 (setq unfound nil)))
|
|
725 (when (and unfound
|
|
726 topic
|
|
727 (not (gnus-topic-goto-missing-topic topic)))
|
56927
|
728 (gnus-topic-display-missing-topic topic)))))
|
|
729
|
|
730 (defun gnus-topic-display-missing-topic (topic)
|
|
731 "Insert topic lines recursively for missing topics."
|
|
732 (let ((parent (gnus-topic-find-topology
|
|
733 (gnus-topic-parent-topic topic))))
|
|
734 (when (and parent
|
|
735 (not (gnus-topic-goto-missing-topic (caadr parent))))
|
|
736 (gnus-topic-display-missing-topic (caadr parent))))
|
|
737 (gnus-topic-goto-missing-topic topic)
|
85712
|
738 ;; Skip past all groups in the topic we're in.
|
|
739 (while (gnus-group-group-name)
|
|
740 (forward-line 1))
|
56927
|
741 (let* ((top (gnus-topic-find-topology topic))
|
|
742 (children (cddr top))
|
|
743 (type (cadr top))
|
|
744 (unread 0)
|
|
745 (entries (gnus-topic-find-groups
|
|
746 (car type) (car gnus-group-list-mode)
|
|
747 (cdr gnus-group-list-mode)))
|
|
748 entry)
|
|
749 (while children
|
|
750 (incf unread (gnus-topic-unread (caar (pop children)))))
|
|
751 (while (setq entry (pop entries))
|
|
752 (when (numberp (car entry))
|
|
753 (incf unread (car entry))))
|
|
754 (gnus-topic-insert-topic-line
|
|
755 topic t t (car (gnus-topic-find-topology topic)) nil unread)))
|
17493
|
756
|
|
757 (defun gnus-topic-goto-missing-topic (topic)
|
|
758 (if (gnus-topic-goto-topic topic)
|
|
759 (forward-line 1)
|
|
760 ;; Topic not displayed.
|
|
761 (let* ((top (gnus-topic-find-topology
|
|
762 (gnus-topic-parent-topic topic)))
|
|
763 (tp (reverse (cddr top))))
|
31716
|
764 (if (not top)
|
|
765 (gnus-topic-insert-topic-line
|
|
766 topic t t (car (gnus-topic-find-topology topic)) nil 0)
|
|
767 (while (not (equal (caaar tp) topic))
|
|
768 (setq tp (cdr tp)))
|
|
769 (pop tp)
|
|
770 (while (and tp
|
|
771 (not (gnus-topic-goto-topic (caaar tp))))
|
|
772 (pop tp))
|
|
773 (if tp
|
|
774 (gnus-topic-forward-topic 1)
|
|
775 (gnus-topic-goto-missing-topic (caadr top)))))
|
17493
|
776 nil))
|
|
777
|
|
778 (defun gnus-topic-update-topic-line (topic-name &optional reads)
|
|
779 (let* ((top (gnus-topic-find-topology topic-name))
|
|
780 (type (cadr top))
|
|
781 (children (cddr top))
|
|
782 (entries (gnus-topic-find-groups
|
|
783 (car type) (car gnus-group-list-mode)
|
|
784 (cdr gnus-group-list-mode)))
|
|
785 (parent (gnus-topic-parent-topic topic-name))
|
|
786 (all-entries entries)
|
|
787 (unread 0)
|
24357
|
788 old-unread entry new-unread)
|
17493
|
789 (when (gnus-topic-goto-topic (car type))
|
|
790 ;; Tally all the groups that belong in this topic.
|
|
791 (if reads
|
|
792 (setq unread (- (gnus-group-topic-unread) reads))
|
|
793 (while children
|
|
794 (incf unread (gnus-topic-unread (caar (pop children)))))
|
|
795 (while (setq entry (pop entries))
|
|
796 (when (numberp (car entry))
|
|
797 (incf unread (car entry)))))
|
|
798 (setq old-unread (gnus-group-topic-unread))
|
|
799 ;; Insert the topic line.
|
|
800 (gnus-topic-insert-topic-line
|
|
801 (car type) (gnus-topic-visible-p)
|
|
802 (not (eq (nth 2 type) 'hidden))
|
|
803 (gnus-group-topic-level) all-entries unread)
|
24357
|
804 (gnus-delete-line)
|
|
805 (forward-line -1)
|
|
806 (setq new-unread (gnus-group-topic-unread)))
|
17493
|
807 (when parent
|
|
808 (forward-line -1)
|
|
809 (gnus-topic-update-topic-line
|
24357
|
810 parent
|
|
811 (- (or old-unread 0) (or new-unread 0))))
|
17493
|
812 unread))
|
|
813
|
|
814 (defun gnus-topic-group-indentation ()
|
|
815 (make-string
|
|
816 (* gnus-topic-indent-level
|
|
817 (or (save-excursion
|
|
818 (forward-line -1)
|
|
819 (gnus-topic-goto-topic (gnus-current-topic))
|
|
820 (gnus-group-topic-level))
|
|
821 0))
|
|
822 ? ))
|
|
823
|
|
824 ;;; Initialization
|
|
825
|
|
826 (gnus-add-shutdown 'gnus-topic-close 'gnus)
|
|
827
|
|
828 (defun gnus-topic-close ()
|
|
829 (setq gnus-topic-active-topology nil
|
|
830 gnus-topic-active-alist nil
|
|
831 gnus-topic-killed-topics nil
|
|
832 gnus-topology-checked-p nil))
|
|
833
|
|
834 (defun gnus-topic-check-topology ()
|
|
835 ;; The first time we set the topology to whatever we have
|
|
836 ;; gotten here, which can be rather random.
|
|
837 (unless gnus-topic-alist
|
|
838 (gnus-topic-init-alist))
|
|
839
|
|
840 (setq gnus-topology-checked-p t)
|
|
841 ;; Go through the topic alist and make sure that all topics
|
|
842 ;; are in the topic topology.
|
|
843 (let ((topics (gnus-topic-list))
|
|
844 (alist gnus-topic-alist)
|
|
845 changed)
|
|
846 (while alist
|
|
847 (unless (member (caar alist) topics)
|
|
848 (nconc gnus-topic-topology
|
|
849 (list (list (list (caar alist) 'visible))))
|
|
850 (setq changed t))
|
|
851 (setq alist (cdr alist)))
|
|
852 (when changed
|
|
853 (gnus-topic-enter-dribble))
|
|
854 ;; Conversely, go through the topology and make sure that all
|
|
855 ;; topologies have alists.
|
|
856 (while topics
|
|
857 (unless (assoc (car topics) gnus-topic-alist)
|
|
858 (push (list (car topics)) gnus-topic-alist))
|
|
859 (pop topics)))
|
|
860 ;; Go through all living groups and make sure that
|
|
861 ;; they belong to some topic.
|
85712
|
862 (let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist)))
|
19969
|
863 (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist)))
|
17493
|
864 (newsrc (cdr gnus-newsrc-alist))
|
|
865 group)
|
|
866 (while newsrc
|
|
867 (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)
|
19969
|
868 (setcdr entry (list group))
|
|
869 (setq entry (cdr entry)))))
|
17493
|
870 ;; Go through all topics and make sure they contain only living groups.
|
|
871 (let ((alist gnus-topic-alist)
|
|
872 topic)
|
|
873 (while (setq topic (pop alist))
|
|
874 (while (cdr topic)
|
19969
|
875 (if (and (cadr topic)
|
85712
|
876 (gnus-group-entry (cadr topic)))
|
17493
|
877 (setq topic (cdr topic))
|
|
878 (setcdr topic (cddr topic)))))))
|
|
879
|
|
880 (defun gnus-topic-init-alist ()
|
|
881 "Initialize the topic structures."
|
|
882 (setq gnus-topic-topology
|
|
883 (cons (list "Gnus" 'visible)
|
|
884 (mapcar (lambda (topic)
|
|
885 (list (list (car topic) 'visible)))
|
|
886 '(("misc")))))
|
|
887 (setq gnus-topic-alist
|
|
888 (list (cons "misc"
|
|
889 (mapcar (lambda (info) (gnus-info-group info))
|
|
890 (cdr gnus-newsrc-alist)))
|
|
891 (list "Gnus")))
|
|
892 (gnus-topic-enter-dribble))
|
|
893
|
|
894 ;;; Maintenance
|
|
895
|
|
896 (defun gnus-topic-clean-alist ()
|
|
897 "Remove bogus groups from the topic alist."
|
|
898 (let ((topic-alist gnus-topic-alist)
|
|
899 result topic)
|
|
900 (unless gnus-killed-hashtb
|
|
901 (gnus-make-hashtable-from-killed))
|
|
902 (while (setq topic (pop topic-alist))
|
|
903 (let ((topic-name (pop topic))
|
|
904 group filtered-topic)
|
|
905 (while (setq group (pop topic))
|
85712
|
906 (when (and (or (gnus-active group)
|
17493
|
907 (gnus-info-method (gnus-get-info group)))
|
|
908 (not (gnus-gethash group gnus-killed-hashtb)))
|
|
909 (push group filtered-topic)))
|
|
910 (push (cons topic-name (nreverse filtered-topic)) result)))
|
|
911 (setq gnus-topic-alist (nreverse result))))
|
|
912
|
19969
|
913 (defun gnus-topic-change-level (group level oldlevel &optional previous)
|
17493
|
914 "Run when changing levels to enter/remove groups from topics."
|
|
915 (save-excursion
|
|
916 (set-buffer gnus-group-buffer)
|
24357
|
917 (let ((buffer-read-only nil))
|
|
918 (unless gnus-topic-inhibit-change-level
|
|
919 (gnus-group-goto-group (or (car (nth 2 previous)) group))
|
|
920 (when (and gnus-topic-mode
|
|
921 gnus-topic-alist
|
|
922 (not gnus-topic-inhibit-change-level))
|
|
923 ;; Remove the group from the topics.
|
|
924 (if (and (< oldlevel gnus-level-zombie)
|
|
925 (>= level gnus-level-zombie))
|
|
926 (let ((alist gnus-topic-alist))
|
|
927 (while (gnus-group-goto-group group)
|
|
928 (gnus-delete-line))
|
|
929 (while alist
|
|
930 (when (member group (car alist))
|
|
931 (setcdr (car alist) (delete group (cdar alist))))
|
|
932 (pop alist)))
|
|
933 ;; If the group is subscribed we enter it into the topics.
|
|
934 (when (and (< level gnus-level-zombie)
|
|
935 (>= oldlevel gnus-level-zombie))
|
|
936 (let* ((prev (gnus-group-group-name))
|
|
937 (gnus-topic-inhibit-change-level t)
|
|
938 (gnus-group-indentation
|
|
939 (make-string
|
|
940 (* gnus-topic-indent-level
|
|
941 (or (save-excursion
|
|
942 (gnus-topic-goto-topic (gnus-current-topic))
|
|
943 (gnus-group-topic-level))
|
|
944 0))
|
|
945 ? ))
|
|
946 (yanked (list group))
|
|
947 alist talist end)
|
56927
|
948 ;; Then we enter the yanked groups into the topics
|
|
949 ;; they belong to.
|
24357
|
950 (when (setq alist (assoc (save-excursion
|
|
951 (forward-line -1)
|
|
952 (or
|
|
953 (gnus-current-topic)
|
|
954 (caar gnus-topic-topology)))
|
|
955 gnus-topic-alist))
|
|
956 (setq talist alist)
|
|
957 (when (stringp yanked)
|
|
958 (setq yanked (list yanked)))
|
|
959 (if (not prev)
|
|
960 (nconc alist yanked)
|
|
961 (if (not (cdr alist))
|
|
962 (setcdr alist (nconc yanked (cdr alist)))
|
|
963 (while (and (not end) (cdr alist))
|
|
964 (when (equal (cadr alist) prev)
|
|
965 (setcdr alist (nconc yanked (cdr alist)))
|
|
966 (setq end t))
|
|
967 (setq alist (cdr alist)))
|
|
968 (unless end
|
|
969 (nconc talist yanked))))))
|
|
970 (gnus-topic-update-topic))))))))
|
17493
|
971
|
|
972 (defun gnus-topic-goto-next-group (group props)
|
|
973 "Go to group or the next group after group."
|
|
974 (if (not group)
|
|
975 (if (not (memq 'gnus-topic props))
|
|
976 (goto-char (point-max))
|
|
977 (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props)))))
|
|
978 (if (gnus-group-goto-group group)
|
|
979 t
|
|
980 ;; The group is no longer visible.
|
|
981 (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist))
|
|
982 (after (cdr (member group (cdr list)))))
|
|
983 ;; First try to put point on a group after the current one.
|
|
984 (while (and after
|
|
985 (not (gnus-group-goto-group (car after))))
|
|
986 (setq after (cdr after)))
|
|
987 ;; Then try to put point on a group before point.
|
|
988 (unless after
|
|
989 (setq after (cdr (member group (reverse (cdr list)))))
|
|
990 (while (and after
|
|
991 (not (gnus-group-goto-group (car after))))
|
|
992 (setq after (cdr after))))
|
|
993 ;; Finally, just put point on the topic.
|
|
994 (if (not (car list))
|
|
995 (goto-char (point-min))
|
|
996 (unless after
|
|
997 (gnus-topic-goto-topic (car list))
|
|
998 (setq after nil)))
|
|
999 t))))
|
|
1000
|
|
1001 ;;; Topic-active functions
|
|
1002
|
|
1003 (defun gnus-topic-grok-active (&optional force)
|
|
1004 "Parse all active groups and create topic structures for them."
|
|
1005 ;; First we make sure that we have really read the active file.
|
|
1006 (when (or force
|
|
1007 (not gnus-topic-active-alist))
|
|
1008 (let (groups)
|
|
1009 ;; Get a list of all groups available.
|
|
1010 (mapatoms (lambda (g) (when (symbol-value g)
|
|
1011 (push (symbol-name g) groups)))
|
|
1012 gnus-active-hashtb)
|
|
1013 (setq groups (sort groups 'string<))
|
|
1014 ;; Init the variables.
|
|
1015 (setq gnus-topic-active-topology (list (list "" 'visible)))
|
|
1016 (setq gnus-topic-active-alist nil)
|
|
1017 ;; Descend the top-level hierarchy.
|
|
1018 (gnus-topic-grok-active-1 gnus-topic-active-topology groups)
|
|
1019 ;; Set the top-level topic names to something nice.
|
|
1020 (setcar (car gnus-topic-active-topology) "Gnus active")
|
|
1021 (setcar (car gnus-topic-active-alist) "Gnus active"))))
|
|
1022
|
|
1023 (defun gnus-topic-grok-active-1 (topology groups)
|
|
1024 (let* ((name (caar topology))
|
|
1025 (prefix (concat "^" (regexp-quote name)))
|
|
1026 tgroups ntopology group)
|
|
1027 (while (and groups
|
|
1028 (string-match prefix (setq group (car groups))))
|
|
1029 (if (not (string-match "\\." group (match-end 0)))
|
|
1030 ;; There are no further hierarchies here, so we just
|
|
1031 ;; enter this group into the list belonging to this
|
|
1032 ;; topic.
|
|
1033 (push (pop groups) tgroups)
|
|
1034 ;; New sub-hierarchy, so we add it to the topology.
|
|
1035 (nconc topology (list (setq ntopology
|
|
1036 (list (list (substring
|
|
1037 group 0 (match-end 0))
|
|
1038 'invisible)))))
|
|
1039 ;; Descend the hierarchy.
|
|
1040 (setq groups (gnus-topic-grok-active-1 ntopology groups))))
|
|
1041 ;; We remove the trailing "." from the topic name.
|
|
1042 (setq name
|
|
1043 (if (string-match "\\.$" name)
|
|
1044 (substring name 0 (match-beginning 0))
|
|
1045 name))
|
|
1046 ;; Add this topic and its groups to the topic alist.
|
|
1047 (push (cons name (nreverse tgroups)) gnus-topic-active-alist)
|
|
1048 (setcar (car topology) name)
|
|
1049 ;; We return the rest of the groups that didn't belong
|
|
1050 ;; to this topic.
|
|
1051 groups))
|
|
1052
|
|
1053 ;;; Topic mode, commands and keymap.
|
|
1054
|
|
1055 (defvar gnus-topic-mode-map nil)
|
|
1056 (defvar gnus-group-topic-map nil)
|
|
1057
|
|
1058 (unless gnus-topic-mode-map
|
|
1059 (setq gnus-topic-mode-map (make-sparse-keymap))
|
|
1060
|
|
1061 ;; Override certain group mode keys.
|
|
1062 (gnus-define-keys gnus-topic-mode-map
|
|
1063 "=" gnus-topic-select-group
|
|
1064 "\r" gnus-topic-select-group
|
|
1065 " " gnus-topic-read-group
|
31716
|
1066 "\C-c\C-x" gnus-topic-expire-articles
|
56927
|
1067 "c" gnus-topic-catchup-articles
|
17493
|
1068 "\C-k" gnus-topic-kill-group
|
|
1069 "\C-y" gnus-topic-yank-group
|
|
1070 "\M-g" gnus-topic-get-new-news-this-topic
|
|
1071 "AT" gnus-topic-list-active
|
|
1072 "Gp" gnus-topic-edit-parameters
|
|
1073 "#" gnus-topic-mark-topic
|
|
1074 "\M-#" gnus-topic-unmark-topic
|
24357
|
1075 [tab] gnus-topic-indent
|
|
1076 [(meta tab)] gnus-topic-unindent
|
|
1077 "\C-i" gnus-topic-indent
|
|
1078 "\M-\C-i" gnus-topic-unindent
|
17493
|
1079 gnus-mouse-2 gnus-mouse-pick-topic)
|
|
1080
|
|
1081 ;; Define a new submap.
|
|
1082 (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map)
|
|
1083 "#" gnus-topic-mark-topic
|
|
1084 "\M-#" gnus-topic-unmark-topic
|
|
1085 "n" gnus-topic-create-topic
|
|
1086 "m" gnus-topic-move-group
|
|
1087 "D" gnus-topic-remove-group
|
|
1088 "c" gnus-topic-copy-group
|
|
1089 "h" gnus-topic-hide-topic
|
|
1090 "s" gnus-topic-show-topic
|
31716
|
1091 "j" gnus-topic-jump-to-topic
|
17493
|
1092 "M" gnus-topic-move-matching
|
|
1093 "C" gnus-topic-copy-matching
|
56927
|
1094 "\M-p" gnus-topic-goto-previous-topic
|
|
1095 "\M-n" gnus-topic-goto-next-topic
|
17493
|
1096 "\C-i" gnus-topic-indent
|
|
1097 [tab] gnus-topic-indent
|
|
1098 "r" gnus-topic-rename
|
19969
|
1099 "\177" gnus-topic-delete
|
|
1100 [delete] gnus-topic-delete
|
24357
|
1101 "H" gnus-topic-toggle-display-empty-topics)
|
17493
|
1102
|
|
1103 (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map)
|
|
1104 "s" gnus-topic-sort-groups
|
|
1105 "a" gnus-topic-sort-groups-by-alphabet
|
|
1106 "u" gnus-topic-sort-groups-by-unread
|
|
1107 "l" gnus-topic-sort-groups-by-level
|
56927
|
1108 "e" gnus-topic-sort-groups-by-server
|
17493
|
1109 "v" gnus-topic-sort-groups-by-score
|
|
1110 "r" gnus-topic-sort-groups-by-rank
|
|
1111 "m" gnus-topic-sort-groups-by-method))
|
|
1112
|
|
1113 (defun gnus-topic-make-menu-bar ()
|
|
1114 (unless (boundp 'gnus-topic-menu)
|
|
1115 (easy-menu-define
|
|
1116 gnus-topic-menu gnus-topic-mode-map ""
|
|
1117 '("Topics"
|
|
1118 ["Toggle topics" gnus-topic-mode t]
|
|
1119 ("Groups"
|
56927
|
1120 ["Copy..." gnus-topic-copy-group t]
|
|
1121 ["Move..." gnus-topic-move-group t]
|
17493
|
1122 ["Remove" gnus-topic-remove-group t]
|
56927
|
1123 ["Copy matching..." gnus-topic-copy-matching t]
|
|
1124 ["Move matching..." gnus-topic-move-matching t])
|
17493
|
1125 ("Topics"
|
56927
|
1126 ["Goto..." gnus-topic-jump-to-topic t]
|
17493
|
1127 ["Show" gnus-topic-show-topic t]
|
|
1128 ["Hide" gnus-topic-hide-topic t]
|
|
1129 ["Delete" gnus-topic-delete t]
|
56927
|
1130 ["Rename..." gnus-topic-rename t]
|
|
1131 ["Create..." gnus-topic-create-topic t]
|
17493
|
1132 ["Mark" gnus-topic-mark-topic t]
|
19969
|
1133 ["Indent" gnus-topic-indent t]
|
31716
|
1134 ["Sort" gnus-topic-sort-topics t]
|
56927
|
1135 ["Previous topic" gnus-topic-goto-previous-topic t]
|
|
1136 ["Next topic" gnus-topic-goto-next-topic t]
|
19969
|
1137 ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t]
|
|
1138 ["Edit parameters" gnus-topic-edit-parameters t])
|
17493
|
1139 ["List active" gnus-topic-list-active t]))))
|
|
1140
|
|
1141 (defun gnus-topic-mode (&optional arg redisplay)
|
|
1142 "Minor mode for topicsifying Gnus group buffers."
|
|
1143 (interactive (list current-prefix-arg t))
|
|
1144 (when (eq major-mode 'gnus-group-mode)
|
|
1145 (make-local-variable 'gnus-topic-mode)
|
|
1146 (setq gnus-topic-mode
|
|
1147 (if (null arg) (not gnus-topic-mode)
|
|
1148 (> (prefix-numeric-value arg) 0)))
|
|
1149 ;; Infest Gnus with topics.
|
31716
|
1150 (if (not gnus-topic-mode)
|
56927
|
1151 (setq gnus-goto-missing-group-function nil)
|
17493
|
1152 (when (gnus-visual-p 'topic-menu 'menu)
|
|
1153 (gnus-topic-make-menu-bar))
|
24357
|
1154 (gnus-set-format 'topic t)
|
85712
|
1155 (add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map)
|
17493
|
1156 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
|
|
1157 (set (make-local-variable 'gnus-group-prepare-function)
|
|
1158 'gnus-group-prepare-topics)
|
|
1159 (set (make-local-variable 'gnus-group-get-parameter-function)
|
|
1160 'gnus-group-topic-parameters)
|
|
1161 (set (make-local-variable 'gnus-group-goto-next-group-function)
|
|
1162 'gnus-topic-goto-next-group)
|
|
1163 (set (make-local-variable 'gnus-group-indentation-function)
|
|
1164 'gnus-topic-group-indentation)
|
|
1165 (set (make-local-variable 'gnus-group-update-group-function)
|
|
1166 'gnus-topic-update-topics-containing-group)
|
|
1167 (set (make-local-variable 'gnus-group-sort-alist-function)
|
|
1168 'gnus-group-sort-topic)
|
|
1169 (setq gnus-group-change-level-function 'gnus-topic-change-level)
|
|
1170 (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group)
|
56927
|
1171 (gnus-make-local-hook 'gnus-check-bogus-groups-hook)
|
|
1172 (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist
|
|
1173 nil 'local)
|
17493
|
1174 (setq gnus-topology-checked-p nil)
|
|
1175 ;; We check the topology.
|
|
1176 (when gnus-newsrc-alist
|
|
1177 (gnus-topic-check-topology))
|
24357
|
1178 (gnus-run-hooks 'gnus-topic-mode-hook))
|
17493
|
1179 ;; Remove topic infestation.
|
|
1180 (unless gnus-topic-mode
|
|
1181 (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
|
33326
|
1182 (setq gnus-group-change-level-function nil)
|
17493
|
1183 (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist)
|
|
1184 (setq gnus-group-prepare-function 'gnus-group-prepare-flat)
|
|
1185 (setq gnus-group-sort-alist-function 'gnus-group-sort-flat))
|
|
1186 (when redisplay
|
|
1187 (gnus-group-list-groups))))
|
|
1188
|
|
1189 (defun gnus-topic-select-group (&optional all)
|
|
1190 "Select this newsgroup.
|
|
1191 No article is selected automatically.
|
56927
|
1192 If the group is opened, just switch the summary buffer.
|
17493
|
1193 If ALL is non-nil, already read articles become readable.
|
92147
|
1194
|
|
1195 If ALL is a positive number, fetch this number of the latest
|
|
1196 articles in the group. If ALL is a negative number, fetch this
|
|
1197 number of the earliest articles in the group.
|
17493
|
1198
|
|
1199 If performed over a topic line, toggle folding the topic."
|
|
1200 (interactive "P")
|
56927
|
1201 (when (and (eobp) (not (gnus-group-group-name)))
|
|
1202 (forward-line -1))
|
17493
|
1203 (if (gnus-group-topic-p)
|
|
1204 (let ((gnus-group-list-mode
|
|
1205 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
|
31716
|
1206 (gnus-topic-fold all)
|
|
1207 (gnus-dribble-touch))
|
17493
|
1208 (gnus-group-select-group all)))
|
|
1209
|
|
1210 (defun gnus-mouse-pick-topic (e)
|
|
1211 "Select the group or topic under the mouse pointer."
|
|
1212 (interactive "e")
|
|
1213 (mouse-set-point e)
|
|
1214 (gnus-topic-read-group nil))
|
|
1215
|
31716
|
1216 (defun gnus-topic-expire-articles (topic)
|
|
1217 "Expire articles in this topic or group."
|
|
1218 (interactive (list (gnus-group-topic-name)))
|
|
1219 (if (not topic)
|
|
1220 (call-interactively 'gnus-group-expire-articles)
|
|
1221 (save-excursion
|
|
1222 (gnus-message 5 "Expiring groups in %s..." topic)
|
|
1223 (let ((gnus-group-marked
|
|
1224 (mapcar (lambda (entry) (car (nth 2 entry)))
|
56927
|
1225 (gnus-topic-find-groups topic gnus-level-killed t
|
|
1226 nil t))))
|
31716
|
1227 (gnus-group-expire-articles nil))
|
|
1228 (gnus-message 5 "Expiring groups in %s...done" topic))))
|
|
1229
|
56927
|
1230 (defun gnus-topic-catchup-articles (topic)
|
|
1231 "Catchup this topic or group.
|
|
1232 Also see `gnus-group-catchup'."
|
|
1233 (interactive (list (gnus-group-topic-name)))
|
|
1234 (if (not topic)
|
|
1235 (call-interactively 'gnus-group-catchup-current)
|
|
1236 (save-excursion
|
|
1237 (let* ((groups
|
|
1238 (mapcar (lambda (entry) (car (nth 2 entry)))
|
|
1239 (gnus-topic-find-groups topic gnus-level-killed t
|
|
1240 nil t)))
|
|
1241 (buffer-read-only nil)
|
|
1242 (gnus-group-marked groups))
|
|
1243 (gnus-group-catchup-current)
|
|
1244 (mapcar 'gnus-topic-update-topics-containing-group groups)))))
|
|
1245
|
17493
|
1246 (defun gnus-topic-read-group (&optional all no-article group)
|
|
1247 "Read news in this newsgroup.
|
|
1248 If the prefix argument ALL is non-nil, already read articles become
|
92147
|
1249 readable.
|
|
1250
|
|
1251 If ALL is a positive number, fetch this number of the latest
|
|
1252 articles in the group. If ALL is a negative number, fetch this
|
|
1253 number of the earliest articles in the group.
|
|
1254
|
|
1255 If the optional argument NO-ARTICLE is non-nil, no article will
|
|
1256 be auto-selected upon group entry. If GROUP is non-nil, fetch
|
|
1257 that group.
|
17493
|
1258
|
|
1259 If performed over a topic line, toggle folding the topic."
|
|
1260 (interactive "P")
|
|
1261 (if (gnus-group-topic-p)
|
|
1262 (let ((gnus-group-list-mode
|
|
1263 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
|
|
1264 (gnus-topic-fold all))
|
|
1265 (gnus-group-read-group all no-article group)))
|
|
1266
|
|
1267 (defun gnus-topic-create-topic (topic parent &optional previous full-topic)
|
19969
|
1268 "Create a new TOPIC under PARENT.
|
|
1269 When used interactively, PARENT will be the topic under point."
|
17493
|
1270 (interactive
|
|
1271 (list
|
|
1272 (read-string "New topic: ")
|
|
1273 (gnus-current-topic)))
|
|
1274 ;; Check whether this topic already exists.
|
|
1275 (when (gnus-topic-find-topology topic)
|
|
1276 (error "Topic already exists"))
|
|
1277 (unless parent
|
|
1278 (setq parent (caar gnus-topic-topology)))
|
|
1279 (let ((top (cdr (gnus-topic-find-topology parent)))
|
34858
6c93e7d6a930
* message.el (message-setup): Use cons. Suggested by Johan Vromans
ShengHuo ZHU <zsh@cs.rochester.edu>
diff
changeset
|
1280 (full-topic (or full-topic (list (list topic 'visible nil nil)))))
|
17493
|
1281 (unless top
|
|
1282 (error "No such parent topic: %s" parent))
|
|
1283 (if previous
|
|
1284 (progn
|
|
1285 (while (and (cdr top)
|
|
1286 (not (equal (caaadr top) previous)))
|
|
1287 (setq top (cdr top)))
|
|
1288 (setcdr top (cons full-topic (cdr top))))
|
|
1289 (nconc top (list full-topic)))
|
|
1290 (unless (assoc topic gnus-topic-alist)
|
|
1291 (push (list topic) gnus-topic-alist)))
|
|
1292 (gnus-topic-enter-dribble)
|
|
1293 (gnus-group-list-groups)
|
|
1294 (gnus-topic-goto-topic topic))
|
|
1295
|
49598
|
1296 ;; FIXME:
|
|
1297 ;; 1. When the marked groups are overlapped with the process
|
31716
|
1298 ;; region, the behavior of move or remove is not right.
|
49598
|
1299 ;; 2. Can't process on several marked groups with a same name,
|
31716
|
1300 ;; because gnus-group-marked only keeps one copy.
|
|
1301
|
17493
|
1302 (defun gnus-topic-move-group (n topic &optional copyp)
|
|
1303 "Move the next N groups to TOPIC.
|
|
1304 If COPYP, copy the groups instead."
|
|
1305 (interactive
|
|
1306 (list current-prefix-arg
|
56927
|
1307 (gnus-completing-read "Move to topic" gnus-topic-alist nil t
|
|
1308 'gnus-topic-history)))
|
49598
|
1309 (let ((use-marked (and (not n) (not (gnus-region-active-p))
|
31716
|
1310 gnus-group-marked t))
|
|
1311 (groups (gnus-group-process-prefix n))
|
17493
|
1312 (topicl (assoc topic gnus-topic-alist))
|
31716
|
1313 (start-topic (gnus-group-topic-name))
|
17493
|
1314 (start-group (progn (forward-line 1) (gnus-group-group-name)))
|
|
1315 entry)
|
31716
|
1316 (if (and (not groups) (not copyp) start-topic)
|
|
1317 (gnus-topic-move start-topic topic)
|
85712
|
1318 (dolist (g groups)
|
|
1319 (gnus-group-remove-mark g use-marked)
|
|
1320 (when (and
|
|
1321 (setq entry (assoc (gnus-current-topic) gnus-topic-alist))
|
|
1322 (not copyp))
|
|
1323 (setcdr entry (gnus-delete-first g (cdr entry))))
|
|
1324 (nconc topicl (list g)))
|
31716
|
1325 (gnus-topic-enter-dribble)
|
|
1326 (if start-group
|
|
1327 (gnus-group-goto-group start-group)
|
|
1328 (gnus-topic-goto-topic start-topic))
|
|
1329 (gnus-group-list-groups))))
|
|
1330
|
|
1331 (defun gnus-topic-remove-group (&optional n)
|
|
1332 "Remove the current group from the topic."
|
|
1333 (interactive "P")
|
49598
|
1334 (let ((use-marked (and (not n) (not (gnus-region-active-p))
|
31716
|
1335 gnus-group-marked t))
|
|
1336 (groups (gnus-group-process-prefix n)))
|
85712
|
1337 (mapc
|
31716
|
1338 (lambda (group)
|
|
1339 (gnus-group-remove-mark group use-marked)
|
|
1340 (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
|
|
1341 (buffer-read-only nil))
|
|
1342 (when (and topicl group)
|
|
1343 (gnus-delete-line)
|
|
1344 (gnus-delete-first group topicl))
|
|
1345 (gnus-topic-update-topic)))
|
17493
|
1346 groups)
|
|
1347 (gnus-topic-enter-dribble)
|
31716
|
1348 (gnus-group-position-point)))
|
17493
|
1349
|
|
1350 (defun gnus-topic-copy-group (n topic)
|
|
1351 "Copy the current group to a topic."
|
|
1352 (interactive
|
|
1353 (list current-prefix-arg
|
|
1354 (completing-read "Copy to topic: " gnus-topic-alist nil t)))
|
|
1355 (gnus-topic-move-group n topic t))
|
|
1356
|
|
1357 (defun gnus-topic-kill-group (&optional n discard)
|
|
1358 "Kill the next N groups."
|
|
1359 (interactive "P")
|
|
1360 (if (gnus-group-topic-p)
|
|
1361 (let ((topic (gnus-group-topic-name)))
|
|
1362 (push (cons
|
|
1363 (gnus-topic-find-topology topic)
|
|
1364 (assoc topic gnus-topic-alist))
|
|
1365 gnus-topic-killed-topics)
|
|
1366 (gnus-topic-remove-topic nil t)
|
|
1367 (gnus-topic-find-topology topic nil nil gnus-topic-topology)
|
|
1368 (gnus-topic-enter-dribble))
|
|
1369 (gnus-group-kill-group n discard)
|
31716
|
1370 (if (not (gnus-group-topic-p))
|
|
1371 (gnus-topic-update-topic)
|
|
1372 ;; Move up one line so that we update the right topic.
|
|
1373 (forward-line -1)
|
|
1374 (gnus-topic-update-topic)
|
|
1375 (forward-line 1))))
|
17493
|
1376
|
|
1377 (defun gnus-topic-yank-group (&optional arg)
|
|
1378 "Yank the last topic."
|
|
1379 (interactive "p")
|
|
1380 (if gnus-topic-killed-topics
|
|
1381 (let* ((previous
|
|
1382 (or (gnus-group-topic-name)
|
|
1383 (gnus-topic-next-topic (gnus-current-topic))))
|
|
1384 (data (pop gnus-topic-killed-topics))
|
|
1385 (alist (cdr data))
|
|
1386 (item (cdar data)))
|
|
1387 (push alist gnus-topic-alist)
|
|
1388 (gnus-topic-create-topic
|
|
1389 (caar item) (gnus-topic-parent-topic previous) previous
|
|
1390 item)
|
|
1391 (gnus-topic-enter-dribble)
|
|
1392 (gnus-topic-goto-topic (caar item)))
|
|
1393 (let* ((prev (gnus-group-group-name))
|
|
1394 (gnus-topic-inhibit-change-level t)
|
|
1395 (gnus-group-indentation
|
|
1396 (make-string
|
|
1397 (* gnus-topic-indent-level
|
|
1398 (or (save-excursion
|
|
1399 (gnus-topic-goto-topic (gnus-current-topic))
|
|
1400 (gnus-group-topic-level))
|
|
1401 0))
|
|
1402 ? ))
|
|
1403 yanked alist)
|
|
1404 ;; We first yank the groups the normal way...
|
|
1405 (setq yanked (gnus-group-yank-group arg))
|
|
1406 ;; Then we enter the yanked groups into the topics they belong
|
|
1407 ;; to.
|
|
1408 (setq alist (assoc (save-excursion
|
|
1409 (forward-line -1)
|
|
1410 (gnus-current-topic))
|
|
1411 gnus-topic-alist))
|
|
1412 (when (stringp yanked)
|
|
1413 (setq yanked (list yanked)))
|
|
1414 (if (not prev)
|
|
1415 (nconc alist yanked)
|
|
1416 (if (not (cdr alist))
|
|
1417 (setcdr alist (nconc yanked (cdr alist)))
|
|
1418 (while (cdr alist)
|
|
1419 (when (equal (cadr alist) prev)
|
|
1420 (setcdr alist (nconc yanked (cdr alist)))
|
|
1421 (setq alist nil))
|
|
1422 (setq alist (cdr alist))))))
|
|
1423 (gnus-topic-update-topic)))
|
|
1424
|
31716
|
1425 (defun gnus-topic-hide-topic (&optional permanent)
|
|
1426 "Hide the current topic.
|
|
1427 If PERMANENT, make it stay hidden in subsequent sessions as well."
|
|
1428 (interactive "P")
|
17493
|
1429 (when (gnus-current-topic)
|
|
1430 (gnus-topic-goto-topic (gnus-current-topic))
|
31716
|
1431 (if permanent
|
49598
|
1432 (setcar (cddr
|
31716
|
1433 (cadr
|
|
1434 (gnus-topic-find-topology (gnus-current-topic))))
|
|
1435 'hidden))
|
|
1436 (gnus-topic-remove-topic nil nil)))
|
17493
|
1437
|
31716
|
1438 (defun gnus-topic-show-topic (&optional permanent)
|
|
1439 "Show the hidden topic.
|
|
1440 If PERMANENT, make it stay shown in subsequent sessions as well."
|
|
1441 (interactive "P")
|
17493
|
1442 (when (gnus-group-topic-p)
|
31716
|
1443 (if (not permanent)
|
|
1444 (gnus-topic-remove-topic t nil)
|
49598
|
1445 (let ((topic
|
|
1446 (gnus-topic-find-topology
|
31716
|
1447 (completing-read "Show topic: " gnus-topic-alist nil t))))
|
|
1448 (setcar (cddr (cadr topic)) nil)
|
|
1449 (setcar (cdr (cadr topic)) 'visible)
|
|
1450 (gnus-group-list-groups)))))
|
17493
|
1451
|
56927
|
1452 (defun gnus-topic-mark-topic (topic &optional unmark non-recursive)
|
31785
|
1453 "Mark all groups in the TOPIC with the process mark.
|
56927
|
1454 If NON-RECURSIVE (which is the prefix) is t, don't mark its subtopics."
|
31785
|
1455 (interactive (list (gnus-group-topic-name)
|
|
1456 nil
|
|
1457 (and current-prefix-arg t)))
|
17493
|
1458 (if (not topic)
|
|
1459 (call-interactively 'gnus-group-mark-group)
|
|
1460 (save-excursion
|
49598
|
1461 (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil
|
56927
|
1462 (not non-recursive))))
|
17493
|
1463 (while groups
|
|
1464 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
|
|
1465 (gnus-info-group (nth 2 (pop groups)))))))))
|
|
1466
|
56927
|
1467 (defun gnus-topic-unmark-topic (topic &optional dummy non-recursive)
|
31785
|
1468 "Remove the process mark from all groups in the TOPIC.
|
56927
|
1469 If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics."
|
31785
|
1470 (interactive (list (gnus-group-topic-name)
|
|
1471 nil
|
|
1472 (and current-prefix-arg t)))
|
17493
|
1473 (if (not topic)
|
|
1474 (call-interactively 'gnus-group-unmark-group)
|
56927
|
1475 (gnus-topic-mark-topic topic t non-recursive)))
|
17493
|
1476
|
|
1477 (defun gnus-topic-get-new-news-this-topic (&optional n)
|
|
1478 "Check for new news in the current topic."
|
|
1479 (interactive "P")
|
|
1480 (if (not (gnus-group-topic-p))
|
|
1481 (gnus-group-get-new-news-this-group n)
|
56927
|
1482 (let* ((topic (gnus-group-topic-name))
|
|
1483 (data (cadr (gnus-topic-find-topology topic))))
|
|
1484 (save-excursion
|
|
1485 (gnus-topic-mark-topic topic nil (and n t))
|
|
1486 (gnus-group-get-new-news-this-group))
|
|
1487 (gnus-topic-remove-topic (eq 'visible (cadr data))))))
|
17493
|
1488
|
|
1489 (defun gnus-topic-move-matching (regexp topic &optional copyp)
|
|
1490 "Move all groups that match REGEXP to some topic."
|
|
1491 (interactive
|
|
1492 (let (topic)
|
|
1493 (nreverse
|
|
1494 (list
|
|
1495 (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t))
|
|
1496 (read-string (format "Move to %s (regexp): " topic))))))
|
|
1497 (gnus-group-mark-regexp regexp)
|
|
1498 (gnus-topic-move-group nil topic copyp))
|
|
1499
|
|
1500 (defun gnus-topic-copy-matching (regexp topic &optional copyp)
|
|
1501 "Copy all groups that match REGEXP to some topic."
|
|
1502 (interactive
|
|
1503 (let (topic)
|
|
1504 (nreverse
|
|
1505 (list
|
|
1506 (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t))
|
|
1507 (read-string (format "Copy to %s (regexp): " topic))))))
|
|
1508 (gnus-topic-move-matching regexp topic t))
|
|
1509
|
|
1510 (defun gnus-topic-delete (topic)
|
|
1511 "Delete a topic."
|
|
1512 (interactive (list (gnus-group-topic-name)))
|
|
1513 (unless topic
|
|
1514 (error "No topic to be deleted"))
|
|
1515 (let ((entry (assoc topic gnus-topic-alist))
|
|
1516 (buffer-read-only nil))
|
|
1517 (when (cdr entry)
|
|
1518 (error "Topic not empty"))
|
|
1519 ;; Delete if visible.
|
|
1520 (when (gnus-topic-goto-topic topic)
|
|
1521 (gnus-delete-line))
|
|
1522 ;; Remove from alist.
|
|
1523 (setq gnus-topic-alist (delq entry gnus-topic-alist))
|
|
1524 ;; Remove from topology.
|
19969
|
1525 (gnus-topic-find-topology topic nil nil 'delete)
|
|
1526 (gnus-dribble-touch)))
|
17493
|
1527
|
|
1528 (defun gnus-topic-rename (old-name new-name)
|
|
1529 "Rename a topic."
|
|
1530 (interactive
|
|
1531 (let ((topic (gnus-current-topic)))
|
|
1532 (list topic
|
56927
|
1533 (read-string (format "Rename %s to: " topic) topic))))
|
24357
|
1534 ;; Check whether the new name exists.
|
|
1535 (when (gnus-topic-find-topology new-name)
|
|
1536 (error "Topic '%s' already exists" new-name))
|
|
1537 ;; "nil" is an invalid name, for reasons I'd rather not go
|
|
1538 ;; into here. Trust me.
|
|
1539 (when (equal new-name "nil")
|
|
1540 (error "Invalid name: %s" nil))
|
|
1541 ;; Do the renaming.
|
17493
|
1542 (let ((top (gnus-topic-find-topology old-name))
|
|
1543 (entry (assoc old-name gnus-topic-alist)))
|
|
1544 (when top
|
|
1545 (setcar (cadr top) new-name))
|
|
1546 (when entry
|
|
1547 (setcar entry new-name))
|
|
1548 (forward-line -1)
|
|
1549 (gnus-dribble-touch)
|
24357
|
1550 (gnus-group-list-groups)
|
|
1551 (forward-line 1)))
|
17493
|
1552
|
|
1553 (defun gnus-topic-indent (&optional unindent)
|
|
1554 "Indent a topic -- make it a sub-topic of the previous topic.
|
|
1555 If UNINDENT, remove an indentation."
|
|
1556 (interactive "P")
|
|
1557 (if unindent
|
|
1558 (gnus-topic-unindent)
|
|
1559 (let* ((topic (gnus-current-topic))
|
|
1560 (parent (gnus-topic-previous-topic topic))
|
|
1561 (buffer-read-only nil))
|
|
1562 (unless parent
|
|
1563 (error "Nothing to indent %s into" topic))
|
|
1564 (when topic
|
|
1565 (gnus-topic-goto-topic topic)
|
|
1566 (gnus-topic-kill-group)
|
|
1567 (push (cdar gnus-topic-killed-topics) gnus-topic-alist)
|
|
1568 (gnus-topic-create-topic
|
46192
be3ff3e3e5b0
* gnus-topic.el (gnus-topic-indent, gnus-topic-unindent): Change
ShengHuo ZHU <zsh@cs.rochester.edu>
diff
changeset
|
1569 topic parent nil (cdar (car gnus-topic-killed-topics)))
|
17493
|
1570 (pop gnus-topic-killed-topics)
|
|
1571 (or (gnus-topic-goto-topic topic)
|
|
1572 (gnus-topic-goto-topic parent))))))
|
|
1573
|
|
1574 (defun gnus-topic-unindent ()
|
|
1575 "Unindent a topic."
|
|
1576 (interactive)
|
|
1577 (let* ((topic (gnus-current-topic))
|
|
1578 (parent (gnus-topic-parent-topic topic))
|
|
1579 (grandparent (gnus-topic-parent-topic parent)))
|
|
1580 (unless grandparent
|
|
1581 (error "Nothing to indent %s into" topic))
|
|
1582 (when topic
|
|
1583 (gnus-topic-goto-topic topic)
|
|
1584 (gnus-topic-kill-group)
|
|
1585 (push (cdar gnus-topic-killed-topics) gnus-topic-alist)
|
|
1586 (gnus-topic-create-topic
|
|
1587 topic grandparent (gnus-topic-next-topic parent)
|
46192
be3ff3e3e5b0
* gnus-topic.el (gnus-topic-indent, gnus-topic-unindent): Change
ShengHuo ZHU <zsh@cs.rochester.edu>
diff
changeset
|
1588 (cdar (car gnus-topic-killed-topics)))
|
17493
|
1589 (pop gnus-topic-killed-topics)
|
|
1590 (gnus-topic-goto-topic topic))))
|
|
1591
|
|
1592 (defun gnus-topic-list-active (&optional force)
|
|
1593 "List all groups that Gnus knows about in a topicsified fashion.
|
|
1594 If FORCE, always re-read the active file."
|
|
1595 (interactive "P")
|
|
1596 (when force
|
|
1597 (gnus-get-killed-groups))
|
|
1598 (gnus-topic-grok-active force)
|
|
1599 (let ((gnus-topic-topology gnus-topic-active-topology)
|
|
1600 (gnus-topic-alist gnus-topic-active-alist)
|
|
1601 gnus-killed-list gnus-zombie-list)
|
24357
|
1602 (gnus-group-list-groups gnus-level-killed nil 1)))
|
17493
|
1603
|
19969
|
1604 (defun gnus-topic-toggle-display-empty-topics ()
|
|
1605 "Show/hide topics that have no unread articles."
|
|
1606 (interactive)
|
|
1607 (setq gnus-topic-display-empty-topics
|
|
1608 (not gnus-topic-display-empty-topics))
|
|
1609 (gnus-group-list-groups)
|
|
1610 (message "%s empty topics"
|
|
1611 (if gnus-topic-display-empty-topics
|
|
1612 "Showing" "Hiding")))
|
|
1613
|
17493
|
1614 ;;; Topic sorting functions
|
|
1615
|
|
1616 (defun gnus-topic-edit-parameters (group)
|
|
1617 "Edit the group parameters of GROUP.
|
|
1618 If performed on a topic, edit the topic parameters instead."
|
|
1619 (interactive (list (gnus-group-group-name)))
|
|
1620 (if group
|
|
1621 (gnus-group-edit-group-parameters group)
|
|
1622 (if (not (gnus-group-topic-p))
|
19969
|
1623 (error "Nothing to edit on the current line")
|
17493
|
1624 (let ((topic (gnus-group-topic-name)))
|
|
1625 (gnus-edit-form
|
|
1626 (gnus-topic-parameters topic)
|
|
1627 (format "Editing the topic parameters for `%s'."
|
|
1628 (or group topic))
|
|
1629 `(lambda (form)
|
|
1630 (gnus-topic-set-parameters ,topic form)))))))
|
|
1631
|
|
1632 (defun gnus-group-sort-topic (func reverse)
|
|
1633 "Sort groups in the topics according to FUNC and REVERSE."
|
|
1634 (let ((alist gnus-topic-alist))
|
|
1635 (while alist
|
|
1636 ;; !!!Sometimes nil elements sneak into the alist,
|
|
1637 ;; for some reason or other.
|
|
1638 (setcar alist (delq nil (car alist)))
|
|
1639 (setcar alist (delete "dummy.group" (car alist)))
|
|
1640 (gnus-topic-sort-topic (pop alist) func reverse))))
|
|
1641
|
|
1642 (defun gnus-topic-sort-topic (topic func reverse)
|
|
1643 ;; Each topic only lists the name of the group, while
|
|
1644 ;; the sort predicates expect group infos as inputs.
|
|
1645 ;; So we first transform the group names into infos,
|
|
1646 ;; then sort, and then transform back into group names.
|
|
1647 (setcdr
|
|
1648 topic
|
|
1649 (mapcar
|
|
1650 (lambda (info) (gnus-info-group info))
|
|
1651 (sort
|
|
1652 (mapcar
|
|
1653 (lambda (group) (gnus-get-info group))
|
|
1654 (cdr topic))
|
|
1655 func)))
|
|
1656 ;; Do the reversal, if necessary.
|
|
1657 (when reverse
|
|
1658 (setcdr topic (nreverse (cdr topic)))))
|
|
1659
|
|
1660 (defun gnus-topic-sort-groups (func &optional reverse)
|
|
1661 "Sort the current topic according to FUNC.
|
|
1662 If REVERSE, reverse the sorting order."
|
|
1663 (interactive (list gnus-group-sort-function current-prefix-arg))
|
|
1664 (let ((topic (assoc (gnus-current-topic) gnus-topic-alist)))
|
|
1665 (gnus-topic-sort-topic
|
|
1666 topic (gnus-make-sort-function func) reverse)
|
|
1667 (gnus-group-list-groups)))
|
|
1668
|
|
1669 (defun gnus-topic-sort-groups-by-alphabet (&optional reverse)
|
|
1670 "Sort the current topic alphabetically by group name.
|
|
1671 If REVERSE, sort in reverse order."
|
|
1672 (interactive "P")
|
|
1673 (gnus-topic-sort-groups 'gnus-group-sort-by-alphabet reverse))
|
|
1674
|
|
1675 (defun gnus-topic-sort-groups-by-unread (&optional reverse)
|
|
1676 "Sort the current topic by number of unread articles.
|
|
1677 If REVERSE, sort in reverse order."
|
|
1678 (interactive "P")
|
|
1679 (gnus-topic-sort-groups 'gnus-group-sort-by-unread reverse))
|
|
1680
|
|
1681 (defun gnus-topic-sort-groups-by-level (&optional reverse)
|
|
1682 "Sort the current topic by group level.
|
|
1683 If REVERSE, sort in reverse order."
|
|
1684 (interactive "P")
|
|
1685 (gnus-topic-sort-groups 'gnus-group-sort-by-level reverse))
|
|
1686
|
|
1687 (defun gnus-topic-sort-groups-by-score (&optional reverse)
|
|
1688 "Sort the current topic by group score.
|
|
1689 If REVERSE, sort in reverse order."
|
|
1690 (interactive "P")
|
|
1691 (gnus-topic-sort-groups 'gnus-group-sort-by-score reverse))
|
|
1692
|
|
1693 (defun gnus-topic-sort-groups-by-rank (&optional reverse)
|
|
1694 "Sort the current topic by group rank.
|
|
1695 If REVERSE, sort in reverse order."
|
|
1696 (interactive "P")
|
|
1697 (gnus-topic-sort-groups 'gnus-group-sort-by-rank reverse))
|
|
1698
|
|
1699 (defun gnus-topic-sort-groups-by-method (&optional reverse)
|
|
1700 "Sort the current topic alphabetically by backend name.
|
|
1701 If REVERSE, sort in reverse order."
|
|
1702 (interactive "P")
|
|
1703 (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
|
|
1704
|
56927
|
1705 (defun gnus-topic-sort-groups-by-server (&optional reverse)
|
|
1706 "Sort the current topic alphabetically by server name.
|
|
1707 If REVERSE, sort in reverse order."
|
|
1708 (interactive "P")
|
|
1709 (gnus-topic-sort-groups 'gnus-group-sort-by-server reverse))
|
|
1710
|
31716
|
1711 (defun gnus-topic-sort-topics-1 (top reverse)
|
|
1712 (if (cdr top)
|
|
1713 (let ((subtop
|
56927
|
1714 (mapcar (gnus-byte-compile
|
|
1715 `(lambda (top)
|
|
1716 (gnus-topic-sort-topics-1 top ,reverse)))
|
31716
|
1717 (sort (cdr top)
|
56927
|
1718 (lambda (t1 t2)
|
|
1719 (string-lessp (caar t1) (caar t2)))))))
|
31716
|
1720 (setcdr top (if reverse (reverse subtop) subtop))))
|
|
1721 top)
|
|
1722
|
|
1723 (defun gnus-topic-sort-topics (&optional topic reverse)
|
48588
|
1724 "Sort topics in TOPIC alphabetically by topic name.
|
31716
|
1725 If REVERSE, reverse the sorting order."
|
49598
|
1726 (interactive
|
|
1727 (list (completing-read "Sort topics in : " gnus-topic-alist nil t
|
31716
|
1728 (gnus-current-topic))
|
|
1729 current-prefix-arg))
|
|
1730 (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic)))
|
|
1731 gnus-topic-topology)))
|
|
1732 (gnus-topic-sort-topics-1 topic-topology reverse)
|
|
1733 (gnus-topic-enter-dribble)
|
|
1734 (gnus-group-list-groups)
|
|
1735 (gnus-topic-goto-topic topic)))
|
|
1736
|
|
1737 (defun gnus-topic-move (current to)
|
|
1738 "Move the CURRENT topic to TO."
|
49598
|
1739 (interactive
|
|
1740 (list
|
31716
|
1741 (gnus-group-topic-name)
|
|
1742 (completing-read "Move to topic: " gnus-topic-alist nil t)))
|
|
1743 (unless (and current to)
|
|
1744 (error "Can't find topic"))
|
|
1745 (let ((current-top (cdr (gnus-topic-find-topology current)))
|
|
1746 (to-top (cdr (gnus-topic-find-topology to))))
|
|
1747 (unless current-top
|
|
1748 (error "Can't find topic `%s'" current))
|
|
1749 (unless to-top
|
|
1750 (error "Can't find topic `%s'" to))
|
|
1751 (if (gnus-topic-find-topology to current-top 0);; Don't care the level
|
|
1752 (error "Can't move `%s' to its sub-level" current))
|
|
1753 (gnus-topic-find-topology current nil nil 'delete)
|
85712
|
1754 (setcdr (last to-top) (list current-top))
|
31716
|
1755 (gnus-topic-enter-dribble)
|
|
1756 (gnus-group-list-groups)
|
|
1757 (gnus-topic-goto-topic current)))
|
|
1758
|
|
1759 (defun gnus-subscribe-topics (newsgroup)
|
|
1760 (catch 'end
|
|
1761 (let (match gnus-group-change-level-function)
|
|
1762 (dolist (topic (gnus-topic-list))
|
|
1763 (when (and (setq match (cdr (assq 'subscribe
|
|
1764 (gnus-topic-parameters topic))))
|
|
1765 (string-match match newsgroup))
|
|
1766 ;; Just subscribe the group.
|
|
1767 (gnus-subscribe-alphabetically newsgroup)
|
|
1768 ;; Add the group to the topic.
|
|
1769 (nconc (assoc topic gnus-topic-alist) (list newsgroup))
|
56927
|
1770 ;; if this topic specifies a default level, use it
|
|
1771 (let ((subscribe-level (cdr (assq 'subscribe-level
|
|
1772 (gnus-topic-parameters topic)))))
|
|
1773 (when subscribe-level
|
|
1774 (gnus-group-change-level newsgroup subscribe-level
|
|
1775 gnus-level-default-subscribed)))
|
|
1776 (throw 'end t)))
|
|
1777 nil)))
|
49598
|
1778
|
17493
|
1779 (provide 'gnus-topic)
|
|
1780
|
93975
|
1781 ;; arch-tag: bf176856-f30c-40f0-ae77-e41529a1134c
|
17493
|
1782 ;;; gnus-topic.el ends here
|