X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-topic.el;h=cf4f601e599ab53e3bae67b16a92a4f6438d9d3c;hb=6565967e150bf77c301b9a10dc5d3db3fa7dc385;hp=f30c26c0650e7f39f1605b12902d21a06e984860;hpb=44a2a6a79d7681974e94c543c591f6ff8fdda799;p=gnus diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el index f30c26c06..cf4f601e5 100644 --- a/lisp/gnus-topic.el +++ b/lisp/gnus-topic.el @@ -27,7 +27,8 @@ ;;; Code: (require 'gnus) -(eval-when-compile (require 'cl)) +(require 'gnus-group) +(require 'gnus-start) (defvar gnus-topic-mode nil "Minor mode for Gnus group buffers.") @@ -48,17 +49,20 @@ with some simple extensions. %A Number of unread articles in the groups in the topic and its subtopics. ") -(defvar gnus-topic-unique t - "*If non-nil, each group will only belong to one topic.") - (defvar gnus-topic-indent-level 2 "*How much each subtopic should be indented.") +(defvar gnus-topic-display-empty-topics t + "*If non-nil, display the topic lines even of topics that have no unread articles.") + ;; Internal variables. (defvar gnus-topic-active-topology nil) (defvar gnus-topic-active-alist nil) +(defvar gnus-topology-checked-p nil + "Whether the topology has been checked in this session.") + (defvar gnus-topic-killed-topics nil) (defvar gnus-topic-inhibit-change-level nil) (defvar gnus-topic-tallied-groups nil) @@ -74,7 +78,7 @@ with some simple extensions. (defvar gnus-topic-line-format-spec nil) -;; Functions. +;;; Utility functions (defun gnus-group-topic-name () "The name of the topic on the current line." @@ -89,19 +93,237 @@ with some simple extensions. "The number of unread articles in topic on the current line." (get-text-property (gnus-point-at-bol) 'gnus-topic-unread)) -(defun gnus-topic-init-alist () - "Initialize the topic structures." - (setq gnus-topic-topology - (cons (list "Gnus" 'visible) - (mapcar (lambda (topic) - (list (list (car topic) 'visible))) - '(("misc"))))) - (setq gnus-topic-alist - (list (cons "misc" - (mapcar (lambda (info) (gnus-info-group info)) - (cdr gnus-newsrc-alist))) - (list "Gnus"))) - (gnus-topic-enter-dribble)) +(defun gnus-topic-unread (topic) + "Return the number of unread articles in TOPIC." + (or (save-excursion + (and (gnus-topic-goto-topic topic) + (gnus-group-topic-unread))) + 0)) + +(defun gnus-group-topic-p () + "Return non-nil if the current line is a topic." + (gnus-group-topic-name)) + +(defun gnus-topic-visible-p () + "Return non-nil if the current topic is visible." + (get-text-property (gnus-point-at-bol) 'gnus-topic-visible)) + +(defun gnus-topic-articles-in-topic (entries) + (let ((total 0) + number) + (while entries + (when (numberp (setq number (car (pop entries)))) + (incf total number))) + total)) + +(defun gnus-group-topic (group) + "Return the topic GROUP is a member of." + (let ((alist gnus-topic-alist) + out) + (while alist + (when (member group (cdar alist)) + (setq out (caar alist) + alist nil)) + (setq alist (cdr alist))) + out)) + +(defun gnus-group-parent-topic (group) + "Return the topic GROUP is member of by looking at the group buffer." + (save-excursion + (set-buffer gnus-group-buffer) + (if (gnus-group-goto-group group) + (gnus-current-topic) + (gnus-group-topic group)))) + +(defun gnus-topic-goto-topic (topic) + "Go to TOPIC." + (when topic + (gnus-goto-char (text-property-any (point-min) (point-max) + 'gnus-topic (intern topic))))) + +(defun gnus-current-topic () + "Return the name of the current topic." + (let ((result + (or (get-text-property (point) 'gnus-topic) + (save-excursion + (and (gnus-goto-char (previous-single-property-change + (point) 'gnus-topic)) + (get-text-property (max (1- (point)) (point-min)) + 'gnus-topic)))))) + (when result + (symbol-name result)))) + +(defun gnus-current-topics () + "Return a list of all current topics, lowest in hierarchy first." + (let ((topic (gnus-current-topic)) + topics) + (while topic + (push topic topics) + (setq topic (gnus-topic-parent-topic topic))) + (nreverse topics))) + +(defun gnus-group-active-topic-p () + "Say whether the current topic comes from the active topics." + (save-excursion + (beginning-of-line) + (get-text-property (point) 'gnus-active))) + +(defun gnus-topic-find-groups (topic &optional level all) + "Return entries for all visible groups in TOPIC." + (let ((groups (cdr (assoc topic gnus-topic-alist))) + info clevel unread group lowest params visible-groups entry active) + (setq lowest (or lowest 1)) + (setq level (or level 7)) + ;; We go through the newsrc to look for matches. + (while groups + (setq entry (gnus-gethash (setq group (pop groups)) gnus-newsrc-hashtb) + info (nth 2 entry) + params (gnus-info-params info) + active (gnus-active group) + unread (or (car entry) + (and (not (equal group "dummy.group")) + active + (- (1+ (cdr active)) (car active)))) + clevel (or (gnus-info-level info) + (if (member group gnus-zombie-list) 8 9))) + (and + unread ; nil means that the group is dead. + (<= clevel level) + (>= clevel lowest) ; Is inside the level we want. + (or all + (if (eq unread t) + gnus-group-list-inactive-groups + (> unread 0)) + (and gnus-list-groups-with-ticked-articles + (cdr (assq 'tick (gnus-info-marks info)))) + ; Has right readedness. + ;; Check for permanent visibility. + (and gnus-permanently-visible-groups + (string-match gnus-permanently-visible-groups group)) + (memq 'visible params) + (cdr (assq 'visible params))) + ;; Add this group to the list of visible groups. + (push (or entry group) visible-groups))) + (nreverse visible-groups))) + +(defun gnus-topic-previous-topic (topic) + "Return the previous topic on the same level as TOPIC." + (let ((top (cddr (gnus-topic-find-topology + (gnus-topic-parent-topic topic))))) + (unless (equal topic (caaar top)) + (while (and top (not (equal (caaadr top) topic))) + (setq top (cdr top))) + (caaar top)))) + +(defun gnus-topic-parent-topic (topic &optional topology) + "Return the parent of TOPIC." + (unless topology + (setq topology gnus-topic-topology)) + (let ((parent (car (pop topology))) + result found) + (while (and topology + (not (setq found (equal (caaar topology) topic))) + (not (setq result (gnus-topic-parent-topic topic + (car topology))))) + (setq topology (cdr topology))) + (or result (and found parent)))) + +(defun gnus-topic-next-topic (topic &optional previous) + "Return the next sibling of TOPIC." + (let ((parentt (cddr (gnus-topic-find-topology + (gnus-topic-parent-topic topic)))) + prev) + (while (and parentt + (not (equal (caaar parentt) topic))) + (setq prev (caaar parentt) + parentt (cdr parentt))) + (if previous + prev + (caaadr parentt)))) + +(defun gnus-topic-find-topology (topic &optional topology level remove) + "Return the topology of TOPIC." + (unless topology + (setq topology gnus-topic-topology) + (setq level 0)) + (let ((top topology) + result) + (if (equal (caar topology) topic) + (progn + (when remove + (delq topology remove)) + (cons level topology)) + (setq topology (cdr topology)) + (while (and topology + (not (setq result (gnus-topic-find-topology + topic (car topology) (1+ level) + (and remove top))))) + (setq topology (cdr topology))) + result))) + +(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))) + (unless top + (error "No such topic: %s" topic)) + (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))) + +(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 @@ -114,7 +336,8 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (setq gnus-topic-tallied-groups nil) - (unless gnus-topic-alist + (when (or (not gnus-topic-alist) + (not gnus-topology-checked-p)) (gnus-topic-check-topology)) (unless list-topic @@ -123,7 +346,7 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." ;; 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<)) + (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) gnus-level-zombie ?Z regexp)) @@ -177,12 +400,13 @@ articles in the topic and its subtopics." (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) + (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) + (gnus-info-level info) (gnus-info-marks info) (car entry) (gnus-info-method info))))) (when (and (listp entry) (numberp (car entry)) @@ -192,7 +416,9 @@ articles in the topic and its subtopics." (incf unread (car entry)))) (goto-char beg) ;; Insert the topic line. - (unless silent + (when (and (not silent) + (or gnus-topic-display-empty-topics + (not (zerop unread)))) (gnus-extent-start-open (point)) (gnus-topic-insert-topic-line (car type) visiblep @@ -201,44 +427,6 @@ articles in the topic and its subtopics." (goto-char end) unread)) -(defun gnus-topic-find-groups (topic &optional level all) - "Return entries for all visible groups in TOPIC." - (let ((groups (cdr (assoc topic gnus-topic-alist))) - info clevel unread group lowest params visible-groups entry active) - (setq lowest (or lowest 1)) - (setq level (or level 7)) - ;; We go through the newsrc to look for matches. - (while groups - (setq entry (gnus-gethash (setq group (pop groups)) gnus-newsrc-hashtb) - info (nth 2 entry) - params (gnus-info-params info) - active (gnus-active group) - unread (or (car entry) - (and (not (equal group "dummy.group")) - active - (- (1+ (cdr active)) (car active)))) - clevel (or (gnus-info-level info) - (if (member group gnus-zombie-list) 8 9))) - (and - unread ; nil means that the group is dead. - (<= clevel level) - (>= clevel lowest) ; Is inside the level we want. - (or all - (if (eq unread t) - gnus-group-list-inactive-groups - (> unread 0)) - (and gnus-list-groups-with-ticked-articles - (cdr (assq 'tick (gnus-info-marks info)))) - ; Has right readedness. - ;; Check for permanent visibility. - (and gnus-permanently-visible-groups - (string-match gnus-permanently-visible-groups group)) - (memq 'visible params) - (cdr (assq 'visible params))) - ;; Add this group to the list of visible groups. - (push (or entry group) visible-groups))) - (nreverse visible-groups))) - (defun gnus-topic-remove-topic (&optional insert total-remove hide in-level) "Remove the current topic." (let ((topic (gnus-group-topic-name)) @@ -249,12 +437,18 @@ articles in the topic and its subtopics." (while (and (zerop (forward-line 1)) (> (or (gnus-group-topic-level) (1+ level)) level))) (delete-region beg (point)) - (setcar (cdadr (gnus-topic-find-topology topic)) - (if insert 'visible 'invisible)) - (when hide - (setcdr (cdadr (gnus-topic-find-topology topic)) - (list hide))) - (unless total-remove + ;; 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) @@ -265,7 +459,7 @@ articles in the topic and its subtopics." (defun gnus-topic-fold (&optional insert) "Remove/insert the current topic." - (let ((topic (gnus-group-topic-name))) + (let ((topic (gnus-group-topic-name))) (when topic (save-excursion (if (not (gnus-group-active-topic-p)) @@ -277,14 +471,6 @@ articles in the topic and its subtopics." (gnus-topic-remove-topic (or insert (not (gnus-topic-visible-p))) nil nil 9))))))) -(defun gnus-group-topic-p () - "Return non-nil if the current line is a topic." - (gnus-group-topic-name)) - -(defun gnus-topic-visible-p () - "Return non-nil if the current topic is visible." - (get-text-property (gnus-point-at-bol) 'gnus-topic-visible)) - (defun gnus-topic-insert-topic-line (name visiblep shownp level entries &optional unread) (let* ((visible (if visiblep "" "...")) @@ -296,7 +482,7 @@ articles in the topic and its subtopics." ;; Insert the text. (gnus-add-text-properties (point) - (prog1 (1+ (point)) + (prog1 (1+ (point)) (eval gnus-topic-line-format-spec) (gnus-topic-remove-excess-properties)1) (list 'gnus-topic (intern name) @@ -305,166 +491,49 @@ articles in the topic and its subtopics." 'gnus-active active-topic 'gnus-topic-visible visiblep)))) -(defun gnus-topic-previous-topic (topic) - "Return the previous topic on the same level as TOPIC." - (let ((top (cddr (gnus-topic-find-topology - (gnus-topic-parent-topic topic))))) - (unless (equal topic (caaar top)) - (while (and top (not (equal (caaadr top) topic))) - (setq top (cdr top))) - (caaar top)))) - -(defun gnus-topic-parent-topic (topic &optional topology) - "Return the parent of TOPIC." - (unless topology - (setq topology gnus-topic-topology)) - (let ((parent (car (pop topology))) - result found) - (while (and topology - (not (setq found (equal (caaar topology) topic))) - (not (setq result (gnus-topic-parent-topic topic - (car topology))))) - (setq topology (cdr topology))) - (or result (and found parent)))) - -(defun gnus-topic-next-topic (topic &optional previous) - "Return the next sibling of TOPIC." - (let ((topology gnus-topic-topology) - (parentt (cddr (gnus-topic-find-topology - (gnus-topic-parent-topic topic)))) - prev) - (while (and parentt - (not (equal (caaar parentt) topic))) - (setq prev (caaar parentt) - parentt (cdr parentt))) - (if previous - prev - (caaadr parentt)))) - -(defun gnus-topic-find-topology (topic &optional topology level remove) - "Return the topology of TOPIC." - (unless topology - (setq topology gnus-topic-topology) - (setq level 0)) - (let ((top topology) - result) - (if (equal (caar topology) topic) - (progn - (when remove - (delq topology remove)) - (cons level topology)) - (setq topology (cdr topology)) - (while (and topology - (not (setq result (gnus-topic-find-topology - topic (car topology) (1+ level) - (and remove top))))) - (setq topology (cdr topology))) - result))) - -(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)) - -(defun gnus-topic-check-topology () - ;; The first time we set the topology to whatever we have - ;; gotten here, which can be rather random. - (unless gnus-topic-alist - (gnus-topic-init-alist)) - - (let ((topics (gnus-topic-list)) - (alist gnus-topic-alist) - changed) - (while alist - (unless (member (caar alist) topics) - (nconc gnus-topic-topology - (list (list (list (caar alist) 'visible)))) - (setq changed t)) - (setq alist (cdr alist))) - (when changed - (gnus-topic-enter-dribble))) - (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry)) - gnus-topic-alist))) - (entry (assoc (caar gnus-topic-topology) gnus-topic-alist)) - (newsrc gnus-newsrc-alist) - group) - (while newsrc - (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) - (setcdr entry (cons group (cdr entry))))))) - -(defvar gnus-tmp-topics nil) -(defun gnus-topic-list (&optional 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) - -(defun gnus-topic-enter-dribble () - (gnus-dribble-enter - (format "(setq gnus-topic-topology '%S)" gnus-topic-topology))) - -(defun gnus-topic-articles-in-topic (entries) - (let ((total 0) - number) - (while entries - (when (numberp (setq number (car (pop entries)))) - (incf total number))) - total)) - -(defun gnus-group-parent-topic () - "Return the topic the current group belongs in." - (let ((group (gnus-group-group-name))) - (if group - (gnus-group-topic group) - (gnus-group-topic-name)))) - -(defun gnus-group-topic (group) - "Return the topic GROUP is a member of." - (let ((alist gnus-topic-alist) - out) - (while alist - (when (member group (cdar alist)) - (setq out (caar alist) - alist nil)) - (setq alist (cdr alist))) - out)) +(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-goto-topic (topic) - (when topic - (gnus-goto-char (text-property-any (point-min) (point-max) - 'gnus-topic (intern topic))))) - (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-group-parent-topic))) + (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) +(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)) - (while (and g unfound) - (when (gnus-group-goto-group (pop g)) - (beginning-of-line) - (setq unfound nil))) - (when unfound + ;; 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)) + (when (gnus-group-goto-group (pop g) t) (forward-line 1) (setq unfound nil))) (when unfound @@ -472,7 +541,9 @@ articles in the topic and its subtopics." (forward-line 1))))) (defun gnus-topic-update-topic-line (topic-name &optional reads) - (let* ((type (cadr (gnus-topic-find-topology topic-name))) + (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))) @@ -484,6 +555,8 @@ articles in the topic and its subtopics." ;; 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))))) @@ -500,6 +573,185 @@ articles in the topic and its subtopics." 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 () + ;; The first time we set the topology to whatever we have + ;; gotten here, which can be rather random. + (unless gnus-topic-alist + (gnus-topic-init-alist)) + + (setq gnus-topology-checked-p t) + ;; Go through the topic alist and make sure that all topics + ;; are in the topic topology. + (let ((topics (gnus-topic-list)) + (alist gnus-topic-alist) + changed) + (while alist + (unless (member (caar alist) topics) + (nconc gnus-topic-topology + (list (list (list (caar alist) 'visible)))) + (setq changed t)) + (setq alist (cdr alist))) + (when changed + (gnus-topic-enter-dribble)) + ;; Conversely, go through the topology and make sure that all + ;; topologies have alists. + (while topics + (unless (assoc (car topics) gnus-topic-alist) + (push (list (car topics)) gnus-topic-alist)) + (pop topics))) + ;; Go through all living groups and make sure that + ;; they belong to some topic. + (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry)) + gnus-topic-alist))) + (entry (assoc (caar gnus-topic-topology) gnus-topic-alist)) + (newsrc gnus-newsrc-alist) + group) + (while newsrc + (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) + (setcdr entry (cons group (cdr entry)))))) + ;; Go through all topics and make sure they contain only living groups. + (let ((alist gnus-topic-alist) + topic) + (while (setq topic (pop alist)) + (while (cdr topic) + (if (gnus-gethash (cadr topic) gnus-newsrc-hashtb) + (setq topic (cdr topic)) + (setcdr topic (cddr topic))))))) + +(defun gnus-topic-init-alist () + "Initialize the topic structures." + (setq gnus-topic-topology + (cons (list "Gnus" 'visible) + (mapcar (lambda (topic) + (list (list (car topic) 'visible))) + '(("misc"))))) + (setq gnus-topic-alist + (list (cons "misc" + (mapcar (lambda (info) (gnus-info-group info)) + (cdr gnus-newsrc-alist))) + (list "Gnus"))) + (gnus-topic-enter-dribble)) + +;;; Maintenance + +(defun gnus-topic-clean-alist () + "Remove bogus groups from the topic alist." + (let ((topic-alist gnus-topic-alist) + result topic) + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) + (while (setq topic (pop topic-alist)) + (let ((topic-name (pop topic)) + group filtered-topic) + (while (setq group (pop topic)) + (when (and (or (gnus-gethash group gnus-active-hashtb) + (gnus-info-method (gnus-get-info group))) + (not (gnus-gethash group gnus-killed-hashtb))) + (push group filtered-topic))) + (push (cons topic-name (nreverse filtered-topic)) result))) + (setq gnus-topic-alist (nreverse result)))) + +(defun gnus-topic-change-level (group level oldlevel) + "Run when changing levels to enter/remove groups from topics." + (save-excursion + (set-buffer gnus-group-buffer) + (when (and gnus-topic-mode + gnus-topic-alist + (not gnus-topic-inhibit-change-level)) + ;; Remove the group from the topics. + (when (and (< oldlevel gnus-level-zombie) + (>= level gnus-level-zombie)) + (let (alist) + (forward-line -1) + (when (setq alist (assoc (gnus-current-topic) gnus-topic-alist)) + (setcdr alist (gnus-delete-first group (cdr alist)))))) + ;; If the group is subscribed. then we enter it into the topics. + (when (and (< level gnus-level-zombie) + (>= oldlevel gnus-level-zombie)) + (let* ((prev (gnus-group-group-name)) + (gnus-topic-inhibit-change-level t) + (gnus-group-indentation + (make-string + (* gnus-topic-indent-level + (or (save-excursion + (gnus-topic-goto-topic (gnus-current-topic)) + (gnus-group-topic-level)) + 0)) + ? )) + (yanked (list group)) + alist talist end) + ;; Then we enter the yanked groups into the topics they belong + ;; to. + (when (setq alist (assoc (save-excursion + (forward-line -1) + (or + (gnus-current-topic) + (caar gnus-topic-topology))) + gnus-topic-alist)) + (setq talist alist) + (when (stringp yanked) + (setq yanked (list yanked))) + (if (not prev) + (nconc alist yanked) + (if (not (cdr alist)) + (setcdr alist (nconc yanked (cdr alist))) + (while (and (not end) (cdr alist)) + (when (equal (cadr alist) prev) + (setcdr alist (nconc yanked (cdr alist))) + (setq end t)) + (setq alist (cdr alist))) + (unless end + (nconc talist yanked)))))) + (gnus-topic-update-topic))))) + +(defun gnus-topic-goto-next-group (group props) + "Go to group or the next group after group." + (if (null group) + (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props)))) + (if (gnus-group-goto-group group) + t + ;; The group is no longer visible. + (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist)) + (after (cdr (member group (cdr list))))) + ;; First try to put point on a group after the current one. + (while (and after + (not (gnus-group-goto-group (car after)))) + (setq after (cdr after))) + ;; Then try to put point on a group before point. + (unless after + (setq after (cdr (member group (reverse (cdr list))))) + (while (and after + (not (gnus-group-goto-group (car after)))) + (setq after (cdr after)))) + ;; Finally, just put point on the topic. + (unless after + (gnus-topic-goto-topic (car list)) + (setq after nil)) + t)))) + +;;; Topic-active functions + (defun gnus-topic-grok-active (&optional force) "Parse all active groups and create topic structures for them." ;; First we make sure that we have really read the active file. @@ -512,7 +764,7 @@ articles in the topic and its subtopics." gnus-active-hashtb) (setq groups (sort groups 'string<)) ;; Init the variables. - (setq gnus-topic-active-topology '(("" visible))) + (setq gnus-topic-active-topology (list (list "" 'visible))) (setq gnus-topic-active-alist nil) ;; Descend the top-level hierarchy. (gnus-topic-grok-active-1 gnus-topic-active-topology groups) @@ -550,12 +802,6 @@ articles in the topic and its subtopics." ;; to this topic. groups)) -(defun gnus-group-active-topic-p () - "Return whether the current active comes from the active topics." - (save-excursion - (beginning-of-line) - (get-text-property (point) 'gnus-active))) - ;;; Topic mode, commands and keymap. (defvar gnus-topic-mode-map nil) @@ -565,34 +811,42 @@ articles in the topic and its subtopics." (setq gnus-topic-mode-map (make-sparse-keymap)) ;; Override certain group mode keys. - (gnus-define-keys - gnus-topic-mode-map - "=" gnus-topic-select-group - "\r" gnus-topic-select-group - " " gnus-topic-read-group - "\C-k" gnus-topic-kill-group - "\C-y" gnus-topic-yank-group - "\M-g" gnus-topic-get-new-news-this-topic - "AT" gnus-topic-list-active - gnus-mouse-2 gnus-mouse-pick-topic) + (gnus-define-keys gnus-topic-mode-map + "=" gnus-topic-select-group + "\r" gnus-topic-select-group + " " gnus-topic-read-group + "\C-k" gnus-topic-kill-group + "\C-y" gnus-topic-yank-group + "\M-g" gnus-topic-get-new-news-this-topic + "AT" gnus-topic-list-active + "Gp" gnus-topic-edit-parameters + gnus-mouse-2 gnus-mouse-pick-topic) ;; Define a new submap. - (gnus-define-keys - (gnus-group-topic-map "T" gnus-group-mode-map) - "#" gnus-topic-mark-topic - "\M-#" gnus-topic-unmark-topic - "n" gnus-topic-create-topic - "m" gnus-topic-move-group - "D" gnus-topic-remove-group - "c" gnus-topic-copy-group - "h" gnus-topic-hide-topic - "s" gnus-topic-show-topic - "M" gnus-topic-move-matching - "C" gnus-topic-copy-matching - "\C-i" gnus-topic-indent - [tab] gnus-topic-indent - "r" gnus-topic-rename - "\177" gnus-topic-delete)) + (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map) + "#" gnus-topic-mark-topic + "\M-#" gnus-topic-unmark-topic + "n" gnus-topic-create-topic + "m" gnus-topic-move-group + "D" gnus-topic-remove-group + "c" gnus-topic-copy-group + "h" gnus-topic-hide-topic + "s" gnus-topic-show-topic + "M" gnus-topic-move-matching + "C" gnus-topic-copy-matching + "\C-i" gnus-topic-indent + [tab] gnus-topic-indent + "r" gnus-topic-rename + "\177" gnus-topic-delete) + + (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map) + "s" gnus-topic-sort-groups + "a" gnus-topic-sort-groups-by-alphabet + "u" gnus-topic-sort-groups-by-unread + "l" gnus-topic-sort-groups-by-level + "v" gnus-topic-sort-groups-by-score + "r" gnus-topic-sort-groups-by-rank + "m" gnus-topic-sort-groups-by-method)) (defun gnus-topic-make-menu-bar () (unless (boundp 'gnus-topic-menu) @@ -639,25 +893,35 @@ articles in the topic and its subtopics." minor-mode-map-alist)) (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) - (make-local-variable 'gnus-group-prepare-function) - (setq gnus-group-prepare-function 'gnus-group-prepare-topics) - (make-local-variable 'gnus-group-goto-next-group-function) - (setq gnus-group-goto-next-group-function - 'gnus-topic-goto-next-group) + (set (make-local-variable 'gnus-group-prepare-function) + 'gnus-group-prepare-topics) + (set (make-local-variable 'gnus-group-get-parameter-function) + 'gnus-group-topic-parameters) + (set (make-local-variable 'gnus-group-goto-next-group-function) + 'gnus-topic-goto-next-group) + (set (make-local-variable 'gnus-group-indentation-function) + 'gnus-topic-group-indentation) + (set (make-local-variable 'gnus-group-update-group-function) + 'gnus-topic-update-topics-containing-group) + (set (make-local-variable 'gnus-group-sort-alist-function) + 'gnus-group-sort-topic) (setq gnus-group-change-level-function 'gnus-topic-change-level) (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) - (make-local-variable 'gnus-group-indentation-function) - (setq gnus-group-indentation-function - 'gnus-topic-group-indentation) + (gnus-make-local-hook 'gnus-check-bogus-groups-hook) + (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) + (setq gnus-topology-checked-p nil) ;; We check the topology. - (gnus-topic-check-topology) + (when gnus-newsrc-alist + (gnus-topic-check-topology)) (run-hooks 'gnus-topic-mode-hook)) ;; Remove topic infestation. (unless gnus-topic-mode (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) (remove-hook 'gnus-group-change-level-function 'gnus-topic-change-level) - (setq gnus-group-prepare-function 'gnus-group-prepare-flat)) + (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) + (setq gnus-group-prepare-function 'gnus-group-prepare-flat) + (setq gnus-group-sort-alist-function 'gnus-group-sort-flat)) (when redisplay (gnus-group-list-groups)))) @@ -665,7 +929,9 @@ articles in the topic and its subtopics." "Select this newsgroup. No article is selected automatically. If ALL is non-nil, already read articles become readable. -If ALL is a number, fetch this number of articles." +If ALL is a number, fetch this number of articles. + +If performed over a topic line, toggle folding the topic." (interactive "P") (if (gnus-group-topic-p) (let ((gnus-group-list-mode @@ -685,7 +951,9 @@ If the prefix argument ALL is non-nil, already read articles become readable. IF ALL is a number, fetch this number of articles. If the optional argument NO-ARTICLE is non-nil, no article will be auto-selected upon group entry. If GROUP is non-nil, fetch that -group." +group. + +If performed over a topic line, toggle folding the topic." (interactive "P") (if (gnus-group-topic-p) (let ((gnus-group-list-mode @@ -697,10 +965,10 @@ group." (interactive (list (read-string "New topic: ") - (gnus-group-parent-topic))) + (gnus-current-topic))) ;; Check whether this topic already exists. (when (gnus-topic-find-topology topic) - (error "Topic aleady exists")) + (error "Topic already exists")) (unless parent (setq parent (caar gnus-topic-topology))) (let ((top (cdr (gnus-topic-find-topology parent))) @@ -721,36 +989,43 @@ group." (gnus-topic-goto-topic topic)) (defun gnus-topic-move-group (n topic &optional copyp) - "Move the current group to a topic." + "Move the next N groups to TOPIC. +If COPYP, copy the groups instead." (interactive (list current-prefix-arg (completing-read "Move to topic: " gnus-topic-alist nil t))) (let ((groups (gnus-group-process-prefix n)) (topicl (assoc topic gnus-topic-alist)) + (start-group (progn (forward-line 1) (gnus-group-group-name))) + (start-topic (gnus-group-topic-name)) entry) - (mapcar (lambda (g) - (gnus-group-remove-mark g) - (when (and - (setq entry (assoc (gnus-group-topic g) gnus-topic-alist)) - (not copyp)) - (setcdr entry (delete g (cdr entry)))) - (when topicl - (nconc topicl (list g)))) - groups) - (gnus-group-position-point)) - (gnus-topic-enter-dribble) - (gnus-group-list-groups)) + (mapcar + (lambda (g) + (gnus-group-remove-mark g) + (when (and + (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) + (not copyp)) + (setcdr entry (gnus-delete-first g (cdr entry)))) + (nconc topicl (list g))) + groups) + (gnus-topic-enter-dribble) + (if start-group + (gnus-group-goto-group start-group) + (gnus-topic-goto-topic start-topic)) + (gnus-group-list-groups))) -(defun gnus-topic-remove-group () +(defun gnus-topic-remove-group (&optional arg) "Remove the current group from the topic." - (interactive) - (let ((topicl (assoc (gnus-group-parent-topic) gnus-topic-alist)) - (group (gnus-group-group-name)) - (buffer-read-only nil)) - (when (and topicl group) - (gnus-delete-line) - (delq (gnus-group-group-name) topicl)) - (gnus-group-position-point))) + (interactive "P") + (gnus-group-iterate arg + (lambda (group) + (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) + (buffer-read-only nil)) + (when (and topicl group) + (gnus-delete-line) + (gnus-delete-first group topicl)) + (gnus-topic-update-topic) + (gnus-group-position-point))))) (defun gnus-topic-copy-group (n topic) "Copy the current group to a topic." @@ -759,86 +1034,6 @@ group." (completing-read "Copy to topic: " gnus-topic-alist nil t))) (gnus-topic-move-group n topic t)) -(defun gnus-topic-group-indentation () - (make-string - (* gnus-topic-indent-level - (or (save-excursion - (gnus-topic-goto-topic (gnus-group-parent-topic)) - (gnus-group-topic-level)) 0)) ? )) - -(defun gnus-topic-change-level (group level oldlevel) - "Run when changing levels to enter/remove groups from topics." - (when (and gnus-topic-mode - gnus-topic-alist - (not gnus-topic-inhibit-change-level)) - ;; Remove the group from the topics. - (when (and (< oldlevel gnus-level-zombie) - (>= level gnus-level-zombie)) - (let (alist) - (when (setq alist (assoc (gnus-group-topic group) gnus-topic-alist)) - (setcdr alist (delete group (cdr alist)))))) - ;; If the group is subscribed. then we enter it into the topics. - (when (and (< level gnus-level-zombie) - (>= oldlevel gnus-level-zombie)) - (let* ((prev (gnus-group-group-name)) - (gnus-topic-inhibit-change-level t) - (gnus-group-indentation - (make-string - (* gnus-topic-indent-level - (or (save-excursion - (gnus-topic-goto-topic (gnus-group-parent-topic)) - (gnus-group-topic-level)) 0)) ? )) - (yanked (list group)) - alist talist end) - ;; Then we enter the yanked groups into the topics they belong - ;; to. - (when (setq alist (assoc (save-excursion - (forward-line -1) - (or - (gnus-group-parent-topic) - (caar gnus-topic-topology))) - gnus-topic-alist)) - (setq talist alist) - (when (stringp yanked) - (setq yanked (list yanked))) - (if (not prev) - (nconc alist yanked) - (if (not (cdr alist)) - (setcdr alist (nconc yanked (cdr alist))) - (while (and (not end) (cdr alist)) - (when (equal (cadr alist) prev) - (setcdr alist (nconc yanked (cdr alist))) - (setq end t)) - (setq alist (cdr alist))) - (unless end - (nconc talist yanked)))))) - (gnus-topic-update-topic)))) - -(defun gnus-topic-goto-next-group (group props) - "Go to group or the next group after group." - (if (null group) - (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props)))) - (if (gnus-group-goto-group group) - t - ;; The group is no longer visible. - (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist)) - (after (cdr (member group (cdr list))))) - ;; First try to put point on a group after the current one. - (while (and after - (not (gnus-group-goto-group (car after)))) - (setq after (cdr after))) - ;; Then try to put point on a group before point. - (unless after - (setq after (cdr (member group (reverse (cdr list))))) - (while (and after - (not (gnus-group-goto-group (car after)))) - (setq after (cdr after)))) - ;; Finally, just put point on the topic. - (unless after - (gnus-topic-goto-topic (car list)) - (setq after nil)) - t)))) - (defun gnus-topic-kill-group (&optional n discard) "Kill the next N groups." (interactive "P") @@ -846,7 +1041,8 @@ group." (let ((topic (gnus-group-topic-name))) (gnus-topic-remove-topic nil t) (push (gnus-topic-find-topology topic nil nil gnus-topic-topology) - gnus-topic-killed-topics)) + gnus-topic-killed-topics) + (gnus-topic-enter-dribble)) (gnus-group-kill-group n discard) (gnus-topic-update-topic))) @@ -854,11 +1050,14 @@ group." "Yank the last topic." (interactive "p") (if gnus-topic-killed-topics - (let ((previous (gnus-group-parent-topic)) + (let ((previous + (or (gnus-group-topic-name) + (gnus-topic-next-topic (gnus-current-topic)))) (item (cdr (pop gnus-topic-killed-topics)))) (gnus-topic-create-topic (caar item) (gnus-topic-parent-topic previous) previous item) + (gnus-topic-enter-dribble) (gnus-topic-goto-topic (caar item))) (let* ((prev (gnus-group-group-name)) (gnus-topic-inhibit-change-level t) @@ -866,8 +1065,10 @@ group." (make-string (* gnus-topic-indent-level (or (save-excursion - (gnus-topic-goto-topic (gnus-group-parent-topic)) - (gnus-group-topic-level)) 0)) ? )) + (gnus-topic-goto-topic (gnus-current-topic)) + (gnus-group-topic-level)) + 0)) + ? )) yanked alist) ;; We first yank the groups the normal way... (setq yanked (gnus-group-yank-group arg)) @@ -875,7 +1076,7 @@ group." ;; to. (setq alist (assoc (save-excursion (forward-line -1) - (gnus-group-parent-topic)) + (gnus-current-topic)) gnus-topic-alist)) (when (stringp yanked) (setq yanked (list yanked))) @@ -891,10 +1092,10 @@ group." (gnus-topic-update-topic))) (defun gnus-topic-hide-topic () - "Hide all subtopics under the current topic." + "Hide the current topic." (interactive) - (when (gnus-group-parent-topic) - (gnus-topic-goto-topic (gnus-group-parent-topic)) + (when (gnus-current-topic) + (gnus-topic-goto-topic (gnus-current-topic)) (gnus-topic-remove-topic nil nil 'hidden))) (defun gnus-topic-show-topic () @@ -905,7 +1106,7 @@ group." (defun gnus-topic-mark-topic (topic &optional unmark) "Mark all groups in the topic with the process mark." - (interactive (list (gnus-group-parent-topic))) + (interactive (list (gnus-current-topic))) (save-excursion (let ((groups (gnus-topic-find-groups topic 9 t))) (while groups @@ -914,7 +1115,7 @@ group." (defun gnus-topic-unmark-topic (topic &optional unmark) "Remove the process mark from all groups in the topic." - (interactive (list (gnus-group-parent-topic))) + (interactive (list (gnus-current-topic))) (gnus-topic-mark-topic topic t)) (defun gnus-topic-get-new-news-this-topic (&optional n) @@ -966,7 +1167,7 @@ group." (defun gnus-topic-rename (old-name new-name) "Rename a topic." (interactive - (let ((topic (gnus-group-parent-topic))) + (let ((topic (gnus-current-topic))) (list topic (read-string (format "Rename %s to: " topic))))) (let ((top (gnus-topic-find-topology old-name)) @@ -975,6 +1176,7 @@ group." (setcar (cadr top) new-name)) (when entry (setcar entry new-name)) + (forward-line -1) (gnus-group-list-groups))) (defun gnus-topic-indent (&optional unindent) @@ -983,7 +1185,7 @@ If UNINDENT, remove an indentation." (interactive "P") (if unindent (gnus-topic-unindent) - (let* ((topic (gnus-group-parent-topic)) + (let* ((topic (gnus-current-topic)) (parent (gnus-topic-previous-topic topic))) (unless parent (error "Nothing to indent %s into" topic)) @@ -998,7 +1200,7 @@ If UNINDENT, remove an indentation." (defun gnus-topic-unindent () "Unindent a topic." (interactive) - (let* ((topic (gnus-group-parent-topic)) + (let* ((topic (gnus-current-topic)) (parent (gnus-topic-parent-topic topic)) (grandparent (gnus-topic-parent-topic parent))) (unless grandparent @@ -1023,6 +1225,92 @@ If FORCE, always re-read the active file." gnus-killed-list gnus-zombie-list) (gnus-group-list-groups 9 nil 1))) +;;; Topic sorting functions + +(defun gnus-topic-edit-parameters (group) + "Edit the group parameters of GROUP. +If performed on a topic, edit the topic parameters instead." + (interactive (list (gnus-group-group-name))) + (if group + (gnus-group-edit-group-parameters group) + (if (not (gnus-group-topic-p)) + (error "Nothing to edit on the current line.") + (let ((topic (gnus-group-topic-name))) + (gnus-edit-form + (gnus-topic-parameters topic) + "Editing the topic parameters." + `(lambda (form) + (gnus-topic-set-parameters ,topic form))))))) + +(defun gnus-group-sort-topic (func reverse) + "Sort groups in the topics according to FUNC and REVERSE." + (let ((alist gnus-topic-alist)) + (while alist + (gnus-topic-sort-topic (pop alist) func reverse)))) + +(defun gnus-topic-sort-topic (topic func reverse) + ;; Each topic only lists the name of the group, while + ;; the sort predicates expect group infos as inputs. + ;; So we first transform the group names into infos, + ;; then sort, and then transform back into group names. + (setcdr + topic + (mapcar + (lambda (info) (gnus-info-group info)) + (sort + (mapcar + (lambda (group) (gnus-get-info group)) + (cdr topic)) + func))) + ;; Do the reversal, if necessary. + (when reverse + (setcdr topic (nreverse (cdr topic))))) + +(defun gnus-topic-sort-groups (func &optional reverse) + "Sort the current topic according to FUNC. +If REVERSE, reverse the sorting order." + (interactive (list gnus-group-sort-function current-prefix-arg)) + (let ((topic (assoc (gnus-current-topic) gnus-topic-alist))) + (gnus-topic-sort-topic + topic (gnus-make-sort-function func) reverse) + (gnus-group-list-groups))) + +(defun gnus-topic-sort-groups-by-alphabet (&optional reverse) + "Sort the current topic alphabetically by group name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-alphabet reverse)) + +(defun gnus-topic-sort-groups-by-unread (&optional reverse) + "Sort the current topic by number of unread articles. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-unread reverse)) + +(defun gnus-topic-sort-groups-by-level (&optional reverse) + "Sort the current topic by group level. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-level reverse)) + +(defun gnus-topic-sort-groups-by-score (&optional reverse) + "Sort the current topic by group score. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-score reverse)) + +(defun gnus-topic-sort-groups-by-rank (&optional reverse) + "Sort the current topic by group rank. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-rank reverse)) + +(defun gnus-topic-sort-groups-by-method (&optional reverse) + "Sort the current topic alphabetically by backend name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) + (provide 'gnus-topic) ;;; gnus-topic.el ends here