X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-topic.el;h=3f2b2af955ffc67df5deeb721380c1e921e36b6e;hb=04aa4d466b5e1d5906632c748818fed207fd0c32;hp=1c493c665719ae981f78d6c9085058da2fa0ecb0;hpb=3a75505b36e914f05480b86020edd727c6abe2fb;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el index 1c493c6..3f2b2af 100644 --- a/lisp/gnus-topic.el +++ b/lisp/gnus-topic.el @@ -1,6 +1,5 @@ ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 -;; Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. ;; Author: Ilja Weis ;; Lars Magne Ingebrigtsen @@ -46,9 +45,6 @@ :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, @@ -60,10 +56,7 @@ 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) @@ -156,21 +149,11 @@ See (gnus)Formatting Variables." (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-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 @@ -199,11 +182,10 @@ If TOPIC, start with that topic." (beginning-of-line) (get-text-property (point) 'gnus-active))) -(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." +(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 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. @@ -221,17 +203,16 @@ If RECURSIVE is t, return groups in its subtopics too." (if (member group gnus-zombie-list) gnus-level-zombie gnus-level-killed)))) (and - info ; nil means that the group is dead. + unread ; nil means that the group is dead. (<= clevel level) (>= clevel lowest) ; Is inside the level we want. (or all - (if (or (eq unread t) - (eq unread nil)) + (if (eq unread t) gnus-group-list-inactive-groups (> unread 0)) (and gnus-list-groups-with-ticked-articles (cdr (assq 'tick (gnus-info-marks info)))) - ;; Has right readedness. + ; Has right readedness. ;; Check for permanent visibility. (and gnus-permanently-visible-groups (string-match gnus-permanently-visible-groups group)) @@ -239,40 +220,7 @@ If RECURSIVE is t, return groups in its subtopics too." (cdr (assq 'visible params))) ;; Add this group to the list of visible groups. (push (or entry group) 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)) + (nreverse visible-groups))) (defun gnus-topic-previous-topic (topic) "Return the previous topic on the same level as TOPIC." @@ -413,19 +361,14 @@ If RECURSIVE is t, return groups in its subtopics too." ;;; Generating group buffers -(defun gnus-group-prepare-topics (level &optional predicate lowest - regexp list-topic topic-level) +(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 PREDICTE is a function, list groups that the function returns non-nil; -if it is t, list groups that have no unread articles. +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)) - (not-in-list - (and gnus-group-listed-groups - (copy-sequence gnus-group-listed-groups)))) + (lowest (or lowest 1))) (when (or (not gnus-topic-alist) (not gnus-topology-checked-p)) @@ -435,63 +378,48 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (erase-buffer)) ;; List dead groups? - (when (or gnus-group-listed-groups - (and (>= level gnus-level-zombie) - (<= lowest gnus-level-zombie))) + (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 (or gnus-group-listed-groups - (and (>= level gnus-level-killed) - (<= lowest gnus-level-killed))) + (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)) (gnus-group-prepare-flat-list-dead (setq gnus-killed-list (sort gnus-killed-list 'string<)) - gnus-level-killed ?K regexp) - (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))) + gnus-level-killed ?K + regexp)) ;; Use topics. (prog1 - (when (or (< lowest gnus-level-zombie) - gnus-group-listed-groups) + (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) predicate - nil lowest regexp)) + (or topic-level level) all + nil lowest)) (gnus-topic-prepare-topic gnus-topic-topology 0 - (or topic-level level) predicate - nil lowest regexp))) + (or topic-level level) all + nil lowest))) + (gnus-group-set-mode-line) - (setq gnus-group-list-mode (cons level predicate)) + (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 - predicate silent - lowest regexp) +(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) - (if gnus-group-listed-groups - gnus-level-killed - list-level) - (or predicate gnus-group-listed-groups - (cdr (assq 'visible + (car type) list-level + (or all + (cdr (assq 'visible (gnus-topic-hierarchical-parameters (car type))))) - (if gnus-group-listed-groups 0 lowest))) + lowest)) (visiblep (and (eq (nth 1 type) 'visible) (not silent))) (gnus-group-indentation (make-string (* gnus-topic-indent-level level) ? )) @@ -506,61 +434,31 @@ articles in the topic and its subtopics." (while topicl (incf unread (gnus-topic-prepare-topic - (pop topicl) (1+ level) list-level predicate - (not visiblep) lowest regexp))) + (pop topicl) (1+ level) list-level all + (not visiblep) lowest))) (setq end (point)) (goto-char beg) ;; Insert all the groups that belong in this topic. (while (setq entry (pop entries)) - (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)))) + (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) @@ -594,7 +492,7 @@ articles in the topic and its subtopics." (let ((data (cadr (gnus-topic-find-topology topic)))) (setcdr data (list (if insert 'visible 'invisible) - (caddr data) + (if hide 'hide nil) (cadddr data)))) (if total-remove (setq gnus-topic-alist @@ -607,9 +505,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 topic) +(defun gnus-topic-fold (&optional insert) "Remove/insert the current topic." - (let ((topic (or topic (gnus-group-topic-name)))) + (let ((topic (gnus-group-topic-name))) (when topic (save-excursion (if (not (gnus-group-active-topic-p)) @@ -633,16 +531,15 @@ articles in the topic and its subtopics." (gnus-topic-update-unreads name unread) (beginning-of-line) ;; Insert the text. - (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))))) + (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) @@ -670,7 +567,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) @@ -685,8 +582,7 @@ 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) - entry) + (unfound t)) ;; Try to jump to a visible group. (while (and g (not (gnus-group-goto-group (car g) t))) (pop g)) @@ -700,20 +596,8 @@ articles in the topic and its subtopics." (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)))))) + (gnus-topic-insert-topic-line + topic t t (car (gnus-topic-find-topology topic)) nil 0))))) (defun gnus-topic-goto-missing-topic (topic) (if (gnus-topic-goto-topic topic) @@ -722,18 +606,15 @@ articles in the topic and its subtopics." (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))))) + (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) @@ -1025,8 +906,6 @@ 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 @@ -1050,11 +929,8 @@ 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 @@ -1067,7 +943,6 @@ 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)) @@ -1085,7 +960,6 @@ 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] @@ -1093,9 +967,6 @@ articles in the topic and its subtopics." ["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])))) @@ -1109,15 +980,12 @@ articles in the topic and its subtopics." (if (null arg) (not gnus-topic-mode) (> (prefix-numeric-value arg) 0))) ;; Infest Gnus with topics. - (if (not gnus-topic-mode) - (setq gnus-goto-missing-group-function nil) + (if (not gnus-topic-mode) + (setq gnus-goto-missing-group-function nil) (when (gnus-visual-p 'topic-menu 'menu) (gnus-topic-make-menu-bar)) (gnus-set-format 'topic t) - (gnus-add-minor-mode 'gnus-topic-mode " Topic" - gnus-topic-mode-map nil (lambda (&rest junk) - (interactive) - (gnus-topic-mode nil t))) + (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) (set (make-local-variable 'gnus-group-prepare-function) 'gnus-group-prepare-topics) @@ -1134,8 +1002,7 @@ 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 - nil 'local) + (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 @@ -1144,7 +1011,8 @@ articles in the topic and its subtopics." ;; Remove topic infestation. (unless gnus-topic-mode (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) - (setq gnus-group-change-level-function nil) + (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-sort-alist-function 'gnus-group-sort-flat)) @@ -1154,7 +1022,6 @@ 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. @@ -1163,8 +1030,7 @@ If performed over a topic line, toggle folding the topic." (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-dribble-touch)) + (gnus-topic-fold all)) (gnus-group-select-group all))) (defun gnus-mouse-pick-topic (e) @@ -1173,34 +1039,6 @@ 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-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 @@ -1230,7 +1068,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 (list (list topic 'visible nil nil))))) + (full-topic (or full-topic `((,topic visible))))) (unless top (error "No such parent topic: %s" parent)) (if previous @@ -1246,61 +1084,44 @@ 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 - (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)) + (completing-read "Move to topic: " gnus-topic-alist nil t))) + (let ((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))) + (start-topic (gnus-group-topic-name)) entry) - (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 n) - "Remove the current group from the topic." - (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))) + (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) - (gnus-group-position-point))) + (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) + "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))))) (defun gnus-topic-copy-group (n topic) "Copy the current group to a topic." @@ -1322,12 +1143,7 @@ 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) - (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)))) + (gnus-topic-update-topic))) (defun gnus-topic-yank-group (&optional arg) "Yank the last topic." @@ -1377,69 +1193,44 @@ If COPYP, copy the groups instead." (setq alist (cdr alist)))))) (gnus-topic-update-topic))) -(defun gnus-topic-hide-topic (&optional permanent) - "Hide the current topic. -If PERMANENT, make it stay hidden in subsequent sessions as well." - (interactive "P") +(defun gnus-topic-hide-topic () + "Hide the current topic." + (interactive) (when (gnus-current-topic) (gnus-topic-goto-topic (gnus-current-topic)) - (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") + (gnus-topic-remove-topic nil nil 'hidden))) + +(defun gnus-topic-show-topic () + "Show the hidden topic." + (interactive) (when (gnus-group-topic-p) - (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 recursive) - "Mark all groups in the TOPIC with the process mark. -If RECURSIVE is t, mark its subtopics too." - (interactive (list (gnus-group-topic-name) - nil - (and current-prefix-arg t))) + (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 topic) (call-interactively 'gnus-group-mark-group) (save-excursion - (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil - recursive))) + (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 dummy recursive) - "Remove the process mark from all groups in the TOPIC. -If RECURSIVE is t, unmark its subtopics too." - (interactive (list (gnus-group-topic-name) - nil - (and current-prefix-arg t))) +(defun gnus-topic-unmark-topic (topic &optional unmark) + "Remove the process mark from all groups in the topic." + (interactive (list (gnus-group-topic-name))) (if (not topic) (call-interactively 'gnus-group-unmark-group) - (gnus-topic-mark-topic topic t recursive))) + (gnus-topic-mark-topic topic t))) (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) - (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)))))) + (gnus-topic-mark-topic (gnus-group-topic-name)) + (gnus-group-get-new-news-this-group))) (defun gnus-topic-move-matching (regexp topic &optional copyp) "Move all groups that match REGEXP to some topic." @@ -1485,7 +1276,7 @@ If RECURSIVE is t, unmark its subtopics too." (interactive (let ((topic (gnus-current-topic))) (list topic - (read-string (format "Rename %s to: " topic) 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)) @@ -1657,82 +1448,6 @@ 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 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)) - ;; 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