X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-topic.el;h=0f45fd379e30d138f85218e494e5647d3360af97;hb=9b741e050b400987d68ff761c6cc3276c932839c;hp=7420265ee0fab444808a903efb7381095152431d;hpb=de3d8f7666167551f9a60d27366eb97cb707fa61;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el index 7420265..0f45fd3 100644 --- a/lisp/gnus-topic.el +++ b/lisp/gnus-topic.el @@ -1,5 +1,5 @@ ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 ;; Free Software Foundation, Inc. ;; Author: Ilja Weis @@ -47,6 +47,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, @@ -58,7 +61,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 (gnus)Formatting Variables." + :link '(custom-manual "(gnus)Formatting Variables") :type 'string :group 'gnus-topic) @@ -162,9 +168,10 @@ with some simple extensions. (mapcar 'list (gnus-topic-list)) nil t))) (dolist (topic (gnus-current-topics topic)) + (gnus-topic-goto-topic topic) (gnus-topic-fold t)) (gnus-topic-goto-topic topic)) - + (defun gnus-current-topic () "Return the name of the current topic." (let ((result @@ -197,7 +204,7 @@ If TOPIC, start with that topic." "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 params visible-groups entry active) + info clevel unread group params visible-groups entry active) (setq lowest (or lowest 1)) (setq level (or level gnus-level-unsubscribed)) ;; We go through the newsrc to look for matches. @@ -234,18 +241,40 @@ If RECURSIVE is t, return groups in its subtopics too." ;; Add this group to the list of visible groups. (push (or entry group) visible-groups))) (setq visible-groups (nreverse visible-groups)) - (when recursive + (when recursive (if (eq recursive t) (setq recursive (cdr (gnus-topic-find-topology topic)))) (mapcar (lambda (topic-topology) - (setq visible-groups - (nconc visible-groups + (setq visible-groups + (nconc visible-groups (gnus-topic-find-groups - (caar topic-topology) + (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." (let ((top (cddr (gnus-topic-find-topology @@ -352,9 +381,17 @@ If RECURSIVE is t, return groups in its subtopics too." "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) (nconc params-list - (gnus-topic-hierarchical-parameters (gnus-current-topic)))))) + (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." @@ -394,8 +431,8 @@ 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)) - (not-in-list + (lowest (or lowest 1)) + (not-in-list (and gnus-group-listed-groups (copy-sequence gnus-group-listed-groups)))) @@ -416,17 +453,20 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." regexp)) (when (or gnus-group-listed-groups - (and (>= level gnus-level-killed) - (<= lowest gnus-level-killed))) + (and (>= level gnus-level-killed) + (<= lowest gnus-level-killed))) (gnus-group-prepare-flat-list-dead - (gnus-union - (and not-in-list - (gnus-delete-if (lambda (group) - (< (gnus-group-level group) gnus-level-killed)) - not-in-list)) - (setq gnus-killed-list (sort gnus-killed-list 'string<))) - gnus-level-killed ?K - regexp)) + (setq gnus-killed-list (sort gnus-killed-list 'string<)) + 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-delete-if (lambda (group) + (or (gnus-gethash group gnus-newsrc-hashtb) + (gnus-gethash group gnus-killed-hashtb))) + not-in-list) + gnus-level-killed ?K regexp))) ;; Use topics. (prog1 @@ -444,7 +484,7 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (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 +(defun gnus-topic-prepare-topic (topicl level &optional list-level predicate silent lowest regexp) "Insert TOPIC into the group buffer. @@ -452,8 +492,8 @@ 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) - (if gnus-group-listed-groups + (car type) + (if gnus-group-listed-groups gnus-level-killed list-level) (or predicate gnus-group-listed-groups @@ -482,7 +522,7 @@ articles in the topic and its subtopics." ;; Insert all the groups that belong in this topic. (while (setq entry (pop entries)) (when (if (stringp entry) - (gnus-group-prepare-logic + (gnus-group-prepare-logic entry (and (or (not gnus-group-listed-groups) @@ -492,7 +532,7 @@ articles in the topic and its subtopics." gnus-level-zombie gnus-level-killed))) (and (<= entry-level list-level) (>= entry-level lowest))))) - (cond + (cond ((stringp regexp) (string-match regexp entry)) ((functionp regexp) @@ -500,7 +540,7 @@ articles in the topic and its subtopics." ((null regexp) t) (t nil)))) (setq info (nth 2 entry)) - (gnus-group-prepare-logic + (gnus-group-prepare-logic (gnus-info-group info) (and (or (not gnus-group-listed-groups) (let ((entry-level (gnus-info-level info))) @@ -639,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) @@ -995,6 +1035,7 @@ articles in the topic and its subtopics." "\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 @@ -1021,6 +1062,8 @@ articles in the topic and its subtopics." "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 @@ -1033,6 +1076,7 @@ articles in the topic and its subtopics." "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)) @@ -1059,6 +1103,8 @@ articles in the topic and its subtopics." ["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])))) @@ -1073,7 +1119,7 @@ articles in the topic and its subtopics." (> (prefix-numeric-value arg) 0))) ;; Infest Gnus with topics. (if (not gnus-topic-mode) - (setq gnus-goto-missing-group-function nil) + (setq gnus-goto-missing-group-function nil) (when (gnus-visual-p 'topic-menu 'menu) (gnus-topic-make-menu-bar)) (gnus-set-format 'topic t) @@ -1097,7 +1143,8 @@ articles in the topic and its subtopics." (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) + (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 @@ -1116,6 +1163,7 @@ 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. @@ -1147,6 +1195,21 @@ If performed over a topic line, toggle folding the topic." (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))) + (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 @@ -1192,10 +1255,10 @@ 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 +;; 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, +;; 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) @@ -1203,8 +1266,9 @@ When used interactively, PARENT will be the topic under point." If COPYP, copy the groups instead." (interactive (list current-prefix-arg - (completing-read "Move to topic: " gnus-topic-alist nil t))) - (let ((use-marked (and (not n) (not (gnus-region-active-p)) + (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)) @@ -1231,7 +1295,7 @@ If COPYP, copy the groups instead." (defun gnus-topic-remove-group (&optional n) "Remove the current group from the topic." (interactive "P") - (let ((use-marked (and (not n) (not (gnus-region-active-p)) + (let ((use-marked (and (not n) (not (gnus-region-active-p)) gnus-group-marked t)) (groups (gnus-group-process-prefix n))) (mapcar @@ -1329,7 +1393,7 @@ If PERMANENT, make it stay hidden in subsequent sessions as well." (when (gnus-current-topic) (gnus-topic-goto-topic (gnus-current-topic)) (if permanent - (setcar (cddr + (setcar (cddr (cadr (gnus-topic-find-topology (gnus-current-topic)))) 'hidden)) @@ -1342,8 +1406,8 @@ If PERMANENT, make it stay shown in subsequent sessions as well." (when (gnus-group-topic-p) (if (not permanent) (gnus-topic-remove-topic t nil) - (let ((topic - (gnus-topic-find-topology + (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) @@ -1358,7 +1422,7 @@ If RECURSIVE is t, mark its subtopics too." (if (not topic) (call-interactively 'gnus-group-mark-group) (save-excursion - (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil + (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil recursive))) (while groups (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) @@ -1379,8 +1443,12 @@ If RECURSIVE is t, unmark its subtopics too." (interactive "P") (if (not (gnus-group-topic-p)) (gnus-group-get-new-news-this-group n) - (gnus-topic-mark-topic (gnus-group-topic-name) nil (and n t)) - (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." @@ -1426,7 +1494,7 @@ If RECURSIVE is t, unmark its subtopics too." (interactive (let ((topic (gnus-current-topic))) (list topic - (read-string "Rename topic 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)) @@ -1598,22 +1666,29 @@ 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 `(lambda (top) - (gnus-topic-sort-topics-1 top ,reverse)) + (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))))))) + (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 + (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))) @@ -1625,8 +1700,8 @@ If REVERSE, reverse the sorting order." (defun gnus-topic-move (current to) "Move the CURRENT topic to TO." - (interactive - (list + (interactive + (list (gnus-group-topic-name) (completing-read "Move to topic: " gnus-topic-alist nil t))) (unless (and current to) @@ -1658,8 +1733,15 @@ If REVERSE, reverse the sorting order." (gnus-subscribe-alphabetically newsgroup) ;; Add the group to the topic. (nconc (assoc topic gnus-topic-alist) (list newsgroup)) - (throw 'end t)))))) - + ;; 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) ;;; gnus-topic.el ends here