Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-topic.el @ 16:0293115a14e9 r19-15b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b91
author cvs
date Mon, 13 Aug 2007 08:49:20 +0200
parents ac2d302a0011
children d95e72db5c07
comparison
equal deleted inserted replaced
15:ad457d5f7d04 16:0293115a14e9
1 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers 1 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
3 3
4 ;; Author: Ilja Weis <kult@uni-paderborn.de> 4 ;; Author: Ilja Weis <kult@uni-paderborn.de>
5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
6 ;; Keywords: news 6 ;; Keywords: news
7 7
25 ;;; Commentary: 25 ;;; Commentary:
26 26
27 ;;; Code: 27 ;;; Code:
28 28
29 (require 'gnus) 29 (require 'gnus)
30 (eval-when-compile (require 'cl)) 30 (require 'gnus-group)
31 (require 'gnus-start)
32
33 (defgroup gnus-topic nil
34 "Group topics."
35 :group 'gnus-group)
31 36
32 (defvar gnus-topic-mode nil 37 (defvar gnus-topic-mode nil
33 "Minor mode for Gnus group buffers.") 38 "Minor mode for Gnus group buffers.")
34 39
35 (defvar gnus-topic-mode-hook nil 40 (defcustom gnus-topic-mode-hook nil
36 "Hook run in topic mode buffers.") 41 "Hook run in topic mode buffers."
37 42 :type 'hook
38 (defvar gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" 43 :group 'gnus-topic)
44
45 (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n"
39 "Format of topic lines. 46 "Format of topic lines.
40 It works along the same lines as a normal formatting string, 47 It works along the same lines as a normal formatting string,
41 with some simple extensions. 48 with some simple extensions.
42 49
43 %i Indentation based on topic level. 50 %i Indentation based on topic level.
44 %n Topic name. 51 %n Topic name.
45 %v Nothing if the topic is visible, \"...\" otherwise. 52 %v Nothing if the topic is visible, \"...\" otherwise.
46 %g Number of groups in the topic. 53 %g Number of groups in the topic.
47 %a Number of unread articles in the groups in the topic. 54 %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. 55 %A Number of unread articles in the groups in the topic and its subtopics.
49 ") 56 "
50 57 :type 'string
51 (defvar gnus-topic-indent-level 2 58 :group 'gnus-topic)
52 "*How much each subtopic should be indented.") 59
60 (defcustom gnus-topic-indent-level 2
61 "*How much each subtopic should be indented."
62 :type 'integer
63 :group 'gnus-topic)
64
65 (defcustom gnus-topic-display-empty-topics t
66 "*If non-nil, display the topic lines even of topics that have no unread articles."
67 :type 'boolean
68 :group 'gnus-topic)
53 69
54 ;; Internal variables. 70 ;; Internal variables.
55 71
56 (defvar gnus-topic-active-topology nil) 72 (defvar gnus-topic-active-topology nil)
57 (defvar gnus-topic-active-alist nil) 73 (defvar gnus-topic-active-alist nil)
72 (?A total-number-of-articles ?d) 88 (?A total-number-of-articles ?d)
73 (?l level ?d))) 89 (?l level ?d)))
74 90
75 (defvar gnus-topic-line-format-spec nil) 91 (defvar gnus-topic-line-format-spec nil)
76 92
77 ;; Functions. 93 ;;; Utility functions
78 94
79 (defun gnus-group-topic-name () 95 (defun gnus-group-topic-name ()
80 "The name of the topic on the current line." 96 "The name of the topic on the current line."
81 (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic))) 97 (let ((topic (get-text-property (point-at-bol) 'gnus-topic)))
82 (and topic (symbol-name topic)))) 98 (and topic (symbol-name topic))))
83 99
84 (defun gnus-group-topic-level () 100 (defun gnus-group-topic-level ()
85 "The level of the topic on the current line." 101 "The level of the topic on the current line."
86 (get-text-property (gnus-point-at-bol) 'gnus-topic-level)) 102 (get-text-property (point-at-bol) 'gnus-topic-level))
87 103
88 (defun gnus-group-topic-unread () 104 (defun gnus-group-topic-unread ()
89 "The number of unread articles in topic on the current line." 105 "The number of unread articles in topic on the current line."
90 (get-text-property (gnus-point-at-bol) 'gnus-topic-unread)) 106 (get-text-property (point-at-bol) 'gnus-topic-unread))
91 107
92 (defun gnus-topic-unread (topic) 108 (defun gnus-topic-unread (topic)
93 "Return the number of unread articles in TOPIC." 109 "Return the number of unread articles in TOPIC."
94 (or (save-excursion 110 (or (save-excursion
95 (and (gnus-topic-goto-topic topic) 111 (and (gnus-topic-goto-topic topic)
96 (gnus-group-topic-unread))) 112 (gnus-group-topic-unread)))
97 0)) 113 0))
98 114
99 (defun gnus-topic-init-alist () 115 (defun gnus-group-topic-p ()
100 "Initialize the topic structures." 116 "Return non-nil if the current line is a topic."
101 (setq gnus-topic-topology 117 (gnus-group-topic-name))
102 (cons (list "Gnus" 'visible) 118
103 (mapcar (lambda (topic) 119 (defun gnus-topic-visible-p ()
104 (list (list (car topic) 'visible))) 120 "Return non-nil if the current topic is visible."
105 '(("misc"))))) 121 (get-text-property (point-at-bol) 'gnus-topic-visible))
106 (setq gnus-topic-alist 122
107 (list (cons "misc" 123 (defun gnus-topic-articles-in-topic (entries)
108 (mapcar (lambda (info) (gnus-info-group info)) 124 (let ((total 0)
109 (cdr gnus-newsrc-alist))) 125 number)
110 (list "Gnus"))) 126 (while entries
111 (gnus-topic-enter-dribble)) 127 (when (numberp (setq number (car (pop entries))))
128 (incf total number)))
129 total))
130
131 (defun gnus-group-topic (group)
132 "Return the topic GROUP is a member of."
133 (let ((alist gnus-topic-alist)
134 out)
135 (while alist
136 (when (member group (cdar alist))
137 (setq out (caar alist)
138 alist nil))
139 (setq alist (cdr alist)))
140 out))
141
142 (defun gnus-group-parent-topic (group)
143 "Return the topic GROUP is member of by looking at the group buffer."
144 (save-excursion
145 (set-buffer gnus-group-buffer)
146 (if (gnus-group-goto-group group)
147 (gnus-current-topic)
148 (gnus-group-topic group))))
149
150 (defun gnus-topic-goto-topic (topic)
151 "Go to TOPIC."
152 (when topic
153 (gnus-goto-char (text-property-any (point-min) (point-max)
154 'gnus-topic (intern topic)))))
155
156 (defun gnus-current-topic ()
157 "Return the name of the current topic."
158 (let ((result
159 (or (get-text-property (point) 'gnus-topic)
160 (save-excursion
161 (and (gnus-goto-char (previous-single-property-change
162 (point) 'gnus-topic))
163 (get-text-property (max (1- (point)) (point-min))
164 'gnus-topic))))))
165 (when result
166 (symbol-name result))))
167
168 (defun gnus-current-topics ()
169 "Return a list of all current topics, lowest in hierarchy first."
170 (let ((topic (gnus-current-topic))
171 topics)
172 (while topic
173 (push topic topics)
174 (setq topic (gnus-topic-parent-topic topic)))
175 (nreverse topics)))
176
177 (defun gnus-group-active-topic-p ()
178 "Say whether the current topic comes from the active topics."
179 (save-excursion
180 (beginning-of-line)
181 (get-text-property (point) 'gnus-active)))
182
183 (defun gnus-topic-find-groups (topic &optional level all)
184 "Return entries for all visible groups in TOPIC."
185 (let ((groups (cdr (assoc topic gnus-topic-alist)))
186 info clevel unread group lowest params visible-groups entry active)
187 (setq lowest (or lowest 1))
188 (setq level (or level 7))
189 ;; We go through the newsrc to look for matches.
190 (while groups
191 (when (setq group (pop groups))
192 (setq entry (gnus-gethash group gnus-newsrc-hashtb)
193 info (nth 2 entry)
194 params (gnus-info-params info)
195 active (gnus-active group)
196 unread (or (car entry)
197 (and (not (equal group "dummy.group"))
198 active
199 (- (1+ (cdr active)) (car active))))
200 clevel (or (gnus-info-level info)
201 (if (member group gnus-zombie-list) 8 9))))
202 (and
203 unread ; nil means that the group is dead.
204 (<= clevel level)
205 (>= clevel lowest) ; Is inside the level we want.
206 (or all
207 (if (eq unread t)
208 gnus-group-list-inactive-groups
209 (> unread 0))
210 (and gnus-list-groups-with-ticked-articles
211 (cdr (assq 'tick (gnus-info-marks info))))
212 ; Has right readedness.
213 ;; Check for permanent visibility.
214 (and gnus-permanently-visible-groups
215 (string-match gnus-permanently-visible-groups group))
216 (memq 'visible params)
217 (cdr (assq 'visible params)))
218 ;; Add this group to the list of visible groups.
219 (push (or entry group) visible-groups)))
220 (nreverse visible-groups)))
221
222 (defun gnus-topic-previous-topic (topic)
223 "Return the previous topic on the same level as TOPIC."
224 (let ((top (cddr (gnus-topic-find-topology
225 (gnus-topic-parent-topic topic)))))
226 (unless (equal topic (caaar top))
227 (while (and top (not (equal (caaadr top) topic)))
228 (setq top (cdr top)))
229 (caaar top))))
230
231 (defun gnus-topic-parent-topic (topic &optional topology)
232 "Return the parent of TOPIC."
233 (unless topology
234 (setq topology gnus-topic-topology))
235 (let ((parent (car (pop topology)))
236 result found)
237 (while (and topology
238 (not (setq found (equal (caaar topology) topic)))
239 (not (setq result (gnus-topic-parent-topic topic
240 (car topology)))))
241 (setq topology (cdr topology)))
242 (or result (and found parent))))
243
244 (defun gnus-topic-next-topic (topic &optional previous)
245 "Return the next sibling of TOPIC."
246 (let ((parentt (cddr (gnus-topic-find-topology
247 (gnus-topic-parent-topic topic))))
248 prev)
249 (while (and parentt
250 (not (equal (caaar parentt) topic)))
251 (setq prev (caaar parentt)
252 parentt (cdr parentt)))
253 (if previous
254 prev
255 (caaadr parentt))))
256
257 (defun gnus-topic-find-topology (topic &optional topology level remove)
258 "Return the topology of TOPIC."
259 (unless topology
260 (setq topology gnus-topic-topology)
261 (setq level 0))
262 (let ((top topology)
263 result)
264 (if (equal (caar topology) topic)
265 (progn
266 (when remove
267 (delq topology remove))
268 (cons level topology))
269 (setq topology (cdr topology))
270 (while (and topology
271 (not (setq result (gnus-topic-find-topology
272 topic (car topology) (1+ level)
273 (and remove top)))))
274 (setq topology (cdr topology)))
275 result)))
276
277 (defvar gnus-tmp-topics nil)
278 (defun gnus-topic-list (&optional topology)
279 "Return a list of all topics in the topology."
280 (unless topology
281 (setq topology gnus-topic-topology
282 gnus-tmp-topics nil))
283 (push (caar topology) gnus-tmp-topics)
284 (mapcar 'gnus-topic-list (cdr topology))
285 gnus-tmp-topics)
286
287 ;;; Topic parameter jazz
288
289 (defun gnus-topic-parameters (topic)
290 "Return the parameters for TOPIC."
291 (let ((top (gnus-topic-find-topology topic)))
292 (when top
293 (nth 3 (cadr top)))))
294
295 (defun gnus-topic-set-parameters (topic parameters)
296 "Set the topic parameters of TOPIC to PARAMETERS."
297 (let ((top (gnus-topic-find-topology topic)))
298 (unless top
299 (error "No such topic: %s" topic))
300 ;; We may have to extend if there is no parameters here
301 ;; to begin with.
302 (unless (nthcdr 2 (cadr top))
303 (nconc (cadr top) (list nil)))
304 (unless (nthcdr 3 (cadr top))
305 (nconc (cadr top) (list nil)))
306 (setcar (nthcdr 3 (cadr top)) parameters)
307 (gnus-dribble-enter
308 (format "(gnus-topic-set-parameters %S '%S)" topic parameters))))
309
310 (defun gnus-group-topic-parameters (group)
311 "Compute the group parameters for GROUP taking into account inheritance from topics."
312 (let ((params-list (list (gnus-group-get-parameter group)))
313 topics params param out)
314 (save-excursion
315 (gnus-group-goto-group group)
316 (setq topics (gnus-current-topics))
317 (while topics
318 (push (gnus-topic-parameters (pop topics)) params-list))
319 ;; We probably have lots of nil elements here, so
320 ;; we remove them. Probably faster than doing this "properly".
321 (setq params-list (delq nil params-list))
322 ;; Now we have all the parameters, so we go through them
323 ;; and do inheritance in the obvious way.
324 (while (setq params (pop params-list))
325 (while (setq param (pop params))
326 (when (atom param)
327 (setq param (cons param t)))
328 ;; Override any old versions of this param.
329 (setq out (delq (assq (car param) out) out))
330 (push param out)))
331 ;; Return the resulting parameter list.
332 out)))
333
334 ;;; General utility functions
335
336 (defun gnus-topic-enter-dribble ()
337 (gnus-dribble-enter
338 (format "(setq gnus-topic-topology '%S)" gnus-topic-topology)))
339
340 ;;; Generating group buffers
112 341
113 (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) 342 (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 343 "List all newsgroups with unread articles of level LEVEL or lower, and
115 use the `gnus-group-topics' to sort the groups. 344 use the `gnus-group-topics' to sort the groups.
116 If ALL is non-nil, list groups that have no unread articles. 345 If ALL is non-nil, list groups that have no unread articles.
129 (erase-buffer)) 358 (erase-buffer))
130 359
131 ;; List dead groups? 360 ;; List dead groups?
132 (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)) 361 (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie))
133 (gnus-group-prepare-flat-list-dead 362 (gnus-group-prepare-flat-list-dead
134 (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) 363 (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
135 gnus-level-zombie ?Z 364 gnus-level-zombie ?Z
136 regexp)) 365 regexp))
137 366
138 (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)) 367 (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))
139 (gnus-group-prepare-flat-list-dead 368 (gnus-group-prepare-flat-list-dead
140 (setq gnus-killed-list (sort gnus-killed-list 'string<)) 369 (setq gnus-killed-list (sort gnus-killed-list 'string<))
141 gnus-level-killed ?K 370 gnus-level-killed ?K
142 regexp)) 371 regexp))
143 372
144 ;; Use topics. 373 ;; Use topics.
145 (when (< lowest gnus-level-zombie) 374 (prog1
146 (if list-topic 375 (when (< lowest gnus-level-zombie)
147 (let ((top (gnus-topic-find-topology list-topic))) 376 (if list-topic
148 (gnus-topic-prepare-topic (cdr top) (car top) 377 (let ((top (gnus-topic-find-topology list-topic)))
149 (or topic-level level) all)) 378 (gnus-topic-prepare-topic (cdr top) (car top)
150 (gnus-topic-prepare-topic gnus-topic-topology 0 379 (or topic-level level) all))
151 (or topic-level level) all)))) 380 (gnus-topic-prepare-topic gnus-topic-topology 0
152 381 (or topic-level level) all)))
153 (gnus-group-set-mode-line) 382
154 (setq gnus-group-list-mode (cons level all)) 383 (gnus-group-set-mode-line)
155 (run-hooks 'gnus-group-prepare-hook)) 384 (setq gnus-group-list-mode (cons level all))
385 (run-hooks 'gnus-group-prepare-hook))))
156 386
157 (defun gnus-topic-prepare-topic (topicl level &optional list-level all silent) 387 (defun gnus-topic-prepare-topic (topicl level &optional list-level all silent)
158 "Insert TOPIC into the group buffer. 388 "Insert TOPIC into the group buffer.
159 If SILENT, don't insert anything. Return the number of unread 389 If SILENT, don't insert anything. Return the number of unread
160 articles in the topic and its subtopics." 390 articles in the topic and its subtopics."
164 (gnus-group-indentation 394 (gnus-group-indentation
165 (make-string (* gnus-topic-indent-level level) ? )) 395 (make-string (* gnus-topic-indent-level level) ? ))
166 (beg (progn (beginning-of-line) (point))) 396 (beg (progn (beginning-of-line) (point)))
167 (topicl (reverse topicl)) 397 (topicl (reverse topicl))
168 (all-entries entries) 398 (all-entries entries)
399 (point-max (point-max))
169 (unread 0) 400 (unread 0)
170 (topic (car type)) 401 (topic (car type))
171 info entry end active) 402 info entry end active)
172 ;; Insert any sub-topics. 403 ;; Insert any sub-topics.
173 (while topicl 404 (while topicl
183 (if (stringp entry) 414 (if (stringp entry)
184 ;; Dead groups. 415 ;; Dead groups.
185 (gnus-group-insert-group-line 416 (gnus-group-insert-group-line
186 entry (if (member entry gnus-zombie-list) 8 9) 417 entry (if (member entry gnus-zombie-list) 8 9)
187 nil (- (1+ (cdr (setq active (gnus-active entry)))) 418 nil (- (1+ (cdr (setq active (gnus-active entry))))
188 (car active)) nil) 419 (car active))
420 nil)
189 ;; Living groups. 421 ;; Living groups.
190 (when (setq info (nth 2 entry)) 422 (when (setq info (nth 2 entry))
191 (gnus-group-insert-group-line 423 (gnus-group-insert-group-line
192 (gnus-info-group info) 424 (gnus-info-group info)
193 (gnus-info-level info) (gnus-info-marks info) 425 (gnus-info-level info) (gnus-info-marks info)
194 (car entry) (gnus-info-method info))))) 426 (car entry) (gnus-info-method info)))))
195 (when (and (listp entry) 427 (when (and (listp entry)
196 (numberp (car entry)) 428 (numberp (car entry))
197 (not (member (gnus-info-group (setq info (nth 2 entry))) 429 (not (member (gnus-info-group (setq info (nth 2 entry)))
198 gnus-topic-tallied-groups))) 430 gnus-topic-tallied-groups)))
199 (push (gnus-info-group info) gnus-topic-tallied-groups) 431 (push (gnus-info-group info) gnus-topic-tallied-groups)
200 (incf unread (car entry)))) 432 (incf unread (car entry))))
201 (goto-char beg) 433 (goto-char beg)
202 ;; Insert the topic line. 434 ;; Insert the topic line.
203 (unless silent 435 (when (and (not silent)
436 (or gnus-topic-display-empty-topics
437 (not (zerop unread))
438 (/= point-max (point-max))))
204 (gnus-extent-start-open (point)) 439 (gnus-extent-start-open (point))
205 (gnus-topic-insert-topic-line 440 (gnus-topic-insert-topic-line
206 (car type) visiblep 441 (car type) visiblep
207 (not (eq (nth 2 type) 'hidden)) 442 (not (eq (nth 2 type) 'hidden))
208 level all-entries unread)) 443 level all-entries unread))
209 (goto-char end) 444 (goto-char end)
210 unread)) 445 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 446
250 (defun gnus-topic-remove-topic (&optional insert total-remove hide in-level) 447 (defun gnus-topic-remove-topic (&optional insert total-remove hide in-level)
251 "Remove the current topic." 448 "Remove the current topic."
252 (let ((topic (gnus-group-topic-name)) 449 (let ((topic (gnus-group-topic-name))
253 (level (gnus-group-topic-level)) 450 (level (gnus-group-topic-level))
255 buffer-read-only) 452 buffer-read-only)
256 (when topic 453 (when topic
257 (while (and (zerop (forward-line 1)) 454 (while (and (zerop (forward-line 1))
258 (> (or (gnus-group-topic-level) (1+ level)) level))) 455 (> (or (gnus-group-topic-level) (1+ level)) level)))
259 (delete-region beg (point)) 456 (delete-region beg (point))
260 (setcar (cdadr (gnus-topic-find-topology topic)) 457 ;; Do the change in this rather odd manner because it has been
261 (if insert 'visible 'invisible)) 458 ;; reported that some topics share parts of some lists, for some
262 (when hide 459 ;; reason. I have been unable to determine why this is the
263 (setcdr (cdadr (gnus-topic-find-topology topic)) 460 ;; case, but this hack seems to take care of things.
264 (list hide))) 461 (let ((data (cadr (gnus-topic-find-topology topic))))
265 (unless total-remove 462 (setcdr data
463 (list (if insert 'visible 'invisible)
464 (if hide 'hide nil)
465 (cadddr data))))
466 (if total-remove
467 (setq gnus-topic-alist
468 (delq (assoc topic gnus-topic-alist) gnus-topic-alist))
266 (gnus-topic-insert-topic topic in-level))))) 469 (gnus-topic-insert-topic topic in-level)))))
267 470
268 (defun gnus-topic-insert-topic (topic &optional level) 471 (defun gnus-topic-insert-topic (topic &optional level)
269 "Insert TOPIC." 472 "Insert TOPIC."
270 (gnus-group-prepare-topics 473 (gnus-group-prepare-topics
271 (car gnus-group-list-mode) (cdr gnus-group-list-mode) 474 (car gnus-group-list-mode) (cdr gnus-group-list-mode)
272 nil nil topic level)) 475 nil nil topic level))
273 476
274 (defun gnus-topic-fold (&optional insert) 477 (defun gnus-topic-fold (&optional insert)
275 "Remove/insert the current topic." 478 "Remove/insert the current topic."
276 (let ((topic (gnus-group-topic-name))) 479 (let ((topic (gnus-group-topic-name)))
277 (when topic 480 (when topic
278 (save-excursion 481 (save-excursion
279 (if (not (gnus-group-active-topic-p)) 482 (if (not (gnus-group-active-topic-p))
280 (gnus-topic-remove-topic 483 (gnus-topic-remove-topic
281 (or insert (not (gnus-topic-visible-p)))) 484 (or insert (not (gnus-topic-visible-p))))
282 (let ((gnus-topic-topology gnus-topic-active-topology) 485 (let ((gnus-topic-topology gnus-topic-active-topology)
283 (gnus-topic-alist gnus-topic-active-alist) 486 (gnus-topic-alist gnus-topic-active-alist)
284 (gnus-group-list-mode (cons 5 t))) 487 (gnus-group-list-mode (cons 5 t)))
285 (gnus-topic-remove-topic 488 (gnus-topic-remove-topic
286 (or insert (not (gnus-topic-visible-p))) nil nil 9))))))) 489 (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 490
296 (defun gnus-topic-insert-topic-line (name visiblep shownp level entries 491 (defun gnus-topic-insert-topic-line (name visiblep shownp level entries
297 &optional unread) 492 &optional unread)
298 (let* ((visible (if visiblep "" "...")) 493 (let* ((visible (if visiblep "" "..."))
299 (indentation (make-string (* gnus-topic-indent-level level) ? )) 494 (indentation (make-string (* gnus-topic-indent-level level) ? ))
302 (active-topic (eq gnus-topic-alist gnus-topic-active-alist))) 497 (active-topic (eq gnus-topic-alist gnus-topic-active-alist)))
303 (beginning-of-line) 498 (beginning-of-line)
304 ;; Insert the text. 499 ;; Insert the text.
305 (gnus-add-text-properties 500 (gnus-add-text-properties
306 (point) 501 (point)
307 (prog1 (1+ (point)) 502 (prog1 (1+ (point))
308 (eval gnus-topic-line-format-spec) 503 (eval gnus-topic-line-format-spec)
309 (gnus-topic-remove-excess-properties)1) 504 (gnus-topic-remove-excess-properties)1)
310 (list 'gnus-topic (intern name) 505 (list 'gnus-topic (intern name)
311 'gnus-topic-level level 506 'gnus-topic-level level
312 'gnus-topic-unread unread 507 'gnus-topic-unread unread
313 'gnus-active active-topic 508 'gnus-active active-topic
314 'gnus-topic-visible visiblep)))) 509 'gnus-topic-visible visiblep))))
315 510
316 (defun gnus-topic-previous-topic (topic) 511 (defun gnus-topic-update-topics-containing-group (group)
317 "Return the previous topic on the same level as TOPIC." 512 "Update all topics that have GROUP as a member."
318 (let ((top (cddr (gnus-topic-find-topology 513 (when (and (eq major-mode 'gnus-group-mode)
319 (gnus-topic-parent-topic topic))))) 514 gnus-topic-mode)
320 (unless (equal topic (caaar top)) 515 (save-excursion
321 (while (and top (not (equal (caaadr top) topic))) 516 (let ((alist gnus-topic-alist))
322 (setq top (cdr top))) 517 ;; This is probably not entirely correct. If a topic
323 (caaar top)))) 518 ;; isn't shown, then it's not updated. But the updating
324 519 ;; should be performed in any case, since the topic's
325 (defun gnus-topic-parent-topic (topic &optional topology) 520 ;; parent should be updated. Pfft.
326 "Return the parent of TOPIC." 521 (while alist
327 (unless topology 522 (when (and (member group (cdar alist))
328 (setq topology gnus-topic-topology)) 523 (gnus-topic-goto-topic (caar alist)))
329 (let ((parent (car (pop topology))) 524 (gnus-topic-update-topic-line (caar alist)))
330 result found) 525 (pop alist))))))
331 (while (and topology 526
332 (not (setq found (equal (caaar topology) topic))) 527 (defun gnus-topic-update-topic ()
333 (not (setq result (gnus-topic-parent-topic topic 528 "Update all parent topics to the current group."
334 (car topology))))) 529 (when (and (eq major-mode 'gnus-group-mode)
335 (setq topology (cdr topology))) 530 gnus-topic-mode)
336 (or result (and found parent)))) 531 (let ((group (gnus-group-group-name))
337 532 (buffer-read-only nil))
338 (defun gnus-topic-next-topic (topic &optional previous) 533 (when (and group
339 "Return the next sibling of TOPIC." 534 (gnus-get-info group)
340 (let ((topology gnus-topic-topology) 535 (gnus-topic-goto-topic (gnus-current-topic)))
341 (parentt (cddr (gnus-topic-find-topology 536 (gnus-topic-update-topic-line (gnus-group-topic-name))
342 (gnus-topic-parent-topic topic)))) 537 (gnus-group-goto-group group)
343 prev) 538 (gnus-group-position-point)))))
344 (while (and parentt 539
345 (not (equal (caaar parentt) topic))) 540 (defun gnus-topic-goto-missing-group (group)
346 (setq prev (caaar parentt) 541 "Place point where GROUP is supposed to be inserted."
347 parentt (cdr parentt))) 542 (let* ((topic (gnus-group-topic group))
348 (if previous 543 (groups (cdr (assoc topic gnus-topic-alist)))
349 prev 544 (g (cdr (member group groups)))
350 (caaadr parentt)))) 545 (unfound t))
351 546 ;; Try to jump to a visible group.
352 (defun gnus-topic-find-topology (topic &optional topology level remove) 547 (while (and g (not (gnus-group-goto-group (car g) t)))
353 "Return the topology of TOPIC." 548 (pop g))
354 (unless topology 549 ;; It wasn't visible, so we try to see where to insert it.
355 (setq topology gnus-topic-topology) 550 (when (not g)
356 (setq level 0)) 551 (setq g (cdr (member group (reverse groups))))
357 (let ((top topology) 552 (while (and g unfound)
358 result) 553 (when (gnus-group-goto-group (pop g) t)
359 (if (equal (caar topology) topic) 554 (forward-line 1)
360 (progn 555 (setq unfound nil)))
361 (when remove 556 (when unfound
362 (delq topology remove)) 557 (gnus-topic-goto-topic topic)
363 (cons level topology)) 558 (forward-line 1)))))
364 (setq topology (cdr topology)) 559
365 (while (and topology 560 (defun gnus-topic-update-topic-line (topic-name &optional reads)
366 (not (setq result (gnus-topic-find-topology 561 (let* ((top (gnus-topic-find-topology topic-name))
367 topic (car topology) (1+ level) 562 (type (cadr top))
368 (and remove top))))) 563 (children (cddr top))
369 (setq topology (cdr topology))) 564 (entries (gnus-topic-find-groups
370 result))) 565 (car type) (car gnus-group-list-mode)
566 (cdr gnus-group-list-mode)))
567 (parent (gnus-topic-parent-topic topic-name))
568 (all-entries entries)
569 (unread 0)
570 old-unread entry)
571 (when (gnus-topic-goto-topic (car type))
572 ;; Tally all the groups that belong in this topic.
573 (if reads
574 (setq unread (- (gnus-group-topic-unread) reads))
575 (while children
576 (incf unread (gnus-topic-unread (caar (pop children)))))
577 (while (setq entry (pop entries))
578 (when (numberp (car entry))
579 (incf unread (car entry)))))
580 (setq old-unread (gnus-group-topic-unread))
581 ;; Insert the topic line.
582 (gnus-topic-insert-topic-line
583 (car type) (gnus-topic-visible-p)
584 (not (eq (nth 2 type) 'hidden))
585 (gnus-group-topic-level) all-entries unread)
586 (gnus-delete-line))
587 (when parent
588 (forward-line -1)
589 (gnus-topic-update-topic-line
590 parent (- old-unread (gnus-group-topic-unread))))
591 unread))
592
593 (defun gnus-topic-group-indentation ()
594 (make-string
595 (* gnus-topic-indent-level
596 (or (save-excursion
597 (forward-line -1)
598 (gnus-topic-goto-topic (gnus-current-topic))
599 (gnus-group-topic-level))
600 0))
601 ? ))
602
603 ;;; Initialization
371 604
372 (gnus-add-shutdown 'gnus-topic-close 'gnus) 605 (gnus-add-shutdown 'gnus-topic-close 'gnus)
373 606
374 (defun gnus-topic-close () 607 (defun gnus-topic-close ()
375 (setq gnus-topic-active-topology nil 608 (setq gnus-topic-active-topology nil
376 gnus-topic-active-alist nil 609 gnus-topic-active-alist nil
377 gnus-topic-killed-topics nil 610 gnus-topic-killed-topics nil
378 gnus-topic-tallied-groups nil 611 gnus-topic-tallied-groups nil
379 gnus-topology-checked-p nil)) 612 gnus-topology-checked-p nil))
380 613
381 614 (defun gnus-topic-check-topology ()
382 (defun gnus-topic-check-topology ()
383 ;; The first time we set the topology to whatever we have 615 ;; The first time we set the topology to whatever we have
384 ;; gotten here, which can be rather random. 616 ;; gotten here, which can be rather random.
385 (unless gnus-topic-alist 617 (unless gnus-topic-alist
386 (gnus-topic-init-alist)) 618 (gnus-topic-init-alist))
387 619
422 (while (cdr topic) 654 (while (cdr topic)
423 (if (gnus-gethash (cadr topic) gnus-newsrc-hashtb) 655 (if (gnus-gethash (cadr topic) gnus-newsrc-hashtb)
424 (setq topic (cdr topic)) 656 (setq topic (cdr topic))
425 (setcdr topic (cddr topic))))))) 657 (setcdr topic (cddr topic)))))))
426 658
427 (defvar gnus-tmp-topics nil) 659 (defun gnus-topic-init-alist ()
428 (defun gnus-topic-list (&optional topology) 660 "Initialize the topic structures."
429 (unless topology 661 (setq gnus-topic-topology
430 (setq topology gnus-topic-topology 662 (cons (list "Gnus" 'visible)
431 gnus-tmp-topics nil)) 663 (mapcar (lambda (topic)
432 (push (caar topology) gnus-tmp-topics) 664 (list (list (car topic) 'visible)))
433 (mapcar 'gnus-topic-list (cdr topology)) 665 '(("misc")))))
434 gnus-tmp-topics) 666 (setq gnus-topic-alist
435 667 (list (cons "misc"
436 (defun gnus-topic-enter-dribble () 668 (mapcar (lambda (info) (gnus-info-group info))
437 (gnus-dribble-enter 669 (cdr gnus-newsrc-alist)))
438 (format "(setq gnus-topic-topology '%S)" gnus-topic-topology))) 670 (list "Gnus")))
439 671 (gnus-topic-enter-dribble))
440 (defun gnus-topic-articles-in-topic (entries) 672
441 (let ((total 0) 673 ;;; Maintenance
442 number) 674
443 (while entries 675 (defun gnus-topic-clean-alist ()
444 (when (numberp (setq number (car (pop entries)))) 676 "Remove bogus groups from the topic alist."
445 (incf total number))) 677 (let ((topic-alist gnus-topic-alist)
446 total)) 678 result topic)
447 679 (unless gnus-killed-hashtb
448 (defun gnus-group-topic (group) 680 (gnus-make-hashtable-from-killed))
449 "Return the topic GROUP is a member of." 681 (while (setq topic (pop topic-alist))
450 (let ((alist gnus-topic-alist) 682 (let ((topic-name (pop topic))
451 out) 683 group filtered-topic)
452 (while alist 684 (while (setq group (pop topic))
453 (when (member group (cdar alist)) 685 (when (and (or (gnus-gethash group gnus-active-hashtb)
454 (setq out (caar alist) 686 (gnus-info-method (gnus-get-info group)))
455 alist nil)) 687 (not (gnus-gethash group gnus-killed-hashtb)))
456 (setq alist (cdr alist))) 688 (push group filtered-topic)))
457 out)) 689 (push (cons topic-name (nreverse filtered-topic)) result)))
458 690 (setq gnus-topic-alist (nreverse result))))
459 (defun gnus-topic-goto-topic (topic) 691
460 "Go to TOPIC." 692 (defun gnus-topic-change-level (group level oldlevel)
461 (when topic 693 "Run when changing levels to enter/remove groups from topics."
462 (gnus-goto-char (text-property-any (point-min) (point-max) 694 (save-excursion
463 'gnus-topic (intern topic))))) 695 (set-buffer gnus-group-buffer)
464 696 (when (and gnus-topic-mode
465 (defun gnus-group-parent-topic () 697 gnus-topic-alist
466 "Return the name of the current topic." 698 (not gnus-topic-inhibit-change-level))
467 (let ((result 699 ;; Remove the group from the topics.
468 (or (get-text-property (point) 'gnus-topic) 700 (when (and (< oldlevel gnus-level-zombie)
469 (save-excursion 701 (>= level gnus-level-zombie))
470 (and (gnus-goto-char (previous-single-property-change 702 (let (alist)
471 (point) 'gnus-topic)) 703 (forward-line -1)
472 (get-text-property (max (1- (point)) (point-min)) 704 (when (setq alist (assoc (gnus-current-topic) gnus-topic-alist))
473 'gnus-topic)))))) 705 (setcdr alist (gnus-delete-first group (cdr alist))))))
474 (when result 706 ;; If the group is subscribed we enter it into the topics.
475 (symbol-name result)))) 707 (when (and (< level gnus-level-zombie)
476 708 (>= oldlevel gnus-level-zombie))
477 (defun gnus-topic-update-topic () 709 (let* ((prev (gnus-group-group-name))
478 "Update all parent topics to the current group." 710 (gnus-topic-inhibit-change-level t)
479 (when (and (eq major-mode 'gnus-group-mode) 711 (gnus-group-indentation
480 gnus-topic-mode) 712 (make-string
481 (let ((group (gnus-group-group-name)) 713 (* gnus-topic-indent-level
482 (buffer-read-only nil)) 714 (or (save-excursion
483 (when (and group (gnus-get-info group) 715 (gnus-topic-goto-topic (gnus-current-topic))
484 (gnus-topic-goto-topic (gnus-group-parent-topic))) 716 (gnus-group-topic-level))
485 (gnus-topic-update-topic-line (gnus-group-topic-name)) 717 0))
486 (gnus-group-goto-group group) 718 ? ))
487 (gnus-group-position-point))))) 719 (yanked (list group))
488 720 alist talist end)
489 (defun gnus-topic-goto-missing-group (group) 721 ;; Then we enter the yanked groups into the topics they belong
490 "Place point where GROUP is supposed to be inserted." 722 ;; to.
491 (let* ((topic (gnus-group-topic group)) 723 (when (setq alist (assoc (save-excursion
492 (groups (cdr (assoc topic gnus-topic-alist))) 724 (forward-line -1)
493 (g (cdr (member group groups))) 725 (or
494 (unfound t)) 726 (gnus-current-topic)
495 (while (and g unfound) 727 (caar gnus-topic-topology)))
496 (when (gnus-group-goto-group (pop g)) 728 gnus-topic-alist))
497 (beginning-of-line) 729 (setq talist alist)
498 (setq unfound nil))) 730 (when (stringp yanked)
499 (when unfound 731 (setq yanked (list yanked)))
500 (setq g (cdr (member group (reverse groups)))) 732 (if (not prev)
501 (while (and g unfound) 733 (nconc alist yanked)
502 (when (gnus-group-goto-group (pop g)) 734 (if (not (cdr alist))
503 (forward-line 1) 735 (setcdr alist (nconc yanked (cdr alist)))
504 (setq unfound nil))) 736 (while (and (not end) (cdr alist))
505 (when unfound 737 (when (equal (cadr alist) prev)
506 (gnus-topic-goto-topic topic) 738 (setcdr alist (nconc yanked (cdr alist)))
507 (forward-line 1))))) 739 (setq end t))
508 740 (setq alist (cdr alist)))
509 (defun gnus-topic-update-topic-line (topic-name &optional reads) 741 (unless end
510 (let* ((top (gnus-topic-find-topology topic-name)) 742 (nconc talist yanked))))))
511 (type (cadr top)) 743 (gnus-topic-update-topic)))))
512 (children (cddr top)) 744
513 (entries (gnus-topic-find-groups 745 (defun gnus-topic-goto-next-group (group props)
514 (car type) (car gnus-group-list-mode) 746 "Go to group or the next group after group."
515 (cdr gnus-group-list-mode))) 747 (if (not group)
516 (parent (gnus-topic-parent-topic topic-name)) 748 (if (not (memq 'gnus-topic props))
517 (all-entries entries) 749 (goto-char (point-max))
518 (unread 0) 750 (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props)))))
519 old-unread entry) 751 (if (gnus-group-goto-group group)
520 (when (gnus-topic-goto-topic (car type)) 752 t
521 ;; Tally all the groups that belong in this topic. 753 ;; The group is no longer visible.
522 (if reads 754 (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist))
523 (setq unread (- (gnus-group-topic-unread) reads)) 755 (after (cdr (member group (cdr list)))))
524 (while children 756 ;; First try to put point on a group after the current one.
525 (incf unread (gnus-topic-unread (caar (pop children))))) 757 (while (and after
526 (while (setq entry (pop entries)) 758 (not (gnus-group-goto-group (car after))))
527 (when (numberp (car entry)) 759 (setq after (cdr after)))
528 (incf unread (car entry))))) 760 ;; Then try to put point on a group before point.
529 (setq old-unread (gnus-group-topic-unread)) 761 (unless after
530 ;; Insert the topic line. 762 (setq after (cdr (member group (reverse (cdr list)))))
531 (gnus-topic-insert-topic-line 763 (while (and after
532 (car type) (gnus-topic-visible-p) 764 (not (gnus-group-goto-group (car after))))
533 (not (eq (nth 2 type) 'hidden)) 765 (setq after (cdr after))))
534 (gnus-group-topic-level) all-entries unread) 766 ;; Finally, just put point on the topic.
535 (gnus-delete-line)) 767 (if (not (car list))
536 (when parent 768 (goto-char (point-min))
537 (forward-line -1) 769 (unless after
538 (gnus-topic-update-topic-line 770 (gnus-topic-goto-topic (car list))
539 parent (- old-unread (gnus-group-topic-unread)))) 771 (setq after nil)))
540 unread)) 772 t))))
773
774 ;;; Topic-active functions
541 775
542 (defun gnus-topic-grok-active (&optional force) 776 (defun gnus-topic-grok-active (&optional force)
543 "Parse all active groups and create topic structures for them." 777 "Parse all active groups and create topic structures for them."
544 ;; First we make sure that we have really read the active file. 778 ;; First we make sure that we have really read the active file.
545 (when (or force 779 (when (or force
587 (setcar (car topology) name) 821 (setcar (car topology) name)
588 ;; We return the rest of the groups that didn't belong 822 ;; We return the rest of the groups that didn't belong
589 ;; to this topic. 823 ;; to this topic.
590 groups)) 824 groups))
591 825
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. 826 ;;; Topic mode, commands and keymap.
599 827
600 (defvar gnus-topic-mode-map nil) 828 (defvar gnus-topic-mode-map nil)
601 (defvar gnus-group-topic-map nil) 829 (defvar gnus-group-topic-map nil)
602 830
603 (unless gnus-topic-mode-map 831 (unless gnus-topic-mode-map
604 (setq gnus-topic-mode-map (make-sparse-keymap)) 832 (setq gnus-topic-mode-map (make-sparse-keymap))
605 833
606 ;; Override certain group mode keys. 834 ;; Override certain group mode keys.
607 (gnus-define-keys 835 (gnus-define-keys gnus-topic-mode-map
608 gnus-topic-mode-map 836 "=" gnus-topic-select-group
609 "=" gnus-topic-select-group 837 "\r" gnus-topic-select-group
610 "\r" gnus-topic-select-group 838 " " gnus-topic-read-group
611 " " gnus-topic-read-group 839 "\C-k" gnus-topic-kill-group
612 "\C-k" gnus-topic-kill-group 840 "\C-y" gnus-topic-yank-group
613 "\C-y" gnus-topic-yank-group 841 "\M-g" gnus-topic-get-new-news-this-topic
614 "\M-g" gnus-topic-get-new-news-this-topic 842 "AT" gnus-topic-list-active
615 "AT" gnus-topic-list-active 843 "Gp" gnus-topic-edit-parameters
616 gnus-mouse-2 gnus-mouse-pick-topic) 844 "#" gnus-topic-mark-topic
845 "\M-#" gnus-topic-unmark-topic
846 gnus-mouse-2 gnus-mouse-pick-topic)
617 847
618 ;; Define a new submap. 848 ;; Define a new submap.
619 (gnus-define-keys 849 (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map)
620 (gnus-group-topic-map "T" gnus-group-mode-map) 850 "#" gnus-topic-mark-topic
621 "#" gnus-topic-mark-topic 851 "\M-#" gnus-topic-unmark-topic
622 "\M-#" gnus-topic-unmark-topic 852 "n" gnus-topic-create-topic
623 "n" gnus-topic-create-topic 853 "m" gnus-topic-move-group
624 "m" gnus-topic-move-group 854 "D" gnus-topic-remove-group
625 "D" gnus-topic-remove-group 855 "c" gnus-topic-copy-group
626 "c" gnus-topic-copy-group 856 "h" gnus-topic-hide-topic
627 "h" gnus-topic-hide-topic 857 "s" gnus-topic-show-topic
628 "s" gnus-topic-show-topic 858 "M" gnus-topic-move-matching
629 "M" gnus-topic-move-matching 859 "C" gnus-topic-copy-matching
630 "C" gnus-topic-copy-matching 860 "\C-i" gnus-topic-indent
631 "\C-i" gnus-topic-indent 861 [tab] gnus-topic-indent
632 [tab] gnus-topic-indent 862 "r" gnus-topic-rename
633 "r" gnus-topic-rename 863 "\177" gnus-topic-delete)
634 "\177" gnus-topic-delete)) 864
865 (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map)
866 "s" gnus-topic-sort-groups
867 "a" gnus-topic-sort-groups-by-alphabet
868 "u" gnus-topic-sort-groups-by-unread
869 "l" gnus-topic-sort-groups-by-level
870 "v" gnus-topic-sort-groups-by-score
871 "r" gnus-topic-sort-groups-by-rank
872 "m" gnus-topic-sort-groups-by-method))
635 873
636 (defun gnus-topic-make-menu-bar () 874 (defun gnus-topic-make-menu-bar ()
637 (unless (boundp 'gnus-topic-menu) 875 (unless (boundp 'gnus-topic-menu)
638 (easy-menu-define 876 (easy-menu-define
639 gnus-topic-menu gnus-topic-mode-map "" 877 gnus-topic-menu gnus-topic-mode-map ""
663 (setq gnus-topic-mode 901 (setq gnus-topic-mode
664 (if (null arg) (not gnus-topic-mode) 902 (if (null arg) (not gnus-topic-mode)
665 (> (prefix-numeric-value arg) 0))) 903 (> (prefix-numeric-value arg) 0)))
666 ;; Infest Gnus with topics. 904 ;; Infest Gnus with topics.
667 (when gnus-topic-mode 905 (when gnus-topic-mode
668 (when (and menu-bar-mode 906 (when (gnus-visual-p 'topic-menu 'menu)
669 (gnus-visual-p 'topic-menu 'menu))
670 (gnus-topic-make-menu-bar)) 907 (gnus-topic-make-menu-bar))
671 (setq gnus-topic-line-format-spec 908 (setq gnus-topic-line-format-spec
672 (gnus-parse-format gnus-topic-line-format 909 (gnus-parse-format gnus-topic-line-format
673 gnus-topic-line-format-alist t)) 910 gnus-topic-line-format-alist t))
674 (unless (assq 'gnus-topic-mode minor-mode-alist) 911 (unless (assq 'gnus-topic-mode minor-mode-alist)
676 (unless (assq 'gnus-topic-mode minor-mode-map-alist) 913 (unless (assq 'gnus-topic-mode minor-mode-map-alist)
677 (push (cons 'gnus-topic-mode gnus-topic-mode-map) 914 (push (cons 'gnus-topic-mode gnus-topic-mode-map)
678 minor-mode-map-alist)) 915 minor-mode-map-alist))
679 (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) 916 (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
680 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) 917 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
681 (add-hook 'gnus-group-update-group-hook 'gnus-topic-update-topic) 918 (set (make-local-variable 'gnus-group-prepare-function)
682 (make-local-variable 'gnus-group-prepare-function) 919 'gnus-group-prepare-topics)
683 (setq gnus-group-prepare-function 'gnus-group-prepare-topics) 920 (set (make-local-variable 'gnus-group-get-parameter-function)
684 (make-local-variable 'gnus-group-goto-next-group-function) 921 'gnus-group-topic-parameters)
685 (setq gnus-group-goto-next-group-function 922 (set (make-local-variable 'gnus-group-goto-next-group-function)
686 'gnus-topic-goto-next-group) 923 'gnus-topic-goto-next-group)
924 (set (make-local-variable 'gnus-group-indentation-function)
925 'gnus-topic-group-indentation)
926 (set (make-local-variable 'gnus-group-update-group-function)
927 'gnus-topic-update-topics-containing-group)
928 (set (make-local-variable 'gnus-group-sort-alist-function)
929 'gnus-group-sort-topic)
687 (setq gnus-group-change-level-function 'gnus-topic-change-level) 930 (setq gnus-group-change-level-function 'gnus-topic-change-level)
688 (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) 931 (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)
692 (gnus-make-local-hook 'gnus-check-bogus-groups-hook) 932 (gnus-make-local-hook 'gnus-check-bogus-groups-hook)
693 (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) 933 (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist)
694 (setq gnus-topology-checked-p nil) 934 (setq gnus-topology-checked-p nil)
695 ;; We check the topology. 935 ;; We check the topology.
696 (when gnus-newsrc-alist 936 (when gnus-newsrc-alist
700 (unless gnus-topic-mode 940 (unless gnus-topic-mode
701 (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) 941 (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
702 (remove-hook 'gnus-group-change-level-function 942 (remove-hook 'gnus-group-change-level-function
703 'gnus-topic-change-level) 943 'gnus-topic-change-level)
704 (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) 944 (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist)
705 (setq gnus-group-prepare-function 'gnus-group-prepare-flat)) 945 (setq gnus-group-prepare-function 'gnus-group-prepare-flat)
946 (setq gnus-group-sort-alist-function 'gnus-group-sort-flat))
706 (when redisplay 947 (when redisplay
707 (gnus-group-list-groups)))) 948 (gnus-group-list-groups))))
708 949
709 (defun gnus-topic-select-group (&optional all) 950 (defun gnus-topic-select-group (&optional all)
710 "Select this newsgroup. 951 "Select this newsgroup.
744 985
745 (defun gnus-topic-create-topic (topic parent &optional previous full-topic) 986 (defun gnus-topic-create-topic (topic parent &optional previous full-topic)
746 (interactive 987 (interactive
747 (list 988 (list
748 (read-string "New topic: ") 989 (read-string "New topic: ")
749 (gnus-group-parent-topic))) 990 (gnus-current-topic)))
750 ;; Check whether this topic already exists. 991 ;; Check whether this topic already exists.
751 (when (gnus-topic-find-topology topic) 992 (when (gnus-topic-find-topology topic)
752 (error "Topic aleady exists")) 993 (error "Topic already exists"))
753 (unless parent 994 (unless parent
754 (setq parent (caar gnus-topic-topology))) 995 (setq parent (caar gnus-topic-topology)))
755 (let ((top (cdr (gnus-topic-find-topology parent))) 996 (let ((top (cdr (gnus-topic-find-topology parent)))
756 (full-topic (or full-topic `((,topic visible))))) 997 (full-topic (or full-topic `((,topic visible)))))
757 (unless top 998 (unless top
775 (interactive 1016 (interactive
776 (list current-prefix-arg 1017 (list current-prefix-arg
777 (completing-read "Move to topic: " gnus-topic-alist nil t))) 1018 (completing-read "Move to topic: " gnus-topic-alist nil t)))
778 (let ((groups (gnus-group-process-prefix n)) 1019 (let ((groups (gnus-group-process-prefix n))
779 (topicl (assoc topic gnus-topic-alist)) 1020 (topicl (assoc topic gnus-topic-alist))
1021 (start-group (progn (forward-line 1) (gnus-group-group-name)))
1022 (start-topic (gnus-group-topic-name))
780 entry) 1023 entry)
781 (mapcar (lambda (g) 1024 (mapcar
782 (gnus-group-remove-mark g) 1025 (lambda (g)
783 (when (and 1026 (gnus-group-remove-mark g)
784 (setq entry (assoc (gnus-group-parent-topic) 1027 (when (and
785 gnus-topic-alist)) 1028 (setq entry (assoc (gnus-current-topic) gnus-topic-alist))
786 (not copyp)) 1029 (not copyp))
787 (setcdr entry (gnus-delete-first g (cdr entry)))) 1030 (setcdr entry (gnus-delete-first g (cdr entry))))
788 (nconc topicl (list g))) 1031 (nconc topicl (list g)))
789 groups) 1032 groups)
790 (gnus-group-position-point)) 1033 (gnus-topic-enter-dribble)
791 (gnus-topic-enter-dribble) 1034 (if start-group
792 (gnus-group-list-groups)) 1035 (gnus-group-goto-group start-group)
793 1036 (gnus-topic-goto-topic start-topic))
794 (defun gnus-topic-remove-group () 1037 (gnus-group-list-groups)))
1038
1039 (defun gnus-topic-remove-group (&optional arg)
795 "Remove the current group from the topic." 1040 "Remove the current group from the topic."
796 (interactive) 1041 (interactive "P")
797 (let ((topicl (assoc (gnus-group-parent-topic) gnus-topic-alist)) 1042 (gnus-group-iterate arg
798 (group (gnus-group-group-name)) 1043 (lambda (group)
799 (buffer-read-only nil)) 1044 (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
800 (when (and topicl group) 1045 (buffer-read-only nil))
801 (gnus-delete-line) 1046 (when (and topicl group)
802 (gnus-delete-first group topicl)) 1047 (gnus-delete-line)
803 (gnus-group-position-point))) 1048 (gnus-delete-first group topicl))
1049 (gnus-topic-update-topic)
1050 (gnus-group-position-point)))))
804 1051
805 (defun gnus-topic-copy-group (n topic) 1052 (defun gnus-topic-copy-group (n topic)
806 "Copy the current group to a topic." 1053 "Copy the current group to a topic."
807 (interactive 1054 (interactive
808 (list current-prefix-arg 1055 (list current-prefix-arg
809 (completing-read "Copy to topic: " gnus-topic-alist nil t))) 1056 (completing-read "Copy to topic: " gnus-topic-alist nil t)))
810 (gnus-topic-move-group n topic t)) 1057 (gnus-topic-move-group n topic t))
811 1058
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
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
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) 1059 (defun gnus-topic-kill-group (&optional n discard)
912 "Kill the next N groups." 1060 "Kill the next N groups."
913 (interactive "P") 1061 (interactive "P")
914 (if (gnus-group-topic-p) 1062 (if (gnus-group-topic-p)
915 (let ((topic (gnus-group-topic-name))) 1063 (let ((topic (gnus-group-topic-name)))
1064 (push (cons
1065 (gnus-topic-find-topology topic)
1066 (assoc topic gnus-topic-alist))
1067 gnus-topic-killed-topics)
916 (gnus-topic-remove-topic nil t) 1068 (gnus-topic-remove-topic nil t)
917 (push (gnus-topic-find-topology topic nil nil gnus-topic-topology) 1069 (gnus-topic-find-topology topic nil nil gnus-topic-topology)
918 gnus-topic-killed-topics)) 1070 (gnus-topic-enter-dribble))
919 (gnus-group-kill-group n discard) 1071 (gnus-group-kill-group n discard)
920 (gnus-topic-update-topic))) 1072 (gnus-topic-update-topic)))
921 1073
922 (defun gnus-topic-yank-group (&optional arg) 1074 (defun gnus-topic-yank-group (&optional arg)
923 "Yank the last topic." 1075 "Yank the last topic."
924 (interactive "p") 1076 (interactive "p")
925 (if gnus-topic-killed-topics 1077 (if gnus-topic-killed-topics
926 (let ((previous 1078 (let* ((previous
927 (or (gnus-group-topic-name) 1079 (or (gnus-group-topic-name)
928 (gnus-topic-next-topic (gnus-group-parent-topic)))) 1080 (gnus-topic-next-topic (gnus-current-topic))))
929 (item (cdr (pop gnus-topic-killed-topics)))) 1081 (data (pop gnus-topic-killed-topics))
1082 (alist (cdr data))
1083 (item (cdar data)))
1084 (push alist gnus-topic-alist)
930 (gnus-topic-create-topic 1085 (gnus-topic-create-topic
931 (caar item) (gnus-topic-parent-topic previous) previous 1086 (caar item) (gnus-topic-parent-topic previous) previous
932 item) 1087 item)
1088 (gnus-topic-enter-dribble)
933 (gnus-topic-goto-topic (caar item))) 1089 (gnus-topic-goto-topic (caar item)))
934 (let* ((prev (gnus-group-group-name)) 1090 (let* ((prev (gnus-group-group-name))
935 (gnus-topic-inhibit-change-level t) 1091 (gnus-topic-inhibit-change-level t)
936 (gnus-group-indentation 1092 (gnus-group-indentation
937 (make-string 1093 (make-string
938 (* gnus-topic-indent-level 1094 (* gnus-topic-indent-level
939 (or (save-excursion 1095 (or (save-excursion
940 (gnus-topic-goto-topic (gnus-group-parent-topic)) 1096 (gnus-topic-goto-topic (gnus-current-topic))
941 (gnus-group-topic-level)) 0)) ? )) 1097 (gnus-group-topic-level))
1098 0))
1099 ? ))
942 yanked alist) 1100 yanked alist)
943 ;; We first yank the groups the normal way... 1101 ;; We first yank the groups the normal way...
944 (setq yanked (gnus-group-yank-group arg)) 1102 (setq yanked (gnus-group-yank-group arg))
945 ;; Then we enter the yanked groups into the topics they belong 1103 ;; Then we enter the yanked groups into the topics they belong
946 ;; to. 1104 ;; to.
947 (setq alist (assoc (save-excursion 1105 (setq alist (assoc (save-excursion
948 (forward-line -1) 1106 (forward-line -1)
949 (gnus-group-parent-topic)) 1107 (gnus-current-topic))
950 gnus-topic-alist)) 1108 gnus-topic-alist))
951 (when (stringp yanked) 1109 (when (stringp yanked)
952 (setq yanked (list yanked))) 1110 (setq yanked (list yanked)))
953 (if (not prev) 1111 (if (not prev)
954 (nconc alist yanked) 1112 (nconc alist yanked)
962 (gnus-topic-update-topic))) 1120 (gnus-topic-update-topic)))
963 1121
964 (defun gnus-topic-hide-topic () 1122 (defun gnus-topic-hide-topic ()
965 "Hide the current topic." 1123 "Hide the current topic."
966 (interactive) 1124 (interactive)
967 (when (gnus-group-parent-topic) 1125 (when (gnus-current-topic)
968 (gnus-topic-goto-topic (gnus-group-parent-topic)) 1126 (gnus-topic-goto-topic (gnus-current-topic))
969 (gnus-topic-remove-topic nil nil 'hidden))) 1127 (gnus-topic-remove-topic nil nil 'hidden)))
970 1128
971 (defun gnus-topic-show-topic () 1129 (defun gnus-topic-show-topic ()
972 "Show the hidden topic." 1130 "Show the hidden topic."
973 (interactive) 1131 (interactive)
974 (when (gnus-group-topic-p) 1132 (when (gnus-group-topic-p)
975 (gnus-topic-remove-topic t nil 'shown))) 1133 (gnus-topic-remove-topic t nil 'shown)))
976 1134
977 (defun gnus-topic-mark-topic (topic &optional unmark) 1135 (defun gnus-topic-mark-topic (topic &optional unmark)
978 "Mark all groups in the topic with the process mark." 1136 "Mark all groups in the topic with the process mark."
979 (interactive (list (gnus-group-parent-topic))) 1137 (interactive (list (gnus-group-topic-name)))
980 (save-excursion 1138 (if (not topic)
981 (let ((groups (gnus-topic-find-groups topic 9 t))) 1139 (call-interactively 'gnus-group-mark-group)
982 (while groups 1140 (save-excursion
983 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) 1141 (let ((groups (gnus-topic-find-groups topic 9 t)))
984 (gnus-info-group (nth 2 (pop groups)))))))) 1142 (while groups
1143 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
1144 (gnus-info-group (nth 2 (pop groups)))))))))
985 1145
986 (defun gnus-topic-unmark-topic (topic &optional unmark) 1146 (defun gnus-topic-unmark-topic (topic &optional unmark)
987 "Remove the process mark from all groups in the topic." 1147 "Remove the process mark from all groups in the topic."
988 (interactive (list (gnus-group-parent-topic))) 1148 (interactive (list (gnus-group-topic-name)))
989 (gnus-topic-mark-topic topic t)) 1149 (if (not topic)
1150 (call-interactively 'gnus-group-unmark-group)
1151 (gnus-topic-mark-topic topic t)))
990 1152
991 (defun gnus-topic-get-new-news-this-topic (&optional n) 1153 (defun gnus-topic-get-new-news-this-topic (&optional n)
992 "Check for new news in the current topic." 1154 "Check for new news in the current topic."
993 (interactive "P") 1155 (interactive "P")
994 (if (not (gnus-group-topic-p)) 1156 (if (not (gnus-group-topic-p))
1035 (gnus-topic-find-topology topic nil nil 'delete))) 1197 (gnus-topic-find-topology topic nil nil 'delete)))
1036 1198
1037 (defun gnus-topic-rename (old-name new-name) 1199 (defun gnus-topic-rename (old-name new-name)
1038 "Rename a topic." 1200 "Rename a topic."
1039 (interactive 1201 (interactive
1040 (let ((topic (gnus-group-parent-topic))) 1202 (let ((topic (gnus-current-topic)))
1041 (list topic 1203 (list topic
1042 (read-string (format "Rename %s to: " topic))))) 1204 (read-string (format "Rename %s to: " topic)))))
1043 (let ((top (gnus-topic-find-topology old-name)) 1205 (let ((top (gnus-topic-find-topology old-name))
1044 (entry (assoc old-name gnus-topic-alist))) 1206 (entry (assoc old-name gnus-topic-alist)))
1045 (when top 1207 (when top
1046 (setcar (cadr top) new-name)) 1208 (setcar (cadr top) new-name))
1047 (when entry 1209 (when entry
1048 (setcar entry new-name)) 1210 (setcar entry new-name))
1049 (forward-line -1) 1211 (forward-line -1)
1212 (gnus-dribble-touch)
1050 (gnus-group-list-groups))) 1213 (gnus-group-list-groups)))
1051 1214
1052 (defun gnus-topic-indent (&optional unindent) 1215 (defun gnus-topic-indent (&optional unindent)
1053 "Indent a topic -- make it a sub-topic of the previous topic. 1216 "Indent a topic -- make it a sub-topic of the previous topic.
1054 If UNINDENT, remove an indentation." 1217 If UNINDENT, remove an indentation."
1055 (interactive "P") 1218 (interactive "P")
1056 (if unindent 1219 (if unindent
1057 (gnus-topic-unindent) 1220 (gnus-topic-unindent)
1058 (let* ((topic (gnus-group-parent-topic)) 1221 (let* ((topic (gnus-current-topic))
1059 (parent (gnus-topic-previous-topic topic))) 1222 (parent (gnus-topic-previous-topic topic))
1223 (buffer-read-only nil))
1060 (unless parent 1224 (unless parent
1061 (error "Nothing to indent %s into" topic)) 1225 (error "Nothing to indent %s into" topic))
1062 (when topic 1226 (when topic
1063 (gnus-topic-goto-topic topic) 1227 (gnus-topic-goto-topic topic)
1064 (gnus-topic-kill-group) 1228 (gnus-topic-kill-group)
1229 (push (cdar gnus-topic-killed-topics) gnus-topic-alist)
1065 (gnus-topic-create-topic 1230 (gnus-topic-create-topic
1066 topic parent nil (cdr (pop gnus-topic-killed-topics))) 1231 topic parent nil (cdaar gnus-topic-killed-topics))
1232 (pop gnus-topic-killed-topics)
1067 (or (gnus-topic-goto-topic topic) 1233 (or (gnus-topic-goto-topic topic)
1068 (gnus-topic-goto-topic parent)))))) 1234 (gnus-topic-goto-topic parent))))))
1069 1235
1070 (defun gnus-topic-unindent () 1236 (defun gnus-topic-unindent ()
1071 "Unindent a topic." 1237 "Unindent a topic."
1072 (interactive) 1238 (interactive)
1073 (let* ((topic (gnus-group-parent-topic)) 1239 (let* ((topic (gnus-current-topic))
1074 (parent (gnus-topic-parent-topic topic)) 1240 (parent (gnus-topic-parent-topic topic))
1075 (grandparent (gnus-topic-parent-topic parent))) 1241 (grandparent (gnus-topic-parent-topic parent)))
1076 (unless grandparent 1242 (unless grandparent
1077 (error "Nothing to indent %s into" topic)) 1243 (error "Nothing to indent %s into" topic))
1078 (when topic 1244 (when topic
1079 (gnus-topic-goto-topic topic) 1245 (gnus-topic-goto-topic topic)
1080 (gnus-topic-kill-group) 1246 (gnus-topic-kill-group)
1247 (push (cdar gnus-topic-killed-topics) gnus-topic-alist)
1081 (gnus-topic-create-topic 1248 (gnus-topic-create-topic
1082 topic grandparent (gnus-topic-next-topic parent) 1249 topic grandparent (gnus-topic-next-topic parent)
1083 (cdr (pop gnus-topic-killed-topics))) 1250 (cdaar gnus-topic-killed-topics))
1251 (pop gnus-topic-killed-topics)
1084 (gnus-topic-goto-topic topic)))) 1252 (gnus-topic-goto-topic topic))))
1085 1253
1086 (defun gnus-topic-list-active (&optional force) 1254 (defun gnus-topic-list-active (&optional force)
1087 "List all groups that Gnus knows about in a topicsified fashion. 1255 "List all groups that Gnus knows about in a topicsified fashion.
1088 If FORCE, always re-read the active file." 1256 If FORCE, always re-read the active file."
1093 (let ((gnus-topic-topology gnus-topic-active-topology) 1261 (let ((gnus-topic-topology gnus-topic-active-topology)
1094 (gnus-topic-alist gnus-topic-active-alist) 1262 (gnus-topic-alist gnus-topic-active-alist)
1095 gnus-killed-list gnus-zombie-list) 1263 gnus-killed-list gnus-zombie-list)
1096 (gnus-group-list-groups 9 nil 1))) 1264 (gnus-group-list-groups 9 nil 1)))
1097 1265
1266 ;;; Topic sorting functions
1267
1268 (defun gnus-topic-edit-parameters (group)
1269 "Edit the group parameters of GROUP.
1270 If performed on a topic, edit the topic parameters instead."
1271 (interactive (list (gnus-group-group-name)))
1272 (if group
1273 (gnus-group-edit-group-parameters group)
1274 (if (not (gnus-group-topic-p))
1275 (error "Nothing to edit on the current line.")
1276 (let ((topic (gnus-group-topic-name)))
1277 (gnus-edit-form
1278 (gnus-topic-parameters topic)
1279 "Editing the topic parameters."
1280 `(lambda (form)
1281 (gnus-topic-set-parameters ,topic form)))))))
1282
1283 (defun gnus-group-sort-topic (func reverse)
1284 "Sort groups in the topics according to FUNC and REVERSE."
1285 (let ((alist gnus-topic-alist))
1286 (while alist
1287 ;; !!!Sometimes nil elements sneak into the alist,
1288 ;; for some reason or other.
1289 (setcar alist (delq nil (car alist)))
1290 (gnus-topic-sort-topic (pop alist) func reverse))))
1291
1292 (defun gnus-topic-sort-topic (topic func reverse)
1293 ;; Each topic only lists the name of the group, while
1294 ;; the sort predicates expect group infos as inputs.
1295 ;; So we first transform the group names into infos,
1296 ;; then sort, and then transform back into group names.
1297 (setcdr
1298 topic
1299 (mapcar
1300 (lambda (info) (gnus-info-group info))
1301 (sort
1302 (mapcar
1303 (lambda (group) (gnus-get-info group))
1304 (cdr topic))
1305 func)))
1306 ;; Do the reversal, if necessary.
1307 (when reverse
1308 (setcdr topic (nreverse (cdr topic)))))
1309
1310 (defun gnus-topic-sort-groups (func &optional reverse)
1311 "Sort the current topic according to FUNC.
1312 If REVERSE, reverse the sorting order."
1313 (interactive (list gnus-group-sort-function current-prefix-arg))
1314 (let ((topic (assoc (gnus-current-topic) gnus-topic-alist)))
1315 (gnus-topic-sort-topic
1316 topic (gnus-make-sort-function func) reverse)
1317 (gnus-group-list-groups)))
1318
1319 (defun gnus-topic-sort-groups-by-alphabet (&optional reverse)
1320 "Sort the current topic alphabetically by group name.
1321 If REVERSE, sort in reverse order."
1322 (interactive "P")
1323 (gnus-topic-sort-groups 'gnus-group-sort-by-alphabet reverse))
1324
1325 (defun gnus-topic-sort-groups-by-unread (&optional reverse)
1326 "Sort the current topic by number of unread articles.
1327 If REVERSE, sort in reverse order."
1328 (interactive "P")
1329 (gnus-topic-sort-groups 'gnus-group-sort-by-unread reverse))
1330
1331 (defun gnus-topic-sort-groups-by-level (&optional reverse)
1332 "Sort the current topic by group level.
1333 If REVERSE, sort in reverse order."
1334 (interactive "P")
1335 (gnus-topic-sort-groups 'gnus-group-sort-by-level reverse))
1336
1337 (defun gnus-topic-sort-groups-by-score (&optional reverse)
1338 "Sort the current topic by group score.
1339 If REVERSE, sort in reverse order."
1340 (interactive "P")
1341 (gnus-topic-sort-groups 'gnus-group-sort-by-score reverse))
1342
1343 (defun gnus-topic-sort-groups-by-rank (&optional reverse)
1344 "Sort the current topic by group rank.
1345 If REVERSE, sort in reverse order."
1346 (interactive "P")
1347 (gnus-topic-sort-groups 'gnus-group-sort-by-rank reverse))
1348
1349 (defun gnus-topic-sort-groups-by-method (&optional reverse)
1350 "Sort the current topic alphabetically by backend name.
1351 If REVERSE, sort in reverse order."
1352 (interactive "P")
1353 (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
1354
1098 (provide 'gnus-topic) 1355 (provide 'gnus-topic)
1099 1356
1100 ;;; gnus-topic.el ends here 1357 ;;; gnus-topic.el ends here