1 ;;; gnus-topic.el --- a folding group mode for Gnus
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
4 ;; Author: Ilja Weis <kult@uni-paderborn.de>
5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
29 (eval-when-compile (require 'cl))
31 (defvar gnus-group-topic-face 'bold
32 "*Face used to highlight topic headers.")
34 (defvar gnus-group-topics '(("no" "^no" nil) ("misc" "." nil))
35 "*Alist of newsgroup topics.
36 This alist has entries of the form
40 where TOPIC is the name of the topic a group is put in if it matches
41 REGEXP. A group can only be in one topic at a time.
43 If SHOW is nil, newsgroups will be inserted according to
44 `gnus-group-topic-topics-only', otherwise that variable is ignored and
45 the groups are always shown if SHOW is true or never if SHOW is a
48 (defvar gnus-topic-names nil
49 "A list of all topic names.")
51 (defvar gnus-topic-names nil
52 "A list of all topic names.")
54 (defvar gnus-group-topic-topics-only nil
55 "*If non-nil, only the topics will be shown when typing `l' or `L'.")
57 (defvar gnus-topic-unique t
58 "*If non-nil, each group will only belong to one topic.")
60 ;; Internal variables.
62 (defvar gnus-topics-not-listed nil)
66 (defun gnus-group-topic-name ()
67 "The name of the topic on the current line."
68 (get-text-property (gnus-point-at-bol) 'gnus-topic))
70 (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic)
71 "List all newsgroups with unread articles of level LEVEL or lower, and
72 use the `gnus-group-topics' to sort the groups.
73 If ALL is non-nil, list groups that have no unread articles.
74 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
75 (set-buffer gnus-group-buffer)
76 (let ((buffer-read-only nil)
77 (lowest (or lowest 1))
84 (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)
85 (gnus-group-prepare-flat-list-dead
86 (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
90 (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)
91 (gnus-group-prepare-flat-list-dead
92 (setq gnus-killed-list (sort gnus-killed-list 'string<))
97 (if (< lowest gnus-level-zombie)
98 (let ((topics (gnus-topic-find-groups list-topic level all))
100 (setq gnus-topic-names topics)
102 (setq topic (car (car topics))
103 tlist (cdr (car topics))
104 how (nth 2 (assoc topic gnus-group-topics))
114 (list 'mouse-face gnus-mouse-face
115 'face gnus-group-topic-face
118 ;; We insert the groups for the topics we want to have.
119 (if (and (or (and (not how) (not gnus-group-topic-topics-only))
120 (and how (not (numberp how))))
121 (not (member topic gnus-topics-not-listed)))
122 ;; We want to list this topic.
124 (setq gnus-topics-not-listed
125 (delete topic gnus-topics-not-listed))
126 (setq tlist (nreverse tlist))
128 (setq info (car tlist))
129 (gnus-group-insert-group-line
130 nil (gnus-info-group info)
131 (gnus-info-level info) (gnus-info-marks info)
132 (car (gnus-gethash (gnus-info-group info)
134 (gnus-info-method info))
135 (setq tlist (cdr tlist))))
136 ;; This one is hiddent.
137 (push topic gnus-topics-not-listed))))))
139 (gnus-group-set-mode-line)
140 (setq gnus-group-list-mode (cons level all))
141 (run-hooks 'gnus-group-prepare-hook))
143 (defun gnus-topic-find-groups (&optional topic level all)
144 "Find all topics and all groups in all topics.
145 If TOPIC, just find the groups in that topic."
146 (let ((newsrc (cdr gnus-newsrc-alist))
149 (mapcar (lambda (e) (list (car e)))
151 (topic-alist (if topic (list (assoc topic gnus-group-topics))
153 info clevel unread group w lowest gtopic)
154 (setq lowest (or lowest 1))
155 (setq all (or all nil))
156 (setq level (or level 7))
157 ;; We go through the newsrc to look for matches.
159 (setq info (car newsrc)
160 group (gnus-info-group info)
162 unread (car (gnus-gethash group gnus-newsrc-hashtb)))
164 unread ; nil means that the group is dead.
165 (<= (setq clevel (gnus-info-level info)) level)
166 (>= clevel lowest) ; Is inside the level we want.
170 (cdr (assq 'tick (gnus-info-marks info)))) ; Has right readedness.
172 ;; So we find out what topic this group belongs to. First we
173 ;; check the group parameters.
174 (setq gtopic (cdr (assq 'topic (gnus-info-params info))))
175 ;; On match, we add it.
176 (and (stringp gtopic)
178 (string= gtopic topic))
179 (if (setq e (assoc gtopic topics))
180 (setcdr e (cons info (cdr e)))
181 (setq topics (cons (list gtopic info) topics))))
182 ;; We look through the topic alist for further matches, if
184 (if (or (not gnus-topic-unique) (not (stringp gtopic)))
185 (let ((ts topic-alist))
187 (if (string-match (nth 1 (car ts)) group)
189 (setcdr (setq e (assoc (car (car ts)) topics))
191 (and gnus-topic-unique (setq ts nil))))
192 (setq ts (cdr ts))))))))
195 (defun gnus-topic-remove-topic ()
196 "Remove the current topic."
197 (let ((topic (gnus-group-topic-name))
200 (setq gnus-topics-not-listed (cons topic gnus-topics-not-listed))
202 (unless (gnus-group-topic-name)
203 (delete-region (point)
204 (or (next-single-property-change (point) 'gnus-topic)
207 (defun gnus-topic-insert-topic (topic)
209 (setq gnus-topics-not-listed (delete topic gnus-topics-not-listed))
210 (gnus-group-prepare-topics
211 (car gnus-group-list-mode) (cdr gnus-group-list-mode)
214 (defun gnus-topic-fold ()
215 "Remove/insert the current topic."
216 (let ((topic (gnus-group-topic-name)))
219 (if (not (member topic gnus-topics-not-listed))
220 ;; If the topic is visible, we remove it.
221 (gnus-topic-remove-topic)
222 ;; If not, we insert it.
224 (gnus-topic-insert-topic topic))))))
226 ;; Written by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
227 (defun gnus-group-add-to-topic (n topic)
228 "Add the current group to a topic."
230 (list current-prefix-arg
231 (completing-read "Add to topic: " gnus-topic-names)))
232 (let ((groups (gnus-group-process-prefix n)))
234 (gnus-group-remove-mark g)
235 (gnus-group-add-parameter g (cons 'topic topic)))
237 (gnus-group-position-point)))
239 (defun gnus-topic-toggle-topic ()
240 "Toggle between a flat group buffer and a topic display."
242 (if (eq gnus-group-prepare-function 'gnus-group-prepare-topics)
243 (setq gnus-group-prepare-function 'gnus-group-prepare-flat)
244 (setq gnus-group-prepare-function 'gnus-group-prepare-topics))
245 (gnus-group-list-groups))
247 ;;; gnus-topic.el ends here