X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-topic.el;h=88fe35d8b0c230e10c09e8d68291fda0e7169caf;hb=d6b44b3c5ff2acbf182fc1223a610dbf9af98ba4;hp=fd27326dfb8934786ae8b56f1c584f35f6da7244;hpb=1a96d7bf660263f25557962103bc0ec2495d1d07;p=gnus diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el index fd27326df..88fe35d8b 100644 --- a/lisp/gnus-topic.el +++ b/lisp/gnus-topic.el @@ -1,8 +1,9 @@ ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Free Software Foundation, Inc. ;; Author: Ilja Weis -;; Lars Magne Ingebrigtsen +;; Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. @@ -26,18 +27,26 @@ ;;; Code: -(require 'gnus-load) +(eval-when-compile (require 'cl)) + +(require 'gnus) (require 'gnus-group) (require 'gnus-start) -(require 'gnus) +(require 'gnus-util) + +(defgroup gnus-topic nil + "Group topics." + :group 'gnus-group) (defvar gnus-topic-mode nil "Minor mode for Gnus group buffers.") -(defvar gnus-topic-mode-hook nil - "Hook run in topic mode buffers.") +(defcustom gnus-topic-mode-hook nil + "Hook run in topic mode buffers." + :type 'hook + :group 'gnus-topic) -(defvar gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" +(defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" "Format of topic lines. It works along the same lines as a normal formatting string, with some simple extensions. @@ -48,25 +57,31 @@ with some simple extensions. %g Number of groups in the topic. %a Number of unread articles in the groups in the topic. %A Number of unread articles in the groups in the topic and its subtopics. -") +" + :type 'string + :group 'gnus-topic) -(defvar gnus-topic-indent-level 2 - "*How much each subtopic should be indented.") +(defcustom gnus-topic-indent-level 2 + "*How much each subtopic should be indented." + :type 'integer + :group 'gnus-topic) -(defvar gnus-topic-display-empty-topics t - "*If non-nil, display the topic lines even of topics that have no unread articles.") +(defcustom gnus-topic-display-empty-topics t + "*If non-nil, display the topic lines even of topics that have no unread articles." + :type 'boolean + :group 'gnus-topic) ;; Internal variables. (defvar gnus-topic-active-topology nil) (defvar gnus-topic-active-alist nil) +(defvar gnus-topic-unreads 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) (defconst gnus-topic-line-format-alist `((?n name ?s) @@ -96,9 +111,7 @@ with some simple extensions. (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))) + (or (cdr (assoc topic gnus-topic-unreads)) 0)) (defun gnus-group-topic-p () @@ -137,11 +150,20 @@ with some simple extensions. (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-topic-jump-to-topic (topic) + "Go to TOPIC." + (interactive + (list (completing-read "Go to topic: " + (mapcar 'list (gnus-topic-list)) + nil t))) + (dolist (topic (gnus-current-topics topic)) + (gnus-topic-fold t)) + (gnus-topic-goto-topic topic)) + (defun gnus-current-topic () "Return the name of the current topic." (let ((result @@ -154,9 +176,10 @@ with some simple extensions. (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)) +(defun gnus-current-topics (&optional topic) + "Return a list of all current topics, lowest in hierarchy first. +If TOPIC, start with that topic." + (let ((topic (or topic (gnus-current-topic))) topics) (while topic (push topic topics) @@ -169,35 +192,38 @@ with some simple extensions. (beginning-of-line) (get-text-property (point) 'gnus-active))) -(defun gnus-topic-find-groups (topic &optional level all) +(defun gnus-topic-find-groups (topic &optional level all lowest) "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) + info clevel unread group params visible-groups entry active) (setq lowest (or lowest 1)) - (setq level (or level 7)) + (setq level (or level gnus-level-unsubscribed)) ;; 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) + (when (setq group (pop groups)) + (setq entry (gnus-gethash group 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) + gnus-level-zombie gnus-level-killed)))) + (and + info ; nil means that the group is dead. + (<= clevel level) (>= clevel lowest) ; Is inside the level we want. (or all - (if (eq unread t) + (if (or (eq unread t) + (eq unread nil)) gnus-group-list-inactive-groups (> unread 0)) (and gnus-list-groups-with-ticked-articles (cdr (assq 'tick (gnus-info-marks info)))) - ; Has right readedness. + ;; Has right readedness. ;; Check for permanent visibility. (and gnus-permanently-visible-groups (string-match gnus-permanently-visible-groups group)) @@ -224,14 +250,14 @@ with some simple extensions. result found) (while (and topology (not (setq found (equal (caaar topology) topic))) - (not (setq result (gnus-topic-parent-topic topic - (car topology))))) + (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 + (let ((parentt (cddr (gnus-topic-find-topology (gnus-topic-parent-topic topic)))) prev) (while (and parentt @@ -242,6 +268,20 @@ with some simple extensions. prev (caaadr parentt)))) +(defun gnus-topic-forward-topic (num) + "Go to the next topic on the same level as the current one." + (let* ((topic (gnus-current-topic)) + (way (if (< num 0) 'gnus-topic-previous-topic + 'gnus-topic-next-topic)) + (num (abs num))) + (while (and (not (zerop num)) + (setq topic (funcall way topic))) + (when (gnus-topic-goto-topic topic) + (decf num))) + (unless (zerop num) + (goto-char (point-max))) + num)) + (defun gnus-topic-find-topology (topic &optional topology level remove) "Return the topology of TOPIC." (unless topology @@ -266,7 +306,7 @@ with some simple extensions. (defun gnus-topic-list (&optional topology) "Return a list of all topics in the topology." (unless topology - (setq topology gnus-topic-topology + (setq topology gnus-topic-topology gnus-tmp-topics nil)) (push (caar topology) gnus-tmp-topics) (mapcar 'gnus-topic-list (cdr topology)) @@ -277,9 +317,8 @@ with some simple extensions. (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)))) + (when top + (nth 3 (cadr top))))) (defun gnus-topic-set-parameters (topic parameters) "Set the topic parameters of TOPIC to PARAMETERS." @@ -288,37 +327,44 @@ with some simple extensions. (error "No such topic: %s" topic)) ;; We may have to extend if there is no parameters here ;; to begin with. - (unless (nthcdr 2 (car top)) - (nconc (car top) (list nil))) - (unless (nthcdr 3 (car top)) - (nconc (car top) (list nil))) - (setcar (nthcdr 3 (car top)) parameters))) + (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 inheretance from topics." - (let ((params-list (list (gnus-group-get-parameter group))) - topics params param out) + "Compute the group parameters for GROUP taking into account inheritance from topics." + (let ((params-list (copy-sequence (gnus-group-get-parameter group)))) (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 inheretance 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 funtions + (nconc params-list + (gnus-topic-hierarchical-parameters (gnus-current-topic)))))) + +(defun gnus-topic-hierarchical-parameters (topic) + "Return a topic list computed for TOPIC." + (let ((topics (gnus-current-topics topic)) + params-list param out params) + (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. + (gnus-pull (car param) out) + (push param out))) + ;; Return the resulting parameter list. + out)) + +;;; General utility functions (defun gnus-topic-enter-dribble () (gnus-dribble-enter @@ -326,104 +372,119 @@ with some simple extensions. ;;; 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. +(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. +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 + (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<)) + (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 + (gnus-group-prepare-flat-list-dead (setq gnus-killed-list (sort gnus-killed-list 'string<)) gnus-level-killed ?K regexp)) ;; Use topics. - (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) + (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 + nil lowest)) + (gnus-topic-prepare-topic gnus-topic-topology 0 + (or topic-level level) all + nil lowest))) + + (gnus-group-set-mode-line) + (setq gnus-group-list-mode (cons level all)) + (gnus-run-hooks 'gnus-group-prepare-hook)))) + +(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent + lowest) "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)) + (entries (gnus-topic-find-groups + (car type) list-level + (or all + (cdr (assq 'visible + (gnus-topic-hierarchical-parameters + (car type))))) + lowest)) (visiblep (and (eq (nth 1 type) 'visible) (not silent))) - (gnus-group-indentation + (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) + info entry end active tick) ;; Insert any sub-topics. (while topicl (incf unread - (gnus-topic-prepare-topic + (gnus-topic-prepare-topic (pop topicl) (1+ level) list-level all - (not visiblep)))) + (not visiblep) lowest))) (setq end (point)) (goto-char beg) ;; Insert all the groups that belong in this topic. (while (setq entry (pop entries)) - (when visiblep + (when visiblep (if (stringp entry) ;; Dead groups. (gnus-group-insert-group-line - entry (if (member entry gnus-zombie-list) 8 9) + entry (if (member entry gnus-zombie-list) + gnus-level-zombie gnus-level-killed) 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-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)) - (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)))) + (numberp (car entry))) + (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 - (not (zerop unread)))) + (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 + (gnus-topic-insert-topic-line (car type) visiblep (not (eq (nth 2 type) 'hidden)) level all-entries unread)) + (gnus-topic-update-unreads (car type) unread) (goto-char end) unread)) @@ -437,23 +498,29 @@ 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) + hide + (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 + (gnus-group-prepare-topics (car gnus-group-list-mode) (cdr gnus-group-list-mode) nil nil topic level)) - -(defun gnus-topic-fold (&optional insert) + +(defun gnus-topic-fold (&optional insert topic) "Remove/insert the current topic." - (let ((topic (gnus-group-topic-name))) + (let ((topic (or topic (gnus-group-topic-name)))) (when topic (save-excursion (if (not (gnus-group-active-topic-p)) @@ -463,46 +530,74 @@ articles in the topic and its subtopics." (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))))))) + (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 +(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))) + (active-topic (eq gnus-topic-alist gnus-topic-active-alist)) + gnus-tmp-header) + (gnus-topic-update-unreads name unread) (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)))) + (if shownp + (gnus-add-text-properties + (point) + (prog1 (1+ (point)) + (eval gnus-topic-line-format-spec)) + (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-unreads (topic unreads) + (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads) + gnus-topic-unreads)) + (push (cons topic unreads) gnus-topic-unreads)) + +(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)) + (m (point-marker)) (buffer-read-only nil)) - (when (and group (gnus-get-info group) + (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) + (goto-char m) + (set-marker m nil) (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)) + (unfound t) + entry) ;; Try to jump to a visible group. (while (and g (not (gnus-group-goto-group (car g) t))) (pop g)) @@ -513,21 +608,56 @@ articles in the topic and its subtopics." (when (gnus-group-goto-group (pop g) t) (forward-line 1) (setq unfound nil))) - (when unfound - (gnus-topic-goto-topic topic) - (forward-line 1))))) + (when (and unfound + topic + (not (gnus-topic-goto-missing-topic topic))) + (let* ((top (gnus-topic-find-topology topic)) + (children (cddr top)) + (type (cadr top)) + (unread 0) + (entries (gnus-topic-find-groups + (car type) (car gnus-group-list-mode) + (cdr gnus-group-list-mode)))) + (while children + (incf unread (gnus-topic-unread (caar (pop children))))) + (while (setq entry (pop entries)) + (when (numberp (car entry)) + (incf unread (car entry)))) + (gnus-topic-insert-topic-line + topic t t (car (gnus-topic-find-topology topic)) nil unread)))))) + +(defun gnus-topic-goto-missing-topic (topic) + (if (gnus-topic-goto-topic topic) + (forward-line 1) + ;; Topic not displayed. + (let* ((top (gnus-topic-find-topology + (gnus-topic-parent-topic topic))) + (tp (reverse (cddr top)))) + (if (not top) + (gnus-topic-insert-topic-line + topic t t (car (gnus-topic-find-topology topic)) nil 0) + (while (not (equal (caaar tp) topic)) + (setq tp (cdr tp))) + (pop tp) + (while (and tp + (not (gnus-topic-goto-topic (caaar tp)))) + (pop tp)) + (if tp + (gnus-topic-forward-topic 1) + (gnus-topic-goto-missing-topic (caadr top))))) + nil)) (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 + (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) + old-unread entry new-unread) (when (gnus-topic-goto-topic (car type)) ;; Tally all the groups that belong in this topic. (if reads @@ -539,23 +669,29 @@ articles in the topic and its subtopics." (incf unread (car entry))))) (setq old-unread (gnus-group-topic-unread)) ;; Insert the topic line. - (gnus-topic-insert-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)) + (gnus-delete-line) + (forward-line -1) + (setq new-unread (gnus-group-topic-unread))) (when parent (forward-line -1) (gnus-topic-update-topic-line - parent (- old-unread (gnus-group-topic-unread)))) + parent + (- (or old-unread 0) (or new-unread 0)))) unread)) (defun gnus-topic-group-indentation () - (make-string + (make-string (* gnus-topic-indent-level (or (save-excursion + (forward-line -1) (gnus-topic-goto-topic (gnus-current-topic)) - (gnus-group-topic-level)) 0)) ? )) + (gnus-group-topic-level)) + 0)) + ? )) ;;; Initialization @@ -565,10 +701,9 @@ articles in the topic and its subtopics." (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 () +(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 @@ -598,18 +733,20 @@ articles in the topic and its subtopics." ;; 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) + (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist))) + (newsrc (cdr gnus-newsrc-alist)) group) (while newsrc (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) - (setcdr entry (cons group (cdr entry)))))) + (setcdr entry (list group)) + (setq entry (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) + (if (and (cadr topic) + (gnus-gethash (cadr topic) gnus-newsrc-hashtb)) (setq topic (cdr topic)) (setcdr topic (cddr topic))))))) @@ -639,71 +776,82 @@ articles in the topic and its subtopics." (let ((topic-name (pop topic)) group filtered-topic) (while (setq group (pop topic)) - (if (and (gnus-gethash group gnus-active-hashtb) - (not (gnus-gethash group gnus-killed-hashtb))) - (push group filtered-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) +(defun gnus-topic-change-level (group level oldlevel &optional previous) "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))))) + (let ((buffer-read-only nil)) + (unless gnus-topic-inhibit-change-level + (gnus-group-goto-group (or (car (nth 2 previous)) group)) + (when (and gnus-topic-mode + gnus-topic-alist + (not gnus-topic-inhibit-change-level)) + ;; Remove the group from the topics. + (if (and (< oldlevel gnus-level-zombie) + (>= level gnus-level-zombie)) + (let ((alist gnus-topic-alist)) + (while (gnus-group-goto-group group) + (gnus-delete-line)) + (while alist + (when (member group (car alist)) + (setcdr (car alist) (delete group (cdar alist)))) + (pop alist))) + ;; If the group is subscribed 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 (not group) + (if (not (memq 'gnus-topic props)) + (goto-char (point-max)) + (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-current-topic) gnus-topic-alist)) + (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 @@ -712,20 +860,22 @@ articles in the topic and its subtopics." ;; Then try to put point on a group before point. (unless after (setq after (cdr (member group (reverse (cdr list))))) - (while (and after + (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)) + (if (not (car list)) + (goto-char (point-min)) + (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. + ;; First we make sure that we have really read the active file. (when (or force (not gnus-topic-active-alist)) (let (groups) @@ -755,8 +905,8 @@ articles in the topic and its subtopics." ;; topic. (push (pop groups) tgroups) ;; New sub-hierarchy, so we add it to the topology. - (nconc topology (list (setq ntopology - (list (list (substring + (nconc topology (list (setq ntopology + (list (list (substring group 0 (match-end 0)) 'invisible))))) ;; Descend the hierarchy. @@ -782,35 +932,52 @@ 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 - "Gp" gnus-topic-edit-parameters - 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-c\C-x" gnus-topic-expire-articles + "\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-topic-mark-topic + "\M-#" gnus-topic-unmark-topic + [tab] gnus-topic-indent + [(meta tab)] gnus-topic-unindent + "\C-i" gnus-topic-indent + "\M-\C-i" gnus-topic-unindent + 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 + "j" gnus-topic-jump-to-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 + [delete] gnus-topic-delete + "H" gnus-topic-toggle-display-empty-topics) + + (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) @@ -825,13 +992,17 @@ articles in the topic and its subtopics." ["Copy matching" gnus-topic-copy-matching t] ["Move matching" gnus-topic-move-matching t]) ("Topics" + ["Goto" gnus-topic-jump-to-topic t] ["Show" gnus-topic-show-topic t] ["Hide" gnus-topic-hide-topic t] ["Delete" gnus-topic-delete t] ["Rename" gnus-topic-rename t] ["Create" gnus-topic-create-topic t] ["Mark" gnus-topic-mark-topic t] - ["Indent" gnus-topic-indent t]) + ["Indent" gnus-topic-indent t] + ["Sort" gnus-topic-sort-topics t] + ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t] + ["Edit parameters" gnus-topic-edit-parameters t]) ["List active" gnus-topic-list-active t])))) (defun gnus-topic-mode (&optional arg redisplay) @@ -839,25 +1010,17 @@ articles in the topic and its subtopics." (interactive (list current-prefix-arg t)) (when (eq major-mode 'gnus-group-mode) (make-local-variable 'gnus-topic-mode) - (setq gnus-topic-mode + (setq gnus-topic-mode (if (null arg) (not gnus-topic-mode) (> (prefix-numeric-value arg) 0))) ;; Infest Gnus with topics. - (when gnus-topic-mode - (when (and menu-bar-mode - (gnus-visual-p 'topic-menu 'menu)) + (if (not gnus-topic-mode) + (setq gnus-goto-missing-group-function nil) + (when (gnus-visual-p 'topic-menu 'menu) (gnus-topic-make-menu-bar)) - (setq gnus-topic-line-format-spec - (gnus-parse-format gnus-topic-line-format - gnus-topic-line-format-alist t)) - (unless (assq 'gnus-topic-mode minor-mode-alist) - (push '(gnus-topic-mode " Topic") minor-mode-alist)) - (unless (assq 'gnus-topic-mode minor-mode-map-alist) - (push (cons 'gnus-topic-mode gnus-topic-mode-map) - minor-mode-map-alist)) - (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) + (gnus-set-format 'topic t) + (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) - (add-hook 'gnus-group-update-group-hook 'gnus-topic-update-topic) (set (make-local-variable 'gnus-group-prepare-function) 'gnus-group-prepare-topics) (set (make-local-variable 'gnus-group-get-parameter-function) @@ -866,25 +1029,30 @@ articles in the topic and its subtopics." '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) - (gnus-make-local-hook 'gnus-check-bogus-groups-hook) + (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. (when gnus-newsrc-alist (gnus-topic-check-topology)) - (run-hooks 'gnus-topic-mode-hook)) + (gnus-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 + (remove-hook 'gnus-group-change-level-function 'gnus-topic-change-level) (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) - (setq gnus-group-prepare-function 'gnus-group-prepare-flat)) + (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)))) - + (defun gnus-topic-select-group (&optional all) "Select this newsgroup. No article is selected automatically. @@ -894,7 +1062,7 @@ 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 + (let ((gnus-group-list-mode (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) (gnus-topic-fold all)) (gnus-group-select-group all))) @@ -905,6 +1073,19 @@ If performed over a topic line, toggle folding the topic." (mouse-set-point e) (gnus-topic-read-group nil)) +(defun gnus-topic-expire-articles (topic) + "Expire articles in this topic or group." + (interactive (list (gnus-group-topic-name))) + (if (not topic) + (call-interactively 'gnus-group-expire-articles) + (save-excursion + (gnus-message 5 "Expiring groups in %s..." topic) + (let ((gnus-group-marked + (mapcar (lambda (entry) (car (nth 2 entry))) + (gnus-topic-find-groups topic gnus-level-killed t)))) + (gnus-group-expire-articles nil)) + (gnus-message 5 "Expiring groups in %s...done" topic)))) + (defun gnus-topic-read-group (&optional all no-article group) "Read news in this newsgroup. If the prefix argument ALL is non-nil, already read articles become @@ -916,19 +1097,21 @@ group. If performed over a topic line, toggle folding the topic." (interactive "P") (if (gnus-group-topic-p) - (let ((gnus-group-list-mode + (let ((gnus-group-list-mode (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) (gnus-topic-fold all)) (gnus-group-read-group all no-article group))) (defun gnus-topic-create-topic (topic parent &optional previous full-topic) - (interactive + "Create a new TOPIC under PARENT. +When used interactively, PARENT will be the topic under point." + (interactive (list (read-string "New 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))) @@ -948,37 +1131,59 @@ If performed over a topic line, toggle folding the topic." (gnus-group-list-groups) (gnus-topic-goto-topic topic)) +;; FIXME: +;; 1. When the marked groups are overlapped with the process +;; region, the behavior of move or remove is not right. +;; 2. Can't process on several marked groups with a same name, +;; because gnus-group-marked only keeps one copy. + (defun gnus-topic-move-group (n topic &optional copyp) "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)) + (let ((use-marked (and (not n) (not (gnus-region-active-p)) + gnus-group-marked t)) + (groups (gnus-group-process-prefix n)) (topicl (assoc topic gnus-topic-alist)) + (start-topic (gnus-group-topic-name)) + (start-group (progn (forward-line 1) (gnus-group-group-name))) entry) - (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-group-position-point)) - (gnus-topic-enter-dribble) - (gnus-group-list-groups)) + (if (and (not groups) (not copyp) start-topic) + (gnus-topic-move start-topic topic) + (mapcar + (lambda (g) + (gnus-group-remove-mark g use-marked) + (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 n) "Remove the current group from the topic." - (interactive) - (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) - (group (gnus-group-group-name)) - (buffer-read-only nil)) - (when (and topicl group) - (gnus-delete-line) - (gnus-delete-first group topicl)) + (interactive "P") + (let ((use-marked (and (not n) (not (gnus-region-active-p)) + gnus-group-marked t)) + (groups (gnus-group-process-prefix n))) + (mapcar + (lambda (group) + (gnus-group-remove-mark group use-marked) + (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))) + groups) + (gnus-topic-enter-dribble) (gnus-group-position-point))) (defun gnus-topic-copy-group (n topic) @@ -993,37 +1198,47 @@ If COPYP, copy the groups instead." (interactive "P") (if (gnus-group-topic-p) (let ((topic (gnus-group-topic-name))) + (push (cons + (gnus-topic-find-topology topic) + (assoc topic gnus-topic-alist)) + gnus-topic-killed-topics) (gnus-topic-remove-topic nil t) - (push (gnus-topic-find-topology topic nil nil gnus-topic-topology) - gnus-topic-killed-topics)) + (gnus-topic-find-topology topic nil nil gnus-topic-topology) + (gnus-topic-enter-dribble)) (gnus-group-kill-group n discard) (gnus-topic-update-topic))) - + (defun gnus-topic-yank-group (&optional arg) "Yank the last topic." (interactive "p") (if gnus-topic-killed-topics - (let ((previous - (or (gnus-group-topic-name) - (gnus-topic-next-topic (gnus-current-topic)))) - (item (cdr (pop gnus-topic-killed-topics)))) + (let* ((previous + (or (gnus-group-topic-name) + (gnus-topic-next-topic (gnus-current-topic)))) + (data (pop gnus-topic-killed-topics)) + (alist (cdr data)) + (item (cdar data))) + (push alist gnus-topic-alist) (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) (gnus-group-indentation - (make-string + (make-string (* gnus-topic-indent-level (or (save-excursion (gnus-topic-goto-topic (gnus-current-topic)) - (gnus-group-topic-level)) 0)) ? )) + (gnus-group-topic-level)) + 0)) + ? )) yanked alist) ;; We first yank the groups the normal way... (setq yanked (gnus-group-yank-group arg)) ;; Then we enter the yanked groups into the topics they belong - ;; to. + ;; to. (setq alist (assoc (save-excursion (forward-line -1) (gnus-current-topic)) @@ -1046,27 +1261,31 @@ If COPYP, copy the groups instead." (interactive) (when (gnus-current-topic) (gnus-topic-goto-topic (gnus-current-topic)) - (gnus-topic-remove-topic nil nil 'hidden))) + (gnus-topic-remove-topic nil nil))) (defun gnus-topic-show-topic () "Show the hidden topic." (interactive) (when (gnus-group-topic-p) - (gnus-topic-remove-topic t nil 'shown))) + (gnus-topic-remove-topic t nil))) (defun gnus-topic-mark-topic (topic &optional unmark) "Mark all groups in the topic with the process mark." - (interactive (list (gnus-current-topic))) - (save-excursion - (let ((groups (gnus-topic-find-groups topic 9 t))) - (while groups - (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) - (gnus-info-group (nth 2 (pop groups)))))))) + (interactive (list (gnus-group-topic-name))) + (if (not topic) + (call-interactively 'gnus-group-mark-group) + (save-excursion + (let ((groups (gnus-topic-find-groups topic gnus-level-killed t))) + (while groups + (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) + (gnus-info-group (nth 2 (pop groups))))))))) (defun gnus-topic-unmark-topic (topic &optional unmark) "Remove the process mark from all groups in the topic." - (interactive (list (gnus-current-topic))) - (gnus-topic-mark-topic topic t)) + (interactive (list (gnus-group-topic-name))) + (if (not topic) + (call-interactively 'gnus-group-unmark-group) + (gnus-topic-mark-topic topic t))) (defun gnus-topic-get-new-news-this-topic (&optional n) "Check for new news in the current topic." @@ -1112,7 +1331,8 @@ If COPYP, copy the groups instead." ;; Remove from alist. (setq gnus-topic-alist (delq entry gnus-topic-alist)) ;; Remove from topology. - (gnus-topic-find-topology topic nil nil 'delete))) + (gnus-topic-find-topology topic nil nil 'delete) + (gnus-dribble-touch))) (defun gnus-topic-rename (old-name new-name) "Rename a topic." @@ -1120,14 +1340,24 @@ If COPYP, copy the groups instead." (let ((topic (gnus-current-topic))) (list topic (read-string (format "Rename %s to: " topic))))) + ;; Check whether the new name exists. + (when (gnus-topic-find-topology new-name) + (error "Topic '%s' already exists" new-name)) + ;; "nil" is an invalid name, for reasons I'd rather not go + ;; into here. Trust me. + (when (equal new-name "nil") + (error "Invalid name: %s" nil)) + ;; Do the renaming. (let ((top (gnus-topic-find-topology old-name)) (entry (assoc old-name gnus-topic-alist))) (when top (setcar (cadr top) new-name)) - (when entry + (when entry (setcar entry new-name)) (forward-line -1) - (gnus-group-list-groups))) + (gnus-dribble-touch) + (gnus-group-list-groups) + (forward-line 1))) (defun gnus-topic-indent (&optional unindent) "Indent a topic -- make it a sub-topic of the previous topic. @@ -1136,14 +1366,17 @@ If UNINDENT, remove an indentation." (if unindent (gnus-topic-unindent) (let* ((topic (gnus-current-topic)) - (parent (gnus-topic-previous-topic topic))) + (parent (gnus-topic-previous-topic topic)) + (buffer-read-only nil)) (unless parent (error "Nothing to indent %s into" topic)) (when topic (gnus-topic-goto-topic topic) (gnus-topic-kill-group) + (push (cdar gnus-topic-killed-topics) gnus-topic-alist) (gnus-topic-create-topic - topic parent nil (cdr (pop gnus-topic-killed-topics))) + topic parent nil (cdaar gnus-topic-killed-topics)) + (pop gnus-topic-killed-topics) (or (gnus-topic-goto-topic topic) (gnus-topic-goto-topic parent)))))) @@ -1158,9 +1391,11 @@ If UNINDENT, remove an indentation." (when topic (gnus-topic-goto-topic topic) (gnus-topic-kill-group) + (push (cdar gnus-topic-killed-topics) gnus-topic-alist) (gnus-topic-create-topic topic grandparent (gnus-topic-next-topic parent) - (cdr (pop gnus-topic-killed-topics))) + (cdaar gnus-topic-killed-topics)) + (pop gnus-topic-killed-topics) (gnus-topic-goto-topic topic)))) (defun gnus-topic-list-active (&optional force) @@ -1173,7 +1408,19 @@ If FORCE, always re-read the active file." (let ((gnus-topic-topology gnus-topic-active-topology) (gnus-topic-alist gnus-topic-active-alist) gnus-killed-list gnus-zombie-list) - (gnus-group-list-groups 9 nil 1))) + (gnus-group-list-groups gnus-level-killed nil 1))) + +(defun gnus-topic-toggle-display-empty-topics () + "Show/hide topics that have no unread articles." + (interactive) + (setq gnus-topic-display-empty-topics + (not gnus-topic-display-empty-topics)) + (gnus-group-list-groups) + (message "%s empty topics" + (if gnus-topic-display-empty-topics + "Showing" "Hiding"))) + +;;; Topic sorting functions (defun gnus-topic-edit-parameters (group) "Edit the group parameters of GROUP. @@ -1182,14 +1429,150 @@ If performed on a topic, edit the topic parameters instead." (if group (gnus-group-edit-group-parameters group) (if (not (gnus-group-topic-p)) - (error "Nothing to edit on the current line.") + (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." + (format "Editing the topic parameters for `%s'." + (or group topic)) `(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 + ;; !!!Sometimes nil elements sneak into the alist, + ;; for some reason or other. + (setcar alist (delq nil (car alist))) + (setcar alist (delete "dummy.group" (car 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)) + +(defun gnus-topic-sort-topics-1 (top reverse) + (if (cdr top) + (let ((subtop + (mapcar `(lambda (top) + (gnus-topic-sort-topics-1 top ,reverse)) + (sort (cdr top) + '(lambda (t1 t2) + (string-lessp (caar t1) (caar t2))))))) + (setcdr top (if reverse (reverse subtop) subtop)))) + top) + +(defun gnus-topic-sort-topics (&optional topic reverse) + "Sort topics in TOPIC alphabeticaly by topic name. +If REVERSE, reverse the sorting order." + (interactive + (list (completing-read "Sort topics in : " gnus-topic-alist nil t + (gnus-current-topic)) + current-prefix-arg)) + (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic))) + gnus-topic-topology))) + (gnus-topic-sort-topics-1 topic-topology reverse) + (gnus-topic-enter-dribble) + (gnus-group-list-groups) + (gnus-topic-goto-topic topic))) + +(defun gnus-topic-move (current to) + "Move the CURRENT topic to TO." + (interactive + (list + (gnus-group-topic-name) + (completing-read "Move to topic: " gnus-topic-alist nil t))) + (unless (and current to) + (error "Can't find topic")) + (let ((current-top (cdr (gnus-topic-find-topology current))) + (to-top (cdr (gnus-topic-find-topology to)))) + (unless current-top + (error "Can't find topic `%s'" current)) + (unless to-top + (error "Can't find topic `%s'" to)) + (if (gnus-topic-find-topology to current-top 0);; Don't care the level + (error "Can't move `%s' to its sub-level" current)) + (gnus-topic-find-topology current nil nil 'delete) + (while (cdr to-top) + (setq to-top (cdr to-top))) + (setcdr to-top (list current-top)) + (gnus-topic-enter-dribble) + (gnus-group-list-groups) + (gnus-topic-goto-topic current))) + +(defun gnus-subscribe-topics (newsgroup) + (catch 'end + (let (match gnus-group-change-level-function) + (dolist (topic (gnus-topic-list)) + (when (and (setq match (cdr (assq 'subscribe + (gnus-topic-parameters topic)))) + (string-match match newsgroup)) + ;; Just subscribe the group. + (gnus-subscribe-alphabetically newsgroup) + ;; Add the group to the topic. + (nconc (assoc topic gnus-topic-alist) (list newsgroup)) + (throw 'end t)))))) + (provide 'gnus-topic) ;;; gnus-topic.el ends here