(gnus-group-completing-read): Remove all newlines from group names. They mess up...
[gnus] / lisp / gnus-group.el
1 ;;; gnus-group.el --- group mode commands for Gnus
2
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
5
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; Keywords: news
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
23
24 ;;; Commentary:
25
26 ;;; Code:
27
28 ;; For Emacs <22.2 and XEmacs.
29 (eval-and-compile
30   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
31
32 (eval-when-compile
33   (require 'cl))
34 (defvar tool-bar-mode)
35
36 (require 'gnus)
37 (require 'gnus-start)
38 (require 'nnmail)
39 (require 'gnus-spec)
40 (require 'gnus-int)
41 (require 'gnus-range)
42 (require 'gnus-win)
43 (require 'gnus-undo)
44 (require 'gmm-utils)
45 (require 'time-date)
46 (require 'gnus-ems)
47
48 (eval-when-compile
49   (require 'mm-url)
50   (let ((features (cons 'gnus-group features)))
51     (require 'gnus-sum))
52   (unless (boundp 'gnus-cache-active-hashtb)
53     (defvar gnus-cache-active-hashtb nil)))
54
55 (autoload 'gnus-agent-total-fetched-for "gnus-agent")
56 (autoload 'gnus-cache-total-fetched-for "gnus-cache")
57
58 (defcustom gnus-no-groups-message "No Gnus is good news"
59   "*Message displayed by Gnus when no groups are available."
60   :group 'gnus-start
61   :type 'string)
62
63 (defcustom gnus-keep-same-level nil
64   "*Non-nil means that the next newsgroup after the current will be on the same level.
65 When you type, for instance, `n' after reading the last article in the
66 current newsgroup, you will go to the next newsgroup.  If this variable
67 is nil, the next newsgroup will be the next from the group
68 buffer.
69 If this variable is non-nil, Gnus will either put you in the
70 next newsgroup with the same level, or, if no such newsgroup is
71 available, the next newsgroup with the lowest possible level higher
72 than the current level.
73 If this variable is `best', Gnus will make the next newsgroup the one
74 with the best level."
75   :group 'gnus-group-levels
76   :type '(choice (const nil)
77                  (const best)
78                  (sexp :tag "other" t)))
79
80 (defcustom gnus-group-goto-unread t
81   "*If non-nil, movement commands will go to the next unread and subscribed group."
82   :link '(custom-manual "(gnus)Group Maneuvering")
83   :group 'gnus-group-various
84   :type 'boolean)
85
86 (defcustom gnus-goto-next-group-when-activating t
87   "*If non-nil, the \\<gnus-group-mode-map>\\[gnus-group-get-new-news-this-group] command will advance point to the next group."
88   :link '(custom-manual "(gnus)Scanning New Messages")
89   :group 'gnus-group-various
90   :type 'boolean)
91
92 (defcustom gnus-permanently-visible-groups nil
93   "*Regexp to match groups that should always be listed in the group buffer.
94 This means that they will still be listed even when there are no
95 unread articles in the groups.
96
97 If nil, no groups are permanently visible."
98   :group 'gnus-group-listing
99   :type '(choice regexp (const nil)))
100
101 (defcustom gnus-safe-html-newsgroups "\\`nnrss[+:]"
102   "Groups in which links in html articles are considered all safe.
103 The value may be a regexp matching those groups, a list of group names,
104 or nil.  This overrides `mm-w3m-safe-url-regexp' (which see).  This is
105 effective only when emacs-w3m renders html articles, i.e., in the case
106 `mm-text-html-renderer' is set to `w3m'."
107   :version "23.2"
108   :group 'gnus-group-various
109   :type '(choice regexp
110                  (repeat :tag "List of group names" (string :tag "Group"))
111                  (const nil)))
112
113 (defcustom gnus-list-groups-with-ticked-articles t
114   "*If non-nil, list groups that have only ticked articles.
115 If nil, only list groups that have unread articles."
116   :group 'gnus-group-listing
117   :type 'boolean)
118
119 (defcustom gnus-group-default-list-level gnus-level-subscribed
120   "*Default listing level.
121 Ignored if `gnus-group-use-permanent-levels' is non-nil."
122   :group 'gnus-group-listing
123   :type 'integer)
124
125 (defcustom gnus-group-list-inactive-groups t
126   "*If non-nil, inactive groups will be listed."
127   :group 'gnus-group-listing
128   :group 'gnus-group-levels
129   :type 'boolean)
130
131 (defcustom gnus-group-sort-function 'gnus-group-sort-by-alphabet
132   "*Function used for sorting the group buffer.
133 This function will be called with group info entries as the arguments
134 for the groups to be sorted.  Pre-made functions include
135 `gnus-group-sort-by-alphabet', `gnus-group-sort-by-real-name',
136 `gnus-group-sort-by-unread', `gnus-group-sort-by-level',
137 `gnus-group-sort-by-score', `gnus-group-sort-by-method',
138 `gnus-group-sort-by-server', and `gnus-group-sort-by-rank'.
139
140 This variable can also be a list of sorting functions.  In that case,
141 the most significant sort function should be the last function in the
142 list."
143   :group 'gnus-group-listing
144   :link '(custom-manual "(gnus)Sorting Groups")
145   :type '(repeat :value-to-internal (lambda (widget value)
146                                       (if (listp value) value (list value)))
147                  :match (lambda (widget value)
148                           (or (symbolp value)
149                               (widget-editable-list-match widget value)))
150                  (choice (function-item gnus-group-sort-by-alphabet)
151                          (function-item gnus-group-sort-by-real-name)
152                          (function-item gnus-group-sort-by-unread)
153                          (function-item gnus-group-sort-by-level)
154                          (function-item gnus-group-sort-by-score)
155                          (function-item gnus-group-sort-by-method)
156                          (function-item gnus-group-sort-by-server)
157                          (function-item gnus-group-sort-by-rank)
158                          (function :tag "other" nil))))
159
160 (defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)\n"
161   "*Format of group lines.
162 It works along the same lines as a normal formatting string,
163 with some simple extensions.
164
165 %M    Only marked articles (character, \"*\" or \" \")
166 %S    Whether the group is subscribed (character, \"U\", \"K\", \"Z\" or \" \")
167 %L    Level of subscribedness (integer)
168 %N    Number of unread articles (integer)
169 %I    Number of dormant articles (integer)
170 %i    Number of ticked and dormant (integer)
171 %T    Number of ticked articles (integer)
172 %R    Number of read articles (integer)
173 %U    Number of unseen articles (integer)
174 %t    Estimated total number of articles (integer)
175 %y    Number of unread, unticked articles (integer)
176 %G    Group name (string)
177 %g    Qualified group name (string)
178 %c    Short (collapsed) group name.  See `gnus-group-uncollapsed-levels'.
179 %C    Group comment (string)
180 %D    Group description (string)
181 %s    Select method (string)
182 %o    Moderated group (char, \"m\")
183 %p    Process mark (char)
184 %B    Whether a summary buffer for the group is open (char, \"*\")
185 %O    Moderated group (string, \"(m)\" or \"\")
186 %P    Topic indentation (string)
187 %m    Whether there is new(ish) mail in the group (char, \"%\")
188 %n    Select from where (string)
189 %z    A string that look like `<%s:%n>' if a foreign select method is used
190 %d    The date the group was last entered.
191 %E    Icon as defined by `gnus-group-icon-list'.
192 %F    The disk space used by the articles fetched by both the cache and agent.
193 %u    User defined specifier.  The next character in the format string should
194       be a letter.  Gnus will call the function gnus-user-format-function-X,
195       where X is the letter following %u.  The function will be passed a
196       single dummy parameter as argument.  The function should return a
197       string, which will be inserted into the buffer just like information
198       from any other group specifier.
199
200 Note that this format specification is not always respected.  For
201 reasons of efficiency, when listing killed groups, this specification
202 is ignored altogether.  If the spec is changed considerably, your
203 output may end up looking strange when listing both alive and killed
204 groups.
205
206 If you use %o or %O, reading the active file will be slower and quite
207 a bit of extra memory will be used.  %D and %F will also worsen
208 performance.  Also note that if you change the format specification to
209 include any of these specs, you must probably re-start Gnus to see
210 them go into effect.
211
212 General format specifiers can also be used.
213 See Info node `(gnus)Formatting Variables'."
214   :link '(custom-manual "(gnus)Formatting Variables")
215   :group 'gnus-group-visual
216   :type 'string)
217
218 (defcustom gnus-group-mode-line-format "Gnus: %%b {%M\%:%S}"
219   "*The format specification for the group mode line.
220 It works along the same lines as a normal formatting string,
221 with some simple extensions:
222
223 %S   The native news server.
224 %M   The native select method.
225 %:   \":\" if %S isn't \"\"."
226   :group 'gnus-group-visual
227   :type 'string)
228
229 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
230 (when (featurep 'xemacs)
231   (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
232   (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar))
233
234 (defcustom gnus-group-menu-hook nil
235   "Hook run after the creation of the group mode menu."
236   :group 'gnus-group-various
237   :type 'hook)
238
239 (defcustom gnus-group-catchup-group-hook nil
240   "Hook run when catching up a group from the group buffer."
241   :group 'gnus-group-various
242   :link '(custom-manual "(gnus)Group Data")
243   :type 'hook)
244
245 (defcustom gnus-group-update-group-hook nil
246   "Hook called when updating group lines."
247   :group 'gnus-group-visual
248   :type 'hook)
249
250 (defcustom gnus-group-prepare-function 'gnus-group-prepare-flat
251   "*A function that is called to generate the group buffer.
252 The function is called with three arguments: The first is a number;
253 all group with a level less or equal to that number should be listed,
254 if the second is non-nil, empty groups should also be displayed.  If
255 the third is non-nil, it is a number.  No groups with a level lower
256 than this number should be displayed.
257
258 The only current function implemented is `gnus-group-prepare-flat'."
259   :group 'gnus-group-listing
260   :type 'function)
261
262 (defcustom gnus-group-prepare-hook nil
263   "Hook called after the group buffer has been generated.
264 If you want to modify the group buffer, you can use this hook."
265   :group 'gnus-group-listing
266   :type 'hook)
267
268 (defcustom gnus-suspend-gnus-hook nil
269   "Hook called when suspending (not exiting) Gnus."
270   :group 'gnus-exit
271   :type 'hook)
272
273 (defcustom gnus-exit-gnus-hook nil
274   "Hook called when exiting Gnus."
275   :group 'gnus-exit
276   :type 'hook)
277
278 (defcustom gnus-after-exiting-gnus-hook nil
279   "Hook called after exiting Gnus."
280   :group 'gnus-exit
281   :type 'hook)
282
283 (defcustom gnus-group-update-hook nil
284   "Hook called when a group line is changed."
285   :group 'gnus-group-visual
286   :version "24.1"
287   :type 'hook)
288
289 (defcustom gnus-useful-groups
290   '(("(ding) mailing list mirrored at gmane.org"
291      "gmane.emacs.gnus.general"
292      (nntp "Gmane"
293            (nntp-address "news.gmane.org")))
294     ("Gnus bug archive"
295      "gnus.gnus-bug"
296      (nntp "news.gnus.org"
297            (nntp-address "news.gnus.org")))
298     ("Local Gnus help group"
299      "gnus-help"
300      (nndoc "gnus-help"
301             (nndoc-article-type mbox)
302             (eval `(nndoc-address
303                     ,(let ((file (nnheader-find-etc-directory
304                                   "gnus-tut.txt" t)))
305                        (unless file
306                          (error "Couldn't find doc group"))
307                        file))))))
308   "*Alist of useful group-server pairs."
309   :group 'gnus-group-listing
310   :type '(repeat (list (string :tag "Description")
311                        (string :tag "Name")
312                        (sexp :tag "Method"))))
313
314 (defcustom gnus-group-highlight
315   '(;; Mail.
316     ((and mailp (= unread 0) (eq level 1)) .
317      gnus-group-mail-1-empty)
318     ((and mailp (eq level 1)) .
319      gnus-group-mail-1)
320     ((and mailp (= unread 0) (eq level 2)) .
321      gnus-group-mail-2-empty)
322     ((and mailp (eq level 2)) .
323      gnus-group-mail-2)
324     ((and mailp (= unread 0) (eq level 3)) .
325      gnus-group-mail-3-empty)
326     ((and mailp (eq level 3)) .
327      gnus-group-mail-3)
328     ((and mailp (= unread 0)) .
329      gnus-group-mail-low-empty)
330     ((and mailp) .
331      gnus-group-mail-low)
332     ;; News.
333     ((and (= unread 0) (eq level 1)) .
334      gnus-group-news-1-empty)
335     ((and (eq level 1)) .
336      gnus-group-news-1)
337     ((and (= unread 0) (eq level 2)) .
338      gnus-group-news-2-empty)
339     ((and (eq level 2)) .
340      gnus-group-news-2)
341     ((and (= unread 0) (eq level 3)) .
342      gnus-group-news-3-empty)
343     ((and (eq level 3)) .
344      gnus-group-news-3)
345     ((and (= unread 0) (eq level 4)) .
346      gnus-group-news-4-empty)
347     ((and (eq level 4)) .
348      gnus-group-news-4)
349     ((and (= unread 0) (eq level 5)) .
350      gnus-group-news-5-empty)
351     ((and (eq level 5)) .
352      gnus-group-news-5)
353     ((and (= unread 0) (eq level 6)) .
354      gnus-group-news-6-empty)
355     ((and (eq level 6)) .
356      gnus-group-news-6)
357     ((and (= unread 0)) .
358      gnus-group-news-low-empty)
359     (t .
360      gnus-group-news-low))
361   "*Controls the highlighting of group buffer lines.
362
363 Below is a list of `Form'/`Face' pairs.  When deciding how a a
364 particular group line should be displayed, each form is
365 evaluated.  The content of the face field after the first true form is
366 used.  You can change how those group lines are displayed by
367 editing the face field.
368
369 It is also possible to change and add form fields, but currently that
370 requires an understanding of Lisp expressions.  Hopefully this will
371 change in a future release.  For now, you can use the following
372 variables in the Lisp expression:
373
374 group: The name of the group.
375 unread: The number of unread articles in the group.
376 method: The select method used.
377 mailp: Whether it's a mail group or not.
378 level: The level of the group.
379 score: The score of the group.
380 ticked: The number of ticked articles."
381   :group 'gnus-group-visual
382   :type '(repeat (cons (sexp :tag "Form") face)))
383 (put 'gnus-group-highlight 'risky-local-variable t)
384
385 (defcustom gnus-new-mail-mark ?%
386   "Mark used for groups with new mail."
387   :group 'gnus-group-visual
388   :type 'character)
389
390 (defgroup gnus-group-icons nil
391   "Add Icons to your group buffer."
392   :group 'gnus-group-visual)
393
394 (defcustom gnus-group-icon-list
395   nil
396   "*Controls the insertion of icons into group buffer lines.
397
398 Below is a list of `Form'/`File' pairs.  When deciding how a
399 particular group line should be displayed, each form is evaluated.
400 The icon from the file field after the first true form is used.  You
401 can change how those group lines are displayed by editing the file
402 field.  The File will either be found in the
403 `gnus-group-glyph-directory' or by designating absolute name of the
404 file.
405
406 It is also possible to change and add form fields, but currently that
407 requires an understanding of Lisp expressions.  Hopefully this will
408 change in a future release.  For now, you can use the following
409 variables in the Lisp expression:
410
411 group: The name of the group.
412 unread: The number of unread articles in the group.
413 method: The select method used.
414 mailp: Whether it's a mail group or not.
415 level: The level of the group.
416 score: The score of the group.
417 ticked: The number of ticked articles."
418   :group 'gnus-group-icons
419   :type '(repeat (cons (sexp :tag "Form") file)))
420 (put 'gnus-group-icon-list 'risky-local-variable t)
421
422 (defcustom gnus-group-name-charset-method-alist nil
423   "Alist of method and the charset for group names.
424
425 For example:
426     (((nntp \"news.com.cn\") . cn-gb-2312))"
427   :version "21.1"
428   :group 'gnus-charset
429   :type '(repeat (cons (sexp :tag "Method") (symbol :tag "Charset"))))
430
431 (defcustom gnus-group-name-charset-group-alist
432   (if (or (and (fboundp 'find-coding-system) (find-coding-system 'utf-8))
433           (mm-coding-system-p 'utf-8))
434       '((".*" . utf-8))
435     nil)
436   "Alist of group regexp and the charset for group names.
437
438 For example:
439     ((\"\\.com\\.cn:\" . cn-gb-2312))"
440   :group 'gnus-charset
441   :type '(repeat (cons (regexp :tag "Group") (symbol :tag "Charset"))))
442
443 (defcustom gnus-group-jump-to-group-prompt nil
444   "Default prompt for `gnus-group-jump-to-group'.
445
446 If non-nil, the value should be a string or an alist.  If it is a string,
447 e.g. \"nnml:\", in which case `gnus-group-jump-to-group' offers \"Group:
448 nnml:\" in the minibuffer prompt.
449
450 If it is an alist, it must consist of \(NUMBER .  PROMPT\) pairs, for example:
451 \((1 .  \"\") (2 .  \"nnfolder+archive:\")).  The element with number 0 is
452 used when no prefix argument is given to `gnus-group-jump-to-group'."
453   :version "22.1"
454   :group 'gnus-group-various
455   :type '(choice (string :tag "Prompt string")
456                  (const :tag "Empty" nil)
457                  (repeat (cons (integer :tag "Argument")
458                                (string :tag "Prompt string")))))
459
460 (defvar gnus-group-listing-limit 1000
461   "*A limit of the number of groups when listing.
462 If the number of groups is larger than the limit, list them in a
463 simple manner.")
464
465 ;;; Internal variables
466
467 (defvar gnus-group-is-exiting-p nil)
468 (defvar gnus-group-is-exiting-without-update-p nil)
469 (defvar gnus-group-sort-alist-function 'gnus-group-sort-flat
470   "Function for sorting the group buffer.")
471
472 (defvar gnus-group-sort-selected-function 'gnus-group-sort-selected-flat
473   "Function for sorting the selected groups in the group buffer.")
474
475 (defvar gnus-group-indentation-function nil)
476 (defvar gnus-goto-missing-group-function nil)
477 (defvar gnus-group-update-group-function nil)
478 (defvar gnus-group-goto-next-group-function nil
479   "Function to override finding the next group after listing groups.")
480
481 (defvar gnus-group-edit-buffer nil)
482
483 (defvar gnus-group-line-format-alist
484   `((?M gnus-tmp-marked-mark ?c)
485     (?S gnus-tmp-subscribed ?c)
486     (?L gnus-tmp-level ?d)
487     (?N (cond ((eq number t) "*" )
488               ((numberp number)
489                (int-to-string
490                 (+ number
491                    (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked)))
492                    (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))))))
493               (t number)) ?s)
494     (?R gnus-tmp-number-of-read ?s)
495     (?U (if (gnus-active gnus-tmp-group)
496             (gnus-number-of-unseen-articles-in-group gnus-tmp-group)
497           "*")
498         ?s)
499     (?t gnus-tmp-number-total ?d)
500     (?y gnus-tmp-number-of-unread ?s)
501     (?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d)
502     (?T (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))) ?d)
503     (?i (+ (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked)))
504            (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))) ?d)
505     (?g (if (boundp 'gnus-tmp-decoded-group)
506             gnus-tmp-decoded-group
507           gnus-tmp-group)
508         ?s)
509     (?G gnus-tmp-qualified-group ?s)
510     (?c (gnus-short-group-name (if (boundp 'gnus-tmp-decoded-group)
511                                    gnus-tmp-decoded-group
512                                  gnus-tmp-group))
513         ?s)
514     (?C gnus-tmp-comment ?s)
515     (?D gnus-tmp-newsgroup-description ?s)
516     (?o gnus-tmp-moderated ?c)
517     (?O gnus-tmp-moderated-string ?s)
518     (?p gnus-tmp-process-marked ?c)
519     (?s gnus-tmp-news-server ?s)
520     (?n ,(if (featurep 'xemacs)
521              '(symbol-name gnus-tmp-news-method)
522            'gnus-tmp-news-method)
523         ?s)
524     (?P gnus-group-indentation ?s)
525     (?E gnus-tmp-group-icon ?s)
526     (?B gnus-tmp-summary-live ?c)
527     (?z gnus-tmp-news-method-string ?s)
528     (?m (gnus-group-new-mail gnus-tmp-group) ?c)
529     (?d (gnus-group-timestamp-string gnus-tmp-group) ?s)
530     (?u gnus-tmp-user-defined ?s)
531     (?F (gnus-total-fetched-for gnus-tmp-group) ?s)
532     ))
533
534 (defvar gnus-group-mode-line-format-alist
535   `((?S gnus-tmp-news-server ?s)
536     (?M gnus-tmp-news-method ?s)
537     (?u gnus-tmp-user-defined ?s)
538     (?: gnus-tmp-colon ?s)))
539
540 (defvar gnus-topic-topology nil
541   "The complete topic hierarchy.")
542
543 (defvar gnus-topic-alist nil
544   "The complete topic-group alist.")
545
546 (defvar gnus-group-marked nil)
547
548 (defvar gnus-group-list-mode nil)
549
550
551 (defvar gnus-group-listed-groups nil)
552 (defvar gnus-group-list-option nil)
553
554 ;;;
555 ;;; Gnus group mode
556 ;;;
557
558 (put 'gnus-group-mode 'mode-class 'special)
559
560 (gnus-define-keys gnus-group-mode-map
561   " " gnus-group-read-group
562   "=" gnus-group-select-group
563   "\r" gnus-group-select-group
564   "\M-\r" gnus-group-quick-select-group
565   "\M- " gnus-group-visible-select-group
566   [(meta control return)] gnus-group-select-group-ephemerally
567   "j" gnus-group-jump-to-group
568   "n" gnus-group-next-unread-group
569   "p" gnus-group-prev-unread-group
570   "\177" gnus-group-prev-unread-group
571   [delete] gnus-group-prev-unread-group
572   [backspace] gnus-group-prev-unread-group
573   "N" gnus-group-next-group
574   "P" gnus-group-prev-group
575   "\M-n" gnus-group-next-unread-group-same-level
576   "\M-p" gnus-group-prev-unread-group-same-level
577   "," gnus-group-best-unread-group
578   "." gnus-group-first-unread-group
579   "u" gnus-group-unsubscribe-current-group
580   "U" gnus-group-unsubscribe-group
581   "c" gnus-group-catchup-current
582   "C" gnus-group-catchup-current-all
583   "\M-c" gnus-group-clear-data
584   "l" gnus-group-list-groups
585   "L" gnus-group-list-all-groups
586   "m" gnus-group-mail
587   "i" gnus-group-news
588   "g" gnus-group-get-new-news
589   "\M-g" gnus-group-get-new-news-this-group
590   "R" gnus-group-restart
591   "r" gnus-group-read-init-file
592   "B" gnus-group-browse-foreign-server
593   "b" gnus-group-check-bogus-groups
594   "F" gnus-group-find-new-groups
595   "\C-c\C-d" gnus-group-describe-group
596   "\M-d" gnus-group-describe-all-groups
597   "\C-c\C-a" gnus-group-apropos
598   "\C-c\M-\C-a" gnus-group-description-apropos
599   "a" gnus-group-post-news
600   "\ek" gnus-group-edit-local-kill
601   "\eK" gnus-group-edit-global-kill
602   "\C-k" gnus-group-kill-group
603   "\C-y" gnus-group-yank-group
604   "\C-w" gnus-group-kill-region
605   "\C-x\C-t" gnus-group-transpose-groups
606   "\C-c\C-l" gnus-group-list-killed
607   "\C-c\C-x" gnus-group-expire-articles
608   "\C-c\M-\C-x" gnus-group-expire-all-groups
609   "V" gnus-version
610   "s" gnus-group-save-newsrc
611   "z" gnus-group-suspend
612   "q" gnus-group-exit
613   "Q" gnus-group-quit
614   "?" gnus-group-describe-briefly
615   "\C-c\C-i" gnus-info-find-node
616   "\M-e" gnus-group-edit-group-method
617   "^" gnus-group-enter-server-mode
618   gnus-mouse-2 gnus-mouse-pick-group
619   [follow-link] mouse-face
620   "<" beginning-of-buffer
621   ">" end-of-buffer
622   "\C-c\C-b" gnus-bug
623   "\C-c\C-s" gnus-group-sort-groups
624   "t" gnus-topic-mode
625   "\C-c\M-g" gnus-activate-all-groups
626   "\M-&" gnus-group-universal-argument
627   "#" gnus-group-mark-group
628   "\M-#" gnus-group-unmark-group)
629
630 (gnus-define-keys (gnus-group-mark-map "M" gnus-group-mode-map)
631   "m" gnus-group-mark-group
632   "u" gnus-group-unmark-group
633   "w" gnus-group-mark-region
634   "b" gnus-group-mark-buffer
635   "r" gnus-group-mark-regexp
636   "U" gnus-group-unmark-all-groups)
637
638 (gnus-define-keys (gnus-group-sieve-map "D" gnus-group-mode-map)
639   "u" gnus-sieve-update
640   "g" gnus-sieve-generate)
641
642 (gnus-define-keys (gnus-group-group-map "G" gnus-group-mode-map)
643   "d" gnus-group-make-directory-group
644   "h" gnus-group-make-help-group
645   "u" gnus-group-make-useful-group
646   "l" gnus-group-nnimap-edit-acl
647   "m" gnus-group-make-group
648   "E" gnus-group-edit-group
649   "e" gnus-group-edit-group-method
650   "p" gnus-group-edit-group-parameters
651   "v" gnus-group-add-to-virtual
652   "V" gnus-group-make-empty-virtual
653   "D" gnus-group-enter-directory
654   "f" gnus-group-make-doc-group
655   "w" gnus-group-make-web-group
656   "M" gnus-group-read-ephemeral-group
657   "r" gnus-group-rename-group
658   "R" gnus-group-make-rss-group
659   "c" gnus-group-customize
660   "z" gnus-group-compact-group
661   "x" gnus-group-expunge-group
662   "\177" gnus-group-delete-group
663   [delete] gnus-group-delete-group)
664
665 (gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map)
666   "s" gnus-group-sort-groups
667   "a" gnus-group-sort-groups-by-alphabet
668   "u" gnus-group-sort-groups-by-unread
669   "l" gnus-group-sort-groups-by-level
670   "v" gnus-group-sort-groups-by-score
671   "r" gnus-group-sort-groups-by-rank
672   "m" gnus-group-sort-groups-by-method
673   "n" gnus-group-sort-groups-by-real-name)
674
675 (gnus-define-keys (gnus-group-sort-selected-map "P" gnus-group-group-map)
676   "s" gnus-group-sort-selected-groups
677   "a" gnus-group-sort-selected-groups-by-alphabet
678   "u" gnus-group-sort-selected-groups-by-unread
679   "l" gnus-group-sort-selected-groups-by-level
680   "v" gnus-group-sort-selected-groups-by-score
681   "r" gnus-group-sort-selected-groups-by-rank
682   "m" gnus-group-sort-selected-groups-by-method
683   "n" gnus-group-sort-selected-groups-by-real-name)
684
685 (gnus-define-keys (gnus-group-list-map "A" gnus-group-mode-map)
686   "k" gnus-group-list-killed
687   "z" gnus-group-list-zombies
688   "s" gnus-group-list-groups
689   "u" gnus-group-list-all-groups
690   "A" gnus-group-list-active
691   "a" gnus-group-apropos
692   "d" gnus-group-description-apropos
693   "m" gnus-group-list-matching
694   "M" gnus-group-list-all-matching
695   "l" gnus-group-list-level
696   "c" gnus-group-list-cached
697   "?" gnus-group-list-dormant)
698
699 (gnus-define-keys (gnus-group-list-limit-map "/" gnus-group-list-map)
700   "k"  gnus-group-list-limit
701   "z"  gnus-group-list-limit
702   "s"  gnus-group-list-limit
703   "u"  gnus-group-list-limit
704   "A"  gnus-group-list-limit
705   "m"  gnus-group-list-limit
706   "M"  gnus-group-list-limit
707   "l"  gnus-group-list-limit
708   "c"  gnus-group-list-limit
709   "?"  gnus-group-list-limit)
710
711 (gnus-define-keys (gnus-group-list-flush-map "f" gnus-group-list-map)
712   "k"  gnus-group-list-flush
713   "z"  gnus-group-list-flush
714   "s"  gnus-group-list-flush
715   "u"  gnus-group-list-flush
716   "A"  gnus-group-list-flush
717   "m"  gnus-group-list-flush
718   "M"  gnus-group-list-flush
719   "l"  gnus-group-list-flush
720   "c"  gnus-group-list-flush
721   "?"  gnus-group-list-flush)
722
723 (gnus-define-keys (gnus-group-list-plus-map "p" gnus-group-list-map)
724   "k"  gnus-group-list-plus
725   "z"  gnus-group-list-plus
726   "s"  gnus-group-list-plus
727   "u"  gnus-group-list-plus
728   "A"  gnus-group-list-plus
729   "m"  gnus-group-list-plus
730   "M"  gnus-group-list-plus
731   "l"  gnus-group-list-plus
732   "c"  gnus-group-list-plus
733   "?"  gnus-group-list-plus)
734
735 (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map)
736   "f" gnus-score-flush-cache
737   "e" gnus-score-edit-all-score)
738
739 (gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map)
740   "C" gnus-group-fetch-control
741   "d" gnus-group-describe-group
742   "v" gnus-version)
743
744 (gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map)
745   "l" gnus-group-set-current-level
746   "t" gnus-group-unsubscribe-current-group
747   "s" gnus-group-unsubscribe-group
748   "k" gnus-group-kill-group
749   "y" gnus-group-yank-group
750   "w" gnus-group-kill-region
751   "\C-k" gnus-group-kill-level
752   "z" gnus-group-kill-all-zombies)
753
754 (defun gnus-topic-mode-p ()
755   "Return non-nil in `gnus-topic-mode'."
756   (and (boundp 'gnus-topic-mode)
757        (symbol-value 'gnus-topic-mode)))
758
759 (defun gnus-group-make-menu-bar ()
760   (unless (boundp 'gnus-group-reading-menu)
761
762     (easy-menu-define
763      gnus-group-reading-menu gnus-group-mode-map ""
764      `("Group"
765        ["Read" gnus-group-read-group
766         :included (not (gnus-topic-mode-p))
767         :active (gnus-group-group-name)]
768        ["Read " gnus-topic-read-group
769         :included (gnus-topic-mode-p)]
770        ["Select" gnus-group-select-group
771         :included (not (gnus-topic-mode-p))
772         :active (gnus-group-group-name)]
773        ["Select " gnus-topic-select-group
774         :included (gnus-topic-mode-p)]
775        ["See old articles" (gnus-group-select-group 'all)
776         :keys "C-u SPC" :active (gnus-group-group-name)]
777        ["Catch up" gnus-group-catchup-current
778         :included (not (gnus-topic-mode-p))
779         :active (gnus-group-group-name)
780         ,@(if (featurep 'xemacs) nil
781             '(:help "Mark unread articles in the current group as read"))]
782        ["Catch up " gnus-topic-catchup-articles
783         :included (gnus-topic-mode-p)
784         ,@(if (featurep 'xemacs) nil
785             '(:help "Mark unread articles in the current group or topic as read"))]
786        ["Catch up all articles" gnus-group-catchup-current-all
787         (gnus-group-group-name)]
788        ["Check for new articles" gnus-group-get-new-news-this-group
789         :included (not (gnus-topic-mode-p))
790         :active (gnus-group-group-name)
791         ,@(if (featurep 'xemacs) nil
792             '(:help "Check for new messages in current group"))]
793        ["Check for new articles " gnus-topic-get-new-news-this-topic
794         :included (gnus-topic-mode-p)
795         ,@(if (featurep 'xemacs) nil
796             '(:help "Check for new messages in current group or topic"))]
797        ["Toggle subscription" gnus-group-unsubscribe-current-group
798         (gnus-group-group-name)]
799        ["Kill" gnus-group-kill-group :active (gnus-group-group-name)
800         ,@(if (featurep 'xemacs) nil
801               '(:help "Kill (remove) current group"))]
802        ["Yank" gnus-group-yank-group gnus-list-of-killed-groups]
803        ["Describe" gnus-group-describe-group :active (gnus-group-group-name)
804         ,@(if (featurep 'xemacs) nil
805             '(:help "Display description of the current group"))]
806        ["Fetch control message" gnus-group-fetch-control
807         :active (gnus-group-group-name)
808         ,@(if (featurep 'xemacs) nil
809             '(:help "Display the archived control message for the current group"))]
810        ;; Actually one should check, if any of the marked groups gives t for
811        ;; (gnus-check-backend-function 'request-expire-articles ...)
812        ["Expire articles" gnus-group-expire-articles
813         :included (not (gnus-topic-mode-p))
814         :active (or (and (gnus-group-group-name)
815                          (gnus-check-backend-function
816                           'request-expire-articles
817                           (gnus-group-group-name))) gnus-group-marked)]
818        ["Expire articles " gnus-topic-expire-articles
819         :included (gnus-topic-mode-p)]
820        ["Set group level..." gnus-group-set-current-level
821         (gnus-group-group-name)]
822        ["Select quick" gnus-group-quick-select-group (gnus-group-group-name)]
823        ["Customize" gnus-group-customize (gnus-group-group-name)]
824        ["Compact" gnus-group-compact-group
825         :active (gnus-group-group-name)]
826        ("Edit"
827         ["Parameters" gnus-group-edit-group-parameters
828          :included (not (gnus-topic-mode-p))
829          :active (gnus-group-group-name)]
830         ["Parameters " gnus-topic-edit-parameters
831          :included (gnus-topic-mode-p)]
832         ["Select method" gnus-group-edit-group-method
833          (gnus-group-group-name)]
834         ["Info" gnus-group-edit-group (gnus-group-group-name)]
835         ["Local kill file" gnus-group-edit-local-kill (gnus-group-group-name)]
836         ["Global kill file" gnus-group-edit-global-kill t])))
837
838     (easy-menu-define
839      gnus-group-group-menu gnus-group-mode-map ""
840      '("Groups"
841        ("Listing"
842         ["List unread subscribed groups" gnus-group-list-groups t]
843         ["List (un)subscribed groups" gnus-group-list-all-groups t]
844         ["List killed groups" gnus-group-list-killed gnus-killed-list]
845         ["List zombie groups" gnus-group-list-zombies gnus-zombie-list]
846         ["List level..." gnus-group-list-level t]
847         ["Describe all groups" gnus-group-describe-all-groups t]
848         ["Group apropos..." gnus-group-apropos t]
849         ["Group and description apropos..." gnus-group-description-apropos t]
850         ["List groups matching..." gnus-group-list-matching t]
851         ["List all groups matching..." gnus-group-list-all-matching t]
852         ["List active file" gnus-group-list-active t]
853         ["List groups with cached" gnus-group-list-cached t]
854         ["List groups with dormant" gnus-group-list-dormant t])
855        ("Sort"
856         ["Default sort" gnus-group-sort-groups t]
857         ["Sort by method" gnus-group-sort-groups-by-method t]
858         ["Sort by rank" gnus-group-sort-groups-by-rank t]
859         ["Sort by score" gnus-group-sort-groups-by-score t]
860         ["Sort by level" gnus-group-sort-groups-by-level t]
861         ["Sort by unread" gnus-group-sort-groups-by-unread t]
862         ["Sort by name" gnus-group-sort-groups-by-alphabet t]
863         ["Sort by real name" gnus-group-sort-groups-by-real-name t])
864        ("Sort process/prefixed"
865         ["Default sort" gnus-group-sort-selected-groups
866          (not (gnus-topic-mode-p))]
867         ["Sort by method" gnus-group-sort-selected-groups-by-method
868          (not (gnus-topic-mode-p))]
869         ["Sort by rank" gnus-group-sort-selected-groups-by-rank
870          (not (gnus-topic-mode-p))]
871         ["Sort by score" gnus-group-sort-selected-groups-by-score
872          (not (gnus-topic-mode-p))]
873         ["Sort by level" gnus-group-sort-selected-groups-by-level
874          (not (gnus-topic-mode-p))]
875         ["Sort by unread" gnus-group-sort-selected-groups-by-unread
876          (not (gnus-topic-mode-p))]
877         ["Sort by name" gnus-group-sort-selected-groups-by-alphabet
878          (not (gnus-topic-mode-p))]
879         ["Sort by real name" gnus-group-sort-selected-groups-by-real-name
880          (not (gnus-topic-mode-p))])
881        ("Mark"
882         ["Mark group" gnus-group-mark-group
883          (and (gnus-group-group-name)
884               (not (memq (gnus-group-group-name) gnus-group-marked)))]
885         ["Unmark group" gnus-group-unmark-group
886          (and (gnus-group-group-name)
887               (memq (gnus-group-group-name) gnus-group-marked))]
888         ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked]
889         ["Mark regexp..." gnus-group-mark-regexp t]
890         ["Mark region" gnus-group-mark-region :active (gnus-mark-active-p)]
891         ["Mark buffer" gnus-group-mark-buffer t]
892         ["Execute command" gnus-group-universal-argument
893          (or gnus-group-marked (gnus-group-group-name))])
894        ("Subscribe"
895         ["Subscribe to a group..." gnus-group-unsubscribe-group t]
896         ["Kill all newsgroups in region" gnus-group-kill-region
897          :active (gnus-mark-active-p)]
898         ["Kill all zombie groups" gnus-group-kill-all-zombies
899          gnus-zombie-list]
900         ["Kill all groups on level..." gnus-group-kill-level t])
901        ("Foreign groups"
902         ["Make a foreign group..." gnus-group-make-group t]
903         ["Add a directory group..." gnus-group-make-directory-group t]
904         ["Add the help group" gnus-group-make-help-group t]
905         ["Make a doc group..." gnus-group-make-doc-group t]
906         ["Make a web group..." gnus-group-make-web-group t]
907         ["Make a virtual group..." gnus-group-make-empty-virtual t]
908         ["Add a group to a virtual..." gnus-group-add-to-virtual t]
909         ["Make an ephemeral group..." gnus-group-read-ephemeral-group t]
910         ["Make an RSS group..." gnus-group-make-rss-group t]
911         ["Rename group..." gnus-group-rename-group
912          (gnus-check-backend-function
913           'request-rename-group (gnus-group-group-name))]
914         ["Delete group" gnus-group-delete-group
915          (gnus-check-backend-function
916           'request-delete-group (gnus-group-group-name))])
917        ("Move"
918         ["Next" gnus-group-next-group t]
919         ["Previous" gnus-group-prev-group t]
920         ["Next unread" gnus-group-next-unread-group t]
921         ["Previous unread" gnus-group-prev-unread-group t]
922         ["Next unread same level" gnus-group-next-unread-group-same-level t]
923         ["Previous unread same level"
924          gnus-group-prev-unread-group-same-level t]
925         ["Jump to group..." gnus-group-jump-to-group t]
926         ["First unread group" gnus-group-first-unread-group t]
927         ["Best unread group" gnus-group-best-unread-group t])
928        ("Sieve"
929         ["Generate" gnus-sieve-generate t]
930         ["Generate and update" gnus-sieve-update t])
931        ["Delete bogus groups" gnus-group-check-bogus-groups t]
932        ["Find new newsgroups" gnus-group-find-new-groups t]
933        ["Transpose" gnus-group-transpose-groups
934         (gnus-group-group-name)]
935        ["Read a directory as a group..." gnus-group-enter-directory t]))
936
937     (easy-menu-define
938      gnus-group-misc-menu gnus-group-mode-map ""
939      `("Gnus"
940        ["Send a mail" gnus-group-mail t]
941        ["Send a message (mail or news)" gnus-group-post-news t]
942        ["Create a local message" gnus-group-news t]
943        ["Check for new news" gnus-group-get-new-news
944         ,@(if (featurep 'xemacs) '(t)
945             '(:help "Get newly arrived articles"))
946         ]
947        ["Send queued messages" gnus-delay-send-queue
948         ,@(if (featurep 'xemacs) '(t)
949             '(:help "Send all messages that are scheduled to be sent now"))
950         ]
951        ["Activate all groups" gnus-activate-all-groups t]
952        ["Restart Gnus" gnus-group-restart t]
953        ["Read init file" gnus-group-read-init-file t]
954        ["Browse foreign server..." gnus-group-browse-foreign-server t]
955        ["Enter server buffer" gnus-group-enter-server-mode t]
956        ["Expire all expirable articles" gnus-group-expire-all-groups t]
957        ["Gnus version" gnus-version t]
958        ["Save .newsrc files" gnus-group-save-newsrc t]
959        ["Suspend Gnus" gnus-group-suspend t]
960        ["Clear dribble buffer" gnus-group-clear-dribble t]
961        ["Read manual" gnus-info-find-node t]
962        ["Flush score cache" gnus-score-flush-cache t]
963        ["Toggle topics" gnus-topic-mode t]
964        ["Send a bug report" gnus-bug t]
965        ["Exit from Gnus" gnus-group-exit
966         ,@(if (featurep 'xemacs) '(t)
967             '(:help "Quit reading news"))]
968        ["Exit without saving" gnus-group-quit t]))
969
970     (gnus-run-hooks 'gnus-group-menu-hook)))
971
972
973 (defvar gnus-group-tool-bar-map nil)
974
975 (defun gnus-group-tool-bar-update (&optional symbol value)
976   "Update group buffer toolbar.
977 Setter function for custom variables."
978   (when symbol
979     (set-default symbol value))
980   ;; (setq-default gnus-group-tool-bar-map nil)
981   ;; (use-local-map gnus-group-mode-map)
982   (when (gnus-alive-p)
983     (with-current-buffer gnus-group-buffer
984       (gnus-group-make-tool-bar t))))
985
986 (defcustom gnus-group-tool-bar (if (eq gmm-tool-bar-style 'gnome)
987                                    'gnus-group-tool-bar-gnome
988                                  'gnus-group-tool-bar-retro)
989   "Specifies the Gnus group tool bar.
990
991 It can be either a list or a symbol refering to a list.  See
992 `gmm-tool-bar-from-list' for the format of the list.  The
993 default key map is `gnus-group-mode-map'.
994
995 Pre-defined symbols include `gnus-group-tool-bar-gnome' and
996 `gnus-group-tool-bar-retro'."
997   :type '(choice (const :tag "GNOME style" gnus-group-tool-bar-gnome)
998                  (const :tag "Retro look" gnus-group-tool-bar-retro)
999                  (repeat :tag "User defined list" gmm-tool-bar-item)
1000                  (symbol))
1001   :version "23.1" ;; No Gnus
1002   :initialize 'custom-initialize-default
1003   :set 'gnus-group-tool-bar-update
1004   :group 'gnus-group)
1005
1006 (defcustom gnus-group-tool-bar-gnome
1007   '((gnus-group-post-news "mail/compose")
1008     ;; Some useful agent icons?  I don't use the agent so agent users should
1009     ;; suggest useful commands:
1010     (gnus-agent-toggle-plugged "disconnect" t
1011                                :help "Gnus is currently unplugged.  Click to work online."
1012                                :visible (and gnus-agent (not gnus-plugged)))
1013     (gnus-agent-toggle-plugged "connect" t
1014                                :help "Gnus is currently plugged.  Click to work offline."
1015                                :visible (and gnus-agent gnus-plugged))
1016     ;; FIXME: gnus-agent-toggle-plugged (in gnus-agent-group-make-menu-bar)
1017     ;; should have a better help text.
1018     (gnus-group-send-queue "mail/outbox" t
1019                            :visible (and gnus-agent gnus-plugged)
1020                            :help "Send articles from the queue group")
1021     (gnus-group-get-new-news "mail/inbox" nil
1022                              :visible (or (not gnus-agent)
1023                                           gnus-plugged))
1024     ;; FIXME: gnus-*-read-group should have a better help text.
1025     (gnus-topic-read-group "open" nil
1026                            :visible (and (boundp 'gnus-topic-mode)
1027                                          gnus-topic-mode))
1028     (gnus-group-read-group "open" nil
1029                            :visible (not (and (boundp 'gnus-topic-mode)
1030                                               gnus-topic-mode)))
1031     ;; (gnus-group-find-new-groups "???" nil)
1032     (gnus-group-save-newsrc "save")
1033     (gnus-group-describe-group "describe")
1034     (gnus-group-unsubscribe-current-group "gnus/toggle-subscription")
1035     (gnus-group-prev-unread-group "left-arrow")
1036     (gnus-group-next-unread-group "right-arrow")
1037     (gnus-group-exit "exit")
1038     (gmm-customize-mode "preferences" t :help "Edit mode preferences")
1039     (gnus-info-find-node "help"))
1040   "List of functions for the group tool bar (GNOME style).
1041
1042 See `gmm-tool-bar-from-list' for the format of the list."
1043   :type '(repeat gmm-tool-bar-item)
1044   :version "23.1" ;; No Gnus
1045   :initialize 'custom-initialize-default
1046   :set 'gnus-group-tool-bar-update
1047   :group 'gnus-group)
1048
1049 (defcustom gnus-group-tool-bar-retro
1050   '((gnus-group-get-new-news "gnus/get-news")
1051     (gnus-group-get-new-news-this-group "gnus/gnntg")
1052     (gnus-group-catchup-current "gnus/catchup")
1053     (gnus-group-describe-group "gnus/describe-group")
1054     (gnus-group-subscribe "gnus/subscribe" t
1055                           :help "Subscribe to the current group")
1056     (gnus-group-unsubscribe "gnus/unsubscribe" t
1057                             :help "Unsubscribe from the current group")
1058     (gnus-group-exit "gnus/exit-gnus" gnus-group-mode-map))
1059   "List of functions for the group tool bar (retro look).
1060
1061 See `gmm-tool-bar-from-list' for the format of the list."
1062   :type '(repeat gmm-tool-bar-item)
1063   :version "23.1" ;; No Gnus
1064   :initialize 'custom-initialize-default
1065   :set 'gnus-group-tool-bar-update
1066   :group 'gnus-group)
1067
1068 (defcustom gnus-group-tool-bar-zap-list t
1069   "List of icon items from the global tool bar.
1070 These items are not displayed in the Gnus group mode tool bar.
1071
1072 See `gmm-tool-bar-from-list' for the format of the list."
1073   :type 'gmm-tool-bar-zap-list
1074   :version "23.1" ;; No Gnus
1075   :initialize 'custom-initialize-default
1076   :set 'gnus-group-tool-bar-update
1077   :group 'gnus-group)
1078
1079 (defvar image-load-path)
1080 (defvar tool-bar-map)
1081
1082 (defun gnus-group-make-tool-bar (&optional force)
1083   "Make a group mode tool bar from `gnus-group-tool-bar'.
1084 When FORCE, rebuild the tool bar."
1085   (when (and (not (featurep 'xemacs))
1086              (boundp 'tool-bar-mode)
1087              tool-bar-mode
1088              ;; The Gnus 5.10.6 code checked (default-value 'tool-bar-mode).
1089              ;; Why?  --rsteib
1090              (or (not gnus-group-tool-bar-map) force))
1091     (let* ((load-path
1092             (gmm-image-load-path-for-library "gnus"
1093                                              "gnus/toggle-subscription.xpm"
1094                                              nil t))
1095            (image-load-path (cons (car load-path)
1096                                   (when (boundp 'image-load-path)
1097                                     image-load-path)))
1098            (map (gmm-tool-bar-from-list gnus-group-tool-bar
1099                                         gnus-group-tool-bar-zap-list
1100                                         'gnus-group-mode-map)))
1101       (if map
1102           (set (make-local-variable 'tool-bar-map) map))))
1103   gnus-group-tool-bar-map)
1104
1105 (defun gnus-group-mode ()
1106   "Major mode for reading news.
1107
1108 All normal editing commands are switched off.
1109 \\<gnus-group-mode-map>
1110 The group buffer lists (some of) the groups available.  For instance,
1111 `\\[gnus-group-list-groups]' will list all subscribed groups with unread articles, while `\\[gnus-group-list-zombies]'
1112 lists all zombie groups.
1113
1114 Groups that are displayed can be entered with `\\[gnus-group-read-group]'.  To subscribe
1115 to a group not displayed, type `\\[gnus-group-unsubscribe-group]'.
1116
1117 For more in-depth information on this mode, read the manual (`\\[gnus-info-find-node]').
1118
1119 The following commands are available:
1120
1121 \\{gnus-group-mode-map}"
1122   (interactive)
1123   (kill-all-local-variables)
1124   (when (gnus-visual-p 'group-menu 'menu)
1125     (gnus-group-make-menu-bar)
1126     (gnus-group-make-tool-bar))
1127   (gnus-simplify-mode-line)
1128   (setq major-mode 'gnus-group-mode)
1129   (setq mode-name "Group")
1130   (gnus-group-set-mode-line)
1131   (setq mode-line-process nil)
1132   (use-local-map gnus-group-mode-map)
1133   (buffer-disable-undo)
1134   (setq truncate-lines t)
1135   (setq buffer-read-only t
1136         show-trailing-whitespace nil)
1137   (gnus-set-default-directory)
1138   (gnus-update-format-specifications nil 'group 'group-mode)
1139   (gnus-update-group-mark-positions)
1140   (when gnus-use-undo
1141     (gnus-undo-mode 1))
1142   (when gnus-slave
1143     (gnus-slave-mode))
1144   (gnus-run-mode-hooks 'gnus-group-mode-hook))
1145
1146 (defun gnus-update-group-mark-positions ()
1147   (save-excursion
1148     (let ((gnus-process-mark ?\200)
1149           (gnus-group-update-hook nil)
1150           (gnus-group-marked '("dummy.group"))
1151           (gnus-active-hashtb (make-vector 10 0))
1152           (topic ""))
1153       (gnus-set-active "dummy.group" '(0 . 0))
1154       (gnus-set-work-buffer)
1155       (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil)
1156       (goto-char (point-min))
1157       (setq gnus-group-mark-positions
1158             (list (cons 'process (and (search-forward
1159                                        (mm-string-to-multibyte "\200") nil t)
1160                                       (- (point) (point-min) 1))))))))
1161
1162 (defun gnus-mouse-pick-group (e)
1163   "Enter the group under the mouse pointer."
1164   (interactive "e")
1165   (mouse-set-point e)
1166   (gnus-group-read-group nil))
1167
1168 ;; Look at LEVEL and find out what the level is really supposed to be.
1169 ;; If LEVEL is non-nil, LEVEL will be returned, if not, what happens
1170 ;; will depend on whether `gnus-group-use-permanent-levels' is used.
1171 (defun gnus-group-default-level (&optional level number-or-nil)
1172   (cond
1173    (gnus-group-use-permanent-levels
1174     (or (setq gnus-group-use-permanent-levels
1175               (or level (if (numberp gnus-group-use-permanent-levels)
1176                             gnus-group-use-permanent-levels
1177                           (or gnus-group-default-list-level
1178                               gnus-level-subscribed))))
1179         gnus-group-default-list-level gnus-level-subscribed))
1180    (number-or-nil
1181     level)
1182    (t
1183     (or level gnus-group-default-list-level gnus-level-subscribed))))
1184
1185 (defun gnus-group-setup-buffer ()
1186   (set-buffer (gnus-get-buffer-create gnus-group-buffer))
1187   (unless (eq major-mode 'gnus-group-mode)
1188     (gnus-group-mode)))
1189
1190 (defun gnus-group-name-charset (method group)
1191   (if (null method)
1192       (setq method (gnus-find-method-for-group group)))
1193   (let ((item (or (assoc method gnus-group-name-charset-method-alist)
1194                   (and (consp method)
1195                        (assoc (list (car method) (cadr method))
1196                               gnus-group-name-charset-method-alist))))
1197         (alist gnus-group-name-charset-group-alist)
1198         result)
1199     (if item
1200         (cdr item)
1201       (while (setq item (pop alist))
1202         (if (string-match (car item) group)
1203             (setq alist nil
1204                   result (cdr item))))
1205       result)))
1206
1207 (defun gnus-group-name-decode (string charset)
1208   ;; Fixme: Don't decode in unibyte mode.
1209   (if (and string charset (featurep 'mule))
1210       (mm-decode-coding-string string charset)
1211     string))
1212
1213 (defun gnus-group-decoded-name (string)
1214   (let ((charset (gnus-group-name-charset nil string)))
1215     (gnus-group-name-decode string charset)))
1216
1217 (defun gnus-group-list-groups (&optional level unread lowest)
1218   "List newsgroups with level LEVEL or lower that have unread articles.
1219 Default is all subscribed groups.
1220 If argument UNREAD is non-nil, groups with no unread articles are also
1221 listed.
1222
1223 Also see the `gnus-group-use-permanent-levels' variable."
1224   (interactive
1225    (list (if current-prefix-arg
1226              (prefix-numeric-value current-prefix-arg)
1227            (or
1228             (gnus-group-default-level nil t)
1229             gnus-group-default-list-level
1230             gnus-level-subscribed))))
1231   (unless level
1232     (setq level (car gnus-group-list-mode)
1233           unread (cdr gnus-group-list-mode)))
1234   (setq level (gnus-group-default-level level))
1235   (gnus-group-setup-buffer)
1236   (gnus-update-format-specifications nil 'group 'group-mode)
1237   (let ((case-fold-search nil)
1238         (props (text-properties-at (point-at-bol)))
1239         (empty (= (point-min) (point-max)))
1240         (group (gnus-group-group-name))
1241         number)
1242     (set-buffer gnus-group-buffer)
1243     (setq number (funcall gnus-group-prepare-function level unread lowest))
1244     (when (or (and (numberp number)
1245                    (zerop number))
1246               (zerop (buffer-size)))
1247       ;; No groups in the buffer.
1248       (gnus-message 5 "%s" gnus-no-groups-message))
1249     ;; We have some groups displayed.
1250     (goto-char (point-max))
1251     (when (or (not gnus-group-goto-next-group-function)
1252               (not (funcall gnus-group-goto-next-group-function
1253                             group props)))
1254       (cond
1255        (empty
1256         (goto-char (point-min)))
1257        ((not group)
1258         ;; Go to the first group with unread articles.
1259         (gnus-group-search-forward t))
1260        (t
1261         ;; Find the right group to put point on.  If the current group
1262         ;; has disappeared in the new listing, try to find the next
1263         ;; one.  If no next one can be found, just leave point at the
1264         ;; first newsgroup in the buffer.
1265         (when (not (gnus-goto-char
1266                     (text-property-any
1267                      (point-min) (point-max)
1268                      'gnus-group (gnus-intern-safe
1269                                   group gnus-active-hashtb))))
1270           (let ((newsrc (cdddr (gnus-group-entry group))))
1271             (while (and newsrc
1272                         (not (gnus-goto-char
1273                               (text-property-any
1274                                (point-min) (point-max) 'gnus-group
1275                                (gnus-intern-safe
1276                                 (caar newsrc) gnus-active-hashtb)))))
1277               (setq newsrc (cdr newsrc)))
1278             (unless newsrc
1279               (goto-char (point-max))
1280               (forward-line -1)))))))
1281     ;; Adjust cursor point.
1282     (gnus-group-position-point)))
1283
1284 (defun gnus-group-list-level (level &optional all)
1285   "List groups on LEVEL.
1286 If ALL (the prefix), also list groups that have no unread articles."
1287   (interactive "nList groups on level: \nP")
1288   (gnus-group-list-groups level all level))
1289
1290 (defun gnus-group-prepare-logic (group test)
1291   (or (and gnus-group-listed-groups
1292            (null gnus-group-list-option)
1293            (member group gnus-group-listed-groups))
1294       (cond
1295        ((null gnus-group-listed-groups) test)
1296        ((null gnus-group-list-option) test)
1297        (t (and (member group gnus-group-listed-groups)
1298                (if (eq gnus-group-list-option 'flush)
1299                    (not test)
1300                  test))))))
1301
1302 (defun gnus-group-prepare-flat (level &optional predicate lowest regexp)
1303   "List all newsgroups with unread articles of level LEVEL or lower.
1304 If PREDICATE is a function, list groups that the function returns non-nil;
1305 if it is t, list groups that have no unread articles.
1306 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher.
1307 If REGEXP is a function, list dead groups that the function returns non-nil;
1308 if it is a string, only list groups matching REGEXP."
1309   (set-buffer gnus-group-buffer)
1310   (let ((buffer-read-only nil)
1311         (newsrc (cdr gnus-newsrc-alist))
1312         (lowest (or lowest 1))
1313         (not-in-list (and gnus-group-listed-groups
1314                           (copy-sequence gnus-group-listed-groups)))
1315         info clevel unread group params)
1316     (erase-buffer)
1317     (when (or (< lowest gnus-level-zombie)
1318               gnus-group-listed-groups)
1319       ;; List living groups.
1320       (while newsrc
1321         (setq info (car newsrc)
1322               group (gnus-info-group info)
1323               params (gnus-info-params info)
1324               newsrc (cdr newsrc)
1325               unread (gnus-group-unread group))
1326         (when not-in-list
1327           (setq not-in-list (delete group not-in-list)))
1328         (when (gnus-group-prepare-logic
1329                group
1330                (and (or unread          ; This group might be unchecked
1331                         predicate)      ; Check if this group should be listed
1332                     (or (not (stringp regexp))
1333                         (string-match regexp group))
1334                     (<= (setq clevel (gnus-info-level info)) level)
1335                     (>= clevel lowest)
1336                     (cond
1337                      ((functionp predicate)
1338                       (funcall predicate info))
1339                      (predicate t)      ; We list all groups?
1340                      (t
1341                       (or
1342                        (if (eq unread t) ; Unactivated?
1343                            gnus-group-list-inactive-groups
1344                                         ; We list unactivated
1345                          (and (numberp unread) (> unread 0)))
1346                                         ; We list groups with unread articles
1347                        (and gnus-list-groups-with-ticked-articles
1348                             (cdr (assq 'tick (gnus-info-marks info))))
1349                                         ; And groups with tickeds
1350                        ;; Check for permanent visibility.
1351                        (and gnus-permanently-visible-groups
1352                             (string-match gnus-permanently-visible-groups
1353                                           group))
1354                        (memq 'visible params)
1355                        (cdr (assq 'visible params)))))))
1356           (gnus-group-insert-group-line
1357            group (gnus-info-level info)
1358            (gnus-info-marks info) unread (gnus-info-method info)))))
1359
1360     ;; List dead groups.
1361     (when (or gnus-group-listed-groups
1362               (and (>= level gnus-level-zombie)
1363                    (<= lowest gnus-level-zombie)))
1364       (gnus-group-prepare-flat-list-dead
1365        (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
1366        gnus-level-zombie ?Z
1367        regexp))
1368     (when not-in-list
1369       (dolist (group gnus-zombie-list)
1370         (setq not-in-list (delete group not-in-list))))
1371     (when (or gnus-group-listed-groups
1372               (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)))
1373       (gnus-group-prepare-flat-list-dead
1374        (gnus-union
1375         not-in-list
1376         (setq gnus-killed-list (sort gnus-killed-list 'string<)))
1377        gnus-level-killed ?K regexp))
1378
1379     (gnus-group-set-mode-line)
1380     (setq gnus-group-list-mode (cons level predicate))
1381     (gnus-run-hooks 'gnus-group-prepare-hook)
1382     t))
1383
1384 (defun gnus-group-prepare-flat-list-dead (groups level mark regexp)
1385   ;; List zombies and killed lists somewhat faster, which was
1386   ;; suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>.  It does
1387   ;; this by ignoring the group format specification altogether.
1388   (let (group)
1389     (if (> (length groups) gnus-group-listing-limit)
1390         (while groups
1391           (setq group (pop groups))
1392           (when (gnus-group-prepare-logic
1393                  group
1394                  (or (not regexp)
1395                      (and (stringp regexp) (string-match regexp group))
1396                      (and (functionp regexp) (funcall regexp group))))
1397             (gnus-add-text-properties
1398              (point) (prog1 (1+ (point))
1399                        (insert " " mark "     *: "
1400                                (gnus-group-decoded-name group)
1401                                "\n"))
1402              (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
1403                    'gnus-unread t
1404                    'gnus-level level))))
1405       (while groups
1406         (setq group (pop groups))
1407         (when (gnus-group-prepare-logic
1408                group
1409                (or (not regexp)
1410                    (and (stringp regexp) (string-match regexp group))
1411                    (and (functionp regexp) (funcall regexp group))))
1412           (gnus-group-insert-group-line
1413            group level nil
1414            (let ((active (gnus-active group)))
1415              (if active
1416                  (if (zerop (cdr active))
1417                      0
1418                    (- (1+ (cdr active)) (car active)))
1419                nil))
1420            (gnus-method-simplify (gnus-find-method-for-group group))))))))
1421
1422 (defun gnus-group-update-group-line ()
1423   "Update the current line in the group buffer."
1424   (let* ((buffer-read-only nil)
1425          (group (gnus-group-group-name))
1426          (entry (and group (gnus-group-entry group)))
1427          gnus-group-indentation)
1428     (when group
1429       (and entry
1430            (not (gnus-ephemeral-group-p group))
1431            (gnus-dribble-enter
1432             (concat "(gnus-group-set-info '"
1433                     (gnus-prin1-to-string (nth 2 entry))
1434                     ")")))
1435       (setq gnus-group-indentation (gnus-group-group-indentation))
1436       (gnus-delete-line)
1437       (gnus-group-insert-group-line-info group)
1438       (forward-line -1)
1439       (gnus-group-position-point))))
1440
1441 (defun gnus-group-insert-group-line-info (group)
1442   "Insert GROUP on the current line."
1443   (let ((entry (gnus-group-entry group))
1444         (gnus-group-indentation (gnus-group-group-indentation))
1445         active info)
1446     (if entry
1447         (progn
1448           ;; (Un)subscribed group.
1449           (setq info (nth 2 entry))
1450           (gnus-group-insert-group-line
1451            group (gnus-info-level info) (gnus-info-marks info)
1452            (or (car entry) t) (gnus-info-method info)))
1453       ;; This group is dead.
1454       (gnus-group-insert-group-line
1455        group
1456        (if (member group gnus-zombie-list) gnus-level-zombie gnus-level-killed)
1457        nil
1458        (if (setq active (gnus-active group))
1459            (if (zerop (cdr active))
1460                0
1461              (- (1+ (cdr active)) (car active)))
1462          nil)
1463        (gnus-method-simplify (gnus-find-method-for-group group))))))
1464
1465 (defun gnus-number-of-unseen-articles-in-group (group)
1466   (let* ((info (nth 2 (gnus-group-entry group)))
1467          (marked (gnus-info-marks info))
1468          (seen (cdr (assq 'seen marked)))
1469          (active (gnus-active group)))
1470     (if (not active)
1471         0
1472       (length (gnus-uncompress-range
1473                (gnus-range-difference
1474                 (gnus-range-difference (list active) (gnus-info-read info))
1475                 seen))))))
1476
1477 ;; Moving through the Group buffer (in topic mode) e.g. with C-n doesn't
1478 ;; update the state (enabled/disabled) of the icon `gnus-group-describe-group'
1479 ;; automatically.  After `C-l' the state is correct.  See the following report
1480 ;; on emacs-devel
1481 ;; <http://thread.gmane.org/v9acdmrcse.fsf@marauder.physik.uni-ulm.de>:
1482 ;; From: Reiner Steib
1483 ;; Subject: tool bar icons not updated according to :active condition
1484 ;; Newsgroups: gmane.emacs.devel
1485 ;; Date: Mon, 23 Jan 2006 19:59:13 +0100
1486 ;; Message-ID: <v9acdmrcse.fsf@marauder.physik.uni-ulm.de>
1487
1488 (defcustom gnus-group-update-tool-bar
1489   (and (not (featurep 'xemacs))
1490        (boundp 'tool-bar-mode)
1491        tool-bar-mode
1492        ;; Using `redraw-frame' (see `gnus-tool-bar-update') in Emacs might
1493        ;; be confusing, so maybe we shouldn't call it by default.
1494        (fboundp 'force-window-update))
1495   "Force updating the group buffer tool bar."
1496   :group 'gnus-group
1497   :version "22.1"
1498   :initialize 'custom-initialize-default
1499   :set (lambda (symbol value)
1500          (set-default symbol value)
1501          (when (gnus-alive-p)
1502            (with-current-buffer gnus-group-buffer
1503              ;; FIXME: Is there a better way to redraw the group buffer?
1504              (gnus-group-get-new-news 0))))
1505   :type 'boolean)
1506
1507 (defun gnus-group-insert-group-line (gnus-tmp-group gnus-tmp-level
1508                                                     gnus-tmp-marked number
1509                                                     gnus-tmp-method)
1510   "Insert a group line in the group buffer."
1511   (let* ((gnus-tmp-method
1512           (gnus-server-get-method gnus-tmp-group gnus-tmp-method))
1513          (group-name-charset (gnus-group-name-charset gnus-tmp-method
1514                                                       gnus-tmp-group))
1515          (gnus-tmp-active (gnus-active gnus-tmp-group))
1516          (gnus-tmp-number-total
1517           (if gnus-tmp-active
1518               (1+ (- (cdr gnus-tmp-active) (car gnus-tmp-active)))
1519             0))
1520          (gnus-tmp-number-of-unread
1521           (if (numberp number) (int-to-string (max 0 number))
1522             "*"))
1523          (gnus-tmp-number-of-read
1524           (if (numberp number)
1525               (int-to-string (max 0 (- gnus-tmp-number-total number)))
1526             "*"))
1527          (gnus-tmp-subscribed
1528           (cond ((<= gnus-tmp-level gnus-level-subscribed) ? )
1529                 ((<= gnus-tmp-level gnus-level-unsubscribed) ?U)
1530                 ((= gnus-tmp-level gnus-level-zombie) ?Z)
1531                 (t ?K)))
1532          (gnus-tmp-qualified-group
1533           (gnus-group-name-decode (gnus-group-real-name gnus-tmp-group)
1534                                   group-name-charset))
1535          (gnus-tmp-comment
1536           (or (gnus-group-get-parameter gnus-tmp-group 'comment t)
1537               gnus-tmp-group))
1538          (gnus-tmp-newsgroup-description
1539           (if gnus-description-hashtb
1540               (or (gnus-group-name-decode
1541                    (gnus-gethash gnus-tmp-group gnus-description-hashtb)
1542                    group-name-charset) "")
1543             ""))
1544          (gnus-tmp-moderated
1545           (if (and gnus-moderated-hashtb
1546                    (gnus-gethash gnus-tmp-group gnus-moderated-hashtb))
1547               ?m ? ))
1548          (gnus-tmp-moderated-string
1549           (if (eq gnus-tmp-moderated ?m) "(m)" ""))
1550          (gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-group))
1551          (gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
1552          (gnus-tmp-news-method (or (car gnus-tmp-method) ""))
1553          (gnus-tmp-news-method-string
1554           (if gnus-tmp-method
1555               (format "(%s:%s)" (car gnus-tmp-method)
1556                       (cadr gnus-tmp-method)) ""))
1557          (gnus-tmp-marked-mark
1558           (if (and (numberp number)
1559                    (zerop number)
1560                    (cdr (assq 'tick gnus-tmp-marked)))
1561               ?* ? ))
1562          (gnus-tmp-summary-live
1563           (if (and (not gnus-group-is-exiting-p)
1564                    (gnus-buffer-live-p (gnus-summary-buffer-name
1565                                         gnus-tmp-group)))
1566               ?* ? ))
1567          (gnus-tmp-process-marked
1568           (if (member gnus-tmp-group gnus-group-marked)
1569               gnus-process-mark ? ))
1570          (buffer-read-only nil)
1571          beg end
1572          header gnus-tmp-header)        ; passed as parameter to user-funcs.
1573     (beginning-of-line)
1574     (setq beg (point))
1575     (gnus-add-text-properties
1576      (point)
1577      (prog1 (1+ (point))
1578        ;; Insert the text.
1579        (let ((gnus-tmp-decoded-group (gnus-group-name-decode
1580                                       gnus-tmp-group group-name-charset)))
1581          (eval gnus-group-line-format-spec)))
1582      `(gnus-group ,(gnus-intern-safe gnus-tmp-group gnus-active-hashtb)
1583                   gnus-unread ,(if (numberp number)
1584                                    (string-to-number gnus-tmp-number-of-unread)
1585                                  t)
1586                   gnus-marked ,gnus-tmp-marked-mark
1587                   gnus-indentation ,gnus-group-indentation
1588                   gnus-level ,gnus-tmp-level))
1589     (setq end (point))
1590     (when gnus-group-update-tool-bar
1591       (gnus-put-text-property beg end 'point-entered
1592                               'gnus-tool-bar-update)
1593       (gnus-put-text-property beg end 'point-left
1594                               'gnus-tool-bar-update))
1595     (forward-line -1)
1596     (when (inline (gnus-visual-p 'group-highlight 'highlight))
1597       (gnus-group-highlight-line gnus-tmp-group beg end))
1598     (gnus-run-hooks 'gnus-group-update-hook)
1599     (forward-line)
1600     ;; Allow XEmacs to remove front-sticky text properties.
1601     (gnus-group-remove-excess-properties)))
1602
1603 (defun gnus-group-update-eval-form (group list)
1604   "Eval `car' of each element of LIST, and return the first that return t.
1605 Some value are bound so the form can use them."
1606   (when list
1607     (let* ((entry (gnus-group-entry group))
1608            (unread (if (numberp (car entry)) (car entry) 0))
1609            (active (gnus-active group))
1610            (total (if active (1+ (- (cdr active) (car active))) 0))
1611            (info (nth 2 entry))
1612            (method (inline (gnus-server-get-method group (gnus-info-method info))))
1613            (marked (gnus-info-marks info))
1614            (mailp (apply 'append
1615                          (mapcar
1616                           (lambda (x)
1617                             (memq x (assoc (symbol-name
1618                                             (car (or method gnus-select-method)))
1619                                            gnus-valid-select-methods)))
1620                           '(mail post-mail))))
1621            (level (or (gnus-info-level info) gnus-level-killed))
1622            (score (or (gnus-info-score info) 0))
1623            (ticked (gnus-range-length (cdr (assq 'tick marked))))
1624            (group-age (gnus-group-timestamp-delta group)))
1625       ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465
1626       ;; ======================================================================
1627       ;; From: Richard Stallman
1628       ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...])
1629       ;; Cc: ding@gnus.org
1630       ;; Date: Sat, 27 Oct 2007 19:41:20 -0400
1631       ;; Message-ID: <E1IlvHM-0006TS-7t@fencepost.gnu.org>
1632       ;;
1633       ;; [...]
1634       ;; The kludge is that the alist elements contain expressions that refer
1635       ;; to local variables with short names.  Perhaps write your own tiny
1636       ;; evaluator that handles just `and', `or', and numeric comparisons
1637       ;; and just a few specific variables.
1638       ;; ======================================================================
1639       ;;
1640       ;; Similar for other evaluated variables.  Grep for risky-local-variable
1641       ;; to find them!  -- rsteib
1642       ;;
1643       ;; Eval the cars of the lists until we find a match.
1644       (while (and list
1645                   (not (eval (caar list))))
1646         (setq list (cdr list)))
1647       list)))
1648
1649 (defun gnus-group-highlight-line (group beg end)
1650   "Highlight the current line according to `gnus-group-highlight'.
1651 GROUP is current group, and the line to highlight starts at BEG
1652 and ends at END."
1653   (let ((face (cdar (gnus-group-update-eval-form
1654                       group
1655                       gnus-group-highlight))))
1656     (unless (eq face (get-text-property beg 'face))
1657       (let ((inhibit-read-only t))
1658         (gnus-put-text-property-excluding-characters-with-faces
1659          beg end 'face
1660          (if (boundp face) (symbol-value face) face)))
1661       (gnus-extent-start-open beg))))
1662
1663 (defun gnus-group-get-icon (group)
1664   "Return an icon for GROUP according to `gnus-group-icon-list'."
1665   (if gnus-group-icon-list
1666       (let ((image-path
1667              (cdar (gnus-group-update-eval-form group gnus-group-icon-list))))
1668         (if image-path
1669             (propertize " "
1670                         'display
1671                         (append
1672                          (gnus-create-image (expand-file-name image-path))
1673                          '(:ascent center)))
1674           " "))
1675     " "))
1676
1677 (defun gnus-group-update-group (group &optional visible-only)
1678   "Update all lines where GROUP appear.
1679 If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't
1680 already."
1681   (with-current-buffer gnus-group-buffer
1682     (save-excursion
1683       ;; The buffer may be narrowed.
1684       (save-restriction
1685         (widen)
1686         (let ((ident (gnus-intern-safe group gnus-active-hashtb))
1687               (loc (point-min))
1688               found buffer-read-only)
1689           ;; Enter the current status into the dribble buffer.
1690           (let ((entry (gnus-group-entry group)))
1691             (when (and entry
1692                        (not (gnus-ephemeral-group-p group)))
1693               (gnus-dribble-enter
1694                (concat "(gnus-group-set-info '"
1695                        (gnus-prin1-to-string (nth 2 entry))
1696                        ")"))))
1697           ;; Find all group instances.  If topics are in use, each group
1698           ;; may be listed in more than once.
1699           (while (setq loc (text-property-any
1700                             loc (point-max) 'gnus-group ident))
1701             (setq found t)
1702             (goto-char loc)
1703             (let ((gnus-group-indentation (gnus-group-group-indentation)))
1704               (gnus-delete-line)
1705               (gnus-group-insert-group-line-info group)
1706               (save-excursion
1707                 (forward-line -1)
1708                 (gnus-run-hooks 'gnus-group-update-group-hook)))
1709             (setq loc (1+ loc)))
1710           (unless (or found visible-only)
1711             ;; No such line in the buffer, find out where it's supposed to
1712             ;; go, and insert it there (or at the end of the buffer).
1713             (if gnus-goto-missing-group-function
1714                 (funcall gnus-goto-missing-group-function group)
1715               (let ((entry (cddr (gnus-group-entry group))))
1716                 (while (and entry (car entry)
1717                             (not
1718                              (gnus-goto-char
1719                               (text-property-any
1720                                (point-min) (point-max)
1721                                'gnus-group (gnus-intern-safe
1722                                             (caar entry)
1723                                             gnus-active-hashtb)))))
1724                   (setq entry (cdr entry)))
1725                 (or entry (goto-char (point-max)))))
1726             ;; Finally insert the line.
1727             (let ((gnus-group-indentation (gnus-group-group-indentation)))
1728               (gnus-group-insert-group-line-info group)
1729               (save-excursion
1730                 (forward-line -1)
1731                 (gnus-run-hooks 'gnus-group-update-group-hook))))
1732           (when gnus-group-update-group-function
1733             (funcall gnus-group-update-group-function group))
1734           (gnus-group-set-mode-line))))))
1735
1736 (defun gnus-group-set-mode-line ()
1737   "Update the mode line in the group buffer."
1738   (when (memq 'group gnus-updated-mode-lines)
1739     ;; Yes, we want to keep this mode line updated.
1740     (with-current-buffer gnus-group-buffer
1741       (let* ((gformat (or gnus-group-mode-line-format-spec
1742                           (gnus-set-format 'group-mode)))
1743              (gnus-tmp-news-server (cadr gnus-select-method))
1744              (gnus-tmp-news-method (car gnus-select-method))
1745              (gnus-tmp-colon (if (equal gnus-tmp-news-server "") "" ":"))
1746              (max-len 60)
1747              gnus-tmp-header            ;Dummy binding for user-defined formats
1748              ;; Get the resulting string.
1749              (modified
1750               (and gnus-dribble-buffer
1751                    (buffer-name gnus-dribble-buffer)
1752                    (buffer-modified-p gnus-dribble-buffer)
1753                    (with-current-buffer gnus-dribble-buffer
1754                      (not (zerop (buffer-size))))))
1755              (mode-string (eval gformat)))
1756         ;; Say whether the dribble buffer has been modified.
1757         (setq mode-line-modified
1758               (if modified (car gnus-mode-line-modified)
1759                 (cdr gnus-mode-line-modified)))
1760         ;; If the line is too long, we chop it off.
1761         (when (> (length mode-string) max-len)
1762           (setq mode-string (substring mode-string 0 (- max-len 4))))
1763         (prog1
1764             (setq mode-line-buffer-identification
1765                   (gnus-mode-line-buffer-identification
1766                    (list mode-string)))
1767           (set-buffer-modified-p modified))))))
1768
1769 (defun gnus-group-group-name ()
1770   "Get the name of the newsgroup on the current line."
1771   (let ((group (get-text-property (point-at-bol) 'gnus-group)))
1772     (when group
1773       (symbol-name group))))
1774
1775 (defun gnus-group-group-level ()
1776   "Get the level of the newsgroup on the current line."
1777   (get-text-property (point-at-bol) 'gnus-level))
1778
1779 (defun gnus-group-group-indentation ()
1780   "Get the indentation of the newsgroup on the current line."
1781   (or (get-text-property (point-at-bol) 'gnus-indentation)
1782       (and gnus-group-indentation-function
1783            (funcall gnus-group-indentation-function))
1784       ""))
1785
1786 (defun gnus-group-group-unread ()
1787   "Get the number of unread articles of the newsgroup on the current line."
1788   (get-text-property (point-at-bol) 'gnus-unread))
1789
1790 (defun gnus-group-new-mail (group)
1791   (if (nnmail-new-mail-p (gnus-group-real-name group))
1792       gnus-new-mail-mark
1793     ? ))
1794
1795 (defun gnus-group-level (group)
1796   "Return the estimated level of GROUP."
1797   (or (gnus-info-level (gnus-get-info group))
1798       (and (member group gnus-zombie-list) gnus-level-zombie)
1799       gnus-level-killed))
1800
1801 (defun gnus-group-search-forward (&optional backward all level first-too)
1802   "Find the next newsgroup with unread articles.
1803 If BACKWARD is non-nil, find the previous newsgroup instead.
1804 If ALL is non-nil, just find any newsgroup.
1805 If LEVEL is non-nil, find group with level LEVEL, or higher if no such
1806 group exists.
1807 If FIRST-TOO, the current line is also eligible as a target."
1808   (let ((way (if backward -1 1))
1809         (low gnus-level-killed)
1810         (beg (point))
1811         pos found lev)
1812     (if (and backward (progn (beginning-of-line)) (bobp))
1813         nil
1814       (unless first-too
1815         (forward-line way))
1816       (while (and
1817               (not (eobp))
1818               (not (setq
1819                     found
1820                     (and
1821                      (get-text-property (point) 'gnus-group)
1822                      (or all
1823                          (and
1824                           (let ((unread
1825                                  (get-text-property (point) 'gnus-unread)))
1826                             (and (numberp unread) (> unread 0)))
1827                           (setq lev (get-text-property (point)
1828                                                        'gnus-level))
1829                           (<= lev gnus-level-subscribed)))
1830                      (or (not level)
1831                          (and (setq lev (get-text-property (point)
1832                                                            'gnus-level))
1833                               (or (= lev level)
1834                                   (and (< lev low)
1835                                        (< level lev)
1836                                        (progn
1837                                          (setq low lev)
1838                                          (setq pos (point))
1839                                          nil))))))))
1840               (zerop (forward-line way)))))
1841     (if found
1842         (progn (gnus-group-position-point) t)
1843       (goto-char (or pos beg))
1844       (and pos t))))
1845
1846 (defun gnus-total-fetched-for (group)
1847   (let* ((size-in-cache (or (gnus-cache-total-fetched-for group) 0))
1848          (size-in-agent (or (gnus-agent-total-fetched-for group) 0))
1849          (size (+ size-in-cache size-in-agent))
1850          (suffix '("B" "K" "M" "G"))
1851          (scale 1024.0)
1852          (cutoff scale))
1853     (while (> size cutoff)
1854       (setq size (/ size scale)
1855             suffix (cdr suffix)))
1856     (format "%5.1f%s" size (car suffix))))
1857
1858 ;;; Gnus group mode commands
1859
1860 ;; Group marking.
1861
1862 (defun gnus-group-mark-line-p ()
1863   (save-excursion
1864     (beginning-of-line)
1865     (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
1866     (eq (char-after) gnus-process-mark)))
1867
1868 (defun gnus-group-mark-group (n &optional unmark no-advance)
1869   "Mark the current group."
1870   (interactive "p")
1871   (let ((buffer-read-only nil)
1872         group)
1873     (while (and (> n 0)
1874                 (not (eobp)))
1875       (when (setq group (gnus-group-group-name))
1876         ;; Go to the mark position.
1877         (beginning-of-line)
1878         (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
1879         (delete-char 1)
1880         (if unmark
1881             (progn
1882               (setq gnus-group-marked (delete group gnus-group-marked))
1883               (insert-char ? 1 t))
1884            (setq gnus-group-marked
1885                  (cons group (delete group gnus-group-marked)))
1886            (insert-char gnus-process-mark 1 t)))
1887       (unless no-advance
1888         (gnus-group-next-group 1))
1889       (decf n))
1890     (gnus-group-position-point)
1891     n))
1892
1893 (defun gnus-group-unmark-group (n)
1894   "Remove the mark from the current group."
1895   (interactive "p")
1896   (gnus-group-mark-group n 'unmark)
1897   (gnus-group-position-point))
1898
1899 (defun gnus-group-unmark-all-groups ()
1900   "Unmark all groups."
1901   (interactive)
1902   (save-excursion
1903     (mapc 'gnus-group-remove-mark gnus-group-marked))
1904   (gnus-group-position-point))
1905
1906 (defun gnus-group-mark-region (unmark beg end)
1907   "Mark all groups between point and mark.
1908 If UNMARK, remove the mark instead."
1909   (interactive "P\nr")
1910   (let ((num (count-lines beg end)))
1911     (save-excursion
1912       (goto-char beg)
1913       (- num (gnus-group-mark-group num unmark)))))
1914
1915 (defun gnus-group-mark-buffer (&optional unmark)
1916   "Mark all groups in the buffer.
1917 If UNMARK, remove the mark instead."
1918   (interactive "P")
1919   (gnus-group-mark-region unmark (point-min) (point-max)))
1920
1921 (defun gnus-group-mark-regexp (regexp)
1922   "Mark all groups that match some regexp."
1923   (interactive "sMark (regexp): ")
1924   (let ((alist (cdr gnus-newsrc-alist))
1925         group)
1926     (save-excursion
1927       (while alist
1928         (when (string-match regexp (setq group (gnus-info-group (pop alist))))
1929           (gnus-group-jump-to-group group)
1930           (gnus-group-set-mark group)))))
1931   (gnus-group-position-point))
1932
1933 (defun gnus-group-remove-mark (group &optional test-marked)
1934   "Remove the process mark from GROUP and move point there.
1935 Return nil if the group isn't displayed."
1936   (if (gnus-group-goto-group group nil test-marked)
1937       (save-excursion
1938         (gnus-group-mark-group 1 'unmark t)
1939         t)
1940     (setq gnus-group-marked
1941           (delete group gnus-group-marked))
1942     nil))
1943
1944 (defun gnus-group-set-mark (group)
1945   "Set the process mark on GROUP."
1946   (if (gnus-group-goto-group group)
1947       (save-excursion
1948         (gnus-group-mark-group 1 nil t))
1949     (setq gnus-group-marked (cons group (delete group gnus-group-marked)))))
1950
1951 (defun gnus-group-universal-argument (arg &optional groups func)
1952   "Perform any command on all groups according to the process/prefix convention."
1953   (interactive "P")
1954   (if (eq (setq func (or func
1955                          (key-binding
1956                           (read-key-sequence
1957                            (substitute-command-keys
1958                             "\\<gnus-group-mode-map>\\[gnus-group-universal-argument]")))))
1959           'undefined)
1960       (gnus-error 1 "Undefined key")
1961     (gnus-group-iterate arg
1962       (lambda (group)
1963         (command-execute func))))
1964   (gnus-group-position-point))
1965
1966 (defun gnus-group-process-prefix (n)
1967   "Return a list of groups to work on.
1968 Take into consideration N (the prefix) and the list of marked groups."
1969   (cond
1970    (n
1971     (setq n (prefix-numeric-value n))
1972     ;; There is a prefix, so we return a list of the N next
1973     ;; groups.
1974     (let ((way (if (< n 0) -1 1))
1975           (n (abs n))
1976           group groups)
1977       (save-excursion
1978         (while (> n 0)
1979           (if (setq group (gnus-group-group-name))
1980               (push group groups))
1981           (setq n (1- n))
1982           (gnus-group-next-group way)))
1983       (nreverse groups)))
1984    ((and (gnus-region-active-p) (mark))
1985     ;; Work on the region between point and mark.
1986     (let ((max (max (point) (mark)))
1987           groups)
1988       (save-excursion
1989         (goto-char (min (point) (mark)))
1990         (while
1991             (and
1992              (push (gnus-group-group-name) groups)
1993              (zerop (gnus-group-next-group 1))
1994              (< (point) max)))
1995         (nreverse groups))))
1996    (gnus-group-marked
1997     ;; No prefix, but a list of marked articles.
1998     (reverse gnus-group-marked))
1999    (t
2000     ;; Neither marked articles or a prefix, so we return the
2001     ;; current group.
2002     (let ((group (gnus-group-group-name)))
2003       (and group (list group))))))
2004
2005 ;;; !!!Surely gnus-group-iterate should be a macro instead?  I can't
2006 ;;; imagine why I went through these contortions...
2007 (eval-and-compile
2008   (let ((function (make-symbol "gnus-group-iterate-function"))
2009         (window (make-symbol "gnus-group-iterate-window"))
2010         (groups (make-symbol "gnus-group-iterate-groups"))
2011         (group (make-symbol "gnus-group-iterate-group")))
2012     (eval
2013      `(defun gnus-group-iterate (arg ,function)
2014         "Iterate FUNCTION over all process/prefixed groups.
2015 FUNCTION will be called with the group name as the parameter
2016 and with point over the group in question."
2017         (let ((,groups (gnus-group-process-prefix arg))
2018               (,window (selected-window))
2019               ,group)
2020           (while ,groups
2021             (setq ,group (car ,groups)
2022                   ,groups (cdr ,groups))
2023             (select-window ,window)
2024             (gnus-group-remove-mark ,group)
2025             (save-selected-window
2026               (save-excursion
2027                 (funcall ,function ,group)))))))))
2028
2029 (put 'gnus-group-iterate 'lisp-indent-function 1)
2030
2031 ;; Selecting groups.
2032
2033 (defun gnus-group-read-group (&optional all no-article group select-articles)
2034   "Read news in this newsgroup.
2035 If the prefix argument ALL is non-nil, already read articles become
2036 readable.
2037
2038 If ALL is a positive number, fetch this number of the latest
2039 articles in the group.  If ALL is a negative number, fetch this
2040 number of the earliest articles in the group.
2041
2042 If the optional argument NO-ARTICLE is non-nil, no article will
2043 be auto-selected upon group entry.  If GROUP is non-nil, fetch
2044 that group."
2045   (interactive "P")
2046   (let ((no-display (eq all 0))
2047         (group (or group (gnus-group-group-name)))
2048         number active marked entry)
2049     (when (eq all 0)
2050       (setq all nil))
2051     (unless group
2052       (error "No group on current line"))
2053     (setq marked (gnus-info-marks
2054                   (nth 2 (setq entry (gnus-group-entry group)))))
2055     ;; This group might be a dead group.  In that case we have to get
2056     ;; the number of unread articles from `gnus-active-hashtb'.
2057     (setq number
2058           (cond ((numberp all) all)
2059                 (entry (car entry))
2060                 ((setq active (gnus-active group))
2061                  (- (1+ (cdr active)) (car active)))))
2062     (gnus-summary-read-group
2063      group (or all (and (numberp number)
2064                         (zerop (+ number (gnus-range-length
2065                                           (cdr (assq 'tick marked)))
2066                                   (gnus-range-length
2067                                    (cdr (assq 'dormant marked)))))))
2068      no-article nil no-display nil select-articles)))
2069
2070 (defun gnus-group-select-group (&optional all)
2071   "Select this newsgroup.
2072 No article is selected automatically.
2073 If the group is opened, just switch the summary buffer.
2074 If ALL is non-nil, already read articles become readable.
2075 If ALL is a positive number, fetch this number of the latest
2076 articles in the group.
2077 If ALL is a negative number, fetch this number of the earliest
2078 articles in the group."
2079   (interactive "P")
2080   (when (and (eobp) (not (gnus-group-group-name)))
2081     (forward-line -1))
2082   (gnus-group-read-group all t))
2083
2084 (defun gnus-group-quick-select-group (&optional all group)
2085   "Select the GROUP \"quickly\".
2086 This means that no highlighting or scoring will be performed.  If
2087 ALL (the prefix argument) is 0, don't even generate the summary
2088 buffer.  If GROUP is nil, use current group.
2089
2090 This might be useful if you want to toggle threading
2091 before entering the group."
2092   (interactive "P")
2093   (require 'gnus-score)
2094   (let (gnus-visual
2095         gnus-score-find-score-files-function
2096         gnus-home-score-file
2097         gnus-apply-kill-hook
2098         gnus-summary-expunge-below)
2099     (gnus-group-read-group all t group)))
2100
2101 (defun gnus-group-visible-select-group (&optional all)
2102   "Select the current group without hiding any articles."
2103   (interactive "P")
2104   (let ((gnus-inhibit-limiting t))
2105     (gnus-group-read-group all t)))
2106
2107 (defun gnus-group-select-group-ephemerally ()
2108   "Select the current group without doing any processing whatsoever.
2109 You will actually be entered into a group that's a copy of
2110 the current group; no changes you make while in this group will
2111 be permanent."
2112   (interactive)
2113   (require 'gnus-score)
2114   (let* (gnus-visual
2115          gnus-score-find-score-files-function gnus-apply-kill-hook
2116          gnus-summary-expunge-below gnus-show-threads gnus-suppress-duplicates
2117          gnus-summary-mode-hook gnus-select-group-hook
2118          (group (gnus-group-group-name))
2119          (method (gnus-find-method-for-group group)))
2120     (gnus-group-read-ephemeral-group
2121      (gnus-group-prefixed-name group method) method)))
2122
2123 (defun gnus-group-name-at-point ()
2124   "Return a group name from around point if it exists, or nil."
2125   (if (eq major-mode 'gnus-group-mode)
2126       (let ((group (gnus-group-group-name)))
2127         (when group
2128           (gnus-group-decoded-name group)))
2129     (let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\
2130 \\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\
2131 \[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\
2132 \\|[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)+\\)")
2133           (start (point))
2134           (case-fold-search nil))
2135       (prog1
2136           (if (or (and (not (or (eobp)
2137                                 (looking-at "[][\C-@-*,/;-@\\^`{-\C-?]")))
2138                        (prog1 t
2139                          (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?"
2140                                               (point-at-bol))))
2141                   (and (looking-at "[][\C-@-\t\v-*,/;-@\\^`{-\C-?]*$")
2142                        (prog1 t
2143                          (skip-chars-backward "][\C-@-\t\v-*,/;-@\\^`{-\C-?")
2144                          (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?"
2145                                               (point-at-bol))))
2146                   (string-match "\\`[][\C-@-\t\v-*,/;-@\\^`{-\C-?]*\\'"
2147                                 (buffer-substring (point-at-bol) (point))))
2148               (when (looking-at regexp)
2149                 (match-string 1))
2150             (let (group distance)
2151               (when (looking-at regexp)
2152                 (setq group (match-string 1)
2153                       distance (- (match-beginning 1) (match-beginning 0))))
2154               (skip-chars-backward "][\C-@-\t\v-*,/;-@\\^`{-\C-?")
2155               (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?"
2156                                    (point-at-bol))
2157               (if (looking-at regexp)
2158                   (if (and group (<= distance (- start (match-end 0))))
2159                       group
2160                     (match-string 1))
2161                 group)))
2162         (goto-char start)))))
2163
2164 (defun gnus-group-completing-read (&optional prompt collection
2165                                              require-match initial-input hist
2166                                              def)
2167   "Read a group name with completion.  Non-ASCII group names are allowed.
2168 The arguments are the same as `completing-read' except that COLLECTION
2169 and HIST default to `gnus-active-hashtb' and `gnus-group-history'
2170 respectively if they are omitted.  Regards COLLECTION as a hash table
2171 if it is not a list."
2172   (or collection (setq collection gnus-active-hashtb))
2173   (let (choices group)
2174     (if (listp collection)
2175         (dolist (symbol collection)
2176           (setq group (symbol-name symbol))
2177           (push (if (string-match "[^\000-\177]" group)
2178                     (gnus-group-decoded-name group)
2179                   group)
2180                 choices))
2181       (mapatoms (lambda (symbol)
2182                   (setq group (symbol-name symbol))
2183                   (push (if (string-match "[^\000-\177]" group)
2184                             (gnus-group-decoded-name group)
2185                           group)
2186                         choices))
2187                 collection))
2188     (setq group (gnus-completing-read (or prompt "Group") (nreverse choices)
2189                                       require-match initial-input
2190                                       (or hist 'gnus-group-history)
2191                                       def))
2192     (unless (if (listp collection)
2193                 (member group (mapcar 'symbol-name collection))
2194               (symbol-value (intern-soft group collection)))
2195       (setq group
2196             (mm-encode-coding-string
2197              group (gnus-group-name-charset nil group))))
2198     (replace-regexp-in-string "\n" "" group)))
2199
2200 ;;;###autoload
2201 (defun gnus-fetch-group (group &optional articles)
2202   "Start Gnus if necessary and enter GROUP.
2203 If ARTICLES, display those articles.
2204 Returns whether the fetching was successful or not."
2205   (interactive (list (gnus-group-completing-read nil
2206                                                  nil nil
2207                                                  (gnus-group-name-at-point))))
2208   (unless (gnus-alive-p)
2209     (gnus-no-server))
2210   (gnus-group-read-group (if articles nil t) nil group articles))
2211
2212 ;;;###autoload
2213 (defun gnus-fetch-group-other-frame (group)
2214   "Pop up a frame and enter GROUP."
2215   (interactive "P")
2216   (let ((window (get-buffer-window gnus-group-buffer)))
2217     (cond (window
2218            (select-frame (window-frame window)))
2219           ((= (length (frame-list)) 1)
2220            (select-frame (make-frame)))
2221           (t
2222            (other-frame 1))))
2223   (gnus-fetch-group group))
2224
2225 (defcustom gnus-large-ephemeral-newsgroup 200
2226   "The number of articles which indicates a large ephemeral newsgroup.
2227 Same as `gnus-large-newsgroup', but only used for ephemeral newsgroups.
2228
2229 If the number of articles in a newsgroup is greater than this value,
2230 confirmation is required for selecting the newsgroup.  If it is nil, no
2231 confirmation is required."
2232   :version "22.1"
2233   :group 'gnus-group-select
2234   :type '(choice (const :tag "No limit" nil)
2235                  integer))
2236
2237 (defcustom gnus-fetch-old-ephemeral-headers nil
2238   "Same as `gnus-fetch-old-headers', but only used for ephemeral newsgroups."
2239   :version "22.1"
2240   :group 'gnus-thread
2241   :type '(choice (const :tag "off" nil)
2242                  (const some)
2243                  number
2244                  (sexp :menu-tag "other" t)))
2245
2246 ;; Enter a group that is not in the group buffer.  Non-nil is returned
2247 ;; if selection was successful.
2248 (defun gnus-group-read-ephemeral-group (group method &optional activate
2249                                               quit-config request-only
2250                                               select-articles
2251                                               parameters
2252                                               number)
2253   "Read GROUP from METHOD as an ephemeral group.
2254 If ACTIVATE, request the group first.
2255 If QUIT-CONFIG, use that window configuration when exiting from the
2256 ephemeral group.
2257 If REQUEST-ONLY, don't actually read the group; just request it.
2258 If SELECT-ARTICLES, only select those articles.
2259 If PARAMETERS, use those as the group parameters.
2260 If NUMBER, fetch this number of articles.
2261
2262 Return the name of the group if selection was successful."
2263   (interactive
2264    (list
2265     ;; (gnus-read-group "Group name: ")
2266     (gnus-group-completing-read)
2267     (gnus-read-method "From method: ")))
2268   ;; Transform the select method into a unique server.
2269   (when (stringp method)
2270     (setq method (gnus-server-to-method method)))
2271   (setq method
2272         `(,(car method) ,(concat (cadr method) "-ephemeral")
2273           (,(intern (format "%s-address" (car method))) ,(cadr method))
2274           ,@(cddr method)))
2275   (let ((group (if (gnus-group-foreign-p group) group
2276                  (gnus-group-prefixed-name (gnus-group-real-name group)
2277                                            method))))
2278     (gnus-sethash
2279      group
2280      `(-1 nil (,group
2281                ,gnus-level-default-subscribed nil nil ,method
2282                ,(cons
2283                  (if quit-config
2284                      (cons 'quit-config quit-config)
2285                    (cons 'quit-config
2286                          (cons gnus-summary-buffer
2287                                gnus-current-window-configuration)))
2288                  parameters)))
2289      gnus-newsrc-hashtb)
2290     (push method gnus-ephemeral-servers)
2291     (set-buffer gnus-group-buffer)
2292     (unless (gnus-check-server method)
2293       (error "Unable to contact server: %s" (gnus-status-message method)))
2294     (when activate
2295       (gnus-activate-group group 'scan)
2296       (unless (gnus-request-group group)
2297         (error "Couldn't request group: %s"
2298                (nnheader-get-report (car method)))))
2299     (if request-only
2300         group
2301       (condition-case ()
2302           (when (let ((gnus-large-newsgroup gnus-large-ephemeral-newsgroup)
2303                       (gnus-fetch-old-headers
2304                        gnus-fetch-old-ephemeral-headers))
2305                   (gnus-group-read-group (or number t) t group select-articles))
2306             group)
2307         ;;(error nil)
2308         (quit
2309          (message "Quit reading the ephemeral group")
2310          nil)))))
2311
2312 (defcustom gnus-gmane-group-download-format
2313   "http://download.gmane.org/%s/%s/%s"
2314   "URL for downloading mbox files.
2315 It must contain three \"%s\".  They correspond to the group, the
2316 minimal and maximal article numbers, respectively."
2317   :group 'gnus-group-foreign
2318   :version "23.1" ;; No Gnus
2319   :type 'string)
2320
2321 (autoload 'url-insert-file-contents "url-handlers")
2322 ;; FIXME:
2323 ;; - Add documentation, menu, key bindings, ...
2324
2325 (defun gnus-read-ephemeral-gmane-group (group start &optional range)
2326   "Read articles from Gmane group GROUP as an ephemeral group.
2327 START is the first article.  RANGE specifies how many articles
2328 are fetched.  The articles are downloaded via HTTP using the URL
2329 specified by `gnus-gmane-group-download-format'."
2330   ;; See <http://gmane.org/export.php> for more information.
2331   (interactive
2332    (list
2333     (gnus-group-completing-read "Gmane group")
2334     (read-number "Start article number: ")
2335     (read-number "How many articles: ")))
2336   (unless range (setq range 500))
2337   (when (< range 1)
2338     (error "Invalid range: %s" range))
2339   (let ((tmpfile (mm-make-temp-file
2340                   (format "%s.start-%s.range-%s." group start range)))
2341         (gnus-thread-sort-functions '(gnus-thread-sort-by-number)))
2342     (with-temp-file tmpfile
2343       (url-insert-file-contents
2344        (format gnus-gmane-group-download-format
2345                group start (+ start range)))
2346       (write-region (point-min) (point-max) tmpfile)
2347       (gnus-group-read-ephemeral-group
2348        (format "%s.start-%s.range-%s" group start range)
2349        `(nndoc ,tmpfile
2350                (nndoc-article-type mbox))))
2351     (delete-file tmpfile)))
2352
2353 (defun gnus-read-ephemeral-gmane-group-url (url)
2354   "Create an ephemeral Gmane group from URL.
2355
2356 Valid input formats include:
2357 \"http://thread.gmane.org/gmane.foo.bar/12300/focus=12399\",
2358 \"http://thread.gmane.org/gmane.foo.bar/12345/\",
2359 \"http://article.gmane.org/gmane.foo.bar/12345/\",
2360 \"http://news.gmane.org/group/gmane.foo.bar/thread=12345\""
2361   ;; - Feel free to add other useful Gmane URLs here!  Maybe the URLs should
2362   ;;   be customizable?
2363   ;; - The URLs should be added to `gnus-button-alist'.  Probably we should
2364   ;;   prompt the user to decide: "View via `browse-url' or in Gnus? "
2365   ;;   (`gnus-read-ephemeral-gmane-group-url')
2366   (interactive
2367    (list (gnus-group-completing-read "Gmane URL")))
2368   (let (group start range)
2369     (cond
2370      ;; URLs providing `group', `start' and `range':
2371      ((string-match
2372        ;; http://thread.gmane.org/gmane.emacs.devel/86326/focus=86525
2373        "^http://thread\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)/focus=\\([0-9]+\\)$"
2374        url)
2375       (setq group (match-string 1 url)
2376             start (string-to-number (match-string 2 url))
2377             ;; Ensure that `range' is large enough to ensure focus article is
2378             ;; included.
2379             range (- (string-to-number (match-string 3 url))
2380                      start -1)))
2381      ;; URLs providing `group' and `start':
2382      ((or (string-match
2383            ;; http://article.gmane.org/gmane.comp.gnu.make.bugs/3584
2384            "^http://\\(?:thread\\|article\\|permalink\\)\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)"
2385            url)
2386           (string-match
2387            ;; Don't advertise these in the doc string yet:
2388            "^\\(?:nntp\\|news\\)://news\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)"
2389            url)
2390           (string-match
2391            ;; http://news.gmane.org/group/gmane.emacs.gnus.general/thread=65099/force_load=t
2392            "^http://news\.gmane\.org/group/\\([^/]+\\)/thread=\\([0-9]+\\)"
2393            url))
2394       (setq group (match-string 1 url)
2395             start (string-to-number (match-string 2 url))))
2396      (t
2397       (error "Can't parse URL %s" url)))
2398     (gnus-read-ephemeral-gmane-group group start range)))
2399
2400 (defcustom gnus-bug-group-download-format-alist
2401   '((emacs . "http://debbugs.gnu.org/%s;mbox=yes")
2402     (debian
2403      . "http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=%s&mbox=yes"))
2404   "Alist of symbols for bug trackers and the corresponding URL format string.
2405 The URL format string must contain a single \"%s\", specifying
2406 the bug number, and browsing the URL must return mbox output."
2407   :group 'gnus-group-foreign
2408   :version "23.2" ;; No Gnus
2409   :type '(repeat (cons (symbol) (string :tag "URL format string"))))
2410
2411 (defun gnus-read-ephemeral-bug-group (number mbox-url)
2412   "Browse bug NUMBER as ephemeral group."
2413   (interactive (list (read-string "Enter bug number: "
2414                                   (thing-at-point 'word) nil)
2415                      ;; FIXME: Add completing-read from
2416                      ;; `gnus-emacs-bug-group-download-format' ...
2417                      (cdr (assoc 'emacs gnus-bug-group-download-format-alist))))
2418   (when (stringp number)
2419     (setq number (string-to-number number)))
2420   (let ((tmpfile (mm-make-temp-file "gnus-temp-group-")))
2421     (with-temp-file tmpfile
2422       (url-insert-file-contents (format mbox-url number))
2423       (goto-char (point-min))
2424       ;; Add the debbugs address so that we can respond to reports easily.
2425       (while (re-search-forward "^To: " nil t)
2426         (end-of-line)
2427         (insert (format ", %s@%s" number
2428                         (replace-regexp-in-string
2429                          "/.*$" ""
2430                          (replace-regexp-in-string "^http://" "" mbox-url)))))
2431       (write-region (point-min) (point-max) tmpfile)
2432       (gnus-group-read-ephemeral-group
2433        "gnus-read-ephemeral-bug"
2434        `(nndoc ,tmpfile
2435                (nndoc-article-type mbox))))
2436     (delete-file tmpfile)))
2437
2438 (defun gnus-read-ephemeral-debian-bug-group (number)
2439   "Browse Debian bug NUMBER as ephemeral group."
2440   (interactive (list (read-string "Enter bug number: "
2441                                   (thing-at-point 'word) nil)))
2442   (gnus-read-ephemeral-bug-group
2443    number
2444    (cdr (assoc 'debian gnus-bug-group-download-format-alist))))
2445
2446 (defun gnus-read-ephemeral-emacs-bug-group (number)
2447   "Browse Emacs bug NUMBER as ephemeral group."
2448   (interactive (list (read-string "Enter bug number: "
2449                                   (thing-at-point 'word) nil)))
2450   (gnus-read-ephemeral-bug-group
2451    number
2452    (cdr (assoc 'emacs gnus-bug-group-download-format-alist))))
2453
2454 (defun gnus-group-jump-to-group (group &optional prompt)
2455   "Jump to newsgroup GROUP.
2456
2457 If PROMPT (the prefix) is a number, use the prompt specified in
2458 `gnus-group-jump-to-group-prompt'."
2459   (interactive
2460    (list (gnus-group-completing-read
2461           nil nil (gnus-read-active-file-p)
2462           (if current-prefix-arg
2463               (cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt))
2464             (or (and (stringp gnus-group-jump-to-group-prompt)
2465                      gnus-group-jump-to-group-prompt)
2466                 (let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt))))
2467                   (and (stringp p) p)))))))
2468
2469   (when (equal group "")
2470     (error "Empty group name"))
2471
2472   (unless (gnus-ephemeral-group-p group)
2473     ;; Either go to the line in the group buffer...
2474     (unless (gnus-group-goto-group group)
2475       ;; ... or insert the line.
2476       (gnus-group-update-group group)
2477       (gnus-group-goto-group group)))
2478   ;; Adjust cursor point.
2479   (gnus-group-position-point))
2480
2481 (defun gnus-group-goto-group (group &optional far test-marked)
2482   "Goto to newsgroup GROUP.
2483 If FAR, it is likely that the group is not on the current line.
2484 If TEST-MARKED, the line must be marked."
2485   (when group
2486     (beginning-of-line)
2487     (cond
2488      ;; It's quite likely that we are on the right line, so
2489      ;; we check the current line first.
2490      ((and (not far)
2491            (eq (get-text-property (point) 'gnus-group)
2492                (gnus-intern-safe group gnus-active-hashtb))
2493            (or (not test-marked) (gnus-group-mark-line-p)))
2494       (point))
2495      ;; Previous and next line are also likely, so we check them as well.
2496      ((and (not far)
2497            (save-excursion
2498              (forward-line -1)
2499              (and (eq (get-text-property (point) 'gnus-group)
2500                       (gnus-intern-safe group gnus-active-hashtb))
2501                   (or (not test-marked) (gnus-group-mark-line-p)))))
2502       (forward-line -1)
2503       (point))
2504      ((and (not far)
2505            (save-excursion
2506              (forward-line 1)
2507              (and (eq (get-text-property (point) 'gnus-group)
2508                       (gnus-intern-safe group gnus-active-hashtb))
2509                   (or (not test-marked) (gnus-group-mark-line-p)))))
2510       (forward-line 1)
2511       (point))
2512      (test-marked
2513       (goto-char (point-min))
2514       (let (found)
2515         (while (and (not found)
2516                     (gnus-goto-char
2517                      (text-property-any
2518                       (point) (point-max)
2519                       'gnus-group
2520                       (gnus-intern-safe group gnus-active-hashtb))))
2521           (if (gnus-group-mark-line-p)
2522               (setq found t)
2523             (forward-line 1)))
2524         found))
2525      (t
2526       ;; Search through the entire buffer.
2527       (gnus-goto-char
2528        (text-property-any
2529         (point-min) (point-max)
2530         'gnus-group (gnus-intern-safe group gnus-active-hashtb)))))))
2531
2532 (defun gnus-group-next-group (n &optional silent)
2533   "Go to next N'th newsgroup.
2534 If N is negative, search backward instead.
2535 Returns the difference between N and the number of skips actually
2536 done."
2537   (interactive "p")
2538   (gnus-group-next-unread-group n t nil silent))
2539
2540 (defun gnus-group-next-unread-group (n &optional all level silent)
2541   "Go to next N'th unread newsgroup.
2542 If N is negative, search backward instead.
2543 If ALL is non-nil, choose any newsgroup, unread or not.
2544 If LEVEL is non-nil, choose the next group with level LEVEL, or, if no
2545 such group can be found, the next group with a level higher than
2546 LEVEL.
2547 Returns the difference between N and the number of skips actually
2548 made."
2549   (interactive "p")
2550   (let ((backward (< n 0))
2551         (n (abs n)))
2552     (while (and (> n 0)
2553                 (gnus-group-search-forward
2554                  backward (or (not gnus-group-goto-unread) all) level))
2555       (setq n (1- n)))
2556     (when (and (/= 0 n)
2557                (not silent))
2558       (gnus-message 7 "No more%s newsgroups%s" (if all "" " unread")
2559                     (if level " on this level or higher" "")))
2560     n))
2561
2562 (defun gnus-group-prev-group (n)
2563   "Go to previous N'th newsgroup.
2564 Returns the difference between N and the number of skips actually
2565 done."
2566   (interactive "p")
2567   (gnus-group-next-unread-group (- n) t))
2568
2569 (defun gnus-group-prev-unread-group (n)
2570   "Go to previous N'th unread newsgroup.
2571 Returns the difference between N and the number of skips actually
2572 done."
2573   (interactive "p")
2574   (gnus-group-next-unread-group (- n)))
2575
2576 (defun gnus-group-next-unread-group-same-level (n)
2577   "Go to next N'th unread newsgroup on the same level.
2578 If N is negative, search backward instead.
2579 Returns the difference between N and the number of skips actually
2580 done."
2581   (interactive "p")
2582   (gnus-group-next-unread-group n t (gnus-group-group-level))
2583   (gnus-group-position-point))
2584
2585 (defun gnus-group-prev-unread-group-same-level (n)
2586   "Go to next N'th unread newsgroup on the same level.
2587 Returns the difference between N and the number of skips actually
2588 done."
2589   (interactive "p")
2590   (gnus-group-next-unread-group (- n) t (gnus-group-group-level))
2591   (gnus-group-position-point))
2592
2593 (defun gnus-group-best-unread-group (&optional exclude-group)
2594   "Go to the group with the highest level.
2595 If EXCLUDE-GROUP, do not go to that group."
2596   (interactive)
2597   (goto-char (point-min))
2598   (let ((best 100000)
2599         unread best-point)
2600     (while (not (eobp))
2601       (setq unread (get-text-property (point) 'gnus-unread))
2602       (when (and (numberp unread) (> unread 0))
2603         (when (and (get-text-property (point) 'gnus-level)
2604                    (< (get-text-property (point) 'gnus-level) best)
2605                    (or (not exclude-group)
2606                        (not (equal exclude-group (gnus-group-group-name)))))
2607           (setq best (get-text-property (point) 'gnus-level))
2608           (setq best-point (point))))
2609       (forward-line 1))
2610     (when best-point
2611       (goto-char best-point))
2612     (gnus-group-position-point)
2613     (and best-point (gnus-group-group-name))))
2614
2615 ;; Is there something like an after-point-motion-hook?
2616 ;; (inhibit-point-motion-hooks?).  Is there a tool-bar-update function?
2617
2618 ;; (defun gnus-group-menu-bar-update ()
2619 ;;   (let* ((buf (list (with-current-buffer gnus-group-buffer
2620 ;;                    (current-buffer))))
2621 ;;       (name (buffer-name (car buf))))
2622 ;;     (setcdr buf
2623 ;;          (if (> (length name) 27)
2624 ;;              (concat (substring name 0 12)
2625 ;;                      "..."
2626 ;;                      (substring name -12))
2627 ;;            name))
2628 ;;     (menu-bar-update-buffers-1 buf)))
2629
2630 ;; (defun gnus-group-position-point ()
2631 ;;   (gnus-goto-colon)
2632 ;;   (gnus-group-menu-bar-update))
2633
2634 (defun gnus-group-first-unread-group ()
2635   "Go to the first group with unread articles."
2636   (interactive)
2637   (prog1
2638       (let ((opoint (point))
2639             unread)
2640         (goto-char (point-min))
2641         (if (or (eq (setq unread (gnus-group-group-unread)) t) ; Not active.
2642                 (and (numberp unread)   ; Not a topic.
2643                      (not (zerop unread))) ; Has unread articles.
2644                 (zerop (gnus-group-next-unread-group 1))) ; Next unread group.
2645             (point)                     ; Success.
2646           (goto-char opoint)
2647           nil))                         ; Not success.
2648     (gnus-group-position-point)))
2649
2650 (defun gnus-group-enter-server-mode ()
2651   "Jump to the server buffer."
2652   (interactive)
2653   (gnus-enter-server-buffer))
2654
2655 (defun gnus-group-make-group-simple (&optional group)
2656   "Add a new newsgroup.
2657 The user will be prompted for GROUP."
2658   (interactive (list (gnus-group-completing-read)))
2659   (gnus-group-make-group (gnus-group-real-name group)
2660                          (gnus-group-server group)
2661                          nil nil t))
2662
2663 (defun gnus-group-make-group (name &optional method address args encoded)
2664   "Add a new newsgroup.
2665 The user will be prompted for a NAME, for a select METHOD, and an
2666 ADDRESS.  NAME should be a human-readable string (i.e., not be encoded
2667 even if it contains non-ASCII characters) unless ENCODED is non-nil.
2668
2669 If the backend supports it, the group will also be created on the
2670 server."
2671   (interactive
2672    (list
2673     (gnus-read-group "Group name: ")
2674     (gnus-read-method "From method: ")))
2675
2676   (when (stringp method)
2677     (setq method (or (gnus-server-to-method method) method)))
2678   (unless encoded
2679     (setq name (mm-encode-coding-string
2680                 name
2681                 (gnus-group-name-charset method name))))
2682   (let* ((meth (gnus-method-simplify
2683                 (when (and method
2684                            (not (gnus-server-equal method gnus-select-method)))
2685                   (if address (list (intern method) address)
2686                     method))))
2687          (nname (if method (gnus-group-prefixed-name name meth) name))
2688          backend info)
2689     (when (gnus-group-entry nname)
2690       (error "Group %s already exists" (gnus-group-decoded-name nname)))
2691     ;; Subscribe to the new group.
2692     (gnus-group-change-level
2693      (setq info (list t nname gnus-level-default-subscribed nil nil meth))
2694      gnus-level-default-subscribed gnus-level-killed
2695      (and (gnus-group-group-name)
2696           (gnus-group-entry (gnus-group-group-name)))
2697      t)
2698     ;; Make it active.
2699     (gnus-set-active nname (cons 1 0))
2700     (unless (gnus-ephemeral-group-p name)
2701       (gnus-dribble-enter
2702        (concat "(gnus-group-set-info '"
2703                (gnus-prin1-to-string (cdr info)) ")")))
2704     ;; Insert the line.
2705     (gnus-group-insert-group-line-info nname)
2706     (forward-line -1)
2707     (gnus-group-position-point)
2708
2709     ;; Load the back end and try to make the back end create
2710     ;; the group as well.
2711     (when (assoc (symbol-name (setq backend (car (gnus-server-get-method
2712                                                   nil meth))))
2713                  gnus-valid-select-methods)
2714       (require backend))
2715     (gnus-check-server meth)
2716     (when (gnus-check-backend-function 'request-create-group nname)
2717       (unless (gnus-request-create-group nname nil args)
2718         (error "Could not create group on server: %s"
2719                (nnheader-get-report backend))))
2720     t))
2721
2722 (defun gnus-group-delete-groups (&optional arg)
2723   "Delete the current group.  Only meaningful with editable groups."
2724   (interactive "P")
2725   (let ((n (length (gnus-group-process-prefix arg))))
2726     (when (gnus-yes-or-no-p
2727            (if (= n 1)
2728                "Delete this 1 group? "
2729              (format "Delete these %d groups? " n)))
2730       (gnus-group-iterate arg
2731         (lambda (group)
2732           (gnus-group-delete-group group nil t))))))
2733
2734 (defun gnus-group-delete-group (group &optional force no-prompt)
2735   "Delete the current group.  Only meaningful with editable groups.
2736 If FORCE (the prefix) is non-nil, all the articles in the group will
2737 be deleted.  This is \"deleted\" as in \"removed forever from the face
2738 of the Earth\".  There is no undo.  The user will be prompted before
2739 doing the deletion.
2740 Note that you also have to specify FORCE if you want the group to
2741 be removed from the server, even when it's empty."
2742   (interactive
2743    (list (gnus-group-group-name)
2744          current-prefix-arg))
2745   (unless group
2746     (error "No group to delete"))
2747   (unless (gnus-check-backend-function 'request-delete-group group)
2748     (error "This back end does not support group deletion"))
2749   (prog1
2750       (let ((group-decoded (gnus-group-decoded-name group)))
2751         (if (and (not no-prompt)
2752                  (not (gnus-yes-or-no-p
2753                        (format
2754                         "Do you really want to delete %s%s? "
2755                         group-decoded (if force " and all its contents" "")))))
2756             ()                          ; Whew!
2757           (gnus-message 6 "Deleting group %s..." group-decoded)
2758           (if (not (gnus-request-delete-group group force))
2759               (gnus-error 3 "Couldn't delete group %s" group-decoded)
2760             (gnus-message 6 "Deleting group %s...done" group-decoded)
2761             (gnus-group-goto-group group)
2762             (gnus-group-kill-group 1 t)
2763             (gnus-set-active group nil)
2764             t)))
2765     (gnus-group-position-point)))
2766
2767 (defun gnus-group-rename-group (group new-name)
2768   "Rename group from GROUP to NEW-NAME.
2769 When used interactively, GROUP is the group under point
2770 and NEW-NAME will be prompted for."
2771   (interactive
2772    (let ((group (gnus-group-group-name))
2773          method new-name)
2774      (unless (gnus-check-backend-function 'request-rename-group group)
2775        (error "This back end does not support renaming groups"))
2776      (setq new-name (gnus-read-group
2777                      "Rename group to: "
2778                      (gnus-group-real-name (gnus-group-decoded-name group)))
2779            method (gnus-info-method (gnus-get-info group)))
2780      (list group (mm-encode-coding-string
2781                   new-name
2782                   (gnus-group-name-charset
2783                    method
2784                    (gnus-group-prefixed-name new-name method))))))
2785
2786   (unless (gnus-check-backend-function 'request-rename-group group)
2787     (error "This back end does not support renaming groups"))
2788   (unless group
2789     (error "No group to rename"))
2790   (when (equal (gnus-group-real-name group) new-name)
2791     (error "Can't rename to the same name"))
2792
2793   ;; We find the proper prefixed name.
2794   (setq new-name
2795         (if (gnus-group-native-p group)
2796             ;; Native group.
2797             new-name
2798           ;; Foreign group.
2799           (gnus-group-prefixed-name
2800            (gnus-group-real-name new-name)
2801            (gnus-info-method (gnus-get-info group)))))
2802
2803   (let ((decoded-group (gnus-group-decoded-name group))
2804         (decoded-new-name (gnus-group-decoded-name new-name)))
2805     (when (gnus-active new-name)
2806       (error "The group %s already exists" decoded-new-name))
2807
2808     (gnus-message 6 "Renaming group %s to %s..."
2809                   decoded-group decoded-new-name)
2810     (prog1
2811         (if (progn
2812               (gnus-group-goto-group group)
2813               (not (when (< (gnus-group-group-level) gnus-level-zombie)
2814                      (gnus-request-rename-group group new-name))))
2815             (gnus-error 3 "Couldn't rename group %s to %s"
2816                         decoded-group decoded-new-name)
2817           ;; We rename the group internally by killing it...
2818           (gnus-group-kill-group)
2819           ;; ... changing its name ...
2820           (setcar (cdar gnus-list-of-killed-groups) new-name)
2821           ;; ... and then yanking it.  Magic!
2822           (gnus-group-yank-group)
2823           (gnus-set-active new-name (gnus-active group))
2824           (gnus-message 6 "Renaming group %s to %s...done"
2825                         decoded-group decoded-new-name)
2826           new-name)
2827       (setq gnus-killed-list (delete group gnus-killed-list))
2828       (gnus-set-active group nil)
2829       (gnus-dribble-touch)
2830       (gnus-group-position-point))))
2831
2832 (defun gnus-group-edit-group (group &optional part)
2833   "Edit the group on the current line."
2834   (interactive (list (gnus-group-group-name)))
2835   (let ((part (or part 'info))
2836         info)
2837     (unless group
2838       (error "No group on current line"))
2839     (unless (setq info (gnus-get-info group))
2840       (error "Killed group; can't be edited"))
2841     (ignore-errors
2842       (gnus-close-group group))
2843     (gnus-edit-form
2844      ;; Find the proper form to edit.
2845      (cond ((eq part 'method)
2846             (or (gnus-info-method info) "native"))
2847            ((eq part 'params)
2848             (gnus-info-params info))
2849            (t info))
2850      ;; The proper documentation.
2851      (format
2852       "Editing the %s for `%s'."
2853       (cond
2854        ((eq part 'method) "select method")
2855        ((eq part 'params) "group parameters")
2856        (t "group info"))
2857       (gnus-group-decoded-name group))
2858      `(lambda (form)
2859         (gnus-group-edit-group-done ',part ,group form)))
2860     (local-set-key
2861      "\C-c\C-i"
2862      (gnus-create-info-command
2863       (cond
2864        ((eq part 'method)
2865         "(gnus)Select Methods")
2866        ((eq part 'params)
2867         "(gnus)Group Parameters")
2868        (t
2869         "(gnus)Group Info"))))))
2870
2871 (defun gnus-group-edit-group-method (group)
2872   "Edit the select method of GROUP."
2873   (interactive (list (gnus-group-group-name)))
2874   (gnus-group-edit-group group 'method))
2875
2876 (defun gnus-group-edit-group-parameters (group)
2877   "Edit the group parameters of GROUP."
2878   (interactive (list (gnus-group-group-name)))
2879   (gnus-group-edit-group group 'params))
2880
2881 (defun gnus-group-edit-group-done (part group form)
2882   "Update variables."
2883   (let* ((method (cond ((eq part 'info) (nth 4 form))
2884                        ((eq part 'method) form)
2885                        (t nil)))
2886          (info (cond ((eq part 'info) form)
2887                      ((eq part 'method) (gnus-get-info group))
2888                      (t nil)))
2889          (new-group (if info
2890                         (if (or (not method)
2891                                 (gnus-server-equal
2892                                  gnus-select-method method))
2893                             (gnus-group-real-name (car info))
2894                           (gnus-group-prefixed-name
2895                            (gnus-group-real-name (car info)) method))
2896                       nil)))
2897     (when (and new-group
2898                (not (equal new-group group)))
2899       (when (gnus-group-goto-group group)
2900         (gnus-group-kill-group 1))
2901       (gnus-activate-group new-group))
2902     ;; Set the info.
2903     (if (not (and info new-group))
2904         (gnus-group-set-info form (or new-group group) part)
2905       (setq info (gnus-copy-sequence info))
2906       (setcar info new-group)
2907       (unless (gnus-server-equal method "native")
2908         (unless (nthcdr 3 info)
2909           (nconc info (list nil nil)))
2910         (unless (nthcdr 4 info)
2911           (nconc info (list nil)))
2912         (gnus-info-set-method info method))
2913       (gnus-group-set-info info))
2914     (gnus-group-update-group (or new-group group))
2915     (gnus-group-position-point)))
2916
2917 (defun gnus-group-make-useful-group (group method)
2918   "Create one of the groups described in `gnus-useful-groups'."
2919   (interactive
2920    (let ((entry (assoc (gnus-completing-read "Create group"
2921                                              (mapcar 'car gnus-useful-groups)
2922                                              t)
2923                        gnus-useful-groups)))
2924      (list (cadr entry)
2925            ;; Don't use `caddr' here since macros within the `interactive'
2926            ;; form won't be expanded.
2927            (car (cddr entry)))))
2928   (setq method (gnus-copy-sequence method))
2929   (let (entry)
2930     (while (setq entry (memq (assq 'eval method) method))
2931       (setcar entry (eval (cadar entry)))))
2932   (gnus-group-make-group group method))
2933
2934 (defun gnus-group-make-help-group (&optional noerror)
2935   "Create the Gnus documentation group.
2936 Optional argument NOERROR modifies the behavior of this function when the
2937 group already exists:
2938 - if not given, and error is signaled,
2939 - if t, stay silent,
2940 - if anything else, just print a message."
2941   (interactive)
2942   (let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help")))
2943         (file (nnheader-find-etc-directory "gnus-tut.txt" t)))
2944     (if (gnus-group-entry name)
2945         (cond ((eq noerror nil)
2946                (error "Documentation group already exists"))
2947               ((eq noerror t)
2948                ;; stay silent
2949                )
2950               (t
2951                (gnus-message 1 "Documentation group already exists")))
2952       ;; else:
2953       (if (not file)
2954           (gnus-message 1 "Couldn't find doc group")
2955         (gnus-group-make-group
2956          (gnus-group-real-name name)
2957          (list 'nndoc "gnus-help"
2958                (list 'nndoc-address file)
2959                (list 'nndoc-article-type 'mbox))))
2960       ))
2961   (gnus-group-position-point))
2962
2963 (defun gnus-group-make-doc-group (file type)
2964   "Create a group that uses a single file as the source.
2965
2966 If called with a prefix argument, ask for the file type."
2967   (interactive
2968    (list (read-file-name "File name: ")
2969          (and current-prefix-arg 'ask)))
2970   (when (eq type 'ask)
2971     (let ((err "")
2972           char found)
2973       (while (not found)
2974         (message
2975          "%sFile type (mbox, babyl, digest, forward, mmdf, guess) [m, b, d, f, a, g]: "
2976          err)
2977         (setq found (cond ((= (setq char (read-char)) ?m) 'mbox)
2978                           ((= char ?b) 'babyl)
2979                           ((= char ?d) 'digest)
2980                           ((= char ?f) 'forward)
2981                           ((= char ?a) 'mmfd)
2982                           ((= char ?g) 'guess)
2983                           (t (setq err (format "%c unknown. " char))
2984                              nil))))
2985       (setq type found)))
2986   (setq file (expand-file-name file))
2987   (let* ((name (gnus-generate-new-group-name
2988                 (gnus-group-prefixed-name
2989                  (file-name-nondirectory file) '(nndoc ""))))
2990          (method (list 'nndoc file
2991                        (list 'nndoc-address file)
2992                        (list 'nndoc-article-type (or type 'guess))))
2993          (coding (gnus-group-name-charset method name)))
2994     (setcar (cdr method) (mm-encode-coding-string file coding))
2995     (gnus-group-make-group
2996      (mm-encode-coding-string (gnus-group-real-name name) coding)
2997      method nil nil t)))
2998
2999 (defvar nnweb-type-definition)
3000 (defvar gnus-group-web-type-history nil)
3001 (defvar gnus-group-web-search-history nil)
3002 (defun gnus-group-make-web-group (&optional solid)
3003   "Create an ephemeral nnweb group.
3004 If SOLID (the prefix), create a solid group."
3005   (interactive "P")
3006   (require 'nnweb)
3007   (let* ((group
3008           (if solid (gnus-read-group "Group name: ")
3009             (message-unique-id)))
3010          (default-type (or (car gnus-group-web-type-history)
3011                            (symbol-name (caar nnweb-type-definition))))
3012          (type
3013           (gnus-string-or
3014            (gnus-completing-read
3015             "Search engine type"
3016             (mapcar (lambda (elem) (symbol-name (car elem)))
3017                     nnweb-type-definition)
3018             t nil 'gnus-group-web-type-history)
3019            default-type))
3020          (search
3021           (read-string
3022            "Search string: "
3023            (cons (or (car gnus-group-web-search-history) "") 0)
3024            'gnus-group-web-search-history))
3025          (method
3026           `(nnweb ,group (nnweb-search ,search)
3027                   (nnweb-type ,(intern type))
3028                   (nnweb-ephemeral-p t))))
3029     (if solid
3030         (progn
3031           (gnus-alist-pull 'nnweb-ephemeral-p method)
3032           (gnus-group-make-group group method))
3033       (gnus-group-read-ephemeral-group
3034        group method t
3035        (cons (current-buffer)
3036              (if (eq major-mode 'gnus-summary-mode) 'summary 'group))))))
3037
3038 (defvar nnrss-group-alist)
3039 (eval-when-compile
3040   (defun nnrss-discover-feed (arg))
3041   (defun nnrss-save-server-data (arg)))
3042 (defun gnus-group-make-rss-group (&optional url)
3043   "Given a URL, discover if there is an RSS feed.
3044 If there is, use Gnus to create an nnrss group"
3045   (interactive)
3046   (require 'nnrss)
3047   (if (not url)
3048       (setq url (read-from-minibuffer "URL to Search for RSS: ")))
3049   (let ((feedinfo (nnrss-discover-feed url)))
3050     (if feedinfo
3051         (let* ((title (gnus-newsgroup-savable-name
3052                        (read-from-minibuffer "Title: "
3053                                              (gnus-newsgroup-savable-name
3054                                               (mapconcat
3055                                                'identity
3056                                                (split-string
3057                                                 (or (cdr (assoc 'title
3058                                                                 feedinfo))
3059                                                     ""))
3060                                                " ")))))
3061                (desc  (read-from-minibuffer "Description: "
3062                                             (mapconcat
3063                                              'identity
3064                                              (split-string
3065                                               (or (cdr (assoc 'description
3066                                                               feedinfo))
3067                                                   ""))
3068                                              " ")))
3069                (href (cdr (assoc 'href feedinfo)))
3070                (coding (gnus-group-name-charset '(nnrss "") title)))
3071           (when coding
3072             ;; Unify non-ASCII text.
3073             (setq title (mm-decode-coding-string
3074                          (mm-encode-coding-string title coding)
3075                          coding)))
3076           (gnus-group-make-group title '(nnrss ""))
3077           (push (list title href desc) nnrss-group-alist)
3078           (nnrss-save-server-data nil))
3079       (error "No feeds found for %s" url))))
3080
3081 (defun gnus-group-make-directory-group (dir)
3082   "Create an nndir group.
3083 The user will be prompted for a directory.  The contents of this
3084 directory will be used as a newsgroup.  The directory should contain
3085 mail messages or news articles in files that have numeric names."
3086   (interactive
3087    (list (read-file-name "Create group from directory: ")))
3088   (unless (file-exists-p dir)
3089     (error "No such directory"))
3090   (unless (file-directory-p dir)
3091     (error "Not a directory"))
3092   (let ((ext "")
3093         (i 0)
3094         group)
3095     (while (or (not group) (gnus-group-entry group))
3096       (setq group
3097             (gnus-group-prefixed-name
3098              (expand-file-name ext dir)
3099              '(nndir "")))
3100       (setq ext (format "<%d>" (setq i (1+ i)))))
3101     (gnus-group-make-group
3102      (gnus-group-real-name group)
3103      (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir)))))
3104
3105 (defun gnus-group-add-to-virtual (n vgroup)
3106   "Add the current group to a virtual group."
3107   (interactive
3108    (list current-prefix-arg
3109          (gnus-group-completing-read "Add to virtual group"
3110                                      nil t "nnvirtual:")))
3111   (unless (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual)
3112     (error "%s is not an nnvirtual group" vgroup))
3113   (gnus-close-group vgroup)
3114   (let* ((groups (gnus-group-process-prefix n))
3115          (method (gnus-info-method (gnus-get-info vgroup))))
3116     (setcar (cdr method)
3117             (concat
3118              (nth 1 method) "\\|"
3119              (mapconcat
3120               (lambda (s)
3121                 (gnus-group-remove-mark s)
3122                 (concat "\\(^" (regexp-quote s) "$\\)"))
3123               groups "\\|"))))
3124   (gnus-group-position-point))
3125
3126 (defun gnus-group-make-empty-virtual (group)
3127   "Create a new, fresh, empty virtual group."
3128   (interactive "sCreate new, empty virtual group: ")
3129   (let* ((method (list 'nnvirtual "^$"))
3130          (pgroup (gnus-group-prefixed-name group method)))
3131     ;; Check whether it exists already.
3132     (when (gnus-group-entry pgroup)
3133       (error "Group %s already exists" pgroup))
3134     ;; Subscribe the new group after the group on the current line.
3135     (gnus-subscribe-group pgroup (gnus-group-group-name) method)
3136     (gnus-group-update-group pgroup)
3137     (forward-line -1)
3138     (gnus-group-position-point)))
3139
3140 (defun gnus-group-enter-directory (dir)
3141   "Enter an ephemeral nneething group."
3142   (interactive "DDirectory to read: ")
3143   (let* ((method (list 'nneething dir '(nneething-read-only t)))
3144          (leaf (gnus-group-prefixed-name
3145                 (file-name-nondirectory (directory-file-name dir))
3146                 method))
3147          (name (gnus-generate-new-group-name leaf)))
3148     (unless (gnus-group-read-ephemeral-group
3149              name method t
3150              (cons (current-buffer)
3151                    (if (eq major-mode 'gnus-summary-mode)
3152                        'summary 'group)))
3153       (error "Couldn't enter %s" dir))))
3154
3155 (defun gnus-group-expunge-group (group)
3156   "Expunge deleted articles in current nnimap GROUP."
3157   (interactive (list (gnus-group-group-name)))
3158   (let ((method (gnus-find-method-for-group group)))
3159     (if (not (gnus-check-backend-function
3160               'request-expunge-group (car method)))
3161         (error "%s does not support expunging" (car method))
3162       (gnus-request-expunge-group group method))))
3163
3164 (autoload 'nnimap-acl-get "nnimap")
3165 (autoload 'nnimap-acl-edit "nnimap")
3166
3167 (defun gnus-group-nnimap-edit-acl (group)
3168   "Edit the Access Control List of current nnimap GROUP."
3169   (interactive (list (gnus-group-group-name)))
3170   (let ((mailbox (gnus-group-real-name group)) method acl)
3171     (unless group
3172       (error "No group on current line"))
3173     (unless (gnus-get-info group)
3174       (error "Killed group; can't be edited"))
3175     (unless (eq (car (setq method (gnus-find-method-for-group group))) 'nnimap)
3176       (error "%s is not an nnimap group" group))
3177     (unless (setq acl (nnimap-acl-get mailbox (cadr method)))
3178       (error "Server does not support ACL's"))
3179     (gnus-edit-form acl (format "Editing the access control list for `%s'.
3180
3181    An access control list is a list of (identifier . rights) elements.
3182
3183    The identifier string specifies the corresponding user.  The
3184    identifier \"anyone\" is reserved to refer to the universal identity.
3185
3186    Rights is a string listing a (possibly empty) set of alphanumeric
3187    characters, each character listing a set of operations which is being
3188    controlled.  Letters are reserved for ``standard'' rights, listed
3189    below.  Digits are reserved for implementation or site defined rights.
3190
3191    l - lookup (mailbox is visible to LIST/LSUB commands)
3192    r - read (SELECT the mailbox, perform CHECK, FETCH, PARTIAL,
3193        SEARCH, COPY from mailbox)
3194    s - keep seen/unseen information across sessions (STORE \\SEEN flag)
3195    w - write (STORE flags other than \\SEEN and \\DELETED)
3196    i - insert (perform APPEND, COPY into mailbox)
3197    p - post (send mail to submission address for mailbox,
3198        not enforced by IMAP4 itself)
3199    c - create and delete mailbox (CREATE new sub-mailboxes in any
3200        implementation-defined hierarchy, RENAME or DELETE mailbox)
3201    d - delete messages (STORE \\DELETED flag, perform EXPUNGE)
3202    a - administer (perform SETACL)" group)
3203                     `(lambda (form)
3204                        (nnimap-acl-edit
3205                         ,mailbox ',method ',acl form)))))
3206
3207 ;; Group sorting commands
3208 ;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>.
3209
3210 (defun gnus-group-sort-groups (func &optional reverse)
3211   "Sort the group buffer according to FUNC.
3212 When used interactively, the sorting function used will be
3213 determined by the `gnus-group-sort-function' variable.
3214 If REVERSE (the prefix), reverse the sorting order."
3215   (interactive (list gnus-group-sort-function current-prefix-arg))
3216   (funcall gnus-group-sort-alist-function
3217            (gnus-make-sort-function func) reverse)
3218   (gnus-group-unmark-all-groups)
3219   (gnus-group-list-groups)
3220   (gnus-dribble-touch))
3221
3222 (defun gnus-group-sort-flat (func reverse)
3223   ;; We peel off the dummy group from the alist.
3224   (when func
3225     (when (equal (gnus-info-group (car gnus-newsrc-alist)) "dummy.group")
3226       (pop gnus-newsrc-alist))
3227     ;; Do the sorting.
3228     (setq gnus-newsrc-alist
3229           (sort gnus-newsrc-alist func))
3230     (when reverse
3231       (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist)))
3232     ;; Regenerate the hash table.
3233     (gnus-make-hashtable-from-newsrc-alist)))
3234
3235 (defun gnus-group-sort-groups-by-alphabet (&optional reverse)
3236   "Sort the group buffer alphabetically by group name.
3237 If REVERSE, sort in reverse order."
3238   (interactive "P")
3239   (gnus-group-sort-groups 'gnus-group-sort-by-alphabet reverse))
3240
3241 (defun gnus-group-sort-groups-by-real-name (&optional reverse)
3242   "Sort the group buffer alphabetically by real (unprefixed) group name.
3243 If REVERSE, sort in reverse order."
3244   (interactive "P")
3245   (gnus-group-sort-groups 'gnus-group-sort-by-real-name reverse))
3246
3247 (defun gnus-group-sort-groups-by-unread (&optional reverse)
3248   "Sort the group buffer by number of unread articles.
3249 If REVERSE, sort in reverse order."
3250   (interactive "P")
3251   (gnus-group-sort-groups 'gnus-group-sort-by-unread reverse))
3252
3253 (defun gnus-group-sort-groups-by-level (&optional reverse)
3254   "Sort the group buffer by group level.
3255 If REVERSE, sort in reverse order."
3256   (interactive "P")
3257   (gnus-group-sort-groups 'gnus-group-sort-by-level reverse))
3258
3259 (defun gnus-group-sort-groups-by-score (&optional reverse)
3260   "Sort the group buffer by group score.
3261 If REVERSE, sort in reverse order."
3262   (interactive "P")
3263   (gnus-group-sort-groups 'gnus-group-sort-by-score reverse))
3264
3265 (defun gnus-group-sort-groups-by-rank (&optional reverse)
3266   "Sort the group buffer by group rank.
3267 If REVERSE, sort in reverse order."
3268   (interactive "P")
3269   (gnus-group-sort-groups 'gnus-group-sort-by-rank reverse))
3270
3271 (defun gnus-group-sort-groups-by-method (&optional reverse)
3272   "Sort the group buffer alphabetically by back end name.
3273 If REVERSE, sort in reverse order."
3274   (interactive "P")
3275   (gnus-group-sort-groups 'gnus-group-sort-by-method reverse))
3276
3277 (defun gnus-group-sort-groups-by-server (&optional reverse)
3278   "Sort the group buffer alphabetically by server name.
3279 If REVERSE, sort in reverse order."
3280   (interactive "P")
3281   (gnus-group-sort-groups 'gnus-group-sort-by-server reverse))
3282
3283 ;;; Selected group sorting.
3284
3285 (defun gnus-group-sort-selected-groups (n func &optional reverse)
3286   "Sort the process/prefixed groups."
3287   (interactive (list current-prefix-arg gnus-group-sort-function))
3288   (let ((groups (gnus-group-process-prefix n)))
3289     (funcall gnus-group-sort-selected-function
3290              groups (gnus-make-sort-function func) reverse)
3291     (gnus-group-unmark-all-groups)
3292     (gnus-group-list-groups)
3293     (gnus-dribble-touch)))
3294
3295 (defun gnus-group-sort-selected-flat (groups func reverse)
3296   (let (entries infos)
3297     ;; First find all the group entries for these groups.
3298     (while groups
3299       (push (nthcdr 2 (gnus-group-entry (pop groups)))
3300             entries))
3301     ;; Then sort the infos.
3302     (setq infos
3303           (sort
3304            (mapcar
3305             (lambda (entry) (car entry))
3306             (setq entries (nreverse entries)))
3307            func))
3308     (when reverse
3309       (setq infos (nreverse infos)))
3310     ;; Go through all the infos and replace the old entries
3311     ;; with the new infos.
3312     (while infos
3313       (setcar (car entries) (pop infos))
3314       (pop entries))
3315     ;; Update the hashtable.
3316     (gnus-make-hashtable-from-newsrc-alist)))
3317
3318 (defun gnus-group-sort-selected-groups-by-alphabet (&optional n reverse)
3319   "Sort the group buffer alphabetically by group name.
3320 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3321 sort in reverse order."
3322   (interactive (gnus-interactive "P\ny"))
3323   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-alphabet reverse))
3324
3325 (defun gnus-group-sort-selected-groups-by-real-name (&optional n reverse)
3326   "Sort the group buffer alphabetically by real group name.
3327 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3328 sort in reverse order."
3329   (interactive (gnus-interactive "P\ny"))
3330   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-real-name reverse))
3331
3332 (defun gnus-group-sort-selected-groups-by-unread (&optional n reverse)
3333   "Sort the group buffer by number of unread articles.
3334 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3335 sort in reverse order."
3336   (interactive (gnus-interactive "P\ny"))
3337   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-unread reverse))
3338
3339 (defun gnus-group-sort-selected-groups-by-level (&optional n reverse)
3340   "Sort the group buffer by group level.
3341 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3342 sort in reverse order."
3343   (interactive (gnus-interactive "P\ny"))
3344   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-level reverse))
3345
3346 (defun gnus-group-sort-selected-groups-by-score (&optional n reverse)
3347   "Sort the group buffer by group score.
3348 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3349 sort in reverse order."
3350   (interactive (gnus-interactive "P\ny"))
3351   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-score reverse))
3352
3353 (defun gnus-group-sort-selected-groups-by-rank (&optional n reverse)
3354   "Sort the group buffer by group rank.
3355 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3356 sort in reverse order."
3357   (interactive (gnus-interactive "P\ny"))
3358   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-rank reverse))
3359
3360 (defun gnus-group-sort-selected-groups-by-method (&optional n reverse)
3361   "Sort the group buffer alphabetically by back end name.
3362 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3363 sort in reverse order."
3364   (interactive (gnus-interactive "P\ny"))
3365   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-method reverse))
3366
3367 ;;; Sorting predicates.
3368
3369 (defun gnus-group-sort-by-alphabet (info1 info2)
3370   "Sort alphabetically."
3371   (string< (gnus-info-group info1) (gnus-info-group info2)))
3372
3373 (defun gnus-group-sort-by-real-name (info1 info2)
3374   "Sort alphabetically on real (unprefixed) names."
3375   (string< (gnus-group-real-name (gnus-info-group info1))
3376            (gnus-group-real-name (gnus-info-group info2))))
3377
3378 (defun gnus-group-sort-by-unread (info1 info2)
3379   "Sort by number of unread articles."
3380   (let ((n1 (gnus-group-unread (gnus-info-group info1)))
3381         (n2 (gnus-group-unread (gnus-info-group info2))))
3382     (< (or (and (numberp n1) n1) 0)
3383        (or (and (numberp n2) n2) 0))))
3384
3385 (defun gnus-group-sort-by-level (info1 info2)
3386   "Sort by level."
3387   (< (gnus-info-level info1) (gnus-info-level info2)))
3388
3389 (defun gnus-group-sort-by-method (info1 info2)
3390   "Sort alphabetically by back end name."
3391   (string< (car (gnus-find-method-for-group
3392                  (gnus-info-group info1) info1))
3393            (car (gnus-find-method-for-group
3394                  (gnus-info-group info2) info2))))
3395
3396 (defun gnus-group-sort-by-server (info1 info2)
3397   "Sort alphabetically by server name."
3398   (string< (gnus-method-to-full-server-name
3399             (gnus-find-method-for-group
3400              (gnus-info-group info1) info1))
3401            (gnus-method-to-full-server-name
3402             (gnus-find-method-for-group
3403              (gnus-info-group info2) info2))))
3404
3405 (defun gnus-group-sort-by-score (info1 info2)
3406   "Sort by group score."
3407   (> (gnus-info-score info1) (gnus-info-score info2)))
3408
3409 (defun gnus-group-sort-by-rank (info1 info2)
3410   "Sort by level and score."
3411   (let ((level1 (gnus-info-level info1))
3412         (level2 (gnus-info-level info2)))
3413     (or (< level1 level2)
3414         (and (= level1 level2)
3415              (> (gnus-info-score info1) (gnus-info-score info2))))))
3416
3417 ;;; Clearing data
3418
3419 (defun gnus-group-clear-data (&optional arg)
3420   "Clear all marks and read ranges from the current group.
3421 Obeys the process/prefix convention."
3422   (interactive "P")
3423   (gnus-group-iterate arg
3424     (lambda (group)
3425       (let (info)
3426         (gnus-info-clear-data (setq info (gnus-get-info group)))
3427         (gnus-get-unread-articles-in-group info (gnus-active group) t)
3428         (when (gnus-group-goto-group group)
3429           (gnus-group-update-group-line))))))
3430
3431 (defun gnus-group-clear-data-on-native-groups ()
3432   "Clear all marks and read ranges from all native groups."
3433   (interactive)
3434   (when (gnus-yes-or-no-p "Really clear all data from almost all groups? ")
3435     (let ((alist (cdr gnus-newsrc-alist))
3436           info)
3437       (while (setq info (pop alist))
3438         (when (gnus-group-native-p (gnus-info-group info))
3439           (gnus-info-clear-data info)))
3440       (gnus-get-unread-articles)
3441       (gnus-dribble-touch)
3442       (when (gnus-y-or-n-p
3443              "Move the cache away to avoid problems in the future? ")
3444         (call-interactively 'gnus-cache-move-cache)))))
3445
3446 (defun gnus-info-clear-data (info)
3447   "Clear all marks and read ranges from INFO."
3448   (let ((group (gnus-info-group info))
3449         action)
3450     (dolist (el (gnus-info-marks info))
3451       (push `(,(cdr el) add (,(car el))) action))
3452     (push `(,(gnus-info-read info) add (read)) action)
3453     (gnus-undo-register
3454       `(progn
3455          (gnus-request-set-mark ,group ',action)
3456          (gnus-info-set-marks ',info ',(gnus-info-marks info) t)
3457          (gnus-info-set-read ',info ',(gnus-info-read info))
3458          (when (gnus-group-goto-group ,group)
3459            (gnus-get-unread-articles-in-group ',info ',(gnus-active group) t)
3460            (gnus-group-update-group-line))))
3461     (setq action (mapcar (lambda (el) (list (nth 0 el) 'del (nth 2 el)))
3462                          action))
3463     (gnus-request-set-mark group action)
3464     (gnus-info-set-read info nil)
3465     (when (gnus-info-marks info)
3466       (gnus-info-set-marks info nil))))
3467
3468 ;; Group catching up.
3469
3470 (defun gnus-group-catchup-current (&optional n all)
3471   "Mark all unread articles in the current newsgroup as read.
3472 If prefix argument N is numeric, the next N newsgroups will be
3473 caught up.  If ALL is non-nil, marked articles will also be marked as
3474 read.  Cross references (Xref: header) of articles are ignored.
3475 The number of newsgroups that this function was unable to catch
3476 up is returned."
3477   (interactive "P")
3478   (let ((groups (gnus-group-process-prefix n))
3479         (ret 0)
3480         group)
3481     (unless groups (error "No groups selected"))
3482     (if (not
3483          (or (not gnus-interactive-catchup) ;Without confirmation?
3484              gnus-expert-user
3485              (gnus-y-or-n-p
3486               (format
3487                (if all
3488                    "Do you really want to mark all articles in %s as read? "
3489                  "Mark all unread articles in %s as read? ")
3490                (if (= (length groups) 1)
3491                    (gnus-group-decoded-name (car groups))
3492                  (format "these %d groups" (length groups)))))))
3493         n
3494       (while (setq group (pop groups))
3495         (gnus-group-remove-mark group)
3496         ;; Virtual groups have to be given special treatment.
3497         (let ((method (gnus-find-method-for-group group)))
3498           (when (eq 'nnvirtual (car method))
3499             (nnvirtual-catchup-group
3500              (gnus-group-real-name group) (nth 1 method) all)))
3501         (cond
3502          ((>= (gnus-group-level group) gnus-level-zombie)
3503           (gnus-message 2 "Dead groups can't be caught up"))
3504          ((prog1
3505               (gnus-group-goto-group group)
3506             (gnus-group-catchup group all))
3507           (gnus-group-update-group-line))
3508          (t
3509           (setq ret (1+ ret)))))
3510       (gnus-group-next-unread-group 1)
3511       ret)))
3512
3513 (defun gnus-group-catchup-current-all (&optional n)
3514   "Mark all articles in current newsgroup as read.
3515 Cross references (Xref: header) of articles are ignored."
3516   (interactive "P")
3517   (gnus-group-catchup-current n 'all))
3518
3519 (defun gnus-group-catchup (group &optional all)
3520   "Mark all articles in GROUP as read.
3521 If ALL is non-nil, all articles are marked as read.
3522 The return value is the number of articles that were marked as read,
3523 or nil if no action could be taken."
3524   (let* ((entry (gnus-group-entry group))
3525          (num (car entry))
3526          (marks (gnus-info-marks (nth 2 entry)))
3527          (unread (gnus-sequence-of-unread-articles group)))
3528     ;; Remove entries for this group.
3529     (nnmail-purge-split-history (gnus-group-real-name group))
3530     ;; Do the updating only if the newsgroup isn't killed.
3531     (if (not (numberp (car entry)))
3532         (gnus-message 1 "Can't catch up %s; non-active group" group)
3533       (gnus-update-read-articles group nil)
3534       (when all
3535         ;; Nix out the lists of marks and dormants.
3536         (gnus-request-set-mark group (list (list (cdr (assq 'tick marks))
3537                                                  'del '(tick))
3538                                            (list (cdr (assq 'dormant marks))
3539                                                  'del '(dormant))))
3540         (setq unread (gnus-range-add (gnus-range-add
3541                                       unread (cdr (assq 'dormant marks)))
3542                                      (cdr (assq 'tick marks))))
3543         (gnus-add-marked-articles group 'tick nil nil 'force)
3544         (gnus-add-marked-articles group 'dormant nil nil 'force))
3545       ;; Do auto-expirable marks if that's required.
3546       (when (gnus-group-auto-expirable-p group)
3547         (gnus-range-map
3548          (lambda (article)
3549            (gnus-add-marked-articles group 'expire (list article))
3550            (gnus-request-set-mark group (list (list (list article)
3551                                                     'add '(expire)))))
3552          unread))
3553       (let ((gnus-newsgroup-name group))
3554         (gnus-run-hooks 'gnus-group-catchup-group-hook))
3555       num)))
3556
3557 (defun gnus-group-expire-articles (&optional n)
3558   "Expire all expirable articles in the current newsgroup.
3559 Uses the process/prefix convention."
3560   (interactive "P")
3561   (let ((groups (gnus-group-process-prefix n))
3562         group)
3563     (unless groups
3564       (error "No groups to expire"))
3565     (while (setq group (pop groups))
3566       (gnus-group-remove-mark group)
3567       (gnus-group-expire-articles-1 group)
3568       (gnus-dribble-touch)
3569       (gnus-group-position-point))))
3570
3571 (defun gnus-group-expire-articles-1 (group)
3572   (when (gnus-check-backend-function 'request-expire-articles group)
3573     (gnus-message 6 "Expiring articles in %s..."
3574                   (gnus-group-decoded-name group))
3575     (let* ((info (gnus-get-info group))
3576            (expirable (if (gnus-group-total-expirable-p group)
3577                           (cons nil (gnus-list-of-read-articles group))
3578                         (assq 'expire (gnus-info-marks info))))
3579            (expiry-wait (gnus-group-find-parameter group 'expiry-wait))
3580            (nnmail-expiry-target
3581             (or (gnus-group-find-parameter group 'expiry-target)
3582                 nnmail-expiry-target)))
3583       (when expirable
3584         (gnus-check-group group)
3585         (setcdr
3586          expirable
3587          (gnus-compress-sequence
3588           (if expiry-wait
3589               ;; We set the expiry variables to the group
3590               ;; parameter.
3591               (let ((nnmail-expiry-wait-function nil)
3592                     (nnmail-expiry-wait expiry-wait))
3593                 (gnus-request-expire-articles
3594                  (gnus-uncompress-sequence (cdr expirable)) group))
3595             ;; Just expire using the normal expiry values.
3596             (gnus-request-expire-articles
3597              (gnus-uncompress-sequence (cdr expirable)) group))))
3598         (gnus-close-group group))
3599       (gnus-message 6 "Expiring articles in %s...done"
3600                     (gnus-group-decoded-name group))
3601       ;; Return the list of un-expired articles.
3602       (cdr expirable))))
3603
3604 (defun gnus-group-expire-all-groups ()
3605   "Expire all expirable articles in all newsgroups."
3606   (interactive)
3607   (save-excursion
3608     (gnus-message 5 "Expiring...")
3609     (let ((gnus-group-marked (mapcar (lambda (info) (gnus-info-group info))
3610                                      (cdr gnus-newsrc-alist))))
3611       (gnus-group-expire-articles nil)))
3612   (gnus-group-position-point)
3613   (gnus-message 5 "Expiring...done"))
3614
3615 (defun gnus-group-set-current-level (n level)
3616   "Set the level of the next N groups to LEVEL."
3617   (interactive
3618    (list
3619     current-prefix-arg
3620     (progn
3621       (unless (gnus-group-process-prefix current-prefix-arg)