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