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