cgit.sxemacs.org Git - gnus/blob - lisp/gnus-topic.el

   1 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
   2 ;; Copyright (C) 1995 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
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'gnus)
  29 (eval-when-compile (require 'cl))
  30
  31 (defvar gnus-topic-mode nil
  32   "Minor mode for Gnus group buffers.")
  33
  34 (defvar gnus-topic-line-format "%i[ %(%{%n%}%) -- %a ]%v\n"
  35   "Format of topic lines.
  36 It works along the same lines as a normal formatting string,
  37 with some simple extensions.
  38
  39 %i  Indentation based on topic level.
  40 %n  Topic name.
  41 %v  Nothing if the topic is visible, \"...\" otherwise.
  42 %g  Number of groups in the topic.
  43 %a  Number of unread articles in the groups in the topic.
  44 ")
  45
  46 (defvar gnus-group-topic-topics-only nil
  47   "*If non-nil, only the topics will be shown when typing `l' or `L'.")
  48
  49 (defvar gnus-topic-unique t
  50   "*If non-nil, each group will only belong to one topic.")
  51
  52 (defvar gnus-topic-hide-subtopics t
  53   "*If non-nil, hide subtopics along with groups.")
  54
  55 ;; Internal variables.
  56
  57 (defvar gnus-topic-killed-topics nil)
  58
  59 (defconst gnus-topic-line-format-alist
  60   `((?n name ?s)
  61     (?v visible ?s)
  62     (?i indentation ?s)
  63     (?g number-of-groups ?d)
  64     (?a number-of-articles ?d)
  65     (?l level ?d)))
  66
  67 (defvar gnus-topic-line-format-spec nil)
  68
  69 ;; Functions.
  70
  71 (defun gnus-group-topic-name ()
  72   "The name of the topic on the current line."
  73   (get-text-property (gnus-point-at-bol) 'gnus-topic))
  74
  75 (defun gnus-group-topic-level ()
  76   "The level of the topic on the current line."
  77   (get-text-property (gnus-point-at-bol) 'gnus-topic-level))
  78
  79 (defun gnus-topic-init-alist ()
  80   (setq gnus-topic-topology
  81         (cons (list "Gnus" 'visible)
  82               (mapcar (lambda (topic)
  83                         (list (list (car topic) 'visible)))
  84                       '(("misc")))))
  85   (setq gnus-topic-alist
  86         (list (cons "misc"
  87                     (mapcar (lambda (info) (gnus-info-group info))
  88                             (cdr gnus-newsrc-alist)))
  89               (list "Gnus")))
  90   (gnus-topic-enter-dribble))
  91
  92 (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic)
  93   "List all newsgroups with unread articles of level LEVEL or lower, and
  94 use the `gnus-group-topics' to sort the groups.
  95 If ALL is non-nil, list groups that have no unread articles.
  96 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
  97   (set-buffer gnus-group-buffer)
  98   (setq gnus-topic-indentation "")
  99   (let ((buffer-read-only nil)
 100         (lowest (or lowest 1))
 101         tlist info)
 102
 103     (unless list-topic
 104       (erase-buffer))
 105
 106     ;; List dead groups?
 107     (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie))
 108       (gnus-group-prepare-flat-list-dead
 109        (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
 110        gnus-level-zombie ?Z
 111        regexp))
 112
 113     (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))
 114       (gnus-group-prepare-flat-list-dead
 115        (setq gnus-killed-list (sort gnus-killed-list 'string<))
 116        gnus-level-killed ?K
 117        regexp))
 118
 119     ;; Use topics.
 120     (when (< lowest gnus-level-zombie)
 121       (let (topics topic how)
 122         ;; The first time we set the topology to whatever we have
 123         ;; gotten here, which can be rather random.
 124         (unless gnus-topic-alist
 125           (gnus-topic-init-alist))
 126         (gnus-topic-check-topology)
 127
 128         (if list-topic
 129             (let ((top (gnus-topic-find-topology list-topic)))
 130               (gnus-topic-prepare-topic (cdr top) (car top) level all))
 131           (gnus-topic-prepare-topic gnus-topic-topology 0 level all)))))
 132
 133   (gnus-group-set-mode-line)
 134   (setq gnus-group-list-mode (cons level all))
 135   (run-hooks 'gnus-group-prepare-hook))
 136
 137 (defun gnus-topic-prepare-topic (topic level &optional list-level all)
 138   "Insert TOPIC into the group buffer."
 139   (let* ((type (pop topic))
 140          (entries (gnus-topic-find-groups (car type) list-level all))
 141          (visiblep (eq (nth 1 type) 'visible))
 142          info entry)
 143     ;; Insert the topic line.
 144     (gnus-topic-insert-topic-line
 145      (car type) visiblep
 146      (not (eq (nth 2 type) 'hidden))
 147      level entries)
 148     (when visiblep
 149       ;; Insert all the groups that belong in this topic.
 150       (while entries
 151         (setq entry (pop entries)
 152               info (nth 2 entry))
 153         (gnus-group-insert-group-line
 154          (gnus-info-group info)
 155          (gnus-info-level info) (gnus-info-marks info)
 156          (car entry) (gnus-info-method info))))
 157     ;; Insert any sub-topics.
 158     (when (or visiblep
 159               (and (not gnus-topic-hide-subtopics)
 160                    (eq (nth 2 type) 'shown)))
 161       (while topic
 162         (gnus-topic-prepare-topic (pop topic) (1+ level) list-level all)))))
 163
 164 (defun gnus-topic-find-groups (topic &optional level all)
 165   "Return entries for all visible groups in TOPIC."
 166   (let ((groups (cdr (assoc topic gnus-topic-alist)))
 167         info clevel unread group w lowest gtopic params visible-groups entry)
 168     (setq lowest (or lowest 1))
 169     (setq level (or level 7))
 170     ;; We go through the newsrc to look for matches.
 171     (while groups
 172       (setq entry (gnus-gethash (pop groups) gnus-newsrc-hashtb)
 173             info (nth 2 entry)
 174             group (gnus-info-group info)
 175             params (gnus-info-params info)
 176             unread (car entry))
 177       (and
 178        unread                           ; nil means that the group is dead.
 179        (<= (setq clevel (gnus-info-level info)) level)
 180        (>= clevel lowest)               ; Is inside the level we want.
 181        (or all
 182            (eq unread t)
 183            (> unread 0)
 184            (cdr (assq 'tick (gnus-info-marks info))) ; Has right readedness.
 185            ;; Check for permanent visibility.
 186            (and gnus-permanently-visible-groups
 187                 (string-match gnus-permanently-visible-groups group))
 188            (memq 'visible params)
 189            (cdr (assq 'visible params)))
 190        ;; Add this group to the list of visible groups.
 191        (push entry visible-groups)))
 192     (nreverse visible-groups)))
 193
 194 (defun gnus-topic-remove-topic (&optional insert total-remove hide)
 195   "Remove the current topic."
 196   (let ((topic (gnus-group-topic-name))
 197         (level (gnus-group-topic-level))
 198         (beg (progn (beginning-of-line) (point)))
 199         buffer-read-only)
 200     (when topic
 201       (while (and (zerop (forward-line 1))
 202                   (> (or (gnus-group-topic-level) (1+ level)) level)))
 203       (delete-region beg (point))
 204       (setcar (cdr (car (cdr (gnus-topic-find-topology topic))))
 205               (if insert 'visible 'invisible))
 206       (when hide
 207         (setcdr (cdr (car (cdr (gnus-topic-find-topology topic))))
 208                 (list hide)))
 209       (unless total-remove
 210         (gnus-topic-insert-topic topic)))))
 211
 212 (defun gnus-topic-insert-topic (topic)
 213   "Insert TOPIC."
 214   (gnus-group-prepare-topics
 215    (car gnus-group-list-mode) (cdr gnus-group-list-mode)
 216    nil nil topic))
 217
 218 (defun gnus-topic-fold (&optional insert)
 219   "Remove/insert the current topic."
 220   (let ((topic (gnus-group-topic-name)))
 221     (when topic
 222       (save-excursion
 223         (gnus-topic-remove-topic (or insert (not (gnus-topic-visible-p))))))))
 224
 225 (defun gnus-group-topic-p ()
 226   "Return non-nil if the current line is a topic."
 227   (get-text-property (gnus-point-at-bol) 'gnus-topic))
 228
 229 (defun gnus-topic-visible-p ()
 230   "Return non-nil if the current topic is visible."
 231   (get-text-property (gnus-point-at-bol) 'gnus-topic-visible))
 232
 233 (defun gnus-topic-insert-topic-line (name visiblep shownp level entries)
 234   (let* ((visible (if (and visiblep shownp) "" "..."))
 235          (indentation (make-string (* 2 level) ? ))
 236          (number-of-articles (gnus-topic-articles-in-topic entries))
 237          (number-of-groups (length entries)))
 238     (setq gnus-topic-indentation "")
 239     (beginning-of-line)
 240     ;; Insert the text.
 241     (add-text-properties
 242      (point)
 243      (prog1 (1+ (point))
 244        (eval gnus-topic-line-format-spec)
 245        (gnus-group-remove-excess-properties))
 246      (list 'gnus-topic name
 247            'gnus-topic-level level
 248            'gnus-topic-visible visiblep))))
 249
 250 (defun gnus-topic-previous-topic (topic)
 251   "Return the previous topic on the same level as TOPIC."
 252   (let ((top (cdr (cdr (gnus-topic-find-topology
 253                         (gnus-topic-parent-topic topic))))))
 254     (unless (equal topic (car (car (car top))))
 255       (while (and top (not (equal (car (car (car (cdr top)))) topic)))
 256         (setq top (cdr top)))
 257       (car (car (car top))))))
 258
 259 (defun gnus-topic-parent-topic (topic &optional topology)
 260   "Return the parent of TOPIC."
 261   (unless topology
 262     (setq topology gnus-topic-topology))
 263   (let ((parent (car (pop topology)))
 264         result found)
 265     (while (and topology
 266                 (not (setq found (equal (car (car (car topology))) topic)))
 267                 (not (setq result (gnus-topic-parent-topic topic
 268                                                            (car topology)))))
 269       (setq topology (cdr topology)))
 270     (or result (and found parent))))
 271
 272 (defun gnus-topic-find-topology (topic &optional topology level remove)
 273   "Return the topology of TOPIC."
 274   (unless topology
 275     (setq topology gnus-topic-topology)
 276     (setq level 0))
 277   (let ((top topology)
 278         result)
 279     (if (equal (car (car topology)) topic)
 280         (progn
 281           (when remove
 282             (delq topology remove))
 283           (cons level topology))
 284       (setq topology (cdr topology))
 285       (while (and topology
 286                   (not (setq result (gnus-topic-find-topology
 287                                      topic (car topology) (1+ level)
 288                                      (and remove top)))))
 289         (setq topology (cdr topology)))
 290       result)))
 291
 292 (defun gnus-topic-check-topology ()
 293   (let ((topics (gnus-topic-list))
 294         (alist gnus-topic-alist)
 295         changed)
 296     (while alist
 297       (unless (member (car (car alist)) topics)
 298         (nconc gnus-topic-topology
 299                (list (list (list (car (car alist)) 'visible))))
 300         (setq changed t))
 301       (setq alist (cdr alist)))
 302     (when changed
 303       (gnus-topic-enter-dribble)))
 304   (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry))
 305                                          gnus-topic-alist)))
 306          (entry (assoc "Gnus" gnus-topic-alist))
 307          (newsrc gnus-newsrc-alist)
 308          group)
 309     (while newsrc
 310       (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)
 311         (setcdr entry (cons group (cdr entry)))))))
 312
 313 (defvar gnus-tmp-topics nil)
 314 (defun gnus-topic-list (&optional topology)
 315   (unless topology
 316     (setq topology gnus-topic-topology
 317           gnus-tmp-topics nil))
 318   (push (car (car topology)) gnus-tmp-topics)
 319   (mapcar 'gnus-topic-list (cdr topology))
 320   gnus-tmp-topics)
 321
 322 (defun gnus-topic-enter-dribble ()
 323   (gnus-dribble-enter
 324    (format "(setq gnus-topic-topology '%S)" gnus-topic-topology)))
 325
 326 (defun gnus-topic-articles-in-topic (entries)
 327   (let ((total 0)
 328         number)
 329     (while entries
 330       (when (numberp (setq number (car (pop entries))))
 331         (incf total number)))
 332     total))
 333
 334 (defun gnus-group-parent-topic ()
 335   "Return the topic the current group belongs in."
 336   (let ((group (gnus-group-group-name)))
 337     (if group
 338         (gnus-group-topic group)
 339       (gnus-group-topic-name))))
 340
 341 (defun gnus-group-topic (group)
 342   "Return the topic GROUP is a member of."
 343   (let ((alist gnus-topic-alist)
 344         out)
 345     (while alist
 346       (when (member group (cdr (car alist)))
 347         (setq out (car (car alist))
 348               alist nil))
 349       (setq alist (cdr alist)))
 350     out))
 351
 352 (defun gnus-topic-goto-topic (topic)
 353   (goto-char (point-min))
 354   (while (and (not (equal topic (gnus-group-topic-name)))
 355               (zerop (forward-line 1))))
 356   (gnus-group-topic-name))
 357
 358 (defun gnus-topic-update-topic ()
 359   (when (and (eq major-mode 'gnus-group-mode)
 360              gnus-topic-mode)
 361     (let ((group (gnus-group-group-name)))
 362       (gnus-topic-goto-topic (gnus-group-parent-topic))
 363       (gnus-topic-update-topic-line)
 364       (gnus-group-goto-group group)
 365       (gnus-group-position-point))))
 366
 367 (defun gnus-topic-update-topic-line ()
 368   (let* ((buffer-read-only nil)
 369          (topic (gnus-group-topic-name))
 370          (entry (gnus-topic-find-topology topic))
 371          (level (car entry))
 372          (type (nth 1 entry))
 373          (entries (gnus-topic-find-groups (car type)))
 374          (visiblep (eq (nth 1 type) 'visible)))
 375     ;; Insert the topic line.
 376     (when topic
 377       (gnus-delete-line)
 378       (gnus-topic-insert-topic-line
 379        (car type) visiblep
 380        (not (eq (nth 2 type) 'hidden)) level entries))))
 381
 382 ;;; Topic mode, commands and keymap.
 383
 384 (defvar gnus-topic-mode-map nil)
 385 (defvar gnus-group-topic-map nil)
 386
 387 (unless gnus-topic-mode-map
 388   (setq gnus-topic-mode-map (make-sparse-keymap))
 389   (define-key gnus-topic-mode-map "=" 'gnus-topic-select-group)
 390   (define-key gnus-topic-mode-map "\r" 'gnus-topic-select-group)
 391   (define-key gnus-topic-mode-map " " 'gnus-topic-read-group)
 392   (define-key gnus-topic-mode-map "\C-k" 'gnus-topic-kill-group)
 393   (define-key gnus-topic-mode-map "\C-y" 'gnus-topic-yank-group)
 394   (define-key gnus-topic-mode-map "\M-g" 'gnus-topic-get-new-news-this-topic)
 395   (define-key gnus-topic-mode-map "\C-i" 'gnus-topic-indent)
 396
 397   (define-prefix-command 'gnus-group-topic-map)
 398   (define-key gnus-group-mode-map "T" 'gnus-group-topic-map)
 399   (define-key gnus-group-topic-map "#" 'gnus-topic-mark-topic)
 400   (define-key gnus-group-topic-map "n" 'gnus-topic-create-topic)
 401   (define-key gnus-group-topic-map "m" 'gnus-topic-move-group)
 402   (define-key gnus-group-topic-map "c" 'gnus-topic-copy-group)
 403   (define-key gnus-group-topic-map "h" 'gnus-topic-hide-topic)
 404   (define-key gnus-group-topic-map "s" 'gnus-topic-show-topic)
 405   (define-key gnus-group-topic-map "M" 'gnus-topic-move-matching)
 406   (define-key gnus-group-topic-map "C" 'gnus-topic-copy-matching)
 407   (define-key gnus-group-topic-map "r" 'gnus-topic-rename)
 408   (define-key gnus-group-topic-map "\177" 'gnus-topic-delete)
 409
 410   (define-key gnus-topic-mode-map gnus-mouse-2 'gnus-mouse-pick-topic)
 411   )
 412
 413 ;;;###autoload
 414 (defun gnus-topic-mode (&optional arg redisplay)
 415   "Minor mode for Gnus group buffers."
 416   (interactive (list current-prefix-arg t))
 417   (when (eq major-mode 'gnus-group-mode)
 418     (make-local-variable 'gnus-topic-mode)
 419     (setq gnus-topic-mode
 420           (if (null arg) (not gnus-topic-mode)
 421             (> (prefix-numeric-value arg) 0)))
 422     (when gnus-topic-mode
 423       (setq gnus-topic-line-format-spec
 424             (gnus-parse-format gnus-topic-line-format
 425                                gnus-topic-line-format-alist t))
 426       (unless (assq 'gnus-topic-mode minor-mode-alist)
 427         (push '(gnus-topic-mode " Topic") minor-mode-alist))
 428       (unless (assq 'gnus-topic-mode minor-mode-map-alist)
 429         (push (cons 'gnus-topic-mode gnus-topic-mode-map)
 430               minor-mode-map-alist)))
 431     (make-local-variable 'gnus-group-prepare-function)
 432     (setq gnus-group-prepare-function
 433           (if gnus-topic-mode
 434               'gnus-group-prepare-topics
 435             'gnus-group-prepare-flat))
 436     (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
 437     (when redisplay
 438       (gnus-group-list-groups))))
 439
 440 (defun gnus-topic-select-group (&optional all)
 441   "Select this newsgroup.
 442 No article is selected automatically.
 443 If ALL is non-nil, already read articles become readable.
 444 If ALL is a number, fetch this number of articles."
 445   (interactive "P")
 446   (if (gnus-group-topic-p)
 447       (let ((gnus-group-list-mode
 448              (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
 449         (gnus-topic-fold all))
 450     (gnus-group-select-group all)))
 451
 452 (defun gnus-mouse-pick-topic (e)
 453   "Select the group or topic under the mouse pointer."
 454   (interactive "e")
 455   (mouse-set-point e)
 456   (gnus-topic-read-group nil))
 457
 458 (defun gnus-topic-read-group (&optional all no-article group)
 459   "Read news in this newsgroup.
 460 If the prefix argument ALL is non-nil, already read articles become
 461 readable.  IF ALL is a number, fetch this number of articles.  If the
 462 optional argument NO-ARTICLE is non-nil, no article will be
 463 auto-selected upon group entry.  If GROUP is non-nil, fetch that
 464 group."
 465   (interactive "P")
 466   (if (gnus-group-topic-p)
 467       (let ((gnus-group-list-mode
 468              (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
 469         (gnus-topic-fold all))
 470     (gnus-group-read-group all no-article group)))
 471
 472 (defun gnus-topic-create-topic (topic parent &optional previous)
 473   (interactive
 474    (list
 475     (read-string "Create topic: ")
 476     (completing-read "Parent topic: " gnus-topic-alist nil t)))
 477   ;; Check whether this topic already exists.
 478   (when (gnus-topic-find-topology topic)
 479     (error "Topic aleady exists"))
 480   (unless parent
 481     (setq parent (car (car gnus-topic-topology))))
 482   (let ((top (cdr (gnus-topic-find-topology parent))))
 483     (unless top
 484       (error "No such parent topic: %s" parent))
 485     (if previous
 486         (progn
 487           (while (and (cdr top)
 488                       (not (equal (car (car (car (cdr top)))) previous)))
 489             (setq top (cdr top)))
 490           (setcdr top (cons (list (list topic 'visible)) (cdr top))))
 491       (nconc top (list (list (list topic 'visible)))))
 492     (unless (assoc topic gnus-topic-alist)
 493       (push (list topic) gnus-topic-alist)))
 494   (gnus-topic-enter-dribble)
 495   (gnus-group-list-groups))
 496
 497 (defun gnus-topic-move-group (n topic &optional copyp)
 498   "Move the current group to a topic."
 499   (interactive
 500    (list current-prefix-arg
 501          (completing-read "Move to topic: " gnus-topic-alist nil t)))
 502   (let ((groups (gnus-group-process-prefix n))
 503         (topicl (assoc topic gnus-topic-alist))
 504         entry)
 505     (unless topicl
 506       (error "No such topic: %s" topic))
 507     (mapcar (lambda (g)
 508               (gnus-group-remove-mark g)
 509               (when (and
 510                      (setq entry (assoc (gnus-group-topic g) gnus-topic-alist))
 511                      (not copyp))
 512                 (setcdr entry (delete g (cdr entry))))
 513               (nconc topicl (list g)))
 514             groups)
 515     (gnus-group-position-point))
 516   (gnus-topic-enter-dribble)
 517   (gnus-group-list-groups))
 518
 519 (defun gnus-topic-copy-group (n topic)
 520   "Copy the current group to a topic."
 521   (interactive
 522    (list current-prefix-arg
 523          (completing-read "Copy to topic: " gnus-topic-alist nil t)))
 524   (gnus-topic-move-group n topic t))
 525
 526 (defun gnus-topic-kill-group (&optional n discard)
 527   "Kill the next N groups."
 528   (interactive "P")
 529   (if (gnus-group-topic-p)
 530       (let ((topic (gnus-group-topic-name)))
 531         (gnus-topic-remove-topic nil t)
 532         (push (gnus-topic-find-topology topic nil nil gnus-topic-topology)
 533               gnus-topic-killed-topics))
 534     ;; We first kill the groups the normal way...
 535     (let ((killed (gnus-group-kill-group n discard))
 536           group alist)
 537       ;; Then we remove the killed groups from the topics they belong to.
 538       (when (stringp killed)
 539         (setq killed (list killed)))
 540       (while killed
 541         (when (setq alist (assoc (gnus-group-topic (setq group (pop killed)))
 542                                  gnus-topic-alist))
 543           (setcdr alist (delete group (cdr alist))))))))
 544
 545 (defun gnus-topic-yank-group (&optional arg)
 546   "Yank the last topic."
 547   (interactive "p")
 548   (if gnus-topic-killed-topics
 549       (let ((previous (gnus-group-parent-topic))
 550             (item (nth 1 (pop gnus-topic-killed-topics))))
 551         (gnus-topic-create-topic
 552          (car item) (gnus-topic-parent-topic previous) previous))
 553     ;; We first yank the groups the normal way...
 554     (let* ((topic (gnus-group-parent-topic))
 555            (prev (gnus-group-group-name))
 556            (alist (assoc topic gnus-topic-alist))
 557            (yanked (gnus-group-yank-group arg))
 558            group)
 559       ;; Then we enter the yanked groups in the topics they belong to.
 560       (when (stringp yanked)
 561         (setq yanked (list yanked)))
 562       (if (not prev)
 563           (nconc alist yanked)
 564         (setq alist (cdr alist))
 565         (while (cdr alist)
 566           (when (equal (car (cdr alist)) prev)
 567             (setcdr alist (nconc yanked (cdr alist)))
 568             (setq alist nil))
 569           (setq alist (cdr alist)))))))
 570
 571 (defun gnus-topic-hide-topic ()
 572   "Hide all subtopics under the current topic."
 573   (interactive)
 574   (when (gnus-group-topic-p)
 575     (gnus-topic-remove-topic nil nil 'hidden)))
 576
 577 (defun gnus-topic-show-topic ()
 578   "Show the hidden topic."
 579   (interactive)
 580   (when (gnus-group-topic-p)
 581     (gnus-topic-remove-topic t nil 'shown)))
 582
 583 (defun gnus-topic-mark-topic (topic)
 584   "Mark all groups in the topic with the process mark."
 585   (interactive (list (gnus-group-parent-topic)))
 586   (let ((groups (cdr (gnus-topic-find-groups topic))))
 587     (while groups
 588       (gnus-group-set-mark (gnus-info-group (nth 2 (pop groups)))))))
 589
 590 (defun gnus-topic-get-new-news-this-topic (&optional n)
 591   "Check for new news in the current topic."
 592   (interactive "P")
 593   (if (not (gnus-group-topic-p))
 594       (gnus-group-get-new-news-this-group n)
 595     (gnus-topic-mark-topic (gnus-group-topic-name))
 596     (gnus-group-get-new-news-this-group)))
 597
 598 (defun gnus-topic-move-matching (regexp topic &optional copyp)
 599   "Move all groups that match REGEXP to some topic."
 600   (interactive
 601    (let (topic)
 602      (nreverse
 603       (list
 604        (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t))
 605        (read-string (format "Move to %s (regexp): " topic))))))
 606   (gnus-group-mark-regexp regexp)
 607   (gnus-topic-move-group nil topic copyp))
 608
 609 (defun gnus-topic-copy-matching (regexp topic &optional copyp)
 610   "Copy all groups that match REGEXP to some topic."
 611   (interactive
 612    (let (topic)
 613      (nreverse
 614       (list
 615        (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t))
 616        (read-string (format "Copy to %s (regexp): " topic))))))
 617   (gnus-topic-move-matching regexp topic t))
 618
 619 (defun gnus-topic-delete (topic)
 620   "Delete a topic."
 621   (interactive (list (gnus-group-topic-name)))
 622   (unless topic
 623     (error "No topic to be deleted"))
 624   (let ((entry (assoc topic gnus-topic-alist))
 625         (buffer-read-only nil))
 626     (when (cdr entry)
 627       (error "Topic not empty"))
 628     ;; Delete if visible.
 629     (when (gnus-topic-goto-topic topic)
 630       (gnus-delete-line))
 631     ;; Remove from alist.
 632     (setq gnus-topic-alist (delq entry gnus-topic-alist))
 633     ;; Remove from topology.
 634     (gnus-topic-find-topology topic nil nil 'delete)))
 635
 636 (defun gnus-topic-rename (old-name new-name)
 637   "Rename a topic."
 638   (interactive
 639    (let (topic)
 640      (list
 641       (setq topic (completing-read "Rename topic: " gnus-topic-alist nil t))
 642       (read-string (format "Rename %s to: " topic)))))
 643   (let ((top (gnus-topic-find-topology old-name))
 644         (entry (assoc old-name gnus-topic-alist)))
 645     (when top
 646       (setcar (car (cdr top)) new-name))
 647     (when entry
 648       (setcar entry new-name))
 649     (gnus-group-list-groups)))
 650
 651 (defun gnus-topic-indent (&optional unindent)
 652   "Indent a topic -- make it a sub-topic of the previous topic.
 653 If UNINDENT, remove an indentation."
 654   (interactive "P")
 655   (if unindent
 656       (gnus-topic-unindent)
 657     (let* ((topic (gnus-group-parent-topic))
 658            (parent (gnus-topic-previous-topic topic)))
 659       (unless parent
 660         (error "Nothing to indent %s into" topic))
 661       (when topic
 662         (gnus-topic-goto-topic topic)
 663         (gnus-topic-kill-group)
 664         (gnus-topic-create-topic topic parent)))))
 665
 666 (defun gnus-topic-unindent ()
 667   "Unindent a topic."
 668   (interactive)
 669   (let* ((topic (gnus-group-parent-topic))
 670          (parent (gnus-topic-parent-topic topic))
 671          (grandparent (gnus-topic-parent-topic parent)))
 672     (unless grandparent
 673       (error "Nothing to indent %s into" topic))
 674     (when topic
 675       (gnus-topic-goto-topic topic)
 676       (gnus-topic-kill-group)
 677       (gnus-topic-create-topic topic grandparent))))
 678
 679 (provide 'gnus-topic)
 680
 681 ;;; gnus-topic.el ends here