*** empty log message ***
[gnus] / lisp / gnus-topic.el
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-unique t
52   "*If non-nil, each group will only belong to one topic.")
53
54 (defvar gnus-topic-indent-level 2
55   "*How much each subtopic should be indented.")
56
57 ;; Internal variables.
58
59 (defvar gnus-topic-killed-topics nil)
60 (defvar gnus-topic-inhibit-change-level nil)
61
62
63 (defconst gnus-topic-line-format-alist
64   `((?n name ?s)
65     (?v visible ?s)
66     (?i indentation ?s)
67     (?g number-of-groups ?d)
68     (?a (gnus-topic-articles-in-topic entries) ?d)
69     (?A total-number-of-articles ?d)
70     (?l level ?d)))
71
72 (defvar gnus-topic-line-format-spec nil)
73 (defvar gnus-topic-active-topology nil)
74 (defvar gnus-topic-active-alist nil)
75
76 ;; Functions.
77
78 (defun gnus-group-topic-name ()
79   "The name of the topic on the current line."
80   (get-text-property (gnus-point-at-bol) 'gnus-topic))
81
82 (defun gnus-group-topic-level ()
83   "The level of the topic on the current line."
84   (get-text-property (gnus-point-at-bol) 'gnus-topic-level))
85
86 (defun gnus-topic-init-alist ()
87   "Initialize the topic structures."
88   (setq gnus-topic-topology
89         (cons (list "Gnus" 'visible)
90               (mapcar (lambda (topic)
91                         (list (list (car topic) 'visible)))
92                       '(("misc")))))
93   (setq gnus-topic-alist
94         (list (cons "misc"
95                     (mapcar (lambda (info) (gnus-info-group info))
96                             (cdr gnus-newsrc-alist)))
97               (list "Gnus")))
98   (gnus-topic-enter-dribble))
99
100 (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic)
101   "List all newsgroups with unread articles of level LEVEL or lower, and
102 use the `gnus-group-topics' to sort the groups.
103 If ALL is non-nil, list groups that have no unread articles.
104 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
105   (set-buffer gnus-group-buffer)
106   (let ((buffer-read-only nil)
107         (lowest (or lowest 1))
108         tlist info)
109     
110     (unless list-topic 
111       (erase-buffer))
112     
113     ;; List dead groups?
114     (when nil
115     (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie))
116       (gnus-group-prepare-flat-list-dead 
117        (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) 
118        gnus-level-zombie ?Z
119        regexp))
120     
121     (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))
122       (gnus-group-prepare-flat-list-dead 
123        (setq gnus-killed-list (sort gnus-killed-list 'string<))
124        gnus-level-killed ?K
125        regexp)))
126     
127     ;; Use topics.
128     (when (< lowest gnus-level-zombie)
129       (if list-topic
130           (let ((top (gnus-topic-find-topology list-topic)))
131             (gnus-topic-prepare-topic (cdr top) (car top) level all))
132         (gnus-topic-prepare-topic gnus-topic-topology 0 level all))))
133
134   (gnus-group-set-mode-line)
135   (setq gnus-group-list-mode (cons level all))
136   (run-hooks 'gnus-group-prepare-hook))
137
138 (defun gnus-topic-prepare-topic (topic level &optional list-level all silent)
139   "Insert TOPIC into the group buffer.
140 If SILENT, don't insert anything.  Return the number of unread
141 articles in the topic and its subtopics."
142   (let* ((type (pop topic))
143          (entries (gnus-topic-find-groups (car type) list-level all))
144          (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
145          (gnus-group-indentation 
146           (make-string (* gnus-topic-indent-level level) ? ))
147          (beg (progn (beginning-of-line) (point)))
148          (topic (reverse topic))
149          (all-entries entries)
150          (unread 0)
151          info entry end)
152     ;; Insert any sub-topics.
153     (while topic
154       (incf unread
155             (gnus-topic-prepare-topic 
156              (pop topic) (1+ level) list-level all
157              (not visiblep))))
158     (setq end (point))
159     (goto-char beg)
160     ;; Insert all the groups that belong in this topic.
161     (while (setq info (nth 2 (setq entry (pop entries))))
162       (when visiblep 
163         (gnus-group-insert-group-line 
164          (gnus-info-group info)
165          (gnus-info-level info) (gnus-info-marks info) 
166          (car entry) (gnus-info-method info)))
167       (when (numberp (car entry))
168         (incf unread (car entry))))
169     (goto-char beg)
170     ;; Insert the topic line.
171     (unless silent
172       (gnus-extent-start-open (point))
173       (gnus-topic-insert-topic-line 
174        (car type) visiblep
175        (not (eq (nth 2 type) 'hidden))
176        level all-entries unread))
177     (goto-char end)
178     unread))
179
180 (defun gnus-topic-find-groups (topic &optional level all)
181   "Return entries for all visible groups in TOPIC."
182   (let ((groups (cdr (assoc topic gnus-topic-alist)))
183         info clevel unread group w lowest gtopic params visible-groups entry)
184     (setq lowest (or lowest 1))
185     (setq level (or level 7))
186     ;; We go through the newsrc to look for matches.
187     (while groups
188       (setq entry (gnus-gethash (pop groups) gnus-newsrc-hashtb)
189             info (nth 2 entry)
190             group (gnus-info-group info)
191             params (gnus-info-params info)
192             unread (car entry))
193       (and 
194        unread                           ; nil means that the group is dead.
195        (<= (setq clevel (gnus-info-level info)) level) 
196        (>= clevel lowest)               ; Is inside the level we want.
197        (or all
198            (and gnus-group-list-inactive-groups
199                 (eq unread t))
200            (> unread 0)
201            (and gnus-list-groups-with-ticked-articles
202                 (cdr (assq 'tick (gnus-info-marks info))))
203                                         ; Has right readedness.
204            ;; Check for permanent visibility.
205            (and gnus-permanently-visible-groups
206                 (string-match gnus-permanently-visible-groups group))
207            (memq 'visible params)
208            (cdr (assq 'visible params)))
209        ;; Add this group to the list of visible groups.
210        (push entry visible-groups)))
211     (nreverse visible-groups)))
212
213 (defun gnus-topic-remove-topic (&optional insert total-remove hide)
214   "Remove the current topic."
215   (let ((topic (gnus-group-topic-name))
216         (level (gnus-group-topic-level))
217         (beg (progn (beginning-of-line) (point)))
218         buffer-read-only)
219     (when topic
220       (while (and (zerop (forward-line 1))
221                   (> (or (gnus-group-topic-level) (1+ level)) level)))
222       (delete-region beg (point))
223       (setcar (cdr (car (cdr (gnus-topic-find-topology topic))))
224               (if insert 'visible 'invisible))
225       (when hide
226         (setcdr (cdr (car (cdr (gnus-topic-find-topology topic))))
227                 (list hide)))
228       (unless total-remove
229         (gnus-topic-insert-topic topic)))))
230
231 (defun gnus-topic-insert-topic (topic)
232   "Insert TOPIC."
233   (gnus-group-prepare-topics 
234    (car gnus-group-list-mode) (cdr gnus-group-list-mode)
235    nil nil topic))
236   
237 (defun gnus-topic-fold (&optional insert)
238   "Remove/insert the current topic."
239   (let ((topic (gnus-group-topic-name))) 
240     (when topic
241       (save-excursion
242         (if (not (gnus-group-active-topic-p))
243             (gnus-topic-remove-topic
244              (or insert (not (gnus-topic-visible-p))))
245           (let ((gnus-topic-topology gnus-topic-active-topology)
246                 (gnus-topic-alist gnus-topic-active-alist))
247             (gnus-topic-remove-topic
248              (or insert (not (gnus-topic-visible-p))))))))))
249
250 (defun gnus-group-topic-p ()
251   "Return non-nil if the current line is a topic."
252   (get-text-property (gnus-point-at-bol) 'gnus-topic))
253
254 (defun gnus-topic-visible-p ()
255   "Return non-nil if the current topic is visible."
256   (get-text-property (gnus-point-at-bol) 'gnus-topic-visible))
257
258 (defun gnus-topic-insert-topic-line (name visiblep shownp level entries 
259                                           &optional unread)
260   (let* ((visible (if visiblep "" "..."))
261          (indentation (make-string (* gnus-topic-indent-level level) ? ))
262          (total-number-of-articles unread)
263          (number-of-groups (length entries))
264          (active-topic (eq gnus-topic-alist gnus-topic-active-alist)))
265     (beginning-of-line)
266     ;; Insert the text.
267     (add-text-properties 
268      (point)
269      (prog1 (1+ (point)) 
270        (eval gnus-topic-line-format-spec)
271        (gnus-topic-remove-excess-properties))
272      (list 'gnus-topic name
273            'gnus-topic-level level
274            'gnus-active active-topic
275            'gnus-topic-visible visiblep))))
276
277 (defun gnus-topic-previous-topic (topic)
278   "Return the previous topic on the same level as TOPIC."
279   (let ((top (cdr (cdr (gnus-topic-find-topology
280                         (gnus-topic-parent-topic topic))))))
281     (unless (equal topic (car (car (car top))))
282       (while (and top (not (equal (car (car (car (cdr top)))) topic)))
283         (setq top (cdr top)))
284       (car (car (car top))))))
285
286 (defun gnus-topic-parent-topic (topic &optional topology)
287   "Return the parent of TOPIC."
288   (unless topology
289     (setq topology gnus-topic-topology))
290   (let ((parent (car (pop topology)))
291         result found)
292     (while (and topology
293                 (not (setq found (equal (car (car (car topology))) topic)))
294                 (not (setq result (gnus-topic-parent-topic topic 
295                                                            (car topology)))))
296       (setq topology (cdr topology)))
297     (or result (and found parent))))
298
299 (defun gnus-topic-find-topology (topic &optional topology level remove)
300   "Return the topology of TOPIC."
301   (unless topology
302     (setq topology gnus-topic-topology)
303     (setq level 0))
304   (let ((top topology)
305         result)
306     (if (equal (car (car topology)) topic)
307         (progn
308           (when remove
309             (delq topology remove))
310           (cons level topology))
311       (setq topology (cdr topology))
312       (while (and topology
313                   (not (setq result (gnus-topic-find-topology
314                                      topic (car topology) (1+ level)
315                                      (and remove top)))))
316         (setq topology (cdr topology)))
317       result)))
318
319 (defun gnus-topic-check-topology ()  
320   ;; The first time we set the topology to whatever we have
321   ;; gotten here, which can be rather random.
322   (unless gnus-topic-alist
323     (gnus-topic-init-alist))
324
325   (let ((topics (gnus-topic-list))
326         (alist gnus-topic-alist)
327         changed)
328     (while alist
329       (unless (member (car (car alist)) topics)
330         (nconc gnus-topic-topology
331                (list (list (list (car (car alist)) 'visible))))
332         (setq changed t))
333       (setq alist (cdr alist)))
334     (when changed
335       (gnus-topic-enter-dribble)))
336   (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry))
337                                          gnus-topic-alist)))
338          (entry (assoc (caar gnus-topic-topology) gnus-topic-alist))
339          (newsrc gnus-newsrc-alist)
340          group)
341     (while newsrc
342       (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)
343         (setcdr entry (cons group (cdr entry)))))))
344
345 (defvar gnus-tmp-topics nil)
346 (defun gnus-topic-list (&optional topology)
347   (unless topology
348     (setq topology gnus-topic-topology 
349           gnus-tmp-topics nil))
350   (push (car (car topology)) gnus-tmp-topics)
351   (mapcar 'gnus-topic-list (cdr topology))
352   gnus-tmp-topics)
353
354 (defun gnus-topic-enter-dribble ()
355   (gnus-dribble-enter
356    (format "(setq gnus-topic-topology '%S)" gnus-topic-topology)))
357
358 (defun gnus-topic-articles-in-topic (entries)
359   (let ((total 0)
360         number)
361     (while entries
362       (when (numberp (setq number (car (pop entries))))
363         (incf total number)))
364     total))
365
366 (defun gnus-group-parent-topic ()
367   "Return the topic the current group belongs in."
368   (let ((group (gnus-group-group-name)))
369     (if group
370         (gnus-group-topic group)
371       (gnus-group-topic-name))))
372
373 (defun gnus-group-topic (group)
374   "Return the topic GROUP is a member of."
375   (let ((alist gnus-topic-alist)
376         out)
377     (while alist
378       (when (member group (cdr (car alist)))
379         (setq out (car (car alist))
380               alist nil))
381       (setq alist (cdr alist)))
382     out))
383
384 (defun gnus-topic-goto-topic (topic)
385   (let ((orig (point)))
386     (goto-char (point-min))
387     (while (and (not (equal topic (gnus-group-topic-name)))
388                 (zerop (forward-line 1))))
389     (or (gnus-group-topic-name)
390         (progn
391           (goto-char orig)
392           nil))))
393   
394 (defun gnus-topic-update-topic ()
395   "Update all parent topics to the current group."
396   (when (and (eq major-mode 'gnus-group-mode)
397              gnus-topic-mode)
398     (let ((group (gnus-group-group-name)))
399       (gnus-topic-goto-topic (gnus-group-parent-topic))
400       (gnus-topic-update-topic-line)
401       (gnus-group-goto-group group)
402       (gnus-group-position-point))))
403
404 (defun gnus-topic-update-topic-line (&optional topic level)
405   (unless topic
406     (setq topic gnus-topic-topology)
407     (setq level 0))
408   (let* ((type (pop topic))
409          (buffer-read-only nil)
410          (entries (gnus-topic-find-groups 
411                    (car type) (car gnus-group-list-mode)
412                    (cdr gnus-group-list-mode)))
413          (visiblep (eq (nth 1 type) 'visible))
414          (all-entries entries)
415          (unread 0)
416          info entry end)
417     ;; Tally any sub-topics.
418     (while topic
419       (incf unread (gnus-topic-update-topic-line (pop topic) (1+ level))))
420     ;; Tally all the groups that belong in this topic.
421     (while (setq info (nth 2 (setq entry (pop entries))))
422       (when (numberp (car entry))
423         (incf unread (car entry))))
424     ;; Insert the topic line.
425     (when (gnus-topic-goto-topic (car type))
426       (gnus-topic-insert-topic-line 
427        (car type) visiblep
428        (not (eq (nth 2 type) 'hidden))
429        level all-entries unread)
430       (gnus-delete-line))
431     unread))
432
433 (defun gnus-topic-grok-active (&optional force)
434   "Parse all active groups and create topic structures for them."
435   ;; First we make sure that we have really read the active file. 
436   (when (or force
437             (not gnus-topic-active-alist))
438     (when (or force
439               (not gnus-have-read-active-file))
440       (let ((gnus-read-active-file t))
441         (gnus-read-active-file)))
442     (let (topology groups alist)
443       ;; Get a list of all groups available.
444       (mapatoms (lambda (g) (when (symbol-value g)
445                               (push (symbol-name g) groups)))
446                 gnus-active-hashtb)
447       (setq groups (sort groups 'string<))
448       ;; Init the variables.
449       (setq gnus-topic-active-topology '(("" visible)))
450       (setq gnus-topic-active-alist nil)
451       ;; Descend the top-level hierarchy.
452       (gnus-topic-grok-active-1 gnus-topic-active-topology groups)
453       ;; Set the top-level topic names to something nice.
454       (setcar (car gnus-topic-active-topology) "Gnus active")
455       (setcar (car gnus-topic-active-alist) "Gnus active"))))
456
457 (defun gnus-topic-grok-active-1 (topology groups)
458   (let* ((name (caar topology))
459          (prefix (concat "^" (regexp-quote name)))
460          tgroups nprefix ntopology group)
461     (while (and groups
462                 (string-match prefix (setq group (car groups))))
463       (if (not (string-match "\\." group (match-end 0)))
464           ;; There are no further hierarchies here, so we just
465           ;; enter this group into the list belonging to this
466           ;; topic.
467           (push (pop groups) tgroups)
468         ;; New sub-hierarchy, so we add it to the topology.
469         (nconc topology (list (setq ntopology 
470                                     (list (list (substring 
471                                                  group 0 (match-end 0))
472                                                 'invisible)))))
473         ;; Descend the hierarchy.
474         (setq groups (gnus-topic-grok-active-1 ntopology groups))))
475     ;; We remove the trailing "." from the topic name.
476     (setq name
477           (if (string-match "\\.$" name)
478               (substring name 0 (match-beginning 0))
479             name))
480     ;; Add this topic and its groups to the topic alist.
481     (push (cons name (nreverse tgroups)) gnus-topic-active-alist)
482     (setcar (car topology) name)
483     ;; We return the rest of the groups that didn't belong
484     ;; to this topic.
485     groups))
486
487 (defun gnus-group-active-topic-p ()
488   "Return whether the current active comes from the active topics."
489   (save-excursion
490     (beginning-of-line)
491     (get-text-property (point) 'gnus-active)))
492
493 ;;; Topic mode, commands and keymap.
494
495 (defvar gnus-topic-mode-map nil)
496 (defvar gnus-group-topic-map nil)
497
498 (unless gnus-topic-mode-map
499   (setq gnus-topic-mode-map (make-sparse-keymap))
500
501   ;; Override certain group mode keys.
502   (gnus-define-keys
503    gnus-topic-mode-map
504    "=" gnus-topic-select-group
505    "\r" gnus-topic-select-group
506    " " gnus-topic-read-group
507    "\C-k" gnus-topic-kill-group
508    "\C-y" gnus-topic-yank-group
509    "\M-g" gnus-topic-get-new-news-this-topic
510    "\C-i" gnus-topic-indent
511    "AT" gnus-topic-list-active
512    gnus-mouse-2 gnus-mouse-pick-topic)
513
514   ;; Define a new submap.
515   (gnus-define-keys
516    (gnus-group-topic-map "T" gnus-group-mode-map)
517    "#" gnus-topic-mark-topic
518    "n" gnus-topic-create-topic
519    "m" gnus-topic-move-group
520    "c" gnus-topic-copy-group
521    "h" gnus-topic-hide-topic
522    "s" gnus-topic-show-topic
523    "M" gnus-topic-move-matching
524    "C" gnus-topic-copy-matching
525    "r" gnus-topic-rename
526    "\177" gnus-topic-delete))
527
528 (defun gnus-topic-make-menu-bar ()
529   (unless (boundp 'gnus-topic-menu)
530     (easy-menu-define
531      gnus-topic-menu gnus-topic-mode-map ""
532      '("Topics"
533        ["Toggle topics" gnus-topic-mode t]
534        ("Groups"
535         ["Copy" gnus-topic-copy-group t]
536         ["Move" gnus-topic-move-group t]
537         ["Copy matching" gnus-topic-copy-matching t]
538         ["Move matching" gnus-topic-move-matching t])
539        ("Topics"
540         ["Show" gnus-topic-show-topic t]
541         ["Hide" gnus-topic-hide-topic t]
542         ["Delete" gnus-topic-delete t]
543         ["Rename" gnus-topic-rename t]
544         ["Create" gnus-topic-create-topic t]
545         ["Mark" gnus-topic-mark-topic t]
546         ["Indent" gnus-topic-indent t])
547        ["List active" gnus-topic-list-active t]))))
548
549
550 (defun gnus-topic-mode (&optional arg redisplay)
551   "Minor mode for topicsifying Gnus group buffers."
552   (interactive (list current-prefix-arg t))
553   (when (eq major-mode 'gnus-group-mode)
554     (make-local-variable 'gnus-topic-mode)
555     (setq gnus-topic-mode 
556           (if (null arg) (not gnus-topic-mode)
557             (> (prefix-numeric-value arg) 0)))
558     ;; Infest Gnus with topics.
559     (when gnus-topic-mode
560       (when (and menu-bar-mode
561                  (gnus-visual-p 'topic-menu 'menu))
562         (gnus-topic-make-menu-bar))
563       (setq gnus-topic-line-format-spec 
564             (gnus-parse-format gnus-topic-line-format 
565                                gnus-topic-line-format-alist t))
566       (unless (assq 'gnus-topic-mode minor-mode-alist)
567         (push '(gnus-topic-mode " Topic") minor-mode-alist))
568       (unless (assq 'gnus-topic-mode minor-mode-map-alist)
569         (push (cons 'gnus-topic-mode gnus-topic-mode-map)
570               minor-mode-map-alist))
571       (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
572       (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
573       (make-local-variable 'gnus-group-prepare-function)
574       (setq gnus-group-prepare-function 'gnus-group-prepare-topics)
575       (make-local-variable 'gnus-group-goto-next-group-function)
576       (setq gnus-group-goto-next-group-function 
577             'gnus-topic-goto-next-group)
578       (setq gnus-group-change-level-function 'gnus-topic-change-level)
579       (run-hooks 'gnus-topic-mode-hook)
580       ;; We check the topology.
581       (gnus-topic-check-topology))
582     ;; Remove topic infestation.
583     (unless gnus-topic-mode
584       (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
585       (remove-hook 'gnus-group-change-level-function 
586                    'gnus-topic-change-level)
587       (setq gnus-group-prepare-function 'gnus-group-prepare-flat))
588     (when redisplay
589       (gnus-group-list-groups))))
590     
591 (defun gnus-topic-select-group (&optional all)
592   "Select this newsgroup.
593 No article is selected automatically.
594 If ALL is non-nil, already read articles become readable.
595 If ALL is a number, fetch this number of articles."
596   (interactive "P")
597   (if (gnus-group-topic-p)
598       (let ((gnus-group-list-mode 
599              (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
600         (gnus-topic-fold all))
601     (gnus-group-select-group all)))
602
603 (defun gnus-mouse-pick-topic (e)
604   "Select the group or topic under the mouse pointer."
605   (interactive "e")
606   (mouse-set-point e)
607   (gnus-topic-read-group nil))
608
609 (defun gnus-topic-read-group (&optional all no-article group)
610   "Read news in this newsgroup.
611 If the prefix argument ALL is non-nil, already read articles become
612 readable.  IF ALL is a number, fetch this number of articles.  If the
613 optional argument NO-ARTICLE is non-nil, no article will be
614 auto-selected upon group entry.  If GROUP is non-nil, fetch that
615 group."
616   (interactive "P")
617   (if (gnus-group-topic-p)
618       (let ((gnus-group-list-mode 
619              (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
620         (gnus-topic-fold all))
621     (gnus-group-read-group all no-article group)))
622
623 (defun gnus-topic-create-topic (topic parent &optional previous)
624   (interactive 
625    (list
626     (read-string "Create topic: ")
627     (completing-read "Parent topic: " gnus-topic-alist nil t
628                      (cons (gnus-group-parent-topic) 0))))
629   ;; Check whether this topic already exists.
630   (when (gnus-topic-find-topology topic)
631     (error "Topic aleady exists"))
632   (unless parent
633     (setq parent (car (car gnus-topic-topology))))
634   (let ((top (cdr (gnus-topic-find-topology parent))))
635     (unless top
636       (error "No such parent topic: %s" parent))
637     (if previous
638         (progn
639           (while (and (cdr top)
640                       (not (equal (car (car (car (cdr top)))) previous)))
641             (setq top (cdr top)))
642           (setcdr top (cons (list (list topic 'visible)) (cdr top))))
643       (nconc top (list (list (list topic 'visible)))))
644     (unless (assoc topic gnus-topic-alist)
645       (push (list topic) gnus-topic-alist)))
646   (gnus-topic-enter-dribble)
647   (gnus-group-list-groups))
648
649 (defun gnus-topic-move-group (n topic &optional copyp)
650   "Move the current group to a topic."
651   (interactive
652    (list current-prefix-arg
653          (completing-read "Move to topic: " gnus-topic-alist nil t)))
654   (let ((groups (gnus-group-process-prefix n))
655         (topicl (assoc topic gnus-topic-alist))
656         entry)
657     (unless topicl
658       (error "No such topic: %s" topic))
659     (mapcar (lambda (g) 
660               (gnus-group-remove-mark g)
661               (when (and
662                      (setq entry (assoc (gnus-group-topic g) gnus-topic-alist))
663                      (not copyp))
664                 (setcdr entry (delete g (cdr entry))))
665               (nconc topicl (list g)))
666             groups)
667     (gnus-group-position-point))
668   (gnus-topic-enter-dribble)
669   (gnus-group-list-groups))
670
671 (defun gnus-topic-copy-group (n topic)
672   "Copy the current group to a topic."
673   (interactive
674    (list current-prefix-arg
675          (completing-read "Copy to topic: " gnus-topic-alist nil t)))
676   (gnus-topic-move-group n topic t))
677
678 (defun gnus-topic-change-level (group level oldlevel)
679   "Run when changing levels to enter/remove groups from topics."
680   (when (and gnus-topic-mode 
681              (not gnus-topic-inhibit-change-level))
682     ;; Remove the group from the topics.
683     (when (and (< oldlevel gnus-level-zombie)
684                (>= level gnus-level-zombie))
685       (let (alist)
686         (when (setq alist (assoc (gnus-group-topic group) gnus-topic-alist))
687           (setcdr alist (delete group (cdr alist))))))
688     ;; If the group is subscribed. then we enter it into the topics.
689     (when (and (< level gnus-level-zombie)
690                (>= oldlevel gnus-level-zombie))
691       (let ((entry (assoc (caar gnus-topic-topology) gnus-topic-alist)))
692         (setcdr entry (cons group (cdr entry)))))))
693
694 (defun gnus-topic-goto-next-group (group props)
695   "Go to group or the next group after group."
696   (if (null group)
697       (gnus-topic-goto-topic (cadr (memq 'gnus-topic props)))
698     (if (gnus-group-goto-group group)
699         t
700       ;; The group is no longer visible.
701       (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist))
702              (after (cdr (member group (cdr list)))))
703         ;; First try to put point on a group after the current one.
704         (while (and after
705                     (not (gnus-group-goto-group (car after))))
706           (setq after (cdr after)))
707         ;; Then try to put point on a group before point.
708         (unless after
709           (setq after (cdr (member group (reverse (cdr list)))))
710           (while (and after 
711                       (not (gnus-group-goto-group (car after))))
712             (setq after (cdr after))))
713         ;; Finally, just put point on the topic.
714         (unless after
715           (gnus-topic-goto-topic (car list))
716           (setq after nil))
717         t))))
718
719 (defun gnus-topic-kill-group (&optional n discard)
720   "Kill the next N groups."
721   (interactive "P")
722   (if (gnus-group-topic-p)
723       (let ((topic (gnus-group-topic-name)))
724         (gnus-topic-remove-topic nil t)
725         (push (gnus-topic-find-topology topic nil nil gnus-topic-topology)
726               gnus-topic-killed-topics))
727     (gnus-group-kill-group n discard)
728     (gnus-topic-update-topic)))
729   
730 (defun gnus-topic-yank-group (&optional arg)
731   "Yank the last topic."
732   (interactive "p")
733   (if gnus-topic-killed-topics
734       (let ((previous (gnus-group-parent-topic))
735             (item (nth 1 (pop gnus-topic-killed-topics))))
736         (gnus-topic-create-topic
737          (car item) (gnus-topic-parent-topic previous) previous))
738     (let* ((prev (gnus-group-group-name))
739            (gnus-topic-inhibit-change-level t)
740            (gnus-group-indentation
741             (make-string 
742              (* gnus-topic-indent-level
743                 (or (save-excursion
744                       (gnus-topic-goto-topic (gnus-group-parent-topic))
745                       (gnus-group-topic-level)) 0)) ? ))
746            yanked group alist)
747       ;; We first yank the groups the normal way...
748       (setq yanked (gnus-group-yank-group arg))
749       ;; Then we enter the yanked groups into the topics they belong
750       ;; to. 
751       (setq alist (assoc (save-excursion
752                            (forward-line -1)
753                            (gnus-group-parent-topic))
754                          gnus-topic-alist))
755       (when (stringp yanked)
756         (setq yanked (list yanked)))
757       (if (not prev)
758           (nconc alist yanked)
759         (if (not (cdr alist))
760             (setcdr alist (nconc yanked (cdr alist)))
761           (while (cdr alist)
762             (when (equal (car (cdr alist)) prev)
763               (setcdr alist (nconc yanked (cdr alist)))
764               (setq alist nil))
765             (setq alist (cdr alist))))))
766     (gnus-topic-update-topic)))
767
768 (defun gnus-topic-hide-topic ()
769   "Hide all subtopics under the current topic."
770   (interactive)
771   (when (gnus-group-topic-p)
772     (gnus-topic-remove-topic nil nil 'hidden)))
773
774 (defun gnus-topic-show-topic ()
775   "Show the hidden topic."
776   (interactive)
777   (when (gnus-group-topic-p)
778     (gnus-topic-remove-topic t nil 'shown)))
779
780 (defun gnus-topic-mark-topic (topic)
781   "Mark all groups in the topic with the process mark."
782   (interactive (list (gnus-group-parent-topic)))
783   (let ((groups (cdr (gnus-topic-find-groups topic))))
784     (while groups
785       (gnus-group-set-mark (gnus-info-group (nth 2 (pop groups)))))))
786
787 (defun gnus-topic-get-new-news-this-topic (&optional n)
788   "Check for new news in the current topic."
789   (interactive "P")
790   (if (not (gnus-group-topic-p))
791       (gnus-group-get-new-news-this-group n)
792     (gnus-topic-mark-topic (gnus-group-topic-name))
793     (gnus-group-get-new-news-this-group)))
794
795 (defun gnus-topic-move-matching (regexp topic &optional copyp)
796   "Move all groups that match REGEXP to some topic."
797   (interactive
798    (let (topic)
799      (nreverse
800       (list
801        (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t))
802        (read-string (format "Move to %s (regexp): " topic))))))
803   (gnus-group-mark-regexp regexp)
804   (gnus-topic-move-group nil topic copyp))
805
806 (defun gnus-topic-copy-matching (regexp topic &optional copyp)
807   "Copy all groups that match REGEXP to some topic."
808   (interactive
809    (let (topic)
810      (nreverse
811       (list
812        (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t))
813        (read-string (format "Copy to %s (regexp): " topic))))))
814   (gnus-topic-move-matching regexp topic t))
815
816 (defun gnus-topic-delete (topic)
817   "Delete a topic."
818   (interactive (list (gnus-group-topic-name)))
819   (unless topic
820     (error "No topic to be deleted"))
821   (let ((entry (assoc topic gnus-topic-alist))
822         (buffer-read-only nil))
823     (when (cdr entry)
824       (error "Topic not empty"))
825     ;; Delete if visible.
826     (when (gnus-topic-goto-topic topic)
827       (gnus-delete-line))
828     ;; Remove from alist.
829     (setq gnus-topic-alist (delq entry gnus-topic-alist))
830     ;; Remove from topology.
831     (gnus-topic-find-topology topic nil nil 'delete)))
832
833 (defun gnus-topic-rename (old-name new-name)
834   "Rename a topic."
835   (interactive
836    (let (topic)
837      (list
838       (setq topic (completing-read "Rename topic: " gnus-topic-alist nil t
839                                    (cons (gnus-group-parent-topic) 0)))
840       (read-string (format "Rename %s to: " topic)))))
841   (let ((top (gnus-topic-find-topology old-name))
842         (entry (assoc old-name gnus-topic-alist)))
843     (when top
844       (setcar (car (cdr top)) new-name))
845     (when entry 
846       (setcar entry new-name))
847     (gnus-group-list-groups)))
848
849 (defun gnus-topic-indent (&optional unindent)
850   "Indent a topic -- make it a sub-topic of the previous topic.
851 If UNINDENT, remove an indentation."
852   (interactive "P")
853   (if unindent
854       (gnus-topic-unindent)
855     (let* ((topic (gnus-group-parent-topic))
856            (parent (gnus-topic-previous-topic topic)))
857       (unless parent
858         (error "Nothing to indent %s into" topic))
859       (when topic
860         (gnus-topic-goto-topic topic)
861         (gnus-topic-kill-group)
862         (gnus-topic-create-topic topic parent)
863         (gnus-topic-goto-topic topic)))))
864
865 (defun gnus-topic-unindent ()
866   "Unindent a topic."
867   (interactive)
868   (let* ((topic (gnus-group-parent-topic))
869          (parent (gnus-topic-parent-topic topic))
870          (grandparent (gnus-topic-parent-topic parent)))
871     (unless grandparent
872       (error "Nothing to indent %s into" topic))
873     (when topic
874       (gnus-topic-goto-topic topic)
875       (gnus-topic-kill-group)
876       (gnus-topic-create-topic topic grandparent)
877       (gnus-topic-goto-topic topic))))
878
879 (defun gnus-topic-list-active (&optional force)
880   "List all groups that Gnus knows about in a topicsified fashion.
881 If FORCE, always re-read the active file."
882   (interactive "P")
883   (gnus-topic-grok-active)
884   (let ((gnus-topic-topology gnus-topic-active-topology)
885         (gnus-topic-alist gnus-topic-active-alist))
886     (gnus-group-list-groups 9 nil 1)))
887
888 (provide 'gnus-topic)
889
890 ;;; gnus-topic.el ends here