+(defvar gnus-tmp-topics nil)
+(defun gnus-topic-list (&optional topology)
+ "Return a list of all topics in the topology."
+ (unless topology
+ (setq topology gnus-topic-topology
+ gnus-tmp-topics nil))
+ (push (caar topology) gnus-tmp-topics)
+ (mapcar 'gnus-topic-list (cdr topology))
+ gnus-tmp-topics)
+
+;;; Topic parameter jazz
+
+(defun gnus-topic-parameters (topic)
+ "Return the parameters for TOPIC."
+ (let ((top (gnus-topic-find-topology topic)))
+ (when top
+ (nth 3 (cadr top)))))
+
+(defun gnus-topic-set-parameters (topic parameters)
+ "Set the topic parameters of TOPIC to PARAMETERS."
+ (let ((top (gnus-topic-find-topology topic)))
+ (unless top
+ (error "No such topic: %s" topic))
+ ;; We may have to extend if there is no parameters here
+ ;; to begin with.
+ (unless (nthcdr 2 (cadr top))
+ (nconc (cadr top) (list nil)))
+ (unless (nthcdr 3 (cadr top))
+ (nconc (cadr top) (list nil)))
+ (setcar (nthcdr 3 (cadr top)) parameters)
+ (gnus-dribble-enter
+ (format "(gnus-topic-set-parameters %S '%S)" topic parameters))))
+
+(defun gnus-group-topic-parameters (group)
+ "Compute the group parameters for GROUP taking into account inheritance from topics."
+ (let ((params-list (list (gnus-group-get-parameter group)))
+ topics params param out)
+ (save-excursion
+ (gnus-group-goto-group group)
+ (setq topics (gnus-current-topics))
+ (while topics
+ (push (gnus-topic-parameters (pop topics)) params-list))
+ ;; We probably have lots of nil elements here, so
+ ;; we remove them. Probably faster than doing this "properly".
+ (setq params-list (delq nil params-list))
+ ;; Now we have all the parameters, so we go through them
+ ;; and do inheritance in the obvious way.
+ (while (setq params (pop params-list))
+ (while (setq param (pop params))
+ (when (atom param)
+ (setq param (cons param t)))
+ ;; Override any old versions of this param.
+ (setq out (delq (assq (car param) out) out))
+ (push param out)))
+ ;; Return the resulting parameter list.
+ out)))
+
+;;; General utility functions
+
+(defun gnus-topic-enter-dribble ()
+ (gnus-dribble-enter
+ (format "(setq gnus-topic-topology '%S)" gnus-topic-topology)))
+
+;;; Generating group buffers
+
+(defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level)
+ "List all newsgroups with unread articles of level LEVEL or lower, and
+use the `gnus-group-topics' to sort the groups.
+If ALL is non-nil, list groups that have no unread articles.
+If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
+ (set-buffer gnus-group-buffer)
+ (let ((buffer-read-only nil)
+ (lowest (or lowest 1)))
+
+ (setq gnus-topic-tallied-groups nil)
+
+ (when (or (not gnus-topic-alist)
+ (not gnus-topology-checked-p))
+ (gnus-topic-check-topology))
+
+ (unless list-topic
+ (erase-buffer))
+
+ ;; List dead groups?
+ (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie))
+ (gnus-group-prepare-flat-list-dead
+ (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
+ gnus-level-zombie ?Z
+ regexp))
+
+ (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))
+ (gnus-group-prepare-flat-list-dead
+ (setq gnus-killed-list (sort gnus-killed-list 'string<))
+ gnus-level-killed ?K
+ regexp))
+
+ ;; Use topics.
+ (prog1
+ (when (< lowest gnus-level-zombie)
+ (if list-topic
+ (let ((top (gnus-topic-find-topology list-topic)))
+ (gnus-topic-prepare-topic (cdr top) (car top)
+ (or topic-level level) all))
+ (gnus-topic-prepare-topic gnus-topic-topology 0
+ (or topic-level level) all)))
+
+ (gnus-group-set-mode-line)
+ (setq gnus-group-list-mode (cons level all))
+ (run-hooks 'gnus-group-prepare-hook))))
+
+(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent)
+ "Insert TOPIC into the group buffer.
+If SILENT, don't insert anything. Return the number of unread
+articles in the topic and its subtopics."
+ (let* ((type (pop topicl))
+ (entries (gnus-topic-find-groups (car type) list-level all))
+ (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
+ (gnus-group-indentation
+ (make-string (* gnus-topic-indent-level level) ? ))
+ (beg (progn (beginning-of-line) (point)))
+ (topicl (reverse topicl))
+ (all-entries entries)
+ (point-max (point-max))
+ (unread 0)
+ (topic (car type))
+ info entry end active tick)
+ ;; Insert any sub-topics.
+ (while topicl
+ (incf unread
+ (gnus-topic-prepare-topic
+ (pop topicl) (1+ level) list-level all
+ (not visiblep))))
+ (setq end (point))
+ (goto-char beg)
+ ;; Insert all the groups that belong in this topic.
+ (while (setq entry (pop entries))
+ (when visiblep
+ (if (stringp entry)
+ ;; Dead groups.
+ (gnus-group-insert-group-line
+ entry (if (member entry gnus-zombie-list) 8 9)
+ nil (- (1+ (cdr (setq active (gnus-active entry))))
+ (car active))
+ nil)
+ ;; Living groups.
+ (when (setq info (nth 2 entry))
+ (gnus-group-insert-group-line
+ (gnus-info-group info)
+ (gnus-info-level info) (gnus-info-marks info)
+ (car entry) (gnus-info-method info)))))
+ (when (and (listp entry)
+ (numberp (car entry))
+ (not (member (gnus-info-group (setq info (nth 2 entry)))
+ gnus-topic-tallied-groups)))
+ (push (gnus-info-group info) gnus-topic-tallied-groups)
+ (incf unread (car entry)))
+ (when (listp entry)
+ (setq tick t)))
+ (goto-char beg)
+ ;; Insert the topic line.
+ (when (and (not silent)
+ (or gnus-topic-display-empty-topics ;We want empty topics
+ (not (zerop unread)) ;Non-empty
+ tick ;Ticked articles
+ (/= point-max (point-max)))) ;Unactivated groups
+ (gnus-extent-start-open (point))
+ (gnus-topic-insert-topic-line
+ (car type) visiblep
+ (not (eq (nth 2 type) 'hidden))
+ level all-entries unread))
+ (goto-char end)
+ unread))
+
+(defun gnus-topic-remove-topic (&optional insert total-remove hide in-level)
+ "Remove the current topic."
+ (let ((topic (gnus-group-topic-name))
+ (level (gnus-group-topic-level))
+ (beg (progn (beginning-of-line) (point)))
+ buffer-read-only)
+ (when topic
+ (while (and (zerop (forward-line 1))
+ (> (or (gnus-group-topic-level) (1+ level)) level)))
+ (delete-region beg (point))
+ ;; Do the change in this rather odd manner because it has been
+ ;; reported that some topics share parts of some lists, for some
+ ;; reason. I have been unable to determine why this is the
+ ;; case, but this hack seems to take care of things.
+ (let ((data (cadr (gnus-topic-find-topology topic))))
+ (setcdr data
+ (list (if insert 'visible 'invisible)
+ (if hide 'hide nil)
+ (cadddr data))))
+ (if total-remove
+ (setq gnus-topic-alist
+ (delq (assoc topic gnus-topic-alist) gnus-topic-alist))
+ (gnus-topic-insert-topic topic in-level)))))
+
+(defun gnus-topic-insert-topic (topic &optional level)
+ "Insert TOPIC."
+ (gnus-group-prepare-topics
+ (car gnus-group-list-mode) (cdr gnus-group-list-mode)
+ nil nil topic level))
+
+(defun gnus-topic-fold (&optional insert)
+ "Remove/insert the current topic."
+ (let ((topic (gnus-group-topic-name)))
+ (when topic
+ (save-excursion
+ (if (not (gnus-group-active-topic-p))
+ (gnus-topic-remove-topic
+ (or insert (not (gnus-topic-visible-p))))
+ (let ((gnus-topic-topology gnus-topic-active-topology)
+ (gnus-topic-alist gnus-topic-active-alist)
+ (gnus-group-list-mode (cons 5 t)))
+ (gnus-topic-remove-topic
+ (or insert (not (gnus-topic-visible-p))) nil nil 9)
+ (gnus-topic-enter-dribble)))))))
+
+(defun gnus-topic-insert-topic-line (name visiblep shownp level entries
+ &optional unread)
+ (let* ((visible (if visiblep "" "..."))
+ (indentation (make-string (* gnus-topic-indent-level level) ? ))
+ (total-number-of-articles unread)
+ (number-of-groups (length entries))
+ (active-topic (eq gnus-topic-alist gnus-topic-active-alist)))
+ (beginning-of-line)
+ ;; Insert the text.
+ (gnus-add-text-properties
+ (point)
+ (prog1 (1+ (point))
+ (eval gnus-topic-line-format-spec)
+ (gnus-topic-remove-excess-properties)1)
+ (list 'gnus-topic (intern name)
+ 'gnus-topic-level level
+ 'gnus-topic-unread unread
+ 'gnus-active active-topic
+ 'gnus-topic-visible visiblep))))
+
+(defun gnus-topic-update-topics-containing-group (group)
+ "Update all topics that have GROUP as a member."
+ (when (and (eq major-mode 'gnus-group-mode)
+ gnus-topic-mode)
+ (save-excursion
+ (let ((alist gnus-topic-alist))
+ ;; This is probably not entirely correct. If a topic
+ ;; isn't shown, then it's not updated. But the updating
+ ;; should be performed in any case, since the topic's
+ ;; parent should be updated. Pfft.
+ (while alist
+ (when (and (member group (cdar alist))
+ (gnus-topic-goto-topic (caar alist)))
+ (gnus-topic-update-topic-line (caar alist)))
+ (pop alist))))))
+
+(defun gnus-topic-update-topic ()
+ "Update all parent topics to the current group."
+ (when (and (eq major-mode 'gnus-group-mode)
+ gnus-topic-mode)
+ (let ((group (gnus-group-group-name))
+ (buffer-read-only nil))
+ (when (and group
+ (gnus-get-info group)
+ (gnus-topic-goto-topic (gnus-current-topic)))
+ (gnus-topic-update-topic-line (gnus-group-topic-name))
+ (gnus-group-goto-group group)
+ (gnus-group-position-point)))))
+
+(defun gnus-topic-goto-missing-group (group)
+ "Place point where GROUP is supposed to be inserted."
+ (let* ((topic (gnus-group-topic group))
+ (groups (cdr (assoc topic gnus-topic-alist)))
+ (g (cdr (member group groups)))
+ (unfound t))
+ ;; Try to jump to a visible group.
+ (while (and g (not (gnus-group-goto-group (car g) t)))
+ (pop g))
+ ;; It wasn't visible, so we try to see where to insert it.
+ (when (not g)
+ (setq g (cdr (member group (reverse groups))))
+ (while (and g unfound)
+ (when (gnus-group-goto-group (pop g) t)
+ (forward-line 1)
+ (setq unfound nil)))
+ (when unfound
+ (gnus-topic-goto-topic topic)
+ (forward-line 1)))))
+
+(defun gnus-topic-update-topic-line (topic-name &optional reads)
+ (let* ((top (gnus-topic-find-topology topic-name))
+ (type (cadr top))
+ (children (cddr top))
+ (entries (gnus-topic-find-groups
+ (car type) (car gnus-group-list-mode)
+ (cdr gnus-group-list-mode)))
+ (parent (gnus-topic-parent-topic topic-name))
+ (all-entries entries)
+ (unread 0)
+ old-unread entry)
+ (when (gnus-topic-goto-topic (car type))
+ ;; Tally all the groups that belong in this topic.
+ (if reads
+ (setq unread (- (gnus-group-topic-unread) reads))
+ (while children
+ (incf unread (gnus-topic-unread (caar (pop children)))))
+ (while (setq entry (pop entries))
+ (when (numberp (car entry))
+ (incf unread (car entry)))))
+ (setq old-unread (gnus-group-topic-unread))
+ ;; Insert the topic line.
+ (gnus-topic-insert-topic-line
+ (car type) (gnus-topic-visible-p)
+ (not (eq (nth 2 type) 'hidden))
+ (gnus-group-topic-level) all-entries unread)
+ (gnus-delete-line))
+ (when parent
+ (forward-line -1)
+ (gnus-topic-update-topic-line
+ parent (- old-unread (gnus-group-topic-unread))))
+ unread))
+
+(defun gnus-topic-group-indentation ()
+ (make-string
+ (* gnus-topic-indent-level
+ (or (save-excursion
+ (forward-line -1)
+ (gnus-topic-goto-topic (gnus-current-topic))
+ (gnus-group-topic-level))
+ 0))
+ ? ))
+
+;;; Initialization
+
+(gnus-add-shutdown 'gnus-topic-close 'gnus)
+
+(defun gnus-topic-close ()
+ (setq gnus-topic-active-topology nil
+ gnus-topic-active-alist nil
+ gnus-topic-killed-topics nil
+ gnus-topic-tallied-groups nil
+ gnus-topology-checked-p nil))
+
+(defun gnus-topic-check-topology ()