;;; 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
;; 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,
(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
;; 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))
(set-buffer gnus-group-buffer)
(let ((buffer-read-only nil)
(lowest (or lowest 1))
- (not-in-list
+ (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)))
(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)
(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))
+ (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)
(mapcar `(lambda (top)
(gnus-topic-sort-topics-1 top ,reverse))
(sort (cdr top)
- '(lambda (t1 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))))))
-
+ (throw 'end t)))
+ nil)))
+
(provide 'gnus-topic)
;;; gnus-topic.el ends here