;;; 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, 2003
;; Free Software Foundation, Inc.
;; Author: Ilja Weis <kult@uni-paderborn.de>
: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,
%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)
(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
"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.
;; 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
"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."
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
- (not (eq gnus-group-list-option 'limit))
(copy-sequence gnus-group-listed-groups))))
(when (or (not gnus-topic-alist)
regexp))
(when (or gnus-group-listed-groups
- (and (>= level gnus-level-killed)
+ (and (>= level gnus-level-killed)
(<= lowest gnus-level-killed)))
(gnus-group-prepare-flat-list-dead
- (if 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-remove-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
(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.
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
;; 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)
gnus-level-zombie gnus-level-killed)))
(and (<= entry-level list-level)
(>= entry-level lowest)))))
- (cond
+ (cond
((stringp regexp)
(string-match regexp entry))
((functionp regexp)
((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)))
(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)
(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)
(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-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)
(not (gnus-topic-goto-topic (caaar tp))))
(pop tp))
(if tp
- (gnus-topic-forward-topic 1)
+ (forward-line 1)
(gnus-topic-goto-missing-topic (caadr top)))))
nil))
"\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
"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
"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))
'("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]
+ ["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]))))
(> (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)
(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
(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-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-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
(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
(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)
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))
(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
(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))
(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)
(gnus-group-list-groups)))))
-(defun gnus-topic-mark-topic (topic &optional unmark recursive)
+(defun gnus-topic-mark-topic (topic &optional unmark non-recursive)
"Mark all groups in the TOPIC with the process mark.
-If RECURSIVE is t, mark its subtopics too."
+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 gnus-level-killed t nil
- recursive)))
+ (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 dummy recursive)
+(defun gnus-topic-unmark-topic (topic &optional dummy non-recursive)
"Remove the process mark from all groups in the TOPIC.
-If RECURSIVE is t, unmark its subtopics too."
+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 recursive)))
+ (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) 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."
(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))
(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))))))
(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))))
(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.
+ "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
+ (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)))
(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)
(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