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