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