;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
-;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc.
+;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Author: Ilja Weis <kult@uni-paderborn.de>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
(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
- info ; nil means that the group is dead.
+ unread ; nil means that the group is dead.
(<= clevel level)
(>= clevel lowest) ; Is inside the level we want.
(or all
- (if (or (eq unread t)
- (eq unread nil))
+ (if (eq unread t)
gnus-group-list-inactive-groups
(> unread 0))
(and gnus-list-groups-with-ticked-articles
(cdr (assq 'tick (gnus-info-marks info))))
- ;; Has right readedness.
+ ; Has right readedness.
;; Check for permanent visibility.
(and gnus-permanently-visible-groups
(string-match gnus-permanently-visible-groups group))
;;; 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 gnus-group-list-mode) (cdr gnus-group-list-mode)
nil nil topic level))
-(defun gnus-topic-fold (&optional insert topic)
+(defun gnus-topic-fold (&optional insert)
"Remove/insert the current topic."
- (let ((topic (or topic (gnus-group-topic-name))))
+ (let ((topic (gnus-group-topic-name)))
(when topic
(save-excursion
(if (not (gnus-group-active-topic-p))
(let* ((topic (gnus-group-topic group))
(groups (cdr (assoc topic gnus-topic-alist)))
(g (cdr (member group groups)))
- (unfound t)
- entry)
+ (unfound t))
;; Try to jump to a visible group.
(while (and g (not (gnus-group-goto-group (car g) t)))
(pop 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-insert-topic-line
+ topic t t (car (gnus-topic-find-topology topic)) nil 0)))))
(defun gnus-topic-goto-missing-topic (topic)
(if (gnus-topic-goto-topic topic)
(let* ((top (gnus-topic-find-topology
(gnus-topic-parent-topic topic)))
(tp (reverse (cddr 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)))))
+ (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)
"=" 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
"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
["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]))))
(if (null arg) (not gnus-topic-mode)
(> (prefix-numeric-value arg) 0)))
;; Infest Gnus with topics.
- (if (not gnus-topic-mode)
+ (if (not gnus-topic-mode)
(setq gnus-goto-missing-group-function nil)
(when (gnus-visual-p 'topic-menu 'menu)
(gnus-topic-make-menu-bar))
(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-topic (gnus-group-topic-name))
(start-group (progn (forward-line 1) (gnus-group-group-name)))
+ (start-topic (gnus-group-topic-name))
entry)
- (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))))
+ (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 / elisp / gnus.git- / blobdiff