Commit | Line | Data |
---|---|---|
526baa41 LMI |
1 | ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers |
2 | ;; Copyright (C) 1995,96 Free Software Foundation, Inc. | |
3 | ||
4 | ;; Author: Ilja Weis <kult@uni-paderborn.de> | |
5 | ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> | |
6 | ;; Keywords: news | |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
10 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 | ;; it under the terms of the GNU General Public License as published by | |
12 | ;; the Free Software Foundation; either version 2, or (at your option) | |
13 | ;; any later version. | |
14 | ||
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
22 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 | ;; Boston, MA 02111-1307, USA. | |
24 | ||
25 | ;;; Commentary: | |
26 | ||
27 | ;;; Code: | |
28 | ||
29 | (require 'gnus) | |
30 | (eval-when-compile (require 'cl)) | |
31 | ||
32 | (defvar gnus-topic-mode nil | |
33 | "Minor mode for Gnus group buffers.") | |
34 | ||
35 | (defvar gnus-topic-mode-hook nil | |
36 | "Hook run in topic mode buffers.") | |
37 | ||
38 | (defvar gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" | |
39 | "Format of topic lines. | |
40 | It works along the same lines as a normal formatting string, | |
41 | with some simple extensions. | |
42 | ||
43 | %i Indentation based on topic level. | |
44 | %n Topic name. | |
45 | %v Nothing if the topic is visible, \"...\" otherwise. | |
46 | %g Number of groups in the topic. | |
47 | %a Number of unread articles in the groups in the topic. | |
48 | %A Number of unread articles in the groups in the topic and its subtopics. | |
49 | ") | |
50 | ||
51 | (defvar gnus-topic-indent-level 2 | |
52 | "*How much each subtopic should be indented.") | |
53 | ||
54 | ;; Internal variables. | |
55 | ||
56 | (defvar gnus-topic-active-topology nil) | |
57 | (defvar gnus-topic-active-alist nil) | |
58 | ||
59 | (defvar gnus-topology-checked-p nil | |
60 | "Whether the topology has been checked in this session.") | |
61 | ||
62 | (defvar gnus-topic-killed-topics nil) | |
63 | (defvar gnus-topic-inhibit-change-level nil) | |
64 | (defvar gnus-topic-tallied-groups nil) | |
65 | ||
66 | (defconst gnus-topic-line-format-alist | |
67 | `((?n name ?s) | |
68 | (?v visible ?s) | |
69 | (?i indentation ?s) | |
70 | (?g number-of-groups ?d) | |
71 | (?a (gnus-topic-articles-in-topic entries) ?d) | |
72 | (?A total-number-of-articles ?d) | |
73 | (?l level ?d))) | |
74 | ||
75 | (defvar gnus-topic-line-format-spec nil) | |
76 | ||
77 | ;; Functions. | |
78 | ||
79 | (defun gnus-group-topic-name () | |
80 | "The name of the topic on the current line." | |
81 | (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic))) | |
82 | (and topic (symbol-name topic)))) | |
83 | ||
84 | (defun gnus-group-topic-level () | |
85 | "The level of the topic on the current line." | |
86 | (get-text-property (gnus-point-at-bol) 'gnus-topic-level)) | |
87 | ||
88 | (defun gnus-group-topic-unread () | |
89 | "The number of unread articles in topic on the current line." | |
90 | (get-text-property (gnus-point-at-bol) 'gnus-topic-unread)) | |
91 | ||
92 | (defun gnus-topic-unread (topic) | |
93 | "Return the number of unread articles in TOPIC." | |
94 | (or (save-excursion | |
95 | (and (gnus-topic-goto-topic topic) | |
96 | (gnus-group-topic-unread))) | |
97 | 0)) | |
98 | ||
99 | (defun gnus-topic-init-alist () | |
100 | "Initialize the topic structures." | |
101 | (setq gnus-topic-topology | |
102 | (cons (list "Gnus" 'visible) | |
103 | (mapcar (lambda (topic) | |
104 | (list (list (car topic) 'visible))) | |
105 | '(("misc"))))) | |
106 | (setq gnus-topic-alist | |
107 | (list (cons "misc" | |
108 | (mapcar (lambda (info) (gnus-info-group info)) | |
109 | (cdr gnus-newsrc-alist))) | |
110 | (list "Gnus"))) | |
111 | (gnus-topic-enter-dribble)) | |
112 | ||
113 | (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) | |
114 | "List all newsgroups with unread articles of level LEVEL or lower, and | |
115 | use the `gnus-group-topics' to sort the groups. | |
116 | If ALL is non-nil, list groups that have no unread articles. | |
117 | If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." | |
118 | (set-buffer gnus-group-buffer) | |
119 | (let ((buffer-read-only nil) | |
120 | (lowest (or lowest 1))) | |
121 | ||
122 | (setq gnus-topic-tallied-groups nil) | |
123 | ||
124 | (when (or (not gnus-topic-alist) | |
125 | (not gnus-topology-checked-p)) | |
126 | (gnus-topic-check-topology)) | |
127 | ||
128 | (unless list-topic | |
129 | (erase-buffer)) | |
130 | ||
131 | ;; List dead groups? | |
132 | (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)) | |
133 | (gnus-group-prepare-flat-list-dead | |
134 | (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) | |
135 | gnus-level-zombie ?Z | |
136 | regexp)) | |
137 | ||
138 | (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)) | |
139 | (gnus-group-prepare-flat-list-dead | |
140 | (setq gnus-killed-list (sort gnus-killed-list 'string<)) | |
141 | gnus-level-killed ?K | |
142 | regexp)) | |
143 | ||
144 | ;; Use topics. | |
145 | (when (< lowest gnus-level-zombie) | |
146 | (if list-topic | |
147 | (let ((top (gnus-topic-find-topology list-topic))) | |
148 | (gnus-topic-prepare-topic (cdr top) (car top) | |
149 | (or topic-level level) all)) | |
150 | (gnus-topic-prepare-topic gnus-topic-topology 0 | |
151 | (or topic-level level) all)))) | |
152 | ||
153 | (gnus-group-set-mode-line) | |
154 | (setq gnus-group-list-mode (cons level all)) | |
155 | (run-hooks 'gnus-group-prepare-hook)) | |
156 | ||
157 | (defun gnus-topic-prepare-topic (topicl level &optional list-level all silent) | |
158 | "Insert TOPIC into the group buffer. | |
159 | If SILENT, don't insert anything. Return the number of unread | |
160 | articles in the topic and its subtopics." | |
161 | (let* ((type (pop topicl)) | |
162 | (entries (gnus-topic-find-groups (car type) list-level all)) | |
163 | (visiblep (and (eq (nth 1 type) 'visible) (not silent))) | |
164 | (gnus-group-indentation | |
165 | (make-string (* gnus-topic-indent-level level) ? )) | |
166 | (beg (progn (beginning-of-line) (point))) | |
167 | (topicl (reverse topicl)) | |
168 | (all-entries entries) | |
169 | (unread 0) | |
170 | (topic (car type)) | |
171 | info entry end active) | |
172 | ;; Insert any sub-topics. | |
173 | (while topicl | |
174 | (incf unread | |
175 | (gnus-topic-prepare-topic | |
176 | (pop topicl) (1+ level) list-level all | |
177 | (not visiblep)))) | |
178 | (setq end (point)) | |
179 | (goto-char beg) | |
180 | ;; Insert all the groups that belong in this topic. | |
181 | (while (setq entry (pop entries)) | |
182 | (when visiblep | |
183 | (if (stringp entry) | |
184 | ;; Dead groups. | |
185 | (gnus-group-insert-group-line | |
186 | entry (if (member entry gnus-zombie-list) 8 9) | |
187 | nil (- (1+ (cdr (setq active (gnus-active entry)))) | |
188 | (car active)) nil) | |
189 | ;; Living groups. | |
190 | (when (setq info (nth 2 entry)) | |
191 | (gnus-group-insert-group-line | |
192 | (gnus-info-group info) | |
193 | (gnus-info-level info) (gnus-info-marks info) | |
194 | (car entry) (gnus-info-method info))))) | |
195 | (when (and (listp entry) | |
196 | (numberp (car entry)) | |
197 | (not (member (gnus-info-group (setq info (nth 2 entry))) | |
198 | gnus-topic-tallied-groups))) | |
199 | (push (gnus-info-group info) gnus-topic-tallied-groups) | |
200 | (incf unread (car entry)))) | |
201 | (goto-char beg) | |
202 | ;; Insert the topic line. | |
203 | (unless silent | |
204 | (gnus-extent-start-open (point)) | |
205 | (gnus-topic-insert-topic-line | |
206 | (car type) visiblep | |
207 | (not (eq (nth 2 type) 'hidden)) | |
208 | level all-entries unread)) | |
209 | (goto-char end) | |
210 | unread)) | |
211 | ||
212 | (defun gnus-topic-find-groups (topic &optional level all) | |
213 | "Return entries for all visible groups in TOPIC." | |
214 | (let ((groups (cdr (assoc topic gnus-topic-alist))) | |
215 | info clevel unread group lowest params visible-groups entry active) | |
216 | (setq lowest (or lowest 1)) | |
217 | (setq level (or level 7)) | |
218 | ;; We go through the newsrc to look for matches. | |
219 | (while groups | |
220 | (setq entry (gnus-gethash (setq group (pop groups)) gnus-newsrc-hashtb) | |
221 | info (nth 2 entry) | |
222 | params (gnus-info-params info) | |
223 | active (gnus-active group) | |
224 | unread (or (car entry) | |
225 | (and (not (equal group "dummy.group")) | |
226 | active | |
227 | (- (1+ (cdr active)) (car active)))) | |
228 | clevel (or (gnus-info-level info) | |
229 | (if (member group gnus-zombie-list) 8 9))) | |
230 | (and | |
231 | unread ; nil means that the group is dead. | |
232 | (<= clevel level) | |
233 | (>= clevel lowest) ; Is inside the level we want. | |
234 | (or all | |
235 | (if (eq unread t) | |
236 | gnus-group-list-inactive-groups | |
237 | (> unread 0)) | |
238 | (and gnus-list-groups-with-ticked-articles | |
239 | (cdr (assq 'tick (gnus-info-marks info)))) | |
240 | ; Has right readedness. | |
241 | ;; Check for permanent visibility. | |
242 | (and gnus-permanently-visible-groups | |
243 | (string-match gnus-permanently-visible-groups group)) | |
244 | (memq 'visible params) | |
245 | (cdr (assq 'visible params))) | |
246 | ;; Add this group to the list of visible groups. | |
247 | (push (or entry group) visible-groups))) | |
248 | (nreverse visible-groups))) | |
249 | ||
250 | (defun gnus-topic-remove-topic (&optional insert total-remove hide in-level) | |
251 | "Remove the current topic." | |
252 | (let ((topic (gnus-group-topic-name)) | |
253 | (level (gnus-group-topic-level)) | |
254 | (beg (progn (beginning-of-line) (point))) | |
255 | buffer-read-only) | |
256 | (when topic | |
257 | (while (and (zerop (forward-line 1)) | |
258 | (> (or (gnus-group-topic-level) (1+ level)) level))) | |
259 | (delete-region beg (point)) | |
260 | (setcar (cdadr (gnus-topic-find-topology topic)) | |
261 | (if insert 'visible 'invisible)) | |
262 | (when hide | |
263 | (setcdr (cdadr (gnus-topic-find-topology topic)) | |
264 | (list hide))) | |
265 | (unless total-remove | |
266 | (gnus-topic-insert-topic topic in-level))))) | |
267 | ||
268 | (defun gnus-topic-insert-topic (topic &optional level) | |
269 | "Insert TOPIC." | |
270 | (gnus-group-prepare-topics | |
271 | (car gnus-group-list-mode) (cdr gnus-group-list-mode) | |
272 | nil nil topic level)) | |
273 | ||
274 | (defun gnus-topic-fold (&optional insert) | |
275 | "Remove/insert the current topic." | |
276 | (let ((topic (gnus-group-topic-name))) | |
277 | (when topic | |
278 | (save-excursion | |
279 | (if (not (gnus-group-active-topic-p)) | |
280 | (gnus-topic-remove-topic | |
281 | (or insert (not (gnus-topic-visible-p)))) | |
282 | (let ((gnus-topic-topology gnus-topic-active-topology) | |
283 | (gnus-topic-alist gnus-topic-active-alist) | |
284 | (gnus-group-list-mode (cons 5 t))) | |
285 | (gnus-topic-remove-topic | |
286 | (or insert (not (gnus-topic-visible-p))) nil nil 9))))))) | |
287 | ||
288 | (defun gnus-group-topic-p () | |
289 | "Return non-nil if the current line is a topic." | |
290 | (gnus-group-topic-name)) | |
291 | ||
292 | (defun gnus-topic-visible-p () | |
293 | "Return non-nil if the current topic is visible." | |
294 | (get-text-property (gnus-point-at-bol) 'gnus-topic-visible)) | |
295 | ||
296 | (defun gnus-topic-insert-topic-line (name visiblep shownp level entries | |
297 | &optional unread) | |
298 | (let* ((visible (if visiblep "" "...")) | |
299 | (indentation (make-string (* gnus-topic-indent-level level) ? )) | |
300 | (total-number-of-articles unread) | |
301 | (number-of-groups (length entries)) | |
302 | (active-topic (eq gnus-topic-alist gnus-topic-active-alist))) | |
303 | (beginning-of-line) | |
304 | ;; Insert the text. | |
305 | (gnus-add-text-properties | |
306 | (point) | |
307 | (prog1 (1+ (point)) | |
308 | (eval gnus-topic-line-format-spec) | |
309 | (gnus-topic-remove-excess-properties)1) | |
310 | (list 'gnus-topic (intern name) | |
311 | 'gnus-topic-level level | |
312 | 'gnus-topic-unread unread | |
313 | 'gnus-active active-topic | |
314 | 'gnus-topic-visible visiblep)))) | |
315 | ||
316 | (defun gnus-topic-previous-topic (topic) | |
317 | "Return the previous topic on the same level as TOPIC." | |
318 | (let ((top (cddr (gnus-topic-find-topology | |
319 | (gnus-topic-parent-topic topic))))) | |
320 | (unless (equal topic (caaar top)) | |
321 | (while (and top (not (equal (caaadr top) topic))) | |
322 | (setq top (cdr top))) | |
323 | (caaar top)))) | |
324 | ||
325 | (defun gnus-topic-parent-topic (topic &optional topology) | |
326 | "Return the parent of TOPIC." | |
327 | (unless topology | |
328 | (setq topology gnus-topic-topology)) | |
329 | (let ((parent (car (pop topology))) | |
330 | result found) | |
331 | (while (and topology | |
332 | (not (setq found (equal (caaar topology) topic))) | |
333 | (not (setq result (gnus-topic-parent-topic topic | |
334 | (car topology))))) | |
335 | (setq topology (cdr topology))) | |
336 | (or result (and found parent)))) | |
337 | ||
338 | (defun gnus-topic-next-topic (topic &optional previous) | |
339 | "Return the next sibling of TOPIC." | |
340 | (let ((topology gnus-topic-topology) | |
341 | (parentt (cddr (gnus-topic-find-topology | |
342 | (gnus-topic-parent-topic topic)))) | |
343 | prev) | |
344 | (while (and parentt | |
345 | (not (equal (caaar parentt) topic))) | |
346 | (setq prev (caaar parentt) | |
347 | parentt (cdr parentt))) | |
348 | (if previous | |
349 | prev | |
350 | (caaadr parentt)))) | |
351 | ||
352 | (defun gnus-topic-find-topology (topic &optional topology level remove) | |
353 | "Return the topology of TOPIC." | |
354 | (unless topology | |
355 | (setq topology gnus-topic-topology) | |
356 | (setq level 0)) | |
357 | (let ((top topology) | |
358 | result) | |
359 | (if (equal (caar topology) topic) | |
360 | (progn | |
361 | (when remove | |
362 | (delq topology remove)) | |
363 | (cons level topology)) | |
364 | (setq topology (cdr topology)) | |
365 | (while (and topology | |
366 | (not (setq result (gnus-topic-find-topology | |
367 | topic (car topology) (1+ level) | |
368 | (and remove top))))) | |
369 | (setq topology (cdr topology))) | |
370 | result))) | |
371 | ||
372 | (gnus-add-shutdown 'gnus-topic-close 'gnus) | |
373 | ||
374 | (defun gnus-topic-close () | |
375 | (setq gnus-topic-active-topology nil | |
376 | gnus-topic-active-alist nil | |
377 | gnus-topic-killed-topics nil | |
378 | gnus-topic-tallied-groups nil | |
379 | gnus-topology-checked-p nil)) | |
380 | ||
381 | (defun gnus-topic-check-topology () | |
382 | ;; The first time we set the topology to whatever we have | |
383 | ;; gotten here, which can be rather random. | |
384 | (unless gnus-topic-alist | |
385 | (gnus-topic-init-alist)) | |
386 | ||
387 | (setq gnus-topology-checked-p t) | |
388 | (let ((topics (gnus-topic-list)) | |
389 | (alist gnus-topic-alist) | |
390 | changed) | |
391 | (while alist | |
392 | (unless (member (caar alist) topics) | |
393 | (nconc gnus-topic-topology | |
394 | (list (list (list (caar alist) 'visible)))) | |
395 | (setq changed t)) | |
396 | (setq alist (cdr alist))) | |
397 | (when changed | |
398 | (gnus-topic-enter-dribble))) | |
399 | (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry)) | |
400 | gnus-topic-alist))) | |
401 | (entry (assoc (caar gnus-topic-topology) gnus-topic-alist)) | |
402 | (newsrc gnus-newsrc-alist) | |
403 | group) | |
404 | (while newsrc | |
405 | (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) | |
406 | (setcdr entry (cons group (cdr entry))))))) | |
407 | ||
408 | (defvar gnus-tmp-topics nil) | |
409 | (defun gnus-topic-list (&optional topology) | |
410 | (unless topology | |
411 | (setq topology gnus-topic-topology | |
412 | gnus-tmp-topics nil)) | |
413 | (push (caar topology) gnus-tmp-topics) | |
414 | (mapcar 'gnus-topic-list (cdr topology)) | |
415 | gnus-tmp-topics) | |
416 | ||
417 | (defun gnus-topic-enter-dribble () | |
418 | (gnus-dribble-enter | |
419 | (format "(setq gnus-topic-topology '%S)" gnus-topic-topology))) | |
420 | ||
421 | (defun gnus-topic-articles-in-topic (entries) | |
422 | (let ((total 0) | |
423 | number) | |
424 | (while entries | |
425 | (when (numberp (setq number (car (pop entries)))) | |
426 | (incf total number))) | |
427 | total)) | |
428 | ||
429 | (defun gnus-group-topic (group) | |
430 | "Return the topic GROUP is a member of." | |
431 | (let ((alist gnus-topic-alist) | |
432 | out) | |
433 | (while alist | |
434 | (when (member group (cdar alist)) | |
435 | (setq out (caar alist) | |
436 | alist nil)) | |
437 | (setq alist (cdr alist))) | |
438 | out)) | |
439 | ||
440 | (defun gnus-topic-goto-topic (topic) | |
441 | "Go to TOPIC." | |
442 | (when topic | |
443 | (gnus-goto-char (text-property-any (point-min) (point-max) | |
444 | 'gnus-topic (intern topic))))) | |
445 | ||
446 | (defun gnus-group-parent-topic () | |
447 | "Return the name of the current topic." | |
448 | (let ((result | |
449 | (or (get-text-property (point) 'gnus-topic) | |
450 | (save-excursion | |
451 | (and (gnus-goto-char (previous-single-property-change | |
452 | (point) 'gnus-topic)) | |
453 | (get-text-property (max (1- (point)) (point-min)) | |
454 | 'gnus-topic)))))) | |
455 | (when result | |
456 | (symbol-name result)))) | |
457 | ||
458 | (defun gnus-topic-update-topic () | |
459 | "Update all parent topics to the current group." | |
460 | (when (and (eq major-mode 'gnus-group-mode) | |
461 | gnus-topic-mode) | |
462 | (let ((group (gnus-group-group-name)) | |
463 | (buffer-read-only nil)) | |
464 | (when (and group (gnus-get-info group) | |
465 | (gnus-topic-goto-topic (gnus-group-parent-topic))) | |
466 | (gnus-topic-update-topic-line (gnus-group-topic-name)) | |
467 | (gnus-group-goto-group group) | |
468 | (gnus-group-position-point))))) | |
469 | ||
470 | (defun gnus-topic-goto-missing-group (group) | |
471 | "Place point where GROUP is supposed to be inserted." | |
472 | (let* ((topic (gnus-group-topic group)) | |
473 | (groups (cdr (assoc topic gnus-topic-alist))) | |
474 | (g (cdr (member group groups))) | |
475 | (unfound t)) | |
476 | (while (and g unfound) | |
477 | (when (gnus-group-goto-group (pop g)) | |
478 | (beginning-of-line) | |
479 | (setq unfound nil))) | |
480 | (when unfound | |
481 | (setq g (cdr (member group (reverse groups)))) | |
482 | (while (and g unfound) | |
483 | (when (gnus-group-goto-group (pop g)) | |
484 | (forward-line 1) | |
485 | (setq unfound nil))) | |
486 | (when unfound | |
487 | (gnus-topic-goto-topic topic) | |
488 | (forward-line 1))))) | |
489 | ||
490 | (defun gnus-topic-update-topic-line (topic-name &optional reads) | |
491 | (let* ((top (gnus-topic-find-topology topic-name)) | |
492 | (type (cadr top)) | |
493 | (children (cddr top)) | |
494 | (entries (gnus-topic-find-groups | |
495 | (car type) (car gnus-group-list-mode) | |
496 | (cdr gnus-group-list-mode))) | |
497 | (parent (gnus-topic-parent-topic topic-name)) | |
498 | (all-entries entries) | |
499 | (unread 0) | |
500 | old-unread entry) | |
501 | (when (gnus-topic-goto-topic (car type)) | |
502 | ;; Tally all the groups that belong in this topic. | |
503 | (if reads | |
504 | (setq unread (- (gnus-group-topic-unread) reads)) | |
505 | (while children | |
506 | (incf unread (gnus-topic-unread (caar (pop children))))) | |
507 | (while (setq entry (pop entries)) | |
508 | (when (numberp (car entry)) | |
509 | (incf unread (car entry))))) | |
510 | (setq old-unread (gnus-group-topic-unread)) | |
511 | ;; Insert the topic line. | |
512 | (gnus-topic-insert-topic-line | |
513 | (car type) (gnus-topic-visible-p) | |
514 | (not (eq (nth 2 type) 'hidden)) | |
515 | (gnus-group-topic-level) all-entries unread) | |
516 | (gnus-delete-line)) | |
517 | (when parent | |
518 | (forward-line -1) | |
519 | (gnus-topic-update-topic-line | |
520 | parent (- old-unread (gnus-group-topic-unread)))) | |
521 | unread)) | |
522 | ||
523 | (defun gnus-topic-grok-active (&optional force) | |
524 | "Parse all active groups and create topic structures for them." | |
525 | ;; First we make sure that we have really read the active file. | |
526 | (when (or force | |
527 | (not gnus-topic-active-alist)) | |
528 | (let (groups) | |
529 | ;; Get a list of all groups available. | |
530 | (mapatoms (lambda (g) (when (symbol-value g) | |
531 | (push (symbol-name g) groups))) | |
532 | gnus-active-hashtb) | |
533 | (setq groups (sort groups 'string<)) | |
534 | ;; Init the variables. | |
535 | (setq gnus-topic-active-topology (list (list "" 'visible))) | |
536 | (setq gnus-topic-active-alist nil) | |
537 | ;; Descend the top-level hierarchy. | |
538 | (gnus-topic-grok-active-1 gnus-topic-active-topology groups) | |
539 | ;; Set the top-level topic names to something nice. | |
540 | (setcar (car gnus-topic-active-topology) "Gnus active") | |
541 | (setcar (car gnus-topic-active-alist) "Gnus active")))) | |
542 | ||
543 | (defun gnus-topic-grok-active-1 (topology groups) | |
544 | (let* ((name (caar topology)) | |
545 | (prefix (concat "^" (regexp-quote name))) | |
546 | tgroups ntopology group) | |
547 | (while (and groups | |
548 | (string-match prefix (setq group (car groups)))) | |
549 | (if (not (string-match "\\." group (match-end 0))) | |
550 | ;; There are no further hierarchies here, so we just | |
551 | ;; enter this group into the list belonging to this | |
552 | ;; topic. | |
553 | (push (pop groups) tgroups) | |
554 | ;; New sub-hierarchy, so we add it to the topology. | |
555 | (nconc topology (list (setq ntopology | |
556 | (list (list (substring | |
557 | group 0 (match-end 0)) | |
558 | 'invisible))))) | |
559 | ;; Descend the hierarchy. | |
560 | (setq groups (gnus-topic-grok-active-1 ntopology groups)))) | |
561 | ;; We remove the trailing "." from the topic name. | |
562 | (setq name | |
563 | (if (string-match "\\.$" name) | |
564 | (substring name 0 (match-beginning 0)) | |
565 | name)) | |
566 | ;; Add this topic and its groups to the topic alist. | |
567 | (push (cons name (nreverse tgroups)) gnus-topic-active-alist) | |
568 | (setcar (car topology) name) | |
569 | ;; We return the rest of the groups that didn't belong | |
570 | ;; to this topic. | |
571 | groups)) | |
572 | ||
573 | (defun gnus-group-active-topic-p () | |
574 | "Return whether the current active comes from the active topics." | |
575 | (save-excursion | |
576 | (beginning-of-line) | |
577 | (get-text-property (point) 'gnus-active))) | |
578 | ||
579 | ;;; Topic mode, commands and keymap. | |
580 | ||
581 | (defvar gnus-topic-mode-map nil) | |
582 | (defvar gnus-group-topic-map nil) | |
583 | ||
584 | (unless gnus-topic-mode-map | |
585 | (setq gnus-topic-mode-map (make-sparse-keymap)) | |
586 | ||
587 | ;; Override certain group mode keys. | |
588 | (gnus-define-keys | |
589 | gnus-topic-mode-map | |
590 | "=" gnus-topic-select-group | |
591 | "\r" gnus-topic-select-group | |
592 | " " gnus-topic-read-group | |
593 | "\C-k" gnus-topic-kill-group | |
594 | "\C-y" gnus-topic-yank-group | |
595 | "\M-g" gnus-topic-get-new-news-this-topic | |
596 | "AT" gnus-topic-list-active | |
597 | gnus-mouse-2 gnus-mouse-pick-topic) | |
598 | ||
599 | ;; Define a new submap. | |
600 | (gnus-define-keys | |
601 | (gnus-group-topic-map "T" gnus-group-mode-map) | |
602 | "#" gnus-topic-mark-topic | |
603 | "\M-#" gnus-topic-unmark-topic | |
604 | "n" gnus-topic-create-topic | |
605 | "m" gnus-topic-move-group | |
606 | "D" gnus-topic-remove-group | |
607 | "c" gnus-topic-copy-group | |
608 | "h" gnus-topic-hide-topic | |
609 | "s" gnus-topic-show-topic | |
610 | "M" gnus-topic-move-matching | |
611 | "C" gnus-topic-copy-matching | |
612 | "\C-i" gnus-topic-indent | |
613 | [tab] gnus-topic-indent | |
614 | "r" gnus-topic-rename | |
615 | "\177" gnus-topic-delete)) | |
616 | ||
617 | (defun gnus-topic-make-menu-bar () | |
618 | (unless (boundp 'gnus-topic-menu) | |
619 | (easy-menu-define | |
620 | gnus-topic-menu gnus-topic-mode-map "" | |
621 | '("Topics" | |
622 | ["Toggle topics" gnus-topic-mode t] | |
623 | ("Groups" | |
624 | ["Copy" gnus-topic-copy-group t] | |
625 | ["Move" gnus-topic-move-group t] | |
626 | ["Remove" gnus-topic-remove-group t] | |
627 | ["Copy matching" gnus-topic-copy-matching t] | |
628 | ["Move matching" gnus-topic-move-matching t]) | |
629 | ("Topics" | |
630 | ["Show" gnus-topic-show-topic t] | |
631 | ["Hide" gnus-topic-hide-topic t] | |
632 | ["Delete" gnus-topic-delete t] | |
633 | ["Rename" gnus-topic-rename t] | |
634 | ["Create" gnus-topic-create-topic t] | |
635 | ["Mark" gnus-topic-mark-topic t] | |
636 | ["Indent" gnus-topic-indent t]) | |
637 | ["List active" gnus-topic-list-active t])))) | |
638 | ||
639 | (defun gnus-topic-mode (&optional arg redisplay) | |
640 | "Minor mode for topicsifying Gnus group buffers." | |
641 | (interactive (list current-prefix-arg t)) | |
642 | (when (eq major-mode 'gnus-group-mode) | |
643 | (make-local-variable 'gnus-topic-mode) | |
644 | (setq gnus-topic-mode | |
645 | (if (null arg) (not gnus-topic-mode) | |
646 | (> (prefix-numeric-value arg) 0))) | |
647 | ;; Infest Gnus with topics. | |
648 | (when gnus-topic-mode | |
649 | (when (and menu-bar-mode | |
650 | (gnus-visual-p 'topic-menu 'menu)) | |
651 | (gnus-topic-make-menu-bar)) | |
652 | (setq gnus-topic-line-format-spec | |
653 | (gnus-parse-format gnus-topic-line-format | |
654 | gnus-topic-line-format-alist t)) | |
655 | (unless (assq 'gnus-topic-mode minor-mode-alist) | |
656 | (push '(gnus-topic-mode " Topic") minor-mode-alist)) | |
657 | (unless (assq 'gnus-topic-mode minor-mode-map-alist) | |
658 | (push (cons 'gnus-topic-mode gnus-topic-mode-map) | |
659 | minor-mode-map-alist)) | |
660 | (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) | |
661 | (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) | |
662 | (add-hook 'gnus-group-update-group-hook 'gnus-topic-update-topic) | |
663 | (make-local-variable 'gnus-group-prepare-function) | |
664 | (setq gnus-group-prepare-function 'gnus-group-prepare-topics) | |
665 | (make-local-variable 'gnus-group-goto-next-group-function) | |
666 | (setq gnus-group-goto-next-group-function | |
667 | 'gnus-topic-goto-next-group) | |
668 | (setq gnus-group-change-level-function 'gnus-topic-change-level) | |
669 | (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) | |
670 | (make-local-variable 'gnus-group-indentation-function) | |
671 | (setq gnus-group-indentation-function | |
672 | 'gnus-topic-group-indentation) | |
673 | (setq gnus-topology-checked-p nil) | |
674 | ;; We check the topology. | |
675 | (when gnus-newsrc-alist | |
676 | (gnus-topic-check-topology)) | |
677 | (run-hooks 'gnus-topic-mode-hook)) | |
678 | ;; Remove topic infestation. | |
679 | (unless gnus-topic-mode | |
680 | (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) | |
681 | (remove-hook 'gnus-group-change-level-function | |
682 | 'gnus-topic-change-level) | |
683 | (setq gnus-group-prepare-function 'gnus-group-prepare-flat)) | |
684 | (when redisplay | |
685 | (gnus-group-list-groups)))) | |
686 | ||
687 | (defun gnus-topic-select-group (&optional all) | |
688 | "Select this newsgroup. | |
689 | No article is selected automatically. | |
690 | If ALL is non-nil, already read articles become readable. | |
691 | If ALL is a number, fetch this number of articles." | |
692 | (interactive "P") | |
693 | (if (gnus-group-topic-p) | |
694 | (let ((gnus-group-list-mode | |
695 | (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) | |
696 | (gnus-topic-fold all)) | |
697 | (gnus-group-select-group all))) | |
698 | ||
699 | (defun gnus-mouse-pick-topic (e) | |
700 | "Select the group or topic under the mouse pointer." | |
701 | (interactive "e") | |
702 | (mouse-set-point e) | |
703 | (gnus-topic-read-group nil)) | |
704 | ||
705 | (defun gnus-topic-read-group (&optional all no-article group) | |
706 | "Read news in this newsgroup. | |
707 | If the prefix argument ALL is non-nil, already read articles become | |
708 | readable. IF ALL is a number, fetch this number of articles. If the | |
709 | optional argument NO-ARTICLE is non-nil, no article will be | |
710 | auto-selected upon group entry. If GROUP is non-nil, fetch that | |
711 | group." | |
712 | (interactive "P") | |
713 | (if (gnus-group-topic-p) | |
714 | (let ((gnus-group-list-mode | |
715 | (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) | |
716 | (gnus-topic-fold all)) | |
717 | (gnus-group-read-group all no-article group))) | |
718 | ||
719 | (defun gnus-topic-create-topic (topic parent &optional previous full-topic) | |
720 | (interactive | |
721 | (list | |
722 | (read-string "New topic: ") | |
723 | (gnus-group-parent-topic))) | |
724 | ;; Check whether this topic already exists. | |
725 | (when (gnus-topic-find-topology topic) | |
726 | (error "Topic aleady exists")) | |
727 | (unless parent | |
728 | (setq parent (caar gnus-topic-topology))) | |
729 | (let ((top (cdr (gnus-topic-find-topology parent))) | |
730 | (full-topic (or full-topic `((,topic visible))))) | |
731 | (unless top | |
732 | (error "No such parent topic: %s" parent)) | |
733 | (if previous | |
734 | (progn | |
735 | (while (and (cdr top) | |
736 | (not (equal (caaadr top) previous))) | |
737 | (setq top (cdr top))) | |
738 | (setcdr top (cons full-topic (cdr top)))) | |
739 | (nconc top (list full-topic))) | |
740 | (unless (assoc topic gnus-topic-alist) | |
741 | (push (list topic) gnus-topic-alist))) | |
742 | (gnus-topic-enter-dribble) | |
743 | (gnus-group-list-groups) | |
744 | (gnus-topic-goto-topic topic)) | |
745 | ||
746 | (defun gnus-topic-move-group (n topic &optional copyp) | |
747 | "Move the next N groups to TOPIC. | |
748 | If COPYP, copy the groups instead." | |
749 | (interactive | |
750 | (list current-prefix-arg | |
751 | (completing-read "Move to topic: " gnus-topic-alist nil t))) | |
752 | (let ((groups (gnus-group-process-prefix n)) | |
753 | (topicl (assoc topic gnus-topic-alist)) | |
754 | entry) | |
755 | (mapcar (lambda (g) | |
756 | (gnus-group-remove-mark g) | |
757 | (when (and | |
758 | (setq entry (assoc (gnus-group-parent-topic) | |
759 | gnus-topic-alist)) | |
760 | (not copyp)) | |
761 | (setcdr entry (gnus-delete-first g (cdr entry)))) | |
762 | (nconc topicl (list g))) | |
763 | groups) | |
764 | (gnus-group-position-point)) | |
765 | (gnus-topic-enter-dribble) | |
766 | (gnus-group-list-groups)) | |
767 | ||
768 | (defun gnus-topic-remove-group () | |
769 | "Remove the current group from the topic." | |
770 | (interactive) | |
771 | (let ((topicl (assoc (gnus-group-parent-topic) gnus-topic-alist)) | |
772 | (group (gnus-group-group-name)) | |
773 | (buffer-read-only nil)) | |
774 | (when (and topicl group) | |
775 | (gnus-delete-line) | |
776 | (gnus-delete-first group topicl)) | |
777 | (gnus-group-position-point))) | |
778 | ||
779 | (defun gnus-topic-copy-group (n topic) | |
780 | "Copy the current group to a topic." | |
781 | (interactive | |
782 | (list current-prefix-arg | |
783 | (completing-read "Copy to topic: " gnus-topic-alist nil t))) | |
784 | (gnus-topic-move-group n topic t)) | |
785 | ||
786 | (defun gnus-topic-group-indentation () | |
787 | (make-string | |
788 | (* gnus-topic-indent-level | |
789 | (or (save-excursion | |
790 | (gnus-topic-goto-topic (gnus-group-parent-topic)) | |
791 | (gnus-group-topic-level)) 0)) ? )) | |
792 | ||
793 | (defun gnus-topic-change-level (group level oldlevel) | |
794 | "Run when changing levels to enter/remove groups from topics." | |
795 | (save-excursion | |
796 | (set-buffer gnus-group-buffer) | |
797 | (when (and gnus-topic-mode | |
798 | gnus-topic-alist | |
799 | (not gnus-topic-inhibit-change-level)) | |
800 | ;; Remove the group from the topics. | |
801 | (when (and (< oldlevel gnus-level-zombie) | |
802 | (>= level gnus-level-zombie)) | |
803 | (let (alist) | |
804 | (forward-line -1) | |
805 | (when (setq alist (assoc (gnus-group-parent-topic) gnus-topic-alist)) | |
806 | (setcdr alist (gnus-delete-first group (cdr alist)))))) | |
807 | ;; If the group is subscribed. then we enter it into the topics. | |
808 | (when (and (< level gnus-level-zombie) | |
809 | (>= oldlevel gnus-level-zombie)) | |
810 | (let* ((prev (gnus-group-group-name)) | |
811 | (gnus-topic-inhibit-change-level t) | |
812 | (gnus-group-indentation | |
813 | (make-string | |
814 | (* gnus-topic-indent-level | |
815 | (or (save-excursion | |
816 | (gnus-topic-goto-topic (gnus-group-parent-topic)) | |
817 | (gnus-group-topic-level)) 0)) ? )) | |
818 | (yanked (list group)) | |
819 | alist talist end) | |
820 | ;; Then we enter the yanked groups into the topics they belong | |
821 | ;; to. | |
822 | (when (setq alist (assoc (save-excursion | |
823 | (forward-line -1) | |
824 | (or | |
825 | (gnus-group-parent-topic) | |
826 | (caar gnus-topic-topology))) | |
827 | gnus-topic-alist)) | |
828 | (setq talist alist) | |
829 | (when (stringp yanked) | |
830 | (setq yanked (list yanked))) | |
831 | (if (not prev) | |
832 | (nconc alist yanked) | |
833 | (if (not (cdr alist)) | |
834 | (setcdr alist (nconc yanked (cdr alist))) | |
835 | (while (and (not end) (cdr alist)) | |
836 | (when (equal (cadr alist) prev) | |
837 | (setcdr alist (nconc yanked (cdr alist))) | |
838 | (setq end t)) | |
839 | (setq alist (cdr alist))) | |
840 | (unless end | |
841 | (nconc talist yanked)))))) | |
842 | (gnus-topic-update-topic))))) | |
843 | ||
844 | (defun gnus-topic-goto-next-group (group props) | |
845 | "Go to group or the next group after group." | |
846 | (if (null group) | |
847 | (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props)))) | |
848 | (if (gnus-group-goto-group group) | |
849 | t | |
850 | ;; The group is no longer visible. | |
851 | (let* ((list (assoc (gnus-group-parent-topic) gnus-topic-alist)) | |
852 | (after (cdr (member group (cdr list))))) | |
853 | ;; First try to put point on a group after the current one. | |
854 | (while (and after | |
855 | (not (gnus-group-goto-group (car after)))) | |
856 | (setq after (cdr after))) | |
857 | ;; Then try to put point on a group before point. | |
858 | (unless after | |
859 | (setq after (cdr (member group (reverse (cdr list))))) | |
860 | (while (and after | |
861 | (not (gnus-group-goto-group (car after)))) | |
862 | (setq after (cdr after)))) | |
863 | ;; Finally, just put point on the topic. | |
864 | (unless after | |
865 | (gnus-topic-goto-topic (car list)) | |
866 | (setq after nil)) | |
867 | t)))) | |
868 | ||
869 | (defun gnus-topic-kill-group (&optional n discard) | |
870 | "Kill the next N groups." | |
871 | (interactive "P") | |
872 | (if (gnus-group-topic-p) | |
873 | (let ((topic (gnus-group-topic-name))) | |
874 | (gnus-topic-remove-topic nil t) | |
875 | (push (gnus-topic-find-topology topic nil nil gnus-topic-topology) | |
876 | gnus-topic-killed-topics)) | |
877 | (gnus-group-kill-group n discard) | |
878 | (gnus-topic-update-topic))) | |
879 | ||
880 | (defun gnus-topic-yank-group (&optional arg) | |
881 | "Yank the last topic." | |
882 | (interactive "p") | |
883 | (if gnus-topic-killed-topics | |
884 | (let ((previous | |
885 | (or (gnus-group-topic-name) | |
886 | (gnus-topic-next-topic (gnus-group-parent-topic)))) | |
887 | (item (cdr (pop gnus-topic-killed-topics)))) | |
888 | (gnus-topic-create-topic | |
889 | (caar item) (gnus-topic-parent-topic previous) previous | |
890 | item) | |
891 | (gnus-topic-goto-topic (caar item))) | |
892 | (let* ((prev (gnus-group-group-name)) | |
893 | (gnus-topic-inhibit-change-level t) | |
894 | (gnus-group-indentation | |
895 | (make-string | |
896 | (* gnus-topic-indent-level | |
897 | (or (save-excursion | |
898 | (gnus-topic-goto-topic (gnus-group-parent-topic)) | |
899 | (gnus-group-topic-level)) 0)) ? )) | |
900 | yanked alist) | |
901 | ;; We first yank the groups the normal way... | |
902 | (setq yanked (gnus-group-yank-group arg)) | |
903 | ;; Then we enter the yanked groups into the topics they belong | |
904 | ;; to. | |
905 | (setq alist (assoc (save-excursion | |
906 | (forward-line -1) | |
907 | (gnus-group-parent-topic)) | |
908 | gnus-topic-alist)) | |
909 | (when (stringp yanked) | |
910 | (setq yanked (list yanked))) | |
911 | (if (not prev) | |
912 | (nconc alist yanked) | |
913 | (if (not (cdr alist)) | |
914 | (setcdr alist (nconc yanked (cdr alist))) | |
915 | (while (cdr alist) | |
916 | (when (equal (cadr alist) prev) | |
917 | (setcdr alist (nconc yanked (cdr alist))) | |
918 | (setq alist nil)) | |
919 | (setq alist (cdr alist)))))) | |
920 | (gnus-topic-update-topic))) | |
921 | ||
922 | (defun gnus-topic-hide-topic () | |
923 | "Hide all subtopics under the current topic." | |
924 | (interactive) | |
925 | (when (gnus-group-parent-topic) | |
926 | (gnus-topic-goto-topic (gnus-group-parent-topic)) | |
927 | (gnus-topic-remove-topic nil nil 'hidden))) | |
928 | ||
929 | (defun gnus-topic-show-topic () | |
930 | "Show the hidden topic." | |
931 | (interactive) | |
932 | (when (gnus-group-topic-p) | |
933 | (gnus-topic-remove-topic t nil 'shown))) | |
934 | ||
935 | (defun gnus-topic-mark-topic (topic &optional unmark) | |
936 | "Mark all groups in the topic with the process mark." | |
937 | (interactive (list (gnus-group-parent-topic))) | |
938 | (save-excursion | |
939 | (let ((groups (gnus-topic-find-groups topic 9 t))) | |
940 | (while groups | |
941 | (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) | |
942 | (gnus-info-group (nth 2 (pop groups)))))))) | |
943 | ||
944 | (defun gnus-topic-unmark-topic (topic &optional unmark) | |
945 | "Remove the process mark from all groups in the topic." | |
946 | (interactive (list (gnus-group-parent-topic))) | |
947 | (gnus-topic-mark-topic topic t)) | |
948 | ||
949 | (defun gnus-topic-get-new-news-this-topic (&optional n) | |
950 | "Check for new news in the current topic." | |
951 | (interactive "P") | |
952 | (if (not (gnus-group-topic-p)) | |
953 | (gnus-group-get-new-news-this-group n) | |
954 | (gnus-topic-mark-topic (gnus-group-topic-name)) | |
955 | (gnus-group-get-new-news-this-group))) | |
956 | ||
957 | (defun gnus-topic-move-matching (regexp topic &optional copyp) | |
958 | "Move all groups that match REGEXP to some topic." | |
959 | (interactive | |
960 | (let (topic) | |
961 | (nreverse | |
962 | (list | |
963 | (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t)) | |
964 | (read-string (format "Move to %s (regexp): " topic)))))) | |
965 | (gnus-group-mark-regexp regexp) | |
966 | (gnus-topic-move-group nil topic copyp)) | |
967 | ||
968 | (defun gnus-topic-copy-matching (regexp topic &optional copyp) | |
969 | "Copy all groups that match REGEXP to some topic." | |
970 | (interactive | |
971 | (let (topic) | |
972 | (nreverse | |
973 | (list | |
974 | (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t)) | |
975 | (read-string (format "Copy to %s (regexp): " topic)))))) | |
976 | (gnus-topic-move-matching regexp topic t)) | |
977 | ||
978 | (defun gnus-topic-delete (topic) | |
979 | "Delete a topic." | |
980 | (interactive (list (gnus-group-topic-name))) | |
981 | (unless topic | |
982 | (error "No topic to be deleted")) | |
983 | (let ((entry (assoc topic gnus-topic-alist)) | |
984 | (buffer-read-only nil)) | |
985 | (when (cdr entry) | |
986 | (error "Topic not empty")) | |
987 | ;; Delete if visible. | |
988 | (when (gnus-topic-goto-topic topic) | |
989 | (gnus-delete-line)) | |
990 | ;; Remove from alist. | |
991 | (setq gnus-topic-alist (delq entry gnus-topic-alist)) | |
992 | ;; Remove from topology. | |
993 | (gnus-topic-find-topology topic nil nil 'delete))) | |
994 | ||
995 | (defun gnus-topic-rename (old-name new-name) | |
996 | "Rename a topic." | |
997 | (interactive | |
998 | (let ((topic (gnus-group-parent-topic))) | |
999 | (list topic | |
1000 | (read-string (format "Rename %s to: " topic))))) | |
1001 | (let ((top (gnus-topic-find-topology old-name)) | |
1002 | (entry (assoc old-name gnus-topic-alist))) | |
1003 | (when top | |
1004 | (setcar (cadr top) new-name)) | |
1005 | (when entry | |
1006 | (setcar entry new-name)) | |
1007 | (gnus-group-list-groups))) | |
1008 | ||
1009 | (defun gnus-topic-indent (&optional unindent) | |
1010 | "Indent a topic -- make it a sub-topic of the previous topic. | |
1011 | If UNINDENT, remove an indentation." | |
1012 | (interactive "P") | |
1013 | (if unindent | |
1014 | (gnus-topic-unindent) | |
1015 | (let* ((topic (gnus-group-parent-topic)) | |
1016 | (parent (gnus-topic-previous-topic topic))) | |
1017 | (unless parent | |
1018 | (error "Nothing to indent %s into" topic)) | |
1019 | (when topic | |
1020 | (gnus-topic-goto-topic topic) | |
1021 | (gnus-topic-kill-group) | |
1022 | (gnus-topic-create-topic | |
1023 | topic parent nil (cdr (pop gnus-topic-killed-topics))) | |
1024 | (or (gnus-topic-goto-topic topic) | |
1025 | (gnus-topic-goto-topic parent)))))) | |
1026 | ||
1027 | (defun gnus-topic-unindent () | |
1028 | "Unindent a topic." | |
1029 | (interactive) | |
1030 | (let* ((topic (gnus-group-parent-topic)) | |
1031 | (parent (gnus-topic-parent-topic topic)) | |
1032 | (grandparent (gnus-topic-parent-topic parent))) | |
1033 | (unless grandparent | |
1034 | (error "Nothing to indent %s into" topic)) | |
1035 | (when topic | |
1036 | (gnus-topic-goto-topic topic) | |
1037 | (gnus-topic-kill-group) | |
1038 | (gnus-topic-create-topic | |
1039 | topic grandparent (gnus-topic-next-topic parent) | |
1040 | (cdr (pop gnus-topic-killed-topics))) | |
1041 | (gnus-topic-goto-topic topic)))) | |
1042 | ||
1043 | (defun gnus-topic-list-active (&optional force) | |
1044 | "List all groups that Gnus knows about in a topicsified fashion. | |
1045 | If FORCE, always re-read the active file." | |
1046 | (interactive "P") | |
1047 | (when force | |
1048 | (gnus-get-killed-groups)) | |
1049 | (gnus-topic-grok-active force) | |
1050 | (let ((gnus-topic-topology gnus-topic-active-topology) | |
1051 | (gnus-topic-alist gnus-topic-active-alist) | |
1052 | gnus-killed-list gnus-zombie-list) | |
1053 | (gnus-group-list-groups 9 nil 1))) | |
1054 | ||
1055 | (provide 'gnus-topic) | |
1056 | ||
1057 | ;;; gnus-topic.el ends here |