HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Add 2011 to FSF/AIST copyright years.
[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,
5df4f04c 4;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 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."
2205 (let (group)
2206 (mapatoms (lambda (symbol)
2207 (setq group (symbol-name symbol))
2208 (set (intern (if (string-match "[^\000-\177]" group)
2209 (gnus-group-decoded-name group)
2210 group)
2211 collection)
2212 group))
2213 (prog1
2214 (or collection
2215 (setq collection (or gnus-active-hashtb [0])))
2216 (setq collection (gnus-make-hashtable (length collection)))))
2217 (setq group (apply 'completing-read prompt collection predicate
2218 require-match initial-input
2219 (or hist 'gnus-group-history)
2220 def args))
2221 (or (prog1
2222 (symbol-value (intern-soft group collection))
2223 (setq collection nil))
2224 (mm-encode-coding-string group (gnus-group-name-charset nil group)))))
2225
eec82323 2226;;;###autoload
23f87bed 2227(defun gnus-fetch-group (group &optional articles)
eec82323 2228 "Start Gnus if necessary and enter GROUP.
01c52d31 2229If ARTICLES, display those articles.
eec82323 2230Returns whether the fetching was successful or not."
01c52d31
MB		 2231 (interactive (list (gnus-group-completing-read "Group name: "
2232 nil nil nil
2233 (gnus-group-name-at-point))))
2234 (unless (gnus-alive-p)
6748645f 2235 (gnus-no-server))
01c52d31 2236 (gnus-group-read-group (if articles nil t) nil group articles))
eec82323 2237
6748645f
LMI		 2238;;;###autoload
2239(defun gnus-fetch-group-other-frame (group)
2240 "Pop up a frame and enter GROUP."
2241 (interactive "P")
2242 (let ((window (get-buffer-window gnus-group-buffer)))
2243 (cond (window
2244 (select-frame (window-frame window)))
2245 ((= (length (frame-list)) 1)
2246 (select-frame (make-frame)))
2247 (t
2248 (other-frame 1))))
2249 (gnus-fetch-group group))
2250
eec82323
LMI		 2251(defvar gnus-ephemeral-group-server 0)
2252
23f87bed
MB		 2253(defcustom gnus-large-ephemeral-newsgroup 200
2254 "The number of articles which indicates a large ephemeral newsgroup.
2255Same as `gnus-large-newsgroup', but only used for ephemeral newsgroups.
2256
2257If the number of articles in a newsgroup is greater than this value,
2258confirmation is required for selecting the newsgroup. If it is nil, no
2259confirmation is required."
bf247b6e 2260 :version "22.1"
23f87bed
MB		 2261 :group 'gnus-group-select
2262 :type '(choice (const :tag "No limit" nil)
2263 integer))
2264
2265(defcustom gnus-fetch-old-ephemeral-headers nil
2266 "Same as `gnus-fetch-old-headers', but only used for ephemeral newsgroups."
bf247b6e 2267 :version "22.1"
23f87bed
MB		 2268 :group 'gnus-thread
2269 :type '(choice (const :tag "off" nil)
2270 (const some)
2271 number
2272 (sexp :menu-tag "other" t)))
2273
eec82323
LMI		 2274;; Enter a group that is not in the group buffer. Non-nil is returned
2275;; if selection was successful.
2276(defun gnus-group-read-ephemeral-group (group method &optional activate
6748645f 2277 quit-config request-only
23f87bed 2278 select-articles
10ace8ea
MB		 2279 parameters
2280 number)
eec82323
LMI		 2281 "Read GROUP from METHOD as an ephemeral group.
2282If ACTIVATE, request the group first.
2283If QUIT-CONFIG, use that window configuration when exiting from the
2284ephemeral group.
2285If REQUEST-ONLY, don't actually read the group; just request it.
6748645f 2286If SELECT-ARTICLES, only select those articles.
23f87bed 2287If PARAMETERS, use those as the group parameters.
10ace8ea 2288If NUMBER, fetch this number of articles.
eec82323 2289
16409b0b 2290Return the name of the group if selection was successful."
23f87bed
MB		 2291 (interactive
2292 (list
2293 ;; (gnus-read-group "Group name: ")
01c52d31 2294 (gnus-group-completing-read "Group: ")
23f87bed 2295 (gnus-read-method "From method: ")))
eec82323 2296 ;; Transform the select method into a unique server.
6748645f
LMI		 2297 (when (stringp method)
2298 (setq method (gnus-server-to-method method)))
2299 (setq method
2300 `(,(car method) ,(concat (cadr method) "-ephemeral")
2301 (,(intern (format "%s-address" (car method))) ,(cadr method))
2302 ,@(cddr method)))
eec82323 2303 (let ((group (if (gnus-group-foreign-p group) group
23f87bed
MB		 2304 (gnus-group-prefixed-name (gnus-group-real-name group)
2305 method))))
eec82323
LMI		 2306 (gnus-sethash
2307 group
2308 `(-1 nil (,group
2309 ,gnus-level-default-subscribed nil nil ,method
23f87bed
MB		 2310 ,(cons
2311 (if quit-config
2312 (cons 'quit-config quit-config)
2313 (cons 'quit-config
2314 (cons gnus-summary-buffer
2315 gnus-current-window-configuration)))
2316 parameters)))
eec82323 2317 gnus-newsrc-hashtb)
6748645f 2318 (push method gnus-ephemeral-servers)
eec82323
LMI		 2319 (set-buffer gnus-group-buffer)
2320 (unless (gnus-check-server method)
2321 (error "Unable to contact server: %s" (gnus-status-message method)))
2322 (when activate
2323 (gnus-activate-group group 'scan)
2324 (unless (gnus-request-group group)
2325 (error "Couldn't request group: %s"
2326 (nnheader-get-report (car method)))))
2327 (if request-only
2328 group
2329 (condition-case ()
23f87bed
MB		 2330 (when (let ((gnus-large-newsgroup gnus-large-ephemeral-newsgroup)
2331 (gnus-fetch-old-headers
2332 gnus-fetch-old-ephemeral-headers))
10ace8ea 2333 (gnus-group-read-group (or number t) t group select-articles))
eec82323
LMI		 2334 group)
2335 ;;(error nil)
2491844d
DL		 2336 (quit
2337 (message "Quit reading the ephemeral group")
2338 nil)))))
eec82323 2339
9b3ebcb6 2340(defcustom gnus-gmane-group-download-format
95838435
MB		 2341 "http://download.gmane.org/%s/%s/%s"
2342 "URL for downloading mbox files.
2343It must contain three \"%s\". They correspond to the group, the
2344minimal and maximal article numbers, respectively."
2345 :group 'gnus-group-foreign
330f707b 2346 :version "23.1" ;; No Gnus
95838435 2347 :type 'string)
d82cf70b 2348
95838435
MB		 2349(autoload 'url-insert-file-contents "url-handlers")
2350;; FIXME:
2351;; - Add documentation, menu, key bindings, ...
d82cf70b 2352
9b3ebcb6 2353(defun gnus-read-ephemeral-gmane-group (group start &optional range)
d82cf70b 2354 "Read articles from Gmane group GROUP as an ephemeral group.
95838435
MB		 2355START is the first article. RANGE specifies how many articles
2356are fetched. The articles are downloaded via HTTP using the URL
9b3ebcb6 2357specified by `gnus-gmane-group-download-format'."
d82cf70b
MB		 2358 ;; See <http://gmane.org/export.php> for more information.
2359 (interactive
2360 (list
2361 (gnus-group-completing-read "Gmane group: ")
2362 (read-number "Start article number: ")
95838435
MB		 2363 (read-number "How many articles: ")))
2364 (unless range (setq range 500))
2365 (when (< range 1)
2366 (error "Invalid range: %s" range))
2367 (let ((tmpfile (make-temp-file
2368 (format "%s.start-%s.range-%s." group start range)))
2369 (gnus-thread-sort-functions '(gnus-thread-sort-by-number)))
d82cf70b
MB		 2370 (with-temp-file tmpfile
2371 (url-insert-file-contents
9b3ebcb6 2372 (format gnus-gmane-group-download-format
95838435 2373 group start (+ start range)))
d82cf70b
MB		 2374 (write-region (point-min) (point-max) tmpfile)
2375 (gnus-group-read-ephemeral-group
95838435 2376 (format "%s.start-%s.range-%s" group start range)
d82cf70b 2377 `(nndoc ,tmpfile
8f7abae3 2378 (nndoc-article-type mbox))))
d82cf70b
MB		 2379 (delete-file tmpfile)))
2380
9b3ebcb6 2381(defun gnus-read-ephemeral-gmane-group-url (url)
95838435
MB		 2382 "Create an ephemeral Gmane group from URL.
2383
2384Valid input formats include:
2385\"http://thread.gmane.org/gmane.foo.bar/12300/focus=12399\",
2386\"http://thread.gmane.org/gmane.foo.bar/12345/\",
2387\"http://article.gmane.org/gmane.foo.bar/12345/\",
2388\"http://news.gmane.org/group/gmane.foo.bar/thread=12345\""
2389 ;; - Feel free to add other useful Gmane URLs here! Maybe the URLs should
2390 ;; be customizable?
2391 ;; - The URLs should be added to `gnus-button-alist'. Probably we should
2392 ;; prompt the user to decide: "View via `browse-url' or in Gnus? "
9b3ebcb6 2393 ;; (`gnus-read-ephemeral-gmane-group-url')
95838435
MB		 2394 (interactive
2395 (list (gnus-group-completing-read "Gmane URL: ")))
2396 (let (group start range)
2397 (cond
2398 ;; URLs providing `group', `start' and `range':
2399 ((string-match
2400 ;; http://thread.gmane.org/gmane.emacs.devel/86326/focus=86525
2401 "^http://thread\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)/focus=\\([0-9]+\\)$"
2402 url)
2403 (setq group (match-string 1 url)
2404 start (string-to-number (match-string 2 url))
2405 ;; Ensure that `range' is large enough to ensure focus article is
2406 ;; included.
2407 range (- (string-to-number (match-string 3 url))
2408 start -1)))
2409 ;; URLs providing `group' and `start':
2410 ((or (string-match
2411 ;; http://article.gmane.org/gmane.comp.gnu.make.bugs/3584
8f7abae3 2412 "^http://\\(?:thread\\|article\\|permalink\\)\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)"
95838435
MB		 2413 url)
2414 (string-match
834ee131 2415 ;; Don't advertise these in the doc string yet:
95838435
MB		 2416 "^\\(?:nntp\\|news\\)://news\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)"
2417 url)
2418 (string-match
2419 ;; http://news.gmane.org/group/gmane.emacs.gnus.general/thread=65099/force_load=t
2420 "^http://news\.gmane\.org/group/\\([^/]+\\)/thread=\\([0-9]+\\)"
2421 url))
2422 (setq group (match-string 1 url)
2423 start (string-to-number (match-string 2 url))))
2424 (t
2425 (error "Can't parse URL %s" url)))
9b3ebcb6
MB		 2426 (gnus-read-ephemeral-gmane-group group start range)))
2427
2428(defcustom gnus-bug-group-download-format-alist
a0db2cdd 2429 '((emacs . "http://debbugs.gnu.org/%s;mbox=yes")
9b3ebcb6
MB		 2430 (debian
2431 . "http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=%s&mbox=yes"))
2432 "Alist of symbols for bug trackers and the corresponding URL format string.
2433The URL format string must contain a single \"%s\", specifying
2434the bug number, and browsing the URL must return mbox output."
2435 :group 'gnus-group-foreign
a0db2cdd 2436 :version "23.2" ;; No Gnus
9b3ebcb6
MB		 2437 :type '(repeat (cons (symbol) (string :tag "URL format string"))))
2438
2439(defun gnus-read-ephemeral-bug-group (number mbox-url)
2440 "Browse bug NUMBER as ephemeral group."
2441 (interactive (list (read-string "Enter bug number: "
2442 (thing-at-point 'word) nil)
2443 ;; FIXME: Add completing-read from
2444 ;; `gnus-emacs-bug-group-download-format' ...
2445 (cdr (assoc 'emacs gnus-bug-group-download-format-alist))))
2446 (when (stringp number)
2447 (setq number (string-to-number number)))
2448 (let ((tmpfile (make-temp-file "gnus-temp-group-")))
2449 (with-temp-file tmpfile
2450 (url-insert-file-contents (format mbox-url number))
2451 (write-region (point-min) (point-max) tmpfile)
2452 (gnus-group-read-ephemeral-group
2453 "gnus-read-ephemeral-bug"
2454 `(nndoc ,tmpfile
2455 (nndoc-article-type mbox))))
2456 (delete-file tmpfile)))
2457
2458(defun gnus-read-ephemeral-debian-bug-group (number)
2459 "Browse Debian bug NUMBER as ephemeral group."
2460 (interactive (list (read-string "Enter bug number: "
2461 (thing-at-point 'word) nil)))
2462 (gnus-read-ephemeral-bug-group
2463 number
2464 (cdr (assoc 'debian gnus-bug-group-download-format-alist))))
2465
2466(defun gnus-read-ephemeral-emacs-bug-group (number)
2467 "Browse Emacs bug NUMBER as ephemeral group."
2468 (interactive (list (read-string "Enter bug number: "
2469 (thing-at-point 'word) nil)))
2470 (gnus-read-ephemeral-bug-group
2471 number
2472 (cdr (assoc 'emacs gnus-bug-group-download-format-alist))))
95838435 2473
01c52d31
MB		 2474(defun gnus-group-jump-to-group (group &optional prompt)
2475 "Jump to newsgroup GROUP.
2476
2477If PROMPT (the prefix) is a number, use the prompt specified in
2478`gnus-group-jump-to-group-prompt'."
eec82323 2479 (interactive
01c52d31
MB		 2480 (list (gnus-group-completing-read
2481 "Group: " nil nil (gnus-read-active-file-p)
2482 (if current-prefix-arg
2483 (cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt))
2484 (or (and (stringp gnus-group-jump-to-group-prompt)
2485 gnus-group-jump-to-group-prompt)
2486 (let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt))))
2487 (and (stringp p) p)))))))
eec82323
LMI		 2488
2489 (when (equal group "")
2490 (error "Empty group name"))
2491
2492 (unless (gnus-ephemeral-group-p group)
2493 ;; Either go to the line in the group buffer...
2494 (unless (gnus-group-goto-group group)
2495 ;; ... or insert the line.
2496 (gnus-group-update-group group)
2497 (gnus-group-goto-group group)))
2498 ;; Adjust cursor point.
2499 (gnus-group-position-point))
2500
16409b0b 2501(defun gnus-group-goto-group (group &optional far test-marked)
eec82323 2502 "Goto to newsgroup GROUP.
16409b0b
GM		 2503If FAR, it is likely that the group is not on the current line.
2504If TEST-MARKED, the line must be marked."
eec82323 2505 (when group
16409b0b
GM		 2506 (beginning-of-line)
2507 (cond
2508 ;; It's quite likely that we are on the right line, so
2509 ;; we check the current line first.
2510 ((and (not far)
2511 (eq (get-text-property (point) 'gnus-group)
2512 (gnus-intern-safe group gnus-active-hashtb))
2513 (or (not test-marked) (gnus-group-mark-line-p)))
2514 (point))
2515 ;; Previous and next line are also likely, so we check them as well.
2516 ((and (not far)
2517 (save-excursion
2518 (forward-line -1)
2519 (and (eq (get-text-property (point) 'gnus-group)
2520 (gnus-intern-safe group gnus-active-hashtb))
2521 (or (not test-marked) (gnus-group-mark-line-p)))))
2522 (forward-line -1)
2523 (point))
2524 ((and (not far)
2525 (save-excursion
2526 (forward-line 1)
2527 (and (eq (get-text-property (point) 'gnus-group)
2528 (gnus-intern-safe group gnus-active-hashtb))
2529 (or (not test-marked) (gnus-group-mark-line-p)))))
2530 (forward-line 1)
2531 (point))
2532 (test-marked
2533 (goto-char (point-min))
2534 (let (found)
a1506d29 2535 (while (and (not found)
16409b0b
GM		 2536 (gnus-goto-char
2537 (text-property-any
2538 (point) (point-max)
a1506d29 2539 'gnus-group
16409b0b
GM		 2540 (gnus-intern-safe group gnus-active-hashtb))))
2541 (if (gnus-group-mark-line-p)
2542 (setq found t)
2543 (forward-line 1)))
2544 found))
2545 (t
2546 ;; Search through the entire buffer.
2547 (gnus-goto-char
2548 (text-property-any
2549 (point-min) (point-max)
2550 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))))))
eec82323
LMI		 2551
2552(defun gnus-group-next-group (n &optional silent)
2553 "Go to next N'th newsgroup.
2554If N is negative, search backward instead.
2555Returns the difference between N and the number of skips actually
2556done."
2557 (interactive "p")
2558 (gnus-group-next-unread-group n t nil silent))
2559
2560(defun gnus-group-next-unread-group (n &optional all level silent)
2561 "Go to next N'th unread newsgroup.
2562If N is negative, search backward instead.
2563If ALL is non-nil, choose any newsgroup, unread or not.
2564If LEVEL is non-nil, choose the next group with level LEVEL, or, if no
2565such group can be found, the next group with a level higher than
2566LEVEL.
2567Returns the difference between N and the number of skips actually
2568made."
2569 (interactive "p")
2570 (let ((backward (< n 0))
2571 (n (abs n)))
2572 (while (and (> n 0)
2573 (gnus-group-search-forward
2574 backward (or (not gnus-group-goto-unread) all) level))
2575 (setq n (1- n)))
2576 (when (and (/= 0 n)
2577 (not silent))
2578 (gnus-message 7 "No more%s newsgroups%s" (if all "" " unread")
2579 (if level " on this level or higher" "")))
2580 n))
2581
2582(defun gnus-group-prev-group (n)
2583 "Go to previous N'th newsgroup.
2584Returns the difference between N and the number of skips actually
2585done."
2586 (interactive "p")
2587 (gnus-group-next-unread-group (- n) t))
2588
2589(defun gnus-group-prev-unread-group (n)
2590 "Go to previous N'th unread newsgroup.
2591Returns the difference between N and the number of skips actually
2592done."
2593 (interactive "p")
2594 (gnus-group-next-unread-group (- n)))
2595
2596(defun gnus-group-next-unread-group-same-level (n)
2597 "Go to next N'th unread newsgroup on the same level.
2598If N is negative, search backward instead.
2599Returns the difference between N and the number of skips actually
2600done."
2601 (interactive "p")
2602 (gnus-group-next-unread-group n t (gnus-group-group-level))
2603 (gnus-group-position-point))
2604
2605(defun gnus-group-prev-unread-group-same-level (n)
2606 "Go to next N'th unread newsgroup on the same level.
2607Returns the difference between N and the number of skips actually
2608done."
2609 (interactive "p")
2610 (gnus-group-next-unread-group (- n) t (gnus-group-group-level))
2611 (gnus-group-position-point))
2612
2613(defun gnus-group-best-unread-group (&optional exclude-group)
2614 "Go to the group with the highest level.
2615If EXCLUDE-GROUP, do not go to that group."
2616 (interactive)
2617 (goto-char (point-min))
2618 (let ((best 100000)
2619 unread best-point)
2620 (while (not (eobp))
2621 (setq unread (get-text-property (point) 'gnus-unread))
2622 (when (and (numberp unread) (> unread 0))
2623 (when (and (get-text-property (point) 'gnus-level)
2624 (< (get-text-property (point) 'gnus-level) best)
2625 (or (not exclude-group)
2626 (not (equal exclude-group (gnus-group-group-name)))))
2627 (setq best (get-text-property (point) 'gnus-level))
2628 (setq best-point (point))))
2629 (forward-line 1))
2630 (when best-point
2631 (goto-char best-point))
23f87bed 2632 (gnus-group-position-point)
eec82323
LMI		 2633 (and best-point (gnus-group-group-name))))
2634
01c52d31
MB		 2635;; Is there something like an after-point-motion-hook?
2636;; (inhibit-point-motion-hooks?). Is there a tool-bar-update function?
2637
2638;; (defun gnus-group-menu-bar-update ()
2639;; (let* ((buf (list (with-current-buffer gnus-group-buffer
2640;; (current-buffer))))
2641;; (name (buffer-name (car buf))))
2642;; (setcdr buf
2643;; (if (> (length name) 27)
2644;; (concat (substring name 0 12)
2645;; "..."
2646;; (substring name -12))
2647;; name))
2648;; (menu-bar-update-buffers-1 buf)))
2649
2650;; (defun gnus-group-position-point ()
2651;; (gnus-goto-colon)
2652;; (gnus-group-menu-bar-update))
2653
eec82323
LMI		 2654(defun gnus-group-first-unread-group ()
2655 "Go to the first group with unread articles."
2656 (interactive)
2657 (prog1
2658 (let ((opoint (point))
2659 unread)
2660 (goto-char (point-min))
2661 (if (or (eq (setq unread (gnus-group-group-unread)) t) ; Not active.
2662 (and (numberp unread) ; Not a topic.
2663 (not (zerop unread))) ; Has unread articles.
2664 (zerop (gnus-group-next-unread-group 1))) ; Next unread group.
2665 (point) ; Success.
2666 (goto-char opoint)
2667 nil)) ; Not success.
2668 (gnus-group-position-point)))
2669
2670(defun gnus-group-enter-server-mode ()
2671 "Jump to the server buffer."
2672 (interactive)
2673 (gnus-enter-server-buffer))
2674
01c52d31
MB		 2675(defun gnus-group-make-group-simple (&optional group)
2676 "Add a new newsgroup.
2677The user will be prompted for GROUP."
2678 (interactive (list (gnus-group-completing-read "Group: ")))
2679 (gnus-group-make-group (gnus-group-real-name group)
2680 (gnus-group-server group)
2681 nil nil t))
2682
2683(defun gnus-group-make-group (name &optional method address args encoded)
eec82323
LMI		 2684 "Add a new newsgroup.
2685The user will be prompted for a NAME, for a select METHOD, and an
01c52d31
MB		 2686ADDRESS. NAME should be a human-readable string (i.e., not be encoded
2687even if it contains non-ASCII characters) unless ENCODED is non-nil."
eec82323
LMI		 2688 (interactive
2689 (list
2690 (gnus-read-group "Group name: ")
2691 (gnus-read-method "From method: ")))
2692
6748645f 2693 (when (stringp method)
16409b0b 2694 (setq method (or (gnus-server-to-method method) method)))
01c52d31
MB		 2695 (unless encoded
2696 (setq name (mm-encode-coding-string
2697 name
2698 (gnus-group-name-charset method name))))
16409b0b
GM		 2699 (let* ((meth (gnus-method-simplify
2700 (when (and method
2701 (not (gnus-server-equal method gnus-select-method)))
2702 (if address (list (intern method) address)
2703 method))))
eec82323
LMI		 2704 (nname (if method (gnus-group-prefixed-name name meth) name))
2705 backend info)
01c52d31 2706 (when (gnus-group-entry nname)
91472578 2707 (error "Group %s already exists" (gnus-group-decoded-name nname)))
eec82323
LMI		 2708 ;; Subscribe to the new group.
2709 (gnus-group-change-level
2710 (setq info (list t nname gnus-level-default-subscribed nil nil meth))
2711 gnus-level-default-subscribed gnus-level-killed
2712 (and (gnus-group-group-name)
01c52d31 2713 (gnus-group-entry (gnus-group-group-name)))
eec82323
LMI		 2714 t)
2715 ;; Make it active.
2716 (gnus-set-active nname (cons 1 0))
2717 (unless (gnus-ephemeral-group-p name)
2718 (gnus-dribble-enter
2719 (concat "(gnus-group-set-info '"
2720 (gnus-prin1-to-string (cdr info)) ")")))
2721 ;; Insert the line.
2722 (gnus-group-insert-group-line-info nname)
2723 (forward-line -1)
2724 (gnus-group-position-point)
2725
23f87bed 2726 ;; Load the back end and try to make the back end create
eec82323
LMI		 2727 ;; the group as well.
2728 (when (assoc (symbol-name (setq backend (car (gnus-server-get-method
2729 nil meth))))
2730 gnus-valid-select-methods)
2731 (require backend))
2732 (gnus-check-server meth)
2733 (when (gnus-check-backend-function 'request-create-group nname)
23f87bed
MB		 2734 (unless (gnus-request-create-group nname nil args)
2735 (error "Could not create group on server: %s"
2736 (nnheader-get-report backend))))
eec82323
LMI		 2737 t))
2738
16409b0b
GM		 2739(defun gnus-group-delete-groups (&optional arg)
2740 "Delete the current group. Only meaningful with editable groups."
2741 (interactive "P")
2742 (let ((n (length (gnus-group-process-prefix arg))))
2743 (when (gnus-yes-or-no-p
2744 (if (= n 1)
2745 "Delete this 1 group? "
2746 (format "Delete these %d groups? " n)))
2747 (gnus-group-iterate arg
2748 (lambda (group)
2749 (gnus-group-delete-group group nil t))))))
2750
2751(defun gnus-group-delete-group (group &optional force no-prompt)
2752 "Delete the current group. Only meaningful with editable groups.
eec82323
LMI		 2753If FORCE (the prefix) is non-nil, all the articles in the group will
2754be deleted. This is \"deleted\" as in \"removed forever from the face
c30ba437 2755of the Earth\". There is no undo. The user will be prompted before
23f87bed
MB		 2756doing the deletion.
2757Note that you also have to specify FORCE if you want the group to
2758be removed from the server, even when it's empty."
eec82323
LMI		 2759 (interactive
2760 (list (gnus-group-group-name)
2761 current-prefix-arg))
2762 (unless group
23f87bed 2763 (error "No group to delete"))
eec82323 2764 (unless (gnus-check-backend-function 'request-delete-group group)
23f87bed 2765 (error "This back end does not support group deletion"))
eec82323 2766 (prog1
91472578
MB		 2767 (let ((group-decoded (gnus-group-decoded-name group)))
2768 (if (and (not no-prompt)
2769 (not (gnus-yes-or-no-p
2770 (format
2771 "Do you really want to delete %s%s? "
2772 group-decoded (if force " and all its contents" "")))))
2773 () ; Whew!
2774 (gnus-message 6 "Deleting group %s..." group-decoded)
2775 (if (not (gnus-request-delete-group group force))
2776 (gnus-error 3 "Couldn't delete group %s" group-decoded)
2777 (gnus-message 6 "Deleting group %s...done" group-decoded)
2778 (gnus-group-goto-group group)
2779 (gnus-group-kill-group 1 t)
01c52d31 2780 (gnus-set-active group nil)
91472578 2781 t)))
eec82323
LMI		 2782 (gnus-group-position-point)))
2783
2784(defun gnus-group-rename-group (group new-name)
2785 "Rename group from GROUP to NEW-NAME.
2786When used interactively, GROUP is the group under point
2787and NEW-NAME will be prompted for."
2788 (interactive
4d8a28ec
MB		 2789 (let ((group (gnus-group-group-name))
2790 method new-name)
2791 (unless (gnus-check-backend-function 'request-rename-group group)
2792 (error "This back end does not support renaming groups"))
2793 (setq new-name (gnus-read-group
2794 "Rename group to: "
2795 (gnus-group-real-name (gnus-group-decoded-name group)))
2796 method (gnus-info-method (gnus-get-info group)))
2797 (list group (mm-encode-coding-string
2798 new-name
2799 (gnus-group-name-charset
2800 method
2801 (gnus-group-prefixed-name new-name method))))))
eec82323
LMI		 2802
2803 (unless (gnus-check-backend-function 'request-rename-group group)
23f87bed 2804 (error "This back end does not support renaming groups"))
eec82323
LMI		 2805 (unless group
2806 (error "No group to rename"))
2807 (when (equal (gnus-group-real-name group) new-name)
2808 (error "Can't rename to the same name"))
2809
2810 ;; We find the proper prefixed name.
2811 (setq new-name
2812 (if (gnus-group-native-p group)
2813 ;; Native group.
2814 new-name
2815 ;; Foreign group.
2816 (gnus-group-prefixed-name
2817 (gnus-group-real-name new-name)
2818 (gnus-info-method (gnus-get-info group)))))
2819
4d8a28ec
MB		 2820 (let ((decoded-group (gnus-group-decoded-name group))
2821 (decoded-new-name (gnus-group-decoded-name new-name)))
2822 (when (gnus-active new-name)
2823 (error "The group %s already exists" decoded-new-name))
2824
2825 (gnus-message 6 "Renaming group %s to %s..."
2826 decoded-group decoded-new-name)
2827 (prog1
2828 (if (progn
2829 (gnus-group-goto-group group)
2830 (not (when (< (gnus-group-group-level) gnus-level-zombie)
2831 (gnus-request-rename-group group new-name))))
2832 (gnus-error 3 "Couldn't rename group %s to %s"
2833 decoded-group decoded-new-name)
2834 ;; We rename the group internally by killing it...
2835 (gnus-group-kill-group)
2836 ;; ... changing its name ...
2837 (setcar (cdar gnus-list-of-killed-groups) new-name)
2838 ;; ... and then yanking it. Magic!
2839 (gnus-group-yank-group)
2840 (gnus-set-active new-name (gnus-active group))
2841 (gnus-message 6 "Renaming group %s to %s...done"
2842 decoded-group decoded-new-name)
2843 new-name)
2844 (setq gnus-killed-list (delete group gnus-killed-list))
2845 (gnus-set-active group nil)
2846 (gnus-dribble-touch)
2847 (gnus-group-position-point))))
eec82323
LMI		 2848
2849(defun gnus-group-edit-group (group &optional part)
2850 "Edit the group on the current line."
2851 (interactive (list (gnus-group-group-name)))
2852 (let ((part (or part 'info))
2853 info)
2854 (unless group
2855 (error "No group on current line"))
2856 (unless (setq info (gnus-get-info group))
2857 (error "Killed group; can't be edited"))
2858 (ignore-errors
2859 (gnus-close-group group))
2860 (gnus-edit-form
2861 ;; Find the proper form to edit.
2862 (cond ((eq part 'method)
2863 (or (gnus-info-method info) "native"))
2864 ((eq part 'params)
2865 (gnus-info-params info))
2866 (t info))
2867 ;; The proper documentation.
2868 (format
2869 "Editing the %s for `%s'."
2870 (cond
2871 ((eq part 'method) "select method")
2872 ((eq part 'params) "group parameters")
2873 (t "group info"))
16409b0b 2874 (gnus-group-decoded-name group))
eec82323 2875 `(lambda (form)
23f87bed
MB		 2876 (gnus-group-edit-group-done ',part ,group form)))
2877 (local-set-key
2878 "\C-c\C-i"
2879 (gnus-create-info-command
2880 (cond
2881 ((eq part 'method)
2882 "(gnus)Select Methods")
2883 ((eq part 'params)
2884 "(gnus)Group Parameters")
2885 (t
2886 "(gnus)Group Info"))))))
eec82323
LMI		 2887
2888(defun gnus-group-edit-group-method (group)
2889 "Edit the select method of GROUP."
2890 (interactive (list (gnus-group-group-name)))
2891 (gnus-group-edit-group group 'method))
2892
2893(defun gnus-group-edit-group-parameters (group)
2894 "Edit the group parameters of GROUP."
2895 (interactive (list (gnus-group-group-name)))
2896 (gnus-group-edit-group group 'params))
2897
2898(defun gnus-group-edit-group-done (part group form)
2899 "Update variables."
2900 (let* ((method (cond ((eq part 'info) (nth 4 form))
2901 ((eq part 'method) form)
2902 (t nil)))
2903 (info (cond ((eq part 'info) form)
2904 ((eq part 'method) (gnus-get-info group))
2905 (t nil)))
2906 (new-group (if info
2907 (if (or (not method)
2908 (gnus-server-equal
2909 gnus-select-method method))
2910 (gnus-group-real-name (car info))
2911 (gnus-group-prefixed-name
2912 (gnus-group-real-name (car info)) method))
2913 nil)))
2914 (when (and new-group
2915 (not (equal new-group group)))
2916 (when (gnus-group-goto-group group)
2917 (gnus-group-kill-group 1))
2918 (gnus-activate-group new-group))
2919 ;; Set the info.
2920 (if (not (and info new-group))
2921 (gnus-group-set-info form (or new-group group) part)
2922 (setq info (gnus-copy-sequence info))
2923 (setcar info new-group)
2924 (unless (gnus-server-equal method "native")
2925 (unless (nthcdr 3 info)
2926 (nconc info (list nil nil)))
2927 (unless (nthcdr 4 info)
2928 (nconc info (list nil)))
2929 (gnus-info-set-method info method))
2930 (gnus-group-set-info info))
2931 (gnus-group-update-group (or new-group group))
2932 (gnus-group-position-point)))
2933
2934(defun gnus-group-make-useful-group (group method)
6748645f 2935 "Create one of the groups described in `gnus-useful-groups'."
eec82323
LMI		 2936 (interactive
2937 (let ((entry (assoc (completing-read "Create group: " gnus-useful-groups
2938 nil t)
2939 gnus-useful-groups)))
1ae03cd5
KY		 2940 (list (cadr entry)
2941 ;; Don't use `caddr' here since macros within the `interactive'
2942 ;; form won't be expanded.
2943 (car (cddr entry)))))
eec82323
LMI		 2944 (setq method (gnus-copy-sequence method))
2945 (let (entry)
2946 (while (setq entry (memq (assq 'eval method) method))
2947 (setcar entry (eval (cadar entry)))))
2948 (gnus-group-make-group group method))
2949
23f87bed
MB		 2950(defun gnus-group-make-help-group (&optional noerror)
2951 "Create the Gnus documentation group.
2952Optional argument NOERROR modifies the behavior of this function when the
2953group already exists:
2954- if not given, and error is signaled,
2955- if t, stay silent,
2956- if anything else, just print a message."
eec82323
LMI		 2957 (interactive)
2958 (let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help")))
6748645f 2959 (file (nnheader-find-etc-directory "gnus-tut.txt" t)))
01c52d31 2960 (if (gnus-group-entry name)
23f87bed
MB		 2961 (cond ((eq noerror nil)
2962 (error "Documentation group already exists"))
2963 ((eq noerror t)
2964 ;; stay silent
2965 )
2966 (t
2967 (gnus-message 1 "Documentation group already exists")))
2968 ;; else:
2969 (if (not file)
2970 (gnus-message 1 "Couldn't find doc group")
2971 (gnus-group-make-group
2972 (gnus-group-real-name name)
2973 (list 'nndoc "gnus-help"
2974 (list 'nndoc-address file)
2975 (list 'nndoc-article-type 'mbox))))
2976 ))
eec82323
LMI		 2977 (gnus-group-position-point))
2978
2979(defun gnus-group-make-doc-group (file type)
270a576a
MB		 2980 "Create a group that uses a single file as the source.
2981
2982If called with a prefix argument, ask for the file type."
eec82323
LMI		 2983 (interactive
2984 (list (read-file-name "File name: ")
2985 (and current-prefix-arg 'ask)))
2986 (when (eq type 'ask)
2987 (let ((err "")
2988 char found)
2989 (while (not found)
2990 (message
270a576a 2991 "%sFile type (mbox, babyl, digest, forward, mmdf, guess) [m, b, d, f, a, g]: "
eec82323
LMI		 2992 err)
2993 (setq found (cond ((= (setq char (read-char)) ?m) 'mbox)
2994 ((= char ?b) 'babyl)
2995 ((= char ?d) 'digest)
2996 ((= char ?f) 'forward)
2997 ((= char ?a) 'mmfd)
16409b0b 2998 ((= char ?g) 'guess)
eec82323
LMI		 2999 (t (setq err (format "%c unknown. " char))
3000 nil))))
3001 (setq type found)))
c86d4601 3002 (setq file (expand-file-name file))
01c52d31
MB		 3003 (let* ((name (gnus-generate-new-group-name
3004 (gnus-group-prefixed-name
3005 (file-name-nondirectory file) '(nndoc ""))))
3006 (method (list 'nndoc file
3007 (list 'nndoc-address file)
3008 (list 'nndoc-article-type (or type 'guess))))
3009 (coding (gnus-group-name-charset method name)))
3010 (setcar (cdr method) (mm-encode-coding-string file coding))
eec82323 3011 (gnus-group-make-group
01c52d31
MB		 3012 (mm-encode-coding-string (gnus-group-real-name name) coding)
3013 method nil nil t)))
eec82323
LMI		 3014
3015(defvar nnweb-type-definition)
3016(defvar gnus-group-web-type-history nil)
3017(defvar gnus-group-web-search-history nil)
3018(defun gnus-group-make-web-group (&optional solid)
3019 "Create an ephemeral nnweb group.
3020If SOLID (the prefix), create a solid group."
3021 (interactive "P")
3022 (require 'nnweb)
3023 (let* ((group
3024 (if solid (gnus-read-group "Group name: ")
3025 (message-unique-id)))
a8151ef7
LMI		 3026 (default-type (or (car gnus-group-web-type-history)
3027 (symbol-name (caar nnweb-type-definition))))
eec82323 3028 (type
a8151ef7
LMI		 3029 (gnus-string-or
3030 (completing-read
3031 (format "Search engine type (default %s): " default-type)
3032 (mapcar (lambda (elem) (list (symbol-name (car elem))))
3033 nnweb-type-definition)
3034 nil t nil 'gnus-group-web-type-history)
3035 default-type))
eec82323
LMI		 3036 (search
3037 (read-string
3038 "Search string: "
3039 (cons (or (car gnus-group-web-search-history) "") 0)
3040 'gnus-group-web-search-history))
3041 (method
3042 `(nnweb ,group (nnweb-search ,search)
3043 (nnweb-type ,(intern type))
3044 (nnweb-ephemeral-p t))))
3045 (if solid
23f87bed
MB		 3046 (progn
3047 (gnus-pull 'nnweb-ephemeral-p method)
3048 (gnus-group-make-group group method))
eec82323
LMI		 3049 (gnus-group-read-ephemeral-group
3050 group method t
3051 (cons (current-buffer)
3052 (if (eq major-mode 'gnus-summary-mode) 'summary 'group))))))
3053
9efa445f 3054(defvar nnrss-group-alist)
23f87bed 3055(eval-when-compile
23f87bed
MB		 3056 (defun nnrss-discover-feed (arg))
3057 (defun nnrss-save-server-data (arg)))
3058(defun gnus-group-make-rss-group (&optional url)
3059 "Given a URL, discover if there is an RSS feed.
3060If there is, use Gnus to create an nnrss group"
3061 (interactive)
3062 (require 'nnrss)
3063 (if (not url)
3064 (setq url (read-from-minibuffer "URL to Search for RSS: ")))
3065 (let ((feedinfo (nnrss-discover-feed url)))
3066 (if feedinfo
01c52d31
MB		 3067 (let* ((title (gnus-newsgroup-savable-name
3068 (read-from-minibuffer "Title: "
3069 (gnus-newsgroup-savable-name
ee5a613e
KY		 3070 (mapconcat
3071 'identity
3072 (split-string
3073 (or (cdr (assoc 'title
3074 feedinfo))
3075 ""))
3076 " ")))))
01c52d31 3077 (desc (read-from-minibuffer "Description: "
ee5a613e
KY		 3078 (mapconcat
3079 'identity
3080 (split-string
3081 (or (cdr (assoc 'description
3082 feedinfo))
3083 ""))
3084 " ")))
01c52d31
MB		 3085 (href (cdr (assoc 'href feedinfo)))
3086 (coding (gnus-group-name-charset '(nnrss "") title)))
3087 (when coding
91472578
MB		 3088 ;; Unify non-ASCII text.
3089 (setq title (mm-decode-coding-string
01c52d31
MB		 3090 (mm-encode-coding-string title coding)
3091 coding)))
3092 (gnus-group-make-group title '(nnrss ""))
91472578 3093 (push (list title href desc) nnrss-group-alist)
23f87bed
MB		 3094 (nnrss-save-server-data nil))
3095 (error "No feeds found for %s" url))))
3096
16409b0b
GM		 3097(defvar nnwarchive-type-definition)
3098(defvar gnus-group-warchive-type-history nil)
3099(defvar gnus-group-warchive-login-history nil)
3100(defvar gnus-group-warchive-address-history nil)
3101
3102(defun gnus-group-make-warchive-group ()
3103 "Create a nnwarchive group."
3104 (interactive)
3105 (require 'nnwarchive)
3106 (let* ((group (gnus-read-group "Group name: "))
3107 (default-type (or (car gnus-group-warchive-type-history)
3108 (symbol-name (caar nnwarchive-type-definition))))
3109 (type
3110 (gnus-string-or
3111 (completing-read
3112 (format "Warchive type (default %s): " default-type)
3113 (mapcar (lambda (elem) (list (symbol-name (car elem))))
3114 nnwarchive-type-definition)
3115 nil t nil 'gnus-group-warchive-type-history)
3116 default-type))
3117 (address (read-string "Warchive address: "
3118 nil 'gnus-group-warchive-address-history))
3119 (default-login (or (car gnus-group-warchive-login-history)
3120 user-mail-address))
3121 (login
3122 (gnus-string-or
3123 (read-string
3124 (format "Warchive login (default %s): " user-mail-address)
3125 default-login 'gnus-group-warchive-login-history)
3126 user-mail-address))
3127 (method
a1506d29 3128 `(nnwarchive ,address
16409b0b
GM		 3129 (nnwarchive-type ,(intern type))
3130 (nnwarchive-login ,login))))
3131 (gnus-group-make-group group method)))
3132
eec82323
LMI		 3133(defun gnus-group-make-archive-group (&optional all)
3134 "Create the (ding) Gnus archive group of the most recent articles.
3135Given a prefix, create a full group."
3136 (interactive "P")
3137 (let ((group (gnus-group-prefixed-name
3138 (if all "ding.archives" "ding.recent") '(nndir ""))))
01c52d31 3139 (when (gnus-group-entry group)
eec82323
LMI		 3140 (error "Archive group already exists"))
3141 (gnus-group-make-group
3142 (gnus-group-real-name group)
3143 (list 'nndir (if all "hpc" "edu")
3144 (list 'nndir-directory
3145 (if all gnus-group-archive-directory
3146 gnus-group-recent-archive-directory))))
3147 (gnus-group-add-parameter group (cons 'to-address "ding@gnus.org"))))
3148
3149(defun gnus-group-make-directory-group (dir)
3150 "Create an nndir group.
3151The user will be prompted for a directory. The contents of this
c30ba437 3152directory will be used as a newsgroup. The directory should contain
eec82323
LMI		 3153mail messages or news articles in files that have numeric names."
3154 (interactive
3155 (list (read-file-name "Create group from directory: ")))
3156 (unless (file-exists-p dir)
3157 (error "No such directory"))
3158 (unless (file-directory-p dir)
3159 (error "Not a directory"))
3160 (let ((ext "")
3161 (i 0)
3162 group)
01c52d31 3163 (while (or (not group) (gnus-group-entry group))
eec82323
LMI		 3164 (setq group
3165 (gnus-group-prefixed-name
c6e7b580 3166 (expand-file-name ext dir)
eec82323
LMI		 3167 '(nndir "")))
3168 (setq ext (format "<%d>" (setq i (1+ i)))))
3169 (gnus-group-make-group
3170 (gnus-group-real-name group)
3171 (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir)))))
3172
23f87bed 3173(defvar nnkiboze-score-file)
39c7e99d
GM		 3174(declare-function nnkiboze-score-file "nnkiboze" (group))
3175
eec82323
LMI		 3176(defun gnus-group-make-kiboze-group (group address scores)
3177 "Create an nnkiboze group.
3178The user will be prompted for a name, a regexp to match groups, and
3179score file entries for articles to include in the group."
3180 (interactive
3181 (list
3182 (read-string "nnkiboze group name: ")
3183 (read-string "Source groups (regexp): ")
01c52d31 3184 (let ((headers (mapcar 'list
eec82323
LMI		 3185 '("subject" "from" "number" "date" "message-id"
3186 "references" "chars" "lines" "xref"
3187 "followup" "all" "body" "head")))
3188 scores header regexp regexps)
3189 (while (not (equal "" (setq header (completing-read
3190 "Match on header: " headers nil t))))
3191 (setq regexps nil)
3192 (while (not (equal "" (setq regexp (read-string
2491844d 3193 (format "Match on %s (regexp): "
eec82323
LMI		 3194 header)))))
3195 (push (list regexp nil nil 'r) regexps))
3196 (push (cons header regexps) scores))
3197 scores)))
3198 (gnus-group-make-group group "nnkiboze" address)
2491844d
DL		 3199 (let* ((nnkiboze-current-group group)
3200 (score-file (car (nnkiboze-score-file "")))
8b93df01
DL		 3201 (score-dir (file-name-directory score-file)))
3202 (unless (file-exists-p score-dir)
3203 (make-directory score-dir))
3204 (with-temp-file score-file
3205 (let (emacs-lisp-mode-hook)
23f87bed 3206 (gnus-pp scores)))))
eec82323
LMI		 3207
3208(defun gnus-group-add-to-virtual (n vgroup)
3209 "Add the current group to a virtual group."
3210 (interactive
3211 (list current-prefix-arg
3212 (completing-read "Add to virtual group: " gnus-newsrc-hashtb nil t
3213 "nnvirtual:")))
3214 (unless (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual)
3215 (error "%s is not an nnvirtual group" vgroup))
3216 (gnus-close-group vgroup)
3217 (let* ((groups (gnus-group-process-prefix n))
3218 (method (gnus-info-method (gnus-get-info vgroup))))
3219 (setcar (cdr method)
3220 (concat
3221 (nth 1 method) "\\|"
3222 (mapconcat
3223 (lambda (s)
3224 (gnus-group-remove-mark s)
3225 (concat "\\(^" (regexp-quote s) "$\\)"))
3226 groups "\\|"))))
3227 (gnus-group-position-point))
3228
3229(defun gnus-group-make-empty-virtual (group)
3230 "Create a new, fresh, empty virtual group."
3231 (interactive "sCreate new, empty virtual group: ")
3232 (let* ((method (list 'nnvirtual "^$"))
3233 (pgroup (gnus-group-prefixed-name group method)))
3234 ;; Check whether it exists already.
01c52d31 3235 (when (gnus-group-entry pgroup)
a8151ef7 3236 (error "Group %s already exists" pgroup))
eec82323
LMI		 3237 ;; Subscribe the new group after the group on the current line.
3238 (gnus-subscribe-group pgroup (gnus-group-group-name) method)
3239 (gnus-group-update-group pgroup)
3240 (forward-line -1)
3241 (gnus-group-position-point)))
3242
3243(defun gnus-group-enter-directory (dir)
3244 "Enter an ephemeral nneething group."
3245 (interactive "DDirectory to read: ")
3246 (let* ((method (list 'nneething dir '(nneething-read-only t)))
3247 (leaf (gnus-group-prefixed-name
3248 (file-name-nondirectory (directory-file-name dir))
3249 method))
3250 (name (gnus-generate-new-group-name leaf)))
3251 (unless (gnus-group-read-ephemeral-group
3252 name method t
3253 (cons (current-buffer)
3254 (if (eq major-mode 'gnus-summary-mode)
3255 'summary 'group)))
3256 (error "Couldn't enter %s" dir))))
3257
aea499b2
GM		 3258(autoload 'nnimap-expunge "nnimap")
3259(autoload 'nnimap-acl-get "nnimap")
3260(autoload 'nnimap-acl-edit "nnimap")
16409b0b
GM		 3261
3262(defun gnus-group-nnimap-expunge (group)
3263 "Expunge deleted articles in current nnimap GROUP."
3264 (interactive (list (gnus-group-group-name)))
3265 (let ((mailbox (gnus-group-real-name group)) method)
3266 (unless group
3267 (error "No group on current line"))
3268 (unless (gnus-get-info group)
3269 (error "Killed group; can't be edited"))
3270 (unless (eq 'nnimap (car (setq method (gnus-find-method-for-group group))))
3271 (error "%s is not an nnimap group" group))
3272 (nnimap-expunge mailbox (cadr method))))
3273
3274(defun gnus-group-nnimap-edit-acl (group)
3275 "Edit the Access Control List of current nnimap GROUP."
3276 (interactive (list (gnus-group-group-name)))
3277 (let ((mailbox (gnus-group-real-name group)) method acl)
3278 (unless group
3279 (error "No group on current line"))
3280 (unless (gnus-get-info group)
3281 (error "Killed group; can't be edited"))
3282 (unless (eq (car (setq method (gnus-find-method-for-group group))) 'nnimap)
3283 (error "%s is not an nnimap group" group))
2491844d
DL		 3284 (unless (setq acl (nnimap-acl-get mailbox (cadr method)))
3285 (error "Server does not support ACL's"))
3286 (gnus-edit-form acl (format "Editing the access control list for `%s'.
16409b0b
GM		 3287
3288 An access control list is a list of (identifier . rights) elements.
3289
3290 The identifier string specifies the corresponding user. The
3291 identifier \"anyone\" is reserved to refer to the universal identity.
3292
3293 Rights is a string listing a (possibly empty) set of alphanumeric
3294 characters, each character listing a set of operations which is being
3295 controlled. Letters are reserved for ``standard'' rights, listed
3296 below. Digits are reserved for implementation or site defined rights.
3297
3298 l - lookup (mailbox is visible to LIST/LSUB commands)
3299 r - read (SELECT the mailbox, perform CHECK, FETCH, PARTIAL,
3300 SEARCH, COPY from mailbox)
3301 s - keep seen/unseen information across sessions (STORE \\SEEN flag)
3302 w - write (STORE flags other than \\SEEN and \\DELETED)
3303 i - insert (perform APPEND, COPY into mailbox)
3304 p - post (send mail to submission address for mailbox,
3305 not enforced by IMAP4 itself)
3306 c - create and delete mailbox (CREATE new sub-mailboxes in any
3307 implementation-defined hierarchy, RENAME or DELETE mailbox)
3308 d - delete messages (STORE \\DELETED flag, perform EXPUNGE)
3309 a - administer (perform SETACL)" group)
3310 `(lambda (form)
3311 (nnimap-acl-edit
3312 ,mailbox ',method ',acl form)))))
3313
eec82323
LMI		 3314;; Group sorting commands
3315;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>.
3316
3317(defun gnus-group-sort-groups (func &optional reverse)
3318 "Sort the group buffer according to FUNC.
3319When used interactively, the sorting function used will be
3320determined by the `gnus-group-sort-function' variable.
3321If REVERSE (the prefix), reverse the sorting order."
3322 (interactive (list gnus-group-sort-function current-prefix-arg))
3323 (funcall gnus-group-sort-alist-function
3324 (gnus-make-sort-function func) reverse)
23f87bed 3325 (gnus-group-unmark-all-groups)
eec82323
LMI		 3326 (gnus-group-list-groups)
3327 (gnus-dribble-touch))
3328
3329(defun gnus-group-sort-flat (func reverse)
3330 ;; We peel off the dummy group from the alist.
3331 (when func
3332 (when (equal (gnus-info-group (car gnus-newsrc-alist)) "dummy.group")
3333 (pop gnus-newsrc-alist))
3334 ;; Do the sorting.
3335 (setq gnus-newsrc-alist
3336 (sort gnus-newsrc-alist func))
3337 (when reverse
3338 (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist)))
3339 ;; Regenerate the hash table.
3340 (gnus-make-hashtable-from-newsrc-alist)))
3341
3342(defun gnus-group-sort-groups-by-alphabet (&optional reverse)
3343 "Sort the group buffer alphabetically by group name.
3344If REVERSE, sort in reverse order."
3345 (interactive "P")
3346 (gnus-group-sort-groups 'gnus-group-sort-by-alphabet reverse))
3347
23f87bed
MB		 3348(defun gnus-group-sort-groups-by-real-name (&optional reverse)
3349 "Sort the group buffer alphabetically by real (unprefixed) group name.
3350If REVERSE, sort in reverse order."
3351 (interactive "P")
3352 (gnus-group-sort-groups 'gnus-group-sort-by-real-name reverse))
3353
eec82323
LMI		 3354(defun gnus-group-sort-groups-by-unread (&optional reverse)
3355 "Sort the group buffer by number of unread articles.
3356If REVERSE, sort in reverse order."
3357 (interactive "P")
3358 (gnus-group-sort-groups 'gnus-group-sort-by-unread reverse))
3359
3360(defun gnus-group-sort-groups-by-level (&optional reverse)
3361 "Sort the group buffer by group level.
3362If REVERSE, sort in reverse order."
3363 (interactive "P")
3364 (gnus-group-sort-groups 'gnus-group-sort-by-level reverse))
3365
3366(defun gnus-group-sort-groups-by-score (&optional reverse)
3367 "Sort the group buffer by group score.
3368If REVERSE, sort in reverse order."
3369 (interactive "P")
3370 (gnus-group-sort-groups 'gnus-group-sort-by-score reverse))
3371
3372(defun gnus-group-sort-groups-by-rank (&optional reverse)
3373 "Sort the group buffer by group rank.
3374If REVERSE, sort in reverse order."
3375 (interactive "P")
3376 (gnus-group-sort-groups 'gnus-group-sort-by-rank reverse))
3377
3378(defun gnus-group-sort-groups-by-method (&optional reverse)
23f87bed 3379 "Sort the group buffer alphabetically by back end name.
eec82323
LMI		 3380If REVERSE, sort in reverse order."
3381 (interactive "P")
3382 (gnus-group-sort-groups 'gnus-group-sort-by-method reverse))
3383
23f87bed
MB		 3384(defun gnus-group-sort-groups-by-server (&optional reverse)
3385 "Sort the group buffer alphabetically by server name.
3386If REVERSE, sort in reverse order."
3387 (interactive "P")
3388 (gnus-group-sort-groups 'gnus-group-sort-by-server reverse))
3389
eec82323
LMI		 3390;;; Selected group sorting.
3391
3392(defun gnus-group-sort-selected-groups (n func &optional reverse)
3393 "Sort the process/prefixed groups."
3394 (interactive (list current-prefix-arg gnus-group-sort-function))
3395 (let ((groups (gnus-group-process-prefix n)))
3396 (funcall gnus-group-sort-selected-function
3397 groups (gnus-make-sort-function func) reverse)
23f87bed
MB		 3398 (gnus-group-unmark-all-groups)
3399 (gnus-group-list-groups)
3400 (gnus-dribble-touch)))
eec82323
LMI		 3401
3402(defun gnus-group-sort-selected-flat (groups func reverse)
3403 (let (entries infos)
3404 ;; First find all the group entries for these groups.
3405 (while groups
01c52d31 3406 (push (nthcdr 2 (gnus-group-entry (pop groups)))
eec82323
LMI		 3407 entries))
3408 ;; Then sort the infos.
3409 (setq infos
3410 (sort
3411 (mapcar
3412 (lambda (entry) (car entry))
3413 (setq entries (nreverse entries)))
3414 func))
3415 (when reverse
3416 (setq infos (nreverse infos)))
3417 ;; Go through all the infos and replace the old entries
3418 ;; with the new infos.
3419 (while infos
16409b0b 3420 (setcar (car entries) (pop infos))
eec82323
LMI		 3421 (pop entries))
3422 ;; Update the hashtable.
3423 (gnus-make-hashtable-from-newsrc-alist)))
3424
16409b0b 3425(defun gnus-group-sort-selected-groups-by-alphabet (&optional n reverse)
eec82323 3426 "Sort the group buffer alphabetically by group name.
16409b0b
GM		 3427Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
3428sort in reverse order."
3429 (interactive (gnus-interactive "P\ny"))
3430 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-alphabet reverse))
eec82323 3431
23f87bed
MB		 3432(defun gnus-group-sort-selected-groups-by-real-name (&optional n reverse)
3433 "Sort the group buffer alphabetically by real group name.
3434Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
3435sort in reverse order."
3436 (interactive (gnus-interactive "P\ny"))
3437 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-real-name reverse))
3438
16409b0b 3439(defun gnus-group-sort-selected-groups-by-unread (&optional n reverse)
eec82323 3440 "Sort the group buffer by number of unread articles.
16409b0b
GM		 3441Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
3442sort in reverse order."
3443 (interactive (gnus-interactive "P\ny"))
3444 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-unread reverse))
eec82323 3445
16409b0b 3446(defun gnus-group-sort-selected-groups-by-level (&optional n reverse)
eec82323 3447 "Sort the group buffer by group level.
16409b0b
GM		 3448Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
3449sort in reverse order."
3450 (interactive (gnus-interactive "P\ny"))
3451 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-level reverse))
eec82323 3452
16409b0b 3453(defun gnus-group-sort-selected-groups-by-score (&optional n reverse)
eec82323 3454 "Sort the group buffer by group score.
16409b0b
GM		 3455Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
3456sort in reverse order."
3457 (interactive (gnus-interactive "P\ny"))
3458 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-score reverse))
eec82323 3459
16409b0b 3460(defun gnus-group-sort-selected-groups-by-rank (&optional n reverse)
eec82323 3461 "Sort the group buffer by group rank.
16409b0b
GM		 3462Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
3463sort in reverse order."
3464 (interactive (gnus-interactive "P\ny"))
3465 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-rank reverse))
eec82323 3466
16409b0b 3467(defun gnus-group-sort-selected-groups-by-method (&optional n reverse)
23f87bed 3468 "Sort the group buffer alphabetically by back end name.
16409b0b
GM		 3469Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
3470sort in reverse order."
3471 (interactive (gnus-interactive "P\ny"))
3472 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-method reverse))
eec82323
LMI		 3473
3474;;; Sorting predicates.
3475
3476(defun gnus-group-sort-by-alphabet (info1 info2)
3477 "Sort alphabetically."
3478 (string< (gnus-info-group info1) (gnus-info-group info2)))
3479
3480(defun gnus-group-sort-by-real-name (info1 info2)
3481 "Sort alphabetically on real (unprefixed) names."
3482 (string< (gnus-group-real-name (gnus-info-group info1))
3483 (gnus-group-real-name (gnus-info-group info2))))
3484
3485(defun gnus-group-sort-by-unread (info1 info2)
3486 "Sort by number of unread articles."
01c52d31
MB		 3487 (let ((n1 (gnus-group-unread (gnus-info-group info1)))
3488 (n2 (gnus-group-unread (gnus-info-group info2))))
eec82323
LMI		 3489 (< (or (and (numberp n1) n1) 0)
3490 (or (and (numberp n2) n2) 0))))
3491
3492(defun gnus-group-sort-by-level (info1 info2)
3493 "Sort by level."
3494 (< (gnus-info-level info1) (gnus-info-level info2)))
3495
3496(defun gnus-group-sort-by-method (info1 info2)
23f87bed
MB		 3497 "Sort alphabetically by back end name."
3498 (string< (car (gnus-find-method-for-group
3499 (gnus-info-group info1) info1))
3500 (car (gnus-find-method-for-group
3501 (gnus-info-group info2) info2))))
3502
3503(defun gnus-group-sort-by-server (info1 info2)
3504 "Sort alphabetically by server name."
3505 (string< (gnus-method-to-full-server-name
3506 (gnus-find-method-for-group
3507 (gnus-info-group info1) info1))
3508 (gnus-method-to-full-server-name
3509 (gnus-find-method-for-group
3510 (gnus-info-group info2) info2))))
eec82323
LMI		 3511
3512(defun gnus-group-sort-by-score (info1 info2)
3513 "Sort by group score."
23f87bed 3514 (> (gnus-info-score info1) (gnus-info-score info2)))
eec82323
LMI		 3515
3516(defun gnus-group-sort-by-rank (info1 info2)
3517 "Sort by level and score."
3518 (let ((level1 (gnus-info-level info1))
3519 (level2 (gnus-info-level info2)))
3520 (or (< level1 level2)
3521 (and (= level1 level2)
3522 (> (gnus-info-score info1) (gnus-info-score info2))))))
3523
3524;;; Clearing data
3525
3526(defun gnus-group-clear-data (&optional arg)
ff4d3926
MB		 3527 "Clear all marks and read ranges from the current group.
3528Obeys the process/prefix convention."
eec82323
LMI		 3529 (interactive "P")
3530 (gnus-group-iterate arg
3531 (lambda (group)
3532 (let (info)
3533 (gnus-info-clear-data (setq info (gnus-get-info group)))
3534 (gnus-get-unread-articles-in-group info (gnus-active group) t)
3535 (when (gnus-group-goto-group group)
3536 (gnus-group-update-group-line))))))
3537
3538(defun gnus-group-clear-data-on-native-groups ()
3539 "Clear all marks and read ranges from all native groups."
3540 (interactive)
3541 (when (gnus-yes-or-no-p "Really clear all data from almost all groups? ")
3542 (let ((alist (cdr gnus-newsrc-alist))
3543 info)
3544 (while (setq info (pop alist))
3545 (when (gnus-group-native-p (gnus-info-group info))
3546 (gnus-info-clear-data info)))
3547 (gnus-get-unread-articles)
6748645f 3548 (gnus-dribble-touch)
eec82323
LMI		 3549 (when (gnus-y-or-n-p
3550 "Move the cache away to avoid problems in the future? ")
3551 (call-interactively 'gnus-cache-move-cache)))))
3552
3553(defun gnus-info-clear-data (info)
3554 "Clear all marks and read ranges from INFO."
23f87bed
MB		 3555 (let ((group (gnus-info-group info))
3556 action)
3557 (dolist (el (gnus-info-marks info))
3558 (push `(,(cdr el) add (,(car el))) action))
3559 (push `(,(gnus-info-read info) add (read)) action)
eec82323
LMI		 3560 (gnus-undo-register
3561 `(progn
23f87bed 3562 (gnus-request-set-mark ,group ',action)
eec82323
LMI		 3563 (gnus-info-set-marks ',info ',(gnus-info-marks info) t)
3564 (gnus-info-set-read ',info ',(gnus-info-read info))
3565 (when (gnus-group-goto-group ,group)
23f87bed 3566 (gnus-get-unread-articles-in-group ',info ',(gnus-active group) t)
eec82323 3567 (gnus-group-update-group-line))))
23f87bed
MB		 3568 (setq action (mapcar (lambda (el) (list (nth 0 el) 'del (nth 2 el)))
3569 action))
3570 (gnus-request-set-mark group action)
eec82323
LMI		 3571 (gnus-info-set-read info nil)
3572 (when (gnus-info-marks info)
3573 (gnus-info-set-marks info nil))))
3574
3575;; Group catching up.
3576
3577(defun gnus-group-catchup-current (&optional n all)
16409b0b 3578 "Mark all unread articles in the current newsgroup as read.
6748645f 3579If prefix argument N is numeric, the next N newsgroups will be
eec82323
LMI		 3580caught up. If ALL is non-nil, marked articles will also be marked as
3581read. Cross references (Xref: header) of articles are ignored.
6748645f
LMI		 3582The number of newsgroups that this function was unable to catch
3583up is returned."
eec82323 3584 (interactive "P")
eec82323 3585 (let ((groups (gnus-group-process-prefix n))
16409b0b
GM		 3586 (ret 0)
3587 group)
6748645f 3588 (unless groups (error "No groups selected"))
eec82323
LMI		 3589 (if (not
3590 (or (not gnus-interactive-catchup) ;Without confirmation?
3591 gnus-expert-user
3592 (gnus-y-or-n-p
3593 (format
3594 (if all
3595 "Do you really want to mark all articles in %s as read? "
3596 "Mark all unread articles in %s as read? ")
3597 (if (= (length groups) 1)
91472578 3598 (gnus-group-decoded-name (car groups))
eec82323
LMI		 3599 (format "these %d groups" (length groups)))))))
3600 n
16409b0b
GM		 3601 (while (setq group (pop groups))
3602 (gnus-group-remove-mark group)
eec82323 3603 ;; Virtual groups have to be given special treatment.
16409b0b 3604 (let ((method (gnus-find-method-for-group group)))
eec82323
LMI		 3605 (when (eq 'nnvirtual (car method))
3606 (nnvirtual-catchup-group
16409b0b 3607 (gnus-group-real-name group) (nth 1 method) all)))
01c52d31
MB		 3608 (cond
3609 ((>= (gnus-group-level group) gnus-level-zombie)
3610 (gnus-message 2 "Dead groups can't be caught up"))
3611 ((prog1
3612 (gnus-group-goto-group group)
3613 (gnus-group-catchup group all))
3614 (gnus-group-update-group-line))
3615 (t
3616 (setq ret (1+ ret)))))
eec82323
LMI		 3617 (gnus-group-next-unread-group 1)
3618 ret)))
3619
3620(defun gnus-group-catchup-current-all (&optional n)
3621 "Mark all articles in current newsgroup as read.
3622Cross references (Xref: header) of articles are ignored."
3623 (interactive "P")
3624 (gnus-group-catchup-current n 'all))
3625
3626(defun gnus-group-catchup (group &optional all)
3627 "Mark all articles in GROUP as read.
3628If ALL is non-nil, all articles are marked as read.
3629The return value is the number of articles that were marked as read,
3630or nil if no action could be taken."
01c52d31 3631 (let* ((entry (gnus-group-entry group))
23f87bed 3632 (num (car entry))
01c52d31 3633 (marks (gnus-info-marks (nth 2 entry)))
54506618 3634 (unread (gnus-sequence-of-unread-articles group)))
16409b0b
GM		 3635 ;; Remove entries for this group.
3636 (nnmail-purge-split-history (gnus-group-real-name group))
eec82323
LMI		 3637 ;; Do the updating only if the newsgroup isn't killed.
3638 (if (not (numberp (car entry)))
3639 (gnus-message 1 "Can't catch up %s; non-active group" group)
23f87bed
MB		 3640 (gnus-update-read-articles group nil)
3641 (when all
3642 ;; Nix out the lists of marks and dormants.
3643 (gnus-request-set-mark group (list (list (cdr (assq 'tick marks))
3644 'del '(tick))
3645 (list (cdr (assq 'dormant marks))
3646 'del '(dormant))))
54506618 3647 (setq unread (gnus-range-add (gnus-range-add
01c52d31
MB		 3648 unread (cdr (assq 'dormant marks)))
3649 (cdr (assq 'tick marks))))
23f87bed
MB		 3650 (gnus-add-marked-articles group 'tick nil nil 'force)
3651 (gnus-add-marked-articles group 'dormant nil nil 'force))
eec82323
LMI		 3652 ;; Do auto-expirable marks if that's required.
3653 (when (gnus-group-auto-expirable-p group)
01c52d31
MB		 3654 (gnus-range-map
3655 (lambda (article)
3656 (gnus-add-marked-articles group 'expire (list article))
3657 (gnus-request-set-mark group (list (list (list article)
3658 'add '(expire)))))
3659 unread))
23f87bed
MB		 3660 (let ((gnus-newsgroup-name group))
3661 (gnus-run-hooks 'gnus-group-catchup-group-hook))
3662 num)))
eec82323
LMI		 3663
3664(defun gnus-group-expire-articles (&optional n)
23f87bed
MB		 3665 "Expire all expirable articles in the current newsgroup.
3666Uses the process/prefix convention."
eec82323
LMI		 3667 (interactive "P")
3668 (let ((groups (gnus-group-process-prefix n))
3669 group)
3670 (unless groups
3671 (error "No groups to expire"))
3672 (while (setq group (pop groups))
3673 (gnus-group-remove-mark group)
16409b0b 3674 (gnus-group-expire-articles-1 group)
eec82323
LMI		 3675 (gnus-dribble-touch)
3676 (gnus-group-position-point))))
3677
16409b0b
GM		 3678(defun gnus-group-expire-articles-1 (group)
3679 (when (gnus-check-backend-function 'request-expire-articles group)
91472578
MB		 3680 (gnus-message 6 "Expiring articles in %s..."
3681 (gnus-group-decoded-name group))
16409b0b
GM		 3682 (let* ((info (gnus-get-info group))
3683 (expirable (if (gnus-group-total-expirable-p group)
3684 (cons nil (gnus-list-of-read-articles group))
3685 (assq 'expire (gnus-info-marks info))))
3686 (expiry-wait (gnus-group-find-parameter group 'expiry-wait))
3687 (nnmail-expiry-target
3688 (or (gnus-group-find-parameter group 'expiry-target)
3689 nnmail-expiry-target)))
3690 (when expirable
3691 (gnus-check-group group)
3692 (setcdr
3693 expirable
3694 (gnus-compress-sequence
3695 (if expiry-wait
3696 ;; We set the expiry variables to the group
3697 ;; parameter.
3698 (let ((nnmail-expiry-wait-function nil)
3699 (nnmail-expiry-wait expiry-wait))
3700 (gnus-request-expire-articles
3701 (gnus-uncompress-sequence (cdr expirable)) group))
3702 ;; Just expire using the normal expiry values.
3703 (gnus-request-expire-articles
3704 (gnus-uncompress-sequence (cdr expirable)) group))))
3705 (gnus-close-group group))
91472578
MB		 3706 (gnus-message 6 "Expiring articles in %s...done"
3707 (gnus-group-decoded-name group))
16409b0b
GM		 3708 ;; Return the list of un-expired articles.
3709 (cdr expirable))))
3710
eec82323
LMI		 3711(defun gnus-group-expire-all-groups ()
3712 "Expire all expirable articles in all newsgroups."
3713 (interactive)
3714 (save-excursion
3715 (gnus-message 5 "Expiring...")
3716 (let ((gnus-group-marked (mapcar (lambda (info) (gnus-info-group info))
3717 (cdr gnus-newsrc-alist))))
3718 (gnus-group-expire-articles nil)))
3719 (gnus-group-position-point)
3720 (gnus-message 5 "Expiring...done"))
3721
3722(defun gnus-group-set-current-level (n level)
3723 "Set the level of the next N groups to LEVEL."
3724 (interactive
3725 (list
3726 current-prefix-arg
23f87bed
MB		 3727 (progn
3728 (unless (gnus-group-process-prefix current-prefix-arg)
3729 (error "No group on the current line"))
e9bd5782 3730 (string-to-number
23f87bed
MB		 3731 (let ((s (read-string
3732 (format "Level (default %s): "
3733 (or (gnus-group-group-level)
3734 gnus-level-default-subscribed)))))
3735 (if (string-match "^\\s-*$" s)
3736 (int-to-string (or (gnus-group-group-level)
3737 gnus-level-default-subscribed))
3738 s))))))
eec82323 3739 (unless (and (>= level 1) (<= level gnus-level-killed))
16409b0b 3740 (error "Invalid level: %d" level))
01c52d31
MB		 3741 (dolist (group (gnus-group-process-prefix n))
3742 (gnus-group-remove-mark group)
3743 (gnus-message 6 "Changed level of %s from %d to %d"
3744 (gnus-group-decoded-name group)
3745 (or (gnus-group-group-level) gnus-level-killed)
3746 level)
3747 (gnus-group-change-level
3748 group level (or (gnus-group-group-level) gnus-level-killed))
3749 (gnus-group-update-group-line))
eec82323
LMI		 3750 (gnus-group-position-point))
3751
3752(defun gnus-group-unsubscribe (&optional n)
3753 "Unsubscribe the current group."
3754 (interactive "P")
3755 (gnus-group-unsubscribe-current-group n 'unsubscribe))
3756
3757(defun gnus-group-subscribe (&optional n)
3758 "Subscribe the current group."
3759 (interactive "P")
3760 (gnus-group-unsubscribe-current-group n 'subscribe))
3761
3762(defun gnus-group-unsubscribe-current-group (&optional n do-sub)
3763 "Toggle subscription of the current group.
3764If given numerical prefix, toggle the N next groups."
3765 (interactive "P")
23f87bed
MB		 3766 (dolist (group (gnus-group-process-prefix n))
3767 (gnus-group-remove-mark group)
3768 (gnus-group-unsubscribe-group
3769 group
3770 (cond
3771 ((eq do-sub 'unsubscribe)
3772 gnus-level-default-unsubscribed)
3773 ((eq do-sub 'subscribe)
3774 gnus-level-default-subscribed)
3775 ((<= (gnus-group-group-level) gnus-level-subscribed)
3776 gnus-level-default-unsubscribed)
3777 (t
3778 gnus-level-default-subscribed))
3779 t)
3780 (gnus-group-update-group-line))
3781 (gnus-group-next-group 1))
eec82323
LMI		 3782
3783(defun gnus-group-unsubscribe-group (group &optional level silent)
3784 "Toggle subscription to GROUP.
3785Killed newsgroups are subscribed. If SILENT, don't try to update the
3786group line."
01c52d31
MB		 3787 (interactive (list (gnus-group-completing-read
3788 "Group: " nil nil (gnus-read-active-file-p))))
3789 (let ((newsrc (gnus-group-entry group)))
eec82323 3790 (cond
6748645f 3791 ((string-match "^[ \t]*$" group)
eec82323
LMI		 3792 (error "Empty group name"))
3793 (newsrc
3794 ;; Toggle subscription flag.
3795 (gnus-group-change-level
3796 newsrc (if level level (if (<= (gnus-info-level (nth 2 newsrc))
3797 gnus-level-subscribed)
3798 (1+ gnus-level-subscribed)
3799 gnus-level-default-subscribed)))
3800 (unless silent
3801 (gnus-group-update-group group)))
3802 ((and (stringp group)
3803 (or (not (gnus-read-active-file-p))
3804 (gnus-active group)))
3805 ;; Add new newsgroup.
3806 (gnus-group-change-level
3807 group
3808 (if level level gnus-level-default-subscribed)
3809 (or (and (member group gnus-zombie-list)
3810 gnus-level-zombie)
3811 gnus-level-killed)
3812 (when (gnus-group-group-name)
01c52d31 3813 (gnus-group-entry (gnus-group-group-name))))
eec82323
LMI		 3814 (unless silent
3815 (gnus-group-update-group group)))
3816 (t (error "No such newsgroup: %s" group)))
3817 (gnus-group-position-point)))
3818
3819(defun gnus-group-transpose-groups (n)
3820 "Move the current newsgroup up N places.
c30ba437 3821If given a negative prefix, move down instead. The difference between
eec82323
LMI		 3822N and the number of steps taken is returned."
3823 (interactive "p")
3824 (unless (gnus-group-group-name)
3825 (error "No group on current line"))
3826 (gnus-group-kill-group 1)
3827 (prog1
3828 (forward-line (- n))
3829 (gnus-group-yank-group)
3830 (gnus-group-position-point)))
3831
16409b0b
GM		 3832(defun gnus-group-kill-all-zombies (&optional dummy)
3833 "Kill all zombie newsgroups.
3834The optional DUMMY should always be nil."
3835 (interactive (list (not (gnus-yes-or-no-p "Really kill all zombies? "))))
3836 (unless dummy
3837 (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list))
3838 (setq gnus-zombie-list nil)
3839 (gnus-dribble-touch)
3840 (gnus-group-list-groups)))
eec82323
LMI		 3841
3842(defun gnus-group-kill-region (begin end)
3843 "Kill newsgroups in current region (excluding current point).
3844The killed newsgroups can be yanked by using \\[gnus-group-yank-group]."
3845 (interactive "r")
3846 (let ((lines
3847 ;; Count lines.
3848 (save-excursion
3849 (count-lines
3850 (progn
3851 (goto-char begin)
01c52d31 3852 (point-at-bol))
eec82323
LMI		 3853 (progn
3854 (goto-char end)
01c52d31 3855 (point-at-bol))))))
eec82323
LMI		 3856 (goto-char begin)
3857 (beginning-of-line) ;Important when LINES < 1
3858 (gnus-group-kill-group lines)))
3859
3860(defun gnus-group-kill-group (&optional n discard)
3861 "Kill the next N groups.
3862The killed newsgroups can be yanked by using \\[gnus-group-yank-group].
3863However, only groups that were alive can be yanked; already killed
3864groups or zombie groups can't be yanked.
3865The return value is the name of the group that was killed, or a list
3866of groups killed."
3867 (interactive "P")
3868 (let ((buffer-read-only nil)
3869 (groups (gnus-group-process-prefix n))
3870 group entry level out)
3871 (if (< (length groups) 10)
3872 ;; This is faster when there are few groups.
3873 (while groups
3874 (push (setq group (pop groups)) out)
3875 (gnus-group-remove-mark group)
3876 (setq level (gnus-group-group-level))
3877 (gnus-delete-line)
3878 (when (and (not discard)
01c52d31 3879 (setq entry (gnus-group-entry group)))
eec82323
LMI		 3880 (gnus-undo-register
3881 `(progn
3882 (gnus-group-goto-group ,(gnus-group-group-name))
3883 (gnus-group-yank-group)))
3884 (push (cons (car entry) (nth 2 entry))
3885 gnus-list-of-killed-groups))
3886 (gnus-group-change-level
16409b0b 3887 (if entry entry group) gnus-level-killed (if entry nil level))
91472578 3888 (message "Killed group %s" (gnus-group-decoded-name group)))
eec82323
LMI		 3889 ;; If there are lots and lots of groups to be killed, we use
3890 ;; this thing instead.
23f87bed
MB		 3891 (dolist (group (nreverse groups))
3892 (gnus-group-remove-mark group)
3893 (gnus-delete-line)
3894 (push group gnus-killed-list)
3895 (setq gnus-newsrc-alist
3896 (delq (assoc group gnus-newsrc-alist)
3897 gnus-newsrc-alist))
3898 (when gnus-group-change-level-function
3899 (funcall gnus-group-change-level-function
3900 group gnus-level-killed 3))
3901 (cond
01c52d31 3902 ((setq entry (gnus-group-entry group))
23f87bed
MB		 3903 (push (cons (car entry) (nth 2 entry))
3904 gnus-list-of-killed-groups)
3905 (setcdr (cdr entry) (cdddr entry)))
3906 ((member group gnus-zombie-list)
3907 (setq gnus-zombie-list (delete group gnus-zombie-list))))
3908 ;; There may be more than one instance displayed.
3909 (while (gnus-group-goto-group group)
3910 (gnus-delete-line)))
3911 (gnus-make-hashtable-from-newsrc-alist))
eec82323
LMI		 3912
3913 (gnus-group-position-point)
3914 (if (< (length out) 2) (car out) (nreverse out))))
3915
3916(defun gnus-group-yank-group (&optional arg)
6748645f
LMI		 3917 "Yank the last newsgroups killed with \\[gnus-group-kill-group], inserting it before the current newsgroup.
3918The numeric ARG specifies how many newsgroups are to be yanked. The
3919name of the newsgroup yanked is returned, or (if several groups are
3920yanked) a list of yanked groups is returned."
eec82323
LMI		 3921 (interactive "p")
3922 (setq arg (or arg 1))
3923 (let (info group prev out)
3924 (while (>= (decf arg) 0)
3925 (when (not (setq info (pop gnus-list-of-killed-groups)))
3926 (error "No more newsgroups to yank"))
3927 (push (setq group (nth 1 info)) out)
3928 ;; Find which newsgroup to insert this one before - search
3929 ;; backward until something suitable is found. If there are no
3930 ;; other newsgroups in this buffer, just make this newsgroup the
3931 ;; first newsgroup.
3932 (setq prev (gnus-group-group-name))
3933 (gnus-group-change-level
3934 info (gnus-info-level (cdr info)) gnus-level-killed
01c52d31 3935 (and prev (gnus-group-entry prev))
eec82323
LMI		 3936 t)
3937 (gnus-group-insert-group-line-info group)
3938 (gnus-undo-register
3939 `(when (gnus-group-goto-group ,group)
3940 (gnus-group-kill-group 1))))
3941 (forward-line -1)
3942 (gnus-group-position-point)
3943 (if (< (length out) 2) (car out) (nreverse out))))
3944
3945(defun gnus-group-kill-level (level)
3946 "Kill all groups that is on a certain LEVEL."
3947 (interactive "nKill all groups on level: ")
3948 (cond
3949 ((= level gnus-level-zombie)
3950 (setq gnus-killed-list
3951 (nconc gnus-zombie-list gnus-killed-list))
3952 (setq gnus-zombie-list nil))
3953 ((and (< level gnus-level-zombie)
3954 (> level 0)
3955 (or gnus-expert-user
3956 (gnus-yes-or-no-p
3957 (format
3958 "Do you really want to kill all groups on level %d? "
3959 level))))
3960 (let* ((prev gnus-newsrc-alist)
3961 (alist (cdr prev)))
3962 (while alist
3963 (if (= (gnus-info-level (car alist)) level)
3964 (progn
3965 (push (gnus-info-group (car alist)) gnus-killed-list)
3966 (setcdr prev (cdr alist)))
3967 (setq prev alist))
3968 (setq alist (cdr alist)))
3969 (gnus-make-hashtable-from-newsrc-alist)
3970 (gnus-group-list-groups)))
3971 (t
16409b0b 3972 (error "Can't kill; invalid level: %d" level))))
eec82323
LMI		 3973
3974(defun gnus-group-list-all-groups (&optional arg)
3975 "List all newsgroups with level ARG or lower.
23f87bed 3976Default is `gnus-level-unsubscribed', which lists all subscribed and most
eec82323
LMI		 3977unsubscribed groups."
3978 (interactive "P")
3979 (gnus-group-list-groups (or arg gnus-level-unsubscribed) t))
3980
3981;; Redefine this to list ALL killed groups if prefix arg used.
3982;; Rewritten by engstrom@src.honeywell.com (Eric Engstrom).
3983(defun gnus-group-list-killed (&optional arg)
3984 "List all killed newsgroups in the group buffer.
3985If ARG is non-nil, list ALL killed groups known to Gnus. This may
3986entail asking the server for the groups."
3987 (interactive "P")
3988 ;; Find all possible killed newsgroups if arg.
3989 (when arg
3990 (gnus-get-killed-groups))
3991 (if (not gnus-killed-list)
3992 (gnus-message 6 "No killed groups")
3993 (let (gnus-group-list-mode)
3994 (funcall gnus-group-prepare-function
3995 gnus-level-killed t gnus-level-killed))
3996 (goto-char (point-min)))
3997 (gnus-group-position-point))
3998
3999(defun gnus-group-list-zombies ()
4000 "List all zombie newsgroups in the group buffer."
4001 (interactive)
4002 (if (not gnus-zombie-list)
4003 (gnus-message 6 "No zombie groups")
4004 (let (gnus-group-list-mode)
4005 (funcall gnus-group-prepare-function
4006 gnus-level-zombie t gnus-level-zombie))
4007 (goto-char (point-min)))
4008 (gnus-group-position-point))
4009
4010(defun gnus-group-list-active ()
4011 "List all groups that are available from the server(s)."
4012 (interactive)
4013 ;; First we make sure that we have really read the active file.
4014 (unless (gnus-read-active-file-p)
16409b0b 4015 (let ((gnus-read-active-file t)
54506618 4016 (gnus-agent gnus-plugged)); If we're actually plugged, store the active file in the agent.
eec82323
LMI		 4017 (gnus-read-active-file)))
4018 ;; Find all groups and sort them.
4019 (let ((groups
4020 (sort
4021 (let (list)
4022 (mapatoms
4023 (lambda (sym)
4024 (and (boundp sym)
4025 (symbol-value sym)
4026 (push (symbol-name sym) list)))
4027 gnus-active-hashtb)
4028 list)
4029 'string<))
4030 (buffer-read-only nil)
4031 group)
4032 (erase-buffer)
4033 (while groups
16409b0b 4034 (setq group (pop groups))
eec82323
LMI		 4035 (gnus-add-text-properties
4036 (point) (prog1 (1+ (point))
4037 (insert " *: "
23f87bed 4038 (gnus-group-decoded-name group)
16409b0b 4039 "\n"))
eec82323
LMI		 4040 (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
4041 'gnus-unread t
4042 'gnus-level (inline (gnus-group-level group)))))
4043 (goto-char (point-min))))
4044
4045(defun gnus-activate-all-groups (level)
4046 "Activate absolutely all groups."
6748645f 4047 (interactive (list gnus-level-unsubscribed))
eec82323
LMI		 4048 (let ((gnus-activate-level level)
4049 (gnus-activate-foreign-newsgroups level))
4050 (gnus-group-get-new-news)))
4051
4052(defun gnus-group-get-new-news (&optional arg)
4053 "Get newly arrived articles.
4054If ARG is a number, it specifies which levels you are interested in
4055re-scanning. If ARG is non-nil and not a number, this will force
4056\"hard\" re-reading of the active files from all servers."
4057 (interactive "P")
16409b0b
GM		 4058 (require 'nnmail)
4059 (let ((gnus-inhibit-demon t)
4060 ;; Binding this variable will inhibit multiple fetchings
4061 ;; of the same mail source.
4062 (nnmail-fetched-sources (list t)))
23f87bed 4063 (gnus-run-hooks 'gnus-get-top-new-news-hook)
6748645f 4064 (gnus-run-hooks 'gnus-get-new-news-hook)
eec82323
LMI		 4065
4066 ;; Read any slave files.
4067 (unless gnus-slave
4068 (gnus-master-read-slave-newsrc))
4069
4070 ;; We might read in new NoCeM messages here.
4071 (when (and gnus-use-nocem
ea8ae765
MB		 4072 (or (and (numberp gnus-use-nocem)
4073 (numberp arg)
4074 (>= arg gnus-use-nocem))
4075 (not arg)))
eec82323
LMI		 4076 (gnus-nocem-scan-groups))
4077 ;; If ARG is not a number, then we read the active file.
4078 (when (and arg (not (numberp arg)))
4079 (let ((gnus-read-active-file t))
4080 (gnus-read-active-file))
4081 (setq arg nil)
4082
4083 ;; If the user wants it, we scan for new groups.
4084 (when (eq gnus-check-new-newsgroups 'always)
4085 (gnus-find-new-newsgroups)))
4086
4087 (setq arg (gnus-group-default-level arg t))
4088 (if (and gnus-read-active-file (not arg))
4089 (progn
4090 (gnus-read-active-file)
4091 (gnus-get-unread-articles arg))
4092 (let ((gnus-read-active-file (if arg nil gnus-read-active-file)))
4093 (gnus-get-unread-articles arg)))
01c52d31 4094 (gnus-check-reasonable-setup)
6748645f 4095 (gnus-run-hooks 'gnus-after-getting-new-news-hook)
eec82323
LMI		 4096 (gnus-group-list-groups (and (numberp arg)
4097 (max (car gnus-group-list-mode) arg)))))
4098
a8151ef7 4099(defun gnus-group-get-new-news-this-group (&optional n dont-scan)
eec82323
LMI		 4100 "Check for newly arrived news in the current group (and the N-1 next groups).
4101The difference between N and the number of newsgroup checked is returned.
531e5812
MB		 4102If N is negative, this group and the N-1 previous groups will be checked.
4103If DONT-SCAN is non-nil, scan non-activated groups as well."
eec82323
LMI		 4104 (interactive "P")
4105 (let* ((groups (gnus-group-process-prefix n))
4106 (ret (if (numberp n) (- n (length groups)) 0))
4107 (beg (unless n
4108 (point)))
16409b0b
GM		 4109 group method
4110 (gnus-inhibit-demon t)
4111 ;; Binding this variable will inhibit multiple fetchings
4112 ;; of the same mail source.
4113 (nnmail-fetched-sources (list t)))
4114 (gnus-run-hooks 'gnus-get-new-news-hook)
eec82323
LMI		 4115 (while (setq group (pop groups))
4116 (gnus-group-remove-mark group)
4117 ;; Bypass any previous denials from the server.
6748645f 4118 (gnus-remove-denial (setq method (gnus-find-method-for-group group)))
01c52d31
MB		 4119 (if (gnus-activate-group group (if dont-scan nil 'scan) nil method)
4120 (let ((info (gnus-get-info group))
4121 (active (gnus-active group)))
4122 (when info
4123 (gnus-request-update-info info method))
4124 (gnus-get-unread-articles-in-group info active)
eec82323
LMI		 4125 (unless (gnus-virtual-group-p group)
4126 (gnus-close-group group))
16409b0b
GM		 4127 (when gnus-agent
4128 (gnus-agent-save-group-info
01c52d31 4129 method (gnus-group-real-name group) active))
eec82323
LMI		 4130 (gnus-group-update-group group))
4131 (if (eq (gnus-server-status (gnus-find-method-for-group group))
4132 'denied)
4133 (gnus-error 3 "Server denied access")
4134 (gnus-error 3 "%s error: %s" group (gnus-status-message group)))))
4135 (when beg
4136 (goto-char beg))
4137 (when gnus-goto-next-group-when-activating
4138 (gnus-group-next-unread-group 1 t))
4139 (gnus-summary-position-point)
4140 ret))
4141
4142(defun gnus-group-fetch-faq (group &optional faq-dir)
4143 "Fetch the FAQ for the current group.
4144If given a prefix argument, prompt for the FAQ dir
4145to use."
4146 (interactive
4147 (list
4148 (gnus-group-group-name)
a8151ef7
LMI		 4149 (when current-prefix-arg
4150 (completing-read
8f688cb0 4151 "FAQ dir: " (and (listp gnus-group-faq-directory)
c6e7b580 4152 (mapcar #'list
a8151ef7 4153 gnus-group-faq-directory))))))
eec82323
LMI		 4154 (unless group
4155 (error "No group name given"))
4156 (let ((dirs (or faq-dir gnus-group-faq-directory))
4157 dir found file)
4158 (unless (listp dirs)
4159 (setq dirs (list dirs)))
4160 (while (and (not found)
4161 (setq dir (pop dirs)))
6748645f 4162 (let ((name (gnus-group-real-name group)))
c6e7b580 4163 (setq file (expand-file-name name dir)))
eec82323
LMI		 4164 (if (not (file-exists-p file))
4165 (gnus-message 1 "No such file: %s" file)
4166 (let ((enable-local-variables nil))
4167 (find-file file)
4168 (setq found t))))))
4169
23f87bed
MB		 4170(defun gnus-group-fetch-charter (group)
4171 "Fetch the charter for the current group.
4172If given a prefix argument, prompt for a group."
4173 (interactive
4174 (list (or (when current-prefix-arg
01c52d31 4175 (gnus-group-completing-read "Group: "))
23f87bed
MB		 4176 (gnus-group-group-name)
4177 gnus-newsgroup-name)))
4178 (unless group
4179 (error "No group name given"))
4180 (require 'mm-url)
4181 (condition-case nil (require 'url-http) (error nil))
4182 (let ((name (mm-url-form-encode-xwfu (gnus-group-real-name group)))
4183 url hierarchy)
4184 (when (string-match "\\(^[^\\.]+\\)\\..*" name)
4185 (setq hierarchy (match-string 1 name))
4186 (if (and (setq url (cdr (assoc hierarchy gnus-group-charter-alist)))
4187 (if (fboundp 'url-http-file-exists-p)
4188 (url-http-file-exists-p (eval url))
4189 t))
4190 (browse-url (eval url))
4191 (setq url (concat "http://" hierarchy
4192 ".news-admin.org/charters/" name))
4193 (if (and (fboundp 'url-http-file-exists-p)
4194 (url-http-file-exists-p url))
4195 (browse-url url)
4196 (gnus-group-fetch-control group))))))
4197
4198(defun gnus-group-fetch-control (group)
4199 "Fetch the archived control messages for the current group.
4200If given a prefix argument, prompt for a group."
4201 (interactive
4202 (list (or (when current-prefix-arg
01c52d31 4203 (gnus-group-completing-read "Group: "))
23f87bed
MB		 4204 (gnus-group-group-name)
4205 gnus-newsgroup-name)))
4206 (unless group
4207 (error "No group name given"))
4208 (let ((name (gnus-group-real-name group))
4209 hierarchy)
4210 (when (string-match "\\(^[^\\.]+\\)\\..*" name)
4211 (setq hierarchy (match-string 1 name))
4212 (if gnus-group-fetch-control-use-browse-url
4213 (browse-url (concat "ftp://ftp.isc.org/usenet/control/"
4214 hierarchy "/" name ".gz"))
4215 (let ((enable-local-variables nil))
4216 (gnus-group-read-ephemeral-group
4217 group
4218 `(nndoc ,group (nndoc-address
4219 ,(find-file-noselect
4220 (concat "/ftp@ftp.isc.org:/usenet/control/"
4221 hierarchy "/" name ".gz")))
4222 (nndoc-article-type mbox)) t nil nil))))))
4223
eec82323
LMI		 4224(defun gnus-group-describe-group (force &optional group)
4225 "Display a description of the current newsgroup."
4226 (interactive (list current-prefix-arg (gnus-group-group-name)))
4227 (let* ((method (gnus-find-method-for-group group))
4228 (mname (gnus-group-prefixed-name "" method))
4229 desc)
4230 (when (and force
4231 gnus-description-hashtb)
4232 (gnus-sethash mname nil gnus-description-hashtb))
4233 (unless group
4234 (error "No group name given"))
4235 (when (or (and gnus-description-hashtb
4236 ;; We check whether this group's method has been
4237 ;; queried for a description file.
4238 (gnus-gethash mname gnus-description-hashtb))
4239 (setq desc (gnus-group-get-description group))
4240 (gnus-read-descriptions-file method))
4241 (gnus-message 1
4242 (or desc (gnus-gethash group gnus-description-hashtb)
4243 "No description available")))))
4244
4245;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
4246(defun gnus-group-describe-all-groups (&optional force)
4247 "Pop up a buffer with descriptions of all newsgroups."
4248 (interactive "P")
4249 (when force
4250 (setq gnus-description-hashtb nil))
4251 (when (not (or gnus-description-hashtb
4252 (gnus-read-all-descriptions-files)))
4253 (error "Couldn't request descriptions file"))
4254 (let ((buffer-read-only nil)
4255 b)
4256 (erase-buffer)
4257 (mapatoms
4258 (lambda (group)
4259 (setq b (point))
16409b0b 4260 (let ((charset (gnus-group-name-charset nil (symbol-name group))))
a1506d29 4261 (insert (format " *: %-20s %s\n"
16409b0b
GM		 4262 (gnus-group-name-decode
4263 (symbol-name group) charset)
4264 (gnus-group-name-decode
4265 (symbol-value group) charset))))
eec82323
LMI		 4266 (gnus-add-text-properties
4267 b (1+ b) (list 'gnus-group group
4268 'gnus-unread t 'gnus-marked nil
4269 'gnus-level (1+ gnus-level-subscribed))))
4270 gnus-description-hashtb)
4271 (goto-char (point-min))
4272 (gnus-group-position-point)))
4273
4274;; Suggested by Daniel Quinlan <quinlan@best.com>.
4275(defun gnus-group-apropos (regexp &optional search-description)
4276 "List all newsgroups that have names that match a regexp."
4277 (interactive "sGnus apropos (regexp): ")
4278 (let ((prev "")
4279 (obuf (current-buffer))
4280 groups des)
4281 ;; Go through all newsgroups that are known to Gnus.
4282 (mapatoms
4283 (lambda (group)
4284 (and (symbol-name group)
4285 (string-match regexp (symbol-name group))
6748645f 4286 (symbol-value group)
eec82323
LMI		 4287 (push (symbol-name group) groups)))
4288 gnus-active-hashtb)
4289 ;; Also go through all descriptions that are known to Gnus.
4290 (when search-description
4291 (mapatoms
4292 (lambda (group)
4293 (and (string-match regexp (symbol-value group))
eec82323
LMI		 4294 (push (symbol-name group) groups)))
4295 gnus-description-hashtb))
4296 (if (not groups)
4297 (gnus-message 3 "No groups matched \"%s\"." regexp)
4298 ;; Print out all the groups.
4299 (save-excursion
4300 (pop-to-buffer "*Gnus Help*")
16409b0b 4301 (buffer-disable-undo)
eec82323
LMI		 4302 (erase-buffer)
4303 (setq groups (sort groups 'string<))
4304 (while groups
4305 ;; Groups may be entered twice into the list of groups.
4306 (when (not (string= (car groups) prev))
16409b0b
GM		 4307 (setq prev (car groups))
4308 (let ((charset (gnus-group-name-charset nil prev)))
4309 (insert (gnus-group-name-decode prev charset) "\n")
4310 (when (and gnus-description-hashtb
4311 (setq des (gnus-gethash (car groups)
4312 gnus-description-hashtb)))
4313 (insert " " (gnus-group-name-decode des charset) "\n"))))
eec82323
LMI		 4314 (setq groups (cdr groups)))
4315 (goto-char (point-min))))
4316 (pop-to-buffer obuf)))
4317
4318(defun gnus-group-description-apropos (regexp)
23f87bed 4319 "List all newsgroups that have names or descriptions that match REGEXP."
eec82323
LMI		 4320 (interactive "sGnus description apropos (regexp): ")
4321 (when (not (or gnus-description-hashtb
4322 (gnus-read-all-descriptions-files)))
4323 (error "Couldn't request descriptions file"))
4324 (gnus-group-apropos regexp t))
4325
4326;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
4327(defun gnus-group-list-matching (level regexp &optional all lowest)
4328 "List all groups with unread articles that match REGEXP.
4329If the prefix LEVEL is non-nil, it should be a number that says which
4330level to cut off listing groups.
4331If ALL, also list groups with no unread articles.
4332If LOWEST, don't list groups with level lower than LOWEST.
4333
4334This command may read the active file."
4335 (interactive "P\nsList newsgroups matching: ")
4336 ;; First make sure active file has been read.
4337 (when (and level
4338 (> (prefix-numeric-value level) gnus-level-killed))
4339 (gnus-get-killed-groups))
23f87bed
MB		 4340 (funcall gnus-group-prepare-function
4341 (or level gnus-level-subscribed) (and all t) (or lowest 1) regexp)
eec82323
LMI		 4342 (goto-char (point-min))
4343 (gnus-group-position-point))
4344
4345(defun gnus-group-list-all-matching (level regexp &optional lowest)
4346 "List all groups that match REGEXP.
4347If the prefix LEVEL is non-nil, it should be a number that says which
4348level to cut off listing groups.
4349If LOWEST, don't list groups with level lower than LOWEST."
4350 (interactive "P\nsList newsgroups matching: ")
4351 (when level
4352 (setq level (prefix-numeric-value level)))
4353 (gnus-group-list-matching (or level gnus-level-killed) regexp t lowest))
4354
4355;; Suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>.
4356(defun gnus-group-save-newsrc (&optional force)
4357 "Save the Gnus startup files.
4358If FORCE, force saving whether it is necessary or not."
4359 (interactive "P")
4360 (gnus-save-newsrc-file force))
4361
4362(defun gnus-group-restart (&optional arg)
4363 "Force Gnus to read the .newsrc file."
4364 (interactive "P")
4365 (when (gnus-yes-or-no-p
4366 (format "Are you sure you want to restart Gnus? "))
4367 (gnus-save-newsrc-file)
4368 (gnus-clear-system)
4369 (gnus)))
4370
4371(defun gnus-group-read-init-file ()
4372 "Read the Gnus elisp init file."
4373 (interactive)
a8151ef7
LMI		 4374 (gnus-read-init-file)
4375 (gnus-message 5 "Read %s" gnus-init-file))
eec82323
LMI		 4376
4377(defun gnus-group-check-bogus-groups (&optional silent)
4378 "Check bogus newsgroups.
4379If given a prefix, don't ask for confirmation before removing a bogus
4380group."
4381 (interactive "P")
4382 (gnus-check-bogus-newsgroups (and (not silent) (not gnus-expert-user)))
4383 (gnus-group-list-groups))
4384
a8151ef7
LMI		 4385(defun gnus-group-find-new-groups (&optional arg)
4386 "Search for new groups and add them.
54cf8092 4387Each new group will be treated with `gnus-subscribe-newsgroup-method'.
6748645f
LMI		 4388With 1 C-u, use the `ask-server' method to query the server for new
4389groups.
4390With 2 C-u's, use most complete method possible to query the server
4391for new groups, and subscribe the new groups as zombies."
4392 (interactive "p")
4393 (gnus-find-new-newsgroups (or arg 1))
a8151ef7 4394 (gnus-group-list-groups))
6748645f 4395
eec82323
LMI		 4396(defun gnus-group-edit-global-kill (&optional article group)
4397 "Edit the global kill file.
4398If GROUP, edit that local kill file instead."
4399 (interactive "P")
4400 (setq gnus-current-kill-article article)
4401 (gnus-kill-file-edit-file group)
4402 (gnus-message
4403 6
4404 (substitute-command-keys
4405 (format "Editing a %s kill file (Type \\[gnus-kill-file-exit] to exit)"
4406 (if group "local" "global")))))
4407
4408(defun gnus-group-edit-local-kill (article group)
4409 "Edit a local kill file."
4410 (interactive (list nil (gnus-group-group-name)))
4411 (gnus-group-edit-global-kill article group))
4412
4413(defun gnus-group-force-update ()
4414 "Update `.newsrc' file."
4415 (interactive)
4416 (gnus-save-newsrc-file))
4417
23f87bed
MB		 4418(defvar gnus-backlog-articles)
4419
eec82323
LMI		 4420(defun gnus-group-suspend ()
4421 "Suspend the current Gnus session.
4422In fact, cleanup buffers except for group mode buffer.
23f87bed 4423The hook `gnus-suspend-gnus-hook' is called before actually suspending."
eec82323 4424 (interactive)
6748645f 4425 (gnus-run-hooks 'gnus-suspend-gnus-hook)
23f87bed 4426 (gnus-offer-save-summaries)
eec82323 4427 ;; Kill Gnus buffers except for group mode buffer.
6748645f 4428 (let ((group-buf (get-buffer gnus-group-buffer)))
01c52d31
MB		 4429 (dolist (buf (gnus-buffers))
4430 (unless (or (eq buf group-buf)
4431 (eq buf gnus-dribble-buffer)
4432 (with-current-buffer buf
4433 (eq major-mode 'message-mode)))
4434 (gnus-kill-buffer buf)))
23f87bed 4435 (setq gnus-backlog-articles nil)
eec82323
LMI		 4436 (gnus-kill-gnus-frames)
4437 (when group-buf
eec82323
LMI		 4438 (bury-buffer group-buf)
4439 (delete-windows-on group-buf t))))
4440
4441(defun gnus-group-clear-dribble ()
4442 "Clear all information from the dribble buffer."
4443 (interactive)
4444 (gnus-dribble-clear)
4445 (gnus-message 7 "Cleared dribble buffer"))
4446
4447(defun gnus-group-exit ()
4448 "Quit reading news after updating .newsrc.eld and .newsrc.
4449The hook `gnus-exit-gnus-hook' is called before actually exiting."
4450 (interactive)
4451 (when
4452 (or noninteractive ;For gnus-batch-kill
4453 (not gnus-interactive-exit) ;Without confirmation
4454 gnus-expert-user
4455 (gnus-y-or-n-p "Are you sure you want to quit reading news? "))
6748645f 4456 (gnus-run-hooks 'gnus-exit-gnus-hook)
eec82323
LMI		 4457 ;; Offer to save data from non-quitted summary buffers.
4458 (gnus-offer-save-summaries)
4459 ;; Save the newsrc file(s).
4460 (gnus-save-newsrc-file)
4461 ;; Kill-em-all.
4462 (gnus-close-backends)
4463 ;; Reset everything.
4464 (gnus-clear-system)
4465 ;; Allow the user to do things after cleaning up.
6748645f 4466 (gnus-run-hooks 'gnus-after-exiting-gnus-hook)))
eec82323
LMI		 4467
4468(defun gnus-group-quit ()
4469 "Quit reading news without updating .newsrc.eld or .newsrc.
4470The hook `gnus-exit-gnus-hook' is called before actually exiting."
4471 (interactive)
4472 (when (or noninteractive ;For gnus-batch-kill
4473 (zerop (buffer-size))
4474 (not (gnus-server-opened gnus-select-method))
4475 gnus-expert-user
4476 (not gnus-current-startup-file)
4477 (gnus-yes-or-no-p
4478 (format "Quit reading news without saving %s? "
4479 (file-name-nondirectory gnus-current-startup-file))))
6748645f 4480 (gnus-run-hooks 'gnus-exit-gnus-hook)
eec82323 4481 (gnus-configure-windows 'group t)
23f87bed
MB		 4482 (when (and (gnus-buffer-live-p gnus-dribble-buffer)
4483 (not (zerop (save-excursion
4484 (set-buffer gnus-dribble-buffer)
4485 (buffer-size)))))
4486 (gnus-dribble-enter
4487 ";;; Gnus was exited on purpose without saving the .newsrc files."))
eec82323
LMI		 4488 (gnus-dribble-save)
4489 (gnus-close-backends)
4490 (gnus-clear-system)
4491 (gnus-kill-buffer gnus-group-buffer)
4492 ;; Allow the user to do things after cleaning up.
6748645f 4493 (gnus-run-hooks 'gnus-after-exiting-gnus-hook)))
eec82323
LMI		 4494
4495(defun gnus-group-describe-briefly ()
4496 "Give a one line description of the group mode commands."
4497 (interactive)
4498 (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")))
4499
4500(defun gnus-group-browse-foreign-server (method)
4501 "Browse a foreign news server.
4502If called interactively, this function will ask for a select method
4503 (nntp, nnspool, etc.) and a server address (eg. nntp.some.where).
4504If not, METHOD should be a list where the first element is the method
4505and the second element is the address."
4506 (interactive
4507 (list (let ((how (completing-read
23f87bed 4508 "Which back end: "
eec82323
LMI		 4509 (append gnus-valid-select-methods gnus-server-alist)
4510 nil t (cons "nntp" 0) 'gnus-method-history)))
23f87bed 4511 ;; We either got a back end name or a virtual server name.
eec82323
LMI		 4512 ;; If the first, we also need an address.
4513 (if (assoc how gnus-valid-select-methods)
4514 (list (intern how)
4515 ;; Suggested by mapjph@bath.ac.uk.
4516 (completing-read
4517 "Address: "
01c52d31 4518 (mapcar 'list gnus-secondary-servers)))
eec82323
LMI		 4519 ;; We got a server name.
4520 how))))
4521 (gnus-browse-foreign-server method))
4522
4523(defun gnus-group-set-info (info &optional method-only-group part)
16409b0b 4524 (when (or info part)
01c52d31
MB		 4525 (let* ((entry (gnus-group-entry
4526 (or method-only-group (gnus-info-group info))))
16409b0b
GM		 4527 (part-info info)
4528 (info (if method-only-group (nth 2 entry) info))
4529 method)
4530 (when method-only-group
4531 (unless entry
4532 (error "Trying to change non-existent group %s" method-only-group))
4533 ;; We have received parts of the actual group info - either the
c30ba437 4534 ;; select method or the group parameters. We first check
16409b0b
GM		 4535 ;; whether we have to extend the info, and if so, do that.
4536 (let ((len (length info))
4537 (total (if (eq part 'method) 5 6)))
4538 (when (< len total)
4539 (setcdr (nthcdr (1- len) info)
4540 (make-list (- total len) nil)))
4541 ;; Then we enter the new info.
4542 (setcar (nthcdr (1- total) info) part-info)))
eec82323 4543 (unless entry
16409b0b 4544 ;; This is a new group, so we just create it.
eec82323
LMI		 4545 (save-excursion
4546 (set-buffer gnus-group-buffer)
16409b0b
GM		 4547 (setq method (gnus-info-method info))
4548 (when (gnus-server-equal method "native")
4549 (setq method nil))
4550 (save-excursion
4551 (set-buffer gnus-group-buffer)
4552 (if method
4553 ;; It's a foreign group...
4554 (gnus-group-make-group
4555 (gnus-group-real-name (gnus-info-group info))
4556 (if (stringp method) method
4557 (prin1-to-string (car method)))
4558 (and (consp method)
01c52d31
MB		 4559 (nth 1 (gnus-info-method info)))
4560 nil t)
16409b0b 4561 ;; It's a native group.
01c52d31 4562 (gnus-group-make-group (gnus-info-group info) nil nil nil t)))
16409b0b
GM		 4563 (gnus-message 6 "Note: New group created")
4564 (setq entry
01c52d31
MB		 4565 (gnus-group-entry (gnus-group-prefixed-name
4566 (gnus-group-real-name (gnus-info-group info))
4567 (or (gnus-info-method info) gnus-select-method))))))
16409b0b
GM		 4568 ;; Whether it was a new group or not, we now have the entry, so we
4569 ;; can do the update.
4570 (if entry
4571 (progn
4572 (setcar (nthcdr 2 entry) info)
4573 (when (and (not (eq (car entry) t))
4574 (gnus-active (gnus-info-group info)))
23f87bed
MB		 4575 (setcar entry (length
4576 (gnus-list-of-unread-articles (car info))))))
16409b0b 4577 (error "No such group: %s" (gnus-info-group info))))))
eec82323
LMI		 4578
4579(defun gnus-group-set-method-info (group select-method)
4580 (gnus-group-set-info select-method group 'method))
4581
4582(defun gnus-group-set-params-info (group params)
4583 (gnus-group-set-info params group 'params))
4584
4585(defun gnus-add-marked-articles (group type articles &optional info force)
4586 ;; Add ARTICLES of TYPE to the info of GROUP.
16409b0b 4587 ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't
eec82323
LMI		 4588 ;; add, but replace marked articles of TYPE with ARTICLES.
4589 (let ((info (or info (gnus-get-info group)))
eec82323
LMI		 4590 marked m)
4591 (or (not info)
4592 (and (not (setq marked (nthcdr 3 info)))
4593 (or (null articles)
4594 (setcdr (nthcdr 2 info)
4595 (list (list (cons type (gnus-compress-sequence
4596 articles t)))))))
4597 (and (not (setq m (assq type (car marked))))
4598 (or (null articles)
4599 (setcar marked
4600 (cons (cons type (gnus-compress-sequence articles t) )
4601 (car marked)))))
4602 (if force
4603 (if (null articles)
4604 (setcar (nthcdr 3 info)
6748645f 4605 (gnus-delete-alist type (car marked)))
eec82323
LMI		 4606 (setcdr m (gnus-compress-sequence articles t)))
4607 (setcdr m (gnus-compress-sequence
4608 (sort (nconc (gnus-uncompress-range (cdr m))
4609 (copy-sequence articles)) '<) t))))))
4610
23f87bed
MB		 4611(defun gnus-add-mark (group mark article)
4612 "Mark ARTICLE in GROUP with MARK, whether the group is displayed or not."
4613 (let ((buffer (gnus-summary-buffer-name group)))
4614 (if (gnus-buffer-live-p buffer)
4615 (save-excursion
4616 (set-buffer (get-buffer buffer))
4617 (gnus-summary-add-mark article mark))
4618 (gnus-add-marked-articles group (cdr (assq mark gnus-article-mark-lists))
4619 (list article)))))
4620
eec82323
LMI		 4621;;;
4622;;; Group timestamps
4623;;;
4624
4625(defun gnus-group-set-timestamp ()
4626 "Change the timestamp of the current group to the current time.
4627This function can be used in hooks like `gnus-select-group-hook'
4628or `gnus-group-catchup-group-hook'."
4629 (when gnus-newsgroup-name
4630 (let ((time (current-time)))
4631 (setcdr (cdr time) nil)
4632 (gnus-group-set-parameter gnus-newsgroup-name 'timestamp time))))
4633
4634(defsubst gnus-group-timestamp (group)
4635 "Return the timestamp for GROUP."
6748645f 4636 (gnus-group-get-parameter group 'timestamp t))
eec82323
LMI		 4637
4638(defun gnus-group-timestamp-delta (group)
4639 "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number."
4640 (let* ((time (or (gnus-group-timestamp group)
16409b0b 4641 (list 0 0)))
23f87bed 4642 (delta (subtract-time (current-time) time)))
eec82323
LMI		 4643 (+ (* (nth 0 delta) 65536.0)
4644 (nth 1 delta))))
4645
4646(defun gnus-group-timestamp-string (group)
4647 "Return a string of the timestamp for GROUP."
4648 (let ((time (gnus-group-timestamp group)))
4649 (if (not time)
4650 ""
4651 (gnus-time-iso8601 time))))
4652
16409b0b
GM		 4653(defun gnus-group-list-cached (level &optional lowest)
4654 "List all groups with cached articles.
4655If the prefix LEVEL is non-nil, it should be a number that says which
4656level to cut off listing groups.
4657If LOWEST, don't list groups with level lower than LOWEST.
4658
4659This command may read the active file."
4660 (interactive "P")
4661 (when level
4662 (setq level (prefix-numeric-value level)))
4663 (when (or (not level) (>= level gnus-level-zombie))
4664 (gnus-cache-open))
23f87bed
MB		 4665 (funcall gnus-group-prepare-function
4666 (or level gnus-level-subscribed)
4667 #'(lambda (info)
4668 (let ((marks (gnus-info-marks info)))
4669 (assq 'cache marks)))
4670 lowest
4671 #'(lambda (group)
4672 (or (gnus-gethash group
4673 gnus-cache-active-hashtb)
4674 ;; Cache active file might use "."
4675 ;; instead of ":".
4676 (gnus-gethash
4677 (mapconcat 'identity
4678 (split-string group ":")
4679 ".")
4680 gnus-cache-active-hashtb))))
16409b0b
GM		 4681 (goto-char (point-min))
4682 (gnus-group-position-point))
4683
4684(defun gnus-group-list-dormant (level &optional lowest)
4685 "List all groups with dormant articles.
4686If the prefix LEVEL is non-nil, it should be a number that says which
4687level to cut off listing groups.
4688If LOWEST, don't list groups with level lower than LOWEST.
4689
4690This command may read the active file."
4691 (interactive "P")
4692 (when level
4693 (setq level (prefix-numeric-value level)))
4694 (when (or (not level) (>= level gnus-level-zombie))
4695 (gnus-cache-open))
23f87bed
MB		 4696 (funcall gnus-group-prepare-function
4697 (or level gnus-level-subscribed)
4698 #'(lambda (info)
4699 (let ((marks (gnus-info-marks info)))
4700 (assq 'dormant marks)))
4701 lowest
4702 'ignore)
16409b0b
GM		 4703 (goto-char (point-min))
4704 (gnus-group-position-point))
4705
23f87bed
MB		 4706(defun gnus-group-listed-groups ()
4707 "Return a list of listed groups."
4708 (let (point groups)
4709 (goto-char (point-min))
4710 (while (setq point (text-property-not-all (point) (point-max)
4711 'gnus-group nil))
4712 (goto-char point)
4713 (push (symbol-name (get-text-property point 'gnus-group)) groups)
4714 (forward-char 1))
4715 groups))
4716
4717(defun gnus-group-list-plus (&optional args)
4718 "List groups plus the current selection."
4719 (interactive "P")
4720 (let ((gnus-group-listed-groups (gnus-group-listed-groups))
4721 (gnus-group-list-mode gnus-group-list-mode) ;; Save it.
4722 func)
4723 (push last-command-event unread-command-events)
4724 (if (featurep 'xemacs)
4725 (push (make-event 'key-press '(key ?A)) unread-command-events)
4726 (push ?A unread-command-events))
4727 (let (gnus-pick-mode keys)
4728 (setq keys (if (featurep 'xemacs)
4729 (events-to-keys (read-key-sequence nil))
4730 (read-key-sequence nil)))
4731 (setq func (lookup-key (current-local-map) keys)))
4732 (if (or (not func)
4733 (numberp func))
4734 (ding)
4735 (call-interactively func))))
4736
4737(defun gnus-group-list-flush (&optional args)
4738 "Flush groups from the current selection."
4739 (interactive "P")
4740 (let ((gnus-group-list-option 'flush))
4741 (gnus-group-list-plus args)))
4742
4743(defun gnus-group-list-limit (&optional args)
4744 "List groups limited within the current selection."
4745 (interactive "P")
4746 (let ((gnus-group-list-option 'limit))
4747 (gnus-group-list-plus args)))
4748
4749(defun gnus-group-mark-article-read (group article)
4750 "Mark ARTICLE read."
4751 (let ((buffer (gnus-summary-buffer-name group))
4752 (mark gnus-read-mark)
4753 active n)
4754 (if (get-buffer buffer)
4755 (with-current-buffer buffer
4756 (setq active gnus-newsgroup-active)
4757 (gnus-activate-group group)
4758 (when gnus-newsgroup-prepared
4759 (when (and gnus-newsgroup-auto-expire
4760 (memq mark gnus-auto-expirable-marks))
4761 (setq mark gnus-expirable-mark))
4762 (setq mark (gnus-request-update-mark
4763 group article mark))
4764 (gnus-mark-article-as-read article mark)
4765 (setq gnus-newsgroup-active (gnus-active group))
4766 (when active
4767 (setq n (1+ (cdr active)))
4768 (while (<= n (cdr gnus-newsgroup-active))
4769 (unless (eq n article)
4770 (push n gnus-newsgroup-unselected))
4771 (setq n (1+ n)))
4772 (setq gnus-newsgroup-unselected
4773 (nreverse gnus-newsgroup-unselected)))))
4774 (gnus-activate-group group)
4775 (gnus-group-make-articles-read group (list article))
4776 (when (gnus-group-auto-expirable-p group)
4777 (gnus-add-marked-articles
4778 group 'expire (list article))))))
4779
01c52d31
MB		 4780
4781;;;
4782;;; Group compaction. -- dvl
4783;;;
4784
4785(defun gnus-group-compact-group (group)
4786 "Compact the current group.
4787Compaction means removing gaps between article numbers. Hence, this
4788operation is only meaningful for back ends using one file per article
4789\(e.g. nnml).
4790
4791Note: currently only implemented in nnml."
4792 (interactive (list (gnus-group-group-name)))
4793 (unless group
4794 (error "No group to compact"))
4795 (unless (gnus-check-backend-function 'request-compact-group group)
4796 (error "This back end does not support group compaction"))
4797 (let ((group-decoded (gnus-group-decoded-name group)))
4798 (gnus-message 6 "\
4799Compacting group %s... (this may take a long time)"
4800 group-decoded)
4801 (prog1
4802 (if (not (gnus-request-compact-group group))
4803 (gnus-error 3 "Couldn't compact group %s" group-decoded)
4804 (gnus-message 6 "Compacting group %s...done" group-decoded)
4805 t)
4806 ;; Invalidate the "original article" buffer which might be out of date.
4807 ;; #### NOTE: Yes, this might be a bit rude, but since compaction
4808 ;; #### will not happen very often, I think this is acceptable.
4809 (let ((original (get-buffer gnus-original-article-buffer)))
4810 (and original (gnus-kill-buffer original)))
4811 ;; Update the group line to reflect new information (art number etc).
4812 (gnus-group-update-group-line))))
4813
eec82323
LMI		 4814(provide 'gnus-group)
4815
dacb905a 4816;; arch-tag: 2eb5440f-0bca-4091-814c-e37817536af6
eec82323 4817;;; gnus-group.el ends here
Unnamed repository; edit this file 'description' to name the repository.