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