|
0
|
1 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
|
|
|
2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
|
|
|
3
|
|
|
4 ;; Author: Ilja Weis <kult@uni-paderborn.de>
|
|
|
5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
|
|
|
6 ;; Keywords: news
|
|
|
7
|
|
|
8 ;; This file is part of GNU Emacs.
|
|
|
9
|
|
|
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)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
|
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.
|
|
|
19
|
|
|
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 the
|
|
|
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
23 ;; Boston, MA 02111-1307, USA.
|
|
|
24
|
|
|
25 ;;; Commentary:
|
|
|
26
|
|
|
27 ;;; Code:
|
|
|
28
|
|
|
29 (require 'gnus)
|
|
|
30 (eval-when-compile (require 'cl))
|
|
|
31
|
|
|
32 (defvar gnus-topic-mode nil
|
|
|
33 "Minor mode for Gnus group buffers.")
|
|
|
34
|
|
|
35 (defvar gnus-topic-mode-hook nil
|
|
|
36 "Hook run in topic mode buffers.")
|
|
|
37
|
|
|
38 (defvar gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n"
|
|
|
39 "Format of topic lines.
|
|
|
40 It works along the same lines as a normal formatting string,
|
|
|
41 with some simple extensions.
|
|
|
42
|
|
|
43 %i Indentation based on topic level.
|
|
|
44 %n Topic name.
|
|
|
45 %v Nothing if the topic is visible, \"...\" otherwise.
|
|
|
46 %g Number of groups in the topic.
|
|
|
47 %a Number of unread articles in the groups in the topic.
|
|
|
48 %A Number of unread articles in the groups in the topic and its subtopics.
|
|
|
49 ")
|
|
|
50
|
|
|
51 (defvar gnus-topic-indent-level 2
|
|
|
52 "*How much each subtopic should be indented.")
|
|
|
53
|
|
|
54 ;; Internal variables.
|
|
|
55
|
|
|
56 (defvar gnus-topic-active-topology nil)
|
|
|
57 (defvar gnus-topic-active-alist nil)
|
|
|
58
|
|
|
59 (defvar gnus-topology-checked-p nil
|
|
|
60 "Whether the topology has been checked in this session.")
|
|
|
61
|
|
|
62 (defvar gnus-topic-killed-topics nil)
|
|
|
63 (defvar gnus-topic-inhibit-change-level nil)
|
|
|
64 (defvar gnus-topic-tallied-groups nil)
|
|
|
65
|
|
|
66 (defconst gnus-topic-line-format-alist
|
|
|
67 `((?n name ?s)
|
|
|
68 (?v visible ?s)
|
|
|
69 (?i indentation ?s)
|
|
|
70 (?g number-of-groups ?d)
|
|
|
71 (?a (gnus-topic-articles-in-topic entries) ?d)
|
|
|
72 (?A total-number-of-articles ?d)
|
|
|
73 (?l level ?d)))
|
|
|
74
|
|
|
75 (defvar gnus-topic-line-format-spec nil)
|
|
|
76
|
|
|
77 ;; Functions.
|
|
|
78
|
|
|
79 (defun gnus-group-topic-name ()
|
|
|
80 "The name of the topic on the current line."
|
|
|
81 (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic)))
|
|
|
82 (and topic (symbol-name topic))))
|
|
|
83
|
|
|
84 (defun gnus-group-topic-level ()
|
|
|
85 "The level of the topic on the current line."
|
|
|
86 (get-text-property (gnus-point-at-bol) 'gnus-topic-level))
|
|
|
87
|
|
|
88 (defun gnus-group-topic-unread ()
|
|
|
89 "The number of unread articles in topic on the current line."
|
|
|
90 (get-text-property (gnus-point-at-bol) 'gnus-topic-unread))
|
|
|
91
|
|
|
92 (defun gnus-topic-unread (topic)
|
|
|
93 "Return the number of unread articles in TOPIC."
|
|
|
94 (or (save-excursion
|
|
|
95 (and (gnus-topic-goto-topic topic)
|
|
|
96 (gnus-group-topic-unread)))
|
|
|
97 0))
|
|
|
98
|
|
|
99 (defun gnus-topic-init-alist ()
|
|
|
100 "Initialize the topic structures."
|
|
|
101 (setq gnus-topic-topology
|
|
|
102 (cons (list "Gnus" 'visible)
|
|
|
103 (mapcar (lambda (topic)
|
|
|
104 (list (list (car topic) 'visible)))
|
|
|
105 '(("misc")))))
|
|
|
106 (setq gnus-topic-alist
|
|
|
107 (list (cons "misc"
|
|
|
108 (mapcar (lambda (info) (gnus-info-group info))
|
|
|
109 (cdr gnus-newsrc-alist)))
|
|
|
110 (list "Gnus")))
|
|
|
111 (gnus-topic-enter-dribble))
|
|
|
112
|
|
|
113 (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level)
|
|
|
114 "List all newsgroups with unread articles of level LEVEL or lower, and
|
|
|
115 use the `gnus-group-topics' to sort the groups.
|
|
|
116 If ALL is non-nil, list groups that have no unread articles.
|
|
|
117 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
|
|
|
118 (set-buffer gnus-group-buffer)
|
|
|
119 (let ((buffer-read-only nil)
|
|
|
120 (lowest (or lowest 1)))
|
|
|
121
|
|
|
122 (setq gnus-topic-tallied-groups nil)
|
|
|
123
|
|
|
124 (when (or (not gnus-topic-alist)
|
|
|
125 (not gnus-topology-checked-p))
|
|
|
126 (gnus-topic-check-topology))
|
|
|
127
|
|
|
128 (unless list-topic
|
|
|
129 (erase-buffer))
|
|
|
130
|
|
|
131 ;; List dead groups?
|
|
|
132 (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie))
|
|
|
133 (gnus-group-prepare-flat-list-dead
|
|
|
134 (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
|
|
|
135 gnus-level-zombie ?Z
|
|
|
136 regexp))
|
|
|
137
|
|
|
138 (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))
|
|
|
139 (gnus-group-prepare-flat-list-dead
|
|
|
140 (setq gnus-killed-list (sort gnus-killed-list 'string<))
|
|
|
141 gnus-level-killed ?K
|
|
|
142 regexp))
|
|
|
143
|
|
|
144 ;; Use topics.
|
|
|
145 (when (< lowest gnus-level-zombie)
|
|
|
146 (if list-topic
|
|
|
147 (let ((top (gnus-topic-find-topology list-topic)))
|
|
|
148 (gnus-topic-prepare-topic (cdr top) (car top)
|
|
|
149 (or topic-level level) all))
|
|
|
150 (gnus-topic-prepare-topic gnus-topic-topology 0
|
|
|
151 (or topic-level level) all))))
|
|
|
152
|
|
|
153 (gnus-group-set-mode-line)
|
|
|
154 (setq gnus-group-list-mode (cons level all))
|
|
|
155 (run-hooks 'gnus-group-prepare-hook))
|
|
|
156
|
|
|
157 (defun gnus-topic-prepare-topic (topicl level &optional list-level all silent)
|
|
|
158 "Insert TOPIC into the group buffer.
|
|
|
159 If SILENT, don't insert anything. Return the number of unread
|
|
|
160 articles in the topic and its subtopics."
|
|
|
161 (let* ((type (pop topicl))
|
|
|
162 (entries (gnus-topic-find-groups (car type) list-level all))
|
|
|
163 (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
|
|
|
164 (gnus-group-indentation
|
|
|
165 (make-string (* gnus-topic-indent-level level) ? ))
|
|
|
166 (beg (progn (beginning-of-line) (point)))
|
|
|
167 (topicl (reverse topicl))
|
|
|
168 (all-entries entries)
|
|
|
169 (unread 0)
|
|
|
170 (topic (car type))
|
|
|
171 info entry end active)
|
|
|
172 ;; Insert any sub-topics.
|
|
|
173 (while topicl
|
|
|
174 (incf unread
|
|
|
175 (gnus-topic-prepare-topic
|
|
|
176 (pop topicl) (1+ level) list-level all
|
|
|
177 (not visiblep))))
|
|
|
178 (setq end (point))
|
|
|
179 (goto-char beg)
|
|
|
180 ;; Insert all the groups that belong in this topic.
|
|
|
181 (while (setq entry (pop entries))
|
|
|
182 (when visiblep
|
|
|
183 (if (stringp entry)
|
|
|
184 ;; Dead groups.
|
|
|
185 (gnus-group-insert-group-line
|
|
|
186 entry (if (member entry gnus-zombie-list) 8 9)
|
|
|
187 nil (- (1+ (cdr (setq active (gnus-active entry))))
|
|
|
188 (car active)) nil)
|
|
|
189 ;; Living groups.
|
|
|
190 (when (setq info (nth 2 entry))
|
|
|
191 (gnus-group-insert-group-line
|
|
|
192 (gnus-info-group info)
|
|
|
193 (gnus-info-level info) (gnus-info-marks info)
|
|
|
194 (car entry) (gnus-info-method info)))))
|
|
|
195 (when (and (listp entry)
|
|
|
196 (numberp (car entry))
|
|
|
197 (not (member (gnus-info-group (setq info (nth 2 entry)))
|
|
|
198 gnus-topic-tallied-groups)))
|
|
|
199 (push (gnus-info-group info) gnus-topic-tallied-groups)
|
|
|
200 (incf unread (car entry))))
|
|
|
201 (goto-char beg)
|
|
|
202 ;; Insert the topic line.
|
|
|
203 (unless silent
|
|
|
204 (gnus-extent-start-open (point))
|
|
|
205 (gnus-topic-insert-topic-line
|
|
|
206 (car type) visiblep
|
|
|
207 (not (eq (nth 2 type) 'hidden))
|
|
|
208 level all-entries unread))
|
|
|
209 (goto-char end)
|
|
|
210 unread))
|
|
|
211
|
|
|
212 (defun gnus-topic-find-groups (topic &optional level all)
|
|
|
213 "Return entries for all visible groups in TOPIC."
|
|
|
214 (let ((groups (cdr (assoc topic gnus-topic-alist)))
|
|
|
215 info clevel unread group lowest params visible-groups entry active)
|
|
|
216 (setq lowest (or lowest 1))
|
|
|
217 (setq level (or level 7))
|
|
|
218 ;; We go through the newsrc to look for matches.
|
|
|
219 (while groups
|
|
|
220 (setq entry (gnus-gethash (setq group (pop groups)) gnus-newsrc-hashtb)
|
|
|
221 info (nth 2 entry)
|
|
|
222 params (gnus-info-params info)
|
|
|
223 active (gnus-active group)
|
|
|
224 unread (or (car entry)
|
|
|
225 (and (not (equal group "dummy.group"))
|
|
|
226 active
|
|
|
227 (- (1+ (cdr active)) (car active))))
|
|
|
228 clevel (or (gnus-info-level info)
|
|
|
229 (if (member group gnus-zombie-list) 8 9)))
|
|
|
230 (and
|
|
|
231 unread ; nil means that the group is dead.
|
|
|
232 (<= clevel level)
|
|
|
233 (>= clevel lowest) ; Is inside the level we want.
|
|
|
234 (or all
|
|
|
235 (if (eq unread t)
|
|
|
236 gnus-group-list-inactive-groups
|
|
|
237 (> unread 0))
|
|
|
238 (and gnus-list-groups-with-ticked-articles
|
|
|
239 (cdr (assq 'tick (gnus-info-marks info))))
|
|
|
240 ; Has right readedness.
|
|
|
241 ;; Check for permanent visibility.
|
|
|
242 (and gnus-permanently-visible-groups
|
|
|
243 (string-match gnus-permanently-visible-groups group))
|
|
|
244 (memq 'visible params)
|
|
|
245 (cdr (assq 'visible params)))
|
|
|
246 ;; Add this group to the list of visible groups.
|
|
|
247 (push (or entry group) visible-groups)))
|
|
|
248 (nreverse visible-groups)))
|
|
|
249
|
|
|
250 (defun gnus-topic-remove-topic (&optional insert total-remove hide in-level)
|
|
|
251 "Remove the current topic."
|
|
|
252 (let ((topic (gnus-group-topic-name))
|
|
|
253 (level (gnus-group-topic-level))
|
|
|
254 (beg (progn (beginning-of-line) (point)))
|
|
|
255 buffer-read-only)
|
|
|
256 (when topic
|
|
|
257 (while (and (zerop (forward-line 1))
|
|
|
258 (> (or (gnus-group-topic-level) (1+ level)) level)))
|
|
|
259 (delete-region beg (point))
|
|
|
260 (setcar (cdadr (gnus-topic-find-topology topic))
|
|
|
261 (if insert 'visible 'invisible))
|
|
|
262 (when hide
|
|
|
263 (setcdr (cdadr (gnus-topic-find-topology topic))
|
|
|
264 (list hide)))
|
|
|
265 (unless total-remove
|
|
|
266 (gnus-topic-insert-topic topic in-level)))))
|
|
|
267
|
|
|
268 (defun gnus-topic-insert-topic (topic &optional level)
|
|
|
269 "Insert TOPIC."
|
|
|
270 (gnus-group-prepare-topics
|
|
|
271 (car gnus-group-list-mode) (cdr gnus-group-list-mode)
|
|
|
272 nil nil topic level))
|
|
|
273
|
|
|
274 (defun gnus-topic-fold (&optional insert)
|
|
|
275 "Remove/insert the current topic."
|
|
|
276 (let ((topic (gnus-group-topic-name)))
|
|
|
277 (when topic
|
|
|
278 (save-excursion
|
|
|
279 (if (not (gnus-group-active-topic-p))
|
|
|
280 (gnus-topic-remove-topic
|
|
|
281 (or insert (not (gnus-topic-visible-p))))
|
|
|
282 (let ((gnus-topic-topology gnus-topic-active-topology)
|
|
|
283 (gnus-topic-alist gnus-topic-active-alist)
|
|
|
284 (gnus-group-list-mode (cons 5 t)))
|
|
|
285 (gnus-topic-remove-topic
|
|
|
286 (or insert (not (gnus-topic-visible-p))) nil nil 9)))))))
|
|
|
287
|
|
|
288 (defun gnus-group-topic-p ()
|
|
|
289 "Return non-nil if the current line is a topic."
|
|
|
290 (gnus-group-topic-name))
|
|
|
291
|
|
|
292 (defun gnus-topic-visible-p ()
|
|
|
293 "Return non-nil if the current topic is visible."
|
|
|
294 (get-text-property (gnus-point-at-bol) 'gnus-topic-visible))
|
|
|
295
|
|
|
296 (defun gnus-topic-insert-topic-line (name visiblep shownp level entries
|
|
|
297 &optional unread)
|
|
|
298 (let* ((visible (if visiblep "" "..."))
|
|
|
299 (indentation (make-string (* gnus-topic-indent-level level) ? ))
|
|
|
300 (total-number-of-articles unread)
|
|
|
301 (number-of-groups (length entries))
|
|
|
302 (active-topic (eq gnus-topic-alist gnus-topic-active-alist)))
|
|
|
303 (beginning-of-line)
|
|
|
304 ;; Insert the text.
|
|
|
305 (gnus-add-text-properties
|
|
|
306 (point)
|
|
|
307 (prog1 (1+ (point))
|
|
|
308 (eval gnus-topic-line-format-spec)
|
|
|
309 (gnus-topic-remove-excess-properties)1)
|
|
|
310 (list 'gnus-topic (intern name)
|
|
|
311 'gnus-topic-level level
|
|
|
312 'gnus-topic-unread unread
|
|
|
313 'gnus-active active-topic
|
|
|
314 'gnus-topic-visible visiblep))))
|
|
|
315
|
|
|
316 (defun gnus-topic-previous-topic (topic)
|
|
|
317 "Return the previous topic on the same level as TOPIC."
|
|
|
318 (let ((top (cddr (gnus-topic-find-topology
|
|
|
319 (gnus-topic-parent-topic topic)))))
|
|
|
320 (unless (equal topic (caaar top))
|
|
|
321 (while (and top (not (equal (caaadr top) topic)))
|
|
|
322 (setq top (cdr top)))
|
|
|
323 (caaar top))))
|
|
|
324
|
|
|
325 (defun gnus-topic-parent-topic (topic &optional topology)
|
|
|
326 "Return the parent of TOPIC."
|
|
|
327 (unless topology
|
|
|
328 (setq topology gnus-topic-topology))
|
|
|
329 (let ((parent (car (pop topology)))
|
|
|
330 result found)
|
|
|
331 (while (and topology
|
|
|
332 (not (setq found (equal (caaar topology) topic)))
|
|
|
333 (not (setq result (gnus-topic-parent-topic topic
|
|
|
334 (car topology)))))
|
|
|
335 (setq topology (cdr topology)))
|
|
|
336 (or result (and found parent))))
|
|
|
337
|
|
|
338 (defun gnus-topic-next-topic (topic &optional previous)
|
|
|
339 "Return the next sibling of TOPIC."
|
|
|
340 (let ((topology gnus-topic-topology)
|
|
|
341 (parentt (cddr (gnus-topic-find-topology
|
|
|
342 (gnus-topic-parent-topic topic))))
|
|
|
343 prev)
|
|
|
344 (while (and parentt
|
|
|
345 (not (equal (caaar parentt) topic)))
|
|
|
346 (setq prev (caaar parentt)
|
|
|
347 parentt (cdr parentt)))
|
|
|
348 (if previous
|
|
|
349 prev
|
|
|
350 (caaadr parentt))))
|
|
|
351
|
|
|
352 (defun gnus-topic-find-topology (topic &optional topology level remove)
|
|
|
353 "Return the topology of TOPIC."
|
|
|
354 (unless topology
|
|
|
355 (setq topology gnus-topic-topology)
|
|
|
356 (setq level 0))
|
|
|
357 (let ((top topology)
|
|
|
358 result)
|
|
|
359 (if (equal (caar topology) topic)
|
|
|
360 (progn
|
|
|
361 (when remove
|
|
|
362 (delq topology remove))
|
|
|
363 (cons level topology))
|
|
|
364 (setq topology (cdr topology))
|
|
|
365 (while (and topology
|
|
|
366 (not (setq result (gnus-topic-find-topology
|
|
|
367 topic (car topology) (1+ level)
|
|
|
368 (and remove top)))))
|
|
|
369 (setq topology (cdr topology)))
|
|
|
370 result)))
|
|
|
371
|
|
|
372 (gnus-add-shutdown 'gnus-topic-close 'gnus)
|
|
|
373
|
|
|
374 (defun gnus-topic-close ()
|
|
|
375 (setq gnus-topic-active-topology nil
|
|
|
376 gnus-topic-active-alist nil
|
|
|
377 gnus-topic-killed-topics nil
|
|
|
378 gnus-topic-tallied-groups nil
|
|
|
379 gnus-topology-checked-p nil))
|
|
|
380
|
|
2
|
381
|
|
0
|
382 (defun gnus-topic-check-topology ()
|
|
|
383 ;; The first time we set the topology to whatever we have
|
|
|
384 ;; gotten here, which can be rather random.
|
|
|
385 (unless gnus-topic-alist
|
|
|
386 (gnus-topic-init-alist))
|
|
|
387
|
|
|
388 (setq gnus-topology-checked-p t)
|
|
2
|
389 ;; Go through the topic alist and make sure that all topics
|
|
|
390 ;; are in the topic topology.
|
|
0
|
391 (let ((topics (gnus-topic-list))
|
|
|
392 (alist gnus-topic-alist)
|
|
|
393 changed)
|
|
|
394 (while alist
|
|
|
395 (unless (member (caar alist) topics)
|
|
|
396 (nconc gnus-topic-topology
|
|
|
397 (list (list (list (caar alist) 'visible))))
|
|
|
398 (setq changed t))
|
|
|
399 (setq alist (cdr alist)))
|
|
|
400 (when changed
|
|
2
|
401 (gnus-topic-enter-dribble))
|
|
|
402 ;; Conversely, go through the topology and make sure that all
|
|
|
403 ;; topologies have alists.
|
|
|
404 (while topics
|
|
|
405 (unless (assoc (car topics) gnus-topic-alist)
|
|
|
406 (push (list (car topics)) gnus-topic-alist))
|
|
|
407 (pop topics)))
|
|
|
408 ;; Go through all living groups and make sure that
|
|
|
409 ;; they belong to some topic.
|
|
0
|
410 (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry))
|
|
|
411 gnus-topic-alist)))
|
|
|
412 (entry (assoc (caar gnus-topic-topology) gnus-topic-alist))
|
|
|
413 (newsrc gnus-newsrc-alist)
|
|
|
414 group)
|
|
|
415 (while newsrc
|
|
|
416 (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)
|
|
2
|
417 (setcdr entry (cons group (cdr entry))))))
|
|
|
418 ;; Go through all topics and make sure they contain only living groups.
|
|
|
419 (let ((alist gnus-topic-alist)
|
|
|
420 topic)
|
|
|
421 (while (setq topic (pop alist))
|
|
|
422 (while (cdr topic)
|
|
|
423 (if (gnus-gethash (cadr topic) gnus-newsrc-hashtb)
|
|
|
424 (setq topic (cdr topic))
|
|
|
425 (setcdr topic (cddr topic)))))))
|
|
0
|
426
|
|
|
427 (defvar gnus-tmp-topics nil)
|
|
|
428 (defun gnus-topic-list (&optional topology)
|
|
|
429 (unless topology
|
|
|
430 (setq topology gnus-topic-topology
|
|
|
431 gnus-tmp-topics nil))
|
|
|
432 (push (caar topology) gnus-tmp-topics)
|
|
|
433 (mapcar 'gnus-topic-list (cdr topology))
|
|
|
434 gnus-tmp-topics)
|
|
|
435
|
|
|
436 (defun gnus-topic-enter-dribble ()
|
|
|
437 (gnus-dribble-enter
|
|
|
438 (format "(setq gnus-topic-topology '%S)" gnus-topic-topology)))
|
|
|
439
|
|
|
440 (defun gnus-topic-articles-in-topic (entries)
|
|
|
441 (let ((total 0)
|
|
|
442 number)
|
|
|
443 (while entries
|
|
|
444 (when (numberp (setq number (car (pop entries))))
|
|
|
445 (incf total number)))
|
|
|
446 total))
|
|
|
447
|
|
|
448 (defun gnus-group-topic (group)
|
|
|
449 "Return the topic GROUP is a member of."
|
|
|
450 (let ((alist gnus-topic-alist)
|
|
|
451 out)
|
|
|
452 (while alist
|
|
|
453 (when (member group (cdar alist))
|
|
|
454 (setq out (caar alist)
|
|
|
455 alist nil))
|
|
|
456 (setq alist (cdr alist)))
|
|
|
457 out))
|
|
|
458
|
|
|
459 (defun gnus-topic-goto-topic (topic)
|
|
|
460 "Go to TOPIC."
|
|
|
461 (when topic
|
|
|
462 (gnus-goto-char (text-property-any (point-min) (point-max)
|
|
|
463 'gnus-topic (intern topic)))))
|
|
|
464
|
|
|
465 (defun gnus-group-parent-topic ()
|
|
|
466 "Return the name of the current topic."
|
|
|
467 (let ((result
|
|
|
468 (or (get-text-property (point) 'gnus-topic)
|
|
|
469 (save-excursion
|
|
|
470 (and (gnus-goto-char (previous-single-property-change
|
|
|
471 (point) 'gnus-topic))
|
|
|
472 (get-text-property (max (1- (point)) (point-min))
|
|
|
473 'gnus-topic))))))
|
|
|
474 (when result
|
|
|
475 (symbol-name result))))
|
|
|
476
|
|
|
477 (defun gnus-topic-update-topic ()
|
|
|
478 "Update all parent topics to the current group."
|
|
|
479 (when (and (eq major-mode 'gnus-group-mode)
|
|
|
480 gnus-topic-mode)
|
|
|
481 (let ((group (gnus-group-group-name))
|
|
|
482 (buffer-read-only nil))
|
|
|
483 (when (and group (gnus-get-info group)
|
|
|
484 (gnus-topic-goto-topic (gnus-group-parent-topic)))
|
|
|
485 (gnus-topic-update-topic-line (gnus-group-topic-name))
|
|
|
486 (gnus-group-goto-group group)
|
|
|
487 (gnus-group-position-point)))))
|
|
|
488
|
|
|
489 (defun gnus-topic-goto-missing-group (group)
|
|
|
490 "Place point where GROUP is supposed to be inserted."
|
|
|
491 (let* ((topic (gnus-group-topic group))
|
|
|
492 (groups (cdr (assoc topic gnus-topic-alist)))
|
|
|
493 (g (cdr (member group groups)))
|
|
|
494 (unfound t))
|
|
|
495 (while (and g unfound)
|
|
|
496 (when (gnus-group-goto-group (pop g))
|
|
|
497 (beginning-of-line)
|
|
|
498 (setq unfound nil)))
|
|
|
499 (when unfound
|
|
|
500 (setq g (cdr (member group (reverse groups))))
|
|
|
501 (while (and g unfound)
|
|
|
502 (when (gnus-group-goto-group (pop g))
|
|
|
503 (forward-line 1)
|
|
|
504 (setq unfound nil)))
|
|
|
505 (when unfound
|
|
|
506 (gnus-topic-goto-topic topic)
|
|
|
507 (forward-line 1)))))
|
|
|
508
|
|
|
509 (defun gnus-topic-update-topic-line (topic-name &optional reads)
|
|
|
510 (let* ((top (gnus-topic-find-topology topic-name))
|
|
|
511 (type (cadr top))
|
|
|
512 (children (cddr top))
|
|
|
513 (entries (gnus-topic-find-groups
|
|
|
514 (car type) (car gnus-group-list-mode)
|
|
|
515 (cdr gnus-group-list-mode)))
|
|
|
516 (parent (gnus-topic-parent-topic topic-name))
|
|
|
517 (all-entries entries)
|
|
|
518 (unread 0)
|
|
|
519 old-unread entry)
|
|
|
520 (when (gnus-topic-goto-topic (car type))
|
|
|
521 ;; Tally all the groups that belong in this topic.
|
|
|
522 (if reads
|
|
|
523 (setq unread (- (gnus-group-topic-unread) reads))
|
|
|
524 (while children
|
|
|
525 (incf unread (gnus-topic-unread (caar (pop children)))))
|
|
|
526 (while (setq entry (pop entries))
|
|
|
527 (when (numberp (car entry))
|
|
|
528 (incf unread (car entry)))))
|
|
|
529 (setq old-unread (gnus-group-topic-unread))
|
|
|
530 ;; Insert the topic line.
|
|
|
531 (gnus-topic-insert-topic-line
|
|
|
532 (car type) (gnus-topic-visible-p)
|
|
|
533 (not (eq (nth 2 type) 'hidden))
|
|
|
534 (gnus-group-topic-level) all-entries unread)
|
|
|
535 (gnus-delete-line))
|
|
|
536 (when parent
|
|
|
537 (forward-line -1)
|
|
|
538 (gnus-topic-update-topic-line
|
|
|
539 parent (- old-unread (gnus-group-topic-unread))))
|
|
|
540 unread))
|
|
|
541
|
|
|
542 (defun gnus-topic-grok-active (&optional force)
|
|
|
543 "Parse all active groups and create topic structures for them."
|
|
|
544 ;; First we make sure that we have really read the active file.
|
|
|
545 (when (or force
|
|
|
546 (not gnus-topic-active-alist))
|
|
|
547 (let (groups)
|
|
|
548 ;; Get a list of all groups available.
|
|
|
549 (mapatoms (lambda (g) (when (symbol-value g)
|
|
|
550 (push (symbol-name g) groups)))
|
|
|
551 gnus-active-hashtb)
|
|
|
552 (setq groups (sort groups 'string<))
|
|
|
553 ;; Init the variables.
|
|
|
554 (setq gnus-topic-active-topology (list (list "" 'visible)))
|
|
|
555 (setq gnus-topic-active-alist nil)
|
|
|
556 ;; Descend the top-level hierarchy.
|
|
|
557 (gnus-topic-grok-active-1 gnus-topic-active-topology groups)
|
|
|
558 ;; Set the top-level topic names to something nice.
|
|
|
559 (setcar (car gnus-topic-active-topology) "Gnus active")
|
|
|
560 (setcar (car gnus-topic-active-alist) "Gnus active"))))
|
|
|
561
|
|
|
562 (defun gnus-topic-grok-active-1 (topology groups)
|
|
|
563 (let* ((name (caar topology))
|
|
|
564 (prefix (concat "^" (regexp-quote name)))
|
|
|
565 tgroups ntopology group)
|
|
|
566 (while (and groups
|
|
|
567 (string-match prefix (setq group (car groups))))
|
|
|
568 (if (not (string-match "\\." group (match-end 0)))
|
|
|
569 ;; There are no further hierarchies here, so we just
|
|
|
570 ;; enter this group into the list belonging to this
|
|
|
571 ;; topic.
|
|
|
572 (push (pop groups) tgroups)
|
|
|
573 ;; New sub-hierarchy, so we add it to the topology.
|
|
|
574 (nconc topology (list (setq ntopology
|
|
|
575 (list (list (substring
|
|
|
576 group 0 (match-end 0))
|
|
|
577 'invisible)))))
|
|
|
578 ;; Descend the hierarchy.
|
|
|
579 (setq groups (gnus-topic-grok-active-1 ntopology groups))))
|
|
|
580 ;; We remove the trailing "." from the topic name.
|
|
|
581 (setq name
|
|
|
582 (if (string-match "\\.$" name)
|
|
|
583 (substring name 0 (match-beginning 0))
|
|
|
584 name))
|
|
|
585 ;; Add this topic and its groups to the topic alist.
|
|
|
586 (push (cons name (nreverse tgroups)) gnus-topic-active-alist)
|
|
|
587 (setcar (car topology) name)
|
|
|
588 ;; We return the rest of the groups that didn't belong
|
|
|
589 ;; to this topic.
|
|
|
590 groups))
|
|
|
591
|
|
|
592 (defun gnus-group-active-topic-p ()
|
|
|
593 "Return whether the current active comes from the active topics."
|
|
|
594 (save-excursion
|
|
|
595 (beginning-of-line)
|
|
|
596 (get-text-property (point) 'gnus-active)))
|
|
|
597
|
|
|
598 ;;; Topic mode, commands and keymap.
|
|
|
599
|
|
|
600 (defvar gnus-topic-mode-map nil)
|
|
|
601 (defvar gnus-group-topic-map nil)
|
|
|
602
|
|
|
603 (unless gnus-topic-mode-map
|
|
|
604 (setq gnus-topic-mode-map (make-sparse-keymap))
|
|
|
605
|
|
|
606 ;; Override certain group mode keys.
|
|
|
607 (gnus-define-keys
|
|
|
608 gnus-topic-mode-map
|
|
|
609 "=" gnus-topic-select-group
|
|
|
610 "\r" gnus-topic-select-group
|
|
|
611 " " gnus-topic-read-group
|
|
|
612 "\C-k" gnus-topic-kill-group
|
|
|
613 "\C-y" gnus-topic-yank-group
|
|
|
614 "\M-g" gnus-topic-get-new-news-this-topic
|
|
|
615 "AT" gnus-topic-list-active
|
|
|
616 gnus-mouse-2 gnus-mouse-pick-topic)
|
|
|
617
|
|
|
618 ;; Define a new submap.
|
|
|
619 (gnus-define-keys
|
|
|
620 (gnus-group-topic-map "T" gnus-group-mode-map)
|
|
|
621 "#" gnus-topic-mark-topic
|
|
|
622 "\M-#" gnus-topic-unmark-topic
|
|
|
623 "n" gnus-topic-create-topic
|
|
|
624 "m" gnus-topic-move-group
|
|
|
625 "D" gnus-topic-remove-group
|
|
|
626 "c" gnus-topic-copy-group
|
|
|
627 "h" gnus-topic-hide-topic
|
|
|
628 "s" gnus-topic-show-topic
|
|
|
629 "M" gnus-topic-move-matching
|
|
|
630 "C" gnus-topic-copy-matching
|
|
|
631 "\C-i" gnus-topic-indent
|
|
|
632 [tab] gnus-topic-indent
|
|
|
633 "r" gnus-topic-rename
|
|
|
634 "\177" gnus-topic-delete))
|
|
|
635
|
|
|
636 (defun gnus-topic-make-menu-bar ()
|
|
|
637 (unless (boundp 'gnus-topic-menu)
|
|
|
638 (easy-menu-define
|
|
|
639 gnus-topic-menu gnus-topic-mode-map ""
|
|
|
640 '("Topics"
|
|
|
641 ["Toggle topics" gnus-topic-mode t]
|
|
|
642 ("Groups"
|
|
|
643 ["Copy" gnus-topic-copy-group t]
|
|
|
644 ["Move" gnus-topic-move-group t]
|
|
|
645 ["Remove" gnus-topic-remove-group t]
|
|
|
646 ["Copy matching" gnus-topic-copy-matching t]
|
|
|
647 ["Move matching" gnus-topic-move-matching t])
|
|
|
648 ("Topics"
|
|
|
649 ["Show" gnus-topic-show-topic t]
|
|
|
650 ["Hide" gnus-topic-hide-topic t]
|
|
|
651 ["Delete" gnus-topic-delete t]
|
|
|
652 ["Rename" gnus-topic-rename t]
|
|
|
653 ["Create" gnus-topic-create-topic t]
|
|
|
654 ["Mark" gnus-topic-mark-topic t]
|
|
|
655 ["Indent" gnus-topic-indent t])
|
|
|
656 ["List active" gnus-topic-list-active t]))))
|
|
|
657
|
|
|
658 (defun gnus-topic-mode (&optional arg redisplay)
|
|
|
659 "Minor mode for topicsifying Gnus group buffers."
|
|
|
660 (interactive (list current-prefix-arg t))
|
|
|
661 (when (eq major-mode 'gnus-group-mode)
|
|
|
662 (make-local-variable 'gnus-topic-mode)
|
|
|
663 (setq gnus-topic-mode
|
|
|
664 (if (null arg) (not gnus-topic-mode)
|
|
|
665 (> (prefix-numeric-value arg) 0)))
|
|
|
666 ;; Infest Gnus with topics.
|
|
|
667 (when gnus-topic-mode
|
|
|
668 (when (and menu-bar-mode
|
|
|
669 (gnus-visual-p 'topic-menu 'menu))
|
|
|
670 (gnus-topic-make-menu-bar))
|
|
|
671 (setq gnus-topic-line-format-spec
|
|
|
672 (gnus-parse-format gnus-topic-line-format
|
|
|
673 gnus-topic-line-format-alist t))
|
|
|
674 (unless (assq 'gnus-topic-mode minor-mode-alist)
|
|
|
675 (push '(gnus-topic-mode " Topic") minor-mode-alist))
|
|
|
676 (unless (assq 'gnus-topic-mode minor-mode-map-alist)
|
|
|
677 (push (cons 'gnus-topic-mode gnus-topic-mode-map)
|
|
|
678 minor-mode-map-alist))
|
|
|
679 (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
|
|
|
680 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
|
|
|
681 (add-hook 'gnus-group-update-group-hook 'gnus-topic-update-topic)
|
|
|
682 (make-local-variable 'gnus-group-prepare-function)
|
|
|
683 (setq gnus-group-prepare-function 'gnus-group-prepare-topics)
|
|
|
684 (make-local-variable 'gnus-group-goto-next-group-function)
|
|
|
685 (setq gnus-group-goto-next-group-function
|
|
|
686 'gnus-topic-goto-next-group)
|
|
|
687 (setq gnus-group-change-level-function 'gnus-topic-change-level)
|
|
|
688 (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group)
|
|
|
689 (make-local-variable 'gnus-group-indentation-function)
|
|
|
690 (setq gnus-group-indentation-function
|
|
|
691 'gnus-topic-group-indentation)
|
|
2
|
692 (gnus-make-local-hook 'gnus-check-bogus-groups-hook)
|
|
|
693 (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist)
|
|
0
|
694 (setq gnus-topology-checked-p nil)
|
|
|
695 ;; We check the topology.
|
|
|
696 (when gnus-newsrc-alist
|
|
|
697 (gnus-topic-check-topology))
|
|
|
698 (run-hooks 'gnus-topic-mode-hook))
|
|
|
699 ;; Remove topic infestation.
|
|
|
700 (unless gnus-topic-mode
|
|
|
701 (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
|
|
|
702 (remove-hook 'gnus-group-change-level-function
|
|
|
703 'gnus-topic-change-level)
|
|
2
|
704 (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist)
|
|
0
|
705 (setq gnus-group-prepare-function 'gnus-group-prepare-flat))
|
|
|
706 (when redisplay
|
|
|
707 (gnus-group-list-groups))))
|
|
|
708
|
|
|
709 (defun gnus-topic-select-group (&optional all)
|
|
|
710 "Select this newsgroup.
|
|
|
711 No article is selected automatically.
|
|
|
712 If ALL is non-nil, already read articles become readable.
|
|
2
|
713 If ALL is a number, fetch this number of articles.
|
|
|
714
|
|
|
715 If performed over a topic line, toggle folding the topic."
|
|
0
|
716 (interactive "P")
|
|
|
717 (if (gnus-group-topic-p)
|
|
|
718 (let ((gnus-group-list-mode
|
|
|
719 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
|
|
|
720 (gnus-topic-fold all))
|
|
|
721 (gnus-group-select-group all)))
|
|
|
722
|
|
|
723 (defun gnus-mouse-pick-topic (e)
|
|
|
724 "Select the group or topic under the mouse pointer."
|
|
|
725 (interactive "e")
|
|
|
726 (mouse-set-point e)
|
|
|
727 (gnus-topic-read-group nil))
|
|
|
728
|
|
|
729 (defun gnus-topic-read-group (&optional all no-article group)
|
|
|
730 "Read news in this newsgroup.
|
|
|
731 If the prefix argument ALL is non-nil, already read articles become
|
|
|
732 readable. IF ALL is a number, fetch this number of articles. If the
|
|
|
733 optional argument NO-ARTICLE is non-nil, no article will be
|
|
|
734 auto-selected upon group entry. If GROUP is non-nil, fetch that
|
|
2
|
735 group.
|
|
|
736
|
|
|
737 If performed over a topic line, toggle folding the topic."
|
|
0
|
738 (interactive "P")
|
|
|
739 (if (gnus-group-topic-p)
|
|
|
740 (let ((gnus-group-list-mode
|
|
|
741 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
|
|
|
742 (gnus-topic-fold all))
|
|
|
743 (gnus-group-read-group all no-article group)))
|
|
|
744
|
|
|
745 (defun gnus-topic-create-topic (topic parent &optional previous full-topic)
|
|
|
746 (interactive
|
|
|
747 (list
|
|
|
748 (read-string "New topic: ")
|
|
|
749 (gnus-group-parent-topic)))
|
|
|
750 ;; Check whether this topic already exists.
|
|
|
751 (when (gnus-topic-find-topology topic)
|
|
|
752 (error "Topic aleady exists"))
|
|
|
753 (unless parent
|
|
|
754 (setq parent (caar gnus-topic-topology)))
|
|
|
755 (let ((top (cdr (gnus-topic-find-topology parent)))
|
|
|
756 (full-topic (or full-topic `((,topic visible)))))
|
|
|
757 (unless top
|
|
|
758 (error "No such parent topic: %s" parent))
|
|
|
759 (if previous
|
|
|
760 (progn
|
|
|
761 (while (and (cdr top)
|
|
|
762 (not (equal (caaadr top) previous)))
|
|
|
763 (setq top (cdr top)))
|
|
|
764 (setcdr top (cons full-topic (cdr top))))
|
|
|
765 (nconc top (list full-topic)))
|
|
|
766 (unless (assoc topic gnus-topic-alist)
|
|
|
767 (push (list topic) gnus-topic-alist)))
|
|
|
768 (gnus-topic-enter-dribble)
|
|
|
769 (gnus-group-list-groups)
|
|
|
770 (gnus-topic-goto-topic topic))
|
|
|
771
|
|
|
772 (defun gnus-topic-move-group (n topic &optional copyp)
|
|
|
773 "Move the next N groups to TOPIC.
|
|
|
774 If COPYP, copy the groups instead."
|
|
|
775 (interactive
|
|
|
776 (list current-prefix-arg
|
|
|
777 (completing-read "Move to topic: " gnus-topic-alist nil t)))
|
|
|
778 (let ((groups (gnus-group-process-prefix n))
|
|
|
779 (topicl (assoc topic gnus-topic-alist))
|
|
|
780 entry)
|
|
|
781 (mapcar (lambda (g)
|
|
|
782 (gnus-group-remove-mark g)
|
|
|
783 (when (and
|
|
|
784 (setq entry (assoc (gnus-group-parent-topic)
|
|
|
785 gnus-topic-alist))
|
|
|
786 (not copyp))
|
|
|
787 (setcdr entry (gnus-delete-first g (cdr entry))))
|
|
|
788 (nconc topicl (list g)))
|
|
|
789 groups)
|
|
|
790 (gnus-group-position-point))
|
|
|
791 (gnus-topic-enter-dribble)
|
|
|
792 (gnus-group-list-groups))
|
|
|
793
|
|
|
794 (defun gnus-topic-remove-group ()
|
|
|
795 "Remove the current group from the topic."
|
|
|
796 (interactive)
|
|
|
797 (let ((topicl (assoc (gnus-group-parent-topic) gnus-topic-alist))
|
|
|
798 (group (gnus-group-group-name))
|
|
|
799 (buffer-read-only nil))
|
|
|
800 (when (and topicl group)
|
|
|
801 (gnus-delete-line)
|
|
|
802 (gnus-delete-first group topicl))
|
|
|
803 (gnus-group-position-point)))
|
|
|
804
|
|
|
805 (defun gnus-topic-copy-group (n topic)
|
|
|
806 "Copy the current group to a topic."
|
|
|
807 (interactive
|
|
|
808 (list current-prefix-arg
|
|
|
809 (completing-read "Copy to topic: " gnus-topic-alist nil t)))
|
|
|
810 (gnus-topic-move-group n topic t))
|
|
|
811
|
|
|
812 (defun gnus-topic-group-indentation ()
|
|
|
813 (make-string
|
|
|
814 (* gnus-topic-indent-level
|
|
|
815 (or (save-excursion
|
|
|
816 (gnus-topic-goto-topic (gnus-group-parent-topic))
|
|
|
817 (gnus-group-topic-level)) 0)) ? ))
|
|
|
818
|
|
2
|
819 (defun gnus-topic-clean-alist ()
|
|
|
820 "Remove bogus groups from the topic alist."
|
|
|
821 (let ((topic-alist gnus-topic-alist)
|
|
|
822 result topic)
|
|
|
823 (unless gnus-killed-hashtb
|
|
|
824 (gnus-make-hashtable-from-killed))
|
|
|
825 (while (setq topic (pop topic-alist))
|
|
|
826 (let ((topic-name (pop topic))
|
|
|
827 group filtered-topic)
|
|
|
828 (while (setq group (pop topic))
|
|
|
829 (if (and (gnus-gethash group gnus-active-hashtb)
|
|
|
830 (not (gnus-gethash group gnus-killed-hashtb)))
|
|
|
831 (push group filtered-topic)))
|
|
|
832 (push (cons topic-name (nreverse filtered-topic)) result)))
|
|
|
833 (setq gnus-topic-alist (nreverse result))))
|
|
|
834
|
|
0
|
835 (defun gnus-topic-change-level (group level oldlevel)
|
|
|
836 "Run when changing levels to enter/remove groups from topics."
|
|
|
837 (save-excursion
|
|
|
838 (set-buffer gnus-group-buffer)
|
|
|
839 (when (and gnus-topic-mode
|
|
|
840 gnus-topic-alist
|
|
|
841 (not gnus-topic-inhibit-change-level))
|
|
|
842 ;; Remove the group from the topics.
|
|
|
843 (when (and (< oldlevel gnus-level-zombie)
|
|
|
844 (>= level gnus-level-zombie))
|
|
|
845 (let (alist)
|
|
|
846 (forward-line -1)
|
|
|
847 (when (setq alist (assoc (gnus-group-parent-topic) gnus-topic-alist))
|
|
|
848 (setcdr alist (gnus-delete-first group (cdr alist))))))
|
|
|
849 ;; If the group is subscribed. then we enter it into the topics.
|
|
|
850 (when (and (< level gnus-level-zombie)
|
|
|
851 (>= oldlevel gnus-level-zombie))
|
|
|
852 (let* ((prev (gnus-group-group-name))
|
|
|
853 (gnus-topic-inhibit-change-level t)
|
|
|
854 (gnus-group-indentation
|
|
|
855 (make-string
|
|
|
856 (* gnus-topic-indent-level
|
|
|
857 (or (save-excursion
|
|
|
858 (gnus-topic-goto-topic (gnus-group-parent-topic))
|
|
|
859 (gnus-group-topic-level)) 0)) ? ))
|
|
|
860 (yanked (list group))
|
|
|
861 alist talist end)
|
|
|
862 ;; Then we enter the yanked groups into the topics they belong
|
|
|
863 ;; to.
|
|
|
864 (when (setq alist (assoc (save-excursion
|
|
|
865 (forward-line -1)
|
|
|
866 (or
|
|
|
867 (gnus-group-parent-topic)
|
|
|
868 (caar gnus-topic-topology)))
|
|
|
869 gnus-topic-alist))
|
|
|
870 (setq talist alist)
|
|
|
871 (when (stringp yanked)
|
|
|
872 (setq yanked (list yanked)))
|
|
|
873 (if (not prev)
|
|
|
874 (nconc alist yanked)
|
|
|
875 (if (not (cdr alist))
|
|
|
876 (setcdr alist (nconc yanked (cdr alist)))
|
|
|
877 (while (and (not end) (cdr alist))
|
|
|
878 (when (equal (cadr alist) prev)
|
|
|
879 (setcdr alist (nconc yanked (cdr alist)))
|
|
|
880 (setq end t))
|
|
|
881 (setq alist (cdr alist)))
|
|
|
882 (unless end
|
|
|
883 (nconc talist yanked))))))
|
|
|
884 (gnus-topic-update-topic)))))
|
|
|
885
|
|
|
886 (defun gnus-topic-goto-next-group (group props)
|
|
|
887 "Go to group or the next group after group."
|
|
|
888 (if (null group)
|
|
|
889 (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props))))
|
|
|
890 (if (gnus-group-goto-group group)
|
|
|
891 t
|
|
|
892 ;; The group is no longer visible.
|
|
|
893 (let* ((list (assoc (gnus-group-parent-topic) gnus-topic-alist))
|
|
|
894 (after (cdr (member group (cdr list)))))
|
|
|
895 ;; First try to put point on a group after the current one.
|
|
|
896 (while (and after
|
|
|
897 (not (gnus-group-goto-group (car after))))
|
|
|
898 (setq after (cdr after)))
|
|
|
899 ;; Then try to put point on a group before point.
|
|
|
900 (unless after
|
|
|
901 (setq after (cdr (member group (reverse (cdr list)))))
|
|
|
902 (while (and after
|
|
|
903 (not (gnus-group-goto-group (car after))))
|
|
|
904 (setq after (cdr after))))
|
|
|
905 ;; Finally, just put point on the topic.
|
|
|
906 (unless after
|
|
|
907 (gnus-topic-goto-topic (car list))
|
|
|
908 (setq after nil))
|
|
|
909 t))))
|
|
|
910
|
|
|
911 (defun gnus-topic-kill-group (&optional n discard)
|
|
|
912 "Kill the next N groups."
|
|
|
913 (interactive "P")
|
|
|
914 (if (gnus-group-topic-p)
|
|
|
915 (let ((topic (gnus-group-topic-name)))
|
|
|
916 (gnus-topic-remove-topic nil t)
|
|
|
917 (push (gnus-topic-find-topology topic nil nil gnus-topic-topology)
|
|
|
918 gnus-topic-killed-topics))
|
|
|
919 (gnus-group-kill-group n discard)
|
|
|
920 (gnus-topic-update-topic)))
|
|
|
921
|
|
|
922 (defun gnus-topic-yank-group (&optional arg)
|
|
|
923 "Yank the last topic."
|
|
|
924 (interactive "p")
|
|
|
925 (if gnus-topic-killed-topics
|
|
|
926 (let ((previous
|
|
|
927 (or (gnus-group-topic-name)
|
|
|
928 (gnus-topic-next-topic (gnus-group-parent-topic))))
|
|
|
929 (item (cdr (pop gnus-topic-killed-topics))))
|
|
|
930 (gnus-topic-create-topic
|
|
|
931 (caar item) (gnus-topic-parent-topic previous) previous
|
|
|
932 item)
|
|
|
933 (gnus-topic-goto-topic (caar item)))
|
|
|
934 (let* ((prev (gnus-group-group-name))
|
|
|
935 (gnus-topic-inhibit-change-level t)
|
|
|
936 (gnus-group-indentation
|
|
|
937 (make-string
|
|
|
938 (* gnus-topic-indent-level
|
|
|
939 (or (save-excursion
|
|
|
940 (gnus-topic-goto-topic (gnus-group-parent-topic))
|
|
|
941 (gnus-group-topic-level)) 0)) ? ))
|
|
|
942 yanked alist)
|
|
|
943 ;; We first yank the groups the normal way...
|
|
|
944 (setq yanked (gnus-group-yank-group arg))
|
|
|
945 ;; Then we enter the yanked groups into the topics they belong
|
|
|
946 ;; to.
|
|
|
947 (setq alist (assoc (save-excursion
|
|
|
948 (forward-line -1)
|
|
|
949 (gnus-group-parent-topic))
|
|
|
950 gnus-topic-alist))
|
|
|
951 (when (stringp yanked)
|
|
|
952 (setq yanked (list yanked)))
|
|
|
953 (if (not prev)
|
|
|
954 (nconc alist yanked)
|
|
|
955 (if (not (cdr alist))
|
|
|
956 (setcdr alist (nconc yanked (cdr alist)))
|
|
|
957 (while (cdr alist)
|
|
|
958 (when (equal (cadr alist) prev)
|
|
|
959 (setcdr alist (nconc yanked (cdr alist)))
|
|
|
960 (setq alist nil))
|
|
|
961 (setq alist (cdr alist))))))
|
|
|
962 (gnus-topic-update-topic)))
|
|
|
963
|
|
|
964 (defun gnus-topic-hide-topic ()
|
|
2
|
965 "Hide the current topic."
|
|
0
|
966 (interactive)
|
|
|
967 (when (gnus-group-parent-topic)
|
|
|
968 (gnus-topic-goto-topic (gnus-group-parent-topic))
|
|
|
969 (gnus-topic-remove-topic nil nil 'hidden)))
|
|
|
970
|
|
|
971 (defun gnus-topic-show-topic ()
|
|
|
972 "Show the hidden topic."
|
|
|
973 (interactive)
|
|
|
974 (when (gnus-group-topic-p)
|
|
|
975 (gnus-topic-remove-topic t nil 'shown)))
|
|
|
976
|
|
|
977 (defun gnus-topic-mark-topic (topic &optional unmark)
|
|
|
978 "Mark all groups in the topic with the process mark."
|
|
|
979 (interactive (list (gnus-group-parent-topic)))
|
|
|
980 (save-excursion
|
|
|
981 (let ((groups (gnus-topic-find-groups topic 9 t)))
|
|
|
982 (while groups
|
|
|
983 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
|
|
|
984 (gnus-info-group (nth 2 (pop groups))))))))
|
|
|
985
|
|
|
986 (defun gnus-topic-unmark-topic (topic &optional unmark)
|
|
|
987 "Remove the process mark from all groups in the topic."
|
|
|
988 (interactive (list (gnus-group-parent-topic)))
|
|
|
989 (gnus-topic-mark-topic topic t))
|
|
|
990
|
|
|
991 (defun gnus-topic-get-new-news-this-topic (&optional n)
|
|
|
992 "Check for new news in the current topic."
|
|
|
993 (interactive "P")
|
|
|
994 (if (not (gnus-group-topic-p))
|
|
|
995 (gnus-group-get-new-news-this-group n)
|
|
|
996 (gnus-topic-mark-topic (gnus-group-topic-name))
|
|
|
997 (gnus-group-get-new-news-this-group)))
|
|
|
998
|
|
|
999 (defun gnus-topic-move-matching (regexp topic &optional copyp)
|
|
|
1000 "Move all groups that match REGEXP to some topic."
|
|
|
1001 (interactive
|
|
|
1002 (let (topic)
|
|
|
1003 (nreverse
|
|
|
1004 (list
|
|
|
1005 (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t))
|
|
|
1006 (read-string (format "Move to %s (regexp): " topic))))))
|
|
|
1007 (gnus-group-mark-regexp regexp)
|
|
|
1008 (gnus-topic-move-group nil topic copyp))
|
|
|
1009
|
|
|
1010 (defun gnus-topic-copy-matching (regexp topic &optional copyp)
|
|
|
1011 "Copy all groups that match REGEXP to some topic."
|
|
|
1012 (interactive
|
|
|
1013 (let (topic)
|
|
|
1014 (nreverse
|
|
|
1015 (list
|
|
|
1016 (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t))
|
|
|
1017 (read-string (format "Copy to %s (regexp): " topic))))))
|
|
|
1018 (gnus-topic-move-matching regexp topic t))
|
|
|
1019
|
|
|
1020 (defun gnus-topic-delete (topic)
|
|
|
1021 "Delete a topic."
|
|
|
1022 (interactive (list (gnus-group-topic-name)))
|
|
|
1023 (unless topic
|
|
|
1024 (error "No topic to be deleted"))
|
|
|
1025 (let ((entry (assoc topic gnus-topic-alist))
|
|
|
1026 (buffer-read-only nil))
|
|
|
1027 (when (cdr entry)
|
|
|
1028 (error "Topic not empty"))
|
|
|
1029 ;; Delete if visible.
|
|
|
1030 (when (gnus-topic-goto-topic topic)
|
|
|
1031 (gnus-delete-line))
|
|
|
1032 ;; Remove from alist.
|
|
|
1033 (setq gnus-topic-alist (delq entry gnus-topic-alist))
|
|
|
1034 ;; Remove from topology.
|
|
|
1035 (gnus-topic-find-topology topic nil nil 'delete)))
|
|
|
1036
|
|
|
1037 (defun gnus-topic-rename (old-name new-name)
|
|
|
1038 "Rename a topic."
|
|
|
1039 (interactive
|
|
|
1040 (let ((topic (gnus-group-parent-topic)))
|
|
|
1041 (list topic
|
|
|
1042 (read-string (format "Rename %s to: " topic)))))
|
|
|
1043 (let ((top (gnus-topic-find-topology old-name))
|
|
|
1044 (entry (assoc old-name gnus-topic-alist)))
|
|
|
1045 (when top
|
|
|
1046 (setcar (cadr top) new-name))
|
|
|
1047 (when entry
|
|
|
1048 (setcar entry new-name))
|
|
2
|
1049 (forward-line -1)
|
|
0
|
1050 (gnus-group-list-groups)))
|
|
|
1051
|
|
|
1052 (defun gnus-topic-indent (&optional unindent)
|
|
|
1053 "Indent a topic -- make it a sub-topic of the previous topic.
|
|
|
1054 If UNINDENT, remove an indentation."
|
|
|
1055 (interactive "P")
|
|
|
1056 (if unindent
|
|
|
1057 (gnus-topic-unindent)
|
|
|
1058 (let* ((topic (gnus-group-parent-topic))
|
|
|
1059 (parent (gnus-topic-previous-topic topic)))
|
|
|
1060 (unless parent
|
|
|
1061 (error "Nothing to indent %s into" topic))
|
|
|
1062 (when topic
|
|
|
1063 (gnus-topic-goto-topic topic)
|
|
|
1064 (gnus-topic-kill-group)
|
|
|
1065 (gnus-topic-create-topic
|
|
|
1066 topic parent nil (cdr (pop gnus-topic-killed-topics)))
|
|
|
1067 (or (gnus-topic-goto-topic topic)
|
|
|
1068 (gnus-topic-goto-topic parent))))))
|
|
|
1069
|
|
|
1070 (defun gnus-topic-unindent ()
|
|
|
1071 "Unindent a topic."
|
|
|
1072 (interactive)
|
|
|
1073 (let* ((topic (gnus-group-parent-topic))
|
|
|
1074 (parent (gnus-topic-parent-topic topic))
|
|
|
1075 (grandparent (gnus-topic-parent-topic parent)))
|
|
|
1076 (unless grandparent
|
|
|
1077 (error "Nothing to indent %s into" topic))
|
|
|
1078 (when topic
|
|
|
1079 (gnus-topic-goto-topic topic)
|
|
|
1080 (gnus-topic-kill-group)
|
|
|
1081 (gnus-topic-create-topic
|
|
|
1082 topic grandparent (gnus-topic-next-topic parent)
|
|
|
1083 (cdr (pop gnus-topic-killed-topics)))
|
|
|
1084 (gnus-topic-goto-topic topic))))
|
|
|
1085
|
|
|
1086 (defun gnus-topic-list-active (&optional force)
|
|
|
1087 "List all groups that Gnus knows about in a topicsified fashion.
|
|
|
1088 If FORCE, always re-read the active file."
|
|
|
1089 (interactive "P")
|
|
|
1090 (when force
|
|
|
1091 (gnus-get-killed-groups))
|
|
|
1092 (gnus-topic-grok-active force)
|
|
|
1093 (let ((gnus-topic-topology gnus-topic-active-topology)
|
|
|
1094 (gnus-topic-alist gnus-topic-active-alist)
|
|
|
1095 gnus-killed-list gnus-zombie-list)
|
|
|
1096 (gnus-group-list-groups 9 nil 1)))
|
|
|
1097
|
|
|
1098 (provide 'gnus-topic)
|
|
|
1099
|
|
|
1100 ;;; gnus-topic.el ends here
|
