;;; 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 <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 (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
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))))
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
- (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
(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)
"\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))
["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.
(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
(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)
(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)
(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))
(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)))
(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
projects / gnus / blobdiff