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,96,97 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 (require 'gnus-group)
  31 (require 'gnus-start)
  32
  33 (defgroup gnus-topic nil
  34   "Group topics."
  35   :group 'gnus-group)
  36
  37 (defvar gnus-topic-mode nil
  38   "Minor mode for Gnus group buffers.")
  39
  40 (defcustom gnus-topic-mode-hook nil
  41   "Hook run in topic mode buffers."
  42   :type 'hook
  43   :group 'gnus-topic)
  44
  45 (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n"
  46   "Format of topic lines.
  47 It works along the same lines as a normal formatting string,
  48 with some simple extensions.
  49
  50 %i  Indentation based on topic level.
  51 %n  Topic name.
  52 %v  Nothing if the topic is visible, \"...\" otherwise.
  53 %g  Number of groups in the topic.
  54 %a  Number of unread articles in the groups in the topic.
  55 %A  Number of unread articles in the groups in the topic and its subtopics.
  56 "
  57   :type 'string
  58   :group 'gnus-topic)
  59
  60 (defcustom gnus-topic-indent-level 2
  61   "*How much each subtopic should be indented."
  62   :type 'integer
  63   :group 'gnus-topic)
  64
  65 (defcustom gnus-topic-display-empty-topics t
  66   "*If non-nil, display the topic lines even of topics that have no unread articles."
  67   :type 'boolean
  68   :group 'gnus-topic)
  69
  70 ;; Internal variables.
  71
  72 (defvar gnus-topic-active-topology nil)
  73 (defvar gnus-topic-active-alist nil)
  74
  75 (defvar gnus-topology-checked-p nil
  76   "Whether the topology has been checked in this session.")
  77
  78 (defvar gnus-topic-killed-topics nil)
  79 (defvar gnus-topic-inhibit-change-level nil)
  80
  81 (defconst gnus-topic-line-format-alist
  82   `((?n name ?s)
  83     (?v visible ?s)
  84     (?i indentation ?s)
  85     (?g number-of-groups ?d)
  86     (?a (gnus-topic-articles-in-topic entries) ?d)
  87     (?A total-number-of-articles ?d)
  88     (?l level ?d)))
  89
  90 (defvar gnus-topic-line-format-spec nil)
  91
  92 ;;; Utility functions
  93
  94 (defun gnus-group-topic-name ()
  95   "The name of the topic on the current line."
  96   (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic)))
  97     (and topic (symbol-name topic))))
  98
  99 (defun gnus-group-topic-level ()
 100   "The level of the topic on the current line."
 101   (get-text-property (gnus-point-at-bol) 'gnus-topic-level))
 102
 103 (defun gnus-group-topic-unread ()
 104   "The number of unread articles in topic on the current line."
 105   (get-text-property (gnus-point-at-bol) 'gnus-topic-unread))
 106
 107 (defun gnus-topic-unread (topic)
 108   "Return the number of unread articles in TOPIC."
 109   (or (save-excursion
 110         (and (gnus-topic-goto-topic topic)
 111              (gnus-group-topic-unread)))
 112       0))
 113
 114 (defun gnus-group-topic-p ()
 115   "Return non-nil if the current line is a topic."
 116   (gnus-group-topic-name))
 117
 118 (defun gnus-topic-visible-p ()
 119   "Return non-nil if the current topic is visible."
 120   (get-text-property (gnus-point-at-bol) 'gnus-topic-visible))
 121
 122 (defun gnus-topic-articles-in-topic (entries)
 123   (let ((total 0)
 124         number)
 125     (while entries
 126       (when (numberp (setq number (car (pop entries))))
 127         (incf total number)))
 128     total))
 129
 130 (defun gnus-group-topic (group)
 131   "Return the topic GROUP is a member of."
 132   (let ((alist gnus-topic-alist)
 133         out)
 134     (while alist
 135       (when (member group (cdar alist))
 136         (setq out (caar alist)
 137               alist nil))
 138       (setq alist (cdr alist)))
 139     out))
 140
 141 (defun gnus-group-parent-topic (group)
 142   "Return the topic GROUP is member of by looking at the group buffer."
 143   (save-excursion
 144     (set-buffer gnus-group-buffer)
 145     (if (gnus-group-goto-group group)
 146         (gnus-current-topic)
 147       (gnus-group-topic group))))
 148
 149 (defun gnus-topic-goto-topic (topic)
 150   "Go to TOPIC."
 151   (when topic
 152     (gnus-goto-char (text-property-any (point-min) (point-max)
 153                                        'gnus-topic (intern topic)))))
 154
 155 (defun gnus-current-topic ()
 156   "Return the name of the current topic."
 157   (let ((result
 158          (or (get-text-property (point) 'gnus-topic)
 159              (save-excursion
 160                (and (gnus-goto-char (previous-single-property-change
 161                                      (point) 'gnus-topic))
 162                     (get-text-property (max (1- (point)) (point-min))
 163                                        'gnus-topic))))))
 164     (when result
 165       (symbol-name result))))
 166
 167 (defun gnus-current-topics ()
 168   "Return a list of all current topics, lowest in hierarchy first."
 169   (let ((topic (gnus-current-topic))
 170         topics)
 171     (while topic
 172       (push topic topics)
 173       (setq topic (gnus-topic-parent-topic topic)))
 174     (nreverse topics)))
 175
 176 (defun gnus-group-active-topic-p ()
 177   "Say whether the current topic comes from the active topics."
 178   (save-excursion
 179     (beginning-of-line)
 180     (get-text-property (point) 'gnus-active)))
 181
 182 (defun gnus-topic-find-groups (topic &optional level all)
 183   "Return entries for all visible groups in TOPIC."
 184   (let ((groups (cdr (assoc topic gnus-topic-alist)))
 185         info clevel unread group lowest params visible-groups entry active)
 186     (setq lowest (or lowest 1))
 187     (setq level (or level 7))
 188     ;; We go through the newsrc to look for matches.
 189     (while groups
 190       (when (setq group (pop groups))
 191         (setq entry (gnus-gethash group gnus-newsrc-hashtb)
 192               info (nth 2 entry)
 193               params (gnus-info-params info)
 194               active (gnus-active group)
 195               unread (or (car entry)
 196                          (and (not (equal group "dummy.group"))
 197                               active
 198                               (- (1+ (cdr active)) (car active))))
 199               clevel (or (gnus-info-level info)
 200                          (if (member group gnus-zombie-list) 8 9))))
 201       (and
 202        unread                           ; nil means that the group is dead.
 203        (<= clevel level)
 204        (>= clevel lowest)               ; Is inside the level we want.
 205        (or all
 206            (if (eq unread t)
 207                gnus-group-list-inactive-groups
 208              (> unread 0))
 209            (and gnus-list-groups-with-ticked-articles
 210                 (cdr (assq 'tick (gnus-info-marks info))))
 211                                         ; Has right readedness.
 212            ;; Check for permanent visibility.
 213            (and gnus-permanently-visible-groups
 214                 (string-match gnus-permanently-visible-groups group))
 215            (memq 'visible params)
 216            (cdr (assq 'visible params)))
 217        ;; Add this group to the list of visible groups.
 218        (push (or entry group) visible-groups)))
 219     (nreverse visible-groups)))
 220
 221 (defun gnus-topic-previous-topic (topic)
 222   "Return the previous topic on the same level as TOPIC."
 223   (let ((top (cddr (gnus-topic-find-topology
 224                     (gnus-topic-parent-topic topic)))))
 225     (unless (equal topic (caaar top))
 226       (while (and top (not (equal (caaadr top) topic)))
 227         (setq top (cdr top)))
 228       (caaar top))))
 229
 230 (defun gnus-topic-parent-topic (topic &optional topology)
 231   "Return the parent of TOPIC."
 232   (unless topology
 233     (setq topology gnus-topic-topology))
 234   (let ((parent (car (pop topology)))
 235         result found)
 236     (while (and topology
 237                 (not (setq found (equal (caaar topology) topic)))
 238                 (not (setq result (gnus-topic-parent-topic
 239                                    topic (car topology)))))
 240       (setq topology (cdr topology)))
 241     (or result (and found parent))))
 242
 243 (defun gnus-topic-next-topic (topic &optional previous)
 244   "Return the next sibling of TOPIC."
 245   (let ((parentt (cddr (gnus-topic-find-topology
 246                         (gnus-topic-parent-topic topic))))
 247         prev)
 248     (while (and parentt
 249                 (not (equal (caaar parentt) topic)))
 250       (setq prev (caaar parentt)
 251             parentt (cdr parentt)))
 252     (if previous
 253         prev
 254       (caaadr parentt))))
 255
 256 (defun gnus-topic-forward-topic (num)
 257   "Go to the next topic on the same level as the current one."
 258   (let* ((topic (gnus-current-topic))
 259          (way (if (< num 0) 'gnus-topic-previous-topic
 260                 'gnus-topic-next-topic))
 261          (num (abs num)))
 262     (while (and (not (zerop num))
 263                 (setq topic (funcall way topic)))
 264       (when (gnus-topic-goto-topic topic)
 265         (decf num)))
 266     (unless (zerop num)
 267       (goto-char (point-max)))
 268     num))
 269
 270 (defun gnus-topic-find-topology (topic &optional topology level remove)
 271   "Return the topology of TOPIC."
 272   (unless topology
 273     (setq topology gnus-topic-topology)
 274     (setq level 0))
 275   (let ((top topology)
 276         result)
 277     (if (equal (caar topology) topic)
 278         (progn
 279           (when remove
 280             (delq topology remove))
 281           (cons level topology))
 282       (setq topology (cdr topology))
 283       (while (and topology
 284                   (not (setq result (gnus-topic-find-topology
 285                                      topic (car topology) (1+ level)
 286                                      (and remove top)))))
 287         (setq topology (cdr topology)))
 288       result)))
 289
 290 (defvar gnus-tmp-topics nil)
 291 (defun gnus-topic-list (&optional topology)
 292   "Return a list of all topics in the topology."
 293   (unless topology
 294     (setq topology gnus-topic-topology
 295           gnus-tmp-topics nil))
 296   (push (caar topology) gnus-tmp-topics)
 297   (mapcar 'gnus-topic-list (cdr topology))
 298   gnus-tmp-topics)
 299
 300 ;;; Topic parameter jazz
 301
 302 (defun gnus-topic-parameters (topic)
 303   "Return the parameters for TOPIC."
 304   (let ((top (gnus-topic-find-topology topic)))
 305     (when top
 306       (nth 3 (cadr top)))))
 307
 308 (defun gnus-topic-set-parameters (topic parameters)
 309   "Set the topic parameters of TOPIC to PARAMETERS."
 310   (let ((top (gnus-topic-find-topology topic)))
 311     (unless top
 312       (error "No such topic: %s" topic))
 313     ;; We may have to extend if there is no parameters here
 314     ;; to begin with.
 315     (unless (nthcdr 2 (cadr top))
 316       (nconc (cadr top) (list nil)))
 317     (unless (nthcdr 3 (cadr top))
 318       (nconc (cadr top) (list nil)))
 319     (setcar (nthcdr 3 (cadr top)) parameters)
 320     (gnus-dribble-enter
 321      (format "(gnus-topic-set-parameters %S '%S)" topic parameters))))
 322
 323 (defun gnus-group-topic-parameters (group)
 324   "Compute the group parameters for GROUP taking into account inheritance from topics."
 325   (let ((params-list (list (gnus-group-get-parameter group)))
 326         topics params param out)
 327     (save-excursion
 328       (gnus-group-goto-group group)
 329       (setq topics (gnus-current-topics))
 330       (while topics
 331         (push (gnus-topic-parameters (pop topics)) params-list))
 332       ;; We probably have lots of nil elements here, so
 333       ;; we remove them.  Probably faster than doing this "properly".
 334       (setq params-list (delq nil params-list))
 335       ;; Now we have all the parameters, so we go through them
 336       ;; and do inheritance in the obvious way.
 337       (while (setq params (pop params-list))
 338         (while (setq param (pop params))
 339           (when (atom param)
 340             (setq param (cons param t)))
 341           ;; Override any old versions of this param.
 342           (setq out (delq (assq (car param) out) out))
 343           (push param out)))
 344       ;; Return the resulting parameter list.
 345       out)))
 346
 347 ;;; General utility functions
 348
 349 (defun gnus-topic-enter-dribble ()
 350   (gnus-dribble-enter
 351    (format "(setq gnus-topic-topology '%S)" gnus-topic-topology)))
 352
 353 ;;; Generating group buffers
 354
 355 (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level)
 356   "List all newsgroups with unread articles of level LEVEL or lower, and
 357 use the `gnus-group-topics' to sort the groups.
 358 If ALL is non-nil, list groups that have no unread articles.
 359 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
 360   (set-buffer gnus-group-buffer)
 361   (let ((buffer-read-only nil)
 362         (lowest (or lowest 1)))
 363
 364     (when (or (not gnus-topic-alist)
 365               (not gnus-topology-checked-p))
 366       (gnus-topic-check-topology))
 367
 368     (unless list-topic
 369       (erase-buffer))
 370
 371     ;; List dead groups?
 372     (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie))
 373       (gnus-group-prepare-flat-list-dead
 374        (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
 375        gnus-level-zombie ?Z
 376        regexp))
 377
 378     (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))
 379       (gnus-group-prepare-flat-list-dead
 380        (setq gnus-killed-list (sort gnus-killed-list 'string<))
 381        gnus-level-killed ?K
 382        regexp))
 383
 384     ;; Use topics.
 385     (prog1
 386         (when (< lowest gnus-level-zombie)
 387           (if list-topic
 388               (let ((top (gnus-topic-find-topology list-topic)))
 389                 (gnus-topic-prepare-topic (cdr top) (car top)
 390                                           (or topic-level level) all))
 391             (gnus-topic-prepare-topic gnus-topic-topology 0
 392                                       (or topic-level level) all)))
 393
 394       (gnus-group-set-mode-line)
 395       (setq gnus-group-list-mode (cons level all))
 396       (run-hooks 'gnus-group-prepare-hook))))
 397
 398 (defun gnus-topic-prepare-topic (topicl level &optional list-level all silent)
 399   "Insert TOPIC into the group buffer.
 400 If SILENT, don't insert anything.  Return the number of unread
 401 articles in the topic and its subtopics."
 402   (let* ((type (pop topicl))
 403          (entries (gnus-topic-find-groups (car type) list-level all))
 404          (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
 405          (gnus-group-indentation
 406           (make-string (* gnus-topic-indent-level level) ? ))
 407          (beg (progn (beginning-of-line) (point)))
 408          (topicl (reverse topicl))
 409          (all-entries entries)
 410          (point-max (point-max))
 411          (unread 0)
 412          (topic (car type))
 413          info entry end active tick)
 414     ;; Insert any sub-topics.
 415     (while topicl
 416       (incf unread
 417             (gnus-topic-prepare-topic
 418              (pop topicl) (1+ level) list-level all
 419              (not visiblep))))
 420     (setq end (point))
 421     (goto-char beg)
 422     ;; Insert all the groups that belong in this topic.
 423     (while (setq entry (pop entries))
 424       (when visiblep
 425         (if (stringp entry)
 426             ;; Dead groups.
 427             (gnus-group-insert-group-line
 428              entry (if (member entry gnus-zombie-list) 8 9)
 429              nil (- (1+ (cdr (setq active (gnus-active entry))))
 430                     (car active))
 431              nil)
 432           ;; Living groups.
 433           (when (setq info (nth 2 entry))
 434             (gnus-group-insert-group-line
 435              (gnus-info-group info)
 436              (gnus-info-level info) (gnus-info-marks info)
 437              (car entry) (gnus-info-method info)))))
 438       (when (and (listp entry)
 439                  (numberp (car entry)))
 440         (incf unread (car entry)))
 441       (when (listp entry)
 442         (setq tick t)))
 443     (goto-char beg)
 444     ;; Insert the topic line.
 445     (when (and (not silent)
 446                (or gnus-topic-display-empty-topics ;We want empty topics
 447                    (not (zerop unread)) ;Non-empty
 448                    tick                 ;Ticked articles
 449                    (/= point-max (point-max)))) ;Unactivated groups
 450       (gnus-extent-start-open (point))
 451       (gnus-topic-insert-topic-line
 452        (car type) visiblep
 453        (not (eq (nth 2 type) 'hidden))
 454        level all-entries unread))
 455     (goto-char end)
 456     unread))
 457
 458 (defun gnus-topic-remove-topic (&optional insert total-remove hide in-level)
 459   "Remove the current topic."
 460   (let ((topic (gnus-group-topic-name))
 461         (level (gnus-group-topic-level))
 462         (beg (progn (beginning-of-line) (point)))
 463         buffer-read-only)
 464     (when topic
 465       (while (and (zerop (forward-line 1))
 466                   (> (or (gnus-group-topic-level) (1+ level)) level)))
 467       (delete-region beg (point))
 468       ;; Do the change in this rather odd manner because it has been
 469       ;; reported that some topics share parts of some lists, for some
 470       ;; reason.  I have been unable to determine why this is the
 471       ;; case, but this hack seems to take care of things.
 472       (let ((data (cadr (gnus-topic-find-topology topic))))
 473         (setcdr data
 474                 (list (if insert 'visible 'invisible)
 475                       (if hide 'hide nil)
 476                       (cadddr data))))
 477       (if total-remove
 478           (setq gnus-topic-alist
 479                 (delq (assoc topic gnus-topic-alist) gnus-topic-alist))
 480         (gnus-topic-insert-topic topic in-level)))))
 481
 482 (defun gnus-topic-insert-topic (topic &optional level)
 483   "Insert TOPIC."
 484   (gnus-group-prepare-topics
 485    (car gnus-group-list-mode) (cdr gnus-group-list-mode)
 486    nil nil topic level))
 487
 488 (defun gnus-topic-fold (&optional insert)
 489   "Remove/insert the current topic."
 490   (let ((topic (gnus-group-topic-name)))
 491     (when topic
 492       (save-excursion
 493         (if (not (gnus-group-active-topic-p))
 494             (gnus-topic-remove-topic
 495              (or insert (not (gnus-topic-visible-p))))
 496           (let ((gnus-topic-topology gnus-topic-active-topology)
 497                 (gnus-topic-alist gnus-topic-active-alist)
 498                 (gnus-group-list-mode (cons 5 t)))
 499             (gnus-topic-remove-topic
 500              (or insert (not (gnus-topic-visible-p))) nil nil 9)
 501             (gnus-topic-enter-dribble)))))))
 502
 503 (defun gnus-topic-insert-topic-line (name visiblep shownp level entries
 504                                           &optional unread)
 505   (let* ((visible (if visiblep "" "..."))
 506          (indentation (make-string (* gnus-topic-indent-level level) ? ))
 507          (total-number-of-articles unread)
 508          (number-of-groups (length entries))
 509          (active-topic (eq gnus-topic-alist gnus-topic-active-alist)))
 510     (beginning-of-line)
 511     ;; Insert the text.
 512     (gnus-add-text-properties
 513      (point)
 514      (prog1 (1+ (point))
 515        (eval gnus-topic-line-format-spec)
 516        (gnus-topic-remove-excess-properties)1)
 517      (list 'gnus-topic (intern name)
 518            'gnus-topic-level level
 519            'gnus-topic-unread unread
 520            'gnus-active active-topic
 521            'gnus-topic-visible visiblep))))
 522
 523 (defun gnus-topic-update-topics-containing-group (group)
 524   "Update all topics that have GROUP as a member."
 525   (when (and (eq major-mode 'gnus-group-mode)
 526              gnus-topic-mode)
 527     (save-excursion
 528       (let ((alist gnus-topic-alist))
 529         ;; This is probably not entirely correct.  If a topic
 530         ;; isn't shown, then it's not updated.  But the updating
 531         ;; should be performed in any case, since the topic's
 532         ;; parent should be updated.  Pfft.
 533         (while alist
 534           (when (and (member group (cdar alist))
 535                      (gnus-topic-goto-topic (caar alist)))
 536             (gnus-topic-update-topic-line (caar alist)))
 537           (pop alist))))))
 538
 539 (defun gnus-topic-update-topic ()
 540   "Update all parent topics to the current group."
 541   (when (and (eq major-mode 'gnus-group-mode)
 542              gnus-topic-mode)
 543     (let ((group (gnus-group-group-name))
 544           (m (point-marker))
 545           (buffer-read-only nil))
 546       (when (and group
 547                  (gnus-get-info group)
 548                  (gnus-topic-goto-topic (gnus-current-topic)))
 549         (gnus-topic-update-topic-line (gnus-group-topic-name))
 550         (goto-char m)
 551         (set-marker m nil)
 552         (gnus-group-position-point)))))
 553
 554 (defun gnus-topic-goto-missing-group (group)
 555   "Place point where GROUP is supposed to be inserted."
 556   (let* ((topic (gnus-group-topic group))
 557          (groups (cdr (assoc topic gnus-topic-alist)))
 558          (g (cdr (member group groups)))
 559          (unfound t))
 560     ;; Try to jump to a visible group.
 561     (while (and g (not (gnus-group-goto-group (car g) t)))
 562       (pop g))
 563     ;; It wasn't visible, so we try to see where to insert it.
 564     (when (not g)
 565       (setq g (cdr (member group (reverse groups))))
 566       (while (and g unfound)
 567         (when (gnus-group-goto-group (pop g) t)
 568           (forward-line 1)
 569           (setq unfound nil)))
 570       (when (and unfound
 571                  topic
 572                  (not (gnus-topic-goto-missing-topic topic)))
 573         (gnus-topic-insert-topic-line
 574          topic t t (car (gnus-topic-find-topology topic)) nil 0)))))
 575
 576 (defun gnus-topic-goto-missing-topic (topic)
 577   (if (gnus-topic-goto-topic topic)
 578       (forward-line 1)
 579     ;; Topic not displayed.
 580     (let* ((top (gnus-topic-find-topology
 581                  (gnus-topic-parent-topic topic)))
 582            (tp (reverse (cddr top))))
 583       (while (not (equal (caaar tp) topic))
 584         (setq tp (cdr tp)))
 585       (pop tp)
 586       (while (and tp
 587                   (not (gnus-topic-goto-topic (caaar tp))))
 588         (pop tp))
 589       (if tp
 590           (gnus-topic-forward-topic 1)
 591         (gnus-topic-goto-missing-topic (caadr top))))
 592     nil))
 593
 594 (defun gnus-topic-update-topic-line (topic-name &optional reads)
 595   (let* ((top (gnus-topic-find-topology topic-name))
 596          (type (cadr top))
 597          (children (cddr top))
 598          (entries (gnus-topic-find-groups
 599                    (car type) (car gnus-group-list-mode)
 600                    (cdr gnus-group-list-mode)))
 601          (parent (gnus-topic-parent-topic topic-name))
 602          (all-entries entries)
 603          (unread 0)
 604          old-unread entry)
 605     (when (gnus-topic-goto-topic (car type))
 606       ;; Tally all the groups that belong in this topic.
 607       (if reads
 608           (setq unread (- (gnus-group-topic-unread) reads))
 609         (while children
 610           (incf unread (gnus-topic-unread (caar (pop children)))))
 611         (while (setq entry (pop entries))
 612           (when (numberp (car entry))
 613             (incf unread (car entry)))))
 614       (setq old-unread (gnus-group-topic-unread))
 615       ;; Insert the topic line.
 616       (gnus-topic-insert-topic-line
 617        (car type) (gnus-topic-visible-p)
 618        (not (eq (nth 2 type) 'hidden))
 619        (gnus-group-topic-level) all-entries unread)
 620       (gnus-delete-line))
 621     (when parent
 622       (forward-line -1)
 623       (gnus-topic-update-topic-line
 624        parent (- old-unread (gnus-group-topic-unread))))
 625     unread))
 626
 627 (defun gnus-topic-group-indentation ()
 628   (make-string
 629    (* gnus-topic-indent-level
 630       (or (save-excursion
 631             (forward-line -1)
 632             (gnus-topic-goto-topic (gnus-current-topic))
 633             (gnus-group-topic-level))
 634           0))
 635    ? ))
 636
 637 ;;; Initialization
 638
 639 (gnus-add-shutdown 'gnus-topic-close 'gnus)
 640
 641 (defun gnus-topic-close ()
 642   (setq gnus-topic-active-topology nil
 643         gnus-topic-active-alist nil
 644         gnus-topic-killed-topics nil
 645         gnus-topology-checked-p nil))
 646
 647 (defun gnus-topic-check-topology ()
 648   ;; The first time we set the topology to whatever we have
 649   ;; gotten here, which can be rather random.
 650   (unless gnus-topic-alist
 651     (gnus-topic-init-alist))
 652
 653   (setq gnus-topology-checked-p t)
 654   ;; Go through the topic alist and make sure that all topics
 655   ;; are in the topic topology.
 656   (let ((topics (gnus-topic-list))
 657         (alist gnus-topic-alist)
 658         changed)
 659     (while alist
 660       (unless (member (caar alist) topics)
 661         (nconc gnus-topic-topology
 662                (list (list (list (caar alist) 'visible))))
 663         (setq changed t))
 664       (setq alist (cdr alist)))
 665     (when changed
 666       (gnus-topic-enter-dribble))
 667     ;; Conversely, go through the topology and make sure that all
 668     ;; topologies have alists.
 669     (while topics
 670       (unless (assoc (car topics) gnus-topic-alist)
 671         (push (list (car topics)) gnus-topic-alist))
 672       (pop topics)))
 673   ;; Go through all living groups and make sure that
 674   ;; they belong to some topic.
 675   (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry))
 676                                          gnus-topic-alist)))
 677          (entry (assoc (caar gnus-topic-topology) gnus-topic-alist))
 678          (newsrc (cdr gnus-newsrc-alist))
 679          group)
 680     (while newsrc
 681       (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)
 682         (setcdr entry (cons group (cdr entry))))))
 683   ;; Go through all topics and make sure they contain only living groups.
 684   (let ((alist gnus-topic-alist)
 685         topic)
 686     (while (setq topic (pop alist))
 687       (while (cdr topic)
 688         (if (gnus-gethash (cadr topic) gnus-newsrc-hashtb)
 689             (setq topic (cdr topic))
 690           (setcdr topic (cddr topic)))))))
 691
 692 (defun gnus-topic-init-alist ()
 693   "Initialize the topic structures."
 694   (setq gnus-topic-topology
 695         (cons (list "Gnus" 'visible)
 696               (mapcar (lambda (topic)
 697                         (list (list (car topic) 'visible)))
 698                       '(("misc")))))
 699   (setq gnus-topic-alist
 700         (list (cons "misc"
 701                     (mapcar (lambda (info) (gnus-info-group info))
 702                             (cdr gnus-newsrc-alist)))
 703               (list "Gnus")))
 704   (gnus-topic-enter-dribble))
 705
 706 ;;; Maintenance
 707
 708 (defun gnus-topic-clean-alist ()
 709   "Remove bogus groups from the topic alist."
 710   (let ((topic-alist gnus-topic-alist)
 711         result topic)
 712     (unless gnus-killed-hashtb
 713       (gnus-make-hashtable-from-killed))
 714     (while (setq topic (pop topic-alist))
 715       (let ((topic-name (pop topic))
 716             group filtered-topic)
 717         (while (setq group (pop topic))
 718           (when (and (or (gnus-gethash group gnus-active-hashtb)
 719                          (gnus-info-method (gnus-get-info group)))
 720                      (not (gnus-gethash group gnus-killed-hashtb)))
 721             (push group filtered-topic)))
 722         (push (cons topic-name (nreverse filtered-topic)) result)))
 723     (setq gnus-topic-alist (nreverse result))))
 724
 725 (defun gnus-topic-change-level (group level oldlevel)
 726   "Run when changing levels to enter/remove groups from topics."
 727   (save-excursion
 728     (set-buffer gnus-group-buffer)
 729     (when (and gnus-topic-mode
 730                gnus-topic-alist
 731                (not gnus-topic-inhibit-change-level))
 732       ;; Remove the group from the topics.
 733       (when (and (< oldlevel gnus-level-zombie)
 734                  (>= level gnus-level-zombie))
 735         (let (alist)
 736           (forward-line -1)
 737           (when (setq alist (assoc (gnus-current-topic) gnus-topic-alist))
 738             (setcdr alist (gnus-delete-first group (cdr alist))))))
 739       ;; If the group is subscribed we enter it into the topics.
 740       (when (and (< level gnus-level-zombie)
 741                  (>= oldlevel gnus-level-zombie))
 742         (let* ((prev (gnus-group-group-name))
 743                (gnus-topic-inhibit-change-level t)
 744                (gnus-group-indentation
 745                 (make-string
 746                  (* gnus-topic-indent-level
 747                     (or (save-excursion
 748                           (gnus-topic-goto-topic (gnus-current-topic))
 749                           (gnus-group-topic-level))
 750                         0))
 751                  ? ))
 752                (yanked (list group))
 753                alist talist end)
 754           ;; Then we enter the yanked groups into the topics they belong
 755           ;; to.
 756           (when (setq alist (assoc (save-excursion
 757                                      (forward-line -1)
 758                                      (or
 759                                       (gnus-current-topic)
 760                                       (caar gnus-topic-topology)))
 761                                    gnus-topic-alist))
 762             (setq talist alist)
 763             (when (stringp yanked)
 764               (setq yanked (list yanked)))
 765             (if (not prev)
 766                 (nconc alist yanked)
 767               (if (not (cdr alist))
 768                   (setcdr alist (nconc yanked (cdr alist)))
 769                 (while (and (not end) (cdr alist))
 770                   (when (equal (cadr alist) prev)
 771                     (setcdr alist (nconc yanked (cdr alist)))
 772                     (setq end t))
 773                   (setq alist (cdr alist)))
 774                 (unless end
 775                   (nconc talist yanked))))))
 776         (gnus-topic-update-topic)))))
 777
 778 (defun gnus-topic-goto-next-group (group props)
 779   "Go to group or the next group after group."
 780   (if (not group)
 781       (if (not (memq 'gnus-topic props))
 782           (goto-char (point-max))
 783         (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props)))))
 784     (if (gnus-group-goto-group group)
 785         t
 786       ;; The group is no longer visible.
 787       (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist))
 788              (after (cdr (member group (cdr list)))))
 789         ;; First try to put point on a group after the current one.
 790         (while (and after
 791                     (not (gnus-group-goto-group (car after))))
 792           (setq after (cdr after)))
 793         ;; Then try to put point on a group before point.
 794         (unless after
 795           (setq after (cdr (member group (reverse (cdr list)))))
 796           (while (and after
 797                       (not (gnus-group-goto-group (car after))))
 798             (setq after (cdr after))))
 799         ;; Finally, just put point on the topic.
 800         (if (not (car list))
 801             (goto-char (point-min))
 802           (unless after
 803             (gnus-topic-goto-topic (car list))
 804             (setq after nil)))
 805         t))))
 806
 807 ;;; Topic-active functions
 808
 809 (defun gnus-topic-grok-active (&optional force)
 810   "Parse all active groups and create topic structures for them."
 811   ;; First we make sure that we have really read the active file.
 812   (when (or force
 813             (not gnus-topic-active-alist))
 814     (let (groups)
 815       ;; Get a list of all groups available.
 816       (mapatoms (lambda (g) (when (symbol-value g)
 817                               (push (symbol-name g) groups)))
 818                 gnus-active-hashtb)
 819       (setq groups (sort groups 'string<))
 820       ;; Init the variables.
 821       (setq gnus-topic-active-topology (list (list "" 'visible)))
 822       (setq gnus-topic-active-alist nil)
 823       ;; Descend the top-level hierarchy.
 824       (gnus-topic-grok-active-1 gnus-topic-active-topology groups)
 825       ;; Set the top-level topic names to something nice.
 826       (setcar (car gnus-topic-active-topology) "Gnus active")
 827       (setcar (car gnus-topic-active-alist) "Gnus active"))))
 828
 829 (defun gnus-topic-grok-active-1 (topology groups)
 830   (let* ((name (caar topology))
 831          (prefix (concat "^" (regexp-quote name)))
 832          tgroups ntopology group)
 833     (while (and groups
 834                 (string-match prefix (setq group (car groups))))
 835       (if (not (string-match "\\." group (match-end 0)))
 836           ;; There are no further hierarchies here, so we just
 837           ;; enter this group into the list belonging to this
 838           ;; topic.
 839           (push (pop groups) tgroups)
 840         ;; New sub-hierarchy, so we add it to the topology.
 841         (nconc topology (list (setq ntopology
 842                                     (list (list (substring
 843                                                  group 0 (match-end 0))
 844                                                 'invisible)))))
 845         ;; Descend the hierarchy.
 846         (setq groups (gnus-topic-grok-active-1 ntopology groups))))
 847     ;; We remove the trailing "." from the topic name.
 848     (setq name
 849           (if (string-match "\\.$" name)
 850               (substring name 0 (match-beginning 0))
 851             name))
 852     ;; Add this topic and its groups to the topic alist.
 853     (push (cons name (nreverse tgroups)) gnus-topic-active-alist)
 854     (setcar (car topology) name)
 855     ;; We return the rest of the groups that didn't belong
 856     ;; to this topic.
 857     groups))
 858
 859 ;;; Topic mode, commands and keymap.
 860
 861 (defvar gnus-topic-mode-map nil)
 862 (defvar gnus-group-topic-map nil)
 863
 864 (unless gnus-topic-mode-map
 865   (setq gnus-topic-mode-map (make-sparse-keymap))
 866
 867   ;; Override certain group mode keys.
 868   (gnus-define-keys gnus-topic-mode-map
 869     "=" gnus-topic-select-group
 870     "\r" gnus-topic-select-group
 871     " " gnus-topic-read-group
 872     "\C-k" gnus-topic-kill-group
 873     "\C-y" gnus-topic-yank-group
 874     "\M-g" gnus-topic-get-new-news-this-topic
 875     "AT" gnus-topic-list-active
 876     "Gp" gnus-topic-edit-parameters
 877     "#" gnus-topic-mark-topic
 878     "\M-#" gnus-topic-unmark-topic
 879     gnus-mouse-2 gnus-mouse-pick-topic)
 880
 881   ;; Define a new submap.
 882   (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map)
 883     "#" gnus-topic-mark-topic
 884     "\M-#" gnus-topic-unmark-topic
 885     "n" gnus-topic-create-topic
 886     "m" gnus-topic-move-group
 887     "D" gnus-topic-remove-group
 888     "c" gnus-topic-copy-group
 889     "h" gnus-topic-hide-topic
 890     "s" gnus-topic-show-topic
 891     "M" gnus-topic-move-matching
 892     "C" gnus-topic-copy-matching
 893     "\C-i" gnus-topic-indent
 894     [tab] gnus-topic-indent
 895     "r" gnus-topic-rename
 896     "\177" gnus-topic-delete
 897     "h" gnus-topic-toggle-display-empty-topics)
 898
 899   (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map)
 900     "s" gnus-topic-sort-groups
 901     "a" gnus-topic-sort-groups-by-alphabet
 902     "u" gnus-topic-sort-groups-by-unread
 903     "l" gnus-topic-sort-groups-by-level
 904     "v" gnus-topic-sort-groups-by-score
 905     "r" gnus-topic-sort-groups-by-rank
 906     "m" gnus-topic-sort-groups-by-method))
 907
 908 (defun gnus-topic-make-menu-bar ()
 909   (unless (boundp 'gnus-topic-menu)
 910     (easy-menu-define
 911      gnus-topic-menu gnus-topic-mode-map ""
 912      '("Topics"
 913        ["Toggle topics" gnus-topic-mode t]
 914        ("Groups"
 915         ["Copy" gnus-topic-copy-group t]
 916         ["Move" gnus-topic-move-group t]
 917         ["Remove" gnus-topic-remove-group t]
 918         ["Copy matching" gnus-topic-copy-matching t]
 919         ["Move matching" gnus-topic-move-matching t])
 920        ("Topics"
 921         ["Show" gnus-topic-show-topic t]
 922         ["Hide" gnus-topic-hide-topic t]
 923         ["Delete" gnus-topic-delete t]
 924         ["Rename" gnus-topic-rename t]
 925         ["Create" gnus-topic-create-topic t]
 926         ["Mark" gnus-topic-mark-topic t]
 927         ["Indent" gnus-topic-indent t]
 928         ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t])
 929        ["List active" gnus-topic-list-active t]))))
 930
 931 (defun gnus-topic-mode (&optional arg redisplay)
 932   "Minor mode for topicsifying Gnus group buffers."
 933   (interactive (list current-prefix-arg t))
 934   (when (eq major-mode 'gnus-group-mode)
 935     (make-local-variable 'gnus-topic-mode)
 936     (setq gnus-topic-mode
 937           (if (null arg) (not gnus-topic-mode)
 938             (> (prefix-numeric-value arg) 0)))
 939     ;; Infest Gnus with topics.
 940     (if (not gnus-topic-mode)
 941         (setq gnus-goto-missing-group-function nil)
 942       (when (gnus-visual-p 'topic-menu 'menu)
 943         (gnus-topic-make-menu-bar))
 944       (setq gnus-topic-line-format-spec
 945             (gnus-parse-format gnus-topic-line-format
 946                                gnus-topic-line-format-alist t))
 947       (unless (assq 'gnus-topic-mode minor-mode-alist)
 948         (push '(gnus-topic-mode " Topic") minor-mode-alist))
 949       (unless (assq 'gnus-topic-mode minor-mode-map-alist)
 950         (push (cons 'gnus-topic-mode gnus-topic-mode-map)
 951               minor-mode-map-alist))
 952       (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
 953       (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
 954       (set (make-local-variable 'gnus-group-prepare-function)
 955            'gnus-group-prepare-topics)
 956       (set (make-local-variable 'gnus-group-get-parameter-function)
 957            'gnus-group-topic-parameters)
 958       (set (make-local-variable 'gnus-group-goto-next-group-function)
 959            'gnus-topic-goto-next-group)
 960       (set (make-local-variable 'gnus-group-indentation-function)
 961            'gnus-topic-group-indentation)
 962       (set (make-local-variable 'gnus-group-update-group-function)
 963            'gnus-topic-update-topics-containing-group)
 964       (set (make-local-variable 'gnus-group-sort-alist-function)
 965            'gnus-group-sort-topic)
 966       (setq gnus-group-change-level-function 'gnus-topic-change-level)
 967       (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group)
 968       (make-local-hook 'gnus-check-bogus-groups-hook)
 969       (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist)
 970       (setq gnus-topology-checked-p nil)
 971       ;; We check the topology.
 972       (when gnus-newsrc-alist
 973         (gnus-topic-check-topology))
 974       (run-hooks 'gnus-topic-mode-hook))
 975     ;; Remove topic infestation.
 976     (unless gnus-topic-mode
 977       (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
 978       (remove-hook 'gnus-group-change-level-function
 979                    'gnus-topic-change-level)
 980       (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist)
 981       (setq gnus-group-prepare-function 'gnus-group-prepare-flat)
 982       (setq gnus-group-sort-alist-function 'gnus-group-sort-flat))
 983     (when redisplay
 984       (gnus-group-list-groups))))
 985
 986 (defun gnus-topic-select-group (&optional all)
 987   "Select this newsgroup.
 988 No article is selected automatically.
 989 If ALL is non-nil, already read articles become readable.
 990 If ALL is a number, fetch this number of articles.
 991
 992 If performed over a topic line, toggle folding the topic."
 993   (interactive "P")
 994   (if (gnus-group-topic-p)
 995       (let ((gnus-group-list-mode
 996              (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
 997         (gnus-topic-fold all))
 998     (gnus-group-select-group all)))
 999
1000 (defun gnus-mouse-pick-topic (e)
1001   "Select the group or topic under the mouse pointer."
1002   (interactive "e")
1003   (mouse-set-point e)
1004   (gnus-topic-read-group nil))
1005
1006 (defun gnus-topic-read-group (&optional all no-article group)
1007   "Read news in this newsgroup.
1008 If the prefix argument ALL is non-nil, already read articles become
1009 readable.  IF ALL is a number, fetch this number of articles.  If the
1010 optional argument NO-ARTICLE is non-nil, no article will be
1011 auto-selected upon group entry.  If GROUP is non-nil, fetch that
1012 group.
1013
1014 If performed over a topic line, toggle folding the topic."
1015   (interactive "P")
1016   (if (gnus-group-topic-p)
1017       (let ((gnus-group-list-mode
1018              (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
1019         (gnus-topic-fold all))
1020     (gnus-group-read-group all no-article group)))
1021
1022 (defun gnus-topic-create-topic (topic parent &optional previous full-topic)
1023   "Create a new TOPIC under PARENT.
1024 When used interactively, PARENT will be the topic under point."
1025   (interactive
1026    (list
1027     (read-string "New topic: ")
1028     (gnus-current-topic)))
1029   ;; Check whether this topic already exists.
1030   (when (gnus-topic-find-topology topic)
1031     (error "Topic already exists"))
1032   (unless parent
1033     (setq parent (caar gnus-topic-topology)))
1034   (let ((top (cdr (gnus-topic-find-topology parent)))
1035         (full-topic (or full-topic `((,topic visible)))))
1036     (unless top
1037       (error "No such parent topic: %s" parent))
1038     (if previous
1039         (progn
1040           (while (and (cdr top)
1041                       (not (equal (caaadr top) previous)))
1042             (setq top (cdr top)))
1043           (setcdr top (cons full-topic (cdr top))))
1044       (nconc top (list full-topic)))
1045     (unless (assoc topic gnus-topic-alist)
1046       (push (list topic) gnus-topic-alist)))
1047   (gnus-topic-enter-dribble)
1048   (gnus-group-list-groups)
1049   (gnus-topic-goto-topic topic))
1050
1051 (defun gnus-topic-move-group (n topic &optional copyp)
1052   "Move the next N groups to TOPIC.
1053 If COPYP, copy the groups instead."
1054   (interactive
1055    (list current-prefix-arg
1056          (completing-read "Move to topic: " gnus-topic-alist nil t)))
1057   (let ((groups (gnus-group-process-prefix n))
1058         (topicl (assoc topic gnus-topic-alist))
1059         (start-group (progn (forward-line 1) (gnus-group-group-name)))
1060         (start-topic (gnus-group-topic-name))
1061         entry)
1062     (mapcar
1063      (lambda (g)
1064        (gnus-group-remove-mark g)
1065        (when (and
1066               (setq entry (assoc (gnus-current-topic) gnus-topic-alist))
1067               (not copyp))
1068          (setcdr entry (gnus-delete-first g (cdr entry))))
1069        (nconc topicl (list g)))
1070      groups)
1071     (gnus-topic-enter-dribble)
1072     (if start-group
1073         (gnus-group-goto-group start-group)
1074       (gnus-topic-goto-topic start-topic))
1075     (gnus-group-list-groups)))
1076
1077 (defun gnus-topic-remove-group (&optional arg)
1078   "Remove the current group from the topic."
1079   (interactive "P")
1080   (gnus-group-iterate arg
1081     (lambda (group)
1082       (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
1083             (buffer-read-only nil))
1084         (when (and topicl group)
1085           (gnus-delete-line)
1086           (gnus-delete-first group topicl))
1087         (gnus-topic-update-topic)
1088         (gnus-group-position-point)))))
1089
1090 (defun gnus-topic-copy-group (n topic)
1091   "Copy the current group to a topic."
1092   (interactive
1093    (list current-prefix-arg
1094          (completing-read "Copy to topic: " gnus-topic-alist nil t)))
1095   (gnus-topic-move-group n topic t))
1096
1097 (defun gnus-topic-kill-group (&optional n discard)
1098   "Kill the next N groups."
1099   (interactive "P")
1100   (if (gnus-group-topic-p)
1101       (let ((topic (gnus-group-topic-name)))
1102         (push (cons
1103                (gnus-topic-find-topology topic)
1104                (assoc topic gnus-topic-alist))
1105               gnus-topic-killed-topics)
1106         (gnus-topic-remove-topic nil t)
1107         (gnus-topic-find-topology topic nil nil gnus-topic-topology)
1108         (gnus-topic-enter-dribble))
1109     (gnus-group-kill-group n discard)
1110     (gnus-topic-update-topic)))
1111
1112 (defun gnus-topic-yank-group (&optional arg)
1113   "Yank the last topic."
1114   (interactive "p")
1115   (if gnus-topic-killed-topics
1116       (let* ((previous
1117               (or (gnus-group-topic-name)
1118                   (gnus-topic-next-topic (gnus-current-topic))))
1119              (data (pop gnus-topic-killed-topics))
1120              (alist (cdr data))
1121              (item (cdar data)))
1122         (push alist gnus-topic-alist)
1123         (gnus-topic-create-topic
1124          (caar item) (gnus-topic-parent-topic previous) previous
1125          item)
1126         (gnus-topic-enter-dribble)
1127         (gnus-topic-goto-topic (caar item)))
1128     (let* ((prev (gnus-group-group-name))
1129            (gnus-topic-inhibit-change-level t)
1130            (gnus-group-indentation
1131             (make-string
1132              (* gnus-topic-indent-level
1133                 (or (save-excursion
1134                       (gnus-topic-goto-topic (gnus-current-topic))
1135                       (gnus-group-topic-level))
1136                     0))
1137              ? ))
1138            yanked alist)
1139       ;; We first yank the groups the normal way...
1140       (setq yanked (gnus-group-yank-group arg))
1141       ;; Then we enter the yanked groups into the topics they belong
1142       ;; to.
1143       (setq alist (assoc (save-excursion
1144                            (forward-line -1)
1145                            (gnus-current-topic))
1146                          gnus-topic-alist))
1147       (when (stringp yanked)
1148         (setq yanked (list yanked)))
1149       (if (not prev)
1150           (nconc alist yanked)
1151         (if (not (cdr alist))
1152             (setcdr alist (nconc yanked (cdr alist)))
1153           (while (cdr alist)
1154             (when (equal (cadr alist) prev)
1155               (setcdr alist (nconc yanked (cdr alist)))
1156               (setq alist nil))
1157             (setq alist (cdr alist))))))
1158     (gnus-topic-update-topic)))
1159
1160 (defun gnus-topic-hide-topic ()
1161   "Hide the current topic."
1162   (interactive)
1163   (when (gnus-current-topic)
1164     (gnus-topic-goto-topic (gnus-current-topic))
1165     (gnus-topic-remove-topic nil nil 'hidden)))
1166
1167 (defun gnus-topic-show-topic ()
1168   "Show the hidden topic."
1169   (interactive)
1170   (when (gnus-group-topic-p)
1171     (gnus-topic-remove-topic t nil 'shown)))
1172
1173 (defun gnus-topic-mark-topic (topic &optional unmark)
1174   "Mark all groups in the topic with the process mark."
1175   (interactive (list (gnus-group-topic-name)))
1176   (if (not topic)
1177       (call-interactively 'gnus-group-mark-group)
1178     (save-excursion
1179       (let ((groups (gnus-topic-find-groups topic 9 t)))
1180         (while groups
1181           (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
1182                    (gnus-info-group (nth 2 (pop groups)))))))))
1183
1184 (defun gnus-topic-unmark-topic (topic &optional unmark)
1185   "Remove the process mark from all groups in the topic."
1186   (interactive (list (gnus-group-topic-name)))
1187   (if (not topic)
1188       (call-interactively 'gnus-group-unmark-group)
1189     (gnus-topic-mark-topic topic t)))
1190
1191 (defun gnus-topic-get-new-news-this-topic (&optional n)
1192   "Check for new news in the current topic."
1193   (interactive "P")
1194   (if (not (gnus-group-topic-p))
1195       (gnus-group-get-new-news-this-group n)
1196     (gnus-topic-mark-topic (gnus-group-topic-name))
1197     (gnus-group-get-new-news-this-group)))
1198
1199 (defun gnus-topic-move-matching (regexp topic &optional copyp)
1200   "Move all groups that match REGEXP to some topic."
1201   (interactive
1202    (let (topic)
1203      (nreverse
1204       (list
1205        (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t))
1206        (read-string (format "Move to %s (regexp): " topic))))))
1207   (gnus-group-mark-regexp regexp)
1208   (gnus-topic-move-group nil topic copyp))
1209
1210 (defun gnus-topic-copy-matching (regexp topic &optional copyp)
1211   "Copy all groups that match REGEXP to some topic."
1212   (interactive
1213    (let (topic)
1214      (nreverse
1215       (list
1216        (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t))
1217        (read-string (format "Copy to %s (regexp): " topic))))))
1218   (gnus-topic-move-matching regexp topic t))
1219
1220 (defun gnus-topic-delete (topic)
1221   "Delete a topic."
1222   (interactive (list (gnus-group-topic-name)))
1223   (unless topic
1224     (error "No topic to be deleted"))
1225   (let ((entry (assoc topic gnus-topic-alist))
1226         (buffer-read-only nil))
1227     (when (cdr entry)
1228       (error "Topic not empty"))
1229     ;; Delete if visible.
1230     (when (gnus-topic-goto-topic topic)
1231       (gnus-delete-line))
1232     ;; Remove from alist.
1233     (setq gnus-topic-alist (delq entry gnus-topic-alist))
1234     ;; Remove from topology.
1235     (gnus-topic-find-topology topic nil nil 'delete)))
1236
1237 (defun gnus-topic-rename (old-name new-name)
1238   "Rename a topic."
1239   (interactive
1240    (let ((topic (gnus-current-topic)))
1241      (list topic
1242            (read-string (format "Rename %s to: " topic)))))
1243   (let ((top (gnus-topic-find-topology old-name))
1244         (entry (assoc old-name gnus-topic-alist)))
1245     (when top
1246       (setcar (cadr top) new-name))
1247     (when entry
1248       (setcar entry new-name))
1249     (forward-line -1)
1250     (gnus-dribble-touch)
1251     (gnus-group-list-groups)))
1252
1253 (defun gnus-topic-indent (&optional unindent)
1254   "Indent a topic -- make it a sub-topic of the previous topic.
1255 If UNINDENT, remove an indentation."
1256   (interactive "P")
1257   (if unindent
1258       (gnus-topic-unindent)
1259     (let* ((topic (gnus-current-topic))
1260            (parent (gnus-topic-previous-topic topic))
1261            (buffer-read-only nil))
1262       (unless parent
1263         (error "Nothing to indent %s into" topic))
1264       (when topic
1265         (gnus-topic-goto-topic topic)
1266         (gnus-topic-kill-group)
1267         (push (cdar gnus-topic-killed-topics) gnus-topic-alist)
1268         (gnus-topic-create-topic
1269          topic parent nil (cdaar gnus-topic-killed-topics))
1270         (pop gnus-topic-killed-topics)
1271         (or (gnus-topic-goto-topic topic)
1272             (gnus-topic-goto-topic parent))))))
1273
1274 (defun gnus-topic-unindent ()
1275   "Unindent a topic."
1276   (interactive)
1277   (let* ((topic (gnus-current-topic))
1278          (parent (gnus-topic-parent-topic topic))
1279          (grandparent (gnus-topic-parent-topic parent)))
1280     (unless grandparent
1281       (error "Nothing to indent %s into" topic))
1282     (when topic
1283       (gnus-topic-goto-topic topic)
1284       (gnus-topic-kill-group)
1285       (push (cdar gnus-topic-killed-topics) gnus-topic-alist)
1286       (gnus-topic-create-topic
1287        topic grandparent (gnus-topic-next-topic parent)
1288        (cdaar gnus-topic-killed-topics))
1289       (pop gnus-topic-killed-topics)
1290       (gnus-topic-goto-topic topic))))
1291
1292 (defun gnus-topic-list-active (&optional force)
1293   "List all groups that Gnus knows about in a topicsified fashion.
1294 If FORCE, always re-read the active file."
1295   (interactive "P")
1296   (when force
1297     (gnus-get-killed-groups))
1298   (gnus-topic-grok-active force)
1299   (let ((gnus-topic-topology gnus-topic-active-topology)
1300         (gnus-topic-alist gnus-topic-active-alist)
1301         gnus-killed-list gnus-zombie-list)
1302     (gnus-group-list-groups 9 nil 1)))
1303
1304 (defun gnus-topic-toggle-display-empty-topics ()
1305   "Show/hide topics that have no unread articles."
1306   (interactive)
1307   (setq gnus-topic-display-empty-topics
1308         (not gnus-topic-display-empty-topics))
1309   (message "%s empty topics"
1310            (if gnus-topic-display-empty-topics
1311                "Showing" "Hiding")))
1312
1313 ;;; Topic sorting functions
1314
1315 (defun gnus-topic-edit-parameters (group)
1316   "Edit the group parameters of GROUP.
1317 If performed on a topic, edit the topic parameters instead."
1318   (interactive (list (gnus-group-group-name)))
1319   (if group
1320       (gnus-group-edit-group-parameters group)
1321     (if (not (gnus-group-topic-p))
1322         (error "Nothing to edit on the current line.")
1323       (let ((topic (gnus-group-topic-name)))
1324         (gnus-edit-form
1325          (gnus-topic-parameters topic)
1326          (format "Editing the topic parameters for `%s'."
1327                  (or group topic))
1328          `(lambda (form)
1329             (gnus-topic-set-parameters ,topic form)))))))
1330
1331 (defun gnus-group-sort-topic (func reverse)
1332   "Sort groups in the topics according to FUNC and REVERSE."
1333   (let ((alist gnus-topic-alist))
1334     (while alist
1335       ;; !!!Sometimes nil elements sneak into the alist,
1336       ;; for some reason or other.
1337       (setcar alist (delq nil (car alist)))
1338       (setcar alist (delete "dummy.group" (car alist)))
1339       (gnus-topic-sort-topic (pop alist) func reverse))))
1340
1341 (defun gnus-topic-sort-topic (topic func reverse)
1342   ;; Each topic only lists the name of the group, while
1343   ;; the sort predicates expect group infos as inputs.
1344   ;; So we first transform the group names into infos,
1345   ;; then sort, and then transform back into group names.
1346   (setcdr
1347    topic
1348    (mapcar
1349     (lambda (info) (gnus-info-group info))
1350     (sort
1351      (mapcar
1352       (lambda (group) (gnus-get-info group))
1353       (cdr topic))
1354      func)))
1355   ;; Do the reversal, if necessary.
1356   (when reverse
1357     (setcdr topic (nreverse (cdr topic)))))
1358
1359 (defun gnus-topic-sort-groups (func &optional reverse)
1360   "Sort the current topic according to FUNC.
1361 If REVERSE, reverse the sorting order."
1362   (interactive (list gnus-group-sort-function current-prefix-arg))
1363   (let ((topic (assoc (gnus-current-topic) gnus-topic-alist)))
1364     (gnus-topic-sort-topic
1365      topic (gnus-make-sort-function func) reverse)
1366     (gnus-group-list-groups)))
1367
1368 (defun gnus-topic-sort-groups-by-alphabet (&optional reverse)
1369   "Sort the current topic alphabetically by group name.
1370 If REVERSE, sort in reverse order."
1371   (interactive "P")
1372   (gnus-topic-sort-groups 'gnus-group-sort-by-alphabet reverse))
1373
1374 (defun gnus-topic-sort-groups-by-unread (&optional reverse)
1375   "Sort the current topic by number of unread articles.
1376 If REVERSE, sort in reverse order."
1377   (interactive "P")
1378   (gnus-topic-sort-groups 'gnus-group-sort-by-unread reverse))
1379
1380 (defun gnus-topic-sort-groups-by-level (&optional reverse)
1381   "Sort the current topic by group level.
1382 If REVERSE, sort in reverse order."
1383   (interactive "P")
1384   (gnus-topic-sort-groups 'gnus-group-sort-by-level reverse))
1385
1386 (defun gnus-topic-sort-groups-by-score (&optional reverse)
1387   "Sort the current topic by group score.
1388 If REVERSE, sort in reverse order."
1389   (interactive "P")
1390   (gnus-topic-sort-groups 'gnus-group-sort-by-score reverse))
1391
1392 (defun gnus-topic-sort-groups-by-rank (&optional reverse)
1393   "Sort the current topic by group rank.
1394 If REVERSE, sort in reverse order."
1395   (interactive "P")
1396   (gnus-topic-sort-groups 'gnus-group-sort-by-rank reverse))
1397
1398 (defun gnus-topic-sort-groups-by-method (&optional reverse)
1399   "Sort the current topic alphabetically by backend name.
1400 If REVERSE, sort in reverse order."
1401   (interactive "P")
1402   (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
1403
1404 (provide 'gnus-topic)
1405
1406 ;;; gnus-topic.el ends here