X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-topic.el;h=9d7ec35ae188850be293f74f80fddbde02a2199c;hp=e95af935cba9a02764881e32d6ee01131fd91594;hb=21fd4405906dd1efdcdbdf0d5bf9195aea4602f8;hpb=f29cf6c482da66cfc1ca00877b6875e4262c5160 diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el index e95af935c..9d7ec35ae 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,97 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 +;; Free Software Foundation, Inc. ;; Author: Ilja Weis -;; Lars Magne Ingebrigtsen +;; Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. @@ -26,9 +27,12 @@ ;;; Code: +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-group) (require 'gnus-start) +(require 'gnus-util) (defgroup gnus-topic nil "Group topics." @@ -42,6 +46,9 @@ :type 'hook :group 'gnus-topic) +(when (featurep 'xemacs) + (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add)) + (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, @@ -53,7 +60,10 @@ 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. -" + +General format specifiers can also be used. +See Info node `(gnus)Formatting Variables'." + :link '(custom-manual "(gnus)Formatting Variables") :type 'string :group 'gnus-topic) @@ -71,6 +81,7 @@ with some simple extensions. (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.") @@ -93,22 +104,20 @@ with some simple extensions. (defun gnus-group-topic-name () "The name of the topic on the current line." - (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic))) + (let ((topic (get-text-property (point-at-bol) 'gnus-topic))) (and topic (symbol-name topic)))) (defun gnus-group-topic-level () "The level of the topic on the current line." - (get-text-property (gnus-point-at-bol) 'gnus-topic-level)) + (get-text-property (point-at-bol) 'gnus-topic-level)) (defun gnus-group-topic-unread () "The number of unread articles in topic on the current line." - (get-text-property (gnus-point-at-bol) 'gnus-topic-unread)) + (get-text-property (point-at-bol) 'gnus-topic-unread)) (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 () @@ -117,7 +126,7 @@ with some simple extensions. (defun gnus-topic-visible-p () "Return non-nil if the current topic is visible." - (get-text-property (gnus-point-at-bol) 'gnus-topic-visible)) + (get-text-property (point-at-bol) 'gnus-topic-visible)) (defun gnus-topic-articles-in-topic (entries) (let ((total 0) @@ -147,11 +156,23 @@ 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))) + (let ((buffer-read-only nil)) + (dolist (topic (gnus-current-topics topic)) + (unless (gnus-topic-goto-topic topic) + (gnus-topic-goto-missing-topic topic) + (gnus-topic-display-missing-topic topic)))) + (gnus-topic-goto-topic topic)) + (defun gnus-current-topic () "Return the name of the current topic." (let ((result @@ -164,9 +185,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) @@ -175,20 +197,19 @@ with some simple extensions. (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))) + (get-text-property (point-at-bol) 'gnus-active)) -(defun gnus-topic-find-groups (topic &optional level all) - "Return entries for all visible groups in TOPIC." +(defun gnus-topic-find-groups (topic &optional level all lowest recursive) + "Return entries for all visible groups in TOPIC. +If RECURSIVE is t, return groups in its subtopics too." (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 (when (setq group (pop groups)) - (setq entry (gnus-gethash group gnus-newsrc-hashtb) + (setq entry (gnus-group-entry group) info (nth 2 entry) params (gnus-info-params info) active (gnus-active group) @@ -197,18 +218,20 @@ with some simple extensions. active (- (1+ (cdr active)) (car active)))) clevel (or (gnus-info-level info) - (if (member group gnus-zombie-list) 8 9)))) + (if (member group gnus-zombie-list) + gnus-level-zombie gnus-level-killed)))) (and - unread ; nil means that the group is dead. + 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)) @@ -216,7 +239,40 @@ with some simple extensions. (cdr (assq 'visible params))) ;; Add this group to the list of visible groups. (push (or entry group) visible-groups))) - (nreverse visible-groups))) + (setq visible-groups (nreverse visible-groups)) + (when recursive + (if (eq recursive t) + (setq recursive (cdr (gnus-topic-find-topology topic)))) + (mapcar (lambda (topic-topology) + (setq visible-groups + (nconc visible-groups + (gnus-topic-find-groups + (caar topic-topology) + level all lowest topic-topology)))) + (cdr recursive))) + visible-groups)) + +(defun gnus-topic-goto-previous-topic (n) + "Go to the N'th previous topic." + (interactive "p") + (gnus-topic-goto-next-topic (- n))) + +(defun gnus-topic-goto-next-topic (n) + "Go to the N'th next topic." + (interactive "p") + (let ((backward (< n 0)) + (n (abs n)) + (topic (gnus-current-topic))) + (while (and (> n 0) + (setq topic + (if backward + (gnus-topic-previous-topic topic) + (gnus-topic-next-topic topic)))) + (gnus-topic-goto-topic topic) + (setq n (1- n))) + (when (/= 0 n) + (gnus-message 7 "No more topics")) + n)) (defun gnus-topic-previous-topic (topic) "Return the previous topic on the same level as TOPIC." @@ -322,27 +378,39 @@ with some simple extensions. (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) + (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 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))) + (nconc params-list + (gnus-topic-hierarchical-parameters + ;; First we try to go to the group within the group + ;; buffer and find the topic for the group that way. + ;; This hopefully copes well with groups that are in + ;; more than one topic. Failing that (i.e. when the + ;; group isn't visible in the group buffer) we find a + ;; topic for the group via gnus-group-topic. + (or (and (gnus-group-goto-group group) + (gnus-current-topic)) + (gnus-group-topic group))))))) + +(defun gnus-topic-hierarchical-parameters (topic) + "Return a topic list computed for TOPIC." + (let ((params-list (nreverse (mapcar 'gnus-topic-parameters + (gnus-current-topic topic)))) + param out params) + ;; 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 @@ -352,15 +420,22 @@ 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. -If ALL is non-nil, list groups that have no unread articles. +(defun gnus-group-prepare-topics (level &optional predicate 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 PREDICTE is a function, list groups that the function returns non-nil; +if it is t, 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))) + (lowest (or lowest 1)) + (not-in-list + (and gnus-group-listed-groups + (copy-sequence gnus-group-listed-groups)))) + (gnus-update-format-specifications nil 'topic) + (when (or (not gnus-topic-alist) (not gnus-topology-checked-p)) (gnus-topic-check-topology)) @@ -369,38 +444,63 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (erase-buffer)) ;; List dead groups? - (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)) + (when (or gnus-group-listed-groups + (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)) + (when (or gnus-group-listed-groups + (and (>= level gnus-level-killed) + (<= lowest gnus-level-killed))) (gnus-group-prepare-flat-list-dead (setq gnus-killed-list (sort gnus-killed-list 'string<)) - gnus-level-killed ?K - regexp)) + gnus-level-killed ?K regexp) + (when not-in-list + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) + (gnus-group-prepare-flat-list-dead + (gnus-remove-if (lambda (group) + (or (gnus-group-entry group) + (gnus-gethash group gnus-killed-hashtb))) + not-in-list) + gnus-level-killed ?K regexp))) ;; Use topics. (prog1 - (when (< lowest gnus-level-zombie) + (when (or (< lowest gnus-level-zombie) + gnus-group-listed-groups) (if list-topic (let ((top (gnus-topic-find-topology list-topic))) (gnus-topic-prepare-topic (cdr top) (car top) - (or topic-level level) all)) + (or topic-level level) predicate + nil lowest regexp)) (gnus-topic-prepare-topic gnus-topic-topology 0 - (or topic-level level) all))) - + (or topic-level level) predicate + nil lowest regexp))) (gnus-group-set-mode-line) - (setq gnus-group-list-mode (cons level all)) - (run-hooks 'gnus-group-prepare-hook)))) + (setq gnus-group-list-mode (cons level predicate)) + (gnus-run-hooks 'gnus-group-prepare-hook)))) -(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent) +(defun gnus-topic-prepare-topic (topicl level &optional list-level + predicate silent + lowest regexp) "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) + (if gnus-group-listed-groups + gnus-level-killed + list-level) + (or predicate gnus-group-listed-groups + (cdr (assq 'visible + (gnus-topic-hierarchical-parameters + (car type))))) + (if gnus-group-listed-groups 0 lowest))) (visiblep (and (eq (nth 1 type) 'visible) (not silent))) (gnus-group-indentation (make-string (* gnus-topic-indent-level level) ? )) @@ -415,31 +515,61 @@ articles in the topic and its subtopics." (while topicl (incf unread (gnus-topic-prepare-topic - (pop topicl) (1+ level) list-level all - (not visiblep)))) + (pop topicl) (1+ level) list-level predicate + (not visiblep) lowest regexp))) (setq end (point)) (goto-char beg) ;; Insert all the groups that belong in this topic. (while (setq entry (pop entries)) - (when visiblep - (if (stringp entry) - ;; Dead groups. - (gnus-group-insert-group-line - entry (if (member entry gnus-zombie-list) 8 9) - nil (- (1+ (cdr (setq active (gnus-active entry)))) - (car active)) - nil) - ;; Living groups. - (when (setq info (nth 2 entry)) - (gnus-group-insert-group-line - (gnus-info-group info) - (gnus-info-level info) (gnus-info-marks info) - (car entry) (gnus-info-method info))))) - (when (and (listp entry) - (numberp (car entry))) - (incf unread (car entry))) - (when (listp entry) - (setq tick t))) + (when (if (stringp entry) + (gnus-group-prepare-logic + entry + (and + (or (not gnus-group-listed-groups) + (if (< list-level gnus-level-zombie) nil + (let ((entry-level + (if (member entry gnus-zombie-list) + gnus-level-zombie gnus-level-killed))) + (and (<= entry-level list-level) + (>= entry-level lowest))))) + (cond + ((stringp regexp) + (string-match regexp entry)) + ((functionp regexp) + (funcall regexp entry)) + ((null regexp) t) + (t nil)))) + (setq info (nth 2 entry)) + (gnus-group-prepare-logic + (gnus-info-group info) + (and (or (not gnus-group-listed-groups) + (let ((entry-level (gnus-info-level info))) + (and (<= entry-level list-level) + (>= entry-level lowest)))) + (or (not (functionp predicate)) + (funcall predicate info)) + (or (not (stringp regexp)) + (string-match regexp (gnus-info-group info)))))) + (when visiblep + (if (stringp entry) + ;; Dead groups. + (gnus-group-insert-group-line + entry (if (member entry gnus-zombie-list) + gnus-level-zombie gnus-level-killed) + nil (- (1+ (cdr (setq active (gnus-active entry)))) + (car active)) + nil) + ;; Living groups. + (when (setq info (nth 2 entry)) + (gnus-group-insert-group-line + (gnus-info-group info) + (gnus-info-level info) (gnus-info-marks info) + (car entry) (gnus-info-method info))))) + (when (and (listp entry) + (numberp (car entry))) + (incf unread (car entry))) + (when (listp entry) + (setq tick t)))) (goto-char beg) ;; Insert the topic line. (when (and (not silent) @@ -452,6 +582,7 @@ articles in the topic and its subtopics." (car type) visiblep (not (eq (nth 2 type) 'hidden)) level all-entries unread)) + (gnus-topic-update-unreads (car type) unread) (goto-char end) unread)) @@ -472,7 +603,7 @@ articles in the topic and its subtopics." (let ((data (cadr (gnus-topic-find-topology topic)))) (setcdr data (list (if insert 'visible 'invisible) - (if hide 'hide nil) + (caddr data) (cadddr data)))) (if total-remove (setq gnus-topic-alist @@ -485,9 +616,9 @@ articles in the topic and its subtopics." (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)) @@ -506,18 +637,26 @@ articles in the topic and its subtopics." (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)) - (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." @@ -540,7 +679,7 @@ articles in the topic and its subtopics." (when (and (eq major-mode 'gnus-group-mode) gnus-topic-mode) (let ((group (gnus-group-group-name)) - (m (point-marker)) + (m (point-marker)) (buffer-read-only nil)) (when (and group (gnus-get-info group) @@ -555,9 +694,11 @@ articles in the topic and its subtopics." (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))) + (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) @@ -569,8 +710,31 @@ articles in the topic and its subtopics." (when (and unfound topic (not (gnus-topic-goto-missing-topic topic))) - (gnus-topic-insert-topic-line - topic t t (car (gnus-topic-find-topology topic)) nil 0))))) + (gnus-topic-display-missing-topic topic))))) + +(defun gnus-topic-display-missing-topic (topic) + "Insert topic lines recursively for missing topics." + (let ((parent (gnus-topic-find-topology + (gnus-topic-parent-topic topic)))) + (when (and parent + (not (gnus-topic-goto-missing-topic (caadr parent)))) + (gnus-topic-display-missing-topic (caadr parent)))) + (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))) + entry) + (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) @@ -579,15 +743,18 @@ articles in the topic and its subtopics." (let* ((top (gnus-topic-find-topology (gnus-topic-parent-topic topic))) (tp (reverse (cddr top)))) - (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)))) + (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) @@ -600,7 +767,7 @@ articles in the topic and its subtopics." (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 @@ -616,11 +783,14 @@ articles in the topic and its subtopics." (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 () @@ -671,8 +841,7 @@ articles in the topic and its subtopics." (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))) + (let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist))) (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist))) (newsrc (cdr gnus-newsrc-alist)) group) @@ -685,7 +854,8 @@ articles in the topic and its subtopics." topic) (while (setq topic (pop alist)) (while (cdr topic) - (if (gnus-gethash (cadr topic) gnus-newsrc-hashtb) + (if (and (cadr topic) + (gnus-group-entry (cadr topic))) (setq topic (cdr topic)) (setcdr topic (cddr topic))))))) @@ -715,7 +885,7 @@ articles in the topic and its subtopics." (let ((topic-name (pop topic)) group filtered-topic) (while (setq group (pop topic)) - (when (and (or (gnus-gethash group gnus-active-hashtb) + (when (and (or (gnus-active group) (gnus-info-method (gnus-get-info group))) (not (gnus-gethash group gnus-killed-hashtb))) (push group filtered-topic))) @@ -726,55 +896,60 @@ articles in the topic and its subtopics." "Run when changing levels to enter/remove groups from topics." (save-excursion (set-buffer gnus-group-buffer) - (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. - (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 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." @@ -870,6 +1045,8 @@ articles in the topic and its subtopics." "=" gnus-topic-select-group "\r" gnus-topic-select-group " " gnus-topic-read-group + "\C-c\C-x" gnus-topic-expire-articles + "c" gnus-topic-catchup-articles "\C-k" gnus-topic-kill-group "\C-y" gnus-topic-yank-group "\M-g" gnus-topic-get-new-news-this-topic @@ -877,6 +1054,10 @@ articles in the topic and its subtopics." "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. @@ -889,20 +1070,24 @@ articles in the topic and its subtopics." "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 + "\M-p" gnus-topic-goto-previous-topic + "\M-n" gnus-topic-goto-next-topic "\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) + "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 + "e" gnus-topic-sort-groups-by-server "v" gnus-topic-sort-groups-by-score "r" gnus-topic-sort-groups-by-rank "m" gnus-topic-sort-groups-by-method)) @@ -914,19 +1099,23 @@ articles in the topic and its subtopics." '("Topics" ["Toggle topics" gnus-topic-mode t] ("Groups" - ["Copy" gnus-topic-copy-group t] - ["Move" gnus-topic-move-group t] + ["Copy..." gnus-topic-copy-group t] + ["Move..." gnus-topic-move-group t] ["Remove" gnus-topic-remove-group t] - ["Copy matching" gnus-topic-copy-matching t] - ["Move matching" gnus-topic-move-matching t]) + ["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] + ["Rename..." gnus-topic-rename t] + ["Create..." gnus-topic-create-topic t] ["Mark" gnus-topic-mark-topic t] ["Indent" gnus-topic-indent t] + ["Sort" gnus-topic-sort-topics t] + ["Previous topic" gnus-topic-goto-previous-topic t] + ["Next topic" gnus-topic-goto-next-topic 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])))) @@ -944,11 +1133,11 @@ articles in the topic and its subtopics." (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)) - (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) - (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) + (gnus-set-format 'topic t) + (add-minor-mode 'gnus-topic-mode " Topic" + gnus-topic-mode-map nil (lambda (&rest junk) + (interactive) + (gnus-topic-mode nil t))) (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) (set (make-local-variable 'gnus-group-prepare-function) 'gnus-group-prepare-topics) @@ -964,18 +1153,18 @@ articles in the topic and its subtopics." '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-hook 'gnus-check-bogus-groups-hook) - (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) + (gnus-make-local-hook 'gnus-check-bogus-groups-hook) + (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist + nil 'local) (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 - 'gnus-topic-change-level) + (setq gnus-group-change-level-function nil) (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)) @@ -985,15 +1174,19 @@ articles in the topic and its subtopics." (defun gnus-topic-select-group (&optional all) "Select this newsgroup. No article is selected automatically. +If the group is opened, just switch the summary buffer. If ALL is non-nil, already read articles become readable. If ALL is a number, fetch this number of articles. If performed over a topic line, toggle folding the topic." (interactive "P") + (when (and (eobp) (not (gnus-group-group-name))) + (forward-line -1)) (if (gnus-group-topic-p) (let ((gnus-group-list-mode (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) - (gnus-topic-fold all)) + (gnus-topic-fold all) + (gnus-dribble-touch)) (gnus-group-select-group all))) (defun gnus-mouse-pick-topic (e) @@ -1002,6 +1195,36 @@ 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 + nil t)))) + (gnus-group-expire-articles nil)) + (gnus-message 5 "Expiring groups in %s...done" topic)))) + +(defun gnus-topic-catchup-articles (topic) + "Catchup this topic or group. +Also see `gnus-group-catchup'." + (interactive (list (gnus-group-topic-name))) + (if (not topic) + (call-interactively 'gnus-group-catchup-current) + (save-excursion + (let* ((groups + (mapcar (lambda (entry) (car (nth 2 entry))) + (gnus-topic-find-groups topic gnus-level-killed t + nil t))) + (buffer-read-only nil) + (gnus-group-marked groups)) + (gnus-group-catchup-current) + (mapcar 'gnus-topic-update-topics-containing-group groups))))) + (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 @@ -1031,7 +1254,7 @@ When used interactively, PARENT will be the topic under point." (unless parent (setq parent (caar gnus-topic-topology))) (let ((top (cdr (gnus-topic-find-topology parent))) - (full-topic (or full-topic `((,topic visible))))) + (full-topic (or full-topic (list (list topic 'visible nil nil))))) (unless top (error "No such parent topic: %s" parent)) (if previous @@ -1047,44 +1270,61 @@ When used interactively, PARENT will be the topic under point." (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)) + (gnus-completing-read "Move to topic" gnus-topic-alist nil t + 'gnus-topic-history))) + (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-group (progn (forward-line 1) (gnus-group-group-name))) (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-topic-enter-dribble) - (if start-group - (gnus-group-goto-group start-group) - (gnus-topic-goto-topic start-topic)) - (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 (&optional arg) +(defun gnus-topic-remove-group (&optional n) "Remove the current group from the topic." (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))))) + (let ((use-marked (and (not n) (not (gnus-region-active-p)) + gnus-group-marked t)) + (groups (gnus-group-process-prefix n))) + (mapc + (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) "Copy the current group to a topic." @@ -1106,7 +1346,12 @@ If COPYP, copy the groups instead." (gnus-topic-find-topology topic nil nil gnus-topic-topology) (gnus-topic-enter-dribble)) (gnus-group-kill-group n discard) - (gnus-topic-update-topic))) + (if (not (gnus-group-topic-p)) + (gnus-topic-update-topic) + ;; Move up one line so that we update the right topic. + (forward-line -1) + (gnus-topic-update-topic) + (forward-line 1)))) (defun gnus-topic-yank-group (&optional arg) "Yank the last topic." @@ -1156,44 +1401,69 @@ If COPYP, copy the groups instead." (setq alist (cdr alist)))))) (gnus-topic-update-topic))) -(defun gnus-topic-hide-topic () - "Hide the current topic." - (interactive) +(defun gnus-topic-hide-topic (&optional permanent) + "Hide the current topic. +If PERMANENT, make it stay hidden in subsequent sessions as well." + (interactive "P") (when (gnus-current-topic) (gnus-topic-goto-topic (gnus-current-topic)) - (gnus-topic-remove-topic nil nil 'hidden))) - -(defun gnus-topic-show-topic () - "Show the hidden topic." - (interactive) + (if permanent + (setcar (cddr + (cadr + (gnus-topic-find-topology (gnus-current-topic)))) + 'hidden)) + (gnus-topic-remove-topic nil nil))) + +(defun gnus-topic-show-topic (&optional permanent) + "Show the hidden topic. +If PERMANENT, make it stay shown in subsequent sessions as well." + (interactive "P") (when (gnus-group-topic-p) - (gnus-topic-remove-topic t nil 'shown))) - -(defun gnus-topic-mark-topic (topic &optional unmark) - "Mark all groups in the topic with the process mark." - (interactive (list (gnus-group-topic-name))) + (if (not permanent) + (gnus-topic-remove-topic t nil) + (let ((topic + (gnus-topic-find-topology + (completing-read "Show topic: " gnus-topic-alist nil t)))) + (setcar (cddr (cadr topic)) nil) + (setcar (cdr (cadr topic)) 'visible) + (gnus-group-list-groups))))) + +(defun gnus-topic-mark-topic (topic &optional unmark non-recursive) + "Mark all groups in the TOPIC with the process mark. +If NON-RECURSIVE (which is the prefix) is t, don't mark its subtopics." + (interactive (list (gnus-group-topic-name) + nil + (and current-prefix-arg t))) (if (not topic) (call-interactively 'gnus-group-mark-group) (save-excursion - (let ((groups (gnus-topic-find-groups topic 9 t))) + (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil + (not non-recursive)))) (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-group-topic-name))) +(defun gnus-topic-unmark-topic (topic &optional dummy non-recursive) + "Remove the process mark from all groups in the TOPIC. +If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics." + (interactive (list (gnus-group-topic-name) + nil + (and current-prefix-arg t))) (if (not topic) (call-interactively 'gnus-group-unmark-group) - (gnus-topic-mark-topic topic t))) + (gnus-topic-mark-topic topic t non-recursive))) (defun gnus-topic-get-new-news-this-topic (&optional n) "Check for new news in the current topic." (interactive "P") (if (not (gnus-group-topic-p)) (gnus-group-get-new-news-this-group n) - (gnus-topic-mark-topic (gnus-group-topic-name)) - (gnus-group-get-new-news-this-group))) + (let* ((topic (gnus-group-topic-name)) + (data (cadr (gnus-topic-find-topology topic)))) + (save-excursion + (gnus-topic-mark-topic topic nil (and n t)) + (gnus-group-get-new-news-this-group)) + (gnus-topic-remove-topic (eq 'visible (cadr data)))))) (defun gnus-topic-move-matching (regexp topic &optional copyp) "Move all groups that match REGEXP to some topic." @@ -1239,7 +1509,15 @@ If COPYP, copy the groups instead." (interactive (let ((topic (gnus-current-topic))) (list topic - (read-string (format "Rename %s to: " topic))))) + (read-string (format "Rename %s to: " topic) 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 @@ -1248,7 +1526,8 @@ If COPYP, copy the groups instead." (setcar entry new-name)) (forward-line -1) (gnus-dribble-touch) - (gnus-group-list-groups))) + (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. @@ -1266,7 +1545,7 @@ If UNINDENT, remove an indentation." (gnus-topic-kill-group) (push (cdar gnus-topic-killed-topics) gnus-topic-alist) (gnus-topic-create-topic - topic parent nil (cdaar gnus-topic-killed-topics)) + topic parent nil (cdar (car gnus-topic-killed-topics))) (pop gnus-topic-killed-topics) (or (gnus-topic-goto-topic topic) (gnus-topic-goto-topic parent)))))) @@ -1285,7 +1564,7 @@ If UNINDENT, remove an indentation." (push (cdar gnus-topic-killed-topics) gnus-topic-alist) (gnus-topic-create-topic topic grandparent (gnus-topic-next-topic parent) - (cdaar gnus-topic-killed-topics)) + (cdar (car gnus-topic-killed-topics))) (pop gnus-topic-killed-topics) (gnus-topic-goto-topic topic)))) @@ -1299,7 +1578,7 @@ 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." @@ -1402,6 +1681,81 @@ If REVERSE, sort in reverse order." (interactive "P") (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) +(defun gnus-topic-sort-groups-by-server (&optional reverse) + "Sort the current topic alphabetically by server name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-server reverse)) + +(defun gnus-topic-sort-topics-1 (top reverse) + (if (cdr top) + (let ((subtop + (mapcar (gnus-byte-compile + `(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 alphabetically 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) + (setcdr (last 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)) + ;; if this topic specifies a default level, use it + (let ((subscribe-level (cdr (assq 'subscribe-level + (gnus-topic-parameters topic))))) + (when subscribe-level + (gnus-group-change-level newsgroup subscribe-level + gnus-level-default-subscribed))) + (throw 'end t))) + nil))) + (provide 'gnus-topic) +;;; arch-tag: bf176856-f30c-40f0-ae77-e41529a1134c ;;; gnus-topic.el ends here