;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
-;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
+;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc.
;; Author: Ilja Weis <kult@uni-paderborn.de>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
(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.")
(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 ()
(gnus-group-topic group))))
(defun gnus-topic-goto-topic (topic)
- "Go to TOPIC."
(when topic
(gnus-goto-char (text-property-any (point-min) (point-max)
'gnus-topic (intern topic)))))
+(defun gnus-topic-jump-to-topic (topic)
+ "Go to TOPIC."
+ (interactive
+ (list (completing-read "Go to topic: "
+ (mapcar 'list (gnus-topic-list))
+ nil t)))
+ (dolist (topic (gnus-current-topics topic))
+ (gnus-topic-fold t))
+ (gnus-topic-goto-topic topic))
+
(defun gnus-current-topic ()
"Return the name of the current topic."
(let ((result
(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
;;; Generating group buffers
-(defun gnus-group-prepare-topics (level &optional all 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 ALL is non-nil, list groups that have no unread articles.
(entries (gnus-topic-find-groups
(car type) list-level
(or all
- (cdr (assq 'visible
+ (cdr (assq 'visible
(gnus-topic-hierarchical-parameters
(car type)))))
lowest))
(if (stringp entry)
;; Dead groups.
(gnus-group-insert-group-line
- entry (if (member entry gnus-zombie-list) gnus-level-zombie gnus-level-killed)
+ entry (if (member entry gnus-zombie-list)
+ gnus-level-zombie gnus-level-killed)
nil (- (1+ (cdr (setq active (gnus-active entry))))
(car active))
nil)
(car type) visiblep
(not (eq (nth 2 type) 'hidden))
level all-entries unread))
+ (gnus-topic-update-unreads (car type) unread)
(goto-char end)
unread))
(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))
(number-of-groups (length entries))
(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
'gnus-active active-topic
'gnus-topic-visible visiblep))))
+(defun gnus-topic-update-unreads (topic unreads)
+ (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads)
+ gnus-topic-unreads))
+ (push (cons topic unreads) gnus-topic-unreads))
+
(defun gnus-topic-update-topics-containing-group (group)
"Update all topics that have GROUP as a member."
(when (and (eq major-mode 'gnus-group-mode)
(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)
(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
(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 (- (or old-unread 0) (or (gnus-group-topic-unread) 0))))
+ parent
+ (- (or old-unread 0) (or new-unread 0))))
unread))
(defun gnus-topic-group-indentation ()
"=" gnus-topic-select-group
"\r" gnus-topic-select-group
" " gnus-topic-read-group
+ "\C-c\C-x" gnus-topic-expire-articles
"\C-k" gnus-topic-kill-group
"\C-y" gnus-topic-yank-group
"\M-g" gnus-topic-get-new-news-this-topic
"#" gnus-topic-mark-topic
"\M-#" gnus-topic-unmark-topic
[tab] gnus-topic-indent
- [M-tab] gnus-topic-unindent
+ [(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.
"c" gnus-topic-copy-group
"h" gnus-topic-hide-topic
"s" gnus-topic-show-topic
+ "j" gnus-topic-jump-to-topic
"M" gnus-topic-move-matching
"C" gnus-topic-copy-matching
"\C-i" gnus-topic-indent
"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
["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]
["Create" gnus-topic-create-topic t]
["Mark" gnus-topic-mark-topic t]
["Indent" gnus-topic-indent t]
+ ["Sort" gnus-topic-sort-topics t]
["Toggle hide empty" gnus-topic-toggle-display-empty-topics t]
["Edit parameters" gnus-topic-edit-parameters t])
["List active" gnus-topic-list-active t]))))
(gnus-topic-make-menu-bar))
(gnus-set-format 'topic t)
(gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map)
- (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
(add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
(set (make-local-variable 'gnus-group-prepare-function)
'gnus-group-prepare-topics)
(mouse-set-point e)
(gnus-topic-read-group nil))
+(defun gnus-topic-expire-articles (topic)
+ "Expire articles in this topic or group."
+ (interactive (list (gnus-group-topic-name)))
+ (if (not topic)
+ (call-interactively 'gnus-group-expire-articles)
+ (save-excursion
+ (gnus-message 5 "Expiring groups in %s..." topic)
+ (let ((gnus-group-marked
+ (mapcar (lambda (entry) (car (nth 2 entry)))
+ (gnus-topic-find-groups topic gnus-level-killed t))))
+ (gnus-group-expire-articles nil))
+ (gnus-message 5 "Expiring groups in %s...done" topic))))
+
(defun gnus-topic-read-group (&optional all no-article group)
"Read news in this newsgroup.
If the prefix argument ALL is non-nil, already read articles become
(completing-read "Move to topic: " gnus-topic-alist nil t)))
(let ((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)
+ (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)
"Remove the current group from the topic."
(interactive "P")
(gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
+(defun gnus-topic-sort-topics-1 (top reverse)
+ (if (cdr top)
+ (let ((subtop
+ (mapcar `(lambda (top)
+ (gnus-topic-sort-topics-1 top ,reverse))
+ (sort (cdr top)
+ '(lambda (t1 t2)
+ (string-lessp (caar t1) (caar t2)))))))
+ (setcdr top (if reverse (reverse subtop) subtop))))
+ top)
+
+(defun gnus-topic-sort-topics (&optional topic reverse)
+ "Sort topics in TOPIC alphabeticaly by topic name.
+If REVERSE, reverse the sorting order."
+ (interactive
+ (list (completing-read "Sort topics in : " gnus-topic-alist nil t
+ (gnus-current-topic))
+ current-prefix-arg))
+ (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic)))
+ gnus-topic-topology)))
+ (gnus-topic-sort-topics-1 topic-topology reverse)
+ (gnus-topic-enter-dribble)
+ (gnus-group-list-groups)
+ (gnus-topic-goto-topic topic)))
+
+(defun gnus-topic-move (current to)
+ "Move the CURRENT topic to TO."
+ (interactive
+ (list
+ (gnus-group-topic-name)
+ (completing-read "Move to topic: " gnus-topic-alist nil t)))
+ (unless (and current to)
+ (error "Can't find topic"))
+ (let ((current-top (cdr (gnus-topic-find-topology current)))
+ (to-top (cdr (gnus-topic-find-topology to))))
+ (unless current-top
+ (error "Can't find topic `%s'" current))
+ (unless to-top
+ (error "Can't find topic `%s'" to))
+ (if (gnus-topic-find-topology to current-top 0) ;; Don't care the level
+ (error "Can't move `%s' to its sub-level" current))
+ (gnus-topic-find-topology current nil nil 'delete)
+ (while (cdr to-top)
+ (setq to-top (cdr to-top)))
+ (setcdr to-top (list current-top))
+ (gnus-topic-enter-dribble)
+ (gnus-group-list-groups)
+ (gnus-topic-goto-topic current)))
+
+(defun gnus-subscribe-topics (newsgroup)
+ (catch 'end
+ (let (match gnus-group-change-level-function)
+ (dolist (topic (gnus-topic-list))
+ (when (and (setq match (cdr (assq 'subscribe
+ (gnus-topic-parameters topic))))
+ (string-match match newsgroup))
+ ;; Just subscribe the group.
+ (gnus-subscribe-alphabetically newsgroup)
+ ;; Add the group to the topic.
+ (nconc (assoc topic gnus-topic-alist) (list newsgroup))
+ (throw 'end t))))))
+
(provide 'gnus-topic)
;;; gnus-topic.el ends here
projects / gnus / blobdiff