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