X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-topic.el;h=f426bed3a87986c0955c8243ba000e4bcf3ddc01;hb=b28454eed83f245c4160228b076134ce930b320a;hp=7aac67573f543aa7f58c9f7596a8e7da4cdefa9b;hpb=926bcf02432a9bed8ce9f17224e91c514b2a5093;p=gnus diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el index 7aac67573..f426bed3a 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,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Ilja Weis ;; Lars Magne Ingebrigtsen @@ -42,7 +42,7 @@ :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. @@ -53,7 +53,9 @@ 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) (defcustom gnus-topic-indent-level 2 "*How much each subtopic should be indented." @@ -186,17 +188,18 @@ with some simple extensions. (setq level (or level 7)) ;; We go through the newsrc to look for matches. (while groups - (setq entry (gnus-gethash (setq group (pop groups)) gnus-newsrc-hashtb) - info (nth 2 entry) - params (gnus-info-params info) - active (gnus-active group) - unread (or (car entry) - (and (not (equal group "dummy.group")) - active - (- (1+ (cdr active)) (car active)))) - clevel (or (gnus-info-level info) - (if (member group gnus-zombie-list) 8 9))) - (and + (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) 8 9)))) + (and unread ; nil means that the group is dead. (<= clevel level) (>= clevel lowest) ; Is inside the level we want. @@ -233,14 +236,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 + (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 @@ -275,7 +278,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)) @@ -300,7 +303,9 @@ with some simple extensions. (nconc (cadr top) (list nil))) (unless (nthcdr 3 (cadr top)) (nconc (cadr top) (list nil))) - (setcar (nthcdr 3 (cadr top)) parameters))) + (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 inheritance from topics." @@ -349,34 +354,35 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (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 + (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)) + (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)) + (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) "Insert TOPIC into the group buffer. @@ -385,7 +391,7 @@ articles in the topic and its subtopics." (let* ((type (pop topicl)) (entries (gnus-topic-find-groups (car type) list-level all)) (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)) @@ -393,18 +399,18 @@ articles in the topic and its subtopics." (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)))) (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 @@ -414,7 +420,7 @@ articles in the topic and its subtopics." 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) (car entry) (gnus-info-method info))))) @@ -423,15 +429,18 @@ articles in the topic and its subtopics." (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)))) + (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)) - (/= point-max (point-max)))) + (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)) @@ -464,10 +473,10 @@ articles in the topic and its subtopics." (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) "Remove/insert the current topic." (let ((topic (gnus-group-topic-name))) @@ -480,9 +489,10 @@ 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) ? )) @@ -491,7 +501,7 @@ articles in the topic and its subtopics." (active-topic (eq gnus-topic-alist gnus-topic-active-alist))) (beginning-of-line) ;; Insert the text. - (gnus-add-text-properties + (gnus-add-text-properties (point) (prog1 (1+ (point)) (eval gnus-topic-line-format-spec) @@ -524,7 +534,7 @@ articles in the topic and its subtopics." gnus-topic-mode) (let ((group (gnus-group-group-name)) (buffer-read-only nil)) - (when (and group + (when (and group (gnus-get-info group) (gnus-topic-goto-topic (gnus-current-topic))) (gnus-topic-update-topic-line (gnus-group-topic-name)) @@ -555,7 +565,7 @@ articles in the topic and its subtopics." (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)) @@ -573,7 +583,7 @@ 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) @@ -585,7 +595,7 @@ articles in the topic and its subtopics." unread)) (defun gnus-topic-group-indentation () - (make-string + (make-string (* gnus-topic-indent-level (or (save-excursion (forward-line -1) @@ -636,7 +646,7 @@ articles in the topic and its subtopics." (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) + (newsrc (cdr gnus-newsrc-alist)) group) (while newsrc (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) @@ -687,7 +697,7 @@ articles in the topic and its subtopics." "Run when changing levels to enter/remove groups from topics." (save-excursion (set-buffer gnus-group-buffer) - (when (and gnus-topic-mode + (when (and gnus-topic-mode gnus-topic-alist (not gnus-topic-inhibit-change-level)) ;; Remove the group from the topics. @@ -697,13 +707,13 @@ articles in the topic and its subtopics." (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. + ;; 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 + (make-string (* gnus-topic-indent-level (or (save-excursion (gnus-topic-goto-topic (gnus-current-topic)) @@ -713,7 +723,7 @@ articles in the topic and its subtopics." (yanked (list group)) alist talist end) ;; Then we enter the yanked groups into the topics they belong - ;; to. + ;; to. (when (setq alist (assoc (save-excursion (forward-line -1) (or @@ -738,8 +748,10 @@ articles in the topic and its subtopics." (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. @@ -752,20 +764,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) @@ -795,8 +809,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. @@ -831,6 +845,8 @@ articles in the topic and its subtopics." "\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 gnus-mouse-2 gnus-mouse-pick-topic) ;; Define a new submap. @@ -886,15 +902,15 @@ 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 (gnus-visual-p 'topic-menu 'menu) (gnus-topic-make-menu-bar)) - (setq gnus-topic-line-format-spec - (gnus-parse-format gnus-topic-line-format + (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)) @@ -917,7 +933,7 @@ 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) - (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. @@ -927,14 +943,14 @@ articles in the topic and its subtopics." ;; 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-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. @@ -944,7 +960,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))) @@ -966,13 +982,13 @@ 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 + (interactive (list (read-string "New topic: ") (gnus-current-topic))) @@ -1009,7 +1025,7 @@ If COPYP, copy the groups instead." (start-group (progn (forward-line 1) (gnus-group-group-name))) (start-topic (gnus-group-topic-name)) entry) - (mapcar + (mapcar (lambda (g) (gnus-group-remove-mark g) (when (and @@ -1027,7 +1043,7 @@ If COPYP, copy the groups instead." (defun gnus-topic-remove-group (&optional arg) "Remove the current group from the topic." (interactive "P") - (gnus-group-iterate arg + (gnus-group-iterate arg (lambda (group) (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) (buffer-read-only nil)) @@ -1049,21 +1065,27 @@ If COPYP, copy the groups instead." (interactive "P") (if (gnus-group-topic-p) (let ((topic (gnus-group-topic-name))) - (gnus-topic-remove-topic nil t) - (push (gnus-topic-find-topology topic nil nil gnus-topic-topology) + (push (cons + (gnus-topic-find-topology topic) + (assoc topic gnus-topic-alist)) gnus-topic-killed-topics) + (gnus-topic-remove-topic nil t) + (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) @@ -1072,7 +1094,7 @@ If COPYP, copy the groups instead." (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)) @@ -1083,7 +1105,7 @@ If COPYP, copy the groups instead." ;; 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)) @@ -1116,17 +1138,21 @@ If COPYP, copy the groups instead." (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 9 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." @@ -1184,9 +1210,10 @@ If COPYP, copy the groups instead." (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-dribble-touch) (gnus-group-list-groups))) (defun gnus-topic-indent (&optional unindent) @@ -1196,14 +1223,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)))))) @@ -1218,9 +1248,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) @@ -1248,7 +1280,8 @@ If performed on a topic, edit the topic parameters instead." (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))))))) @@ -1256,6 +1289,10 @@ If performed on a topic, edit the topic parameters instead." "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)