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