Remove nnml-retrieve-groups that is unnecessary and somewhat problematic
[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        gnus-level-killed ?K regexp))
1401
1402     (gnus-group-set-mode-line)
1403     (setq gnus-group-list-mode (cons level predicate))
1404     (gnus-run-hooks 'gnus-group-prepare-hook)
1405     t))
1406
1407 (defun gnus-group-prepare-flat-list-dead (groups level mark regexp)
1408   ;; List zombies and killed lists somewhat faster, which was
1409   ;; suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>.  It does
1410   ;; this by ignoring the group format specification altogether.
1411   (let (group)
1412     (if (> (length groups) gnus-group-listing-limit)
1413         (while groups
1414           (setq group (pop groups))
1415           (when (gnus-group-prepare-logic
1416                  group
1417                  (or (not regexp)
1418                      (and (stringp regexp) (string-match regexp group))
1419                      (and (functionp regexp) (funcall regexp group))))
1420             (gnus-add-text-properties
1421              (point) (prog1 (1+ (point))
1422                        (insert " " mark "     *: "
1423                                (gnus-group-decoded-name group)
1424                                "\n"))
1425              (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
1426                    'gnus-unread t
1427                    'gnus-level level))))
1428       (while groups
1429         (setq group (pop groups))
1430         (when (gnus-group-prepare-logic
1431                group
1432                (or (not regexp)
1433                    (and (stringp regexp) (string-match regexp group))
1434                    (and (functionp regexp) (funcall regexp group))))
1435           (gnus-group-insert-group-line
1436            group level nil
1437            (let ((active (gnus-active group)))
1438              (if active
1439                  (if (zerop (cdr active))
1440                      0
1441                    (- (1+ (cdr active)) (car active)))
1442                nil))
1443            (gnus-method-simplify (gnus-find-method-for-group group))))))))
1444
1445 (defun gnus-group-update-group-line ()
1446   "Update the current line in the group buffer."
1447   (let* ((buffer-read-only nil)
1448          (group (gnus-group-group-name))
1449          (entry (and group (gnus-group-entry group)))
1450          gnus-group-indentation)
1451     (when group
1452       (and entry
1453            (not (gnus-ephemeral-group-p group))
1454            (gnus-dribble-enter
1455             (concat "(gnus-group-set-info '"
1456                     (gnus-prin1-to-string (nth 2 entry))
1457                     ")")
1458             (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\"")))
1459       (setq gnus-group-indentation (gnus-group-group-indentation))
1460       (gnus-delete-line)
1461       (gnus-group-insert-group-line-info group)
1462       (forward-line -1)
1463       (gnus-group-position-point))))
1464
1465 (defun gnus-group-insert-group-line-info (group)
1466   "Insert GROUP on the current line."
1467   (let ((entry (gnus-group-entry group))
1468         (gnus-group-indentation (gnus-group-group-indentation))
1469         active info)
1470     (if entry
1471         (progn
1472           ;; (Un)subscribed group.
1473           (setq info (nth 2 entry))
1474           (gnus-group-insert-group-line
1475            group (gnus-info-level info) (gnus-info-marks info)
1476            (or (car entry) t) (gnus-info-method info)))
1477       ;; This group is dead.
1478       (gnus-group-insert-group-line
1479        group
1480        (if (member group gnus-zombie-list) gnus-level-zombie gnus-level-killed)
1481        nil
1482        (if (setq active (gnus-active group))
1483            (if (zerop (cdr active))
1484                0
1485              (- (1+ (cdr active)) (car active)))
1486          nil)
1487        (gnus-method-simplify (gnus-find-method-for-group group))))))
1488
1489 (defun gnus-number-of-unseen-articles-in-group (group)
1490   (let* ((info (nth 2 (gnus-group-entry group)))
1491          (marked (gnus-info-marks info))
1492          (seen (cdr (assq 'seen marked)))
1493          (active (gnus-active group)))
1494     (if (not active)
1495         0
1496       (length (gnus-uncompress-range
1497                (gnus-range-difference
1498                 (gnus-range-difference (list active) (gnus-info-read info))
1499                 seen))))))
1500
1501 ;; Moving through the Group buffer (in topic mode) e.g. with C-n doesn't
1502 ;; update the state (enabled/disabled) of the icon `gnus-group-describe-group'
1503 ;; automatically.  After `C-l' the state is correct.  See the following report
1504 ;; on emacs-devel
1505 ;; <http://thread.gmane.org/v9acdmrcse.fsf@marauder.physik.uni-ulm.de>:
1506 ;; From: Reiner Steib
1507 ;; Subject: tool bar icons not updated according to :active condition
1508 ;; Newsgroups: gmane.emacs.devel
1509 ;; Date: Mon, 23 Jan 2006 19:59:13 +0100
1510 ;; Message-ID: <v9acdmrcse.fsf@marauder.physik.uni-ulm.de>
1511
1512 (defcustom gnus-group-update-tool-bar
1513   (and (not (featurep 'xemacs))
1514        (boundp 'tool-bar-mode)
1515        tool-bar-mode
1516        ;; Using `redraw-frame' (see `gnus-tool-bar-update') in Emacs might
1517        ;; be confusing, so maybe we shouldn't call it by default.
1518        (fboundp 'force-window-update))
1519   "Force updating the group buffer tool bar."
1520   :group 'gnus-group
1521   :version "22.1"
1522   :initialize 'custom-initialize-default
1523   :set (lambda (symbol value)
1524          (set-default symbol value)
1525          (when (gnus-alive-p)
1526            (with-current-buffer gnus-group-buffer
1527              ;; FIXME: Is there a better way to redraw the group buffer?
1528              (gnus-group-get-new-news 0))))
1529   :type 'boolean)
1530
1531 (defun gnus-group-insert-group-line (gnus-tmp-group gnus-tmp-level
1532                                                     gnus-tmp-marked number
1533                                                     gnus-tmp-method)
1534   "Insert a group line in the group buffer."
1535   (let* ((gnus-tmp-method
1536           (gnus-server-get-method gnus-tmp-group gnus-tmp-method))
1537          (group-name-charset (gnus-group-name-charset gnus-tmp-method
1538                                                       gnus-tmp-group))
1539          (gnus-tmp-active (gnus-active gnus-tmp-group))
1540          (gnus-tmp-number-total
1541           (if gnus-tmp-active
1542               (1+ (- (cdr gnus-tmp-active) (car gnus-tmp-active)))
1543             0))
1544          (gnus-tmp-number-of-unread
1545           (if (numberp number) (int-to-string (max 0 number))
1546             "*"))
1547          (gnus-tmp-number-of-read
1548           (if (numberp number)
1549               (int-to-string (max 0 (- gnus-tmp-number-total number)))
1550             "*"))
1551          (gnus-tmp-subscribed
1552           (cond ((<= gnus-tmp-level gnus-level-subscribed) ? )
1553                 ((<= gnus-tmp-level gnus-level-unsubscribed) ?U)
1554                 ((= gnus-tmp-level gnus-level-zombie) ?Z)
1555                 (t ?K)))
1556          (gnus-tmp-qualified-group
1557           (gnus-group-name-decode (gnus-group-real-name gnus-tmp-group)
1558                                   group-name-charset))
1559          (gnus-tmp-comment
1560           (or (gnus-group-get-parameter gnus-tmp-group 'comment t)
1561               gnus-tmp-group))
1562          (gnus-tmp-newsgroup-description
1563           (if gnus-description-hashtb
1564               (or (gnus-group-name-decode
1565                    (gnus-gethash gnus-tmp-group gnus-description-hashtb)
1566                    group-name-charset) "")
1567             ""))
1568          (gnus-tmp-moderated
1569           (if (and gnus-moderated-hashtb
1570                    (gnus-gethash gnus-tmp-group gnus-moderated-hashtb))
1571               ?m ? ))
1572          (gnus-tmp-moderated-string
1573           (if (eq gnus-tmp-moderated ?m) "(m)" ""))
1574          (gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-group))
1575          (gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
1576          (gnus-tmp-news-method (or (car gnus-tmp-method) ""))
1577          (gnus-tmp-news-method-string
1578           (if gnus-tmp-method
1579               (format "(%s:%s)" (car gnus-tmp-method)
1580                       (cadr gnus-tmp-method)) ""))
1581          (gnus-tmp-marked-mark
1582           (if (and (numberp number)
1583                    (zerop number)
1584                    (cdr (assq 'tick gnus-tmp-marked)))
1585               ?* ? ))
1586          (gnus-tmp-summary-live
1587           (if (and (not gnus-group-is-exiting-p)
1588                    (gnus-buffer-live-p (gnus-summary-buffer-name
1589                                         gnus-tmp-group)))
1590               ?* ? ))
1591          (gnus-tmp-process-marked
1592           (if (member gnus-tmp-group gnus-group-marked)
1593               gnus-process-mark ? ))
1594          (buffer-read-only nil)
1595          beg end
1596          gnus-tmp-header)       ; passed as parameter to user-funcs.
1597     (beginning-of-line)
1598     (setq beg (point))
1599     (gnus-add-text-properties
1600      (point)
1601      (prog1 (1+ (point))
1602        ;; Insert the text.
1603        (let ((gnus-tmp-decoded-group (gnus-group-name-decode
1604                                       gnus-tmp-group group-name-charset)))
1605          (eval gnus-group-line-format-spec)))
1606      `(gnus-group ,(gnus-intern-safe gnus-tmp-group gnus-active-hashtb)
1607                   gnus-unread ,(if (numberp number)
1608                                    (string-to-number gnus-tmp-number-of-unread)
1609                                  t)
1610                   gnus-marked ,gnus-tmp-marked-mark
1611                   gnus-indentation ,gnus-group-indentation
1612                   gnus-level ,gnus-tmp-level))
1613     (setq end (point))
1614     (gnus-group--setup-tool-bar-update beg end)
1615     (forward-line -1)
1616     (when (inline (gnus-visual-p 'group-highlight 'highlight))
1617       (gnus-group-highlight-line gnus-tmp-group beg end))
1618     (gnus-run-hooks 'gnus-group-update-hook)
1619     (forward-line)))
1620
1621 (defun gnus-group--setup-tool-bar-update (beg end)
1622   (when gnus-group-update-tool-bar
1623     (if (fboundp 'cursor-sensor-mode)
1624         (progn
1625           (unless (bound-and-true-p cursor-sensor-mode)
1626             (cursor-sensor-mode 1))
1627           (gnus-put-text-property beg end 'cursor-sensor-functions
1628                                   '(gnus-tool-bar-update)))
1629       (gnus-put-text-property beg end 'point-entered
1630                               #'gnus-tool-bar-update)
1631       (gnus-put-text-property beg end 'point-left
1632                               #'gnus-tool-bar-update))))
1633
1634 (defun gnus-group-update-eval-form (group list)
1635   "Eval `car' of each element of LIST, and return the first that return t.
1636 Some value are bound so the form can use them."
1637   (defvar group-age) (defvar ticked) (defvar score) (defvar level)
1638   (defvar mailp) (defvar total) (defvar unread)
1639   (when list
1640     (let* ((entry (gnus-group-entry group))
1641            (unread (if (numberp (car entry)) (car entry) 0))
1642            (active (gnus-active group))
1643            (total (if active (1+ (- (cdr active) (car active))) 0))
1644            (info (nth 2 entry))
1645            (method (inline (gnus-server-get-method group (gnus-info-method info))))
1646            (marked (gnus-info-marks info))
1647            (mailp (apply 'append
1648                          (mapcar
1649                           (lambda (x)
1650                             (memq x (assoc (symbol-name
1651                                             (car (or method gnus-select-method)))
1652                                            gnus-valid-select-methods)))
1653                           '(mail post-mail))))
1654            (level (or (gnus-info-level info) gnus-level-killed))
1655            (score (or (gnus-info-score info) 0))
1656            (ticked (gnus-range-length (cdr (assq 'tick marked))))
1657            (group-age (gnus-group-timestamp-delta group)))
1658       ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465
1659       ;; ======================================================================
1660       ;; From: Richard Stallman
1661       ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...])
1662       ;; Cc: ding@gnus.org
1663       ;; Date: Sat, 27 Oct 2007 19:41:20 -0400
1664       ;; Message-ID: <E1IlvHM-0006TS-7t@fencepost.gnu.org>
1665       ;;
1666       ;; [...]
1667       ;; The kludge is that the alist elements contain expressions that refer
1668       ;; to local variables with short names.  Perhaps write your own tiny
1669       ;; evaluator that handles just `and', `or', and numeric comparisons
1670       ;; and just a few specific variables.
1671       ;; ======================================================================
1672       ;;
1673       ;; Similar for other evaluated variables.  Grep for risky-local-variable
1674       ;; to find them!  -- rsteib
1675       ;;
1676       ;; Eval the cars of the lists until we find a match.
1677       (while (and list
1678                   (not (eval (caar list))))
1679         (setq list (cdr list)))
1680       list)))
1681
1682 (defun gnus-group-highlight-line (group beg end)
1683   "Highlight the current line according to `gnus-group-highlight'.
1684 GROUP is current group, and the line to highlight starts at BEG
1685 and ends at END."
1686   (let ((face (cdar (gnus-group-update-eval-form
1687                       group
1688                       gnus-group-highlight))))
1689     (unless (eq face (gnus-get-text-property-excluding-characters-with-faces beg 'face))
1690       (let ((inhibit-read-only t))
1691         (gnus-put-text-property-excluding-characters-with-faces
1692          beg end 'face
1693          (if (boundp face) (symbol-value face) face)))
1694       (gnus-extent-start-open beg))))
1695
1696 (defun gnus-group-get-icon (group)
1697   "Return an icon for GROUP according to `gnus-group-icon-list'."
1698   (if gnus-group-icon-list
1699       (let ((image-path
1700              (cdar (gnus-group-update-eval-form group gnus-group-icon-list))))
1701         (if image-path
1702             (propertize " "
1703                         'display
1704                         (append
1705                          (gnus-create-image (expand-file-name image-path))
1706                          '(:ascent center)))
1707           " "))
1708     " "))
1709
1710
1711 (defun gnus-group-refresh-group (group)
1712   (gnus-activate-group group)
1713   (gnus-get-unread-articles-in-group (gnus-get-info group)
1714                                      (gnus-active group))
1715   (gnus-group-update-group group))
1716
1717 (defun gnus-group-update-group (group &optional visible-only
1718                                       info-unchanged)
1719   "Update all lines where GROUP appear.
1720 If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't
1721 already.  If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
1722   (with-current-buffer gnus-group-buffer
1723     (save-excursion
1724       ;; The buffer may be narrowed.
1725       (save-restriction
1726         (widen)
1727         (let ((ident (gnus-intern-safe group gnus-active-hashtb))
1728               (loc (point-min))
1729               found buffer-read-only)
1730           (unless info-unchanged
1731             ;; Enter the current status into the dribble buffer.
1732             (let ((entry (gnus-group-entry group)))
1733               (when (and entry
1734                          (not (gnus-ephemeral-group-p group)))
1735                 (gnus-dribble-enter
1736                  (concat "(gnus-group-set-info '"
1737                          (gnus-prin1-to-string (nth 2 entry))
1738                          ")")
1739                  (concat "^(gnus-group-set-info '(\""
1740                          (regexp-quote group) "\"")))))
1741           ;; Find all group instances.  If topics are in use, each group
1742           ;; may be listed in more than once.
1743           (while (setq loc (text-property-any
1744                             loc (point-max) 'gnus-group ident))
1745             (setq found t)
1746             (goto-char loc)
1747             (let ((gnus-group-indentation (gnus-group-group-indentation)))
1748               (gnus-delete-line)
1749               (gnus-group-insert-group-line-info group)
1750               (save-excursion
1751                 (forward-line -1)
1752                 (gnus-run-hooks 'gnus-group-update-group-hook)))
1753             (setq loc (1+ loc)))
1754           (unless (or found visible-only)
1755             ;; No such line in the buffer, find out where it's supposed to
1756             ;; go, and insert it there (or at the end of the buffer).
1757             (if gnus-goto-missing-group-function
1758                 (funcall gnus-goto-missing-group-function group)
1759               (let ((entry (cddr (gnus-group-entry group))))
1760                 (while (and entry (car entry)
1761                             (not
1762                              (gnus-goto-char
1763                               (text-property-any
1764                                (point-min) (point-max)
1765                                'gnus-group (gnus-intern-safe
1766                                             (caar entry)
1767                                             gnus-active-hashtb)))))
1768                   (setq entry (cdr entry)))
1769                 (or entry (goto-char (point-max)))))
1770             ;; Finally insert the line.
1771             (let ((gnus-group-indentation (gnus-group-group-indentation)))
1772               (gnus-group-insert-group-line-info group)
1773               (save-excursion
1774                 (forward-line -1)
1775                 (gnus-run-hooks 'gnus-group-update-group-hook))))
1776           (when gnus-group-update-group-function
1777             (funcall gnus-group-update-group-function group))
1778           (gnus-group-set-mode-line))))))
1779
1780 (defun gnus-group-set-mode-line ()
1781   "Update the mode line in the group buffer."
1782   (when (memq 'group gnus-updated-mode-lines)
1783     ;; Yes, we want to keep this mode line updated.
1784     (with-current-buffer gnus-group-buffer
1785       (let* ((gformat (or gnus-group-mode-line-format-spec
1786                           (gnus-set-format 'group-mode)))
1787              (gnus-tmp-news-server (cadr gnus-select-method))
1788              (gnus-tmp-news-method (car gnus-select-method))
1789              (gnus-tmp-colon (if (equal gnus-tmp-news-server "") "" ":"))
1790              (max-len 60)
1791              gnus-tmp-header            ;Dummy binding for user-defined formats
1792              ;; Get the resulting string.
1793              (modified
1794               (and gnus-dribble-buffer
1795                    (buffer-name gnus-dribble-buffer)
1796                    (buffer-modified-p gnus-dribble-buffer)
1797                    (with-current-buffer gnus-dribble-buffer
1798                      (not (zerop (buffer-size))))))
1799              (mode-string (eval gformat)))
1800         ;; Say whether the dribble buffer has been modified.
1801         (setq mode-line-modified
1802               (if modified (car gnus-mode-line-modified)
1803                 (cdr gnus-mode-line-modified)))
1804         ;; If the line is too long, we chop it off.
1805         (when (> (length mode-string) max-len)
1806           (setq mode-string (substring mode-string 0 (- max-len 4))))
1807         (prog1
1808             (setq mode-line-buffer-identification
1809                   (gnus-mode-line-buffer-identification
1810                    (list mode-string)))
1811           (set-buffer-modified-p modified))))))
1812
1813 (defun gnus-group-group-name ()
1814   "Get the name of the newsgroup on the current line."
1815   (let ((group (get-text-property (point-at-bol) 'gnus-group)))
1816     (when group
1817       (if (stringp group)
1818           group
1819         (symbol-name group)))))
1820
1821 (defun gnus-group-group-level ()
1822   "Get the level of the newsgroup on the current line."
1823   (get-text-property (point-at-bol) 'gnus-level))
1824
1825 (defun gnus-group-group-indentation ()
1826   "Get the indentation of the newsgroup on the current line."
1827   (or (get-text-property (point-at-bol) 'gnus-indentation)
1828       (and gnus-group-indentation-function
1829            (funcall gnus-group-indentation-function))
1830       ""))
1831
1832 (defun gnus-group-group-unread ()
1833   "Get the number of unread articles of the newsgroup on the current line."
1834   (get-text-property (point-at-bol) 'gnus-unread))
1835
1836 (defun gnus-group-new-mail (group)
1837   (if (nnmail-new-mail-p (gnus-group-real-name group))
1838       gnus-new-mail-mark
1839     ? ))
1840
1841 (defun gnus-group-level (group)
1842   "Return the estimated level of GROUP."
1843   (or (gnus-info-level (gnus-get-info group))
1844       (and (member group gnus-zombie-list) gnus-level-zombie)
1845       gnus-level-killed))
1846
1847 (defun gnus-group-search-forward (&optional backward all level first-too)
1848   "Find the next newsgroup with unread articles.
1849 If BACKWARD is non-nil, find the previous newsgroup instead.
1850 If ALL is non-nil, just find any newsgroup.
1851 If LEVEL is non-nil, find group with level LEVEL, or higher if no such
1852 group exists.
1853 If FIRST-TOO, the current line is also eligible as a target."
1854   (let ((way (if backward -1 1))
1855         (low gnus-level-killed)
1856         (beg (point))
1857         pos found lev)
1858     (if (and backward (progn (beginning-of-line)) (bobp))
1859         nil
1860       (unless first-too
1861         (forward-line way))
1862       (while (and
1863               (not (eobp))
1864               (not (setq
1865                     found
1866                     (and
1867                      (get-text-property (point) 'gnus-group)
1868                      (or all
1869                          (and
1870                           (let ((unread
1871                                  (get-text-property (point) 'gnus-unread)))
1872                             (and (numberp unread) (> unread 0)))
1873                           (setq lev (get-text-property (point)
1874                                                        'gnus-level))
1875                           (<= lev gnus-level-subscribed)))
1876                      (or (not level)
1877                          (and (setq lev (get-text-property (point)
1878                                                            'gnus-level))
1879                               (or (= lev level)
1880                                   (and (< lev low)
1881                                        (< level lev)
1882                                        (progn
1883                                          (setq low lev)
1884                                          (setq pos (point))
1885                                          nil))))))))
1886               (zerop (forward-line way)))))
1887     (if found
1888         (progn (gnus-group-position-point) t)
1889       (goto-char (or pos beg))
1890       (and pos t))))
1891
1892 (defun gnus-total-fetched-for (group)
1893   (let* ((size-in-cache (or (gnus-cache-total-fetched-for group) 0))
1894          (size-in-agent (or (gnus-agent-total-fetched-for group) 0))
1895          (size (+ size-in-cache size-in-agent))
1896          (suffix '("B" "K" "M" "G"))
1897          (scale 1024.0)
1898          (cutoff scale))
1899     (while (> size cutoff)
1900       (setq size (/ size scale)
1901             suffix (cdr suffix)))
1902     (format "%5.1f%s" size (car suffix))))
1903
1904 ;;; Gnus group mode commands
1905
1906 ;; Group marking.
1907
1908 (defun gnus-group-mark-line-p ()
1909   (save-excursion
1910     (beginning-of-line)
1911     (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
1912     (eq (char-after) gnus-process-mark)))
1913
1914 (defun gnus-group-mark-group (n &optional unmark no-advance)
1915   "Mark the current group."
1916   (interactive "p")
1917   (let ((buffer-read-only nil)
1918         group)
1919     (while (and (> n 0)
1920                 (not (eobp)))
1921       (when (setq group (gnus-group-group-name))
1922         ;; Go to the mark position.
1923         (beginning-of-line)
1924         (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
1925         (delete-char 1)
1926         (if unmark
1927             (progn
1928               (setq gnus-group-marked (delete group gnus-group-marked))
1929               (insert-char ? 1 t))
1930            (setq gnus-group-marked
1931                  (cons group (delete group gnus-group-marked)))
1932            (insert-char gnus-process-mark 1 t)))
1933       (unless no-advance
1934         (gnus-group-next-group 1))
1935       (decf n))
1936     (gnus-group-position-point)
1937     n))
1938
1939 (defun gnus-group-unmark-group (n)
1940   "Remove the mark from the current group."
1941   (interactive "p")
1942   (gnus-group-mark-group n 'unmark)
1943   (gnus-group-position-point))
1944
1945 (defun gnus-group-unmark-all-groups ()
1946   "Unmark all groups."
1947   (interactive)
1948   (save-excursion
1949     (mapc 'gnus-group-remove-mark gnus-group-marked))
1950   (gnus-group-position-point))
1951
1952 (defun gnus-group-mark-region (unmark beg end)
1953   "Mark all groups between point and mark.
1954 If UNMARK, remove the mark instead."
1955   (interactive "P\nr")
1956   (let ((num (count-lines beg end)))
1957     (save-excursion
1958       (goto-char beg)
1959       (- num (gnus-group-mark-group num unmark)))))
1960
1961 (defun gnus-group-mark-buffer (&optional unmark)
1962   "Mark all groups in the buffer.
1963 If UNMARK, remove the mark instead."
1964   (interactive "P")
1965   (gnus-group-mark-region unmark (point-min) (point-max)))
1966
1967 (defun gnus-group-mark-regexp (regexp)
1968   "Mark all groups that match some regexp."
1969   (interactive "sMark (regexp): ")
1970   (let ((alist (cdr gnus-newsrc-alist))
1971         group)
1972     (save-excursion
1973       (while alist
1974         (when (string-match regexp (setq group (gnus-info-group (pop alist))))
1975           (gnus-group-jump-to-group group)
1976           (gnus-group-set-mark group)))))
1977   (gnus-group-position-point))
1978
1979 (defun gnus-group-remove-mark (group &optional test-marked)
1980   "Remove the process mark from GROUP and move point there.
1981 Return nil if the group isn't displayed."
1982   (if (gnus-group-goto-group group nil test-marked)
1983       (save-excursion
1984         (gnus-group-mark-group 1 'unmark t)
1985         t)
1986     (setq gnus-group-marked
1987           (delete group gnus-group-marked))
1988     nil))
1989
1990 (defun gnus-group-set-mark (group)
1991   "Set the process mark on GROUP."
1992   (if (gnus-group-goto-group group)
1993       (save-excursion
1994         (gnus-group-mark-group 1 nil t))
1995     (setq gnus-group-marked (cons group (delete group gnus-group-marked)))))
1996
1997 (defun gnus-group-universal-argument (arg &optional groups func)
1998   "Perform any command on all groups according to the process/prefix convention."
1999   (interactive "P")
2000   (if (eq (setq func (or func
2001                          (key-binding
2002                           (read-key-sequence
2003                            (substitute-command-keys
2004                             "\\<gnus-group-mode-map>\\[gnus-group-universal-argument]")))))
2005           'undefined)
2006       (gnus-error 1 "Undefined key")
2007     (gnus-group-iterate arg
2008       (lambda (group)
2009         (command-execute func))))
2010   (gnus-group-position-point))
2011
2012 (defun gnus-group-process-prefix (n)
2013   "Return a list of groups to work on.
2014 Take into consideration N (the prefix) and the list of marked groups."
2015   (cond
2016    (n
2017     (setq n (prefix-numeric-value n))
2018     ;; There is a prefix, so we return a list of the N next
2019     ;; groups.
2020     (let ((way (if (< n 0) -1 1))
2021           (n (abs n))
2022           group groups)
2023       (save-excursion
2024         (while (> n 0)
2025           (if (setq group (gnus-group-group-name))
2026               (push group groups))
2027           (setq n (1- n))
2028           (gnus-group-next-group way)))
2029       (nreverse groups)))
2030    ((and (gnus-region-active-p) (mark))
2031     ;; Work on the region between point and mark.
2032     (let ((max (max (point) (mark)))
2033           groups)
2034       (save-excursion
2035         (goto-char (min (point) (mark)))
2036         (while
2037             (and
2038              (push (gnus-group-group-name) groups)
2039              (zerop (gnus-group-next-group 1))
2040              (< (point) max)))
2041         (nreverse groups))))
2042    (gnus-group-marked
2043     ;; No prefix, but a list of marked articles.
2044     (reverse gnus-group-marked))
2045    (t
2046     ;; Neither marked articles or a prefix, so we return the
2047     ;; current group.
2048     (let ((group (gnus-group-group-name)))
2049       (and group (list group))))))
2050
2051 ;;; !!!Surely gnus-group-iterate should be a macro instead?  I can't
2052 ;;; imagine why I went through these contortions...
2053 (eval-and-compile
2054   (let ((function (make-symbol "gnus-group-iterate-function"))
2055         (window (make-symbol "gnus-group-iterate-window"))
2056         (groups (make-symbol "gnus-group-iterate-groups"))
2057         (group (make-symbol "gnus-group-iterate-group")))
2058     (eval
2059      `(defun gnus-group-iterate (arg ,function)
2060         "Iterate FUNCTION over all process/prefixed groups.
2061 FUNCTION will be called with the group name as the parameter
2062 and with point over the group in question."
2063         (let ((,groups (gnus-group-process-prefix arg))
2064               (,window (selected-window))
2065               ,group)
2066           (while ,groups
2067             (setq ,group (car ,groups)
2068                   ,groups (cdr ,groups))
2069             (select-window ,window)
2070             (gnus-group-remove-mark ,group)
2071             (save-selected-window
2072               (save-excursion
2073                 (funcall ,function ,group)))))))))
2074
2075 (put 'gnus-group-iterate 'lisp-indent-function 1)
2076
2077 ;; Selecting groups.
2078
2079 (defun gnus-group-read-group (&optional all no-article group select-articles)
2080   "Read news in this newsgroup.
2081 If the prefix argument ALL is non-nil, already read articles become
2082 readable.
2083
2084 If ALL is a positive number, fetch this number of the latest
2085 articles in the group.  If ALL is a negative number, fetch this
2086 number of the earliest articles in the group.
2087
2088 If the optional argument NO-ARTICLE is non-nil, no article will
2089 be auto-selected upon group entry.  If GROUP is non-nil, fetch
2090 that group."
2091   (interactive "P")
2092   (let ((no-display (eq all 0))
2093         (group (or group (gnus-group-group-name)))
2094         number active marked entry)
2095     (when (eq all 0)
2096       (setq all nil))
2097     (unless group
2098       (error "No group on current line"))
2099     (setq marked (gnus-info-marks
2100                   (nth 2 (setq entry (gnus-group-entry group)))))
2101     ;; This group might be a dead group.  In that case we have to get
2102     ;; the number of unread articles from `gnus-active-hashtb'.
2103     (setq number
2104           (cond ((numberp all) all)
2105                 (entry (car entry))
2106                 ((setq active (gnus-active group))
2107                  (- (1+ (cdr active)) (car active)))))
2108     (gnus-summary-read-group
2109      group (or all (and (numberp number)
2110                         (zerop (+ number (gnus-range-length
2111                                           (cdr (assq 'tick marked)))
2112                                   (gnus-range-length
2113                                    (cdr (assq 'dormant marked)))))))
2114      no-article nil no-display nil select-articles)))
2115
2116 (defun gnus-group-select-group (&optional all)
2117   "Select this newsgroup.
2118 No article is selected automatically.
2119 If the group is opened, just switch the summary buffer.
2120 If ALL is non-nil, already read articles become readable.
2121 If ALL is a positive number, fetch this number of the latest
2122 articles in the group.
2123 If ALL is a negative number, fetch this number of the earliest
2124 articles in the group."
2125   (interactive "P")
2126   (when (and (eobp) (not (gnus-group-group-name)))
2127     (forward-line -1))
2128   (gnus-group-read-group all t))
2129
2130 (defun gnus-group-quick-select-group (&optional all group)
2131   "Select the GROUP \"quickly\".
2132 This means that no highlighting or scoring will be performed.  If
2133 ALL (the prefix argument) is 0, don't even generate the summary
2134 buffer.  If GROUP is nil, use current group.
2135
2136 This might be useful if you want to toggle threading
2137 before entering the group."
2138   (interactive "P")
2139   (require 'gnus-score)
2140   (let (gnus-visual
2141         gnus-score-find-score-files-function
2142         gnus-home-score-file
2143         gnus-apply-kill-hook
2144         gnus-summary-expunge-below)
2145     (gnus-group-read-group all t group)))
2146
2147 (defun gnus-group-visible-select-group (&optional all)
2148   "Select the current group without hiding any articles."
2149   (interactive "P")
2150   (let ((gnus-inhibit-limiting t))
2151     (gnus-group-read-group all t)))
2152
2153 (defun gnus-group-select-group-ephemerally ()
2154   "Select the current group without doing any processing whatsoever.
2155 You will actually be entered into a group that's a copy of
2156 the current group; no changes you make while in this group will
2157 be permanent."
2158   (interactive)
2159   (require 'gnus-score)
2160   (let* (gnus-visual
2161          gnus-score-find-score-files-function gnus-apply-kill-hook
2162          gnus-summary-expunge-below gnus-show-threads gnus-suppress-duplicates
2163          gnus-summary-mode-hook gnus-select-group-hook
2164          (group (gnus-group-group-name))
2165          (method (gnus-find-method-for-group group)))
2166     (gnus-group-read-ephemeral-group
2167      (gnus-group-prefixed-name group method) method)))
2168
2169 (defun gnus-group-name-at-point ()
2170   "Return a group name from around point if it exists, or nil."
2171   (if (derived-mode-p 'gnus-group-mode)
2172       (let ((group (gnus-group-group-name)))
2173         (when group
2174           (gnus-group-decoded-name group)))
2175     (let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\
2176 \\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\
2177 [^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\
2178 \\|[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)+\\)")
2179           (start (point))
2180           (case-fold-search nil))
2181       (prog1
2182           (if (or (and (not (or (eobp)
2183                                 (looking-at "[][\C-@-*,/;-@\\^`{-\C-?]")))
2184                        (prog1 t
2185                          (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?"
2186                                               (point-at-bol))))
2187                   (and (looking-at "[][\C-@-\t\v-*,/;-@\\^`{-\C-?]*$")
2188                        (prog1 t
2189                          (skip-chars-backward "][\C-@-\t\v-*,/;-@\\^`{-\C-?")
2190                          (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?"
2191                                               (point-at-bol))))
2192                   (string-match "\\`[][\C-@-\t\v-*,/;-@\\^`{-\C-?]*\\'"
2193                                 (buffer-substring (point-at-bol) (point))))
2194               (when (looking-at regexp)
2195                 (match-string 1))
2196             (let (group distance)
2197               (when (looking-at regexp)
2198                 (setq group (match-string 1)
2199                       distance (- (match-beginning 1) (match-beginning 0))))
2200               (skip-chars-backward "][\C-@-\t\v-*,/;-@\\^`{-\C-?")
2201               (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?"
2202                                    (point-at-bol))
2203               (if (looking-at regexp)
2204                   (if (and group (<= distance (- start (match-end 0))))
2205                       group
2206                     (match-string 1))
2207                 group)))
2208         (goto-char start)))))
2209
2210 (defun gnus-group-completing-read (&optional prompt collection
2211                                              require-match initial-input hist
2212                                              def)
2213   "Read a group name with completion.  Non-ASCII group names are allowed.
2214 The arguments are the same as `completing-read' except that COLLECTION
2215 and HIST default to `gnus-active-hashtb' and `gnus-group-history'
2216 respectively if they are omitted.  Regards COLLECTION as a hash table
2217 if it is not a list."
2218   (or collection (setq collection gnus-active-hashtb))
2219   (let (choices group)
2220     (if (listp collection)
2221         (dolist (symbol collection)
2222           (setq group (symbol-name symbol))
2223           (push (if (string-match "[^\000-\177]" group)
2224                     (gnus-group-decoded-name group)
2225                   group)
2226                 choices))
2227       (mapatoms (lambda (symbol)
2228                   (setq group (symbol-name symbol))
2229                   (push (if (string-match "[^\000-\177]" group)
2230                             (gnus-group-decoded-name group)
2231                           group)
2232                         choices))
2233                 collection))
2234     (setq group (gnus-completing-read (or prompt "Group") (nreverse choices)
2235                                       require-match initial-input
2236                                       (or hist 'gnus-group-history)
2237                                       def))
2238     (unless (if (listp collection)
2239                 (member group (mapcar 'symbol-name collection))
2240               (symbol-value (intern-soft group collection)))
2241       (setq group
2242             (mm-encode-coding-string
2243              group (gnus-group-name-charset nil group))))
2244     (gnus-replace-in-string group "\n" "")))
2245
2246 ;;;###autoload
2247 (defun gnus-fetch-group (group &optional articles)
2248   "Start Gnus if necessary and enter GROUP.
2249 If ARTICLES, display those articles.
2250 Returns whether the fetching was successful or not."
2251   (interactive (list (gnus-group-completing-read nil
2252                                                  nil nil
2253                                                  (gnus-group-name-at-point))))
2254   (unless (gnus-alive-p)
2255     (gnus-no-server))
2256   (gnus-group-read-group (if articles nil t) nil group articles))
2257
2258 ;;;###autoload
2259 (defun gnus-fetch-group-other-frame (group)
2260   "Pop up a frame and enter GROUP."
2261   (interactive "P")
2262   (let ((window (get-buffer-window gnus-group-buffer)))
2263     (cond (window
2264            (select-frame (window-frame window)))
2265           ((= (length (frame-list)) 1)
2266            (select-frame (make-frame)))
2267           (t
2268            (other-frame 1))))
2269   (gnus-fetch-group group))
2270
2271 (defcustom gnus-large-ephemeral-newsgroup 200
2272   "The number of articles which indicates a large ephemeral newsgroup.
2273 Same as `gnus-large-newsgroup', but only used for ephemeral newsgroups.
2274
2275 If the number of articles in a newsgroup is greater than this value,
2276 confirmation is required for selecting the newsgroup.  If it is nil, no
2277 confirmation is required."
2278   :version "22.1"
2279   :group 'gnus-group-select
2280   :type '(choice (const :tag "No limit" nil)
2281                  integer))
2282
2283 (defcustom gnus-fetch-old-ephemeral-headers nil
2284   "Same as `gnus-fetch-old-headers', but only used for ephemeral newsgroups."
2285   :version "22.1"
2286   :group 'gnus-thread
2287   :type '(choice (const :tag "off" nil)
2288                  (const some)
2289                  number
2290                  (sexp :menu-tag "other" t)))
2291
2292 ;; Enter a group that is not in the group buffer.  Non-nil is returned
2293 ;; if selection was successful.
2294 (defun gnus-group-read-ephemeral-group (group method &optional activate
2295                                               quit-config request-only
2296                                               select-articles
2297                                               parameters
2298                                               number)
2299   "Read GROUP from METHOD as an ephemeral group.
2300 If ACTIVATE, request the group first.
2301 If QUIT-CONFIG, use that Gnus window configuration name when
2302 exiting from the ephemeral group.
2303 If REQUEST-ONLY, don't actually read the group; just request it.
2304 If SELECT-ARTICLES, only select those articles.
2305 If PARAMETERS, use those as the group parameters.
2306 If NUMBER, fetch this number of articles.
2307
2308 Return the name of the group if selection was successful."
2309   (interactive
2310    (list
2311     ;; (gnus-read-group "Group name: ")
2312     (gnus-group-completing-read)
2313     (gnus-read-method "From method")))
2314   (unless (gnus-alive-p)
2315     (nnheader-init-server-buffer)
2316     ;; Necessary because of funky inlining.
2317     (require 'gnus-cache)
2318     (setq gnus-newsrc-hashtb (gnus-make-hashtable)))
2319   ;; Transform the select method into a unique server.
2320   (when (stringp method)
2321     (setq method (gnus-server-to-method method)))
2322   (let ((address-slot
2323          (intern (format "%s-address" (car method)))))
2324     (setq method
2325           (if (assq address-slot (cddr method))
2326               `(,(car method) ,(concat (cadr method) "-ephemeral")
2327                 ,@(cddr method))
2328             `(,(car method) ,(concat (cadr method) "-ephemeral")
2329               (,address-slot ,(cadr method))
2330               ,@(cddr method)))))
2331   (let ((group (if (gnus-group-foreign-p group) group
2332                  (gnus-group-prefixed-name (gnus-group-real-name group)
2333                                            method))))
2334     (gnus-set-active group nil)
2335     (gnus-sethash
2336      group
2337      `(-1 nil (,group
2338                ,gnus-level-default-subscribed nil nil ,method
2339                ,(cons
2340                  (cons 'quit-config
2341                        (cond
2342                         (quit-config
2343                          quit-config)
2344                         ((assq gnus-current-window-configuration
2345                                gnus-buffer-configuration)
2346                          (cons gnus-summary-buffer
2347                                gnus-current-window-configuration))
2348                         (t
2349                          (cons (current-buffer)
2350                                (current-window-configuration)))))
2351                  parameters)))
2352      gnus-newsrc-hashtb)
2353     (push method gnus-ephemeral-servers)
2354     (when (gnus-buffer-live-p gnus-group-buffer)
2355       (set-buffer gnus-group-buffer))
2356     (unless (gnus-check-server method)
2357       (error "Unable to contact server: %s" (gnus-status-message method)))
2358     (when activate
2359       (gnus-activate-group group 'scan)
2360       (unless (gnus-request-group group)
2361         (error "Couldn't request group: %s"
2362                (nnheader-get-report (car method)))))
2363     (if request-only
2364         group
2365       (condition-case ()
2366           (when (let ((gnus-large-newsgroup gnus-large-ephemeral-newsgroup)
2367                       (gnus-fetch-old-headers
2368                        gnus-fetch-old-ephemeral-headers))
2369                   (gnus-group-read-group (or number t) t group select-articles))
2370             group)
2371         (quit
2372          (if debug-on-quit
2373              (debug "Quit")
2374            (message "Quit reading the ephemeral group"))
2375          nil)))))
2376
2377 (defcustom gnus-gmane-group-download-format
2378   "http://download.gmane.org/%s/%s/%s"
2379   "URL for downloading mbox files.
2380 It must contain three \"%s\".  They correspond to the group, the
2381 minimal and maximal article numbers, respectively."
2382   :group 'gnus-group-foreign
2383   :version "23.1" ;; No Gnus
2384   :type 'string)
2385
2386 (autoload 'url-insert-file-contents "url-handlers")
2387 ;; FIXME:
2388 ;; - Add documentation, menu, key bindings, ...
2389
2390 (defun gnus-read-ephemeral-gmane-group (group start &optional range)
2391   "Read articles from Gmane group GROUP as an ephemeral group.
2392 START is the first article.  RANGE specifies how many articles
2393 are fetched.  The articles are downloaded via HTTP using the URL
2394 specified by `gnus-gmane-group-download-format'."
2395   ;; See <http://gmane.org/export.php> for more information.
2396   (interactive
2397    (list
2398     (gnus-group-completing-read "Gmane group")
2399     (read-number "Start article number: ")
2400     (read-number "How many articles: ")))
2401   (unless range (setq range 500))
2402   (when (< range 1)
2403     (error "Invalid range: %s" range))
2404   (let ((tmpfile (mm-make-temp-file
2405                   (format "%s.start-%s.range-%s." group start range)))
2406         (gnus-thread-sort-functions '(gnus-thread-sort-by-number)))
2407     (with-temp-file tmpfile
2408       (url-insert-file-contents
2409        (format gnus-gmane-group-download-format
2410                group start (+ start range)))
2411       (write-region (point-min) (point-max) tmpfile)
2412       (gnus-group-read-ephemeral-group
2413        (format "nndoc+ephemeral:%s.start-%s.range-%s" group start range)
2414        `(nndoc ,tmpfile
2415                (nndoc-article-type mbox))))
2416     (delete-file tmpfile)))
2417
2418 (defun gnus-read-ephemeral-gmane-group-url (url)
2419   "Create an ephemeral Gmane group from URL.
2420
2421 Valid input formats include:
2422 \"http://thread.gmane.org/gmane.foo.bar/12300/focus=12399\",
2423 \"http://thread.gmane.org/gmane.foo.bar/12345/\",
2424 \"http://article.gmane.org/gmane.foo.bar/12345/\",
2425 \"http://news.gmane.org/group/gmane.foo.bar/thread=12345\""
2426   ;; - Feel free to add other useful Gmane URLs here!  Maybe the URLs should
2427   ;;   be customizable?
2428   ;; - The URLs should be added to `gnus-button-alist'.  Probably we should
2429   ;;   prompt the user to decide: "View via `browse-url' or in Gnus? "
2430   ;;   (`gnus-read-ephemeral-gmane-group-url')
2431   (interactive
2432    (list (gnus-group-completing-read "Gmane URL")))
2433   (let (group start range)
2434     (cond
2435      ;; URLs providing `group', `start' and `range':
2436      ((string-match
2437        ;; http://thread.gmane.org/gmane.emacs.devel/86326/focus=86525
2438        "^http://thread\\.gmane\\.org/\\([^/]+\\)/\\([0-9]+\\)/focus=\\([0-9]+\\)$"
2439        url)
2440       (setq group (match-string 1 url)
2441             start (string-to-number (match-string 2 url))
2442             ;; Ensure that `range' is large enough to ensure focus article is
2443             ;; included.
2444             range (- (string-to-number (match-string 3 url))
2445                      start -1)))
2446      ;; URLs providing `group' and `start':
2447      ((or (string-match
2448            ;; http://article.gmane.org/gmane.comp.gnu.make.bugs/3584
2449            "^http://\\(?:thread\\|article\\|permalink\\)\\.gmane\\.org/\\([^/]+\\)/\\([0-9]+\\)"
2450            url)
2451           (string-match
2452            ;; Don't advertise these in the doc string yet:
2453            "^\\(?:nntp\\|news\\)://news\\.gmane\\.org/\\([^/]+\\)/\\([0-9]+\\)"
2454            url)
2455           (string-match
2456            ;; http://news.gmane.org/group/gmane.emacs.gnus.general/thread=65099/force_load=t
2457            "^http://news\\.gmane\\.org/group/\\([^/]+\\)/thread=\\([0-9]+\\)"
2458            url))
2459       (setq group (match-string 1 url)
2460             start (string-to-number (match-string 2 url))))
2461      (t
2462       (error "Can't parse URL %s" url)))
2463     (gnus-read-ephemeral-gmane-group group start range)))
2464
2465 (defcustom gnus-bug-group-download-format-alist
2466   '((emacs . "http://debbugs.gnu.org/cgi/bugreport.cgi?bug=%s;mboxmaint=yes;mboxstat=yes")
2467     (debian
2468      . "http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=%s&mbox=yes;mboxmaint=yes"))
2469   "Alist of symbols for bug trackers and the corresponding URL format string.
2470 The URL format string must contain a single \"%s\", specifying
2471 the bug number, and browsing the URL must return mbox output."
2472   :group 'gnus-group-foreign
2473   ;; Added mboxmaint=yes.  This gets the version with the messages as
2474   ;; they went out, not as they came in.
2475   ;; Eg bug-gnu-emacs is replaced by ###@debbugs.
2476   :version "24.1"
2477   :type '(repeat (cons (symbol) (string :tag "URL format string"))))
2478
2479 (defun gnus-read-ephemeral-bug-group (ids mbox-url &optional window-conf)
2480   "Browse bug NUMBER as ephemeral group."
2481   (interactive (list (read-string "Enter bug number: "
2482                                   (thing-at-point 'word) nil)
2483                      ;; FIXME: Add completing-read from
2484                      ;; `gnus-emacs-bug-group-download-format' ...
2485                      (cdr (assoc 'emacs gnus-bug-group-download-format-alist))))
2486   (when (stringp ids)
2487     (setq ids (string-to-number ids)))
2488   (unless (listp ids)
2489     (setq ids (list ids)))
2490   (let ((tmpfile (mm-make-temp-file "gnus-temp-group-")))
2491     (let ((coding-system-for-write 'binary)
2492           (coding-system-for-read 'binary))
2493       (with-temp-file tmpfile
2494         (mm-disable-multibyte)
2495         (dolist (id ids)
2496           (url-insert-file-contents (format mbox-url id)))
2497         (goto-char (point-min))
2498         ;; Add the debbugs address so that we can respond to reports easily.
2499         (while (re-search-forward "^To: " nil t)
2500           (end-of-line)
2501           (insert (format ", %s@%s" (car ids)
2502                           (gnus-replace-in-string
2503                            (gnus-replace-in-string mbox-url "^http://" "")
2504                            "/.*$" ""))))))
2505     (gnus-group-read-ephemeral-group
2506      (format "nndoc+ephemeral:bug#%s"
2507              (mapconcat 'number-to-string ids ","))
2508      `(nndoc ,tmpfile
2509              (nndoc-article-type mbox))
2510      nil window-conf)
2511     (delete-file tmpfile)))
2512
2513 (defun gnus-read-ephemeral-debian-bug-group (number)
2514   "Browse Debian bug NUMBER as ephemeral group."
2515   (interactive (list (read-string "Enter bug number: "
2516                                   (thing-at-point 'word) nil)))
2517   (gnus-read-ephemeral-bug-group
2518    number
2519    (cdr (assoc 'debian gnus-bug-group-download-format-alist))))
2520
2521 (defvar debbugs-gnu-bug-number)         ; debbugs-gnu
2522
2523 (defun gnus-read-ephemeral-emacs-bug-group (ids &optional window-conf)
2524   "Browse Emacs bugs IDS as an ephemeral group."
2525   (interactive (list (string-to-number
2526                       (read-string "Enter bug number: "
2527                                    (thing-at-point 'word) nil))))
2528   (unless (listp ids)
2529     (setq ids (list ids)))
2530   (gnus-read-ephemeral-bug-group
2531    ids
2532    (cdr (assoc 'emacs gnus-bug-group-download-format-alist))
2533    window-conf)
2534   (when (fboundp 'debbugs-gnu-summary-mode)
2535     (with-current-buffer (window-buffer (selected-window))
2536       (debbugs-gnu-summary-mode 1)
2537       (set (make-local-variable 'debbugs-gnu-bug-number) (car ids)))))
2538
2539 (defun gnus-group-jump-to-group (group &optional prompt)
2540   "Jump to newsgroup GROUP.
2541
2542 If PROMPT (the prefix) is a number, use the prompt specified in
2543 `gnus-group-jump-to-group-prompt'."
2544   (interactive
2545    (list (gnus-group-completing-read
2546           nil nil nil
2547           (if current-prefix-arg
2548               (cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt))
2549             (or (and (stringp gnus-group-jump-to-group-prompt)
2550                      gnus-group-jump-to-group-prompt)
2551                 (let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt))))
2552                   (and (stringp p) p)))))))
2553
2554   (when (equal group "")
2555     (error "Empty group name"))
2556
2557   (unless (gnus-ephemeral-group-p group)
2558     ;; Either go to the line in the group buffer...
2559     (unless (gnus-group-goto-group group)
2560       ;; ... or insert the line.
2561       (gnus-group-update-group group)
2562       (gnus-group-goto-group group)))
2563   ;; Adjust cursor point.
2564   (gnus-group-position-point))
2565
2566 (defun gnus-group-goto-group (group &optional far test-marked)
2567   "Goto to newsgroup GROUP.
2568 If FAR, it is likely that the group is not on the current line.
2569 If TEST-MARKED, the line must be marked."
2570   (when group
2571     (beginning-of-line)
2572     (cond
2573      ;; It's quite likely that we are on the right line, so
2574      ;; we check the current line first.
2575      ((and (not far)
2576            (eq (get-text-property (point) 'gnus-group)
2577                (gnus-intern-safe group gnus-active-hashtb))
2578            (or (not test-marked) (gnus-group-mark-line-p)))
2579       (point))
2580      ;; Previous and next line are also likely, so we check them as well.
2581      ((and (not far)
2582            (save-excursion
2583              (forward-line -1)
2584              (and (eq (get-text-property (point) 'gnus-group)
2585                       (gnus-intern-safe group gnus-active-hashtb))
2586                   (or (not test-marked) (gnus-group-mark-line-p)))))
2587       (forward-line -1)
2588       (point))
2589      ((and (not far)
2590            (save-excursion
2591              (forward-line 1)
2592              (and (eq (get-text-property (point) 'gnus-group)
2593                       (gnus-intern-safe group gnus-active-hashtb))
2594                   (or (not test-marked) (gnus-group-mark-line-p)))))
2595       (forward-line 1)
2596       (point))
2597      (test-marked
2598       (goto-char (point-min))
2599       (let (found)
2600         (while (and (not found)
2601                     (gnus-goto-char
2602                      (text-property-any
2603                       (point) (point-max)
2604                       'gnus-group
2605                       (gnus-intern-safe group gnus-active-hashtb))))
2606           (if (gnus-group-mark-line-p)
2607               (setq found t)
2608             (forward-line 1)))
2609         found))
2610      (t
2611       ;; Search through the entire buffer.
2612       (gnus-goto-char
2613        (text-property-any
2614         (point-min) (point-max)
2615         'gnus-group (gnus-intern-safe group gnus-active-hashtb)))))))
2616
2617 (defun gnus-group-next-group (n &optional silent)
2618   "Go to next N'th newsgroup.
2619 If N is negative, search backward instead.
2620 Returns the difference between N and the number of skips actually
2621 done."
2622   (interactive "p")
2623   (gnus-group-next-unread-group n t nil silent))
2624
2625 (defun gnus-group-next-unread-group (n &optional all level silent)
2626   "Go to next N'th unread newsgroup.
2627 If N is negative, search backward instead.
2628 If ALL is non-nil, choose any newsgroup, unread or not.
2629 If LEVEL is non-nil, choose the next group with level LEVEL, or, if no
2630 such group can be found, the next group with a level higher than
2631 LEVEL.
2632 Returns the difference between N and the number of skips actually
2633 made."
2634   (interactive "p")
2635   (let ((backward (< n 0))
2636         (n (abs n)))
2637     (while (and (> n 0)
2638                 (gnus-group-search-forward
2639                  backward (or (not gnus-group-goto-unread) all) level))
2640       (setq n (1- n)))
2641     (when (and (/= 0 n)
2642                (not silent))
2643       (gnus-message 7 "No more%s newsgroups%s" (if all "" " unread")
2644                     (if level " on this level or higher" "")))
2645     n))
2646
2647 (defun gnus-group-prev-group (n)
2648   "Go to previous N'th newsgroup.
2649 Returns the difference between N and the number of skips actually
2650 done."
2651   (interactive "p")
2652   (gnus-group-next-unread-group (- n) t))
2653
2654 (defun gnus-group-prev-unread-group (n)
2655   "Go to previous N'th unread newsgroup.
2656 Returns the difference between N and the number of skips actually
2657 done."
2658   (interactive "p")
2659   (gnus-group-next-unread-group (- n)))
2660
2661 (defun gnus-group-next-unread-group-same-level (n)
2662   "Go to next N'th unread newsgroup on the same level.
2663 If N is negative, search backward instead.
2664 Returns the difference between N and the number of skips actually
2665 done."
2666   (interactive "p")
2667   (gnus-group-next-unread-group n t (gnus-group-group-level))
2668   (gnus-group-position-point))
2669
2670 (defun gnus-group-prev-unread-group-same-level (n)
2671   "Go to next N'th unread newsgroup on the same level.
2672 Returns the difference between N and the number of skips actually
2673 done."
2674   (interactive "p")
2675   (gnus-group-next-unread-group (- n) t (gnus-group-group-level))
2676   (gnus-group-position-point))
2677
2678 (defun gnus-group-best-unread-group (&optional exclude-group)
2679   "Go to the group with the highest level.
2680 If EXCLUDE-GROUP, do not go to that group."
2681   (interactive)
2682   (goto-char (point-min))
2683   (let ((best 100000)
2684         unread best-point)
2685     (while (not (eobp))
2686       (setq unread (get-text-property (point) 'gnus-unread))
2687       (when (and (numberp unread) (> unread 0))
2688         (when (and (get-text-property (point) 'gnus-level)
2689                    (< (get-text-property (point) 'gnus-level) best)
2690                    (or (not exclude-group)
2691                        (not (equal exclude-group (gnus-group-group-name)))))
2692           (setq best (get-text-property (point) 'gnus-level))
2693           (setq best-point (point))))
2694       (forward-line 1))
2695     (when best-point
2696       (goto-char best-point))
2697     (gnus-group-position-point)
2698     (and best-point (gnus-group-group-name))))
2699
2700 ;; Is there something like an after-point-motion-hook?
2701 ;; (inhibit-point-motion-hooks?).  Is there a tool-bar-update function?
2702
2703 ;; (defun gnus-group-menu-bar-update ()
2704 ;;   (let* ((buf (list (with-current-buffer gnus-group-buffer
2705 ;;                    (current-buffer))))
2706 ;;       (name (buffer-name (car buf))))
2707 ;;     (setcdr buf
2708 ;;          (if (> (length name) 27)
2709 ;;              (concat (substring name 0 12)
2710 ;;                      "..."
2711 ;;                      (substring name -12))
2712 ;;            name))
2713 ;;     (menu-bar-update-buffers-1 buf)))
2714
2715 ;; (defun gnus-group-position-point ()
2716 ;;   (gnus-goto-colon)
2717 ;;   (gnus-group-menu-bar-update))
2718
2719 (defun gnus-group-first-unread-group ()
2720   "Go to the first group with unread articles."
2721   (interactive)
2722   (prog1
2723       (let ((opoint (point))
2724             unread)
2725         (goto-char (point-min))
2726         (if (or (eq (setq unread (gnus-group-group-unread)) t) ; Not active.
2727                 (and (numberp unread)   ; Not a topic.
2728                      (not (zerop unread))) ; Has unread articles.
2729                 (zerop (gnus-group-next-unread-group 1))) ; Next unread group.
2730             (point)                     ; Success.
2731           (goto-char opoint)
2732           nil))                         ; Not success.
2733     (gnus-group-position-point)))
2734
2735 (defun gnus-group-enter-server-mode ()
2736   "Jump to the server buffer."
2737   (interactive)
2738   (gnus-enter-server-buffer))
2739
2740 (defun gnus-group-make-group-simple (&optional group)
2741   "Add a new newsgroup.
2742 The user will be prompted for GROUP."
2743   (interactive (list (gnus-group-completing-read)))
2744   (gnus-group-make-group (gnus-group-real-name group)
2745                          (gnus-group-server group)
2746                          nil nil t))
2747
2748 (defun gnus-group-make-group (name &optional method address args encoded)
2749   "Add a new newsgroup.
2750 The user will be prompted for a NAME, for a select METHOD, and an
2751 ADDRESS.  NAME should be a human-readable string (i.e., not be encoded
2752 even if it contains non-ASCII characters) unless ENCODED is non-nil.
2753
2754 If the backend supports it, the group will also be created on the
2755 server."
2756   (interactive
2757    (list
2758     (gnus-read-group "Group name: ")
2759     (gnus-read-method "Select method for new group (use tab for completion)")))
2760
2761   (when (stringp method)
2762     (setq method (or (gnus-server-to-method method) method)))
2763   (unless encoded
2764     (setq name (mm-encode-coding-string
2765                 name
2766                 (gnus-group-name-charset method name))))
2767   (let* ((meth (gnus-method-simplify
2768                 (when (and method
2769                            (not (gnus-server-equal method gnus-select-method)))
2770                   (if address (list (intern method) address)
2771                     method))))
2772          (nname (if method (gnus-group-prefixed-name name meth) name))
2773          backend info)
2774     (when (gnus-group-entry nname)
2775       (error "Group %s already exists" (gnus-group-decoded-name nname)))
2776     ;; Subscribe to the new group.
2777     (gnus-group-change-level
2778      (setq info (list t nname gnus-level-default-subscribed nil nil meth))
2779      gnus-level-default-subscribed gnus-level-killed
2780      (and (gnus-group-group-name)
2781           (gnus-group-entry (gnus-group-group-name)))
2782      t)
2783     ;; Make it active.
2784     (gnus-set-active nname (cons 1 0))
2785     (unless (gnus-ephemeral-group-p name)
2786       (gnus-dribble-enter
2787        (concat "(gnus-group-set-info '"
2788                (gnus-prin1-to-string (cdr info)) ")")
2789        (concat "^(gnus-group-set-info '(\"" (regexp-quote name) "\"")))
2790     ;; Insert the line.
2791     (gnus-group-insert-group-line-info nname)
2792     (forward-line -1)
2793     (gnus-group-position-point)
2794
2795     ;; Load the back end and try to make the back end create
2796     ;; the group as well.
2797     (when (assoc (symbol-name (setq backend (car (gnus-server-get-method
2798                                                   nil meth))))
2799                  gnus-valid-select-methods)
2800       (require backend))
2801     (gnus-check-server meth)
2802     (when (gnus-check-backend-function 'request-create-group nname)
2803       (unless (gnus-request-create-group nname nil args)
2804         (error "Could not create group on server: %s"
2805                (nnheader-get-report backend))))
2806     t))
2807
2808 (defun gnus-group-delete-groups (&optional arg)
2809   "Delete the current group.  Only meaningful with editable groups."
2810   (interactive "P")
2811   (let ((n (length (gnus-group-process-prefix arg))))
2812     (when (gnus-yes-or-no-p
2813            (if (= n 1)
2814                "Delete this 1 group? "
2815              (format "Delete these %d groups? " n)))
2816       (gnus-group-iterate arg
2817         (lambda (group)
2818           (gnus-group-delete-group group nil t))))))
2819
2820 (defun gnus-group-delete-articles (group &optional oldp)
2821   "Delete all articles in the current group.
2822 If OLDP (the prefix), only delete articles that are \"old\",
2823 according to the expiry settings.  Note that this will delete old
2824 not-expirable articles, too."
2825   (interactive (list (gnus-group-group-name)
2826                      current-prefix-arg))
2827   (let ((articles (gnus-uncompress-range (gnus-active group))))
2828     (when (gnus-yes-or-no-p
2829            (format "Do you really want to delete these %d articles forever? "
2830                    (length articles)))
2831       (gnus-request-expire-articles articles group
2832                                     (if current-prefix-arg
2833                                         nil
2834                                       'force)))))
2835
2836 (defun gnus-group-delete-group (group &optional force no-prompt)
2837   "Delete the current group.  Only meaningful with editable groups.
2838 If FORCE (the prefix) is non-nil, all the articles in the group will
2839 be deleted.  This is \"deleted\" as in \"removed forever from the face
2840 of the Earth\".  There is no undo.  The user will be prompted before
2841 doing the deletion.
2842 Note that you also have to specify FORCE if you want the group to
2843 be removed from the server, even when it's empty."
2844   (interactive
2845    (list (gnus-group-group-name)
2846          current-prefix-arg))
2847   (unless group
2848     (error "No group to delete"))
2849   (unless (gnus-check-backend-function 'request-delete-group group)
2850     (error "This back end does not support group deletion"))
2851   (prog1
2852       (let ((group-decoded (gnus-group-decoded-name group)))
2853         (if (and (not no-prompt)
2854                  (not (gnus-yes-or-no-p
2855                        (format
2856                         "Do you really want to delete %s%s? "
2857                         group-decoded (if force " and all its contents" "")))))
2858             ()                          ; Whew!
2859           (gnus-message 6 "Deleting group %s..." group-decoded)
2860           (if (not (gnus-request-delete-group group force))
2861               (gnus-error 3 "Couldn't delete group %s" group-decoded)
2862             (gnus-message 6 "Deleting group %s...done" group-decoded)
2863             (gnus-group-goto-group group)
2864             (gnus-group-kill-group 1 t)
2865             (gnus-set-active group nil)
2866             t)))
2867     (gnus-group-position-point)))
2868
2869 (defun gnus-group-rename-group (group new-name)
2870   "Rename group from GROUP to NEW-NAME.
2871 When used interactively, GROUP is the group under point
2872 and NEW-NAME will be prompted for."
2873   (interactive
2874    (let ((group (gnus-group-group-name))
2875          method new-name)
2876      (unless (gnus-check-backend-function 'request-rename-group group)
2877        (error "This back end does not support renaming groups"))
2878      (setq new-name (gnus-read-group
2879                      "Rename group to: "
2880                      (gnus-group-real-name (gnus-group-decoded-name group)))
2881            method (gnus-info-method (gnus-get-info group)))
2882      (list group (mm-encode-coding-string
2883                   new-name
2884                   (gnus-group-name-charset
2885                    method
2886                    (gnus-group-prefixed-name new-name method))))))
2887
2888   (unless (gnus-check-backend-function 'request-rename-group group)
2889     (error "This back end does not support renaming groups"))
2890   (unless group
2891     (error "No group to rename"))
2892   (when (equal (gnus-group-real-name group) new-name)
2893     (error "Can't rename to the same name"))
2894
2895   ;; We find the proper prefixed name.
2896   (setq new-name
2897         (if (gnus-group-native-p group)
2898             ;; Native group.
2899             new-name
2900           ;; Foreign group.
2901           (gnus-group-prefixed-name
2902            (gnus-group-real-name new-name)
2903            (gnus-info-method (gnus-get-info group)))))
2904
2905   (let ((decoded-group (gnus-group-decoded-name group))
2906         (decoded-new-name (gnus-group-decoded-name new-name)))
2907     (when (gnus-active new-name)
2908       (error "The group %s already exists" decoded-new-name))
2909
2910     (gnus-message 6 "Renaming group %s to %s..."
2911                   decoded-group decoded-new-name)
2912     (prog1
2913         (if (progn
2914               (gnus-group-goto-group group)
2915               (not (when (< (gnus-group-group-level) gnus-level-zombie)
2916                      (gnus-request-rename-group group new-name))))
2917             (gnus-error 3 "Couldn't rename group %s to %s"
2918                         decoded-group decoded-new-name)
2919           ;; We rename the group internally by killing it...
2920           (gnus-group-kill-group)
2921           ;; ... changing its name ...
2922           (setcar (cdar gnus-list-of-killed-groups) new-name)
2923           ;; ... and then yanking it.  Magic!
2924           (gnus-group-yank-group)
2925           (gnus-set-active new-name (gnus-active group))
2926           (gnus-message 6 "Renaming group %s to %s...done"
2927                         decoded-group decoded-new-name)
2928           new-name)
2929       (setq gnus-killed-list (delete group gnus-killed-list))
2930       (gnus-set-active group nil)
2931       (gnus-dribble-touch)
2932       (gnus-group-position-point))))
2933
2934 (defun gnus-group-edit-group (group &optional part)
2935   "Edit the group on the current line."
2936   (interactive (list (gnus-group-group-name)))
2937   (let ((part (or part 'info))
2938         info)
2939     (unless group
2940       (error "No group on current line"))
2941     (unless (setq info (gnus-get-info group))
2942       (error "Killed group; can't be edited"))
2943     (ignore-errors
2944       (gnus-close-group group))
2945     (gnus-edit-form
2946      ;; Find the proper form to edit.
2947      (cond ((eq part 'method)
2948             (or (gnus-info-method info) "native"))
2949            ((eq part 'params)
2950             (gnus-info-params info))
2951            (t info))
2952      ;; The proper documentation.
2953      (gnus-format-message
2954       "Editing the %s for `%s'."
2955       (cond
2956        ((eq part 'method) "select method")
2957        ((eq part 'params) "group parameters")
2958        (t "group info"))
2959       (gnus-group-decoded-name group))
2960      `(lambda (form)
2961         (gnus-group-edit-group-done ',part ,group form)))
2962     (local-set-key
2963      "\C-c\C-i"
2964      (gnus-create-info-command
2965       (cond
2966        ((eq part 'method)
2967         "(gnus)Select Methods")
2968        ((eq part 'params)
2969         "(gnus)Group Parameters")
2970        (t
2971         "(gnus)Group Info"))))))
2972
2973 (defun gnus-group-edit-group-method (group)
2974   "Edit the select method of GROUP."
2975   (interactive (list (gnus-group-group-name)))
2976   (gnus-group-edit-group group 'method))
2977
2978 (defun gnus-group-edit-group-parameters (group)
2979   "Edit the group parameters of GROUP."
2980   (interactive (list (gnus-group-group-name)))
2981   (gnus-group-edit-group group 'params))
2982
2983 (defun gnus-group-edit-group-done (part group form)
2984   "Update variables."
2985   (let* ((method (cond ((eq part 'info) (nth 4 form))
2986                        ((eq part 'method) form)
2987                        (t nil)))
2988          (info (cond ((eq part 'info) form)
2989                      ((eq part 'method) (gnus-get-info group))
2990                      (t nil)))
2991          (new-group (if info
2992                         (if (or (not method)
2993                                 (gnus-server-equal
2994                                  gnus-select-method method))
2995                             (gnus-group-real-name (car info))
2996                           (gnus-group-prefixed-name
2997                            (gnus-group-real-name (car info)) method))
2998                       nil)))
2999     (when (and new-group
3000                (not (equal new-group group)))
3001       (when (gnus-group-goto-group group)
3002         (gnus-group-kill-group 1))
3003       (gnus-activate-group new-group))
3004     ;; Set the info.
3005     (if (not (and info new-group))
3006         (gnus-group-set-info form (or new-group group) part)
3007       (setq info (gnus-copy-sequence info))
3008       (setcar info new-group)
3009       (unless (gnus-server-equal method "native")
3010         (unless (nthcdr 3 info)
3011           (nconc info (list nil nil)))
3012         (unless (nthcdr 4 info)
3013           (nconc info (list nil)))
3014         (gnus-info-set-method info method))
3015       (gnus-group-set-info info))
3016     (gnus-group-update-group (or new-group group))
3017     (gnus-group-position-point)))
3018
3019 (defun gnus-group-make-useful-group (group method)
3020   "Create one of the groups described in `gnus-useful-groups'."
3021   (interactive
3022    (let ((entry (assoc (gnus-completing-read "Create group"
3023                                              (mapcar 'car gnus-useful-groups)
3024                                              t)
3025                        gnus-useful-groups)))
3026      (list (cadr entry)
3027            ;; Don't use `caddr' here since macros within the `interactive'
3028            ;; form won't be expanded.
3029            (car (cddr entry)))))
3030   (setq method (gnus-copy-sequence method))
3031   (let (entry)
3032     (while (setq entry (memq (assq 'eval method) method))
3033       (setcar entry (eval (cadar entry)))))
3034   (gnus-group-make-group group method))
3035
3036 (defun gnus-group-make-help-group (&optional noerror)
3037   "Create the Gnus documentation group.
3038 Optional argument NOERROR modifies the behavior of this function when the
3039 group already exists:
3040 - if not given, and error is signaled,
3041 - if t, stay silent,
3042 - if anything else, just print a message."
3043   (interactive)
3044   (let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help")))
3045         (file (nnheader-find-etc-directory "gnus-tut.txt" t)))
3046     (if (gnus-group-entry name)
3047         (cond ((eq noerror nil)
3048                (error "Documentation group already exists"))
3049               ((eq noerror t)
3050                ;; stay silent
3051                )
3052               (t
3053                (gnus-message 1 "Documentation group already exists")))
3054       ;; else:
3055       (if (not file)
3056           (gnus-message 1 "Couldn't find doc group")
3057         (gnus-group-make-group
3058          (gnus-group-real-name name)
3059          (list 'nndoc "gnus-help"
3060                (list 'nndoc-address file)
3061                (list 'nndoc-article-type 'mbox))))
3062       ))
3063   (gnus-group-position-point))
3064
3065 (defun gnus-group-make-doc-group (file type)
3066   "Create a group that uses a single file as the source.
3067
3068 If called with a prefix argument, ask for the file type."
3069   (interactive
3070    (list (read-file-name "File name: ")
3071          (and current-prefix-arg 'ask)))
3072   (when (eq type 'ask)
3073     (let ((err "")
3074           char found)
3075       (while (not found)
3076         (message
3077          "%sFile type (mbox, babyl, digest, forward, mmdf, guess) [m, b, d, f, a, g]: "
3078          err)
3079         (setq found (cond ((= (setq char (read-char)) ?m) 'mbox)
3080                           ((= char ?b) 'babyl)
3081                           ((= char ?d) 'digest)
3082                           ((= char ?f) 'forward)
3083                           ((= char ?a) 'mmfd)
3084                           ((= char ?g) 'guess)
3085                           (t (setq err (format "%c unknown. " char))
3086                              nil))))
3087       (setq type found)))
3088   (setq file (expand-file-name file))
3089   (let* ((name (gnus-generate-new-group-name
3090                 (gnus-group-prefixed-name
3091                  (file-name-nondirectory file) '(nndoc ""))))
3092          (method (list 'nndoc file
3093                        (list 'nndoc-address file)
3094                        (list 'nndoc-article-type (or type 'guess))))
3095          (coding (gnus-group-name-charset method name)))
3096     (setcar (cdr method) (mm-encode-coding-string file coding))
3097     (gnus-group-make-group
3098      (mm-encode-coding-string (gnus-group-real-name name) coding)
3099      method nil nil t)))
3100
3101 (defvar nnweb-type-definition)
3102 (defvar gnus-group-web-type-history nil)
3103 (defvar gnus-group-web-search-history nil)
3104 (defun gnus-group-make-web-group (&optional solid)
3105   "Create an ephemeral nnweb group.
3106 If SOLID (the prefix), create a solid group."
3107   (interactive "P")
3108   (require 'nnweb)
3109   (let* ((group
3110           (if solid (gnus-read-group "Group name: ")
3111             (message-unique-id)))
3112          (default-type (or (car gnus-group-web-type-history)
3113                            (symbol-name (caar nnweb-type-definition))))
3114          (type
3115           (gnus-string-or
3116            (gnus-completing-read
3117             "Search engine type"
3118             (mapcar (lambda (elem) (symbol-name (car elem)))
3119                     nnweb-type-definition)
3120             t nil 'gnus-group-web-type-history)
3121            default-type))
3122          (search
3123           (read-string
3124            "Search string: "
3125            (cons (or (car gnus-group-web-search-history) "") 0)
3126            'gnus-group-web-search-history))
3127          (method
3128           `(nnweb ,group (nnweb-search ,search)
3129                   (nnweb-type ,(intern type))
3130                   (nnweb-ephemeral-p t))))
3131     (if solid
3132         (progn
3133           (gnus-alist-pull 'nnweb-ephemeral-p method)
3134           (gnus-group-make-group group method))
3135       (gnus-group-read-ephemeral-group
3136        group method t
3137        (cons (current-buffer)
3138              (if (derived-mode-p 'gnus-summary-mode) 'summary 'group))))))
3139
3140 (defvar nnrss-group-alist)
3141 (eval-when-compile
3142   (defun nnrss-discover-feed (_arg))
3143   (defun nnrss-save-server-data (_arg)))
3144 (defun gnus-group-make-rss-group (&optional url)
3145   "Given a URL, discover if there is an RSS feed.
3146 If there is, use Gnus to create an nnrss group"
3147   (interactive)
3148   (require 'nnrss)
3149   (if (not url)
3150       (setq url (read-from-minibuffer "URL to Search for RSS: ")))
3151   (let ((feedinfo (nnrss-discover-feed url)))
3152     (if feedinfo
3153         (let* ((title (gnus-newsgroup-savable-name
3154                        (read-from-minibuffer "Title: "
3155                                              (gnus-newsgroup-savable-name
3156                                               (mapconcat
3157                                                'identity
3158                                                (split-string
3159                                                 (or (cdr (assoc 'title
3160                                                                 feedinfo))
3161                                                     ""))
3162                                                " ")))))
3163                (desc  (read-from-minibuffer "Description: "
3164                                             (mapconcat
3165                                              'identity
3166                                              (split-string
3167                                               (or (cdr (assoc 'description
3168                                                               feedinfo))
3169                                                   ""))
3170                                              " ")))
3171                (href (cdr (assoc 'href feedinfo)))
3172                (coding (gnus-group-name-charset '(nnrss "") title)))
3173           (when coding
3174             ;; Unify non-ASCII text.
3175             (setq title (mm-decode-coding-string
3176                          (mm-encode-coding-string title coding)
3177                          coding)))
3178           (gnus-group-make-group title '(nnrss ""))
3179           (push (list title href desc) nnrss-group-alist)
3180           (nnrss-save-server-data nil))
3181       (error "No feeds found for %s" url))))
3182
3183 (defun gnus-group-make-directory-group (dir)
3184   "Create an nndir group.
3185 The user will be prompted for a directory.  The contents of this
3186 directory will be used as a newsgroup.  The directory should contain
3187 mail messages or news articles in files that have numeric names."
3188   (interactive
3189    (list (read-directory-name "Create group from directory: ")))
3190   (unless (file-exists-p dir)
3191     (error "No such directory"))
3192   (unless (file-directory-p dir)
3193     (error "Not a directory"))
3194   (let ((ext "")
3195         (i 0)
3196         group)
3197     (while (or (not group) (gnus-group-entry group))
3198       (setq group
3199             (gnus-group-prefixed-name
3200              (expand-file-name ext dir)
3201              '(nndir "")))
3202       (setq ext (format "<%d>" (setq i (1+ i)))))
3203     (gnus-group-make-group
3204      (gnus-group-real-name group)
3205      (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir)))))
3206
3207 (defun gnus-group-add-to-virtual (n vgroup)
3208   "Add the current group to a virtual group."
3209   (interactive
3210    (list current-prefix-arg
3211          (gnus-group-completing-read "Add to virtual group"
3212                                      nil t "nnvirtual:")))
3213   (unless (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual)
3214     (error "%s is not an nnvirtual group" vgroup))
3215   (gnus-close-group vgroup)
3216   (let* ((groups (gnus-group-process-prefix n))
3217          (method (gnus-info-method (gnus-get-info vgroup))))
3218     (setcar (cdr method)
3219             (concat
3220              (nth 1 method) "\\|"
3221              (mapconcat
3222               (lambda (s)
3223                 (gnus-group-remove-mark s)
3224                 (concat "\\(^" (regexp-quote s) "$\\)"))
3225               groups "\\|"))))
3226   (gnus-group-position-point))
3227
3228 (defun gnus-group-make-empty-virtual (group)
3229   "Create a new, fresh, empty virtual group."
3230   (interactive "sCreate new, empty virtual group: ")
3231   (let* ((method (list 'nnvirtual "^$"))
3232          (pgroup (gnus-group-prefixed-name group method)))
3233     ;; Check whether it exists already.
3234     (when (gnus-group-entry pgroup)
3235       (error "Group %s already exists" pgroup))
3236     ;; Subscribe the new group after the group on the current line.
3237     (gnus-subscribe-group pgroup (gnus-group-group-name) method)
3238     (gnus-group-update-group pgroup)
3239     (forward-line -1)
3240     (gnus-group-position-point)))
3241
3242 (defun gnus-group-enter-directory (dir)
3243   "Enter an ephemeral nneething group."
3244   (interactive "DDirectory to read: ")
3245   (let* ((method (list 'nneething dir '(nneething-read-only t)))
3246          (leaf (gnus-group-prefixed-name
3247                 (file-name-nondirectory (directory-file-name dir))
3248                 method))
3249          (name (gnus-generate-new-group-name leaf)))
3250     (unless (gnus-group-read-ephemeral-group
3251              name method t
3252              (cons (current-buffer)
3253                    (if (derived-mode-p 'gnus-summary-mode)
3254                        'summary 'group)))
3255       (error "Couldn't enter %s" dir))))
3256
3257 (defun gnus-group-expunge-group (group)
3258   "Expunge deleted articles in current nnimap GROUP."
3259   (interactive (list (gnus-group-group-name)))
3260   (let ((method (gnus-find-method-for-group group)))
3261     (if (not (gnus-check-backend-function
3262               'request-expunge-group (car method)))
3263         (error "%s does not support expunging" (car method))
3264       (gnus-request-expunge-group group method))))
3265
3266 (autoload 'nnimap-acl-get "nnimap")
3267 (autoload 'nnimap-acl-edit "nnimap")
3268
3269 (defun gnus-group-nnimap-edit-acl (group)
3270   "Edit the Access Control List of current nnimap GROUP."
3271   (interactive (list (gnus-group-group-name)))
3272   (let ((mailbox (gnus-group-real-name group)) method acl)
3273     (unless group
3274       (error "No group on current line"))
3275     (unless (gnus-get-info group)
3276       (error "Killed group; can't be edited"))
3277     (unless (eq (car (setq method (gnus-find-method-for-group group))) 'nnimap)
3278       (error "%s is not an nnimap group" group))
3279     (unless (setq acl (nnimap-acl-get mailbox (cadr method)))
3280       (error "Server does not support ACL's"))
3281     (gnus-edit-form acl (gnus-format-message "\
3282 Editing the access control list for `%s'.
3283
3284    An access control list is a list of (identifier . rights) elements.
3285
3286    The identifier string specifies the corresponding user.  The
3287    identifier \"anyone\" is reserved to refer to the universal identity.
3288
3289    Rights is a string listing a (possibly empty) set of alphanumeric
3290    characters, each character listing a set of operations which is being
3291    controlled.  Letters are reserved for \"standard\" rights, listed
3292    below.  Digits are reserved for implementation or site defined rights.
3293
3294    l - lookup (mailbox is visible to LIST/LSUB commands)
3295    r - read (SELECT the mailbox, perform CHECK, FETCH, PARTIAL,
3296        SEARCH, COPY from mailbox)
3297    s - keep seen/unseen information across sessions (STORE \\SEEN flag)
3298    w - write (STORE flags other than \\SEEN and \\DELETED)
3299    i - insert (perform APPEND, COPY into mailbox)
3300    p - post (send mail to submission address for mailbox,
3301        not enforced by IMAP4 itself)
3302    c - create and delete mailbox (CREATE new sub-mailboxes in any
3303        implementation-defined hierarchy, RENAME or DELETE mailbox)
3304    d - delete messages (STORE \\DELETED flag, perform EXPUNGE)
3305    a - administer (perform SETACL)" group)
3306                     `(lambda (form)
3307                        (nnimap-acl-edit
3308                         ,mailbox ',method ',acl form)))))
3309
3310 ;; Group sorting commands
3311 ;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>.
3312
3313 (defun gnus-group-sort-groups (func &optional reverse)
3314   "Sort the group buffer according to FUNC.
3315 When used interactively, the sorting function used will be
3316 determined by the `gnus-group-sort-function' variable.
3317 If REVERSE (the prefix), reverse the sorting order."
3318   (interactive (list gnus-group-sort-function current-prefix-arg))
3319   (funcall gnus-group-sort-alist-function
3320            (gnus-make-sort-function func) reverse)
3321   (gnus-group-unmark-all-groups)
3322   (gnus-group-list-groups)
3323   (gnus-dribble-touch))
3324
3325 (defun gnus-group-sort-flat (func reverse)
3326   ;; We peel off the dummy group from the alist.
3327   (when func
3328     (when (equal (gnus-info-group (car gnus-newsrc-alist)) "dummy.group")
3329       (pop gnus-newsrc-alist))
3330     ;; Do the sorting.
3331     (setq gnus-newsrc-alist
3332           (sort gnus-newsrc-alist func))
3333     (when reverse
3334       (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist)))
3335     ;; Regenerate the hash table.
3336     (gnus-make-hashtable-from-newsrc-alist)))
3337
3338 (defun gnus-group-sort-groups-by-alphabet (&optional reverse)
3339   "Sort the group buffer alphabetically by group name.
3340 If REVERSE, sort in reverse order."
3341   (interactive "P")
3342   (gnus-group-sort-groups 'gnus-group-sort-by-alphabet reverse))
3343
3344 (defun gnus-group-sort-groups-by-real-name (&optional reverse)
3345   "Sort the group buffer alphabetically by real (unprefixed) group name.
3346 If REVERSE, sort in reverse order."
3347   (interactive "P")
3348   (gnus-group-sort-groups 'gnus-group-sort-by-real-name reverse))
3349
3350 (defun gnus-group-sort-groups-by-unread (&optional reverse)
3351   "Sort the group buffer by number of unread articles.
3352 If REVERSE, sort in reverse order."
3353   (interactive "P")
3354   (gnus-group-sort-groups 'gnus-group-sort-by-unread reverse))
3355
3356 (defun gnus-group-sort-groups-by-level (&optional reverse)
3357   "Sort the group buffer by group level.
3358 If REVERSE, sort in reverse order."
3359   (interactive "P")
3360   (gnus-group-sort-groups 'gnus-group-sort-by-level reverse))
3361
3362 (defun gnus-group-sort-groups-by-score (&optional reverse)
3363   "Sort the group buffer by group score.
3364 If REVERSE, sort in reverse order."
3365   (interactive "P")
3366   (gnus-group-sort-groups 'gnus-group-sort-by-score reverse))
3367
3368 (defun gnus-group-sort-groups-by-rank (&optional reverse)
3369   "Sort the group buffer by group rank.
3370 If REVERSE, sort in reverse order."
3371   (interactive "P")
3372   (gnus-group-sort-groups 'gnus-group-sort-by-rank reverse))
3373
3374 (defun gnus-group-sort-groups-by-method (&optional reverse)
3375   "Sort the group buffer alphabetically by back end name.
3376 If REVERSE, sort in reverse order."
3377   (interactive "P")
3378   (gnus-group-sort-groups 'gnus-group-sort-by-method reverse))
3379
3380 (defun gnus-group-sort-groups-by-server (&optional reverse)
3381   "Sort the group buffer alphabetically by server name.
3382 If REVERSE, sort in reverse order."
3383   (interactive "P")
3384   (gnus-group-sort-groups 'gnus-group-sort-by-server reverse))
3385
3386 ;;; Selected group sorting.
3387
3388 (defun gnus-group-sort-selected-groups (n func &optional reverse)
3389   "Sort the process/prefixed groups."
3390   (interactive (list current-prefix-arg gnus-group-sort-function))
3391   (let ((groups (gnus-group-process-prefix n)))
3392     (funcall gnus-group-sort-selected-function
3393              groups (gnus-make-sort-function func) reverse)
3394     (gnus-group-unmark-all-groups)
3395     (gnus-group-list-groups)
3396     (gnus-dribble-touch)))
3397
3398 (defun gnus-group-sort-selected-flat (groups func reverse)
3399   (let (entries infos)
3400     ;; First find all the group entries for these groups.
3401     (while groups
3402       (push (nthcdr 2 (gnus-group-entry (pop groups)))
3403             entries))
3404     ;; Then sort the infos.
3405     (setq infos
3406           (sort
3407            (mapcar
3408             (lambda (entry) (car entry))
3409             (setq entries (nreverse entries)))
3410            func))
3411     (when reverse
3412       (setq infos (nreverse infos)))
3413     ;; Go through all the infos and replace the old entries
3414     ;; with the new infos.
3415     (while infos
3416       (setcar (car entries) (pop infos))
3417       (pop entries))
3418     ;; Update the hashtable.
3419     (gnus-make-hashtable-from-newsrc-alist)))
3420
3421 (defun gnus-group-sort-selected-groups-by-alphabet (&optional n reverse)
3422   "Sort the group buffer alphabetically by group name.
3423 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3424 sort in reverse order."
3425   (interactive (gnus-interactive "P\ny"))
3426   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-alphabet reverse))
3427
3428 (defun gnus-group-sort-selected-groups-by-real-name (&optional n reverse)
3429   "Sort the group buffer alphabetically by real group name.
3430 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3431 sort in reverse order."
3432   (interactive (gnus-interactive "P\ny"))
3433   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-real-name reverse))
3434
3435 (defun gnus-group-sort-selected-groups-by-unread (&optional n reverse)
3436   "Sort the group buffer by number of unread articles.
3437 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3438 sort in reverse order."
3439   (interactive (gnus-interactive "P\ny"))
3440   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-unread reverse))
3441
3442 (defun gnus-group-sort-selected-groups-by-level (&optional n reverse)
3443   "Sort the group buffer by group level.
3444 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3445 sort in reverse order."
3446   (interactive (gnus-interactive "P\ny"))
3447   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-level reverse))
3448
3449 (defun gnus-group-sort-selected-groups-by-score (&optional n reverse)
3450   "Sort the group buffer by group score.
3451 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3452 sort in reverse order."
3453   (interactive (gnus-interactive "P\ny"))
3454   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-score reverse))
3455
3456 (defun gnus-group-sort-selected-groups-by-rank (&optional n reverse)
3457   "Sort the group buffer by group rank.
3458 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3459 sort in reverse order."
3460   (interactive (gnus-interactive "P\ny"))
3461   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-rank reverse))
3462
3463 (defun gnus-group-sort-selected-groups-by-method (&optional n reverse)
3464   "Sort the group buffer alphabetically by back end name.
3465 Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
3466 sort in reverse order."
3467   (interactive (gnus-interactive "P\ny"))
3468   (gnus-group-sort-selected-groups n 'gnus-group-sort-by-method reverse))
3469
3470 ;;; Sorting predicates.
3471
3472 (defun gnus-group-sort-by-alphabet (info1 info2)
3473   "Sort alphabetically."
3474   (string< (gnus-info-group info1) (gnus-info-group info2)))
3475
3476 (defun gnus-group-sort-by-real-name (info1 info2)
3477   "Sort alphabetically on real (unprefixed) names."
3478   (string< (gnus-group-real-name (gnus-info-group info1))
3479            (gnus-group-real-name (gnus-info-group info2))))
3480
3481 (defun gnus-group-sort-by-unread (info1 info2)
3482   "Sort by number of unread articles."
3483   (let ((n1 (gnus-group-unread (gnus-info-group info1)))
3484         (n2 (gnus-group-unread (gnus-info-group info2))))
3485     (< (or (and (numberp n1) n1) 0)
3486        (or (and (numberp n2) n2) 0))))
3487
3488 (defun gnus-group-sort-by-level (info1 info2)
3489   "Sort by level."
3490   (< (gnus-info-level info1) (gnus-info-level info2)))
3491
3492 (defun gnus-group-sort-by-method (info1 info2)
3493   "Sort alphabetically by back end name."
3494   (string< (car (gnus-find-method-for-group
3495                  (gnus-info-group info1) info1))
3496            (car (gnus-find-method-for-group
3497                  (gnus-info-group info2) info2))))
3498
3499 (defun gnus-group-sort-by-server (info1 info2)
3500   "Sort alphabetically by server name."
3501   (string< (gnus-method-to-full-server-name
3502             (gnus-find-method-for-group
3503              (gnus-info-group info1) info1))
3504            (gnus-method-to-full-server-name
3505             (gnus-find-method-for-group
3506              (gnus-info-group info2) info2))))
3507
3508 (defun gnus-group-sort-by-score (info1 info2)
3509   "Sort by group score."
3510   (> (gnus-info-score info1) (gnus-info-score info2)))
3511
3512 (defun gnus-group-sort-by-rank (info1 info2)
3513   "Sort by level and score."
3514   (let ((level1 (gnus-info-level info1))
3515         (level2 (gnus-info-level info2)))
3516     (or (< level1 level2)
3517         (and (= level1 level2)
3518              (> (gnus-info-score info1) (gnus-info-score info2))))))
3519
3520 ;;; Clearing data
3521
3522 (defun gnus-group-clear-data (&optional arg)
3523   "Clear all marks and read ranges from the current group.
3524 Obeys the process/prefix convention."
3525   (interactive "P")
3526   (when (gnus-y-or-n-p "Really clear data? ")
3527     (gnus-group-iterate arg
3528       (lambda (group)
3529         (let (info)
3530           (gnus-info-clear-data (setq info (gnus-get-info group)))
3531           (gnus-get-unread-articles-in-group info (gnus-active group) t)
3532           (when (gnus-group-goto-group group)
3533             (gnus-group-update-group-line)))))))
3534
3535 (defun gnus-group-clear-data-on-native-groups ()
3536   "Clear all marks and read ranges from all native groups."
3537   (interactive)
3538   (when (gnus-yes-or-no-p "Really clear all data from almost all groups? ")
3539     (let ((alist (cdr gnus-newsrc-alist))
3540           info)
3541       (while (setq info (pop alist))
3542         (when (gnus-group-native-p (gnus-info-group info))
3543           (gnus-info-clear-data info)))
3544       (gnus-get-unread-articles)
3545       (gnus-dribble-touch)
3546       (when (gnus-y-or-n-p
3547              "Move the cache away to avoid problems in the future? ")
3548         (call-interactively 'gnus-cache-move-cache)))))
3549
3550 (defun gnus-info-clear-data (info)
3551   "Clear all marks and read ranges from INFO."
3552   (let ((group (gnus-info-group info))
3553         action)
3554     (dolist (el (gnus-info-marks info))
3555       (push `(,(cdr el) add (,(car el))) action))
3556     (push `(,(gnus-info-read info) add (read)) action)
3557     (gnus-undo-register
3558       `(progn
3559          (gnus-request-set-mark ,group ',action)
3560          (gnus-info-set-marks ',info ',(gnus-info-marks info) t)
3561          (gnus-info-set-read ',info ',(gnus-info-read info))
3562          (when (gnus-group-goto-group ,group)
3563            (gnus-get-unread-articles-in-group ',info ',(gnus-active group) t)
3564            (gnus-group-update-group-line))))
3565     (setq action (mapcar (lambda (el) (list (nth 0 el) 'del (nth 2 el)))
3566                          action))
3567     (gnus-request-set-mark group action)
3568     (gnus-info-set-read info nil)
3569     (when (gnus-info-marks info)
3570       (gnus-info-set-marks info nil))))
3571
3572 ;; Group catching up.
3573
3574 (defun gnus-group-catchup-current (&optional n all)
3575   "Mark all unread articles in the current newsgroup as read.
3576 If prefix argument N is numeric, the next N newsgroups will be
3577 caught up.  If ALL is non-nil, marked articles will also be marked as
3578 read.  Cross references (Xref: header) of articles are ignored.
3579 The number of newsgroups that this function was unable to catch
3580 up is returned."
3581   (interactive "P")
3582   (let ((groups (gnus-group-process-prefix n))
3583         (ret 0)
3584         group)
3585     (unless groups (error "No groups selected"))
3586     (if (not
3587          (or (not gnus-interactive-catchup) ;Without confirmation?
3588              gnus-expert-user
3589              (gnus-y-or-n-p
3590               (format
3591                (if all
3592                    "Do you really want to mark all articles in %s as read? "
3593                  "Mark all unread articles in %s as read? ")
3594                (if (= (length groups) 1)
3595                    (gnus-group-decoded-name (car groups))
3596                  (format "these %d groups" (length groups)))))))
3597         n
3598       (while (setq group (pop groups))
3599         (gnus-group-remove-mark group)
3600         ;; Virtual groups have to be given special treatment.
3601         (let ((method (gnus-find-method-for-group group)))
3602           (when (eq 'nnvirtual (car method))
3603             (nnvirtual-catchup-group
3604              (gnus-group-real-name group) (nth 1 method) all)))
3605         (cond
3606          ((>= (gnus-group-level group) gnus-level-zombie)
3607           (gnus-message 2 "Dead groups can't be caught up"))
3608          ((prog1
3609               (gnus-group-goto-group group)
3610             (gnus-group-catchup group all))
3611           (gnus-group-update-group-line))
3612          (t
3613           (setq ret (1+ ret)))))
3614       (gnus-group-next-unread-group 1)
3615       ret)))
3616
3617 (defun gnus-group-catchup-current-all (&optional n)
3618   "Mark all articles in current newsgroup as read.
3619 Cross references (Xref: header) of articles are ignored."
3620   (interactive "P")
3621   (gnus-group-catchup-current n 'all))
3622
3623 (declare-function gnus-sequence-of-unread-articles "gnus-sum" (group))
3624